diff options
Diffstat (limited to 'src/Reflection')
121 files changed, 0 insertions, 16165 deletions
diff --git a/src/Reflection/BoundByCast.v b/src/Reflection/BoundByCast.v deleted file mode 100644 index d65e67919..000000000 --- a/src/Reflection/BoundByCast.v +++ /dev/null @@ -1,48 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.SmartBound. -Require Import Crypto.Reflection.InlineCast. -Require Import Crypto.Reflection.ExprInversion. -Require Import Crypto.Reflection.Inline. -Require Import Crypto.Reflection.Linearize. -Require Import Crypto.Reflection.MapCast. -Require Import Crypto.Reflection.Eta. - -Local Open Scope expr_scope. -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - (interp_base_type_bounds : base_type_code -> Type) - (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst) - (bound_base_type : forall t, interp_base_type_bounds t -> base_type_code) - (base_type_beq : base_type_code -> base_type_code -> bool) - (base_type_bl_transparent : forall x y, base_type_beq x y = true -> x = y) - (base_type_leb : base_type_code -> base_type_code -> bool) - (Cast : forall var A A', exprf base_type_code op (var:=var) (Tbase A) -> exprf base_type_code op (var:=var) (Tbase A')) - (is_cast : forall src dst, op src dst -> bool) - (is_const : forall src dst, op src dst -> bool) - (genericize_op : forall src dst (opc : op src dst) (new_bounded_type_in new_bounded_type_out : base_type_code), - option { src'dst' : _ & op (fst src'dst') (snd src'dst') }) - (failf : forall var t, @exprf base_type_code op var (Tbase t)). - - Local Notation Expr := (@Expr base_type_code op). - - Definition Boundify {t1} (e1 : Expr t1) args2 - : Expr _ - := ExprEta - (InlineCast - _ base_type_bl_transparent base_type_leb Cast is_cast is_const - (Linearize - (SmartBound - _ - interp_op_bounds - bound_base_type - Cast - (@MapInterpCast - base_type_code interp_base_type_bounds - op (@interp_op_bounds) - (@failf) - (@bound_op _ _ _ interp_op_bounds bound_base_type _ base_type_bl_transparent base_type_leb Cast genericize_op) - t1 e1 args2) - args2))). -End language. diff --git a/src/Reflection/BoundByCastInterp.v b/src/Reflection/BoundByCastInterp.v deleted file mode 100644 index 46a50fd42..000000000 --- a/src/Reflection/BoundByCastInterp.v +++ /dev/null @@ -1,117 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.InterpWfRel. -Require Import Crypto.Reflection.TypeUtil. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.BoundByCast. -Require Import Crypto.Reflection.SmartBound. -Require Import Crypto.Reflection.SmartBoundInterp. -Require Import Crypto.Reflection.SmartBoundWf. -Require Import Crypto.Reflection.InlineCastInterp. -Require Import Crypto.Reflection.ExprInversion. -Require Import Crypto.Reflection.InlineInterp. -Require Import Crypto.Reflection.LinearizeInterp. -Require Import Crypto.Reflection.LinearizeWf. -Require Import Crypto.Reflection.MapCastInterp. -Require Import Crypto.Reflection.MapCastWf. -Require Import Crypto.Reflection.EtaInterp. - -Local Open Scope expr_scope. -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - (interp_base_type interp_base_type_bounds : base_type_code -> Type) - (interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst) - (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst) - (bound_base_type : forall t, interp_base_type_bounds t -> base_type_code) - (base_type_beq : base_type_code -> base_type_code -> bool) - (base_type_bl_transparent : forall x y, base_type_beq x y = true -> x = y) - (base_type_leb : base_type_code -> base_type_code -> bool) - (Cast : forall var A A', exprf base_type_code op (var:=var) (Tbase A) -> exprf base_type_code op (var:=var) (Tbase A')) - (cast_val : forall A A', interp_base_type A -> interp_base_type A') - (is_cast : forall src dst, op src dst -> bool) - (is_const : forall src dst, op src dst -> bool) - (genericize_op : forall src dst (opc : op src dst) (new_bounded_type_in new_bounded_type_out : base_type_code), - option { src'dst' : _ & op (fst src'dst') (snd src'dst') }) - (failf : forall var t, @exprf base_type_code op var (Tbase t)) - (bound_is_good : forall t, interp_base_type_bounds t -> Prop) - (is_bounded_by_base : forall t, interp_base_type t -> interp_base_type_bounds t -> Prop) - (interpf_Cast_id : forall A x, interpf interp_op (Cast _ A A x) = interpf interp_op x) - (interpf_cast : forall A A' e, interpf interp_op (Cast _ A A' e) = cast_val A A' (interpf interp_op e)) - (cast_val_squash : forall a b c v, - base_type_min base_type_leb b (base_type_min base_type_leb a c) = base_type_min base_type_leb a c - -> cast_val b c (cast_val a b v) = cast_val a c v) - (is_cast_correct : forall s d opc e, is_cast (Tbase s) (Tbase d) opc = true - -> interp_op _ _ opc (interpf interp_op e) - = interpf interp_op (Cast _ s d e)) - (wff_Cast : forall var1 var2 G A A' e1 e2, - wff G e1 e2 -> wff G (Cast var1 A A' e1) (Cast var2 A A' e2)) - (strip_cast_val - : forall t x y, - is_bounded_by_base t y x -> - cast_val (bound_base_type t x) t (cast_val t (bound_base_type t x) y) = y). - Local Notation is_bounded_by (*{T} : interp_flat_type interp_base_type T -> interp_flat_type interp_base_type_bounds T -> Prop*) - := (interp_flat_type_rel_pointwise is_bounded_by_base). - Context (is_bounded_by_interp_op - : forall src dst opc sv1 sv2, - is_bounded_by sv1 sv2 -> - is_bounded_by (interp_op src dst opc sv1) (interp_op_bounds src dst opc sv2)). - Local Notation bounds_are_good - := (@interp_flat_type_rel_pointwise1 _ _ bound_is_good). - Local Notation bound_op := (@bound_op _ _ _ interp_op_bounds bound_base_type _ base_type_bl_transparent base_type_leb Cast genericize_op). - Local Notation G_invariant_holds G - := (forall t x x', - List.In (existT _ t (x, x')%core) G -> is_bounded_by_base t x x') - (only parsing). - Context (interpf_bound_op - : forall G t tR opc ein eout ebounds, - wff G ein ebounds - -> G_invariant_holds G - -> interpf interp_op ein = interpf interp_op eout - -> bounds_are_recursively_good interp_op_bounds bound_is_good ebounds - -> bounds_are_good (interp_op_bounds t tR opc (interpf interp_op_bounds ebounds)) - -> interpf interp_op (@bound_op interp_base_type t tR t tR opc opc eout (interpf interp_op_bounds ebounds)) - = interpf interp_op (Op opc ein)). - - Context (is_bounded_by_bound_op - : forall G t tR opc ein eout ebounds, - wff G ein ebounds - -> G_invariant_holds G - -> interpf interp_op ein = interpf interp_op eout - -> bounds_are_recursively_good interp_op_bounds bound_is_good ebounds - -> bounds_are_good (interp_op_bounds t tR opc (interpf interp_op_bounds ebounds)) - -> is_bounded_by - (interpf interp_op (@bound_op interp_base_type t tR t tR opc opc eout (interpf interp_op_bounds ebounds))) - (interpf interp_op_bounds (Op opc ebounds))). - - Local Notation Expr := (@Expr base_type_code op). - Local Notation Boundify := (@Boundify _ _ _ interp_op_bounds bound_base_type _ base_type_bl_transparent base_type_leb Cast is_cast is_const genericize_op failf). - Local Notation interpf_smart_unbound := (@interpf_smart_unbound _ interp_base_type_bounds bound_base_type interp_base_type cast_val). - - Lemma InterpBoundifyAndRel {t} - (e : Expr t) - (Hwf : Wf e) - (input_bounds : interp_flat_type interp_base_type_bounds (domain t)) - (output_bounds := Interp interp_op_bounds e input_bounds) - (e' := Boundify e input_bounds) - (Hgood : bounds_are_recursively_good - (@interp_op_bounds) bound_is_good - (invert_Abs (e _) input_bounds)) - : forall x, - is_bounded_by (interpf_smart_unbound input_bounds x) input_bounds - -> is_bounded_by (Interp interp_op e (interpf_smart_unbound input_bounds x)) output_bounds - /\ interpf_smart_unbound _ (Interp interp_op e' x) - = Interp interp_op e (interpf_smart_unbound input_bounds x). - Proof using cast_val_squash interpf_Cast_id interpf_bound_op interpf_cast is_bounded_by_bound_op is_bounded_by_interp_op is_cast_correct strip_cast_val wff_Cast. - intros; subst e' output_bounds. - unfold Boundify. - erewrite InterpExprEta, InterpInlineCast, InterpLinearize by eauto with wf. - match goal with |- ?A /\ ?B => cut (A /\ (A -> B)); [ tauto | ] end. - split. - { apply interp_wf; auto. } - { intro Hbounded_out. - erewrite InterpSmartBound, InterpMapInterpCast by eauto with wf. - reflexivity. } - Qed. -End language. diff --git a/src/Reflection/BoundByCastWf.v b/src/Reflection/BoundByCastWf.v deleted file mode 100644 index cc60f14b1..000000000 --- a/src/Reflection/BoundByCastWf.v +++ /dev/null @@ -1,47 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.BoundByCast. -Require Import Crypto.Reflection.EtaWf. -Require Import Crypto.Reflection.InlineCastWf. -Require Import Crypto.Reflection.LinearizeWf. -Require Import Crypto.Reflection.SmartBoundWf. -Require Import Crypto.Reflection.MapCastWf. - -Local Open Scope expr_scope. -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - (interp_base_type_bounds : base_type_code -> Type) - (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst) - (bound_base_type : forall t, interp_base_type_bounds t -> base_type_code) - (base_type_beq : base_type_code -> base_type_code -> bool) - (base_type_bl_transparent : forall x y, base_type_beq x y = true -> x = y) - (base_type_leb : base_type_code -> base_type_code -> bool) - (Cast : forall var A A', exprf base_type_code op (var:=var) (Tbase A) -> exprf base_type_code op (var:=var) (Tbase A')) - (is_cast : forall src dst, op src dst -> bool) - (is_const : forall src dst, op src dst -> bool) - (genericize_op : forall src dst (opc : op src dst) (new_bounded_type_in new_bounded_type_out : base_type_code), - option { src'dst' : _ & op (fst src'dst') (snd src'dst') }) - (failf : forall var t, @exprf base_type_code op var (Tbase t)) - (wff_Cast : forall var1 var2 G A A' e1 e2, - wff G e1 e2 -> wff G (Cast var1 A A' e1) (Cast var2 A A' e2)). - - Local Notation Expr := (@Expr base_type_code op). - - Lemma Wf_Boundify {t1} (e1 : Expr t1) args2 - (Hwf : Wf e1) - : Wf (@Boundify - _ op _ interp_op_bounds - bound_base_type - _ base_type_bl_transparent - base_type_leb - Cast - is_cast is_const genericize_op - failf t1 e1 args2). - Proof using wff_Cast. - unfold Boundify; auto 7 with wf. - Qed. -End language. - -Hint Resolve Wf_Boundify : wf. diff --git a/src/Reflection/CommonSubexpressionElimination.v b/src/Reflection/CommonSubexpressionElimination.v deleted file mode 100644 index 6d3921aa6..000000000 --- a/src/Reflection/CommonSubexpressionElimination.v +++ /dev/null @@ -1,191 +0,0 @@ -(** * Common Subexpression Elimination for PHOAS Syntax *) -Require Import Coq.Lists.List. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.SmartMap. -Require Import (*Crypto.Util.Tactics*) Crypto.Util.Bool. - -Local Open Scope list_scope. - -Inductive symbolic_expr {base_type_code op_code} : Type := -| STT -| SVar (v : base_type_code) (n : nat) -| SOp (op : op_code) (args : symbolic_expr) -| SPair (x y : symbolic_expr) -| SInvalid. -Scheme Equality for symbolic_expr. - -Arguments symbolic_expr : clear implicits. - -Ltac inversion_symbolic_expr_step := - match goal with - | [ H : SVar _ _ = SVar _ _ |- _ ] => inversion H; clear H - | [ H : SOp _ _ = SOp _ _ |- _ ] => inversion H; clear H - | [ H : SPair _ _ = SPair _ _ |- _ ] => inversion H; clear H - end. -Ltac inversion_symbolic_expr := repeat inversion_symbolic_expr_step. - -Local Open Scope ctype_scope. -Section symbolic. - (** Holds decidably-equal versions of raw expressions, for lookup. *) - Context (base_type_code : Type) - (op_code : Type) - (base_type_code_beq : base_type_code -> base_type_code -> bool) - (op_code_beq : op_code -> op_code -> bool) - (base_type_code_bl : forall x y, base_type_code_beq x y = true -> x = y) - (base_type_code_lb : forall x y, x = y -> base_type_code_beq x y = true) - (op_code_bl : forall x y, op_code_beq x y = true -> x = y) - (op_code_lb : forall x y, x = y -> op_code_beq x y = true) - (interp_base_type : base_type_code -> Type) - (op : flat_type base_type_code -> flat_type base_type_code -> Type) - (symbolize_op : forall s d, op s d -> op_code). - - Local Notation symbolic_expr := (symbolic_expr base_type_code op_code). - Local Notation symbolic_expr_beq := (@symbolic_expr_beq base_type_code op_code base_type_code_beq op_code_beq). - Local Notation symbolic_expr_lb := (@internal_symbolic_expr_dec_lb base_type_code op_code base_type_code_beq op_code_beq base_type_code_lb op_code_lb). - Local Notation symbolic_expr_bl := (@internal_symbolic_expr_dec_bl base_type_code op_code base_type_code_beq op_code_beq base_type_code_bl op_code_bl). - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation interp_type := (interp_type interp_base_type). - Local Notation interp_flat_type_gen := interp_flat_type. - Local Notation interp_flat_type := (interp_flat_type interp_base_type). - Local Notation exprf := (@exprf base_type_code op). - Local Notation expr := (@expr base_type_code op). - Local Notation Expr := (@Expr base_type_code op). - - - Section with_var. - Context {var : base_type_code -> Type}. - - Local Notation svar t := (var t * symbolic_expr)%type. - Local Notation fsvar := (fun t => svar t). - Local Notation mapping := (forall t : base_type_code, list (svar t))%type. - - Context (prefix : list (sigT (fun t : flat_type => @exprf fsvar t))). - - Definition empty_mapping : mapping := fun _ => nil. - Definition type_lookup t (xs : mapping) : list (svar t) := xs t. - Definition mapping_update_type t (xs : mapping) (upd : list (svar t) -> list (svar t)) - : mapping - := fun t' => (if base_type_code_beq t t' as b return base_type_code_beq t t' = b -> _ - then fun H => match base_type_code_bl _ _ H in (_ = t') return list (svar t') with - | eq_refl => upd (type_lookup t xs) - end - else fun _ => type_lookup t' xs) - eq_refl. - - Fixpoint lookup' {t} (sv : symbolic_expr) (xs : list (svar t)) {struct xs} : option (var t) := - match xs with - | nil => None - | (x, sv') :: xs' => - if symbolic_expr_beq sv' sv - then Some x - else lookup' sv xs' - end. - Definition lookup t (sv : symbolic_expr) (xs : mapping) : option (var t) := - lookup' sv (type_lookup t xs). - Definition symbolicify_var {t : base_type_code} (v : var t) (xs : mapping) : symbolic_expr := - SVar t (length (type_lookup t xs)). - Definition add_mapping {t} (v : var t) (sv : symbolic_expr) (xs : mapping) : mapping := - mapping_update_type t xs (fun ls => (v, sv) :: ls). - - Fixpoint symbolize_exprf - {t} (v : @exprf fsvar t) {struct v} - : option symbolic_expr - := match v with - | TT => Some STT - | Var _ x => Some (snd x) - | Op _ _ op args => option_map - (fun sargs => SOp (symbolize_op _ _ op) sargs) - (@symbolize_exprf _ args) - | LetIn _ ex _ eC => None - | Pair _ ex _ ey => match @symbolize_exprf _ ex, @symbolize_exprf _ ey with - | Some sx, Some sy => Some (SPair sx sy) - | _, _ => None - end - end. - - Fixpoint smart_lookup_gen f (proj : forall t, svar t -> f t) - (t : flat_type) (sv : symbolic_expr) (xs : mapping) {struct t} - : option (interp_flat_type_gen f t) - := match t return option (interp_flat_type_gen f t) with - | Tbase t => option_map (fun v => proj t (v, sv)) (lookup t sv xs) - | Unit => Some tt - | Prod A B => match @smart_lookup_gen f proj A sv xs, @smart_lookup_gen f proj B sv xs with - | Some a, Some b => Some (a, b) - | _, _ => None - end - end. - Definition smart_lookup (t : flat_type) (sv : symbolic_expr) (xs : mapping) : option (interp_flat_type_gen fsvar t) - := @smart_lookup_gen fsvar (fun _ x => x) t sv xs. - Definition smart_lookupo (t : flat_type) (sv : option symbolic_expr) (xs : mapping) : option (interp_flat_type_gen fsvar t) - := match sv with - | Some sv => smart_lookup t sv xs - | None => None - end. - Definition symbolicify_smart_var {t : flat_type} (xs : mapping) (replacement : option symbolic_expr) - : interp_flat_type_gen var t -> interp_flat_type_gen fsvar t - := smart_interp_flat_map - (g:=interp_flat_type_gen fsvar) - (fun t v => (v, - match replacement with - | Some sv => sv - | None => symbolicify_var v xs - end)) - tt - (fun A B => @pair _ _). - Fixpoint smart_add_mapping {t : flat_type} (xs : mapping) : interp_flat_type_gen fsvar t -> mapping - := match t return interp_flat_type_gen fsvar t -> mapping with - | Tbase t => fun v => add_mapping (fst v) (snd v) xs - | Unit => fun _ => xs - | Prod A B - => fun v => let xs := @smart_add_mapping B xs (snd v) in - let xs := @smart_add_mapping A xs (fst v) in - xs - end. - - Definition csef_step - (csef : forall {t} (v : @exprf fsvar t) (xs : mapping), @exprf var t) - {t} (v : @exprf fsvar t) (xs : mapping) - : @exprf var t - := match v in @Syntax.exprf _ _ _ t return exprf t with - | LetIn tx ex _ eC => let sx := symbolize_exprf ex in - let ex' := @csef _ ex xs in - let sv := smart_lookupo tx sx xs in - match sv with - | Some v => @csef _ (eC v) xs - | None - => LetIn ex' (fun x => let x' := symbolicify_smart_var xs sx x in - @csef _ (eC x') (smart_add_mapping xs x')) - end - | TT => TT - | Var _ x => Var (fst x) - | Op _ _ op args => Op op (@csef _ args xs) - | Pair _ ex _ ey => Pair (@csef _ ex xs) (@csef _ ey xs) - end. - - Fixpoint csef {t} (v : @exprf fsvar t) (xs : mapping) - := @csef_step (@csef) t v xs. - - Fixpoint prepend_prefix {t} (e : @exprf fsvar t) (ls : list (sigT (fun t : flat_type => @exprf fsvar t))) - : @exprf fsvar t - := match ls with - | nil => e - | x :: xs => LetIn (projT2 x) (fun _ => @prepend_prefix _ e xs) - end. - - Definition cse {t} (v : @expr fsvar t) (xs : mapping) : @expr var t - := match v in @Syntax.expr _ _ _ t return expr t with - | Abs _ _ f => Abs (fun x => let x' := symbolicify_smart_var xs None x in - csef (prepend_prefix (f x') prefix) (smart_add_mapping xs x')) - end. - End with_var. - - Definition CSE {t} (e : Expr t) (prefix : forall var, list (sigT (fun t : flat_type => @exprf var t))) - : Expr t - := fun var => cse (prefix _) (e _) empty_mapping. -End symbolic. - -Global Arguments csef {_} op_code base_type_code_beq op_code_beq base_type_code_bl {_} symbolize_op {var t} _ _. -Global Arguments cse {_} op_code base_type_code_beq op_code_beq base_type_code_bl {_} symbolize_op {var} prefix {t} _ _. -Global Arguments CSE {_} op_code base_type_code_beq op_code_beq base_type_code_bl {_} symbolize_op {t} e prefix var. diff --git a/src/Reflection/Conversion.v b/src/Reflection/Conversion.v deleted file mode 100644 index bd0f4f695..000000000 --- a/src/Reflection/Conversion.v +++ /dev/null @@ -1,110 +0,0 @@ -(** * Convert between interpretations of types *) -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Map. -Require Import Crypto.Util.Notations. -Require Import Crypto.Util.Tactics.RewriteHyp. - -Local Open Scope expr_scope. - -Section language. - Context (base_type_code : Type). - Context (op : flat_type base_type_code -> flat_type base_type_code -> Type). - Section map. - Context {var1 var2 : base_type_code -> Type}. - Context (f_var12 : forall t, var1 t -> var2 t) - (f_var21 : forall t, var2 t -> var1 t). - - Fixpoint mapf - {t} - (e : @exprf base_type_code op var1 t) - : @exprf base_type_code op var2 t - := match e in @exprf _ _ _ t return @exprf _ _ _ t with - | TT => TT - | Var _ x => Var (f_var12 _ x) - | Op _ _ op args => Op op (@mapf _ args) - | LetIn _ ex _ eC => LetIn (@mapf _ ex) - (fun x => @mapf _ (eC (mapf_interp_flat_type f_var21 x))) - | Pair _ ex _ ey => Pair (@mapf _ ex) - (@mapf _ ey) - end. - - Definition map {t} (e : @expr base_type_code op var1 t) - : @expr base_type_code op var2 t - := match e with - | Abs _ _ f => Abs (fun x => mapf (f (mapf_interp_flat_type f_var21 x))) - end. - End map. - - Section mapf_id. - Context (functional_extensionality : forall {A B} (f g : A -> B), (forall x, f x = g x) -> f = g) - {var : base_type_code -> Type}. - - Lemma mapf_idmap_ext {t} e - : @mapf var var - (fun _ x => x) (fun _ x => x) - t e - = e. - Proof using functional_extensionality. - induction e; - repeat match goal with - | _ => reflexivity - | _ => progress simpl in * - | _ => rewrite_hyp !* - | _ => apply (f_equal2 (fun x f => LetIn x f)) - | _ => solve [ eauto ] - | _ => apply functional_extensionality; intro - end. - clear e IHe H. - revert dependent tC; induction tx; simpl; [ reflexivity | reflexivity | ]; intros. - destruct x as [x0 x1]; simpl in *. - lazymatch goal with - | [ |- ?e0 (?x0', ?x1')%core = _ ] - => rewrite (IHtx1 x0 _ (fun x0'' => e0 (x0'', x1')%core)); cbv beta in * - end. - lazymatch goal with - | [ |- ?e0 (?x0', ?x1')%core = _ ] - => rewrite (IHtx2 x1 _ (fun x1'' => e0 (x0', x1'')%core)); cbv beta in * - end. - reflexivity. - Qed. - End mapf_id. - - Section mapf_id_interp. - Context {interp_base_type : base_type_code -> Type} - (interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst) - (f_var12 f_var21 : forall t, interp_base_type t -> interp_base_type t) - (f_var12_id : forall t x, f_var12 t x = x) - (f_var21_id : forall t x, f_var21 t x = x). - - Lemma mapf_idmap {t} e - : interpf interp_op - (@mapf _ _ - f_var12 f_var21 - t e) - = interpf interp_op e. - Proof using f_var12_id f_var21_id. - induction e; - repeat match goal with - | _ => progress unfold LetIn.Let_In - | _ => reflexivity - | _ => progress simpl in * - | _ => rewrite_hyp !* - | _ => apply (f_equal2 (fun x f => LetIn x f)) - | _ => solve [ eauto ] - end. - clear H IHe. - generalize (interpf interp_op e); intro x; clear e. - revert dependent tC; induction tx; simpl; - [ intros; rewrite_hyp ?*; reflexivity | reflexivity | ]; intros. - destruct x as [x0 x1]; simpl in *. - lazymatch goal with - | [ |- interpf _ (?e0 (?x0', ?x1')%core) = _ ] - => rewrite (IHtx1 x0 _ (fun x0'' => e0 (x0'', x1')%core)); cbv beta in * - end. - lazymatch goal with - | [ |- interpf _ (?e0 (?x0', ?x1')%core) = _ ] - => apply (IHtx2 x1 _ (fun x1'' => e0 (x0', x1'')%core)); cbv beta in * - end. - Qed. - End mapf_id_interp. -End language. diff --git a/src/Reflection/CountLets.v b/src/Reflection/CountLets.v deleted file mode 100644 index 64c46d58a..000000000 --- a/src/Reflection/CountLets.v +++ /dev/null @@ -1,66 +0,0 @@ -(** * Counts how many binders there are *) -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.SmartMap. - -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type}. - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation Expr := (@Expr base_type_code op). - - Fixpoint count_pairs (t : flat_type) : nat - := match t with - | Tbase _ => 1 - | Unit => 0 - | Prod A B => count_pairs A + count_pairs B - end%nat. - - Section with_var. - Context {var : base_type_code -> Type} - (mkVar : forall t, var t). - - Local Notation exprf := (@exprf base_type_code op var). - Local Notation expr := (@expr base_type_code op var). - - Section gen. - Context (count_type_let : flat_type -> nat). - Context (count_type_abs : flat_type -> nat). - - Fixpoint count_lets_genf {t} (e : exprf t) : nat - := match e with - | LetIn tx _ _ eC - => count_type_let tx + @count_lets_genf _ (eC (SmartValf var mkVar tx)) - | Op _ _ _ e => @count_lets_genf _ e - | Pair _ ex _ ey => @count_lets_genf _ ex + @count_lets_genf _ ey - | _ => 0 - end. - Definition count_lets_gen {t} (e : expr t) : nat - := match e with - | Abs tx _ f => count_type_abs tx + @count_lets_genf _ (f (SmartValf _ mkVar tx)) - end. - End gen. - - Definition count_let_bindersf {t} (e : exprf t) : nat - := count_lets_genf count_pairs e. - Definition count_letsf {t} (e : exprf t) : nat - := count_lets_genf (fun _ => 1) e. - Definition count_let_binders {t} (e : expr t) : nat - := count_lets_gen count_pairs (fun _ => 0) e. - Definition count_lets {t} (e : expr t) : nat - := count_lets_gen (fun _ => 1) (fun _ => 0) e. - Definition count_binders {t} (e : expr t) : nat - := count_lets_gen count_pairs count_pairs e. - End with_var. - - Definition CountLetsGen (count_type_let : flat_type -> nat) (count_type_abs : flat_type -> nat) {t} (e : Expr t) : nat - := count_lets_gen (fun _ => tt) count_type_let count_type_abs (e _). - Definition CountLetBinders {t} (e : Expr t) : nat - := count_let_binders (fun _ => tt) (e _). - Definition CountLets {t} (e : Expr t) : nat - := count_lets (fun _ => tt) (e _). - Definition CountBinders {t} (e : Expr t) : nat - := count_binders (fun _ => tt) (e _). -End language. diff --git a/src/Reflection/Equality.v b/src/Reflection/Equality.v deleted file mode 100644 index ad642fe2d..000000000 --- a/src/Reflection/Equality.v +++ /dev/null @@ -1,90 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Util.Decidable. -Require Import Crypto.Util.FixCoqMistakes. - -Section language. - Context (base_type_code : Type) - (eq_base_type_code : base_type_code -> base_type_code -> bool) - (base_type_code_bl : forall x y, eq_base_type_code x y = true -> x = y) - (base_type_code_lb : forall x y, x = y -> eq_base_type_code x y = true). - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - - Fixpoint flat_type_beq (X Y : flat_type) {struct X} : bool - := match X, Y with - | Tbase T, Tbase T0 => eq_base_type_code T T0 - | Unit, Unit => true - | Prod A B, Prod A0 B0 => (flat_type_beq A A0 && flat_type_beq B B0)%bool - | Tbase _, _ - | Prod _ _, _ - | Unit, _ - => false - end. - Local Ltac t := - repeat match goal with - | _ => intro - | _ => reflexivity - | _ => assumption - | _ => progress simpl in * - | _ => solve [ eauto with nocore ] - | [ H : False |- _ ] => exfalso; assumption - | [ H : false = true |- _ ] => apply Bool.diff_false_true in H - | [ |- Prod _ _ = Prod _ _ ] => apply f_equal2 - | [ |- Arrow _ _ = Arrow _ _ ] => apply f_equal2 - | [ |- Tbase _ = Tbase _ ] => apply f_equal - | [ H : forall Y, _ = true -> _ = Y |- _ = ?Y' ] - => is_var Y'; apply H; solve [ t ] - | [ H : forall X Y, X = Y -> _ = true |- _ = true ] - => eapply H; solve [ t ] - | [ H : true = true |- _ ] => clear H - | [ H : andb ?x ?y = true |- _ ] - => destruct x, y; simpl in H; solve [ t ] - | [ H : andb ?x ?y = true |- _ ] - => destruct x eqn:?; simpl in H - | [ H : ?f ?x = true |- _ ] => destruct (f x); solve [ t ] - | [ H : ?x = true |- andb _ ?x = true ] - => destruct x - | [ |- andb ?x _ = true ] - => cut (x = true); [ destruct x; simpl | ] - end. - Lemma flat_type_dec_bl X : forall Y, flat_type_beq X Y = true -> X = Y. - Proof. clear base_type_code_lb; induction X, Y; t. Defined. - Lemma flat_type_dec_lb X : forall Y, X = Y -> flat_type_beq X Y = true. - Proof. clear base_type_code_bl; intros; subst Y; induction X; t. Defined. - Definition flat_type_eq_dec (X Y : flat_type) : {X = Y} + {X <> Y} - := match Sumbool.sumbool_of_bool (flat_type_beq X Y) with - | left pf => left (flat_type_dec_bl _ _ pf) - | right pf => right (fun pf' => let pf'' := eq_sym (flat_type_dec_lb _ _ pf') in - Bool.diff_true_false (eq_trans pf'' pf)) - end. - Definition type_beq (X Y : type) : bool - := match X, Y with - | Arrow A B, Arrow A0 B0 => (flat_type_beq A A0 && flat_type_beq B B0)%bool - end. - Lemma type_dec_bl X : forall Y, type_beq X Y = true -> X = Y. - Proof. clear base_type_code_lb; pose proof flat_type_dec_bl; induction X, Y; t. Defined. - Lemma type_dec_lb X : forall Y, X = Y -> type_beq X Y = true. - Proof. clear base_type_code_bl; pose proof flat_type_dec_lb; intros; subst Y; induction X; t. Defined. - Definition type_eq_dec (X Y : type) : {X = Y} + {X <> Y} - := match Sumbool.sumbool_of_bool (type_beq X Y) with - | left pf => left (type_dec_bl _ _ pf) - | right pf => right (fun pf' => let pf'' := eq_sym (type_dec_lb _ _ pf') in - Bool.diff_true_false (eq_trans pf'' pf)) - end. -End language. - -Lemma dec_eq_flat_type {base_type_code} `{DecidableRel (@eq base_type_code)} - : DecidableRel (@eq (flat_type base_type_code)). -Proof. - repeat intro; hnf; decide equality; apply dec; auto. -Defined. -Hint Extern 1 (Decidable (@eq (flat_type ?base_type_code) ?x ?y)) -=> simple apply (@dec_eq_flat_type base_type_code) : typeclass_instances. -Lemma dec_eq_type {base_type_code} `{DecidableRel (@eq base_type_code)} - : DecidableRel (@eq (type base_type_code)). -Proof. - repeat intro; hnf; decide equality; apply dec; typeclasses eauto. -Defined. -Hint Extern 1 (Decidable (@eq (type ?base_type_code) ?x ?y)) -=> simple apply (@dec_eq_type base_type_code) : typeclass_instances. diff --git a/src/Reflection/Eta.v b/src/Reflection/Eta.v deleted file mode 100644 index d40267858..000000000 --- a/src/Reflection/Eta.v +++ /dev/null @@ -1,75 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.ExprInversion. - -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type}. - Local Notation Expr := (@Expr base_type_code op). - Section with_var. - Context {var : base_type_code -> Type}. - Local Notation exprf := (@exprf base_type_code op var). - Local Notation expr := (@expr base_type_code op var). - - Section gen_flat_type. - Context (eta : forall {A B}, A * B -> A * B). - Fixpoint interp_flat_type_eta_gen {t T} : (interp_flat_type var t -> T) -> interp_flat_type var t -> T - := match t return (interp_flat_type var t -> T) -> interp_flat_type var t -> T with - | Tbase T => fun f => f - | Unit => fun f => f - | Prod A B - => fun f x - => let '(a, b) := eta _ _ x in - @interp_flat_type_eta_gen - A _ - (fun a' => @interp_flat_type_eta_gen B _ (fun b' => f (a', b')) b) - a - end. - - Section gen_type. - Context (exprf_eta : forall {t} (e : exprf t), exprf t). - Definition expr_eta_gen {t} (e : expr t) : expr (Arrow (domain t) (codomain t)) - := Abs (interp_flat_type_eta_gen (fun x => exprf_eta _ (invert_Abs e x))). - End gen_type. - - Fixpoint exprf_eta_gen {t} (e : exprf t) : exprf t - := match e in Syntax.exprf _ _ t return exprf t with - | TT => TT - | Var t v => Var v - | Op t1 tR opc args => Op opc (@exprf_eta_gen _ args) - | LetIn tx ex tC eC - => LetIn (@exprf_eta_gen _ ex) - (interp_flat_type_eta_gen (fun x => @exprf_eta_gen _ (eC x))) - | Pair tx ex ty ey => Pair (@exprf_eta_gen _ ex) (@exprf_eta_gen _ ey) - end. - End gen_flat_type. - - Definition interp_flat_type_eta {t T} - := @interp_flat_type_eta_gen (fun _ _ x => x) t T. - Definition interp_flat_type_eta' {t T} - := @interp_flat_type_eta_gen (fun _ _ x => (fst x, snd x)) t T. - Definition exprf_eta {t} - := @exprf_eta_gen (fun _ _ x => x) t. - Definition exprf_eta' {t} - := @exprf_eta_gen (fun _ _ x => (fst x, snd x)) t. - Definition expr_eta {t} - := @expr_eta_gen (fun _ _ x => x) (@exprf_eta) t. - Definition expr_eta' {t} - := @expr_eta_gen (fun _ _ x => (fst x, snd x)) (@exprf_eta') t. - End with_var. - Definition ExprEtaGen eta {t} (e : Expr t) : Expr (Arrow (domain t) (codomain t)) - := fun var => expr_eta_gen eta (@exprf_eta_gen var eta) (e var). - Definition ExprEta {t} (e : Expr t) : Expr (Arrow (domain t) (codomain t)) - := fun var => expr_eta (e var). - Definition ExprEta' {t} (e : Expr t) : Expr (Arrow (domain t) (codomain t)) - := fun var => expr_eta' (e var). -End language. -(* put these outside the section so the argument order lines up with - [interp] and [Interp] *) -Definition interp_eta {base_type_code interp_base_type op} interp_op - {t} (e : @expr base_type_code op interp_base_type t) - : interp_type interp_base_type t - := interp_flat_type_eta (interp interp_op e). -Definition InterpEta {base_type_code interp_base_type op} interp_op - {t} (e : @Expr base_type_code op t) - : interp_type interp_base_type t - := interp_eta interp_op (e _). diff --git a/src/Reflection/EtaInterp.v b/src/Reflection/EtaInterp.v deleted file mode 100644 index deb551d7d..000000000 --- a/src/Reflection/EtaInterp.v +++ /dev/null @@ -1,105 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Eta. -Require Import Crypto.Reflection.ExprInversion. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.DestructHead. - -Section language. - Context {base_type_code : Type} - {interp_base_type : base_type_code -> Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - {interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst}. - - Local Notation exprf := (@exprf base_type_code op interp_base_type). - - Local Ltac t_step := - match goal with - | _ => reflexivity - | _ => progress simpl in * - | _ => intro - | _ => progress break_match - | _ => progress destruct_head prod - | _ => progress cbv [LetIn.Let_In] - | [ H : _ |- _ ] => rewrite H - | _ => progress autorewrite with core - | [ H : forall A B x, ?f A B x = x, H' : context[?f _ _ _] |- _ ] - => rewrite H in H' - | _ => progress unfold interp_flat_type_eta, interp_flat_type_eta', exprf_eta, exprf_eta', expr_eta, expr_eta' - end. - Local Ltac t := repeat t_step. - - Section gen_flat_type. - Context (eta : forall {A B}, A * B -> A * B) - (eq_eta : forall A B x, @eta A B x = x). - Lemma eq_interp_flat_type_eta_gen {var t T f} x - : @interp_flat_type_eta_gen base_type_code var eta t T f x = f x. - Proof using eq_eta. induction t; t. Qed. - - (* Local *) Hint Rewrite @eq_interp_flat_type_eta_gen. - - Section gen_type. - Context (exprf_eta : forall {t} (e : exprf t), exprf t) - (eq_interp_exprf_eta : forall t e, interpf (@interp_op) (@exprf_eta t e) = interpf (@interp_op) e). - Lemma interp_expr_eta_gen {t e} - : forall x, - interp (@interp_op) (expr_eta_gen eta exprf_eta (t:=t) e) x = interp (@interp_op) e x. - Proof using Type*. t. Qed. - End gen_type. - (* Local *) Hint Rewrite @interp_expr_eta_gen. - - Lemma interpf_exprf_eta_gen {t e} - : interpf (@interp_op) (exprf_eta_gen eta (t:=t) e) = interpf (@interp_op) e. - Proof using eq_eta. induction e; t. Qed. - - Lemma InterpExprEtaGen {t e} - : forall x, Interp (@interp_op) (ExprEtaGen eta (t:=t) e) x = Interp (@interp_op) e x. - Proof using eq_eta. apply interp_expr_eta_gen; intros; apply interpf_exprf_eta_gen. Qed. - End gen_flat_type. - (* Local *) Hint Rewrite @eq_interp_flat_type_eta_gen. - (* Local *) Hint Rewrite @interp_expr_eta_gen. - (* Local *) Hint Rewrite @interpf_exprf_eta_gen. - - Lemma eq_interp_flat_type_eta {var t T f} x - : @interp_flat_type_eta base_type_code var t T f x = f x. - Proof using Type. t. Qed. - (* Local *) Hint Rewrite @eq_interp_flat_type_eta. - Lemma eq_interp_flat_type_eta' {var t T f} x - : @interp_flat_type_eta' base_type_code var t T f x = f x. - Proof using Type. t. Qed. - (* Local *) Hint Rewrite @eq_interp_flat_type_eta'. - Lemma interpf_exprf_eta {t e} - : interpf (@interp_op) (exprf_eta (t:=t) e) = interpf (@interp_op) e. - Proof using Type. t. Qed. - (* Local *) Hint Rewrite @interpf_exprf_eta. - Lemma interpf_exprf_eta' {t e} - : interpf (@interp_op) (exprf_eta' (t:=t) e) = interpf (@interp_op) e. - Proof using Type. t. Qed. - (* Local *) Hint Rewrite @interpf_exprf_eta'. - Lemma interp_expr_eta {t e} - : forall x, interp (@interp_op) (expr_eta (t:=t) e) x = interp (@interp_op) e x. - Proof using Type. t. Qed. - Lemma interp_expr_eta' {t e} - : forall x, interp (@interp_op) (expr_eta' (t:=t) e) x = interp (@interp_op) e x. - Proof using Type. t. Qed. - Lemma InterpExprEta {t e} - : forall x, Interp (@interp_op) (ExprEta (t:=t) e) x = Interp (@interp_op) e x. - Proof using Type. apply interp_expr_eta. Qed. - Lemma InterpExprEta' {t e} - : forall x, Interp (@interp_op) (ExprEta' (t:=t) e) x = Interp (@interp_op) e x. - Proof using Type. apply interp_expr_eta'. Qed. - Lemma InterpExprEta_arrow {s d e} - : forall x, Interp (t:=Arrow s d) (@interp_op) (ExprEta (t:=Arrow s d) e) x = Interp (@interp_op) e x. - Proof using Type. exact (@InterpExprEta (Arrow s d) e). Qed. - Lemma InterpExprEta'_arrow {s d e} - : forall x, Interp (t:=Arrow s d) (@interp_op) (ExprEta' (t:=Arrow s d) e) x = Interp (@interp_op) e x. - Proof using Type. exact (@InterpExprEta' (Arrow s d) e). Qed. - - Lemma eq_interp_eta {t e} - : forall x, interp_eta interp_op (t:=t) e x = interp interp_op e x. - Proof using Type. apply eq_interp_flat_type_eta. Qed. - Lemma eq_InterpEta {t e} - : forall x, InterpEta interp_op (t:=t) e x = Interp interp_op e x. - Proof using Type. apply eq_interp_eta. Qed. -End language. - -Hint Rewrite @eq_interp_flat_type_eta @eq_interp_flat_type_eta' @interpf_exprf_eta @interpf_exprf_eta' @interp_expr_eta @interp_expr_eta' @InterpExprEta @InterpExprEta' @InterpExprEta_arrow @InterpExprEta'_arrow @eq_interp_eta @eq_InterpEta : reflective_interp. diff --git a/src/Reflection/EtaWf.v b/src/Reflection/EtaWf.v deleted file mode 100644 index 240f5a1e3..000000000 --- a/src/Reflection/EtaWf.v +++ /dev/null @@ -1,122 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.Eta. -Require Import Crypto.Reflection.EtaInterp. -Require Import Crypto.Reflection.ExprInversion. -Require Import Crypto.Reflection.WfInversion. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Tactics.SplitInContext. - -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type}. - Local Notation exprf := (@exprf base_type_code op). - - Local Ltac t_step := - match goal with - | _ => intro - | _ => progress subst - | _ => progress destruct_head' sig - | _ => progress destruct_head' and - | _ => progress simpl in * - | _ => progress inversion_expr - | _ => progress destruct_head' @expr - | _ => progress invert_expr_step - | [ |- iff _ _ ] => split - | [ |- wf _ _ ] => constructor - | _ => progress split_iff - | _ => rewrite eq_interp_flat_type_eta_gen by assumption - | [ H : _ |- _ ] => rewrite eq_interp_flat_type_eta_gen in H by assumption - | [ H : appcontext[interp_flat_type_eta_gen] |- _ ] - => setoid_rewrite eq_interp_flat_type_eta_gen in H; [ | assumption.. ] - | _ => progress break_match - | [ H : wff _ _ _ |- _ ] => solve [ inversion H ] - | [ |- wff _ _ _ ] => constructor - | _ => solve [ auto | congruence | tauto ] - end. - Local Ltac t := repeat t_step. - - Local Hint Constructors wff. - - Section with_var. - Context {var1 var2 : base_type_code -> Type}. - Section gen_flat_type. - Context (eta : forall {A B}, A * B -> A * B) - (eq_eta : forall A B x, @eta A B x = x). - Section gen_type. - Context (exprf_eta1 : forall {t} (e : exprf t), exprf t) - (exprf_eta2 : forall {t} (e : exprf t), exprf t) - (wff_exprf_eta : forall G t e1 e2, @wff _ _ var1 var2 G t e1 e2 - <-> @wff _ _ var1 var2 G t (@exprf_eta1 t e1) (@exprf_eta2 t e2)). - Lemma wf_expr_eta_gen {t e1 e2} - : wf (expr_eta_gen eta exprf_eta1 (t:=t) e1) - (expr_eta_gen eta exprf_eta2 (t:=t) e2) - <-> wf e1 e2. - Proof using Type*. unfold expr_eta_gen; t; inversion_wf_step; t. Qed. - End gen_type. - - Lemma wff_exprf_eta_gen {t e1 e2} G - : wff G (exprf_eta_gen eta (t:=t) e1) (exprf_eta_gen eta (t:=t) e2) - <-> @wff base_type_code op var1 var2 G t e1 e2. - Proof using eq_eta. - revert G; induction e1; first [ progress invert_expr | destruct e2 ]; - t; inversion_wf_step; t. - Qed. - End gen_flat_type. - - (* Local *) Hint Resolve -> wff_exprf_eta_gen. - (* Local *) Hint Resolve <- wff_exprf_eta_gen. - - Lemma wff_exprf_eta {G t e1 e2} - : wff G (exprf_eta (t:=t) e1) (exprf_eta (t:=t) e2) - <-> @wff base_type_code op var1 var2 G t e1 e2. - Proof using Type. setoid_rewrite wff_exprf_eta_gen; reflexivity. Qed. - Lemma wff_exprf_eta' {G t e1 e2} - : wff G (exprf_eta' (t:=t) e1) (exprf_eta' (t:=t) e2) - <-> @wff base_type_code op var1 var2 G t e1 e2. - Proof using Type. setoid_rewrite wff_exprf_eta_gen; intuition. Qed. - Lemma wf_expr_eta {t e1 e2} - : wf (expr_eta (t:=t) e1) (expr_eta (t:=t) e2) - <-> @wf base_type_code op var1 var2 t e1 e2. - Proof using Type. - unfold expr_eta, exprf_eta. - setoid_rewrite wf_expr_eta_gen; intuition (solve [ eapply wff_exprf_eta_gen; [ | eassumption ]; intuition ] || eauto). - Qed. - Lemma wf_expr_eta' {t e1 e2} - : wf (expr_eta' (t:=t) e1) (expr_eta' (t:=t) e2) - <-> @wf base_type_code op var1 var2 t e1 e2. - Proof using Type. - unfold expr_eta', exprf_eta'. - setoid_rewrite wf_expr_eta_gen; intuition (solve [ eapply wff_exprf_eta_gen; [ | eassumption ]; intuition ] || eauto). - Qed. - End with_var. - - Lemma Wf_ExprEtaGen - (eta : forall {A B}, A * B -> A * B) - (eq_eta : forall A B x, @eta A B x = x) - {t e} - : Wf (ExprEtaGen (@eta) e) <-> @Wf base_type_code op t e. - Proof using Type. - split; intros H var1 var2; specialize (H var1 var2); - revert H; eapply wf_expr_eta_gen; try eassumption; intros; - symmetry; apply wff_exprf_eta_gen; - auto. - Qed. - Lemma Wf_ExprEta_iff - {t e} - : Wf (ExprEta e) <-> @Wf base_type_code op t e. - Proof using Type. - unfold Wf; setoid_rewrite wf_expr_eta; reflexivity. - Qed. - Lemma Wf_ExprEta'_iff - {t e} - : Wf (ExprEta' e) <-> @Wf base_type_code op t e. - Proof using Type. - unfold Wf; setoid_rewrite wf_expr_eta'; reflexivity. - Qed. - Definition Wf_ExprEta {t e} : Wf e -> Wf (ExprEta e) := proj2 (@Wf_ExprEta_iff t e). - Definition Wf_ExprEta' {t e} : Wf e -> Wf (ExprEta' e) := proj2 (@Wf_ExprEta'_iff t e). -End language. - -Hint Resolve Wf_ExprEta Wf_ExprEta' : wf. diff --git a/src/Reflection/ExprInversion.v b/src/Reflection/ExprInversion.v deleted file mode 100644 index 645555cb5..000000000 --- a/src/Reflection/ExprInversion.v +++ /dev/null @@ -1,254 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.TypeInversion. -Require Import Crypto.Util.Sigma. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Prod. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Notations. - -Section language. - Context {base_type_code : Type} - {interp_base_type : base_type_code -> Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type}. - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation interp_type := (interp_type interp_base_type). - Local Notation interp_flat_type_gen := interp_flat_type. - Local Notation interp_flat_type := (interp_flat_type interp_base_type). - Local Notation Expr := (@Expr base_type_code op). - - Section with_var. - Context {var : base_type_code -> Type}. - - Local Notation exprf := (@exprf base_type_code op var). - Local Notation expr := (@expr base_type_code op var). - - Definition invert_Var {t} (e : exprf (Tbase t)) : option (var t) - := match e in Syntax.exprf _ _ t' - return option (var match t' with - | Tbase t' => t' - | _ => t - end) - with - | Var _ v => Some v - | _ => None - end. - Definition invert_Op {t} (e : exprf t) : option { t1 : flat_type & op t1 t * exprf t1 }%type - := match e with Op _ _ opc args => Some (existT _ _ (opc, args)) | _ => None end. - Definition invert_LetIn {A} (e : exprf A) : option { B : _ & exprf B * (Syntax.interp_flat_type var B -> exprf A) }%type - := match e in Syntax.exprf _ _ t return option { B : _ & _ * (_ -> exprf t) }%type with - | LetIn _ ex _ eC => Some (existT _ _ (ex, eC)) - | _ => None - end. - Definition invert_Pair {A B} (e : exprf (Prod A B)) : option (exprf A * exprf B) - := match e in Syntax.exprf _ _ t - return option match t with - | Prod _ _ => _ - | _ => unit - end with - | Pair _ x _ y => Some (x, y)%core - | _ => None - end. - Definition invert_Abs {T} (e : expr T) : interp_flat_type_gen var (domain T) -> exprf (codomain T) - := match e with Abs _ _ f => f end. - - Definition exprf_code {t} (e : exprf t) : exprf t -> Prop - := match e with - | TT => fun e' => TT = e' - | Var _ v => fun e' => invert_Var e' = Some v - | Pair _ x _ y => fun e' => invert_Pair e' = Some (x, y)%core - | Op _ _ opc args => fun e' => invert_Op e' = Some (existT _ _ (opc, args)%core) - | LetIn _ ex _ eC => fun e' => invert_LetIn e' = Some (existT _ _ (ex, eC)%core) - end. - - Definition expr_code {t} (e1 e2 : expr t) : Prop - := invert_Abs e1 = invert_Abs e2. - - Definition exprf_encode {t} (x y : exprf t) : x = y -> exprf_code x y. - Proof. intro p; destruct p, x; reflexivity. Defined. - Definition expr_encode {t} (x y : expr t) : x = y -> expr_code x y. - Proof. intro p; destruct p, x; reflexivity. Defined. - - Local Ltac t' := - repeat first [ intro - | progress simpl in * - | reflexivity - | assumption - | progress destruct_head False - | progress subst - | progress inversion_option - | progress inversion_sigma - | progress break_match ]. - Local Ltac t := - lazymatch goal with - | [ |- _ = Some ?v -> ?e = _ ] - => revert v; - refine match e with - | Var _ _ => _ - | _ => _ - end - | [ |- _ = ?v -> ?e = _ ] - => revert v; - refine match e with - | Abs _ _ _ => _ - end - end; - t'. - - Lemma invert_Var_Some {t e v} - : @invert_Var t e = Some v -> e = Var v. - Proof. t. Defined. - - Lemma invert_Op_Some {t e v} - : @invert_Op t e = Some v -> e = Op (fst (projT2 v)) (snd (projT2 v)). - Proof. t. Defined. - - Lemma invert_LetIn_Some {t e v} - : @invert_LetIn t e = Some v -> e = LetIn (fst (projT2 v)) (snd (projT2 v)). - Proof. t. Defined. - - Lemma invert_Pair_Some {A B e v} - : @invert_Pair A B e = Some v -> e = Pair (fst v) (snd v). - Proof. t. Defined. - - Lemma invert_Abs_Some {A B e v} - : @invert_Abs (Arrow A B) e = v -> e = Abs v. - Proof. t. Defined. - - Definition exprf_decode {t} (x y : exprf t) : exprf_code x y -> x = y. - Proof. - destruct x; simpl; trivial; - intro H; - first [ apply invert_Var_Some in H - | apply invert_Op_Some in H - | apply invert_LetIn_Some in H - | apply invert_Pair_Some in H ]; - symmetry; assumption. - Defined. - Definition expr_decode {t} (x y : expr t) : expr_code x y -> x = y. - Proof. - destruct x; unfold expr_code; simpl. - intro H; symmetry in H. - apply invert_Abs_Some in H. - symmetry; assumption. - Defined. - Definition path_exprf_rect {t} {x y : exprf t} (Q : x = y -> Type) - (f : forall p, Q (exprf_decode x y p)) - : forall p, Q p. - Proof. intro p; specialize (f (exprf_encode x y p)); destruct x, p; exact f. Defined. - Definition path_expr_rect {t} {x y : expr t} (Q : x = y -> Type) - (f : forall p, Q (expr_decode x y p)) - : forall p, Q p. - Proof. intro p; specialize (f (expr_encode x y p)); destruct x, p; exact f. Defined. - End with_var. - - Lemma interpf_invert_Abs interp_op {T e} x - : Syntax.interpf interp_op (@invert_Abs interp_base_type T e x) - = Syntax.interp interp_op e x. - Proof using Type. destruct e; reflexivity. Qed. -End language. - -Global Arguments invert_Var {_ _ _ _} _. -Global Arguments invert_Op {_ _ _ _} _. -Global Arguments invert_LetIn {_ _ _ _} _. -Global Arguments invert_Pair {_ _ _ _ _} _. -Global Arguments invert_Abs {_ _ _ _} _ _. - -Ltac invert_one_expr e := - preinvert_one_type e; - intros ? e; - destruct e; - try exact I. - -Ltac invert_expr_step := - match goal with - | [ e : exprf _ _ (Tbase _) |- _ ] => invert_one_expr e - | [ e : exprf _ _ (Prod _ _) |- _ ] => invert_one_expr e - | [ e : exprf _ _ Unit |- _ ] => invert_one_expr e - | [ e : expr _ _ (Arrow _ _) |- _ ] => invert_one_expr e - end. - -Ltac invert_expr := repeat invert_expr_step. - -Ltac invert_match_expr_step := - match goal with - | [ |- appcontext[match ?e with TT => _ | _ => _ end] ] - => invert_one_expr e - | [ |- appcontext[match ?e with Abs _ _ _ => _ end] ] - => invert_one_expr e - | [ H : appcontext[match ?e with TT => _ | _ => _ end] |- _ ] - => invert_one_expr e - | [ H : appcontext[match ?e with Abs _ _ _ => _ end] |- _ ] - => invert_one_expr e - end. - -Ltac invert_match_expr := repeat invert_match_expr_step. - -Ltac invert_expr_subst_step_helper guard_tac := - match goal with - | [ H : invert_Var ?e = Some _ |- _ ] => guard_tac H; apply invert_Var_Some in H - | [ H : invert_Op ?e = Some _ |- _ ] => guard_tac H; apply invert_Op_Some in H - | [ H : invert_LetIn ?e = Some _ |- _ ] => guard_tac H; apply invert_LetIn_Some in H - | [ H : invert_Pair ?e = Some _ |- _ ] => guard_tac H; apply invert_Pair_Some in H - | [ e : expr _ _ _ |- _ ] - => guard_tac e; - let f := fresh e in - let H := fresh in - rename e into f; - remember (invert_Abs f) as e eqn:H; - symmetry in H; - apply invert_Abs_Some in H; - subst f - | [ H : invert_Abs ?e = _ |- _ ] => guard_tac H; apply invert_Abs_Some in H - end. -Ltac invert_expr_subst_step := - first [ invert_expr_subst_step_helper ltac:(fun _ => idtac) - | subst ]. -Ltac invert_expr_subst := repeat invert_expr_subst_step. - -Ltac induction_expr_in_using H rect := - induction H as [H] using (rect _ _ _); - cbv [exprf_code expr_code invert_Var invert_LetIn invert_Pair invert_Op invert_Abs] in H; - try lazymatch type of H with - | Some _ = Some _ => apply option_leq_to_eq in H; unfold option_eq in H - | Some _ = None => exfalso; clear -H; solve [ inversion H ] - | None = Some _ => exfalso; clear -H; solve [ inversion H ] - end; - let H1 := fresh H in - let H2 := fresh H in - try lazymatch type of H with - | existT _ _ _ = existT _ _ _ => induction_sigma_in_using H @path_sigT_rect - end; - try lazymatch type of H2 with - | _ = (_, _)%core => induction_path_prod H2 - end. -Ltac inversion_expr_step := - match goal with - | [ H : _ = Var _ |- _ ] - => induction_expr_in_using H @path_exprf_rect - | [ H : _ = TT |- _ ] - => induction_expr_in_using H @path_exprf_rect - | [ H : _ = Op _ _ |- _ ] - => induction_expr_in_using H @path_exprf_rect - | [ H : _ = Pair _ _ |- _ ] - => induction_expr_in_using H @path_exprf_rect - | [ H : _ = LetIn _ _ |- _ ] - => induction_expr_in_using H @path_exprf_rect - | [ H : _ = Abs _ |- _ ] - => induction_expr_in_using H @path_expr_rect - | [ H : Var _ = _ |- _ ] - => induction_expr_in_using H @path_exprf_rect - | [ H : TT = _ |- _ ] - => induction_expr_in_using H @path_exprf_rect - | [ H : Op _ _ = _ |- _ ] - => induction_expr_in_using H @path_exprf_rect - | [ H : Pair _ _ = _ |- _ ] - => induction_expr_in_using H @path_exprf_rect - | [ H : LetIn _ _ = _ |- _ ] - => induction_expr_in_using H @path_exprf_rect - | [ H : Abs _ = _ |- _ ] - => induction_expr_in_using H @path_expr_rect - end. -Ltac inversion_expr := repeat inversion_expr_step. diff --git a/src/Reflection/FilterLive.v b/src/Reflection/FilterLive.v deleted file mode 100644 index 68144c0f7..000000000 --- a/src/Reflection/FilterLive.v +++ /dev/null @@ -1,70 +0,0 @@ -(** * Computes a list of live variables *) -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Named.NameUtil. -Require Import Crypto.Reflection.CountLets. -Require Import Crypto.Util.ListUtil. - -Local Notation eta x := (fst x, snd x). - -Local Open Scope ctype_scope. -Section language. - Context (base_type_code : Type) - (op : flat_type base_type_code -> flat_type base_type_code -> Type) - (Name : Type) - (dead_name : Name) - (merge_names : Name -> Name -> Name) - (* equations: - - [merge_names x dead_name = merge_names dead_name x = x] - - [merge_names x x = x] *). - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation var := (fun t : base_type_code => list Name). - Local Notation exprf := (@exprf base_type_code op var). - Local Notation expr := (@expr base_type_code op var). - Local Notation Expr := (@Expr base_type_code op var). - - Fixpoint merge_name_lists (ls1 ls2 : list Name) : list Name := - match ls1, ls2 with - | cons x xs, cons y ys => cons (merge_names x y) (merge_name_lists xs ys) - | ls1, nil => ls1 - | nil, ls2 => ls2 - end. - - Definition names_to_list {t} : interp_flat_type (fun _ : base_type_code => Name) t -> list Name - := smart_interp_flat_map (g:=fun _ => list Name) (fun _ x => x :: nil)%list nil (fun _ _ x y => x ++ y)%list. - - Fixpoint filter_live_namesf (prefix remaining : list Name) {t} (e : exprf t) : list Name - := match e with - | TT => prefix - | Var _ x => x - | Op _ _ op args => @filter_live_namesf prefix remaining _ args - | LetIn tx ex _ eC - => let namesx := @filter_live_namesf prefix nil _ ex in - let '(ns, remaining') := eta (split_names tx remaining) in - match ns with - | Some n => - @filter_live_namesf - (prefix ++ repeat dead_name (count_pairs tx))%list remaining' _ - (eC (SmartValf (fun _ => list Name) (fun _ => namesx ++ names_to_list n)%list _)) - | None => nil - end - | Pair _ ex _ ey => merge_name_lists (@filter_live_namesf prefix remaining _ ex) - (@filter_live_namesf prefix remaining _ ey) - end. - - Definition filter_live_names (prefix remaining : list Name) {t} (e : expr t) : list Name - := match e with - | Abs src _ ef - => let '(ns, remaining') := eta (split_names src remaining) in - match ns with - | Some n => - let prefix' := (prefix ++ names_to_list n)%list in - filter_live_namesf - prefix' remaining' - (ef (SmartValf _ (fun _ => prefix') src)) - | None => nil - end - end. -End language. diff --git a/src/Reflection/FoldTypes.v b/src/Reflection/FoldTypes.v deleted file mode 100644 index d5d62a3aa..000000000 --- a/src/Reflection/FoldTypes.v +++ /dev/null @@ -1,45 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.ExprInversion. -Require Import Crypto.Reflection.SmartMap. - -Section language. - Context {base_type_code} {op : flat_type base_type_code -> flat_type base_type_code -> Type}. - - Section generic_type. - Context {A} - (process : base_type_code -> A) - (fold : A -> A -> A). - - Section with_var. - Context {var : base_type_code -> Type} - (init : A) - (dummy : forall t, var t). - - Fixpoint fold_flat_type (t : flat_type base_type_code) : A - := match t with - | Tbase T => process T - | Unit => init - | Prod A B => fold (fold_flat_type A) (fold_flat_type B) - end. - - Fixpoint type_foldf {t} (e : @exprf base_type_code op var t) : A - := match e with - | TT => init - | Var t v => process t - | Op t tR opc args - => fold (@type_foldf t args) (fold_flat_type tR) - | LetIn tx ex tC eC - => fold (@type_foldf tx ex) - (@type_foldf tC (eC (SmartValf _ dummy _))) - | Pair tx ex ty ey - => fold (@type_foldf tx ex) (@type_foldf ty ey) - end. - - Definition type_fold {t} (e : @expr base_type_code op var t) : A - := fold (fold_flat_type (domain t)) (type_foldf (invert_Abs e (SmartValf _ dummy _))). - End with_var. - - Definition TypeFold (init : A) {t} (e : Expr base_type_code op t) : A - := type_fold init (fun _ => tt) (e (fun _ => unit)). - End generic_type. -End language. diff --git a/src/Reflection/Inline.v b/src/Reflection/Inline.v deleted file mode 100644 index 74abeef10..000000000 --- a/src/Reflection/Inline.v +++ /dev/null @@ -1,94 +0,0 @@ -(** * Inline: Remove some [Let] expressions *) -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.SmartMap. - -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type}. - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Let Tbase := @Tbase base_type_code. - Local Coercion Tbase : base_type_code >-> Syntax.flat_type. - Local Notation exprf := (@exprf base_type_code op). - Local Notation expr := (@expr base_type_code op). - Local Notation Expr := (@Expr base_type_code op). - - Section with_var. - Context {var : base_type_code -> Type}. - - Inductive inline_directive : flat_type -> Type := - | default_inline {t} (e : @exprf var t) : inline_directive t - | inline {t : base_type_code} (e : @exprf var t) : inline_directive t - | no_inline {t} (e : @exprf var t) : inline_directive t. - - Definition exprf_of_inline_directive {t} (v : inline_directive t) : @exprf var t - := match v with - | default_inline t e => e - | inline t e => e - | no_inline t e => e - end. - - Context (postprocess : forall {t}, @exprf var t -> inline_directive t). - - Fixpoint inline_const_genf {t} (e : @exprf (@exprf var) t) : @exprf var t - := match e in Syntax.exprf _ _ t return @exprf var t with - | LetIn tx ex tC eC - => match postprocess _ (@inline_const_genf _ ex) in inline_directive t' return (interp_flat_type _ t' -> @exprf var tC) -> @exprf var tC with - | default_inline _ ex - => match ex in Syntax.exprf _ _ t' return (interp_flat_type _ t' -> @exprf var tC) -> @exprf var tC with - | TT => fun eC => eC tt - | Var _ x => fun eC => eC (Var x) - | ex => fun eC => LetIn ex (fun x => eC (SmartVarVarf x)) - end - | no_inline _ ex - => fun eC => LetIn ex (fun x => eC (SmartVarVarf x)) - | inline _ ex => fun eC => eC ex - end (fun x => @inline_const_genf _ (eC x)) - | Var _ x => x - | TT => TT - | Pair _ ex _ ey => Pair (@inline_const_genf _ ex) (@inline_const_genf _ ey) - | Op _ _ op args => Op op (@inline_const_genf _ args) - end. - - Definition inline_const_gen {t} (e : @expr (@exprf var) t) : @expr var t - := match e in Syntax.expr _ _ t return @expr var t with - | Abs _ _ f => Abs (fun x => inline_const_genf (f (SmartVarVarf x))) - end. - - Section with_is_const. - Context (is_const : forall s d, op s d -> bool). - - Definition postprocess_for_const (t : flat_type) (v : @exprf var t) : inline_directive t - := if match v with Op _ _ op _ => @is_const _ _ op | _ => false end - then match t return @exprf _ t -> inline_directive t with - | Syntax.Tbase _ => @inline _ - | _ => @default_inline _ - end v - else default_inline v. - End with_is_const. - End with_var. - - Definition inline_constf is_const {var t} - := @inline_const_genf var (postprocess_for_const is_const) t. - Definition inline_const is_const {var t} - := @inline_const_gen var (postprocess_for_const is_const) t. - - Definition InlineConstGen (postprocess : forall var t, @exprf var t -> @inline_directive var t) - {t} (e : Expr t) : Expr t - := fun var => inline_const_gen (postprocess _) (e _). - Definition InlineConst is_const {t} - := @InlineConstGen (fun var => postprocess_for_const is_const) t. -End language. - -Global Arguments inline_directive {_} _ _ _, {_ _ _} _. -Global Arguments no_inline {_ _ _ _} _. -Global Arguments inline {_ _ _ _} _. -Global Arguments default_inline {_ _ _ _} _. -Global Arguments inline_const_genf {_ _ _} postprocess {_} _. -Global Arguments inline_const_gen {_ _ _} postprocess {_} _. -Global Arguments InlineConstGen {_ _} postprocess {_} _ var. -Global Arguments inline_constf {_ _} is_const {_ t} _. -Global Arguments inline_const {_ _} is_const {_ t} _. -Global Arguments InlineConst {_ _} is_const {_} _ var. diff --git a/src/Reflection/InlineCast.v b/src/Reflection/InlineCast.v deleted file mode 100644 index d3e85d02d..000000000 --- a/src/Reflection/InlineCast.v +++ /dev/null @@ -1,90 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.SmartCast. -Require Import Crypto.Reflection.TypeUtil. -Require Import Crypto.Reflection.Inline. -Require Import Crypto.Util.Notations. - -Local Open Scope expr_scope. -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - (base_type_beq : base_type_code -> base_type_code -> bool) - (base_type_bl_transparent : forall x y, base_type_beq x y = true -> x = y) - (base_type_leb : base_type_code -> base_type_code -> bool) - (Cast : forall var A A', exprf base_type_code op (var:=var) (Tbase A) -> exprf base_type_code op (var:=var) (Tbase A')) - (is_cast : forall src dst, op src dst -> bool) - (is_const : forall src dst, op src dst -> bool). - Local Infix "<=?" := base_type_leb : expr_scope. - Local Infix "=?" := base_type_beq : expr_scope. - - Local Notation base_type_min := (base_type_min base_type_leb). - Local Notation SmartCast_base := (@SmartCast_base _ op _ base_type_bl_transparent Cast). - - Local Notation flat_type := (flat_type base_type_code). - Local Notation exprf := (@exprf base_type_code op). - Local Notation Expr := (@Expr base_type_code op). - - (** We can squash [a -> b -> c] into [a -> c] if [min a b c = min a - c], i.e., if the narrowest type we pass through in the original - case is the same as the narrowest type we pass through in the - new case. *) - Definition squash_cast {var} (a b c : base_type_code) - : @exprf var (Tbase a) -> @exprf var (Tbase c) - := if base_type_beq (base_type_min b (base_type_min a c)) (base_type_min a c) - then SmartCast_base - else fun x => Cast _ b c (Cast _ a b x). - Fixpoint maybe_push_cast {var t} (v : @exprf var t) : option (@exprf var t) - := match v in Syntax.exprf _ _ t return option (exprf t) with - | Var _ _ as v' - => Some v' - | Op t1 tR opc args - => match t1, tR return op t1 tR -> exprf t1 -> option (exprf tR) with - | Tbase b, Tbase c - => fun opc args - => if is_cast _ _ opc - then match @maybe_push_cast _ _ args with - | Some (Op t1 tR opc' args') - => match t1, tR return op t1 tR -> exprf t1 -> option (exprf (Tbase c)) with - | Tbase a, Tbase b - => fun opc' args' - => if is_cast _ _ opc' - then Some (squash_cast a b c args') - else None - | Unit, Tbase _ - => fun opc' args' - => if is_const _ _ opc' - then Some (SmartCast_base (Op opc' TT)) - else None - | _, _ => fun _ _ => None - end opc' args' - | Some (Var _ v as v') => Some (SmartCast_base v') - | Some _ => None - | None => None - end - else None - | Unit, _ - => fun opc args - => if is_const _ _ opc - then Some (Op opc TT) - else None - | _, _ - => fun _ _ => None - end opc args - | Pair _ _ _ _ - | LetIn _ _ _ _ - | TT - => None - end. - Definition push_cast {var t} : @exprf var t -> @inline_directive _ op var t - := match t with - | Tbase _ => fun v => match maybe_push_cast v with - | Some e => inline e - | None => default_inline v - end - | _ => default_inline - end. - - Definition InlineCast {t} (e : Expr t) : Expr t - := InlineConstGen (@push_cast) e. -End language. diff --git a/src/Reflection/InlineCastInterp.v b/src/Reflection/InlineCastInterp.v deleted file mode 100644 index f885fbd16..000000000 --- a/src/Reflection/InlineCastInterp.v +++ /dev/null @@ -1,115 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Reflection.TypeUtil. -Require Import Crypto.Reflection.TypeInversion. -Require Import Crypto.Reflection.ExprInversion. -Require Import Crypto.Reflection.InlineCast. -Require Import Crypto.Reflection.InlineInterp. -Require Import Crypto.Reflection.SmartCast. -Require Import Crypto.Reflection.SmartCastInterp. -Require Import Crypto.Reflection.Inline. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Notations. - -Local Open Scope expr_scope. -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - {interp_base_type : base_type_code -> Type} - {interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst} - (base_type_beq : base_type_code -> base_type_code -> bool) - (base_type_bl_transparent : forall x y, base_type_beq x y = true -> x = y) - (base_type_leb : base_type_code -> base_type_code -> bool) - (Cast : forall var A A', exprf base_type_code op (var:=var) (Tbase A) -> exprf base_type_code op (var:=var) (Tbase A')) - (is_cast : forall src dst, op src dst -> bool) - (is_const : forall src dst, op src dst -> bool) - (interpf_Cast_id : forall A x, interpf interp_op (Cast _ A A x) = interpf interp_op x) - (cast_val : forall A A', interp_base_type A -> interp_base_type A') - (interpf_cast : forall A A' e, interpf interp_op (Cast _ A A' e) = cast_val A A' (interpf interp_op e)) - (cast_val_squash : forall a b c v, - base_type_min base_type_leb b (base_type_min base_type_leb a c) = base_type_min base_type_leb a c - -> cast_val b c (cast_val a b v) = cast_val a c v) - (is_cast_correct : forall s d opc e, is_cast (Tbase s) (Tbase d) opc = true - -> interp_op _ _ opc (interpf interp_op e) - = interpf interp_op (Cast _ s d e)). - - Local Notation SmartCast_base := (@SmartCast_base _ op _ base_type_bl_transparent Cast interp_base_type). - Local Notation squash_cast := (@squash_cast _ op _ base_type_bl_transparent base_type_leb Cast). - Local Notation maybe_push_cast := (@maybe_push_cast _ op _ base_type_bl_transparent base_type_leb Cast is_cast is_const). - Local Notation push_cast := (@push_cast _ op _ base_type_bl_transparent base_type_leb Cast is_cast is_const). - Local Notation InlineCast := (@InlineCast _ op _ base_type_bl_transparent base_type_leb Cast is_cast is_const). - Local Notation base_type_min := (base_type_min base_type_leb). - - Lemma cast_val_id A (v : exprf _ _ (Tbase A)) - : cast_val A A (interpf interp_op v) = interpf interp_op v. - Proof using interpf_Cast_id interpf_cast. rewrite <- !interpf_cast, !interpf_Cast_id; reflexivity. Qed. - - Lemma interpf_squash_cast a b c e1 - : interpf interp_op (@squash_cast _ a b c e1) = interpf interp_op (Cast _ b c (Cast _ a b e1)). - Proof using cast_val_squash interpf_Cast_id interpf_cast. - unfold squash_cast; - repeat first [ progress break_innermost_match - | intro - | reflexivity - | progress subst - | match goal with H : base_type_beq _ _ = true |- _ => apply base_type_bl_transparent in H end - | rewrite !cast_val_id - | rewrite !interpf_SmartCast_base by assumption - | rewrite !interpf_Cast_id - | rewrite interpf_cast - | rewrite cast_val_squash by assumption ]. - Qed. - - Lemma interpf_maybe_push_cast t e e' - : @maybe_push_cast _ t e = Some e' - -> interpf interp_op e' = interpf interp_op e. - Proof using cast_val_squash interpf_Cast_id interpf_cast is_cast_correct. - revert e'; induction e; - repeat first [ reflexivity - | discriminate - | progress subst - | progress inversion_option - | progress break_innermost_match_step - | progress simpl in * - | intro - | rewrite !interpf_SmartCast_base by assumption - | setoid_rewrite interpf_SmartCast_base; [ | assumption.. ] - | erewrite is_cast_correct by eassumption - | progress change (fun t => interp_base_type t) with interp_base_type in * - | rewrite !interpf_cast - | rewrite !interpf_squash_cast - | match goal with - | [ H : forall x, Some _ = Some x -> _ |- _ ] - => specialize (H _ eq_refl) - | [ |- context[interpf (t:=Unit) interp_op ?e] ] - => destruct (interpf interp_op e) - | [ H : maybe_push_cast ?e = Some _, H' : _ = interpf interp_op ?e |- _ ] - => rewrite <- H'; clear e H H' - | [ H : context[match ?e with _ => _ end] |- _ ] - => invert_one_expr e - end ]. - Qed. - - Lemma interpf_exprf_of_push_cast t e - : interpf interp_op (exprf_of_inline_directive (@push_cast _ t e)) - = interpf interp_op e. - Proof using cast_val_squash interpf_Cast_id interpf_cast is_cast_correct. - unfold push_cast; break_innermost_match; simpl; try reflexivity. - match goal with H : _ |- _ => apply interpf_maybe_push_cast in H end. - assumption. - Qed. - - Local Hint Resolve interpf_exprf_of_push_cast. - - Lemma InterpInlineCast {t} e (Hwf : Wf e) - : forall x, - Interp interp_op (@InlineCast t e) x - = Interp interp_op e x. - Proof using cast_val_squash interpf_Cast_id interpf_cast is_cast_correct. apply InterpInlineConstGen; auto. Qed. -End language. - -Hint Rewrite @interpf_exprf_of_push_cast @InterpInlineCast using solve [ eassumption | eauto with wf ] : reflective_interp. diff --git a/src/Reflection/InlineCastWf.v b/src/Reflection/InlineCastWf.v deleted file mode 100644 index a61455c4f..000000000 --- a/src/Reflection/InlineCastWf.v +++ /dev/null @@ -1,131 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.TypeInversion. -Require Import Crypto.Reflection.ExprInversion. -Require Import Crypto.Reflection.WfInversion. -Require Import Crypto.Reflection.InlineCast. -Require Import Crypto.Reflection.InlineWf. -Require Import Crypto.Reflection.SmartCast. -Require Import Crypto.Reflection.SmartCastWf. -Require Import Crypto.Reflection.Inline. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Notations. - -Local Open Scope expr_scope. -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - (base_type_beq : base_type_code -> base_type_code -> bool) - (base_type_bl_transparent : forall x y, base_type_beq x y = true -> x = y) - (base_type_leb : base_type_code -> base_type_code -> bool) - (Cast : forall var A A', exprf base_type_code op (var:=var) (Tbase A) -> exprf base_type_code op (var:=var) (Tbase A')) - (is_cast : forall src dst, op src dst -> bool) - (is_const : forall src dst, op src dst -> bool) - (wff_Cast : forall var1 var2 G A A' e1 e2, - wff G e1 e2 -> wff G (Cast var1 A A' e1) (Cast var2 A A' e2)). - Local Infix "<=?" := base_type_leb : expr_scope. - Local Infix "=?" := base_type_beq : expr_scope. - - Local Notation SmartCast_base := (@SmartCast_base _ op _ base_type_bl_transparent Cast). - Local Notation squash_cast := (@squash_cast _ op _ base_type_bl_transparent base_type_leb Cast). - Local Notation maybe_push_cast := (@maybe_push_cast _ op _ base_type_bl_transparent base_type_leb Cast is_cast is_const). - Local Notation push_cast := (@push_cast _ op _ base_type_bl_transparent base_type_leb Cast is_cast is_const). - Local Notation InlineCast := (@InlineCast _ op _ base_type_bl_transparent base_type_leb Cast is_cast is_const). - - Lemma wff_squash_cast var1 var2 a b c e1 e2 G - (Hwf : wff G e1 e2) - : wff G (@squash_cast var1 a b c e1) (@squash_cast var2 a b c e2). - Proof using wff_Cast. - unfold squash_cast; break_innermost_match; auto with wf. - Qed. - - Local Opaque InlineCast.squash_cast. - - Lemma wff_maybe_push_cast_match {var1 var2 t e1 e2 G} - (Hwf : wff G e1 e2) - : match @maybe_push_cast var1 t e1, @maybe_push_cast var2 t e2 with - | Some e1', Some e2' => wff G e1' e2' - | None, None => True - | Some _, None | None, Some _ => False - end. - Proof using wff_Cast. - induction Hwf; - repeat match goal with - | [ |- wff _ (squash_cast _ _ _ _) (squash_cast _ _ _ _) ] - => apply wff_squash_cast - | _ => progress subst - | _ => progress destruct_head' sig - | _ => progress destruct_head' and - | _ => progress inversion_option - | _ => progress simpl in * - | _ => congruence - | _ => progress break_innermost_match_step - | _ => intro - | [ H : forall e1 e2, Some _ = Some e1 -> _ |- _ ] - => specialize (fun e2 => H _ e2 eq_refl) - | [ H : forall e, Some _ = Some e -> _ |- _ ] - => specialize (H _ eq_refl) - | _ => solve [ auto with wf ] - | _ => progress inversion_wf_constr - | _ => progress inversion_flat_type - | [ H : context[match ?e with _ => _ end] |- _ ] => invert_one_expr e - | [ |- context[match ?e with _ => _ end] ] => invert_one_expr e - end. - Qed. - - Lemma wff_maybe_push_cast var1 var2 t e1 e2 G e1' e2' - (Hwf : wff G e1 e2) - : @maybe_push_cast var1 t e1 = Some e1' - -> @maybe_push_cast var2 t e2 = Some e2' - -> wff G e1' e2'. - Proof using wff_Cast. - intros H0 H1; eapply wff_maybe_push_cast_match in Hwf. - rewrite H0, H1 in Hwf; assumption. - Qed. - - Local Notation wff_inline_directive G x y := - (wff G (exprf_of_inline_directive x) (exprf_of_inline_directive y) - /\ (fun x' y' - => match x', y' with - | default_inline _ _, default_inline _ _ - | no_inline _ _, no_inline _ _ - | inline _ _, inline _ _ - => True - | default_inline _ _, _ - | no_inline _ _, _ - | inline _ _, _ - => False - end) x y). - - Lemma wff_push_cast var1 var2 t e1 e2 G - (Hwf : wff G e1 e2) - : wff_inline_directive G (@push_cast var1 t e1) (@push_cast var2 t e2). - Proof using wff_Cast. - pose proof (wff_maybe_push_cast_match Hwf). - unfold push_cast; destruct t; - break_innermost_match; - repeat first [ apply conj - | exact I - | progress simpl in * - | exfalso; assumption - | assumption ]. - Qed. - - Lemma wff_exprf_of_push_cast var1 var2 t e1 e2 G - (Hwf : wff G e1 e2) - : wff G - (exprf_of_inline_directive (@push_cast var1 t e1)) - (exprf_of_inline_directive (@push_cast var2 t e2)). - Proof using wff_Cast. apply wff_push_cast; assumption. Qed. - - Local Hint Resolve wff_push_cast. - - Lemma Wf_InlineCast {t} e (Hwf : Wf e) - : Wf (@InlineCast t e). - Proof using wff_Cast. apply Wf_InlineConstGen; auto. Qed. -End language. - -Hint Resolve Wf_InlineCast : wf. diff --git a/src/Reflection/InlineInterp.v b/src/Reflection/InlineInterp.v deleted file mode 100644 index cb9276d9a..000000000 --- a/src/Reflection/InlineInterp.v +++ /dev/null @@ -1,136 +0,0 @@ -(** * Inline: Remove some [Let] expressions *) -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Reflection.InlineWf. -Require Import Crypto.Reflection.InterpProofs. -Require Import Crypto.Reflection.Inline. -Require Import Crypto.Util.Sigma Crypto.Util.Prod. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.SpecializeBy. - - -Local Open Scope ctype_scope. -Section language. - Context (base_type_code : Type). - Context (interp_base_type : base_type_code -> Type). - Context (op : flat_type base_type_code -> flat_type base_type_code -> Type). - Context (interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst). - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation interp_type := (interp_type interp_base_type). - Local Notation interp_flat_type := (interp_flat_type interp_base_type). - Local Notation exprf := (@exprf base_type_code op). - Local Notation expr := (@expr base_type_code op). - Local Notation Expr := (@Expr base_type_code op). - Local Notation wff := (@wff base_type_code op). - Local Notation wf := (@wf base_type_code op). - - Local Hint Extern 1 => eapply interpf_SmartVarVarf. - - Local Ltac t_fin_step := - match goal with - | _ => reflexivity - | _ => progress simpl in * - | _ => progress unfold postprocess_for_const in * - | _ => progress intros - | _ => progress inversion_sigma - | _ => progress inversion_prod - | _ => solve [ intuition eauto ] - | _ => apply (f_equal (interp_op _ _ _)) - | _ => apply (f_equal2 (@pair _ _)) - | _ => progress specialize_by assumption - | _ => progress subst - | [ H : context[List.In _ (_ ++ _)] |- _ ] => setoid_rewrite List.in_app_iff in H - | [ H : _ = _ :> inline_directive _ |- _ ] - => apply (f_equal exprf_of_inline_directive) in H - | [ H : exprf_of_inline_directive _ = _ |- _ ] - => apply (f_equal (interpf interp_op)) in H - | [ H : @fst ?A ?B ?x = _, H' : context H'T[@fst ?A' ?B' ?x] |- _ ] - => let H'T' := context H'T[@fst A B x] in - progress change H'T' in H' - | [ H : @snd ?A ?B ?x = _, H' : context H'T[@snd ?A' ?B' ?x] |- _ ] - => let H'T' := context H'T[@snd A B x] in - progress change H'T' in H' - | [ H : or _ _ |- _ ] => destruct H - | _ => progress break_match - | _ => rewrite <- !surjective_pairing - | [ H : ?x = _, H' : context[?x] |- _ ] => rewrite H in H' - | [ H : _ |- _ ] => rewrite H; [] - | [ H : _, H' : _ |- _ ] => rewrite H in H' by fail - | [ H : _ |- _ ] => apply H; solve [ repeat t_fin_step ] - | [ H : _ |- _ ] => rewrite H; solve [ repeat t_fin_step ] - end. - Local Ltac t_fin := repeat t_fin_step. - - Lemma interpf_inline_const_genf postprocess G {t} e1 e2 - (wf : @wff _ _ G t e1 e2) - (Hpostprocess : forall t e, interpf interp_op (exprf_of_inline_directive (postprocess t e)) = interpf interp_op e) - (H : forall t x x', - List.In - (existT (fun t : base_type_code => (exprf (Tbase t) * interp_base_type t)%type) t - (x, x')) G - -> interpf interp_op x = x') - : interpf interp_op (inline_const_genf postprocess e1) = interpf interp_op e2. - Proof using Type. - clear -wf H Hpostprocess. - induction wf; t_fin. - Qed. - - Lemma interpf_postprocess_for_const is_const t e - : interpf interp_op (exprf_of_inline_directive (postprocess_for_const is_const t e)) = interpf interp_op e. - Proof using Type. - unfold postprocess_for_const; t_fin. - Qed. - - Local Hint Resolve interpf_postprocess_for_const. - - Lemma interpf_inline_constf is_const G {t} e1 e2 - (wf : @wff _ _ G t e1 e2) - (H : forall t x x', - List.In - (existT (fun t : base_type_code => (exprf (Tbase t) * interp_base_type t)%type) t - (x, x')) G - -> interpf interp_op x = x') - : interpf interp_op (inline_constf is_const e1) = interpf interp_op e2. - Proof using Type. eapply interpf_inline_const_genf; eauto. Qed. - - Local Hint Resolve interpf_inline_constf. - - Lemma interp_inline_const_gen postprocess {t} e1 e2 - (wf : @wf _ _ t e1 e2) - (Hpostprocess : forall t e, interpf interp_op (exprf_of_inline_directive (postprocess t e)) = interpf interp_op e) - : forall x, interp interp_op (inline_const_gen postprocess e1) x = interp interp_op e2 x. - Proof using Type. - destruct wf. - simpl in *; intro; eapply (interpf_inline_const_genf postprocess); eauto. - Qed. - - Local Hint Resolve interp_inline_const_gen. - - Lemma interp_inline_const is_const {t} e1 e2 - (wf : @wf _ _ t e1 e2) - : forall x, interp interp_op (inline_const is_const e1) x = interp interp_op e2 x. - Proof using Type. - eapply interp_inline_const_gen; eauto. - Qed. - - Lemma InterpInlineConstGen postprocess {t} (e : Expr t) - (wf : Wf e) - (Hpostprocess : forall t e, interpf interp_op (exprf_of_inline_directive (postprocess _ t e)) = interpf interp_op e) - : forall x, Interp interp_op (InlineConstGen postprocess e) x = Interp interp_op e x. - Proof using Type. - unfold Interp, InlineConst. - eapply (interp_inline_const_gen (postprocess _)); simpl; intuition. - Qed. - - Lemma InterpInlineConst is_const {t} (e : Expr t) - (wf : Wf e) - : forall x, Interp interp_op (InlineConst is_const e) x = Interp interp_op e x. - Proof using Type. - eapply InterpInlineConstGen; eauto. - Qed. -End language. - -Hint Rewrite @InterpInlineConst @interp_inline_const @interpf_inline_constf using solve [ eassumption | eauto with wf ] : reflective_interp. diff --git a/src/Reflection/InlineWf.v b/src/Reflection/InlineWf.v deleted file mode 100644 index 20ae25010..000000000 --- a/src/Reflection/InlineWf.v +++ /dev/null @@ -1,225 +0,0 @@ -(** * Inline: Remove some [Let] expressions *) -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.TypeInversion. -Require Import Crypto.Reflection.ExprInversion. -Require Import Crypto.Reflection.WfProofs. -Require Import Crypto.Reflection.WfInversion. -Require Import Crypto.Reflection.Inline. -Require Import Crypto.Util.Tactics.SpecializeBy Crypto.Util.Tactics.DestructHead Crypto.Util.Sigma Crypto.Util.Prod. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.UniquePose. -Require Import Crypto.Util.Tactics.SplitInContext. - -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type}. - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation Tbase := (@Tbase base_type_code). - Local Notation exprf := (@exprf base_type_code op). - Local Notation expr := (@expr base_type_code op). - Local Notation Expr := (@Expr base_type_code op). - Local Notation wff := (@wff base_type_code op). - Local Notation wf := (@wf base_type_code op). - - Local Notation wff_inline_directive G x y := - (wff G (exprf_of_inline_directive x) (exprf_of_inline_directive y) - /\ (fun x' y' - => match x', y' with - | default_inline _ _, default_inline _ _ - | no_inline _ _, no_inline _ _ - | inline _ _, inline _ _ - => True - | default_inline _ _, _ - | no_inline _ _, _ - | inline _ _, _ - => False - end) x y). - - - Section with_var. - Context {var1 var2 : base_type_code -> Type}. - - Local Hint Constructors Wf.wff. - Local Hint Resolve List.in_app_or List.in_or_app. - - Local Hint Constructors or. - Local Hint Constructors Wf.wff. - Local Hint Extern 1 => progress unfold List.In in *. - Local Hint Resolve wff_in_impl_Proper. - Local Hint Resolve wff_SmartVarf. - Local Hint Resolve wff_SmartVarVarf. - - Local Ltac t_fin := - repeat first [ intro - | progress inversion_sigma - | progress inversion_prod - | tauto - | progress subst - | solve [ auto with nocore - | eapply (@wff_SmartVarVarf _ _ _ _ _ _ (_ * _)); auto - | eapply wff_SmartVarVarf; eauto with nocore ] - | progress simpl in * - | constructor - | solve [ eauto ] ]. - - Local Ltac invert_inline_directive' i := - preinvert_one_type i; - intros ? i; - destruct i; - try exact I. - Local Ltac invert_inline_directive := - match goal with - | [ i : inline_directive _ |- _ ] => invert_inline_directive' i - end. - - (** XXX TODO: Clean up this proof *) - Lemma wff_inline_const_genf postprocess1 postprocess2 {t} e1 e2 G G' - (H : forall t x x', List.In (existT (fun t : base_type_code => (exprf (Tbase t) * exprf (Tbase t))%type) t (x, x')) G' - -> wff G x x') - (wf : wff G' e1 e2) - (wf_postprocess : forall G t e1 e2, - wff G e1 e2 - -> wff_inline_directive G (postprocess1 t e1) (postprocess2 t e2)) - : @wff var1 var2 G t (inline_const_genf postprocess1 e1) (inline_const_genf postprocess2 e2). - Proof using Type. - revert dependent G; induction wf; simpl in *; auto; intros; []. - repeat match goal with - | [ H : context[List.In _ (_ ++ _)] |- _ ] - => setoid_rewrite List.in_app_iff in H - | [ |- context[postprocess1 ?t ?e1] ] - => match goal with - | [ |- context[postprocess2 t ?e2] ] - => specialize (fun G => wf_postprocess G t e1 e2); - generalize dependent (postprocess1 t e1); - generalize dependent (postprocess2 t e2) - end - | _ => intro - end. - repeat match goal with - | [ H : forall G : list _, _ |- wff ?G' _ _ ] - => unique pose proof (H G') - | [ H : forall x y (G : list _), _ |- wff ?G' _ _ ] - => unique pose proof (fun x y => H x y G') - | [ H : forall x1 x2, (forall t x x', _ \/ List.In _ ?G -> wff ?G0 x x') -> _, - H' : forall t1 x1 x1', List.In _ ?G -> wff ?G0 x1 x1' |- _ ] - => unique pose proof (fun x1 x2 f => H x1 x2 (fun t x x' pf => match pf with or_introl pf => f t x x' pf | or_intror pf => H' t x x' pf end)) - end. - repeat match goal with - | _ => exact I - | [ H : forall x1 : unit, _ |- _ ] => specialize (H tt) - | [ H : False |- _ ] => exfalso; assumption - | _ => progress subst - | _ => progress inversion_sigma - | _ => progress inversion_prod - | _ => progress destruct_head' and - | _ => inversion_wf_step; progress subst - | _ => progress specialize_by_assumption - | _ => progress break_match - | _ => progress invert_inline_directive - | [ |- context[match ?e with _ => _ end] ] - => invert_one_expr e - | _ => progress destruct_head' or - | _ => progress simpl in * - | _ => intro - | _ => progress split_and - | [ H : wff _ TT _ |- _ ] => solve [ inversion H ] - | [ H : wff _ (Var _ _) _ |- _ ] => solve [ inversion H ] - | [ H : wff _ (Op _ _) _ |- _ ] => solve [ inversion H ] - | [ H : wff _ (LetIn _ _) _ |- _ ] => solve [ inversion H ] - | [ H : wff _ (Pair _ _) _ |- _ ] => solve [ inversion H ] - end; - repeat first [ progress specialize_by tauto - | progress specialize_by auto - | solve [ auto ] ]; - try (constructor; auto; intros). - { match goal with H : _ |- _ => apply H end. - intros; destruct_head or; t_fin. } - { match goal with H : _ |- _ => apply H end. - intros; destruct_head or; t_fin. } - { match goal with H : _ |- _ => apply H end. - intros; destruct_head or; t_fin. } - { match goal with H : _ |- _ => apply H end. - intros; destruct_head' or; t_fin. } - { match goal with H : _ |- _ => apply H end. - intros; destruct_head or; t_fin. } - { match goal with H : _ |- _ => apply H end. - intros; destruct_head or; t_fin. } - Qed. - - Lemma wff_postprocess_for_const is_const G t - (e1 : @exprf var1 t) - (e2 : @exprf var2 t) - (Hwf : wff G e1 e2) - : wff_inline_directive G (postprocess_for_const is_const t e1) (postprocess_for_const is_const t e2). - Proof using Type. - destruct e1; unfold postprocess_for_const; - repeat first [ progress subst - | intro - | progress destruct_head' sig - | progress destruct_head' and - | progress inversion_sigma - | progress inversion_option - | progress inversion_prod - | progress destruct_head' False - | progress simpl in * - | progress invert_expr - | progress inversion_wf - | progress break_innermost_match_step - | discriminate - | congruence - | solve [ auto ] ]. - Qed. - - Local Hint Resolve wff_postprocess_for_const. - - Lemma wff_inline_constf is_const {t} e1 e2 G G' - (H : forall t x x', List.In (existT (fun t : base_type_code => (exprf (Tbase t) * exprf (Tbase t))%type) t (x, x')) G' - -> wff G x x') - (wf : wff G' e1 e2) - : @wff var1 var2 G t (inline_constf is_const e1) (inline_constf is_const e2). - Proof using Type. eapply wff_inline_const_genf; eauto. Qed. - - Lemma wf_inline_const_gen postprocess1 postprocess2 {t} e1 e2 - (Hwf : wf e1 e2) - (wf_postprocess : forall G t e1 e2, - wff G e1 e2 - -> wff_inline_directive G (postprocess1 t e1) (postprocess2 t e2)) - : @wf var1 var2 t (inline_const_gen postprocess1 e1) (inline_const_gen postprocess2 e2). - Proof using Type. - destruct Hwf; constructor; intros. - eapply wff_inline_const_genf; eauto using wff_SmartVarVarf_nil. - Qed. - - Lemma wf_inline_const is_const {t} e1 e2 - (Hwf : wf e1 e2) - : @wf var1 var2 t (inline_const is_const e1) (inline_const is_const e2). - Proof using Type. eapply wf_inline_const_gen; eauto. Qed. - End with_var. - - Lemma Wf_InlineConstGen postprocess {t} (e : Expr t) - (Hwf : Wf e) - (Hpostprocess : forall var1 var2 G t e1 e2, - wff G e1 e2 - -> wff_inline_directive G (postprocess var1 t e1) (postprocess var2 t e2)) - : Wf (InlineConstGen postprocess e). - Proof using Type. - intros var1 var2. - apply (@wf_inline_const_gen var1 var2 (postprocess _) (postprocess _) t (e _) (e _)); simpl; auto. - Qed. - - Lemma Wf_InlineConst is_const {t} (e : Expr t) - (Hwf : Wf e) - : Wf (InlineConst is_const e). - Proof using Type. - intros var1 var2. - apply (@wf_inline_const var1 var2 is_const t (e _) (e _)); simpl. - apply Hwf. - Qed. -End language. - -Hint Resolve Wf_InlineConstGen Wf_InlineConst : wf. diff --git a/src/Reflection/InputSyntax.v b/src/Reflection/InputSyntax.v deleted file mode 100644 index 123e4f851..000000000 --- a/src/Reflection/InputSyntax.v +++ /dev/null @@ -1,251 +0,0 @@ -(** * PHOAS Representation of Gallina which allows exact denotation *) -Require Import Coq.Strings.String. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.ExprInversion. -Require Import Crypto.Reflection.InterpProofs. -Require Import Crypto.Util.Tuple. -Require Import Crypto.Util.Tactics.RewriteHyp. -Require Import Crypto.Util.Notations. - -(** We parameterize the language over a type of basic type codes (for - things like [Z], [word], [bool]), as well as a type of n-ary - operations returning one value, and n-ary operations returning two - values. *) -Local Open Scope ctype_scope. -Section language. - Context (base_type_code : Type). - - Local Notation flat_type := (flat_type base_type_code). - Inductive type := Tflat (A : flat_type) | Arrow (A : flat_type) (B : type). - - Section expr_param. - Context (interp_base_type : base_type_code -> Type). - Context (op : flat_type (* input tuple *) -> flat_type (* output type *) -> Type). - Local Notation interp_flat_type_gen := interp_flat_type. - Local Notation interp_flat_type := (interp_flat_type interp_base_type). - - Fixpoint interp_type (t : type) := - match t with - | Tflat A => interp_flat_type A - | Arrow A B => (interp_flat_type A -> interp_type B)%type - end. - - Section expr. - Context {var : flat_type -> Type}. - - (** N.B. [Let] destructures pairs *) - Inductive exprf : flat_type -> Type := - | Const {t : flat_type} : interp_flat_type t -> exprf t - | Var {t} : var t -> exprf t - | Op {t1 tR} : op t1 tR -> exprf t1 -> exprf tR - | LetIn : forall {tx}, exprf tx -> forall {tC}, (var tx -> exprf tC) -> exprf tC - | Pair : forall {t1}, exprf t1 -> forall {t2}, exprf t2 -> exprf (Prod t1 t2) - | MatchPair : forall {t1 t2}, exprf (Prod t1 t2) -> forall {tC}, (var t1 -> var t2 -> exprf tC) -> exprf tC. - Inductive expr : type -> Type := - | Return {T} : exprf T -> expr (Tflat T) - | Abs {src dst} : (var src -> expr dst) -> expr (Arrow src dst). - - Definition Fst {t1 t2} (v : exprf (Prod t1 t2)) : exprf t1 := MatchPair v (fun x y => Var x). - Definition Snd {t1 t2} (v : exprf (Prod t1 t2)) : exprf t2 := MatchPair v (fun x y => Var y). - End expr. - - Definition Expr (t : type) := forall var, @expr var t. - - Section interp. - Context (interp_op : forall src dst, op src dst -> interp_flat_type src -> interp_flat_type dst). - - Fixpoint interpf {t} (e : @exprf interp_flat_type t) : interp_flat_type t - := match e in exprf t return interp_flat_type t with - | Const _ x => x - | Var _ x => x - | Op _ _ op args => @interp_op _ _ op (@interpf _ args) - | LetIn _ ex _ eC => let x := @interpf _ ex in @interpf _ (eC x) - | Pair _ ex _ ey => (@interpf _ ex, @interpf _ ey) - | MatchPair _ _ ex _ eC => match @interpf _ ex with pair x y => @interpf _ (eC x y) end - end. - Fixpoint interp {t} (e : @expr interp_flat_type t) : interp_type t - := match e in expr t return interp_type t with - | Return _ v => interpf v - | Abs _ _ f => fun x => @interp _ (f x) - end. - - Definition Interp {t} (E : Expr t) : interp_type t := interp (E _). - End interp. - - Section compile. - Context {var : base_type_code -> Type} - (make_const : forall t, interp_base_type t -> op Unit (Tbase t)). - - Fixpoint compilet (t : type) : Syntax.type base_type_code - := Syntax.Arrow - match t with - | Tflat T => Unit - | Arrow A (Tflat B) => A - | Arrow A B - => A * domain (compilet B) - end%ctype - match t with - | Tflat T => T - | Arrow A B => codomain (compilet B) - end. - - Fixpoint SmartConst (t : flat_type) : interp_flat_type t -> Syntax.exprf base_type_code op (var:=var) t - := match t return interp_flat_type t -> Syntax.exprf _ _ t with - | Unit => fun _ => TT - | Tbase _ => fun v => Syntax.Op (make_const _ v) TT - | Prod _ _ => fun v => Syntax.Pair (@SmartConst _ (fst v)) - (@SmartConst _ (snd v)) - end. - - Fixpoint compilef {t} (e : @exprf (interp_flat_type_gen var) t) : @Syntax.exprf base_type_code op var t - := match e in exprf t return @Syntax.exprf _ _ _ t with - | Const _ x => @SmartConst _ x - | Var _ x => SmartMap.SmartVarf x - | Op _ _ op args => Syntax.Op op (@compilef _ args) - | LetIn _ ex _ eC => Syntax.LetIn (@compilef _ ex) (fun x => @compilef _ (eC x)) - | Pair _ ex _ ey => Syntax.Pair (@compilef _ ex) (@compilef _ ey) - | MatchPair _ _ ex _ eC => Syntax.LetIn (@compilef _ ex) (fun xy => @compilef _ (eC (fst xy) (snd xy))) - end. - - (* ugh, so much manual annotation *) - Fixpoint compile {t} (e : @expr (interp_flat_type_gen var) t) : @Syntax.expr base_type_code op var (compilet t) - := match e in expr t return @Syntax.expr _ _ _ (compilet t) with - | Return _ v => Syntax.Abs (fun _ => compilef v) - | Abs src dst f - => let res := fun x => @compile _ (f x) in - match dst - return (_ -> Syntax.expr _ _ (compilet dst)) - -> Syntax.expr _ _ (compilet (Arrow src dst)) - with - | Tflat T - => fun resf => Syntax.Abs (fun x => invert_Abs (resf x) tt) - | Arrow A B as dst' - => match compilet dst' as cdst - return (_ -> Syntax.expr _ _ cdst) - -> Syntax.expr _ _ (Syntax.Arrow - (_ * domain cdst) - (codomain cdst)) - with - | Syntax.Arrow A' B' - => fun resf => Syntax.Abs (fun x : interp_flat_type_gen var (_ * _) - => invert_Abs (resf (fst x)) (snd x)) - end - end res - end. - End compile. - - Definition Compile - (make_const : forall t, interp_base_type t -> op Unit (Tbase t)) - {t} (e : Expr t) : Syntax.Expr base_type_code op (compilet t) - := fun var => compile make_const (e _). - - Section compile_correct. - Context (make_const : forall t, interp_base_type t -> op Unit (Tbase t)) - (interp_op : forall src dst, op src dst -> interp_flat_type src -> interp_flat_type dst) - (make_const_correct : forall T v, interp_op Unit (Tbase T) (make_const T v) tt = v). - - Lemma SmartConst_correct t v - : Syntax.interpf interp_op (SmartConst make_const t v) = v. - Proof using Type*. - induction t; try destruct v; simpl in *; congruence. - Qed. - - Lemma compilef_correct {t} (e : @exprf interp_flat_type t) - : Syntax.interpf interp_op (compilef make_const e) = interpf interp_op e. - Proof using Type*. - induction e; - repeat match goal with - | _ => reflexivity - | _ => progress unfold LetIn.Let_In - | _ => progress simpl in * - | _ => rewrite interpf_SmartVarf - | _ => rewrite SmartConst_correct - | _ => rewrite <- surjective_pairing - | _ => progress rewrite_hyp * - | [ |- context[let (x, y) := ?v in _] ] - => rewrite (surjective_pairing v); cbv beta iota - end. - Qed. - - Lemma compile_flat_correct {T} (e : expr (Tflat T)) - : forall x, Syntax.interp interp_op (compile make_const e) x = interp interp_op e. - Proof using Type*. - intros []; simpl. - let G := match goal with |- ?G => G end in - let G := match (eval pattern T, e in G) with ?G _ _ => G end in - refine match e in expr t return match t return expr t -> _ with - | Tflat T => G T - | _ => fun _ => True - end e - with - | Return _ _ => _ - | Abs _ _ _ => I - end; simpl. - apply compilef_correct. - Qed. - - Lemma Compile_flat_correct_flat {T} (e : Expr (Tflat T)) - : forall x, Syntax.Interp interp_op (Compile make_const e) x = Interp interp_op e. - Proof using Type*. apply compile_flat_correct. Qed. - - Lemma Compile_correct {src dst} (e : @Expr (Arrow src (Tflat dst))) - : forall x, Syntax.Interp interp_op (Compile make_const e) x = Interp interp_op e x. - Proof using Type*. - unfold Interp, Compile, Syntax.Interp; simpl. - pose (e interp_flat_type) as E. - repeat match goal with |- context[e ?f] => change (e f) with E end. - clearbody E; clear e. - let G := match goal with |- ?G => G end in - let G := match (eval pattern src, dst, E in G) with ?G _ _ _ => G end in - refine match E in expr t return match t return expr t -> _ with - | Arrow src (Tflat dst) => G src dst - | _ => fun _ => True - end E - with - | Abs src dst e - => match dst - return (forall e : _ -> expr dst, - match dst return expr (Arrow src dst) -> _ with - | Tflat dst => G src dst - | _ => fun _ => True - end (Abs e)) - with - | Tflat _ - => fun e0 x - => _ - | Arrow _ _ => fun _ => I - end e - | Return _ _ => I - end; simpl. - refine match e0 x as e0x in expr t - return match t return expr t -> _ with - | Tflat _ - => fun e0x - => Syntax.interpf _ (invert_Abs (compile _ e0x) _) - = interp _ e0x - | _ => fun _ => True - end e0x - with - | Abs _ _ _ => I - | Return _ _ => _ - end; simpl. - apply compilef_correct. - Qed. - End compile_correct. - End expr_param. -End language. - -Global Arguments Arrow {_} _ _. -Global Arguments Tflat {_} _. -Global Arguments Const {_ _ _ _ _} _. -Global Arguments Var {_ _ _ _ _} _. -Global Arguments Op {_ _ _ _ _ _} _ _. -Global Arguments LetIn {_ _ _ _ _} _ {_} _. -Global Arguments MatchPair {_ _ _ _ _ _} _ {_} _. -Global Arguments Fst {_ _ _ _ _ _} _. -Global Arguments Snd {_ _ _ _ _ _} _. -Global Arguments Pair {_ _ _ _ _} _ {_} _. -Global Arguments Return {_ _ _ _ _} _. -Global Arguments Abs {_ _ _ _ _ _} _. -Global Arguments Compile {_ _ _} make_const {t} _ _. diff --git a/src/Reflection/InterpByIso.v b/src/Reflection/InterpByIso.v deleted file mode 100644 index a971b8e88..000000000 --- a/src/Reflection/InterpByIso.v +++ /dev/null @@ -1,33 +0,0 @@ -(** * PHOAS interpretation function for any retract of [var:=interp_base_type] *) -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.ExprInversion. -Require Import Crypto.Reflection.SmartMap. - -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - {interp_base_type : base_type_code -> Type} - (interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst) - {var : base_type_code -> Type} - (var_of_interp : forall t, interp_base_type t -> var t) - (interp_of_var : forall t, var t -> interp_base_type t) - (var_is_retract : forall t x, interp_of_var t (var_of_interp t x) = x). - - Fixpoint interpf_retr {t} (e : @exprf base_type_code op var t) - : interp_flat_type interp_base_type t - := match e in exprf _ _ t return interp_flat_type interp_base_type t with - | TT => tt - | Var t v => interp_of_var _ v - | Op t1 tR opc args => interp_op _ _ opc (@interpf_retr _ args) - | LetIn tx ex tC eC - => let ev := @interpf_retr _ ex in - @interpf_retr _ (eC (SmartVarfMap var_of_interp ev)) - | Pair tx ex ty ey => (@interpf_retr _ ex, @interpf_retr _ ey) - end. - - Definition interp_retr {t} (e : @expr base_type_code op var t) - : interp_type interp_base_type t - := fun x => interpf_retr (invert_Abs e (SmartVarfMap var_of_interp x)). -End language. - -Global Arguments interp_retr _ _ _ _ _ _ _ _ !_ / _ . diff --git a/src/Reflection/InterpByIsoProofs.v b/src/Reflection/InterpByIsoProofs.v deleted file mode 100644 index 07ad8ed62..000000000 --- a/src/Reflection/InterpByIsoProofs.v +++ /dev/null @@ -1,117 +0,0 @@ -(** * PHOAS interpretation function for any retract of [var:=interp_base_type] *) -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.InterpByIso. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.WfProofs. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Util.Sigma. -Require Import Crypto.Util.Prod. -Require Import Crypto.Util.Tactics.RewriteHyp. -Require Import Crypto.Util.Tactics.DestructHead. - -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - {interp_base_type : base_type_code -> Type} - (interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst). - - Local Notation exprf := (@exprf base_type_code op). - Local Notation expr := (@expr base_type_code op). - Local Notation interpf_retr := (@interpf_retr base_type_code op interp_base_type interp_op). - Local Notation interp_retr := (@interp_retr base_type_code op interp_base_type interp_op). - - Lemma interpf_retr_id {t} (e : @exprf interp_base_type t) - : interpf_retr (fun _ x => x) (fun _ x => x) e = interpf interp_op e. - Proof using Type. - induction e; simpl; cbv [LetIn.Let_In]; rewrite_hyp ?*; rewrite ?SmartVarfMap_id; reflexivity. - Qed. - Lemma interp_retr_id {t} (e : @expr interp_base_type t) - : forall x, - interp_retr (fun _ x => x) (fun _ x => x) e x = interp interp_op e x. - Proof using Type. - destruct e; simpl; intros; rewrite interpf_retr_id, SmartVarfMap_id; reflexivity. - Qed. - - Section with_var2. - Context {var1 var2 : base_type_code -> Type} - (var1_of_interp : forall t, interp_base_type t -> var1 t) - (interp_of_var1 : forall t, var1 t -> interp_base_type t) - (var2_of_interp : forall t, interp_base_type t -> var2 t) - (interp_of_var2 : forall t, var2 t -> interp_base_type t) - (interp_of_var12 : forall t x, interp_of_var1 t (var1_of_interp t x) - = interp_of_var2 t (var2_of_interp t x)). - Hint Rewrite @flatten_binding_list_SmartVarfMap @List.in_map_iff @List.in_app_iff. - Lemma interp_of_var12_SmartVarfMap - t1 e1 t x1 x2 - (H : List.In (existT _ t (x1, x2)) - (flatten_binding_list - (SmartVarfMap (t:=t1) var1_of_interp e1) - (SmartVarfMap var2_of_interp e1))) - : interp_of_var1 t x1 = interp_of_var2 t x2. - Proof using interp_of_var12. - repeat first [ progress repeat autorewrite with core in * - | progress subst - | progress inversion_sigma - | progress inversion_prod - | progress simpl in * - | progress destruct_head' ex - | progress destruct_head' and - | progress destruct_head' or - | progress destruct_head' sigT - | progress destruct_head' prod - | progress rewrite_hyp !* - | solve [ auto ] ]. - do 2 apply f_equal. - eapply interp_flat_type_rel_pointwise_flatten_binding_list with (R':=fun _ => eq); [ eassumption | ]. - apply lift_interp_flat_type_rel_pointwise_f_eq; reflexivity. - Qed. - Local Hint Resolve List.in_app_or interp_of_var12_SmartVarfMap. - - Lemma wff_interpf_retr G {t} (e1 : @exprf var1 t) (e2 : @exprf var2 t) - (HG : forall t x1 x2, - List.In (existT _ t (x1, x2)) G - -> interp_of_var1 t x1 = interp_of_var2 t x2) - (Hwf : wff G e1 e2) - : interpf_retr var1_of_interp interp_of_var1 e1 - = interpf_retr var2_of_interp interp_of_var2 e2. - Proof using interp_of_var12. - induction Hwf; simpl; rewrite_hyp ?*; try reflexivity; auto. - { match goal with H : _ |- _ => apply H end. - intros ???; rewrite List.in_app_iff. - intros [?|?]; eauto. } - Qed. - Lemma wf_interp_retr {t} (e1 : @expr var1 t) (e2 : @expr var2 t) - (Hwf : wf e1 e2) - : forall x, - interp_retr var1_of_interp interp_of_var1 e1 x - = interp_retr var2_of_interp interp_of_var2 e2 x. - Proof using interp_of_var12. - destruct Hwf; simpl; repeat intro; subst; eapply wff_interpf_retr; eauto. - Qed. - End with_var2. - - Section with_var. - Context {var : base_type_code -> Type} - (var_of_interp : forall t, interp_base_type t -> var t) - (interp_of_var : forall t, var t -> interp_base_type t) - (var_is_retract : forall t x, interp_of_var t (var_of_interp t x) = x). - Lemma wff_interpf_retr_correct G {t} (e1 : @exprf var t) (e2 : @exprf interp_base_type t) - (HG : forall t x1 x2, - List.In (existT _ t (x1, x2)) G - -> interp_of_var t x1 = x2) - (Hwf : wff G e1 e2) - : interpf_retr var_of_interp interp_of_var e1 = interpf interp_op e2. - Proof using var_is_retract. - erewrite wff_interpf_retr, interpf_retr_id; eauto. - Qed. - Lemma wf_interp_retr_correct {t} (e1 : @expr var t) (e2 : @expr interp_base_type t) - (Hwf : wf e1 e2) - x - : interp_retr var_of_interp interp_of_var e1 x - = interp interp_op e2 x. - Proof using var_is_retract. - erewrite wf_interp_retr, interp_retr_id; eauto. - Qed. - End with_var. -End language. diff --git a/src/Reflection/InterpProofs.v b/src/Reflection/InterpProofs.v deleted file mode 100644 index 5d8322441..000000000 --- a/src/Reflection/InterpProofs.v +++ /dev/null @@ -1,66 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.WfProofs. -Require Import Crypto.Util.LetIn. -Require Import Crypto.Util.Sigma Crypto.Util.Prod. -Require Import Crypto.Util.Tactics.RewriteHyp. - -Local Open Scope ctype_scope. -Section language. - Context (base_type_code : Type). - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Context (interp_base_type : base_type_code -> Type). - Context (op : flat_type (* input tuple *) -> flat_type (* output type *) -> Type). - Local Notation interp_type := (interp_type interp_base_type). - Local Notation interp_flat_type := (interp_flat_type interp_base_type). - Context (interp_op : forall src dst, op src dst -> interp_flat_type src -> interp_flat_type dst). - - Lemma interpf_LetIn tx ex tC eC - : Syntax.interpf interp_op (LetIn (tx:=tx) ex (tC:=tC) eC) - = dlet x := Syntax.interpf interp_op ex in - Syntax.interpf interp_op (eC x). - Proof using Type. reflexivity. Qed. - - Lemma interpf_SmartVarf t v - : Syntax.interpf interp_op (SmartVarf (t:=t) v) = v. - Proof using Type. - unfold SmartVarf; induction t; - repeat match goal with - | _ => reflexivity - | _ => progress simpl in * - | _ => progress rewrite_hyp * - | _ => rewrite <- surjective_pairing - end. - Qed. - - Lemma interpf_SmartVarVarf {t t'} v x x' - (Hin : List.In - (existT (fun t : base_type_code => (exprf base_type_code op (Tbase t) * interp_base_type t)%type) - t (x, x')) - (flatten_binding_list (t := t') (SmartVarVarf v) v)) - : interpf interp_op x = x'. - Proof using Type. - clear -Hin. - induction t'; simpl in *; try tauto. - { intuition (inversion_sigma; inversion_prod; subst; eauto). } - { apply List.in_app_iff in Hin. - intuition (inversion_sigma; inversion_prod; subst; eauto). } - Qed. - - Lemma interpf_SmartVarVarf_eq {t t'} v v' x x' - (Heq : v = v') - (Hin : List.In - (existT (fun t : base_type_code => (exprf base_type_code op (Tbase t) * interp_base_type t)%type) - t (x, x')) - (flatten_binding_list (t := t') (SmartVarVarf v') v)) - : interpf interp_op x = x'. - Proof using Type. - subst; eapply interpf_SmartVarVarf; eassumption. - Qed. -End language. - -Hint Rewrite @interpf_LetIn @interpf_SmartVarf : reflective_interp. -Hint Rewrite @interpf_SmartVarVarf using assumption : reflective_interp. diff --git a/src/Reflection/InterpWf.v b/src/Reflection/InterpWf.v deleted file mode 100644 index 5f76e0791..000000000 --- a/src/Reflection/InterpWf.v +++ /dev/null @@ -1,80 +0,0 @@ -Require Import Coq.Strings.String Coq.Classes.RelationClasses. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Util.Tuple. -Require Import Crypto.Util.Sigma. -Require Import Crypto.Util.Prod. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Tactics.SpecializeBy. -Require Import Crypto.Util.Tactics.RewriteHyp. -Require Import Crypto.Util.Notations. -Local Open Scope ctype_scope. -Local Open Scope expr_scope. - -Section language. - Context {base_type_code : Type} - {interp_base_type : base_type_code -> Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - (interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst). - - Local Notation exprf := (@exprf base_type_code op interp_base_type). - Local Notation expr := (@expr base_type_code op interp_base_type). - Local Notation Expr := (@Expr base_type_code op). - Local Notation interpf := (@interpf base_type_code interp_base_type op interp_op). - Local Notation interp := (@interp base_type_code interp_base_type op interp_op). - Local Notation Interp := (@Interp base_type_code interp_base_type op interp_op). - - Lemma eq_in_flatten_binding_list - {t x x' T e} - (HIn : List.In (existT (fun t : base_type_code => (interp_base_type t * interp_base_type t)%type) t (x, x')%core) - (flatten_binding_list (t:=T) e e)) - : x = x'. - Proof using Type. - induction T; simpl in *; [ | | rewrite List.in_app_iff in HIn ]; - repeat first [ progress destruct_head or - | progress destruct_head False - | progress destruct_head and - | progress inversion_sigma - | progress inversion_prod - | progress subst - | solve [ eauto ] ]. - Qed. - - - Local Hint Resolve List.in_app_or List.in_or_app eq_in_flatten_binding_list. - - Section wf. - Lemma interpf_wff - {t} {e1 e2 : exprf t} - {G} - (HG : forall t x x', - List.In (existT (fun t : base_type_code => (interp_base_type t * interp_base_type t)%type) t (x, x')%core) G - -> x = x') - (Rwf : wff G e1 e2) - : interpf e1 = interpf e2. - Proof using Type. - induction Rwf; simpl; auto; - specialize_by auto; try congruence. - rewrite_hyp !*; auto. - repeat match goal with - | [ H : context[List.In _ (_ ++ _)] |- _ ] - => setoid_rewrite List.in_app_iff in H - end. - match goal with - | [ H : _ |- _ ] - => apply H; intros; destruct_head' or; solve [ eauto ] - end. - Qed. - - Local Hint Resolve interpf_wff. - - Lemma interp_wf - {t} {e1 e2 : expr t} - (Rwf : wf e1 e2) - : forall x, interp e1 x = interp e2 x. - Proof using Type. - destruct Rwf; simpl; eauto. - Qed. - End wf. -End language. diff --git a/src/Reflection/InterpWfRel.v b/src/Reflection/InterpWfRel.v deleted file mode 100644 index 40288232a..000000000 --- a/src/Reflection/InterpWfRel.v +++ /dev/null @@ -1,94 +0,0 @@ -Require Import Coq.Strings.String Coq.Classes.RelationClasses. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Util.Tuple. -Require Import Crypto.Util.Sigma. -Require Import Crypto.Util.Prod. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Notations. -Local Open Scope ctype_scope. -Local Open Scope expr_scope. - -Section language. - Context {base_type_code : Type} - {interp_base_type1 interp_base_type2 : base_type_code -> Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - (interp_op1 : forall src dst, op src dst -> interp_flat_type interp_base_type1 src -> interp_flat_type interp_base_type1 dst) - (interp_op2 : forall src dst, op src dst -> interp_flat_type interp_base_type2 src -> interp_flat_type interp_base_type2 dst) - {R : forall t, interp_base_type1 t -> interp_base_type2 t -> Prop} - (Rop : forall src dst op sv1 sv2, interp_flat_type_rel_pointwise R sv1 sv2 - -> interp_flat_type_rel_pointwise - R (interp_op1 src dst op sv1) (interp_op2 src dst op sv2)). - - Local Notation exprf1 := (@exprf base_type_code op interp_base_type1). - Local Notation exprf2 := (@exprf base_type_code op interp_base_type2). - Local Notation expr1 := (@expr base_type_code op interp_base_type1). - Local Notation expr2 := (@expr base_type_code op interp_base_type2). - Local Notation Expr := (@Expr base_type_code op). - Local Notation interpf1 := (@interpf base_type_code interp_base_type1 op interp_op1). - Local Notation interpf2 := (@interpf base_type_code interp_base_type2 op interp_op2). - Local Notation interp1 := (@interp base_type_code interp_base_type1 op interp_op1). - Local Notation interp2 := (@interp base_type_code interp_base_type2 op interp_op2). - Local Notation Interp1 := (@Interp base_type_code interp_base_type1 op interp_op1). - Local Notation Interp2 := (@Interp base_type_code interp_base_type2 op interp_op2). - - Lemma interp_flat_type_rel_pointwise_flatten_binding_list - {t x x' T e1 e2} - (Hpointwise : interp_flat_type_rel_pointwise R e1 e2) - (HIn : List.In (existT (fun t : base_type_code => (interp_base_type1 t * interp_base_type2 t)%type) t (x, x')%core) - (flatten_binding_list (t:=T) e1 e2)) - : R t x x'. - Proof using Type. - induction T; simpl in *; try tauto; [ | rewrite List.in_app_iff in HIn ]; - repeat first [ progress destruct_head or - | progress destruct_head False - | progress destruct_head and - | progress inversion_sigma - | progress inversion_prod - | progress subst - | solve [ eauto ] ]. - Qed. - - Local Hint Resolve List.in_app_or List.in_or_app interp_flat_type_rel_pointwise_flatten_binding_list. - - Section wf. - Lemma interpf_wff - {t} {e1 : exprf1 t} {e2 : exprf2 t} - {G} - (HG : forall t x x', - List.In (existT (fun t : base_type_code => (interp_base_type1 t * interp_base_type2 t)%type) t (x, x')%core) G - -> R t x x') - (Rwf : wff G e1 e2) - : interp_flat_type_rel_pointwise R (interpf1 e1) (interpf2 e2). - Proof using Type*. - induction Rwf; simpl; auto. - repeat match goal with - | [ H : context[List.In _ (_ ++ _)] |- _ ] - => setoid_rewrite List.in_app_iff in H - end. - match goal with - | [ H : _ |- _ ] - => apply H; intros; destruct_head' or; solve [ eauto ] - end. - Qed. - - Local Hint Resolve interpf_wff. - - Lemma interp_wf - {t} {e1 : expr1 t} {e2 : expr2 t} - (Rwf : wf e1 e2) - : interp_type_rel_pointwise R (interp1 e1) (interp2 e2). - Proof using Type*. - destruct Rwf; simpl; repeat intro; eauto. - Qed. - - Lemma InterpWf - {t} {e : Expr t} - (Rwf : Wf e) - : interp_type_rel_pointwise R (Interp1 e) (Interp2 e). - Proof using Type*. - unfold Interp, Wf in *; apply interp_wf; simpl; intuition. - Qed. - End wf. -End language. diff --git a/src/Reflection/Linearize.v b/src/Reflection/Linearize.v deleted file mode 100644 index 9fc45c798..000000000 --- a/src/Reflection/Linearize.v +++ /dev/null @@ -1,63 +0,0 @@ -(** * Linearize: Place all and only operations in let binders *) -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.SmartMap. -(*Require Import Crypto.Util.Tactics.*) - -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type}. - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation Tbase := (@Tbase base_type_code). - Local Notation Expr := (@Expr base_type_code op). - - Section with_var. - Context {var : base_type_code -> Type}. - Local Notation exprf := (@exprf base_type_code op var). - Local Notation expr := (@expr base_type_code op var). - - Section under_lets. - Fixpoint under_letsf {t} (e : exprf t) - : forall {tC} (C : interp_flat_type var t -> exprf tC), exprf tC - := match e in Syntax.exprf _ _ t return forall {tC} (C : interp_flat_type var t -> exprf tC), exprf tC with - | LetIn _ ex _ eC - => fun _ C => @under_letsf _ ex _ (fun v => @under_letsf _ (eC v) _ C) - | TT => fun _ C => C tt - | Var _ x => fun _ C => C x - | Op _ _ op args as e => fun _ C => LetIn e C - | Pair A x B y => fun _ C => @under_letsf A x _ (fun x => - @under_letsf B y _ (fun y => - C (x, y))) - end. - End under_lets. - - Fixpoint linearizef {t} (e : exprf t) : exprf t - := match e in Syntax.exprf _ _ t return exprf t with - | LetIn _ ex _ eC - => under_letsf (@linearizef _ ex) (fun x => @linearizef _ (eC x)) - | TT => TT - | Var _ x => Var x - | Op _ _ op args - => under_letsf (@linearizef _ args) (fun args => LetIn (Op op (SmartVarf args)) SmartVarf) - | Pair A ex B ey - => under_letsf (@linearizef _ ex) (fun x => - under_letsf (@linearizef _ ey) (fun y => - SmartVarf (t:=Prod A B) (x, y))) - end. - - Definition linearize {t} (e : expr t) : expr t - := match e in Syntax.expr _ _ t return expr t with - | Abs _ _ f => Abs (fun x => linearizef (f x)) - end. - End with_var. - - Definition Linearize {t} (e : Expr t) : Expr t - := fun var => linearize (e _). -End language. - -Global Arguments under_letsf {_ _ _ _} _ {tC} _. -Global Arguments linearizef {_ _ _ _} _. -Global Arguments linearize {_ _ _ _} _. -Global Arguments Linearize {_ _ _} _ var. diff --git a/src/Reflection/LinearizeInterp.v b/src/Reflection/LinearizeInterp.v deleted file mode 100644 index 293d80a34..000000000 --- a/src/Reflection/LinearizeInterp.v +++ /dev/null @@ -1,88 +0,0 @@ -(** * Linearize: Place all and only operations in let binders *) -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Reflection.LinearizeWf. -Require Import Crypto.Reflection.InterpProofs. -Require Import Crypto.Reflection.Linearize. -Require Import Crypto.Util.Sigma Crypto.Util.Prod. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.SpecializeBy. - - -Local Open Scope ctype_scope. -Section language. - Context (base_type_code : Type). - Context (interp_base_type : base_type_code -> Type). - Context (op : flat_type base_type_code -> flat_type base_type_code -> Type). - Context (interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst). - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation interp_type := (interp_type interp_base_type). - Local Notation interp_flat_type := (interp_flat_type interp_base_type). - Local Notation exprf := (@exprf base_type_code op). - Local Notation expr := (@expr base_type_code op). - Local Notation Expr := (@Expr base_type_code op). - Local Notation wff := (@wff base_type_code op). - Local Notation wf := (@wf base_type_code op). - - Local Hint Extern 1 => eapply interpf_SmartVarVarf. - - Local Ltac t_fin := - repeat match goal with - | _ => reflexivity - | _ => progress unfold LetIn.Let_In - | _ => progress simpl in * - | _ => progress intros - | _ => progress inversion_sigma - | _ => progress inversion_prod - | _ => solve [ intuition eauto ] - | _ => apply (f_equal (interp_op _ _ _)) - | _ => apply (f_equal2 (@pair _ _)) - | _ => progress specialize_by assumption - | _ => progress subst - | [ H : context[List.In _ (_ ++ _)] |- _ ] => setoid_rewrite List.in_app_iff in H - | [ H : or _ _ |- _ ] => destruct H - | _ => progress break_match - | _ => rewrite <- !surjective_pairing - | [ H : ?x = _, H' : context[?x] |- _ ] => rewrite H in H' - | [ H : _ |- _ ] => apply H - | [ H : _ |- _ ] => rewrite H - end. - - Lemma interpf_under_letsf {t tC} (ex : exprf t) (eC : _ -> exprf tC) - : interpf interp_op (under_letsf ex eC) = let x := interpf interp_op ex in interpf interp_op (eC x). - Proof using Type. - clear. - induction ex; t_fin. - Qed. - - Lemma interpf_linearizef {t} e - : interpf interp_op (linearizef (t:=t) e) = interpf interp_op e. - Proof using Type. - clear. - induction e; - repeat first [ progress rewrite ?interpf_under_letsf, ?interpf_SmartVarf - | progress simpl - | t_fin ]. - Qed. - - Local Hint Resolve interpf_linearizef. - - Lemma interp_linearize {t} e - : forall x, interp interp_op (linearize (t:=t) e) x = interp interp_op e x. - Proof using Type. - induction e; simpl; eauto. - Qed. - - Lemma InterpLinearize {t} (e : Expr t) - : forall x, Interp interp_op (Linearize e) x = Interp interp_op e x. - Proof using Type. - unfold Interp, Linearize. - eapply interp_linearize. - Qed. -End language. - -Hint Rewrite @interpf_under_letsf : reflective_interp. -Hint Rewrite @InterpLinearize @interp_linearize @interpf_linearizef using solve [ eassumption | eauto with wf ] : reflective_interp. diff --git a/src/Reflection/LinearizeWf.v b/src/Reflection/LinearizeWf.v deleted file mode 100644 index b12e83b56..000000000 --- a/src/Reflection/LinearizeWf.v +++ /dev/null @@ -1,176 +0,0 @@ -(** * Linearize: Place all and only operations in let binders *) -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.WfProofs. -Require Import Crypto.Reflection.Linearize. -Require Import (*Crypto.Util.Tactics*) Crypto.Util.Sigma. - -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type}. - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation Tbase := (@Tbase base_type_code). - Local Notation exprf := (@exprf base_type_code op). - Local Notation expr := (@expr base_type_code op). - Local Notation Expr := (@Expr base_type_code op). - Local Notation wff := (@wff base_type_code op). - Local Notation wf := (@wf base_type_code op). - - Section with_var. - Context {var1 var2 : base_type_code -> Type}. - - Local Ltac t_fin_step tac := - match goal with - | _ => assumption - | _ => progress simpl in * - | _ => progress subst - | _ => progress inversion_sigma - | _ => setoid_rewrite List.in_app_iff - | [ H : context[List.In _ (_ ++ _)] |- _ ] => setoid_rewrite List.in_app_iff in H - | _ => progress intros - | _ => solve [ eauto ] - | _ => solve [ intuition (subst; eauto) ] - | [ H : forall (x : prod _ _) (y : prod _ _), _ |- _ ] => specialize (fun x x' y y' => H (x, x') (y, y')) - | _ => rewrite !List.app_assoc - | [ H : _ \/ _ |- _ ] => destruct H - | [ H : _ |- _ ] => apply H - | _ => eapply wff_in_impl_Proper; [ solve [ eauto ] | ] - | _ => progress tac - | [ |- wff _ _ _ ] => constructor - | [ |- wf _ _ _ ] => constructor - end. - Local Ltac t_fin tac := repeat t_fin_step tac. - - Local Hint Constructors Wf.wff. - Local Hint Resolve List.in_app_or List.in_or_app. - - Local Ltac small_inversion_helper wf G0 e2 := - let t0 := match type of wf with wff (t:=?t0) _ _ _ => t0 end in - let e1 := match goal with - | |- context[wff G0 (under_letsf ?e1 _) (under_letsf e2 _)] => e1 - end in - pattern G0, t0, e1, e2; - lazymatch goal with - | [ |- ?retP _ _ _ _ ] - => first [ refine (match wf in @Wf.wff _ _ _ _ G t v1 v2 - return match v1 return Prop with - | TT => retP G t v1 v2 - | _ => forall P : Prop, P -> P - end with - | WfTT _ => _ - | _ => fun _ p => p - end) - | refine (match wf in @Wf.wff _ _ _ _ G t v1 v2 - return match v1 return Prop with - | Var _ _ => retP G t v1 v2 - | _ => forall P : Prop, P -> P - end with - | WfVar _ _ _ _ _ => _ - | _ => fun _ p => p - end) - | refine (match wf in @Wf.wff _ _ _ _ G t v1 v2 - return match v1 return Prop with - | Op _ _ _ _ => retP G t v1 v2 - | _ => forall P : Prop, P -> P - end with - | WfOp _ _ _ _ _ _ _ => _ - | _ => fun _ p => p - end) - | refine (match wf in @Wf.wff _ _ _ _ G t v1 v2 - return match v1 return Prop with - | LetIn _ _ _ _ => retP G t v1 v2 - | _ => forall P : Prop, P -> P - end with - | WfLetIn _ _ _ _ _ _ _ _ _ => _ - | _ => fun _ p => p - end) - | refine (match wf in @Wf.wff _ _ _ _ G t v1 v2 - return match v1 return Prop with - | Pair _ _ _ _ => retP G t v1 v2 - | _ => forall P : Prop, P -> P - end with - | WfPair _ _ _ _ _ _ _ _ _ => _ - | _ => fun _ p => p - end) ] - end. - Fixpoint wff_under_letsf G {t} e1 e2 {tC} eC1 eC2 - (wf : @wff var1 var2 G t e1 e2) - (H : forall (x1 : interp_flat_type var1 t) (x2 : interp_flat_type var2 t), - wff (flatten_binding_list x1 x2 ++ G) (eC1 x1) (eC2 x2)) - {struct e1} - : @wff var1 var2 G tC (under_letsf e1 eC1) (under_letsf e2 eC2). - Proof using Type. - revert H. - set (e1v := e1) in *. - destruct e1 as [ | | ? ? ? args | tx ex tC0 eC0 | ? ex ? ey ]; - [ clear wff_under_letsf - | clear wff_under_letsf - | clear wff_under_letsf - | generalize (fun G => match e1v return match e1v with LetIn _ _ _ _ => _ | _ => _ end with - | LetIn _ ex _ eC => wff_under_letsf G _ ex - | _ => I - end); - generalize (fun G => match e1v return match e1v with - | LetIn tx0 _ tC1 e0 => (* 8.4's type inferencer is broken, so we copy/paste the term from 8.5. This entire clause could just be [_], if Coq 8.4 worked *) - forall (x : @interp_flat_type base_type_code var1 tx0) (e3 : exprf tC1) - (tC2 : flat_type) (eC3 : @interp_flat_type base_type_code var1 tC1 -> exprf tC2) - (eC4 : @interp_flat_type base_type_code var2 tC1 -> exprf tC2), - wff G (e0 x) e3 -> - (forall (x1 : @interp_flat_type base_type_code var1 tC1) - (x2 : @interp_flat_type base_type_code var2 tC1), - wff (@flatten_binding_list base_type_code var1 var2 tC1 x1 x2 ++ G) (eC3 x1) (eC4 x2)) -> - wff G (@under_letsf base_type_code op var1 tC1 (e0 x) tC2 eC3) - (@under_letsf base_type_code op var2 tC1 e3 tC2 eC4) - | _ => _ end with - | LetIn _ ex tC' eC => fun x => wff_under_letsf G tC' (eC x) - | _ => I - end); - clear wff_under_letsf - | generalize (fun G => match e1v return match e1v with Pair _ _ _ _ => _ | _ => _ end with - | Pair _ ex _ ey => wff_under_letsf G _ ex - | _ => I - end); - generalize (fun G => match e1v return match e1v with Pair _ _ _ _ => _ | _ => _ end with - | Pair _ ex _ ey => wff_under_letsf G _ ey - | _ => I - end); - clear wff_under_letsf ]; - revert eC1 eC2; - (* alas, Coq's refiner isn't smart enough to figure out these small inversions for us *) - small_inversion_helper wf G e2; - t_fin idtac. - Qed. - - Local Hint Resolve wff_under_letsf. - Local Hint Constructors or. - Local Hint Extern 1 => progress unfold List.In in *. - Local Hint Resolve wff_in_impl_Proper. - Local Hint Resolve wff_SmartVarf. - - Lemma wff_linearizef G {t} e1 e2 - : @wff var1 var2 G t e1 e2 - -> @wff var1 var2 G t (linearizef e1) (linearizef e2). - Proof using Type. - induction 1; t_fin ltac:(apply wff_under_letsf). - Qed. - - Local Hint Resolve wff_linearizef. - - Lemma wf_linearize {t} e1 e2 - : @wf var1 var2 t e1 e2 - -> @wf var1 var2 t (linearize e1) (linearize e2). - Proof using Type. - destruct 1; constructor; auto. - Qed. - End with_var. - - Lemma Wf_Linearize {t} (e : Expr t) : Wf e -> Wf (Linearize e). - Proof using Type. - intros wf var1 var2; apply wf_linearize, wf. - Qed. -End language. - -Hint Resolve Wf_Linearize : wf. diff --git a/src/Reflection/Map.v b/src/Reflection/Map.v deleted file mode 100644 index 9faa69eb9..000000000 --- a/src/Reflection/Map.v +++ /dev/null @@ -1,30 +0,0 @@ -Require Import Crypto.Reflection.Syntax. - -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - {var1 var2 : base_type_code -> Type} - (fvar12 : forall t, var1 t -> var2 t) - (fvar21 : forall t, var2 t -> var1 t). - Local Notation exprf := (@exprf base_type_code op). - Fixpoint mapf_interp_flat_type {t} (e : interp_flat_type var2 t) {struct t} - : interp_flat_type var1 t - := match t return interp_flat_type _ t -> interp_flat_type _ t with - | Tbase _ => fvar21 _ - | Unit => fun v : unit => v - | Prod x y => fun xy => (@mapf_interp_flat_type _ (fst xy), - @mapf_interp_flat_type _ (snd xy)) - end e. - - Fixpoint mapf {t} (e : @exprf var1 t) : @exprf var2 t - := match e in Syntax.exprf _ _ t return exprf t with - | TT => TT - | Var _ x => Var (fvar12 _ x) - | Op _ _ op args => Op op (@mapf _ args) - | LetIn _ ex _ eC => LetIn (@mapf _ ex) (fun x => @mapf _ (eC (mapf_interp_flat_type x))) - | Pair _ ex _ ey => Pair (@mapf _ ex) (@mapf _ ey) - end. -End language. - -Global Arguments mapf_interp_flat_type {_ _ _} _ {t} _. -Global Arguments mapf {_ _ _ _} _ _ {t} _. diff --git a/src/Reflection/MapCast.v b/src/Reflection/MapCast.v deleted file mode 100644 index 56736fa20..000000000 --- a/src/Reflection/MapCast.v +++ /dev/null @@ -1,105 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.ExprInversion. -Require Import Crypto.Util.Sigma. -Require Import Crypto.Util.Prod. -Require Import Crypto.Util.Option. - -Local Open Scope ctype_scope. -Local Open Scope expr_scope. -Section language. - Context {base_type_code1 base_type_code2 : Type} - {interp_base_type2 : base_type_code2 -> Type} - {op1 : flat_type base_type_code1 -> flat_type base_type_code1 -> Type} - {op2 : flat_type base_type_code2 -> flat_type base_type_code2 -> Type} - (interp_op2 : forall src dst, op2 src dst -> interp_flat_type interp_base_type2 src -> interp_flat_type interp_base_type2 dst) - (failv : forall {var t}, @exprf base_type_code1 op1 var (Tbase t)). - Context (transfer_op : forall ovar src1 dst1 src2 dst2 - (opc1 : op1 src1 dst1) - (opc2 : op2 src2 dst2) - (args1' : @exprf base_type_code1 op1 ovar src1) - (args2 : interp_flat_type interp_base_type2 src2), - @exprf base_type_code1 op1 ovar dst1). - - - Section with_var. - Context {ovar : base_type_code1 -> Type}. - Local Notation SmartFail - := (SmartValf _ (@failv _)). - Local Notation failf t (* {t} : @exprf base_type_code1 op1 ovar t*) - := (SmartPairf (SmartFail t)). - - (** We only ever make use of this when [e1] and [e2] are the same - type, and, in fact, the same syntax tree instantiated to - different [var] arguments. However, if we make - [mapf_interp_cast] homogenous (force [t1] and [t2] to be - judgmentally equal), then we run into trouble in the recursive - calls in the [LetIn] and [Op] cases; we'd need to have - evidence that they are the same (such as a (transparent!) - well-foundedness proof), or a decider of type equality with - transparent proofs that we can cast across. - - Rather than asking for either of these, we take the simpler - route of allowing expression trees of different types, and - failing ([failf]) or falling back to default behavior (as in - the [TT] and [Var] cases) when things don't match. - - Allowing two different [base_type_code]s and [op] types is - unnecessary, and they could be collapsed. The extra - generalization costs little in lines-of-code, though, so I've - left it in. *) - Fixpoint mapf_interp_cast - {t1} (e1 : @exprf base_type_code1 op1 ovar t1) - {t2} (e2 : @exprf base_type_code2 op2 interp_base_type2 t2) - {struct e1} - : @exprf base_type_code1 op1 ovar t1 - := match e1 in exprf _ _ t1, e2 as e2 in exprf _ _ t2 - return exprf _ _ (var:=ovar) t1 with - | TT as e1', _ - | Var _ _ as e1', _ - => e1' - | Pair tx1 ex1 ty1 ey1, Pair tx2 ex2 ty2 ey2 - => Pair - (@mapf_interp_cast _ ex1 _ ex2) - (@mapf_interp_cast _ ey1 _ ey2) - | Op _ tR1 op1 args1, Op _ tR2 op2 args2 - => let args' := @mapf_interp_cast _ args1 _ args2 in - transfer_op _ _ _ _ _ op1 op2 args' (interpf interp_op2 args2) - | LetIn tx1 ex1 tC1 eC1, LetIn tx2 ex2 tC2 eC2 - => let ex' := @mapf_interp_cast _ ex1 _ ex2 in - let eC' := fun v' => @mapf_interp_cast _ (eC1 v') _ (eC2 (interpf interp_op2 ex2)) in - LetIn ex' eC' - | Op _ _ _ _, _ - | LetIn _ _ _ _, _ - | Pair _ _ _ _, _ - => @failf _ - end. - Arguments mapf_interp_cast {_} _ {_} _. (* 8.4 workaround for bad arguments *) - - Definition map_interp_cast - {t1} (e1 : @expr base_type_code1 op1 ovar t1) - {t2} (e2 : @expr base_type_code2 op2 interp_base_type2 t2) - (args2 : interp_flat_type interp_base_type2 (domain t2)) - : @expr base_type_code1 op1 ovar (Arrow (domain t1) (codomain t1)) - := let f1 := invert_Abs e1 in - let f2 := invert_Abs e2 in - Abs (fun x => @mapf_interp_cast _ (f1 x) _ (f2 args2)). - End with_var. -End language. - -Global Arguments mapf_interp_cast {_ _ _ _ _} interp_op2 failv transfer_op {ovar} {t1} e1 {t2} e2. -Global Arguments map_interp_cast {_ _ _ _ _} interp_op2 failv transfer_op {ovar} {t1} e1 {t2} e2 args2. - -Section homogenous. - Context {base_type_code : Type} - {interp_base_type2 : base_type_code -> Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - (interp_op2 : forall src dst, op src dst -> interp_flat_type interp_base_type2 src -> interp_flat_type interp_base_type2 dst) - (failv : forall {var t}, @exprf base_type_code op var (Tbase t)). - - Definition MapInterpCast - transfer_op - {t} (e : Expr base_type_code op t) (args : interp_flat_type interp_base_type2 (domain t)) - : Expr base_type_code op (Arrow (domain t) (codomain t)) - := fun var => map_interp_cast interp_op2 (@failv) transfer_op (e _) (e _) args. -End homogenous. diff --git a/src/Reflection/MapCastByDeBruijn.v b/src/Reflection/MapCastByDeBruijn.v deleted file mode 100644 index 68eb06a54..000000000 --- a/src/Reflection/MapCastByDeBruijn.v +++ /dev/null @@ -1,61 +0,0 @@ -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.MapCast. -Require Import Crypto.Reflection.Named.InterpretToPHOAS. -Require Import Crypto.Reflection.Named.Compile. -Require Import Crypto.Reflection.Named.PositiveContext. -Require Import Crypto.Reflection.Named.PositiveContext.Defaults. -Require Import Crypto.Reflection.Syntax. - -(** N.B. This procedure only works when there are no nested lets, - i.e., nothing like [let x := let y := z in w] in the PHOAS syntax - tree. This is a limitation of [compile]. *) - -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - (base_type_code_beq : base_type_code -> base_type_code -> bool) - (base_type_code_bl_transparent : forall x y, base_type_code_beq x y = true -> x = y) - (failb : forall var t, @Syntax.exprf base_type_code op var (Tbase t)) - {interp_base_type_bounds : base_type_code -> Type} - (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst) - (pick_typeb : forall t, interp_base_type_bounds t -> base_type_code). - Local Notation pick_type v := (SmartFlatTypeMap pick_typeb v). - Context (cast_op : forall t tR (opc : op t tR) args_bs, - op (pick_type args_bs) (pick_type (interp_op_bounds t tR opc args_bs))). - - Local Notation PContext var := (PositiveContext _ var _ base_type_code_bl_transparent). - - Section MapCast. - Context {t} (e : Expr base_type_code op t) - (input_bounds : interp_flat_type interp_base_type_bounds (domain t)). - - Definition MapCastCompile - := compile (e _) (DefaultNamesFor e). - Definition MapCastDoCast (e' : option (Named.expr base_type_code op BinNums.positive t)) - := option_map - (fun e'' => map_cast - interp_op_bounds pick_typeb cast_op - (BoundsContext:=PContext _) - empty - e'' - input_bounds) - e'. - Definition MapCastDoInterp - (e' : option - (option - { output_bounds : interp_flat_type interp_base_type_bounds (codomain t) & - Named.expr _ _ _ (Arrow (pick_type input_bounds) (pick_type output_bounds)) })) - : option { output_bounds : interp_flat_type interp_base_type_bounds (codomain t) - & Expr base_type_code op (Arrow (pick_type input_bounds) (pick_type output_bounds)) } - := match e' with - | Some (Some (existT output_bounds e'')) - => Some (existT _ output_bounds (InterpToPHOAS (Context:=fun var => PContext var) failb e'')) - | Some None | None => None - end. - Definition MapCast - : option { output_bounds : interp_flat_type interp_base_type_bounds (codomain t) - & Expr base_type_code op (Arrow (pick_type input_bounds) (pick_type output_bounds)) } - := MapCastDoInterp (MapCastDoCast MapCastCompile). - End MapCast. -End language. diff --git a/src/Reflection/MapCastByDeBruijnInterp.v b/src/Reflection/MapCastByDeBruijnInterp.v deleted file mode 100644 index 90cbad00c..000000000 --- a/src/Reflection/MapCastByDeBruijnInterp.v +++ /dev/null @@ -1,116 +0,0 @@ -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.ContextDefinitions. -Require Import Crypto.Reflection.Named.MapCastInterp. -Require Import Crypto.Reflection.Named.MapCastWf. -Require Import Crypto.Reflection.Named.InterpretToPHOASInterp. -Require Import Crypto.Reflection.Named.CompileInterp. -Require Import Crypto.Reflection.Named.CompileWf. -Require Import Crypto.Reflection.Named.PositiveContext. -Require Import Crypto.Reflection.Named.PositiveContext.Defaults. -Require Import Crypto.Reflection.Named.PositiveContext.DefaultsProperties. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.MapCastByDeBruijn. -Require Import Crypto.Util.Decidable. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Sigma. -Require Import Crypto.Util.Tactics.BreakMatch. - -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - (base_type_code_beq : base_type_code -> base_type_code -> bool) - (base_type_code_bl_transparent : forall x y, base_type_code_beq x y = true -> x = y) - (base_type_code_lb : forall x y, x = y -> base_type_code_beq x y = true) - (failb : forall var t, @Syntax.exprf base_type_code op var (Tbase t)) - {interp_base_type : base_type_code -> Type} - (interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst) - {interp_base_type_bounds : base_type_code -> Type} - (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst) - (pick_typeb : forall t, interp_base_type_bounds t -> base_type_code). - Local Notation pick_type v := (SmartFlatTypeMap pick_typeb v). - Context (cast_op : forall t tR (opc : op t tR) args_bs, - op (pick_type args_bs) (pick_type (interp_op_bounds t tR opc args_bs))) - (cast_backb: forall t b, interp_base_type (pick_typeb t b) -> interp_base_type t). - Let cast_back : forall t b, interp_flat_type interp_base_type (pick_type b) -> interp_flat_type interp_base_type t - := fun t b => SmartFlatTypeMapUnInterp cast_backb. - Context (inboundsb : forall t, interp_base_type_bounds t -> interp_base_type t -> Prop). - Let inbounds : forall t, interp_flat_type interp_base_type_bounds t -> interp_flat_type interp_base_type t -> Prop - := fun t => interp_flat_type_rel_pointwise inboundsb (t:=t). - Context (interp_op_bounds_correct - : forall t tR opc bs - (v : interp_flat_type interp_base_type t) - (H : inbounds t bs v), - inbounds tR (interp_op_bounds t tR opc bs) (interp_op t tR opc v)) - (pull_cast_back - : forall t tR opc bs - (v : interp_flat_type interp_base_type (pick_type bs)) - (H : inbounds t bs (cast_back t bs v)), - interp_op t tR opc (cast_back t bs v) - = - cast_back _ _ (interp_op _ _ (cast_op _ _ opc bs) v)). - - Local Notation MapCast - := (@MapCast - base_type_code op base_type_code_beq base_type_code_bl_transparent - failb interp_base_type_bounds interp_op_bounds pick_typeb cast_op). - - Local Notation PositiveContextOk := (@PositiveContextOk base_type_code _ base_type_code_beq base_type_code_bl_transparent base_type_code_lb). - - Local Instance dec_base_type_code_eq : DecidableRel (@eq base_type_code). - Proof. - refine (fun x y => (if base_type_code_beq x y as b return base_type_code_beq x y = b -> Decidable (x = y) - then fun pf => left (base_type_code_bl_transparent _ _ pf) - else fun pf => right _) eq_refl). - { clear -pf base_type_code_lb. - abstract (intro; erewrite base_type_code_lb in pf by eassumption; congruence). } - Defined. - - Local Arguments Compile.compile : simpl never. - Lemma MapCastCorrect - {t} (e : Expr base_type_code op t) - (Hwf : Wf e) - (input_bounds : interp_flat_type interp_base_type_bounds (domain t)) - : forall {b} e' (He':MapCast e input_bounds = Some (existT _ b e')) - v v' (Hv : @inbounds _ input_bounds v /\ cast_back _ _ v' = v), - Interp interp_op_bounds e input_bounds = b - /\ @inbounds _ b (Interp interp_op e v) - /\ cast_back _ _ (Interp interp_op e' v') = (Interp interp_op e v). - Proof using base_type_code_lb interp_op_bounds_correct pull_cast_back. - unfold MapCastByDeBruijn.MapCast, MapCastCompile, MapCastDoCast, MapCastDoInterp, option_map; intros b e'. - break_innermost_match; try congruence; intros ? v v'. - inversion_option; inversion_sigma; subst; simpl in *; intros. - lazymatch goal with - | [ H : MapCast.map_cast _ _ _ _ _ _ = Some _ |- _ ] - => eapply map_cast_correct with (t:=Arrow _ _) (oldValues:=empty) (newValues:=empty) in H; - [ destruct H; split; [ | eassumption ] | try eassumption.. ] - end; - try solve [ eassumption - | auto using PositiveContextOk with typeclass_instances - | repeat first [ rewrite !lookupb_empty by (apply PositiveContextOk; assumption) - | intro - | congruence ] ]; - unfold Interp; - [ match goal with - | [ H : ?y = Some ?b |- ?x = ?b ] - => cut (y = Some x); [ congruence | ] - end - | - | change (interp interp_op (?e ?var) ?v') with (Interp interp_op e v'); - unfold Interp, InterpretToPHOAS.Named.InterpToPHOAS, InterpretToPHOAS.Named.InterpToPHOAS_gen; - rewrite <- interp_interp_to_phoas; [ reflexivity | ] ]. - { erewrite (interp_compile (ContextOk:=PositiveContextOk)) with (e':=e _); - [ reflexivity | auto | .. | eassumption ]; - auto using name_list_unique_DefaultNamesFor. } - { erewrite (interp_compile (ContextOk:=PositiveContextOk)) with (e':=e _); - [ reflexivity | auto | .. | eassumption ]; - auto using name_list_unique_DefaultNamesFor. } - { intro; eapply wf_map_cast with (t := Arrow _ _) (fValues := empty); eauto using PositiveContextOk with typeclass_instances. - { eapply (wf_compile (ContextOk:=PositiveContextOk)) with (e':= e _); - [ auto | .. | eassumption ]; - auto using name_list_unique_DefaultNamesFor. } - { intros ???; rewrite lookupb_empty by apply PositiveContextOk; congruence. } } - Qed. -End language. diff --git a/src/Reflection/MapCastByDeBruijnWf.v b/src/Reflection/MapCastByDeBruijnWf.v deleted file mode 100644 index 4fd3975f7..000000000 --- a/src/Reflection/MapCastByDeBruijnWf.v +++ /dev/null @@ -1,106 +0,0 @@ -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.ContextDefinitions. -Require Import Crypto.Reflection.Named.MapCastWf. -Require Import Crypto.Reflection.Named.InterpretToPHOASWf. -Require Import Crypto.Reflection.Named.CompileWf. -Require Import Crypto.Reflection.Named.PositiveContext. -Require Import Crypto.Reflection.Named.PositiveContext.Defaults. -Require Import Crypto.Reflection.Named.PositiveContext.DefaultsProperties. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.MapCastByDeBruijn. -Require Import Crypto.Util.Decidable. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Sigma. -Require Import Crypto.Util.Tactics.BreakMatch. - -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - (base_type_code_beq : base_type_code -> base_type_code -> bool) - (base_type_code_bl_transparent : forall x y, base_type_code_beq x y = true -> x = y) - (base_type_code_lb : forall x y, x = y -> base_type_code_beq x y = true) - (failb : forall var t, @Syntax.exprf base_type_code op var (Tbase t)) - {interp_base_type : base_type_code -> Type} - (interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst) - {interp_base_type_bounds : base_type_code -> Type} - (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst) - (pick_typeb : forall t, interp_base_type_bounds t -> base_type_code). - Local Notation pick_type v := (SmartFlatTypeMap pick_typeb v). - Context (cast_op : forall t tR (opc : op t tR) args_bs, - op (pick_type args_bs) (pick_type (interp_op_bounds t tR opc args_bs))) - (cast_backb: forall t b, interp_base_type (pick_typeb t b) -> interp_base_type t). - Let cast_back : forall t b, interp_flat_type interp_base_type (pick_type b) -> interp_flat_type interp_base_type t - := fun t b => SmartFlatTypeMapUnInterp cast_backb. - Context (inboundsb : forall t, interp_base_type_bounds t -> interp_base_type t -> Prop). - Let inbounds : forall t, interp_flat_type interp_base_type_bounds t -> interp_flat_type interp_base_type t -> Prop - := fun t => interp_flat_type_rel_pointwise inboundsb (t:=t). - Context (interp_op_bounds_correct - : forall t tR opc bs - (v : interp_flat_type interp_base_type t) - (H : inbounds t bs v), - inbounds tR (interp_op_bounds t tR opc bs) (interp_op t tR opc v)) - (pull_cast_back - : forall t tR opc bs - (v : interp_flat_type interp_base_type (pick_type bs)) - (H : inbounds t bs (cast_back t bs v)), - interp_op t tR opc (cast_back t bs v) - = - cast_back _ _ (interp_op _ _ (cast_op _ _ opc bs) v)). - - Local Notation MapCast - := (@MapCast - base_type_code op base_type_code_beq base_type_code_bl_transparent - failb interp_base_type_bounds interp_op_bounds pick_typeb cast_op). - - Local Notation PositiveContextOk := (@PositiveContextOk base_type_code _ base_type_code_beq base_type_code_bl_transparent base_type_code_lb). - - Local Instance dec_base_type_code_eq : DecidableRel (@eq base_type_code). - Proof. - refine (fun x y => (if base_type_code_beq x y as b return base_type_code_beq x y = b -> Decidable (x = y) - then fun pf => left (base_type_code_bl_transparent _ _ pf) - else fun pf => right _) eq_refl). - { clear -pf base_type_code_lb. - abstract (intro; erewrite base_type_code_lb in pf by eassumption; congruence). } - Defined. - - Local Arguments Compile.compile : simpl never. - Lemma Wf_MapCast - {t} (e : Expr base_type_code op t) - (input_bounds : interp_flat_type interp_base_type_bounds (domain t)) - : forall {b} e' (He':MapCast e input_bounds = Some (existT _ b e')) (Hwf : Wf e), - Wf e'. - Proof using base_type_code_lb. - unfold MapCastByDeBruijn.MapCast, MapCastCompile, MapCastDoCast, MapCastDoInterp, option_map; intros b e'. - break_innermost_match; try congruence; intros ? v v'. - inversion_option; inversion_sigma; subst; simpl in *; intros. - unfold InterpretToPHOAS.Named.InterpToPHOAS, InterpretToPHOAS.Named.InterpToPHOAS_gen. - destruct t as [src dst]. - eapply (@wf_interp_to_phoas - base_type_code op FMapPositive.PositiveMap.key _ _ _ _ - (PositiveContext base_type_code _ base_type_code_beq base_type_code_bl_transparent) - (PositiveContext base_type_code _ base_type_code_beq base_type_code_bl_transparent) - PositiveContextOk PositiveContextOk - (failb _) (failb _) _ e1); - (eapply wf_map_cast with (fValues:=empty); eauto using PositiveContextOk with typeclass_instances); - try (eapply (wf_compile (ContextOk:=PositiveContextOk)); - [ eauto - | .. - | eassumption ]); - try solve [ auto using name_list_unique_DefaultNamesFor - | intros ???; rewrite lookupb_empty by apply PositiveContextOk; congruence ]. - Qed. - - Lemma Wf_MapCast_arrow - {s d} (e : Expr base_type_code op (Arrow s d)) - (input_bounds : interp_flat_type interp_base_type_bounds s) - : forall {b} (e' : Expr _ _ (Arrow (pick_type input_bounds) (pick_type b))) - (He':MapCast e input_bounds = Some (existT _ b e')) - (Hwf : Wf e), - Wf e'. - Proof using base_type_code_lb. exact (@Wf_MapCast (Arrow s d) e input_bounds). Qed. -End language. - -Hint Resolve Wf_MapCast Wf_MapCast_arrow : wf. diff --git a/src/Reflection/MapCastInterp.v b/src/Reflection/MapCastInterp.v deleted file mode 100644 index 528e69e12..000000000 --- a/src/Reflection/MapCastInterp.v +++ /dev/null @@ -1,291 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.ExprInversion. -Require Import Crypto.Reflection.MapCast. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Reflection.WfProofs. -Require Import Crypto.Reflection.WfInversion. -Require Import Crypto.Util.Sigma. -Require Import Crypto.Util.Prod. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.SpecializeBy. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Tactics.SplitInContext. -Require Import Crypto.Util.Tactics.RewriteHyp. - -Local Open Scope ctype_scope. -Local Open Scope expr_scope. -Section language. - Context {base_type_code : Type} - {interp_base_type1 : base_type_code -> Type} - {interp_base_type2 : base_type_code -> Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - (interp_op1 : forall src dst, op src dst -> interp_flat_type interp_base_type1 src -> interp_flat_type interp_base_type1 dst) - (interp_op2 : forall src dst, op src dst -> interp_flat_type interp_base_type2 src -> interp_flat_type interp_base_type2 dst) - (failv : forall {var t}, @exprf base_type_code op var (Tbase t)). - Context (transfer_op : forall ovar src1 dst1 src2 dst2 - (opc1 : op src1 dst1) - (opc2 : op src2 dst2) - (args1' : @exprf base_type_code op ovar src1) - (args2 : interp_flat_type interp_base_type2 src2), - @exprf base_type_code op ovar dst1). - - Context (R' : forall t, interp_base_type1 t -> interp_base_type2 t -> Prop). - Local Notation R x y := (interp_flat_type_rel_pointwise R' x y). - Section gen_Prop. - Context (P : Type) (and : P -> P -> P) (True : P). - Context (bound_is_good : forall t, interp_base_type2 t -> P). - Local Notation bounds_are_good - := (@interp_flat_type_rel_pointwise1_gen_Prop _ _ P and True bound_is_good _). - Fixpoint bounds_are_recursively_good_gen_Prop {t} (e : exprf base_type_code op t) : P - := match e with - | LetIn tx ex tC eC - => and (@bounds_are_recursively_good_gen_Prop tx ex) - (@bounds_are_recursively_good_gen_Prop tC (eC (interpf interp_op2 ex))) - | Op t1 tR opc args as e' - => and (@bounds_are_recursively_good_gen_Prop _ args) - (bounds_are_good (interpf interp_op2 e')) - | TT => True - | Var t v => bound_is_good _ v - | Pair tx ex ty ey - => and (@bounds_are_recursively_good_gen_Prop _ ex) - (@bounds_are_recursively_good_gen_Prop _ ey) - end. - End gen_Prop. - Definition bounds_are_recursively_goodb - := bounds_are_recursively_good_gen_Prop bool andb true. - Global Arguments bounds_are_recursively_goodb _ {_} !_ / . - Definition bounds_are_recursively_good - := @bounds_are_recursively_good_gen_Prop Prop and True. - Global Arguments bounds_are_recursively_good _ {_} !_ / . - Lemma bounds_are_recursively_good_iff_bool - R t x - : is_true (@bounds_are_recursively_goodb R t x) - <-> @bounds_are_recursively_good (fun t x => is_true (R t x)) t x. - Proof using Type. - unfold is_true. - clear; induction x; simpl in *; rewrite ?Bool.andb_true_iff; - try setoid_rewrite interp_flat_type_rel_pointwise1_gen_Prop_iff_bool; - rewrite_hyp ?*; intuition congruence. - Qed. - Definition bounds_are_recursively_good_gen_Prop_iff_bool - : forall R t x, - is_true (@bounds_are_recursively_good_gen_Prop bool _ _ R t x) - <-> @bounds_are_recursively_good_gen_Prop Prop _ _ (fun t x => is_true (R t x)) t x - := bounds_are_recursively_good_iff_bool. - - Context (bound_is_good : forall t, interp_base_type2 t -> Prop). - Local Notation bounds_are_good - := (@interp_flat_type_rel_pointwise1 _ _ bound_is_good). - Lemma bounds_are_good_when_recursively_good {t} e - : @bounds_are_recursively_good bound_is_good t e -> bounds_are_good (interpf interp_op2 e). - Proof using Type. - induction e; simpl; unfold LetIn.Let_In; intuition auto. - Qed. - Local Hint Resolve bounds_are_good_when_recursively_good. - - Local Notation G_invariant_holds G - := (forall t x x', - List.In (existT _ t (x, x')%core) G -> R' t x x') - (only parsing). - - Context (interpf_transfer_op - : forall G t tR opc ein eout ebounds, - wff G ein ebounds - -> G_invariant_holds G - -> interpf interp_op1 ein = interpf interp_op1 eout - -> bounds_are_recursively_good bound_is_good ebounds - -> bounds_are_good (interp_op2 t tR opc (interpf interp_op2 ebounds)) - -> interpf interp_op1 (transfer_op interp_base_type1 t tR t tR opc opc eout (interpf interp_op2 ebounds)) - = interpf interp_op1 (Op opc ein)). - - Context (R_transfer_op - : forall G t tR opc ein eout ebounds, - wff G ein ebounds - -> G_invariant_holds G - -> interpf interp_op1 ein = interpf interp_op1 eout - -> bounds_are_recursively_good bound_is_good ebounds - -> bounds_are_good (interp_op2 t tR opc (interpf interp_op2 ebounds)) - -> R (interpf interp_op1 (transfer_op interp_base_type1 t tR t tR opc opc eout (interpf interp_op2 ebounds))) - (interpf interp_op2 (Op opc ebounds))). - - Local Notation mapf_interp_cast - := (@mapf_interp_cast - base_type_code base_type_code interp_base_type2 - op op interp_op2 failv - transfer_op). - Local Notation map_interp_cast - := (@map_interp_cast - base_type_code base_type_code interp_base_type2 - op op interp_op2 failv - transfer_op). - Local Notation MapInterpCast - := (@MapInterpCast - base_type_code interp_base_type2 - op interp_op2 failv - transfer_op). - - (* Local *) Hint Resolve <- List.in_app_iff. - Local Hint Resolve (fun t T => @interp_flat_type_rel_pointwise_flatten_binding_list _ _ _ t T R'). - - Local Ltac break_t - := first [ progress subst - | progress inversion_wf - | progress invert_expr_subst - | progress inversion_sigma - | progress inversion_prod - | progress destruct_head sig - | progress destruct_head sigT - | progress destruct_head ex - | progress destruct_head and - | progress destruct_head prod - | progress split_and - | progress break_match_hyps ]. - - Local Ltac fin_False := - lazymatch goal with - | [ H : False |- _ ] => exfalso; assumption - end. - - Local Ltac fin_t0 := - solve [ constructor; eauto - | eauto - | auto - | hnf; auto ]. - - Local Ltac handle_list_t := - match goal with - | _ => progress cbv [LetIn.Let_In duplicate_types] in * - | [ H : List.In _ (_ ++ _) |- _ ] => apply List.in_app_or in H - | [ H : List.In _ (List.map _ _) |- _ ] - => rewrite List.in_map_iff in H - | _ => rewrite <- flatten_binding_list_flatten_binding_list2 - | [ H : appcontext[flatten_binding_list2] |- _ ] - => rewrite <- flatten_binding_list_flatten_binding_list2 in H - | [ H : context[flatten_binding_list (SmartVarfMap _ _) (SmartVarfMap _ _)] |- _ ] - => rewrite flatten_binding_list_SmartVarfMap in H - | [ H : context[flatten_binding_list2 (SmartVarfMap _ _) (SmartVarfMap _ _)] |- _ ] - => rewrite flatten_binding_list2_SmartVarfMap in H - | [ H : context[flatten_binding_list2 (SmartVarfMap _ _) _] |- _ ] - => rewrite flatten_binding_list2_SmartVarfMap1 in H - | [ H : context[flatten_binding_list2 _ (SmartVarfMap _ _)] |- _ ] - => rewrite flatten_binding_list2_SmartVarfMap2 in H - | _ => rewrite <- flatten_binding_list_flatten_binding_list2 - | _ => rewrite List.in_map_iff - | [ H : context[List.In _ (_ ++ _)] |- _ ] - => setoid_rewrite List.in_app_iff in H - end. - - Local Ltac wff_t := - match goal with - | [ |- wff _ _ _ ] => constructor - | [ H : _ |- wff _ (mapf_interp_cast _ _ _) (mapf_interp_cast _ _ _) ] - => eapply H; eauto; []; clear H - | _ => solve [ eauto using wff_in_impl_Proper ] - end. - - Local Ltac R_t := - match goal with - | [ |- R' _ _ _ ] => eapply interp_flat_type_rel_pointwise_flatten_binding_list; eauto - | [ H : forall x y, _ -> R _ _ |- R _ _ ] => apply H; eauto; [] - | [ H : forall x y, _ -> _ -> R _ _ |- R _ _ ] => apply H; eauto; [] - end. - - Local Ltac misc_t := - match goal with - | _ => progress specialize_by eauto - | [ |- exists _, _ ] - => eexists (existT _ _ _) - | [ |- _ /\ _ ] => split - | [ H : _ = _ |- _ ] => rewrite H - | [ H : ?x = _, H' : context[?x] |- _ ] => rewrite H in H' - | [ H : forall x y, _ -> _ -> _ = _ |- interpf _ _ = interpf _ _ ] - => apply H - end. - - Local Ltac t_step := - first [ intro - | fin_False - | progress break_t - | fin_t0 - | progress simpl in * - | wff_t - | handle_list_t - | progress destruct_head' or - | misc_t - | R_t ]. - - Lemma interpf_mapf_interp_cast_and_rel - G - {t1} e1 ebounds - (Hgood : bounds_are_recursively_good bound_is_good ebounds) - (HG : G_invariant_holds G) - (Hwf : wff G e1 ebounds) - : interpf interp_op1 (@mapf_interp_cast interp_base_type1 t1 e1 t1 ebounds) - = interpf interp_op1 e1 - /\ R (interpf interp_op1 (@mapf_interp_cast interp_base_type1 t1 e1 t1 ebounds)) - (interpf interp_op2 ebounds). - Proof using R_transfer_op interpf_transfer_op. induction Hwf; repeat t_step. Qed. - - Local Hint Resolve interpf_mapf_interp_cast_and_rel. - - Lemma interpf_mapf_interp_cast - G - {t1} e1 ebounds - (Hgood : bounds_are_recursively_good bound_is_good ebounds) - (HG : G_invariant_holds G) - (Hwf : wff G e1 ebounds) - : interpf interp_op1 (@mapf_interp_cast interp_base_type1 t1 e1 t1 ebounds) - = interpf interp_op1 e1. - Proof using R_transfer_op interpf_transfer_op. eapply interpf_mapf_interp_cast_and_rel; eassumption. Qed. - - Lemma interp_map_interp_cast_and_rel - {t1} e1 ebounds - args2 - (Hgood : bounds_are_recursively_good bound_is_good (invert_Abs ebounds args2)) - (Hwf : wf e1 ebounds) - : forall x, - R x args2 - -> interp interp_op1 (@map_interp_cast interp_base_type1 t1 e1 t1 ebounds args2) x - = interp interp_op1 e1 x - /\ R (interp interp_op1 (@map_interp_cast interp_base_type1 t1 e1 t1 ebounds args2) x) - (interp interp_op2 ebounds args2). - Proof using R_transfer_op interpf_transfer_op. destruct Hwf; intros; eapply interpf_mapf_interp_cast_and_rel; eauto. Qed. - - Lemma interp_map_interp_cast - {t1} e1 ebounds - args2 - (Hgood : bounds_are_recursively_good bound_is_good (invert_Abs ebounds args2)) - (Hwf : wf e1 ebounds) - : forall x, - R x args2 - -> interp interp_op1 (@map_interp_cast interp_base_type1 t1 e1 t1 ebounds args2) x - = interp interp_op1 e1 x. - Proof using R_transfer_op interpf_transfer_op. intros; eapply interp_map_interp_cast_and_rel; eassumption. Qed. - - Lemma InterpMapInterpCastAndRel - {t} e - args - (Hwf : Wf e) - (Hgood : bounds_are_recursively_good bound_is_good (invert_Abs (e interp_base_type2) args)) - : forall x, - R x args - -> Interp interp_op1 (@MapInterpCast t e args) x - = Interp interp_op1 e x - /\ R (Interp interp_op1 (@MapInterpCast t e args) x) - (Interp interp_op2 e args). - Proof using R_transfer_op interpf_transfer_op. apply interp_map_interp_cast_and_rel; auto. Qed. - - Lemma InterpMapInterpCast - {t} e - args - (Hwf : Wf e) - (Hgood : bounds_are_recursively_good bound_is_good (invert_Abs (e interp_base_type2) args)) - : forall x, - R x args - -> Interp interp_op1 (@MapInterpCast t e args) x - = Interp interp_op1 e x. - Proof using R_transfer_op interpf_transfer_op. apply interp_map_interp_cast; auto. Qed. -End language. diff --git a/src/Reflection/MapCastWf.v b/src/Reflection/MapCastWf.v deleted file mode 100644 index 54e8d0020..000000000 --- a/src/Reflection/MapCastWf.v +++ /dev/null @@ -1,172 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.ExprInversion. -Require Import Crypto.Reflection.MapCast. -Require Import Crypto.Reflection.WfProofs. -Require Import Crypto.Reflection.WfInversion. -Require Import Crypto.Util.Sigma. -Require Import Crypto.Util.Prod. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.DestructHead. - -Local Open Scope ctype_scope. -Local Open Scope expr_scope. -Section language. - Context {base_type_code : Type} - {interp_base_type : base_type_code -> Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - (interp_op2 : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst) - (failv : forall {var t}, @exprf base_type_code op var (Tbase t)). - Context (transfer_op : forall ovar src1 dst1 src2 dst2 - (opc1 : op src1 dst1) - (opc2 : op src2 dst2) - (args1' : @exprf base_type_code op ovar src1) - (args2 : interp_flat_type interp_base_type src2), - @exprf base_type_code op ovar dst1). - - Local Notation interp_flat_type_ivarf_wff G a b - := (forall t x y, - List.In (existT _ t (x, y)%core) (flatten_binding_list a b) - -> wff G x y) - (only parsing). - - Section with_var. - Context {ovar1 ovar2 : base_type_code -> Type}. - - Context (wff_transfer_op - : forall G src1 dst1 src2 dst2 opc1 opc2 args1 args1' args2, - wff G (var1:=ovar1) (var2:=ovar2) args1 args1' - -> wff G - (@transfer_op ovar1 src1 dst1 src2 dst2 opc1 opc2 args1 args2) - (@transfer_op ovar2 src1 dst1 src2 dst2 opc1 opc2 args1' args2)). - Local Notation mapf_interp_cast - := (@mapf_interp_cast - base_type_code base_type_code interp_base_type - op op interp_op2 failv - transfer_op). - Local Notation map_interp_cast - := (@map_interp_cast - base_type_code base_type_code interp_base_type - op op interp_op2 failv - transfer_op). - - Local Notation G1eTf - := (fun t : base_type_code => interp_flat_type ovar1 (Tbase t) * interp_flat_type ovar2 (Tbase t))%type. - Local Notation G2eTf - := (fun t : base_type_code => ovar1 t * ovar2 t)%type. - Local Notation GbeTf - := (fun t : base_type_code => interp_flat_type ovar1 (Tbase t) * interp_base_type t)%type. - - (* Definition Gse_related' {t} (G1e : G1eTf t) (Gbe : GbeTf t) (G2e G2eTf t) : Prop - := fst G1e = fst Gbe /\ - - := exists (pf1 : projT1 G1e = projT1 G2e - - Definition Gse_related (G1e : sigT G1eTf) (G2e : sigT G2eTf) (G3e : sigT G3eTf) : Prop - := exists (pf1 : projT1 G1e = projT1 G2e - /\ - - Local Notation G3eT - := {t : base_type_code & - ((interp_flat_type ivarf1 (Tbase t) * interp_flat_type ivarf2 (Tbase t)) - * (ovar1 t * ovar2 t) - * interp_base_type t)%type }. - Local Notation G3T - := (list G3eT). - - Definition G3e_to_G1e - - *) - (* Local *) Hint Resolve <- List.in_app_iff. - - Local Ltac break_t - := first [ progress subst - | progress inversion_wf - | progress invert_expr_subst - | progress inversion_sigma - | progress inversion_prod - | progress destruct_head sig - | progress destruct_head sigT - | progress destruct_head ex - | progress destruct_head and - | progress destruct_head prod - | progress break_match_hyps ]. - - Lemma wff_mapf_interp_cast - G1 Gbounds - {t1} e1 e2 ebounds - (Hwf_bounds : wff Gbounds e1 ebounds) - (Hwf : wff G1 e1 e2) - : wff G1 - (@mapf_interp_cast ovar1 t1 e1 t1 ebounds) - (@mapf_interp_cast ovar2 t1 e2 t1 ebounds). - Proof using wff_transfer_op. - revert dependent Gbounds; revert ebounds; - induction Hwf; - repeat match goal with - | _ => solve [ exfalso; assumption ] - | _ => intro - | _ => progress break_t - | _ => solve [ constructor; eauto - | eauto - | auto - | hnf; auto ] - | _ => progress simpl in * - | [ H : List.In _ (_ ++ _) |- _ ] => apply List.in_app_or in H - | _ => progress destruct_head or - | [ |- wff _ _ _ ] => constructor - | [ H : _ |- wff _ (mapf_interp_cast _ _ _ _) (mapf_interp_cast _ _ _ _) ] - => eapply H; eauto; []; clear H - | _ => solve [ eauto using wff_SmartVarf, wff_in_impl_Proper ] - end. - Qed. - - Lemma wf_map_interp_cast - {t1} e1 e2 ebounds - args2 - (Hwf_bounds : wf e1 ebounds) - (Hwf : wf e1 e2) - : wf (@map_interp_cast ovar1 t1 e1 t1 ebounds args2) - (@map_interp_cast ovar2 t1 e2 t1 ebounds args2). - Proof using wff_transfer_op. - destruct Hwf; - repeat match goal with - | _ => solve [ constructor; eauto - | eauto using wff_mapf_interp_cast - | exfalso; assumption ] - | _ => intro - | _ => progress break_t - | [ |- wf _ _ ] => constructor - | _ => solve [ eauto using wff_SmartVarf, wff_in_impl_Proper ] - end. - Qed. - End with_var. - - Section gen. - Context (wff_transfer_op - : forall ovar1 ovar2 G src1 dst1 src2 dst2 opc1 opc2 e1 e2 args2, - wff G (var1:=ovar1) (var2:=ovar2) e1 e2 - -> wff G - (@transfer_op ovar1 src1 dst1 src2 dst2 opc1 opc2 e1 args2) - (@transfer_op ovar2 src1 dst1 src2 dst2 opc1 opc2 e2 args2)). - - Local Notation MapInterpCast - := (@MapInterpCast - base_type_code interp_base_type - op interp_op2 failv - transfer_op). - - Lemma Wf_MapInterpCast - {t} e - args - (Hwf : Wf e) - : Wf (@MapInterpCast t e args). - Proof using wff_transfer_op. - intros ??; apply wf_map_interp_cast; auto. - Qed. - End gen. -End language. - -Hint Resolve Wf_MapInterpCast : wf. diff --git a/src/Reflection/MultiSizeTest.v b/src/Reflection/MultiSizeTest.v deleted file mode 100644 index 2c7975113..000000000 --- a/src/Reflection/MultiSizeTest.v +++ /dev/null @@ -1,279 +0,0 @@ -Require Import Coq.omega.Omega. -Require Import Crypto.Reflection.SmartMap. - -Set Implicit Arguments. -Set Asymmetric Patterns. - -(** * Preliminaries: bounded and unbounded number types *) - -Definition bound8 := 256. - -Definition word8 := {n | n < bound8}. - -Definition bound9 := 512. - -Definition word9 := {n | n < bound9}. - - -(** * Expressions over unbounded words *) - -Section unbounded. - Variable var : Type. - - Inductive unbounded := - | Const : nat -> unbounded - | Var : var -> unbounded - | Plus : unbounded -> unbounded -> unbounded - | LetIn : unbounded -> (var -> unbounded) -> unbounded. -End unbounded. - -Arguments Const [var] _. - -Definition Unbounded := forall var, unbounded var. - -Fixpoint unboundedD (e : unbounded nat) : nat := - match e with - | Const n => n - | Var n => n - | Plus e1 e2 => unboundedD e1 + unboundedD e2 - | LetIn e1 e2 => unboundedD (e2 (unboundedD e1)) - end. - -Definition UnboundedD (E : Unbounded) : nat := - unboundedD (E _). - -(** * Opt-in bounded types *) - -Section bounded. - Inductive type := - | Nat - | Word8 - | Word9. - - Variable var : type -> Type. - - Inductive bounded : type -> Type := - | BConst : nat -> bounded Nat - | BConst8 : word8 -> bounded Word8 - | BConst9 : word9 -> bounded Word9 - | BVar : forall t, var t -> bounded t - | BPlus : bounded Nat -> bounded Nat -> bounded Nat - | BPlus8 : bounded Word8 -> bounded Word8 -> bounded Word8 - | BPlus9 : bounded Word9 -> bounded Word9 -> bounded Word9 - | BLetIn : forall t1 t2, bounded t1 -> (var t1 -> bounded t2) -> bounded t2 - - | Unbound : forall t, bounded t -> bounded Nat - | Bound : forall t, bounded Nat -> bounded t. -End bounded. - -Arguments BConst [var] _. -Arguments BConst8 [var] _. -Arguments BConst9 [var] _. -Arguments BVar [var t] _. -Arguments Unbound [var t] _. -Arguments Bound [var] _ _. - -Definition Bounded t := forall var, bounded var t. - -Definition typeD (t : type) : Type := - match t with - | Nat => nat - | Word8 => word8 - | Word9 => word9 - end. - -Axiom admit : forall T, T. - -Theorem O_lt_S : forall n, O < S n. -Proof. - intros; omega. -Qed. - -Definition plus8 (a b : word8) : word8 := - let n := proj1_sig a + proj1_sig b in - match le_lt_dec bound8 n with - | left _ => exist _ O (O_lt_S _) - | right pf => exist _ n pf - end. - -Definition plus9 (a b : word9) : word9 := - let n := proj1_sig a + proj1_sig b in - match le_lt_dec bound9 n with - | left _ => exist _ O (O_lt_S _) - | right pf => exist _ n pf - end. - -Infix "+8" := plus8 (at level 50). -Infix "+9" := plus9 (at level 50). - -Definition unbound {t} : typeD t -> nat := - match t with - | Nat => fun x => x - | Word8 => fun x => proj1_sig x - | Word9 => fun x => proj1_sig x - end. - -Definition bound {t} : nat -> typeD t := - match t return nat -> typeD t with - | Nat => fun x => x - | Word8 => fun x => - match le_lt_dec bound8 x with - | left _ => exist _ O (O_lt_S _) - | right pf => exist _ x pf - end - | Word9 => fun x => - match le_lt_dec bound9 x with - | left _ => exist _ O (O_lt_S _) - | right pf => exist _ x pf - end - end. - -Fixpoint boundedD t (e : bounded typeD t) : typeD t := - match e with - | BConst n => n - | BConst8 n => n - | BConst9 n => n - | BVar _ n => n - | BPlus e1 e2 => boundedD e1 + boundedD e2 - | BPlus8 e1 e2 => boundedD e1 +8 boundedD e2 - | BPlus9 e1 e2 => boundedD e1 +9 boundedD e2 - | BLetIn _ _ e1 e2 => boundedD (e2 (boundedD e1)) - | Unbound _ e1 => unbound (boundedD e1) - | Bound _ e1 => bound (boundedD e1) - end. - -Definition BoundedD t (E : Bounded t) : typeD t := - boundedD (E _). - - -(** * Insertion of bounded types opportunistically *) - -Definition fail {var} : nat * bounded var Nat := (0, BConst 0). - -Fixpoint boundOf (eb : unbounded nat) : nat := - match eb with - | Const n => n - | Var n => n - | Plus eb1 eb2 => boundOf eb1 + boundOf eb2 - | LetIn eb1 eb2 => boundOf (eb2 (boundOf eb1)) - end. - -Fixpoint boundify {var} (eb : unbounded nat) (e : unbounded (var Nat)) : nat * bounded var Nat := - match e with - | Const n => (n, - match le_lt_dec bound8 n with - | left _ => - match le_lt_dec bound9 n with - | left _ => BConst n - | right pf => Unbound (BConst9 (exist _ n pf)) - end - | right pf => Unbound (BConst8 (exist _ n pf)) - end) - | Var x => - match eb with - | Var n => (n, BVar x) - | _ => fail - end - | Plus e1 e2 => - match eb with - | Plus eb1 eb2 => - let (n1, e1') := boundify eb1 e1 in - let (n2, e2') := boundify eb2 e2 in - (n1 + n2, - if le_lt_dec bound8 (n1 + n2) - then if le_lt_dec bound9 (n1 + n2) - then BPlus e1' e2' - else Unbound (BPlus9 (Bound _ e1') (Bound _ e2')) - else Unbound (BPlus8 (Bound _ e1') (Bound _ e2'))) - | _ => fail - end - | LetIn e1 e2 => - match eb with - | LetIn eb1 eb2 => - let (n1, e1') := boundify eb1 e1 in - (boundOf (eb2 n1), BLetIn e1' (fun x => snd (boundify (eb2 n1) (e2 x)))) - | _ => fail - end - end. - -Definition Boundify (E : Unbounded) : Bounded Nat := - fun _ => snd (boundify (E _) (E _)). - - -(** * Moving [Unbound] operators down from [LetIn]s to their use sites *) - -Fixpoint movedown {var t} (e : bounded (bounded var) t) : bounded var t := - match e with - | BConst n => BConst n - | BConst8 n => BConst8 n - | BConst9 n => BConst9 n - | BVar _ e => e - | BPlus e1 e2 => BPlus (movedown e1) (movedown e2) - | BPlus8 e1 e2 => BPlus8 (movedown e1) (movedown e2) - | BPlus9 e1 e2 => BPlus9 (movedown e1) (movedown e2) - | BLetIn _ _ e1 e2 => - match movedown e1 in bounded _ t return (bounded _ t -> _) -> _ with - | Unbound _ e1'' => fun e2_rec => BLetIn e1'' (fun x => e2_rec (Unbound (BVar x))) - | e1' => fun e2_rec => BLetIn e1' (fun x => e2_rec (BVar x)) - end (fun x => movedown (e2 x)) - | Unbound _ e1 => Unbound (movedown e1) - | Bound t e1 => Bound t (movedown e1) - end. - -Definition Movedown t (E : Bounded t) : Bounded t := - fun _ => movedown (E _). - - -(** * Canceling matching [Bound] and [Unbound] *) - -Definition type_eq_dec : forall t1 t2 : type, {t1 = t2} + {t1 <> t2}. -Proof. - decide equality. -Defined. - -Fixpoint cancel {var t} (e : bounded var t) : bounded var t := - match e with - | BConst n => BConst n - | BConst8 n => BConst8 n - | BConst9 n => BConst9 n - | BVar _ x => BVar x - | BPlus e1 e2 => BPlus (cancel e1) (cancel e2) - | BPlus8 e1 e2 => BPlus8 (cancel e1) (cancel e2) - | BPlus9 e1 e2 => BPlus9 (cancel e1) (cancel e2) - | BLetIn _ _ e1 e2 => BLetIn (cancel e1) (fun x => cancel (e2 x)) - | Unbound _ e1 => Unbound (cancel e1) - | Bound t e1 => - match cancel e1 with - | Unbound t' e1' => - match type_eq_dec t' t with - | left pf => match pf in _ = T return bounded _ T with - | eq_refl => e1' - end - | right _ => Bound t (Unbound e1') - end - | e1' => Bound t e1' - end - end. - -Definition Cancel t (E : Bounded t) : Bounded t := - fun _ => cancel (E _). - - -(** * Examples *) - -Example ex1 : Unbounded := fun _ => - LetIn (Const 127) (fun a => - LetIn (Const 63) (fun b => - LetIn (Plus (Var a) (Var b)) (fun c => - Plus (Var c) (Var c)))). - -Eval compute in (UnboundedD ex1). - -Definition ex1b := Boundify ex1. -Eval compute in ex1b. - -Definition ex1bm := Movedown (Boundify ex1). -Eval compute in ex1bm. - -Definition ex1bmc := Cancel (Movedown (Boundify ex1)). -Eval compute in ex1bmc. diff --git a/src/Reflection/MultiSizeTest2.v b/src/Reflection/MultiSizeTest2.v deleted file mode 100644 index 4bac3d14c..000000000 --- a/src/Reflection/MultiSizeTest2.v +++ /dev/null @@ -1,183 +0,0 @@ -Require Import Coq.omega.Omega. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.TypeUtil. -Require Import Crypto.Reflection.BoundByCast. - -(** * Preliminaries: bounded and unbounded number types *) - -Definition bound8 := 256. - -Definition word8 := {n | n < bound8}. - -Definition bound9 := 512. - -Definition word9 := {n | n < bound9}. - - -(** * Expressions over unbounded words *) - -Inductive base_type := Nat | Word8 | Word9. -Scheme Equality for base_type. -Definition interp_base_type (t : base_type) - := match t with - | Nat => nat - | Word8 => word8 - | Word9 => word9 - end. -Definition interp_base_type_bounds (t : base_type) - := nat. -Definition base_type_leb (x y : base_type) : bool - := match x, y with - | Word8, _ => true - | _, Word8 => false - | Word9, _ => true - | _, Word9 => false - | Nat, Nat => true - end. -Local Notation TNat := (Tbase Nat). -Local Notation TWord8 := (Tbase Word8). -Local Notation TWord9 := (Tbase Word9). -Inductive op : flat_type base_type -> flat_type base_type -> Set := -| Const {t} (v : interp_base_type t) : op Unit (Tbase t) -| Plus (t : base_type) : op (Tbase t * Tbase t) (Tbase t) -| Cast (t1 t2 : base_type) : op (Tbase t1) (Tbase t2). - -Definition is_cast src dst (opc : op src dst) : bool - := match opc with Cast _ _ => true | _ => false end. -Definition is_const src dst (opc : op src dst) : bool - := match opc with Const _ _ => true | _ => false end. - -Definition genericize_op src dst (opc : op src dst) (new_t_in new_t_out : base_type) - : option { src'dst' : _ & op (fst src'dst') (snd src'dst') } - := match opc with - | Plus _ => Some (existT _ (_, _) (Plus (base_type_max base_type_leb new_t_in new_t_out))) - | Const _ _ - | Cast _ _ - => None - end. - -Definition Constf {var} {t} (v : interp_base_type t) : exprf base_type op (var:=var) (Tbase t) - := Op (Const v) TT. - -Theorem O_lt_S : forall n, O < S n. -Proof. - intros; omega. -Qed. - -Definition plus8 (a b : word8) : word8 := - let n := proj1_sig a + proj1_sig b in - match le_lt_dec bound8 n with - | left _ => exist _ O (O_lt_S _) - | right pf => exist _ n pf - end. - -Definition plus9 (a b : word9) : word9 := - let n := proj1_sig a + proj1_sig b in - match le_lt_dec bound9 n with - | left _ => exist _ O (O_lt_S _) - | right pf => exist _ n pf - end. - -Infix "+8" := plus8 (at level 50). -Infix "+9" := plus9 (at level 50). - -Definition unbound {t} : interp_base_type t -> nat := - match t with - | Nat => fun x => x - | Word8 => fun x => proj1_sig x - | Word9 => fun x => proj1_sig x - end. - -Definition bound {t} : nat -> interp_base_type t := - match t return nat -> interp_base_type t with - | Nat => fun x => x - | Word8 => fun x => - match le_lt_dec bound8 x with - | left _ => exist _ O (O_lt_S _) - | right pf => exist _ x pf - end - | Word9 => fun x => - match le_lt_dec bound9 x with - | left _ => exist _ O (O_lt_S _) - | right pf => exist _ x pf - end - end. - -Definition interp_op {src dst} (opc : op src dst) : interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst - := match opc in op src dst return interp_flat_type _ src -> interp_flat_type _ dst with - | Const _ v => fun _ => v - | Plus Nat => fun xy => fst xy + snd xy - | Plus Word8 => fun xy => fst xy +8 snd xy - | Plus Word9 => fun xy => fst xy +9 snd xy - | Cast t1 t2 => fun x => bound (unbound x) - end. - -Definition interp_op_bounds {src dst} (opc : op src dst) : interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst - := match opc in op src dst return interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst with - | Const _ v => fun _ => unbound v - | Plus _ => fun xy => fst xy + snd xy - | Cast t1 t2 => fun x => x - end. - -Definition bound_type t (v : interp_base_type_bounds t) : base_type - := if lt_dec v bound8 - then Word8 - else if lt_dec v bound9 - then Word9 - else Nat. - -Definition failv t : interp_base_type t - := match t with - | Nat => 0 - | Word8 => exist _ 0 (O_lt_S _) - | Word9 => exist _ 0 (O_lt_S _) - end. - -Definition failf var t : @exprf base_type op var (Tbase t) - := Op (Const (failv t)) TT. - -Definition Boundify {t1} (e1 : Expr base_type op t1) args2 - : Expr _ _ _ - := @Boundify - base_type op interp_base_type_bounds (@interp_op_bounds) - bound_type base_type_beq internal_base_type_dec_bl - base_type_leb - (fun var A A' => Op (Cast A A')) - is_cast - is_const - genericize_op - (@failf) - t1 e1 args2. - -(** * Examples *) - -Example ex1 : Expr base_type op (Arrow Unit TNat) := fun var => - Abs (fun _ => - LetIn (Constf (t:=Nat) 127) (fun a : var Nat => - LetIn (Constf (t:=Nat) 63) (fun b : var Nat => - LetIn (Op (tR:=TNat) (Plus Nat) (Pair (Var a) (Var b))) (fun c : var Nat => - Op (Plus Nat) (Pair (Var c) (Var c)))))). - -(* -Example ex1f : Expr base_type op (Arrow (TNat * TNat) TNat) := fun var => - Abs (fun a0b0 : interp_flat_type _ (TNat * TNat) => - let a0 := fst a0b0 in let b0 := snd a0b0 in - LetIn (Var a0) (fun a : var Nat => - LetIn (Var b0) (fun b : var Nat => - LetIn (Op (tR:=TNat) (Plus Nat) (Pair (Var a) (Var b))) (fun c : var Nat => - Op (Plus Nat) (Pair (Var c) (Var c)))))). - -Eval compute in (Interp (@interp_op) ex1). -Eval cbv -[plus] in (Interp (@interp_op) ex1f). - -Notation e x := (exist _ x _). - -Definition ex1b := Boundify ex1 tt. -Eval compute in ex1b. - -Definition ex1fb := Boundify ex1f (63, 63)%core. -Eval compute in ex1fb. - -Definition ex1fb' := Boundify ex1f (64, 64)%core. -Eval compute in ex1fb'. -*)
\ No newline at end of file diff --git a/src/Reflection/Named/Compile.v b/src/Reflection/Named/Compile.v deleted file mode 100644 index 55f4aba70..000000000 --- a/src/Reflection/Named/Compile.v +++ /dev/null @@ -1,59 +0,0 @@ -(** * PHOAS → Named Representation of Gallina *) -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.NameUtil. -Require Import Crypto.Reflection.Syntax. - -Local Notation eta x := (fst x, snd x). - -Local Open Scope ctype_scope. -Local Open Scope nexpr_scope. -Local Open Scope expr_scope. -Section language. - Context (base_type_code : Type) - (op : flat_type base_type_code -> flat_type base_type_code -> Type) - (Name : Type). - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation exprf := (@exprf base_type_code op (fun _ => Name)). - Local Notation expr := (@expr base_type_code op (fun _ => Name)). - Local Notation nexprf := (@Named.exprf base_type_code op Name). - Local Notation nexpr := (@Named.expr base_type_code op Name). - - Fixpoint ocompilef {t} (e : exprf t) (ls : list (option Name)) {struct e} - : option (nexprf t) - := match e in @Syntax.exprf _ _ _ t return option (nexprf t) with - | TT => Some Named.TT - | Var _ x => Some (Named.Var x) - | Op _ _ op args => option_map (Named.Op op) (@ocompilef _ args ls) - | LetIn tx ex _ eC - => match @ocompilef _ ex nil, split_onames tx ls with - | Some x, (Some n, ls')%core - => option_map (fun C => Named.LetIn tx n x C) (@ocompilef _ (eC n) ls') - | _, _ => None - end - | Pair _ ex _ ey => match @ocompilef _ ex nil, @ocompilef _ ey nil with - | Some x, Some y => Some (Named.Pair x y) - | _, _ => None - end - end. - - Definition ocompile {t} (e : expr t) (ls : list (option Name)) - : option (nexpr t) - := match e in @Syntax.expr _ _ _ t return option (nexpr t) with - | Abs src _ f - => match split_onames src ls with - | (Some n, ls')%core - => option_map (Named.Abs n) (@ocompilef _ (f n) ls') - | _ => None - end - end. - - Definition compilef {t} (e : exprf t) (ls : list Name) := @ocompilef t e (List.map (@Some _) ls). - Definition compile {t} (e : expr t) (ls : list Name) := @ocompile t e (List.map (@Some _) ls). -End language. - -Global Arguments ocompilef {_ _ _ _} e ls. -Global Arguments ocompile {_ _ _ _} e ls. -Global Arguments compilef {_ _ _ _} e ls. -Global Arguments compile {_ _ _ _} e ls. diff --git a/src/Reflection/Named/CompileInterp.v b/src/Reflection/Named/CompileInterp.v deleted file mode 100644 index 100d53aa3..000000000 --- a/src/Reflection/Named/CompileInterp.v +++ /dev/null @@ -1,196 +0,0 @@ -(** * PHOAS → Named Representation of Gallina *) -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.NameUtil. -Require Import Crypto.Reflection.Named.NameUtilProperties. -Require Import Crypto.Reflection.Named.ContextDefinitions. -Require Import Crypto.Reflection.Named.ContextProperties. -Require Import Crypto.Reflection.Named.ContextProperties.NameUtil. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.Named.Compile. -Require Import Crypto.Util.PointedProp. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Decidable. -Require Import Crypto.Util.Prod. -Require Import Crypto.Util.ListUtil. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Tactics.SpecializeBy. - -Local Open Scope ctype_scope. -Local Open Scope nexpr_scope. -Local Open Scope expr_scope. -Section language. - Context {base_type_code} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - {Name : Type} - {interp_base_type : base_type_code -> Type} - {interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst} - {base_type_dec : DecidableRel (@eq base_type_code)} - {Name_dec : DecidableRel (@eq Name)} - {Context : @Context base_type_code Name interp_base_type} - {ContextOk : ContextOk Context}. - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation exprf := (@exprf base_type_code op (fun _ => Name)). - Local Notation expr := (@expr base_type_code op (fun _ => Name)). - Local Notation wff := (@wff base_type_code op (fun _ => Name) interp_base_type). - Local Notation wf := (@wf base_type_code op (fun _ => Name) interp_base_type). - Local Notation nexprf := (@Named.exprf base_type_code op Name). - Local Notation nexpr := (@Named.expr base_type_code op Name). - Local Notation ocompilef := (@ocompilef base_type_code op Name). - Local Notation ocompile := (@ocompile base_type_code op Name). - Local Notation compilef := (@compilef base_type_code op Name). - Local Notation compile := (@compile base_type_code op Name). - - Lemma interpf_ocompilef (ctx : Context) {t} (e : exprf t) e' (ls : list (option Name)) - G - (Hwf : wff G e e') - (HG : forall t n x, List.In (existT _ t (n, x)%core) G -> lookupb ctx n t = Some x) - v - (H : ocompilef e ls = Some v) - (Hls : oname_list_unique ls) - (HGls : forall t n x, List.In (existT _ t (n, x)%core) G -> List.In (Some n) ls -> False) - : Named.interpf (interp_op:=interp_op) (ctx:=ctx) v - = Some (interpf interp_op e'). - Proof using ContextOk Name_dec base_type_dec. - revert dependent ctx; revert dependent ls; induction Hwf; - repeat first [ progress intros - | progress subst - | progress inversion_option - | apply (f_equal (@Some _)) - | apply (f_equal (@interp_op _ _ _)) - | solve [ eauto ] - | progress simpl in * - | progress unfold option_map, LetIn.Let_In in * - | progress break_innermost_match_step - | progress break_match_hyps - | progress destruct_head' or - | progress inversion_prod - | progress specialize_by_assumption - | progress specialize_by auto using oname_list_unique_nil - | match goal with - | [ H : forall x, oname_list_unique ?ls -> _ |- _ ] - => specialize (fun pf x => H x pf) - | [ H : context[snd (split_onames _ _)] |- _ ] - => rewrite snd_split_onames_skipn in H - | [ H : oname_list_unique (List.skipn _ _) -> _ |- _ ] - => specialize (fun pf => H (@oname_list_unique_skipn _ _ _ pf)) - | [ IH : forall v ls, ocompilef ?e ls = Some v -> _, H : ocompilef ?e ?ls' = Some ?v' |- _ ] - => specialize (IH _ _ H) - | [ IH : forall x1 x2 v ls, ocompilef (?e x1) ls = Some v -> _, H : ocompilef (?e ?x1') ?ls' = Some ?v' |- _ ] - => specialize (fun x2 => IH _ x2 _ _ H) - | [ H : context[List.In _ (_ ++ _)] |- _ ] - => rewrite List.in_app_iff in H - | [ H : forall ctx, _ -> Named.interpf ?e = Some _, H' : context[Named.interpf ?e] |- _ ] - => rewrite H in H' by assumption - | [ H : forall x2 ctx, _ -> Named.interpf ?e = Some _ |- Named.interpf ?e = Some _ ] - => apply H; clear H - | [ H : forall x2, _ -> forall ctx, _ -> Named.interpf ?e = Some _ |- Named.interpf ?e = Some _ ] - => apply H; clear H - end ]; - repeat match goal with - | _ => erewrite lookupb_extend by assumption - | [ |- context[find_Name_and_val ?tdec ?ndec ?a ?b ?c ?d ?default] ] - => lazymatch default with None => fail | _ => idtac end; - rewrite (find_Name_and_val_split tdec ndec (default:=default)) - | [ H : _ |- _ ] => erewrite H by eassumption - | _ => progress unfold dec in * - | _ => progress break_innermost_match_step - | _ => progress subst - | _ => progress destruct_head' and - | _ => congruence - | [ H : List.In _ (flatten_binding_list _ _) |- _ ] - => erewrite <- (flatten_binding_list_find_Name_and_val_unique _ _) in H; - [ | | apply path_prod_uncurried; split; [ eassumption | simpl; reflexivity ] ]; - [ | solve [ eauto using oname_list_unique_firstn, oname_list_unique_skipn ] ] - | [ H : _ |- _ ] - => first [ erewrite find_Name_and_val_wrong_type in H by eassumption - | rewrite find_Name_and_val_different in H by assumption - | rewrite snd_split_onames_skipn in H ] - | _ => solve [ eauto using In_skipn, In_firstn - | eapply split_onames_find_Name_Some_unique; [ | apply path_prod; simpl | ]; eauto ] - | [ H : find_Name_and_val _ _ ?t ?n ?N ?V None = Some _, H' : List.In (Some ?n) (List.skipn _ ?ls) |- False ] - => eapply find_Name_and_val_find_Name_Some, split_onames_find_Name_Some_unique in H; - [ | | apply path_prod_uncurried; split; [ eassumption | simpl; reflexivity ] ]; - [ | solve [ eauto using oname_list_unique_firstn, oname_list_unique_skipn ] ] - | [ H : List.In (existT _ ?t (?n, _)%core) ?G, - H' : List.In (Some ?n) (List.skipn _ ?ls), - IH : forall t' n' x', List.In (existT _ t' (n', x')%core) ?G -> List.In (Some n') ?ls -> False - |- False ] - => apply (IH _ _ _ H); clear IH H - | [ H : List.In (existT _ ?t (?n, _)%core) ?G, - H' : find_Name _ ?n ?N = Some ?t', - IH : forall t' n' x', List.In (existT _ t' (n', x')%core) ?G -> List.In (Some n') ?ls -> False - |- _ ] - => exfalso; apply (IH _ _ _ H); clear IH H - end. - Qed. - - Lemma interp_ocompile (ctx : Context) {t} (e : expr t) e' (ls : list (option Name)) - (Hwf : wf e e') - f - (Hls : oname_list_unique ls) - (H : ocompile e ls = Some f) - : forall v, Named.interp (interp_op:=interp_op) (ctx:=ctx) f v - = Some (interp interp_op e' v). - Proof using ContextOk Name_dec base_type_dec. - revert H; destruct Hwf; - repeat first [ progress simpl in * - | progress unfold option_map, Named.interp in * - | congruence - | progress break_innermost_match - | progress inversion_option - | progress subst - | progress intros ]. - eapply interpf_ocompilef; - [ eauto | | eassumption - | inversion_prod; subst; rewrite snd_split_onames_skipn; eauto using oname_list_unique_skipn - |intros ???; erewrite <- (flatten_binding_list_find_Name_and_val_unique _ _) by eassumption; - let H := fresh in - intro H; apply find_Name_and_val_find_Name_Some in H; - eapply split_onames_find_Name_Some_unique in H; [ | eassumption.. ]; - intuition ]. - { intros ???. - repeat first [ solve [ auto ] - | rewrite (lookupb_extend Context _ _ _) - | progress subst - | progress break_innermost_match - | erewrite <- (flatten_binding_list_find_Name_and_val_unique _ _) by eassumption - | congruence - | match goal with - | [ |- context[find_Name_and_val ?tdec ?ndec ?a ?b ?c ?d ?default] ] - => lazymatch default with None => fail | _ => idtac end; - rewrite (find_Name_and_val_split tdec ndec (default:=default)) - | [ H : _ |- _ ] => first [ erewrite find_Name_and_val_wrong_type in H by eassumption - | erewrite find_Name_and_val_different in H by eassumption ] - end - | progress intros ]. } - Qed. - - Lemma interpf_compilef (ctx : Context) {t} (e : exprf t) e' (ls : list Name) - G - (Hwf : wff G e e') - (HG : forall t n x, List.In (existT _ t (n, x)%core) G -> lookupb ctx n t = Some x) - v - (H : compilef e ls = Some v) - (Hls : name_list_unique ls) - (HGls : forall t n x, List.In (existT _ t (n, x)%core) G -> List.In n ls -> False) - : Named.interpf (interp_op:=interp_op) (ctx:=ctx) v - = Some (interpf interp_op e'). - Proof using ContextOk Name_dec base_type_dec. - eapply interpf_ocompilef; try eassumption. - setoid_rewrite List.in_map_iff; intros; destruct_head' ex; destruct_head' and; inversion_option; subst. - eauto. - Qed. - - Lemma interp_compile (ctx : Context) {t} (e : expr t) e' (ls : list Name) - (Hwf : wf e e') - f - (Hls : name_list_unique ls) - (H : compile e ls = Some f) - : forall v, Named.interp (interp_op:=interp_op) (ctx:=ctx) f v - = Some (interp interp_op e' v). - Proof using ContextOk Name_dec base_type_dec. eapply interp_ocompile; eassumption. Qed. -End language. diff --git a/src/Reflection/Named/CompileProperties.v b/src/Reflection/Named/CompileProperties.v deleted file mode 100644 index 357004197..000000000 --- a/src/Reflection/Named/CompileProperties.v +++ /dev/null @@ -1,74 +0,0 @@ -Require Import Coq.omega.Omega. -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.NameUtil. -Require Import Crypto.Reflection.Named.NameUtilProperties. -Require Import Crypto.Reflection.Named.Compile. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.CountLets. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.SpecializeBy. -Require Import Crypto.Util.Prod. -Require Import Crypto.Util.ListUtil. - -Local Notation eta x := (fst x, snd x). - -Local Open Scope ctype_scope. -Local Open Scope nexpr_scope. -Local Open Scope expr_scope. -Section language. - Context (base_type_code : Type) - (op : flat_type base_type_code -> flat_type base_type_code -> Type) - (Name : Type) - (dummy : base_type_code -> Name). - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation exprft := (@exprf base_type_code op (fun _ => unit)). - Local Notation exprt := (@expr base_type_code op (fun _ => unit)). - Local Notation exprf := (@exprf base_type_code op (fun _ => Name)). - Local Notation expr := (@expr base_type_code op (fun _ => Name)). - Local Notation nexprf := (@Named.exprf base_type_code op Name). - Local Notation nexpr := (@Named.expr base_type_code op Name). - - Lemma compilef_count_let_bindersf_enough {t} - (e1 : exprf t) (e2 : exprft t) - G - (Hwf : wff G e1 e2) - : forall (ls1 : list Name) - (He : compilef e1 ls1 <> None) - (ls2 : list Name) - (Hls : List.length ls2 >= count_let_bindersf dummy e1), - compilef e1 ls2 <> None. - Proof. - unfold compilef; induction Hwf; - repeat first [ progress simpl in * - | progress cbv [option_map] in * - | progress subst - | progress inversion_prod - | congruence - | omega - | progress break_innermost_match_step - | progress break_match_hyps - | progress intros - | progress specialize_by congruence - | match goal with - | [ H : forall ls1, ocompilef ?e _ <> None -> _, H' : ocompilef ?e (List.map _ ?ls') = Some _ |- _ ] - => specialize (H ls'); rewrite H' in H - | [ H : forall ls1, ocompilef ?e _ <> None -> _, H' : ocompilef ?e nil = Some _ |- _ ] - => specialize (H nil); simpl in H; rewrite H' in H - | [ H : forall v ls1, ocompilef (?e v) _ <> None -> _, H' : ocompilef (?e ?v') _ = Some _ |- _ ] - => specialize (H v') - | [ H : forall ls1, List.length ls1 >= ?k -> _, H' : List.length _ >= ?k |- _ ] - => specialize (H _ H') - | [ H : context[snd (split_onames _ _)] |- _ ] - => rewrite snd_split_onames_skipn in H - | [ H : context[List.skipn _ (List.map _ _)] |- _] - => rewrite skipn_map in H - | [ H : fst (split_onames ?t (List.map _ ?ls)) = None |- _ ] - => rewrite split_onames_split_names in H - | [ H : fst (split_names _ _) = None |- _ ] - => apply length_fst_split_names_None_iff in H - end ]. - Abort. -End language. diff --git a/src/Reflection/Named/CompileWf.v b/src/Reflection/Named/CompileWf.v deleted file mode 100644 index 5fb17b18d..000000000 --- a/src/Reflection/Named/CompileWf.v +++ /dev/null @@ -1,226 +0,0 @@ -(** * PHOAS → Named Representation of Gallina *) -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.Wf. -Require Import Crypto.Reflection.Named.ContextDefinitions. -Require Import Crypto.Reflection.Named.ContextProperties. -Require Import Crypto.Reflection.Named.ContextProperties.NameUtil. -Require Import Crypto.Reflection.Named.NameUtil. -Require Import Crypto.Reflection.Named.NameUtilProperties. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.Named.Compile. -Require Import Crypto.Util.PointedProp. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Prod. -Require Import Crypto.Util.Decidable. -Require Import Crypto.Util.ListUtil. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.SpecializeBy. -Require Import Crypto.Util.Tactics.DestructHead. - -Local Open Scope ctype_scope. -Local Open Scope nexpr_scope. -Local Open Scope expr_scope. -Section language. - Context {base_type_code var} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - {Name : Type} - {base_type_dec : DecidableRel (@eq base_type_code)} - {Name_dec : DecidableRel (@eq Name)} - {Context : @Context base_type_code Name var} - {ContextOk : ContextOk Context}. - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation exprf := (@exprf base_type_code op (fun _ => Name)). - Local Notation expr := (@expr base_type_code op (fun _ => Name)). - Local Notation wff := (@wff base_type_code op (fun _ => Name) var). - Local Notation wf := (@wf base_type_code op (fun _ => Name) var). - Local Notation nexprf := (@Named.exprf base_type_code op Name). - Local Notation nexpr := (@Named.expr base_type_code op Name). - Local Notation nwff := (@Named.wff base_type_code Name op var Context). - Local Notation nwf := (@Named.wf base_type_code Name op var Context). - Local Notation ocompilef := (@ocompilef base_type_code op Name). - Local Notation ocompile := (@ocompile base_type_code op Name). - Local Notation compilef := (@compilef base_type_code op Name). - Local Notation compile := (@compile base_type_code op Name). - - Lemma wff_ocompilef (ctx : Context) G - (HG : forall t n v, - List.In (existT _ t (n, v)%core) G -> lookupb ctx n t = Some v) - {t} (e : exprf t) e' (ls : list (option Name)) - (Hwf : wff G e e') - v - (H : ocompilef e ls = Some v) - (Hls : oname_list_unique ls) - (HGls : forall t n x, List.In (existT _ t (n, x)%core) G -> List.In (Some n) ls -> False) - : prop_of_option (nwff ctx v). - Proof using ContextOk Name_dec base_type_dec. - revert dependent ctx; revert dependent ls; induction Hwf; - repeat first [ progress intros - | progress subst - | progress inversion_option - | solve [ auto ] - | progress simpl in * - | progress unfold option_map in * - | progress break_innermost_match_step - | progress break_match_hyps - | progress autorewrite with push_prop_of_option in * - | progress specialize_by tauto - | progress specialize_by auto using oname_list_unique_nil - | solve [ unfold not in *; eauto using In_skipn, oname_list_unique_firstn, oname_list_unique_skipn ] - | progress destruct_head' or - | match goal with - | [ IH : forall v ls, ocompilef ?e ls = Some v -> _, H : ocompilef ?e ?ls' = Some ?v' |- _ ] - => specialize (IH _ _ H) - | [ IH : forall x1 x2 v ls, ocompilef (?e2 x1) ls = Some v -> _, H : ocompilef (?e2 ?x1') ?ls' = Some ?v' |- _ ] - => specialize (fun x2 => IH _ x2 _ _ H) - | [ HG : forall t n v, List.In _ _ -> _ = Some _, H : _ = None |- _ ] - => erewrite HG in H by eassumption - | [ |- _ /\ _ ] => split - | [ H : context[List.In _ (_ ++ _)] |- _ ] - => setoid_rewrite List.in_app_iff in H - | [ H : split_onames _ _ = (_, _)%core |- _ ] - => pose proof (f_equal (@fst _ _) H); - pose proof (f_equal (@snd _ _) H); - clear H - | [ H : context[snd (split_onames _ _)] |- _ ] - => rewrite snd_split_onames_skipn in H - | [ H : forall a, (forall x y z, _ \/ _ -> _) -> _ |- _ ] - => specialize (fun a pf1 pf2 - => H a (fun x y z pf - => match pf with - | or_introl pf' => pf1 x y z pf' - | or_intror pf' => pf2 x y z pf' - end)) - | [ H : forall a b, (forall x y z, _ \/ _ -> _) -> _ |- _ ] - => specialize (fun a b pf1 pf2 - => H a b (fun x y z pf - => match pf with - | or_introl pf' => pf1 x y z pf' - | or_intror pf' => pf2 x y z pf' - end)) - | [ H : forall a b c, (forall x y z, _ \/ _ -> _) -> _ |- _ ] - => specialize (fun a b c pf1 pf2 - => H a b c (fun x y z pf - => match pf with - | or_introl pf' => pf1 x y z pf' - | or_intror pf' => pf2 x y z pf' - end)) - | [ H : forall a b c d, (forall x y z, _ \/ _ -> _) -> _ |- _ ] - => specialize (fun a b c d pf1 pf2 - => H a b c d (fun x y z pf - => match pf with - | or_introl pf' => pf1 x y z pf' - | or_intror pf' => pf2 x y z pf' - end)) - | [ H : _ |- _ ] - => progress rewrite ?firstn_nil, ?skipn_nil, ?skipn_skipn in H - | [ H : List.In ?x (List.firstn ?a (List.skipn ?b ?ls)), H' : List.In ?x (List.skipn (?b + ?a) ?ls) |- False ] - => rewrite firstn_skipn_add in H; apply In_skipn in H - | [ H : _ |- prop_of_option (nwff _ ?v) ] - => eapply H; clear H - end ]; - repeat match goal with - | _ => erewrite lookupb_extend by assumption - | [ |- context[find_Name_and_val ?tdec ?ndec ?a ?b ?c ?d ?default] ] - => lazymatch default with None => fail | _ => idtac end; - rewrite (find_Name_and_val_split tdec ndec (default:=default)) - | [ H : _ |- _ ] => erewrite H by eassumption - | _ => progress unfold dec in * - | _ => progress break_innermost_match_step - | _ => progress subst - | _ => progress destruct_head' and - | _ => congruence - | [ H : List.In _ (flatten_binding_list _ _) |- _ ] - => erewrite <- (flatten_binding_list_find_Name_and_val_unique _ _) in H; - [ | | apply path_prod_uncurried; split; [ eassumption | simpl; reflexivity ] ]; - [ | solve [ eauto using oname_list_unique_firstn, oname_list_unique_skipn ] ] - | [ H : _ |- _ ] - => first [ erewrite find_Name_and_val_wrong_type in H by eassumption - | rewrite find_Name_and_val_different in H by assumption - | rewrite snd_split_onames_skipn in H ] - | _ => solve [ eauto using In_skipn, In_firstn - | eapply split_onames_find_Name_Some_unique; [ | apply path_prod; simpl | ]; eauto ] - | [ H : find_Name_and_val _ _ ?t ?n ?N ?V None = Some _, H' : List.In (Some ?n) (List.skipn _ ?ls) |- False ] - => eapply find_Name_and_val_find_Name_Some, split_onames_find_Name_Some_unique in H; - [ | | apply path_prod_uncurried; split; [ eassumption | simpl; reflexivity ] ]; - [ | solve [ eauto using oname_list_unique_firstn, oname_list_unique_skipn ] ] - | [ H : List.In (existT _ ?t (?n, _)%core) ?G, - H' : List.In (Some ?n) (List.skipn _ ?ls), - IH : forall t' n' x', List.In (existT _ t' (n', x')%core) ?G -> List.In (Some n') ?ls -> False - |- False ] - => apply (IH _ _ _ H); clear IH H - | [ H : List.In (existT _ ?t (?n, _)%core) ?G, - H' : find_Name _ ?n ?N = Some ?t', - IH : forall t' n' x', List.In (existT _ t' (n', x')%core) ?G -> List.In (Some n') ?ls -> False - |- _ ] - => exfalso; apply (IH _ _ _ H); clear IH H - end. - Qed. - - Lemma wf_ocompile (ctx : Context) {t} (e : expr t) e' (ls : list (option Name)) - (Hwf : wf e e') - f - (Hls : oname_list_unique ls) - (H : ocompile e ls = Some f) - : nwf ctx f. - Proof using ContextOk Name_dec base_type_dec. - revert H; destruct Hwf; - repeat first [ progress simpl in * - | progress unfold option_map, Named.interp in * - | congruence - | progress break_innermost_match - | progress inversion_option - | progress subst - | progress intros ]. - intro; simpl. - eapply wff_ocompilef; - [ | solve [ eauto ] | eassumption - | inversion_prod; subst; rewrite snd_split_onames_skipn; eauto using oname_list_unique_skipn - | intros ???; erewrite <- (flatten_binding_list_find_Name_and_val_unique _ _) by eassumption; - let H := fresh in - intro H; apply find_Name_and_val_find_Name_Some in H; - eapply split_onames_find_Name_Some_unique in H; [ | eassumption.. ]; - intuition ]. - { intros ???. - repeat first [ solve [ auto ] - | rewrite (lookupb_extend Context _ _ _) - | progress subst - | progress break_innermost_match - | erewrite <- (flatten_binding_list_find_Name_and_val_unique _ _) by eassumption - | congruence - | eassumption - | match goal with - | [ |- context[find_Name_and_val ?tdec ?ndec ?a ?b ?c ?d ?default] ] - => lazymatch default with None => fail | _ => idtac end; - rewrite (find_Name_and_val_split tdec ndec (default:=default)) - | [ H : _ |- _ ] => first [ erewrite find_Name_and_val_wrong_type in H by eassumption - | erewrite find_Name_and_val_different in H by eassumption ] - end - | progress intros ]. } - Qed. - - Lemma wff_compilef (ctx : Context) {t} (e : exprf t) e' (ls : list Name) - G - (Hwf : wff G e e') - (HG : forall t n x, List.In (existT _ t (n, x)%core) G -> lookupb ctx n t = Some x) - v - (H : compilef e ls = Some v) - (Hls : name_list_unique ls) - (HGls : forall t n x, List.In (existT _ t (n, x)%core) G -> List.In n ls -> False) - : prop_of_option (nwff ctx v). - Proof using ContextOk Name_dec base_type_dec. - eapply wff_ocompilef; try eassumption. - setoid_rewrite List.in_map_iff; intros; destruct_head' ex; destruct_head' and; inversion_option; subst. - eauto. - Qed. - - Lemma wf_compile (ctx : Context) {t} (e : expr t) e' (ls : list Name) - (Hwf : wf e e') - f - (Hls : name_list_unique ls) - (H : compile e ls = Some f) - : nwf ctx f. - Proof using ContextOk Name_dec base_type_dec. eapply wf_ocompile; eassumption. Qed. -End language. diff --git a/src/Reflection/Named/ContextDefinitions.v b/src/Reflection/Named/ContextDefinitions.v deleted file mode 100644 index c63142de6..000000000 --- a/src/Reflection/Named/ContextDefinitions.v +++ /dev/null @@ -1,59 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Decidable. - -Section with_context. - Context {base_type_code Name var} (Context : @Context base_type_code Name var) - (base_type_code_dec : DecidableRel (@eq base_type_code)) - (Name_dec : DecidableRel (@eq Name)). - - Fixpoint find_Name n - {T : flat_type base_type_code} - : interp_flat_type (fun _ => Name) T -> option base_type_code - := match T with - | Tbase t' => fun n' : Name => if dec (n = n') then Some t' else None - | Unit => fun _ => None - | Prod A B - => fun ab : interp_flat_type _ A * interp_flat_type _ B - => match @find_Name n B (snd ab), @find_Name n A (fst ab) with - | Some tb, _ => Some tb - | None, Some ta => Some ta - | None, None => None - end - end. - - Fixpoint find_Name_and_val {var'} t (n : Name) - {T : flat_type base_type_code} - : interp_flat_type (fun _ => Name) T -> interp_flat_type var' T -> option (var' t) -> option (var' t) - := match T with - | Tbase t' => fun (n' : Name) v default - => if dec (n = n') - then cast_if_eq t' t v - else default - | Unit => fun _ _ default => default - | Prod A B - => fun (ab : interp_flat_type _ A * interp_flat_type _ B) - (a'b' : interp_flat_type _ A * interp_flat_type _ B) - default - => @find_Name_and_val - var' t n B (snd ab) (snd a'b') - (@find_Name_and_val - var' t n A (fst ab) (fst a'b') - default) - end. - - Class ContextOk := - { lookupb_extendb_same - : forall (ctx : Context) n t v, lookupb (extendb ctx n (t:=t) v) n t = Some v; - lookupb_extendb_different - : forall (ctx : Context) n n' t t' v, n <> n' -> lookupb (extendb ctx n (t:=t) v) n' t' - = lookupb ctx n' t'; - lookupb_extendb_wrong_type - : forall (ctx : Context) n t t' v, t <> t' -> lookupb (extendb ctx n (t:=t) v) n t' = None; - lookupb_removeb - : forall (ctx : Context) n n' t t', n <> n' -> lookupb (removeb ctx n t) n' t' - = lookupb ctx n' t'; - lookupb_empty - : forall n t, lookupb (@empty _ _ _ Context) n t = None }. -End with_context. diff --git a/src/Reflection/Named/ContextOn.v b/src/Reflection/Named/ContextOn.v deleted file mode 100644 index d32911283..000000000 --- a/src/Reflection/Named/ContextOn.v +++ /dev/null @@ -1,16 +0,0 @@ -(** * Transfer [Context] across an injection *) -Require Import Crypto.Reflection.Named.Syntax. - -Section language. - Context {base_type_code Name1 Name2 : Type} - (f : Name2 -> Name1) - (f_inj : forall x y, f x = f y -> x = y) - {var : base_type_code -> Type}. - - Definition ContextOn (Ctx : Context Name1 var) : Context Name2 var - := {| ContextT := Ctx; - lookupb ctx n t := lookupb ctx (f n) t; - extendb ctx n t v := extendb ctx (f n) v; - removeb ctx n t := removeb ctx (f n) t; - empty := empty |}. -End language. diff --git a/src/Reflection/Named/ContextProperties.v b/src/Reflection/Named/ContextProperties.v deleted file mode 100644 index c031d0af2..000000000 --- a/src/Reflection/Named/ContextProperties.v +++ /dev/null @@ -1,141 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.ContextDefinitions. -Require Import Crypto.Reflection.Named.ContextProperties.Tactics. -Require Import Crypto.Util.Decidable. -Require Import Crypto.Util.Tactics.BreakMatch. - -Section with_context. - Context {base_type_code Name var} (Context : @Context base_type_code Name var) - (base_type_code_dec : DecidableRel (@eq base_type_code)) - (Name_dec : DecidableRel (@eq Name)) - (ContextOk : ContextOk Context). - - Local Notation find_Name := (@find_Name base_type_code Name Name_dec). - Local Notation find_Name_and_val := (@find_Name_and_val base_type_code Name base_type_code_dec Name_dec). - - Lemma lookupb_eq_cast - : forall (ctx : Context) n t t' (pf : t = t'), - lookupb ctx n t' = option_map (fun v => eq_rect _ var v _ pf) (lookupb ctx n t). - Proof. - intros; subst; edestruct lookupb; reflexivity. - Defined. - Lemma lookupb_extendb_eq - : forall (ctx : Context) n t t' (pf : t = t') v, - lookupb (extendb ctx n (t:=t) v) n t' = Some (eq_rect _ var v _ pf). - Proof. - intros; subst; apply lookupb_extendb_same; assumption. - Defined. - - Lemma lookupb_extend (ctx : Context) - T N t n v - : lookupb (extend ctx N (t:=T) v) n t - = find_Name_and_val t n N v (lookupb ctx n t). - Proof using ContextOk. revert ctx; induction T; t. Qed. - - Lemma find_Name_and_val_Some_None - {var' var''} - {t n T N} - {x : interp_flat_type var' T} - {y : interp_flat_type var'' T} - {default default' v} - (H0 : @find_Name_and_val var' t n T N x default = Some v) - (H1 : @find_Name_and_val var'' t n T N y default' = None) - : default = Some v /\ default' = None. - Proof using Type. - revert dependent default; revert dependent default'; induction T; t. - Qed. - - Lemma find_Name_and_val_default_to_None - {var'} - {t n T N} - {x : interp_flat_type var' T} - {default} - (H : @find_Name n T N <> None) - : @find_Name_and_val var' t n T N x default - = @find_Name_and_val var' t n T N x None. - Proof using Type. revert default; induction T; t. Qed. - Hint Rewrite @find_Name_and_val_default_to_None using congruence : ctx_db. - - Lemma find_Name_and_val_different - {var'} - {t n T N} - {x : interp_flat_type var' T} - {default} - (H : @find_Name n T N = None) - : @find_Name_and_val var' t n T N x default = default. - Proof using Type. revert default; induction T; t. Qed. - Hint Rewrite @find_Name_and_val_different using assumption : ctx_db. - - Lemma find_Name_and_val_wrong_type_iff - {var'} - {t t' n T N} - {x : interp_flat_type var' T} - {default} - (H : @find_Name n T N = Some t') - : t <> t' - <-> @find_Name_and_val var' t n T N x default = None. - Proof using Type. split; revert default; induction T; t. Qed. - Lemma find_Name_and_val_wrong_type - {var'} - {t t' n T N} - {x : interp_flat_type var' T} - {default} - (H : @find_Name n T N = Some t') - (Ht : t <> t') - : @find_Name_and_val var' t n T N x default = None. - Proof using Type. eapply find_Name_and_val_wrong_type_iff; eassumption. Qed. - Hint Rewrite @find_Name_and_val_wrong_type using congruence : ctx_db. - - Lemma find_Name_find_Name_and_val_wrong {var' n t' T V N} - : find_Name n N = Some t' - -> @find_Name_and_val var' t' n T N V None = None - -> False. - Proof using Type. induction T; t. Qed. - - Lemma find_Name_and_val_None_iff - {var'} - {t n T N} - {x : interp_flat_type var' T} - {default} - : (@find_Name n T N <> Some t - /\ (@find_Name n T N <> None \/ default = None)) - <-> @find_Name_and_val var' t n T N x default = None. - Proof using Type. - destruct (@find_Name n T N) eqn:?; unfold not; t; - try solve [ eapply find_Name_and_val_wrong_type; [ eassumption | congruence ] - | eapply find_Name_find_Name_and_val_wrong; eassumption - | left; congruence ]. - Qed. - - Lemma find_Name_and_val_split - {var' t n T N V default} - : @find_Name_and_val var' t n T N V default - = match @find_Name n T N with - | Some t' => if dec (t = t') - then @find_Name_and_val var' t n T N V None - else None - | None => default - end. - Proof using Type. - t; erewrite find_Name_and_val_wrong_type by solve [ eassumption | congruence ]; reflexivity. - Qed. - Lemma find_Name_and_val_find_Name_Some - {var' t n T N V v} - (H : @find_Name_and_val var' t n T N V None = Some v) - : @find_Name n T N = Some t. - Proof using Type. - rewrite find_Name_and_val_split in H; break_match_hyps; subst; congruence. - Qed. -End with_context. - -Ltac find_Name_and_val_default_to_None_step := - match goal with - | [ H : context[find_Name_and_val ?tdec ?ndec _ _ _ _ ?default] |- _ ] - => lazymatch default with None => fail | _ => idtac end; - rewrite (find_Name_and_val_split tdec ndec (default:=default)) in H - | [ |- context[find_Name_and_val ?tdec ?ndec _ _ _ _ ?default] ] - => lazymatch default with None => fail | _ => idtac end; - rewrite (find_Name_and_val_split tdec ndec (default:=default)) - end. -Ltac find_Name_and_val_default_to_None := repeat find_Name_and_val_default_to_None_step. diff --git a/src/Reflection/Named/ContextProperties/NameUtil.v b/src/Reflection/Named/ContextProperties/NameUtil.v deleted file mode 100644 index 4853f9a41..000000000 --- a/src/Reflection/Named/ContextProperties/NameUtil.v +++ /dev/null @@ -1,157 +0,0 @@ -Require Import Coq.omega.Omega. -Require Import Crypto.Util.FixCoqMistakes. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.ContextDefinitions. -Require Import Crypto.Reflection.Named.NameUtil. -Require Import Crypto.Reflection.Named.NameUtilProperties. -Require Import Crypto.Reflection.Named.ContextProperties. -Require Import Crypto.Reflection.Named.ContextProperties.Tactics. -Require Import Crypto.Util.Decidable. -Require Import Crypto.Util.ListUtil. -Require Import Crypto.Util.Prod. -Require Import Crypto.Util.Tactics.SplitInContext. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.SpecializeBy. - -Section with_context. - Context {base_type_code Name var} (Context : @Context base_type_code Name var) - (base_type_code_dec : DecidableRel (@eq base_type_code)) - (Name_dec : DecidableRel (@eq Name)) - (ContextOk : ContextOk Context). - - Local Notation find_Name := (@find_Name base_type_code Name Name_dec). - Local Notation find_Name_and_val := (@find_Name_and_val base_type_code Name base_type_code_dec Name_dec). - - Hint Rewrite (@find_Name_and_val_default_to_None _ _ base_type_code_dec Name_dec) using congruence : ctx_db. - Hint Rewrite (@find_Name_and_val_different _ _ base_type_code_dec Name_dec) using assumption : ctx_db. - Hint Rewrite (@find_Name_and_val_wrong_type _ _ base_type_code_dec Name_dec) using congruence : ctx_db. - Hint Rewrite (@snd_split_onames_skipn base_type_code Name) : ctx_db. - - Local Ltac misc_oname_t_step := - match goal with - | [ H : oname_list_unique (List.skipn _ _) -> _ |- _ ] - => specialize (fun pf => H (@oname_list_unique_skipn _ _ _ pf)) - | [ H : ((_, _) = (_, _))%core -> _ |- _ ] - => specialize (fun a b => H (f_equal2 (@pair _ _) a b)) - | [ H : ?x = (_,_)%core -> _ |- _ ] - => rewrite (surjective_pairing x) in H; - specialize (fun a b => H (f_equal2 (@pair _ _) a b)) - end. - - Lemma split_onames_find_Name - {n T N ls ls'} - (H : split_onames _ ls = (Some N, ls')%core) - : (exists t, @find_Name n T N = Some t) - <-> List.In (Some n) (List.firstn (CountLets.count_pairs T) ls). - Proof using Type. - revert dependent ls; intro ls; revert ls ls'; induction T; intros; - [ | | specialize (IHT1 (fst N) ls (snd (split_onames T1 ls))); - specialize (IHT2 (snd N) (snd (split_onames T1 ls)) (snd (split_onames (T1 * T2) ls))) ]; - repeat first [ misc_oname_t_step - | t_step - | progress split_iff - | progress specialize_by (eexists; eauto) - | solve [ eauto using In_skipn, In_firstn ] - | match goal with - | [ H : List.In ?x (List.firstn ?n ?ls) |- List.In ?x (List.firstn (?n + ?m) ?ls) ] - => apply (In_firstn n); rewrite firstn_firstn by omega - | [ H : _ |- _ ] => first [ rewrite firstn_skipn_add in H - | rewrite firstn_firstn in H by omega ] - | [ H : List.In ?x' (List.firstn (?n + ?m) ?ls) |- List.In ?x' (List.firstn ?m (List.skipn ?n ?ls)) ] - => apply (In_firstn_skipn_split n) in H - end ]. - Qed. - - Lemma split_onames_find_Name_Some_unique_iff - {n T N ls ls'} - (Hls : oname_list_unique ls) - (H : split_onames _ ls = (Some N, ls')%core) - : (exists t, @find_Name n T N = Some t) - <-> List.In (Some n) ls /\ ~List.In (Some n) ls'. - Proof using Type. - rewrite (split_onames_find_Name (ls':=ls') (ls:=ls)) by assumption. - rewrite (surjective_pairing (split_onames _ _)) in H. - rewrite fst_split_onames_firstn, snd_split_onames_skipn in H. - inversion_prod; subst. - split; [ split | intros [? ?] ]; eauto using In_firstn, oname_list_unique_specialize. - eapply In_firstn_skipn_split in H; destruct_head' or; eauto; exfalso; eauto. - Qed. - - Lemma split_onames_find_Name_Some_unique - {t n T N ls ls'} - (Hls : oname_list_unique ls) - (H : split_onames _ ls = (Some N, ls')%core) - (Hfind : @find_Name n T N = Some t) - : List.In (Some n) ls /\ ~List.In (Some n) ls'. - Proof using Type. - eapply split_onames_find_Name_Some_unique_iff; eauto. - Qed. - - Lemma flatten_binding_list_find_Name_and_val_unique - {var' t n T N V v ls ls'} - (Hls : oname_list_unique ls) - (H : split_onames _ ls = (Some N, ls')%core) - : @find_Name_and_val var' t n T N V None = Some v - <-> List.In (existT (fun t => (Name * var' t)%type) t (n, v)) (Wf.flatten_binding_list N V). - Proof using Type. - revert dependent ls; intro ls; revert ls ls'; induction T; intros; - [ | | specialize (IHT1 (fst N) (fst V) ls (snd (split_onames T1 ls))); - specialize (IHT2 (snd N) (snd V) (snd (split_onames T1 ls)) (snd (split_onames (T1 * T2) ls))) ]; - repeat first [ find_Name_and_val_default_to_None_step - | progress simpl in * - | rewrite List.in_app_iff - | misc_oname_t_step - | t_step - | progress split_iff - | lazymatch goal with - | [ H : find_Name ?n ?x = Some ?t, H' : find_Name_and_val ?t' ?n ?X ?V None = Some ?v |- _ ] - => apply find_Name_and_val_find_Name_Some in H' - | [ H : find_Name ?n ?x = Some ?t, H' : find_Name ?n ?x' = Some ?t' |- _ ] - => let apply_in_tac H := - (eapply split_onames_find_Name_Some_unique in H; - [ | | apply path_prod_uncurried; split; [ eassumption | simpl; reflexivity ] ]; - [ | solve [ eauto using oname_list_unique_firstn, oname_list_unique_skipn ] ]) in - first [ constr_eq x x'; fail 1 - | apply_in_tac H; apply_in_tac H' ] - end ]. - Qed. - - Lemma fst_split_mnames__flatten_binding_list__find_Name - (MName : Type) (force : MName -> option Name) - {var' t n T N V v} {ls : list MName} - (Hs : fst (split_mnames force T ls) = Some N) - (HN : List.In (existT _ t (n, v)%core) (Wf.flatten_binding_list (var2:=var') N V)) - : find_Name n N = Some t. - Proof. - revert dependent ls; induction T; - [ | | specialize (IHT1 (fst N) (fst V)); - specialize (IHT2 (snd N) (snd V)) ]; - repeat first [ misc_oname_t_step - | t_step - | match goal with - | [ H : _ |- _ ] => first [ rewrite snd_split_mnames_skipn in H - | rewrite List.in_app_iff in H ] - | [ H : context[fst (split_mnames _ _ ?ls)] |- _ ] - => is_var ls; rewrite (@fst_split_mnames_firstn _ _ _ _ _ ls) in H - end ]. - Abort. - - Lemma fst_split_mnames__find_Name__flatten_binding_list - (MName : Type) (force : MName -> option Name) - {var' t n T N V v default} {ls : list MName} - (Hs : fst (split_mnames force T ls) = Some N) - (Hfind : find_Name n N = Some t) - (HN : List.In (existT _ t (n, v)%core) (Wf.flatten_binding_list N V)) - : @find_Name_and_val var' t n T N V default = Some v. - Proof. - revert default; revert dependent ls; induction T; - [ | | specialize (IHT1 (fst N) (fst V)); - specialize (IHT2 (snd N) (snd V)) ]; - repeat first [ find_Name_and_val_default_to_None_step - | rewrite List.in_app_iff in * - | t_step ]. - Abort. -End with_context. diff --git a/src/Reflection/Named/ContextProperties/SmartMap.v b/src/Reflection/Named/ContextProperties/SmartMap.v deleted file mode 100644 index 89d0d1c5d..000000000 --- a/src/Reflection/Named/ContextProperties/SmartMap.v +++ /dev/null @@ -1,200 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.ContextDefinitions. -Require Import Crypto.Reflection.Named.ContextProperties. -Require Import Crypto.Reflection.Named.ContextProperties.Tactics. -Require Import Crypto.Util.Decidable. - -Section with_context. - Context {base_type_code Name var} (Context : @Context base_type_code Name var) - (base_type_code_dec : DecidableRel (@eq base_type_code)) - (Name_dec : DecidableRel (@eq Name)) - (ContextOk : ContextOk Context). - - Local Notation find_Name := (@find_Name base_type_code Name Name_dec). - Local Notation find_Name_and_val := (@find_Name_and_val base_type_code Name base_type_code_dec Name_dec). - - Hint Rewrite (@find_Name_and_val_default_to_None _ _ base_type_code_dec Name_dec) using congruence : ctx_db. - Hint Rewrite (@find_Name_and_val_different _ _ base_type_code_dec Name_dec) using assumption : ctx_db. - Hint Rewrite (@find_Name_and_val_wrong_type _ _ base_type_code_dec Name_dec) using congruence : ctx_db. - - Lemma find_Name_and_val_flatten_binding_list - {var' var'' t n T N V1 V2 v1 v2} - (H1 : @find_Name_and_val var' t n T N V1 None = Some v1) - (H2 : @find_Name_and_val var'' t n T N V2 None = Some v2) - : List.In (existT (fun t => (var' t * var'' t)%type) t (v1, v2)) (Wf.flatten_binding_list V1 V2). - Proof using Type. - induction T; - [ | | specialize (IHT1 (fst N) (fst V1) (fst V2)); - specialize (IHT2 (snd N) (snd V1) (snd V2)) ]; - repeat first [ find_Name_and_val_default_to_None_step - | rewrite List.in_app_iff - | t_step ]. - Qed. - - Lemma find_Name_SmartFlatTypeMapInterp2_None_iff {var' n f T V N} - : @find_Name n (SmartFlatTypeMap f (t:=T) V) - (SmartFlatTypeMapInterp2 (var':=var') (fun _ _ (n' : Name) => n') V N) = None - <-> find_Name n N = None. - Proof using Type. - split; - (induction T; - [ | | specialize (IHT1 (fst V) (fst N)); - specialize (IHT2 (snd V) (snd N)) ]); - t. - Qed. - Hint Rewrite @find_Name_SmartFlatTypeMapInterp2_None_iff : ctx_db. - Lemma find_Name_SmartFlatTypeMapInterp2_None {var' n f T V N} - : @find_Name n (SmartFlatTypeMap f (t:=T) V) - (SmartFlatTypeMapInterp2 (var':=var') (fun _ _ (n' : Name) => n') V N) = None - -> find_Name n N = None. - Proof using Type. apply find_Name_SmartFlatTypeMapInterp2_None_iff. Qed. - Hint Rewrite @find_Name_SmartFlatTypeMapInterp2_None using eassumption : ctx_db. - Lemma find_Name_SmartFlatTypeMapInterp2_None' {var' n f T V N} - : find_Name n N = None - -> @find_Name n (SmartFlatTypeMap f (t:=T) V) - (SmartFlatTypeMapInterp2 (var':=var') (fun _ _ (n' : Name) => n') V N) = None. - Proof using Type. apply find_Name_SmartFlatTypeMapInterp2_None_iff. Qed. - Lemma find_Name_SmartFlatTypeMapInterp2_None_Some_wrong {var' n f T V N v} - : @find_Name n (SmartFlatTypeMap f (t:=T) V) - (SmartFlatTypeMapInterp2 (var':=var') (fun _ _ (n' : Name) => n') V N) = None - -> find_Name n N = Some v - -> False. - Proof using Type. - intro; erewrite find_Name_SmartFlatTypeMapInterp2_None by eassumption; congruence. - Qed. - Local Hint Resolve @find_Name_SmartFlatTypeMapInterp2_None_Some_wrong. - - Lemma find_Name_SmartFlatTypeMapInterp2 {var' n f T V N} - : @find_Name n (SmartFlatTypeMap f (t:=T) V) - (SmartFlatTypeMapInterp2 (var':=var') (fun _ _ (n' : Name) => n') V N) - = match find_Name n N with - | Some t' => match find_Name_and_val t' n N V None with - | Some v => Some (f t' v) - | None => None - end - | None => None - end. - Proof using Type. - induction T; - [ | | specialize (IHT1 (fst V) (fst N)); - specialize (IHT2 (snd V) (snd N)) ]. - { t. } - { t. } - { repeat first [ fin_t_step - | inversion_step - | rewrite_lookupb_extendb_step - | misc_t_step - | refolder_t_step ]. - repeat match goal with - | [ |- context[match @find_Name ?n ?T ?N with _ => _ end] ] - => destruct (@find_Name n T N) eqn:? - | [ H : context[match @find_Name ?n ?T ?N with _ => _ end] |- _ ] - => destruct (@find_Name n T N) eqn:? - end; - repeat first [ fin_t_step - | rewriter_t_step - | fin_t_late_step ]. } - Qed. - - Lemma find_Name_and_val__SmartFlatTypeMapInterp2__SmartFlatTypeMapUnInterp__Some_Some_alt - {var' var'' var''' t b n f g T V N X v v'} - (Hfg - : forall (V : var' t) (X : var'' (f t V)) (H : f t V = f t b), - g t b (eq_rect (f t V) var'' X (f t b) H) = g t V X) - : @find_Name_and_val - var'' (f t b) n (SmartFlatTypeMap f (t:=T) V) - (SmartFlatTypeMapInterp2 (var':=var') (fun _ _ (n' : Name) => n') V N) X None = Some v - -> @find_Name_and_val - var''' t n T N (SmartFlatTypeMapUnInterp (f:=f) g X) None = Some v' - -> g t b v = v'. - Proof using Type. - induction T; - [ | | specialize (IHT1 (fst V) (fst N) (fst X)); - specialize (IHT2 (snd V) (snd N) (snd X)) ]; - repeat first [ find_Name_and_val_default_to_None_step - | t_step - | match goal with - | [ H : _ |- _ ] - => progress rewrite find_Name_and_val_different in H - by solve [ congruence - | apply find_Name_SmartFlatTypeMapInterp2_None'; assumption ] - end ]. - Qed. - - Lemma find_Name_and_val__SmartFlatTypeMapInterp2__SmartFlatTypeMapUnInterp__Some_Some - {var' var'' var''' t b n f g T V N X v v'} - : @find_Name_and_val - var'' (f t b) n (SmartFlatTypeMap f (t:=T) V) - (SmartFlatTypeMapInterp2 (var':=var') (fun _ _ (n' : Name) => n') V N) X None = Some v - -> @find_Name_and_val - _ t n T N V None = Some b - -> @find_Name_and_val - var''' t n T N (SmartFlatTypeMapUnInterp (f:=f) g X) None = Some v' - -> g t b v = v'. - Proof using Type. - induction T; - [ | | specialize (IHT1 (fst V) (fst N) (fst X)); - specialize (IHT2 (snd V) (snd N) (snd X)) ]; - repeat first [ find_Name_and_val_default_to_None_step - | t_step - | match goal with - | [ H : _ |- _ ] - => progress rewrite find_Name_and_val_different in H - by solve [ congruence - | apply find_Name_SmartFlatTypeMapInterp2_None'; assumption ] - end ]. - Qed. - - Lemma interp_flat_type_rel_pointwise__find_Name_and_val - {var' var'' t n T N x y R v0 v1} - (H0 : @find_Name_and_val var' t n T N x None = Some v0) - (H1 : @find_Name_and_val var'' t n T N y None = Some v1) - (HR : interp_flat_type_rel_pointwise R x y) - : R _ v0 v1. - Proof using Type. - induction T; - [ | | specialize (IHT1 (fst N) (fst x) (fst y)); - specialize (IHT2 (snd N) (snd x) (snd y)) ]; - repeat first [ find_Name_and_val_default_to_None_step - | t_step ]. - Qed. - - Lemma find_Name_and_val_SmartFlatTypeMapUnInterp2_Some_Some - {var' var'' var''' f g} - {T} - {N : interp_flat_type (fun _ : base_type_code => Name) T} - {B : interp_flat_type var' T} - {V : interp_flat_type var'' (SmartFlatTypeMap (t:=T) f B)} - {n : Name} - {t : base_type_code} - {v : var''' t} - {b} - {h} {i : forall v, var'' (f _ (h v))} - (Hn : find_Name n N = Some t) - (Hf : find_Name_and_val t n N (SmartFlatTypeMapUnInterp2 g V) None = Some v) - (Hb : find_Name_and_val t n N B None = Some b) - (Hig : forall B V, - existT _ (h (g _ B V)) (i (g _ B V)) - = existT _ B V - :> { b : _ & var'' (f _ b)}) - (N' := SmartFlatTypeMapInterp2 (var'':=fun _ => Name) (f:=f) (fun _ _ n => n) _ N) - : b = h v /\ find_Name_and_val (f t (h v)) n N' V None = Some (i v). - Proof using Type. - induction T; - [ | | specialize (IHT1 (fst N) (fst B) (fst V)); - specialize (IHT2 (snd N) (snd B) (snd V)) ]; - repeat first [ find_Name_and_val_default_to_None_step - | lazymatch goal with - | [ H : context[find_Name ?n (@SmartFlatTypeMapInterp2 _ ?var' _ _ ?f _ ?T ?V ?N)] |- _ ] - => setoid_rewrite find_Name_SmartFlatTypeMapInterp2 in H - end - | t_step - | match goal with - | [ Hhg : forall B V, existT _ (?h (?g ?t B V)) _ = existT _ B _ |- context[?h (?g ?t ?B' ?V')] ] - => specialize (Hhg B' V'); generalize dependent (g t B' V') - end ]. - Qed. -End with_context. diff --git a/src/Reflection/Named/ContextProperties/Tactics.v b/src/Reflection/Named/ContextProperties/Tactics.v deleted file mode 100644 index 91d6d20d2..000000000 --- a/src/Reflection/Named/ContextProperties/Tactics.v +++ /dev/null @@ -1,99 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.ContextDefinitions. -Require Import Crypto.Util.Decidable. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Prod. -Require Import Crypto.Util.Sigma. -Require Import Crypto.Util.HProp. -Require Import Crypto.Util.Tactics.SplitInContext. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.SpecializeBy. - -Ltac fin_t_step := - solve [ reflexivity ]. -Ltac fin_t_late_step := - solve [ tauto - | congruence - | eauto - | exfalso; unfold not in *; eauto ]. -Ltac inversion_step := - first [ progress subst - | match goal with - | [ H := _ |- _ ] => subst H - | [ H : ?x = ?y |- _ ] => subst x || subst y - end - | progress inversion_option - | progress inversion_sigma - | progress inversion_prod - | progress destruct_head' and - | progress eliminate_hprop_eq - | match goal with - | [ H : ?T, H' : ?T |- _ ] => clear H' - | [ H : ?x = ?x |- _ ] => clear H - end - | progress split_and ]. -Ltac rewrite_lookupb_extendb_step := - first [ rewrite lookupb_extendb_different by congruence - | rewrite lookupb_extendb_same - | rewrite lookupb_extendb_wrong_type by assumption ]. -Ltac specializer_t_step := - match goal with - | _ => progress specialize_by_assumption - | [ H : ?x = ?x -> _ |- _ ] => specialize (H eq_refl) - | [ H : ?T, H' : ?T |- _ ] => clear H' - | [ H : forall v, Some _ = Some v -> _ |- _ ] - => specialize (H _ eq_refl) - | [ H : forall v, Some v = Some _ -> _ |- _ ] - => specialize (H _ eq_refl) - end. -Ltac misc_t_step := - first [ progress intros - | progress simpl in * ]. -Ltac break_t_step := - first [ progress break_innermost_match_step - | progress unfold cast_if_eq in * - | match goal with - | [ H : context[match _ with _ => _ end] |- _ ] - => revert H; progress break_innermost_match_step - | [ |- _ /\ _ ] => split - | [ |- _ <-> _ ] => split - | [ |- ~ _ ] => intro - end - | progress destruct_head' ex - | progress destruct_head' or ]. -Ltac refolder_t_step := - let myfold_in_star c := - (let c' := (eval cbv [interp_flat_type] in c) in - change c' with c in * ) in - first [ match goal with - | [ var : ?base_type_code -> Type |- _ ] - => progress myfold_in_star (@interp_flat_type base_type_code var) - | [ base_type_code : Type, Name : Type |- _ ] - => progress myfold_in_star (@interp_flat_type base_type_code (fun _ => Name)) - - end ]. -Ltac rewriter_t_step := - first [ match goal with - | [ H : _ |- _ ] => rewrite H by (assumption || congruence) - | [ H : _ |- _ ] => etransitivity; [ | rewrite H by (assumption || congruence); reflexivity ] - | [ H : ?x = Some _, H' : context[?x] |- _ ] => rewrite H in H' - | [ H : ?x = None, H' : context[?x] |- _ ] => rewrite H in H' - | [ H : ?x = ?a :> option _, H' : ?x = ?b :> option _ |- _ ] - => assert (a = b) - by (transitivity x; [ symmetry | ]; assumption); - clear H' - | _ => progress autorewrite with ctx_db in * - end ]. -Ltac t_step := - first [ fin_t_step - | inversion_step - | rewrite_lookupb_extendb_step - | specializer_t_step - | misc_t_step - | break_t_step - | refolder_t_step - | rewriter_t_step - | fin_t_late_step ]. -Ltac t := repeat t_step. diff --git a/src/Reflection/Named/DeadCodeElimination.v b/src/Reflection/Named/DeadCodeElimination.v deleted file mode 100644 index d97c36742..000000000 --- a/src/Reflection/Named/DeadCodeElimination.v +++ /dev/null @@ -1,66 +0,0 @@ -(** * PHOAS → Named Representation of Gallina *) -Require Import Coq.PArith.BinPos Coq.Lists.List. -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.Compile. -Require Import Crypto.Reflection.Named.RegisterAssign. -Require Import Crypto.Reflection.Named.PositiveContext. -Require Import Crypto.Reflection.Named.EstablishLiveness. -Require Import Crypto.Reflection.CountLets. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Util.ListUtil. -Require Import Crypto.Util.LetIn. - -Local Notation eta x := (fst x, snd x). - -Local Open Scope ctype_scope. -Local Open Scope nexpr_scope. -Local Open Scope expr_scope. -Section language. - Context (base_type_code : Type) - (op : flat_type base_type_code -> flat_type base_type_code -> Type) - (Name : Type) - {Context : Context Name (fun _ : base_type_code => positive)}. - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation exprf := (@exprf base_type_code op (fun _ => Name)). - Local Notation expr := (@expr base_type_code op (fun _ => Name)). - Local Notation Expr := (@Expr base_type_code op). - (*Local Notation lexprf := (@Syntax.exprf base_type_code op (fun _ => list (option Name))). - Local Notation lexpr := (@Syntax.expr base_type_code op (fun _ => list (option Name))).*) - Local Notation nexprf := (@Named.exprf base_type_code op Name). - Local Notation nexpr := (@Named.expr base_type_code op Name). - - (*Definition get_live_namesf (names : list (option Name)) {t} (e : lexprf t) : list (option Name) - := filter_live_namesf - base_type_code op - (option Name) None - (fun x y => match x, y with - | Some x, _ => Some x - | _, Some y => Some y - | None, None => None - end) - nil names e. - Definition get_live_names (names : list (option Name)) {t} (e : lexpr t) : list (option Name) - := filter_live_names - base_type_code op - (option Name) None - (fun x y => match x, y with - | Some x, _ => Some x - | _, Some y => Some y - | None, None => None - end) - nil names e.*) - - Definition CompileAndEliminateDeadCode - {t} (e : Expr t) (ls : list Name) - : option (nexpr t) - := let e := compile (Name:=positive) (e _) (List.map Pos.of_nat (seq 1 (CountBinders e))) in - match e with - | Some e => Let_In (insert_dead_names (Context:=PositiveContext_nd) None e ls) (* help vm_compute by factoring this out *) - (fun names => register_reassign (InContext:=PositiveContext_nd) (ReverseContext:=Context) Pos.eqb empty empty e names) - | None => None - end. -End language. - -Global Arguments CompileAndEliminateDeadCode {_ _ _ _ t} e ls. diff --git a/src/Reflection/Named/EstablishLiveness.v b/src/Reflection/Named/EstablishLiveness.v deleted file mode 100644 index 7509d5f7a..000000000 --- a/src/Reflection/Named/EstablishLiveness.v +++ /dev/null @@ -1,104 +0,0 @@ -(** * Compute a list of liveness values for each binding *) -Require Import Coq.Lists.List. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.CountLets. -Require Import Crypto.Util.ListUtil. - -Local Notation eta x := (fst x, snd x). - -Local Open Scope ctype_scope. -Delimit Scope nexpr_scope with nexpr. - -Inductive liveness := live | dead. -Fixpoint merge_liveness (ls1 ls2 : list liveness) := - match ls1, ls2 with - | cons x xs, cons y ys - => cons match x, y with - | live, _ - | _, live - => live - | dead, dead - => dead - end - (@merge_liveness xs ys) - | nil, ls - | ls, nil - => ls - end. - -Section language. - Context (base_type_code : Type) - (op : flat_type base_type_code -> flat_type base_type_code -> Type). - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation exprf := (@exprf base_type_code op). - Local Notation expr := (@expr base_type_code op). - - Section internal. - Context (Name : Type) - (OutName : Type) - {Context : Context Name (fun _ : base_type_code => list liveness)}. - - Definition compute_livenessf_step - (compute_livenessf : forall (ctx : Context) {t} (e : exprf Name t) (prefix : list liveness), list liveness) - (ctx : Context) - {t} (e : exprf Name t) (prefix : list liveness) - : list liveness - := match e with - | TT => prefix - | Var t' name => match lookup ctx (Tbase t') name with - | Some ls => ls - | _ => nil - end - | Op _ _ op args - => @compute_livenessf ctx _ args prefix - | LetIn tx n ex _ eC - => let lx := @compute_livenessf ctx _ ex prefix in - let lx := merge_liveness lx (prefix ++ repeat live (count_pairs tx)) in - let ctx := extend ctx n (SmartValf _ (fun _ => lx) tx) in - @compute_livenessf ctx _ eC (prefix ++ repeat dead (count_pairs tx)) - | Pair _ ex _ ey - => merge_liveness (@compute_livenessf ctx _ ex prefix) - (@compute_livenessf ctx _ ey prefix) - end. - - Fixpoint compute_livenessf ctx {t} e prefix - := @compute_livenessf_step (@compute_livenessf) ctx t e prefix. - - Definition compute_liveness (ctx : Context) - {t} (e : expr Name t) (prefix : list liveness) - : list liveness - := match e with - | Abs src _ n f - => let prefix := prefix ++ repeat live (count_pairs src) in - let ctx := extend (t:=src) ctx n (SmartValf _ (fun _ => prefix) src) in - compute_livenessf ctx f prefix - end. - - Section insert_dead. - Context (default_out : option OutName). - - Fixpoint insert_dead_names_gen (ls : list liveness) (lsn : list OutName) - : list (option OutName) - := match ls with - | nil => nil - | cons live xs - => match lsn with - | cons n lsn' => Some n :: @insert_dead_names_gen xs lsn' - | nil => default_out :: @insert_dead_names_gen xs nil - end - | cons dead xs - => None :: @insert_dead_names_gen xs lsn - end. - Definition insert_dead_names {t} (e : expr Name t) - := insert_dead_names_gen (compute_liveness empty e nil). - End insert_dead. - End internal. -End language. - -Global Arguments compute_livenessf {_ _ _ _} ctx {t} e prefix. -Global Arguments compute_liveness {_ _ _ _} ctx {t} e prefix. -Global Arguments insert_dead_names {_ _ _ _ _} default_out {t} e lsn. diff --git a/src/Reflection/Named/FMapContext.v b/src/Reflection/Named/FMapContext.v deleted file mode 100644 index e01186f2c..000000000 --- a/src/Reflection/Named/FMapContext.v +++ /dev/null @@ -1,68 +0,0 @@ -Require Import Coq.Bool.Sumbool. -Require Import Coq.FSets.FMapInterface. -Require Import Coq.FSets.FMapFacts. -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.ContextDefinitions. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Equality. - -Module FMapContextFun (E : DecidableType) (W : WSfun E). - Module Import Properties := WProperties_fun E W. - Import F. - Section ctx. - Context (E_eq_l : forall x y, E.eq x y -> x = y) - base_type_code (var : base_type_code -> Type) - (base_type_code_beq : base_type_code -> base_type_code -> bool) - (base_type_code_bl_transparent : forall x y, base_type_code_beq x y = true -> x = y) - (base_type_code_lb : forall x y, x = y -> base_type_code_beq x y = true). - - Definition var_cast {a b} (x : var a) : option (var b) - := match Sumbool.sumbool_of_bool (base_type_code_beq a b), Sumbool.sumbool_of_bool (base_type_code_beq b b) with - | left pf, left pf' => match eq_trans (base_type_code_bl_transparent _ _ pf) (eq_sym (base_type_code_bl_transparent _ _ pf')) with - | eq_refl => Some x - end - | right _, _ | _, right _ => None - end. - Definition FMapContext : @Context base_type_code W.key var - := {| ContextT := W.t { t : _ & var t }; - lookupb ctx n t - := match W.find n ctx with - | Some (existT t' v) - => var_cast v - | None => None - end; - extendb ctx n t v - := W.add n (existT _ t v) ctx; - removeb ctx n t - := W.remove n ctx; - empty := W.empty _ |}. - Lemma FMapContextOk : @ContextOk base_type_code W.key var FMapContext. - Proof using E_eq_l base_type_code_lb. - split; - repeat first [ reflexivity - | progress simpl in * - | progress intros - | rewrite add_eq_o by reflexivity - | progress rewrite ?add_neq_o, ?remove_neq_o in * by intuition - | progress rewrite empty_o in * - | progress unfold var_cast - | progress break_innermost_match_step - | rewrite concat_pV - | congruence - | rewrite base_type_code_lb in * by reflexivity ]. - Qed. - End ctx. - - Section ctx_nd. - Context {base_type_code var : Type}. - - Definition FMapContext_nd : @Context base_type_code W.key (fun _ => var) - := {| ContextT := W.t var; - lookupb ctx n t := W.find n ctx; - extendb ctx n t v := W.add n v ctx; - removeb ctx n t := W.remove n ctx; - empty := W.empty _ |}. - End ctx_nd. -End FMapContextFun. - -Module FMapContext (W : WS) := FMapContextFun W.E W. diff --git a/src/Reflection/Named/IdContext.v b/src/Reflection/Named/IdContext.v deleted file mode 100644 index c2a6936f8..000000000 --- a/src/Reflection/Named/IdContext.v +++ /dev/null @@ -1,25 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Named.Syntax. - -Section language. - Context {base_type_code Name} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - (Context : @Context base_type_code Name (fun _ => Name)). - - Fixpoint collect_binders {t} (e : Named.exprf base_type_code op Name t) - : list { t : flat_type base_type_code & interp_flat_type (fun _ => Name) t } - := match e with - | TT => nil - | Var t n => (existT _ (Tbase t) n) :: nil - | Op t1 tR opc args => @collect_binders _ args - | LetIn tx n ex tC eC - => (existT _ tx n) :: @collect_binders tx ex ++ @collect_binders tC eC - | Pair tx ex ty ey - => @collect_binders tx ex ++ @collect_binders ty ey - end%list. - Definition idcontext {t} (e : Named.exprf base_type_code op Name t) : Context - := List.fold_right - (fun v ctx => extend ctx (projT2 v) (projT2 v)) - empty - (collect_binders e). -End language. diff --git a/src/Reflection/Named/InterpretToPHOAS.v b/src/Reflection/Named/InterpretToPHOAS.v deleted file mode 100644 index a9a44a93f..000000000 --- a/src/Reflection/Named/InterpretToPHOAS.v +++ /dev/null @@ -1,64 +0,0 @@ -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.Wf. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Util.PointedProp. - -Local Notation eta_and x := (conj (let (a, b) := x in a) (let (a, b) := x in b)). - -Module Export Named. - Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - {Name : Type}. - Section with_var. - Context {var : base_type_code -> Type} - {Context : Context Name var} - (failb : forall t, @Syntax.exprf base_type_code op var (Tbase t)). - - Local Notation failf t (* : @Syntax.exprf base_type_code op var t*) - := (SmartPairf (SmartValf _ failb t)). - - Fixpoint interpf_to_phoas - (ctx : Context) - {t} (e : @Named.exprf base_type_code op Name t) - {struct e} - : @Syntax.exprf base_type_code op var t - := match e in Named.exprf _ _ _ t return @Syntax.exprf base_type_code op var t with - | Named.Var t' x - => match lookupb ctx x t' with - | Some v => Var v - | None => failf _ - end - | Named.TT => TT - | Named.Pair tx ex ty ey - => Pair (@interpf_to_phoas ctx tx ex) (@interpf_to_phoas ctx ty ey) - | Named.Op _ _ opc args - => Op opc (@interpf_to_phoas ctx _ args) - | Named.LetIn _ n ex _ eC - => LetIn (@interpf_to_phoas ctx _ ex) - (fun v - => @interpf_to_phoas (extend ctx n v) _ eC) - end. - - Definition interp_to_phoas - (ctx : Context) - {t} (e : @Named.expr base_type_code op Name t) - : @Syntax.expr base_type_code op var (domain t -> codomain t) - := Abs (fun v => interpf_to_phoas (extend ctx (Abs_name e) v) (invert_Abs e)). - End with_var. - - Section all. - Context {Context : forall var, @Context base_type_code Name var} - (failb : forall var t, @Syntax.exprf base_type_code op var (Tbase t)). - Definition InterpToPHOAS_gen - (ctx : forall var, Context var) - {t} (e : @Named.expr base_type_code op Name t) - : @Syntax.Expr base_type_code op (domain t -> codomain t) - := fun var => interp_to_phoas (failb var) (ctx var) e. - - Definition InterpToPHOAS {t} e - := @InterpToPHOAS_gen (fun var => empty) t e. - End all. - End language. -End Named. diff --git a/src/Reflection/Named/InterpretToPHOASInterp.v b/src/Reflection/Named/InterpretToPHOASInterp.v deleted file mode 100644 index 4f66e94d4..000000000 --- a/src/Reflection/Named/InterpretToPHOASInterp.v +++ /dev/null @@ -1,88 +0,0 @@ -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.Wf. -Require Import Crypto.Reflection.Named.ContextDefinitions. -Require Import Crypto.Reflection.Named.ContextProperties. -Require Import Crypto.Reflection.Named.InterpretToPHOAS. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Util.PointedProp. -Require Import Crypto.Util.Decidable. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.DestructHead. - -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - {Name : Type} - {base_type_code_dec : DecidableRel (@eq base_type_code)} - {Name_dec : DecidableRel (@eq Name)} - {interp_base_type : base_type_code -> Type} - {interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst}. - Section with_context. - Context {Context : Context Name interp_base_type} - {ContextOk : ContextOk Context} - (failb : forall t, @Syntax.exprf base_type_code op interp_base_type (Tbase t)). - - Lemma interpf_interpf_to_phoas - (ctx : Context) - {t} (e : @Named.exprf base_type_code op Name t) - (Hwf : prop_of_option (Named.wff ctx e)) - : Named.interpf (interp_op:=interp_op) (ctx:=ctx) e - = Some (Syntax.interpf interp_op (interpf_to_phoas failb ctx e)). - Proof using Type. - revert dependent ctx; induction e; - repeat first [ progress intros - | progress subst - | progress inversion_option - | progress destruct_head' and - | progress break_innermost_match_step - | progress unfold option_map, LetIn.Let_In in * - | apply (f_equal (@Some _)) - | apply (f_equal (@interp_op _ _ _)) - | progress simpl in * - | progress autorewrite with push_prop_of_option in * - | solve [ eauto | congruence | tauto ] - | match goal with - | [ H : forall ctx Hwf', Named.interpf ?e = Some _, Hwf : prop_of_option (Named.wff _ ?e) |- _ ] - => specialize (H _ Hwf) - | [ H : forall ctx Hwf, Named.interpf ?e = Some _ |- Named.interpf ?e = Some _ ] - => rewrite H by auto - end ]. - Qed. - - Lemma interp_interp_to_phoas - (ctx : Context) - {t} (e : @Named.expr base_type_code op Name t) - (Hwf : Named.wf ctx e) - v - : Named.interp (interp_op:=interp_op) (ctx:=ctx) e v - = Some (Syntax.interp interp_op (interp_to_phoas failb ctx e) v). - Proof using Type. - unfold interp, interp_to_phoas, Named.interp; apply interpf_interpf_to_phoas; auto. - Qed. - End with_context. - - Section all. - Context {Context : forall var, @Context base_type_code Name var} - {ContextOk : forall var, ContextOk (Context var)} - (failb : forall var t, @Syntax.exprf base_type_code op var (Tbase t)). - - Lemma Interp_InterpToPHOAS_gen - {ctx : forall var, Context var} - {t} (e : @Named.expr base_type_code op Name t) - (Hwf : forall var, Named.wf (ctx var) e) - v - : Named.interp (interp_op:=interp_op) (ctx:=ctx _) e v - = Some (Interp interp_op (InterpToPHOAS_gen failb ctx e) v). - Proof using Type. apply interp_interp_to_phoas; auto. Qed. - - Lemma Interp_InterpToPHOAS - {t} (e : @Named.expr base_type_code op Name t) - (Hwf : Named.Wf Context e) - v - : Named.interp (Context:=Context _) (interp_op:=interp_op) (ctx:=empty) e v - = Some (Interp interp_op (InterpToPHOAS (Context:=Context) failb e) v). - Proof using Type. apply interp_interp_to_phoas; auto. Qed. - End all. -End language. diff --git a/src/Reflection/Named/InterpretToPHOASWf.v b/src/Reflection/Named/InterpretToPHOASWf.v deleted file mode 100644 index daab24b62..000000000 --- a/src/Reflection/Named/InterpretToPHOASWf.v +++ /dev/null @@ -1,138 +0,0 @@ -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.Wf. -Require Import Crypto.Reflection.Named.ContextDefinitions. -Require Import Crypto.Reflection.Named.ContextProperties. -Require Import Crypto.Reflection.Named.ContextProperties.SmartMap. -Require Import Crypto.Reflection.Named.InterpretToPHOAS. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Util.PointedProp. -Require Import Crypto.Util.Decidable. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.DestructHead. - -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - {Name : Type} - {base_type_code_dec : DecidableRel (@eq base_type_code)} - {Name_dec : DecidableRel (@eq Name)}. - Section with_var. - Context {var1 var2 : base_type_code -> Type} - {Context1 : Context Name var1} - {Context2 : Context Name var2} - {Context1Ok : ContextOk Context1} - {Context2Ok : ContextOk Context2} - (failb1 : forall t, @Syntax.exprf base_type_code op var1 (Tbase t)) - (failb2 : forall t, @Syntax.exprf base_type_code op var2 (Tbase t)). - - Local Ltac t_step := - first [ progress intros - | progress unfold dec in * - | reflexivity - | progress subst - | progress inversion_option - | erewrite lookupb_extend by assumption - | rewrite <- !find_Name_and_val_None_iff - | progress break_innermost_match_step - | progress break_match_hyps - | solve [ eauto using find_Name_and_val_flatten_binding_list ] - | congruence - | tauto - | match goal with - | [ H : lookupb (extend _ _ _) _ = _ |- _ ] - => erewrite (lookupb_extend _ _ _) in H by assumption - | [ H : context[List.In _ (_ ++ _)] |- _ ] - => setoid_rewrite List.in_app_iff in H - | [ |- context[List.In _ (_ ++ _)] ] - => rewrite List.in_app_iff - | [ |- context[find_Name_and_val ?tdec ?ndec ?a ?b ?c ?d ?default] ] - => lazymatch default with None => fail | _ => idtac end; - rewrite (find_Name_and_val_split tdec ndec (default:=default)) - | [ H : context[find_Name_and_val ?tdec ?ndec ?a ?b ?c ?d ?default] |- _ ] - => lazymatch default with None => fail | _ => idtac end; - rewrite (find_Name_and_val_split tdec ndec (default:=default)) in H - | [ H : forall n t, lookupb _ n t = None <-> lookupb _ n t = None |- context[lookupb _ _ = None] ] - => rewrite H - | [ H : forall n t, lookupb _ n t = None |- context[lookupb _ _ = None] ] - => rewrite H - end ]. - Local Ltac t := repeat t_step. - - Lemma wff_interpf_to_phoas - (ctx1 : Context1) (ctx2 : Context2) - {t} (e : @Named.exprf base_type_code op Name t) - (Hwf1 : prop_of_option (Named.wff ctx1 e)) - (Hwf2 : prop_of_option (Named.wff ctx2 e)) - G - (HG : forall n t v1 v2, - lookupb ctx1 n t = Some v1 - -> lookupb ctx2 n t = Some v2 - -> List.In (existT _ t (v1, v2)%core) G) - (Hctx1_ctx2 : forall n t, - lookupb ctx1 n t = None <-> lookupb ctx2 n t = None) - : wff G (interpf_to_phoas failb1 ctx1 e) (interpf_to_phoas failb2 ctx2 e). - Proof using Context1Ok Context2Ok Name_dec base_type_code_dec. - revert dependent G; revert dependent ctx1; revert dependent ctx2; induction e; - repeat first [ progress intros - | progress destruct_head' and - | progress break_innermost_match_step - | progress simpl in * - | progress autorewrite with push_prop_of_option in * - | solve [ eauto | tauto ] - | match goal with - | [ |- wff _ _ _ ] => constructor - end ]. - match goal with H : _ |- _ => eapply H end; t. - Qed. - - Lemma wf_interp_to_phoas_gen - (ctx1 : Context1) (ctx2 : Context2) - {t} (e : @Named.expr base_type_code op Name t) - (Hwf1 : Named.wf ctx1 e) - (Hwf2 : Named.wf ctx2 e) - (Hctx1 : forall n t, lookupb ctx1 n t = None) - (Hctx2 : forall n t, lookupb ctx2 n t = None) - : wf (interp_to_phoas failb1 ctx1 e) (interp_to_phoas failb2 ctx2 e). - Proof using Context1Ok Context2Ok Name_dec base_type_code_dec. - constructor; intros. - apply wff_interpf_to_phoas; t. - Qed. - - Lemma wf_interp_to_phoas - {t} (e : @Named.expr base_type_code op Name t) - (Hwf1 : Named.wf (Context:=Context1) empty e) - (Hwf2 : Named.wf (Context:=Context2) empty e) - : wf (interp_to_phoas (Context:=Context1) failb1 empty e) (interp_to_phoas (Context:=Context2) failb2 empty e). - Proof using Context1Ok Context2Ok Name_dec base_type_code_dec. - apply wf_interp_to_phoas_gen; auto using lookupb_empty. - Qed. - End with_var. - - Section all. - Context {Context : forall var, @Context base_type_code Name var} - {ContextOk : forall var, ContextOk (Context var)} - (failb : forall var t, @Syntax.exprf base_type_code op var (Tbase t)). - - Lemma Wf_InterpToPHOAS_gen - {ctx : forall var, Context var} - {t} (e : @Named.expr base_type_code op Name t) - (Hctx : forall var n t, lookupb (ctx var) n t = None) - (Hwf : forall var, Named.wf (ctx var) e) - : Wf (InterpToPHOAS_gen failb ctx e). - Proof using ContextOk Name_dec base_type_code_dec. - intros ??; apply wf_interp_to_phoas_gen; auto. - Qed. - - Lemma Wf_InterpToPHOAS - {t} (e : @Named.expr base_type_code op Name t) - (Hwf : Named.Wf Context e) - : Wf (InterpToPHOAS (Context:=Context) failb e). - Proof using ContextOk Name_dec base_type_code_dec. - intros ??; apply wf_interp_to_phoas; auto. - Qed. - End all. -End language. - -Hint Resolve Wf_InterpToPHOAS : wf. diff --git a/src/Reflection/Named/MapCast.v b/src/Reflection/Named/MapCast.v deleted file mode 100644 index a0b161a0a..000000000 --- a/src/Reflection/Named/MapCast.v +++ /dev/null @@ -1,71 +0,0 @@ -Require Import Coq.Bool.Sumbool. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Named.Syntax. - -Local Open Scope nexpr_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - {Name : Type} - {interp_base_type_bounds : base_type_code -> Type} - (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst) - (pick_typeb : forall t, interp_base_type_bounds t -> base_type_code). - Local Notation pick_type v := (SmartFlatTypeMap pick_typeb v). - Context (cast_op : forall t tR (opc : op t tR) args_bs, - op (pick_type args_bs) (pick_type (interp_op_bounds t tR opc args_bs))) - {BoundsContext : Context Name interp_base_type_bounds}. - - Fixpoint mapf_cast - (ctx : BoundsContext) - {t} (e : exprf base_type_code op Name t) - {struct e} - : option { bounds : interp_flat_type interp_base_type_bounds t - & exprf base_type_code op Name (pick_type bounds) } - := match e in exprf _ _ _ t return option { bounds : interp_flat_type interp_base_type_bounds t - & exprf base_type_code op Name (pick_type bounds) } with - | TT => Some (existT _ tt TT) - | Pair tx ex ty ey - => match @mapf_cast ctx _ ex, @mapf_cast ctx _ ey with - | Some (existT x_bs xv), Some (existT y_bs yv) - => Some (existT _ (x_bs, y_bs)%core (Pair xv yv)) - | None, _ | _, None => None - end - | Var t x - => option_map - (fun bounds => existT _ bounds (Var x)) - (lookupb (t:=t) ctx x) - | LetIn tx n ex tC eC - => match @mapf_cast ctx _ ex with - | Some (existT x_bounds ex') - => option_map - (fun eC' => let 'existT Cx_bounds C_expr := eC' in - existT _ Cx_bounds (LetIn (pick_type x_bounds) - (SmartFlatTypeMapInterp2 (t:=tx) (fun _ _ (n : Name) => n) x_bounds n) ex' C_expr)) - (@mapf_cast (extend (t:=tx) ctx n x_bounds) _ eC) - | None => None - end - | Op t tR opc args - => option_map - (fun args' - => let 'existT args_bounds argsv := args' in - existT _ - (interp_op_bounds _ _ _ args_bounds) - (Op (cast_op t tR opc args_bounds) argsv)) - (@mapf_cast ctx _ args) - end. - - Definition map_cast - (ctx : BoundsContext) - {t} (e : expr base_type_code op Name t) - (input_bounds : interp_flat_type interp_base_type_bounds (domain t)) - : option { output_bounds : interp_flat_type interp_base_type_bounds (codomain t) - & expr base_type_code op Name (Arrow (pick_type input_bounds) (pick_type output_bounds)) } - := option_map - (fun v => existT - _ - (projT1 v) - (Abs (SmartFlatTypeMapInterp2 (fun _ _ (n' : Name) => n') input_bounds (Abs_name e)) - (projT2 v))) - (mapf_cast (extend ctx (Abs_name e) input_bounds) (invert_Abs e)). -End language. diff --git a/src/Reflection/Named/MapCastInterp.v b/src/Reflection/Named/MapCastInterp.v deleted file mode 100644 index b7afa1494..000000000 --- a/src/Reflection/Named/MapCastInterp.v +++ /dev/null @@ -1,268 +0,0 @@ -Require Import Coq.Bool.Sumbool. -Require Import Coq.Logic.Eqdep_dec. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.ContextDefinitions. -Require Import Crypto.Reflection.Named.ContextProperties. -Require Import Crypto.Reflection.Named.ContextProperties.SmartMap. -Require Import Crypto.Reflection.Named.MapCast. -Require Import Crypto.Util.ZUtil. -Require Import Crypto.Util.Bool. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Sigma. -Require Import Crypto.Util.Decidable. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.SpecializeBy. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Tactics.RewriteHyp. - -Local Open Scope nexpr_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - {Name : Type} - {interp_base_type_bounds : base_type_code -> Type} - (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst) - (pick_typeb : forall t, interp_base_type_bounds t -> base_type_code). - Local Notation pick_type t v := (SmartFlatTypeMap pick_typeb (t:=t) v). - Context (cast_op : forall t tR (opc : op t tR) args_bs, - op (pick_type _ args_bs) (pick_type _ (interp_op_bounds t tR opc args_bs))) - {BoundsContext : Context Name interp_base_type_bounds} - (BoundsContextOk : ContextOk BoundsContext) - {interp_base_type : base_type_code -> Type} - (interp_op : forall src dst, - op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst) - (cast_backb: forall t b, interp_base_type (pick_typeb t b) -> interp_base_type t). - Let cast_back : forall t b, interp_flat_type interp_base_type (@pick_type t b) -> interp_flat_type interp_base_type t - := fun t b => SmartFlatTypeMapUnInterp cast_backb. - Context {Context : Context Name interp_base_type} - (ContextOk : ContextOk Context) - (inboundsb : forall t, interp_base_type_bounds t -> interp_base_type t -> Prop). - Let inbounds : forall t, interp_flat_type interp_base_type_bounds t -> interp_flat_type interp_base_type t -> Prop - := fun t => interp_flat_type_rel_pointwise inboundsb (t:=t). - Context (interp_op_bounds_correct: - forall t tR opc bs - (v : interp_flat_type interp_base_type t) - (H : inbounds t bs v), - inbounds tR (interp_op_bounds t tR opc bs) (interp_op t tR opc v)) - (pull_cast_back: - forall t tR opc bs - (v : interp_flat_type interp_base_type (pick_type t bs)) - (H : inbounds t bs (cast_back t bs v)), - interp_op t tR opc (cast_back t bs v) - = - cast_back _ _ (interp_op _ _ (cast_op _ _ opc bs) v)) - (base_type_dec : DecidableRel (@eq base_type_code)) - (Name_dec : DecidableRel (@eq Name)). - - Local Notation mapf_cast := (@mapf_cast _ op Name _ interp_op_bounds pick_typeb cast_op BoundsContext). - Local Notation map_cast := (@map_cast _ op Name _ interp_op_bounds pick_typeb cast_op BoundsContext). - - Local Ltac handle_options_step := - match goal with - | _ => progress inversion_option - | [ H : ?x = Some _ |- context[?x] ] => rewrite H - | [ H : ?x = None |- context[?x] ] => rewrite H - | [ H : ?x = Some _, H' : context[?x] |- _ ] => rewrite H in H' - | [ H : ?x = None, H' : context[?x] |- _ ] => rewrite H in H' - | [ H : Some _ <> None \/ _ |- _ ] => clear H - | [ H : Some ?x <> Some ?y |- _ ] => assert (x <> y) by congruence; clear H - | [ H : None <> Some _ |- _ ] => clear H - | [ H : Some _ <> None |- _ ] => clear H - | [ H : ?x <> ?x \/ _ |- _ ] => destruct H; [ exfalso; apply H; reflexivity | ] - | [ H : _ \/ None = Some _ |- _ ] => destruct H; [ | exfalso; clear -H; congruence ] - | [ H : _ \/ Some _ = None |- _ ] => destruct H; [ | exfalso; clear -H; congruence ] - | [ H : ?x = Some ?y, H' : ?x = Some ?y' |- _ ] - => assert (y = y') by congruence; (subst y' || subst y) - | _ => progress simpl @option_map - end. - - Local Ltac handle_lookupb_step := - let do_eq_dec dec t t' := - first [ constr_eq t t'; fail 1 - | lazymatch goal with - | [ H : t = t' |- _ ] => fail 1 - | [ H : t <> t' |- _ ] => fail 1 - | [ H : t = t' -> False |- _ ] => fail 1 - | _ => destruct (dec t t') - end ] in - let do_type_dec := do_eq_dec base_type_dec in - match goal with - | _ => progress unfold dec in * - | _ => handle_options_step - (* preprocess *) - | [ H : context[lookupb (extend _ _ _) _] |- _ ] - => first [ rewrite (fun C => lookupb_extend C base_type_dec Name_dec) in H by assumption - | setoid_rewrite (fun C => lookupb_extend C base_type_dec Name_dec) in H; [ | assumption.. ] ] - | [ |- context[lookupb (extend _ _ _) _] ] - => first [ rewrite (fun C => lookupb_extend C base_type_dec Name_dec) by assumption - | setoid_rewrite (fun C => lookupb_extend C base_type_dec Name_dec); [ | assumption.. ] ] - | _ => progress subst - (* handle multiple hypotheses *) - | [ H : find_Name _ ?n ?N = Some ?t', H'' : context[find_Name_and_val _ _ ?t ?n ?N ?x ?default] |- _ ] - => do_type_dec t t' - (* clear the default value *) - | [ H : context[find_Name_and_val ?tdec ?ndec ?t ?n (T:=?T) ?N ?V ?default] |- _ ] - => lazymatch default with None => fail | _ => idtac end; - rewrite find_Name_and_val_split in H - (* generic handlers *) - | [ H : find_Name _ ?n ?N = Some ?t', H' : ?t <> ?t', H'' : context[find_Name_and_val _ _ ?t ?n ?N ?x ?default] |- _ ] - => erewrite find_Name_and_val_wrong_type in H'' by eassumption - | [ H : context[find_Name _ _ (SmartFlatTypeMapInterp2 _ _ _)] |- _ ] - => rewrite find_Name_SmartFlatTypeMapInterp2 with (base_type_code_dec:=base_type_dec) in H - | [ H : find_Name_and_val _ _ _ _ _ _ _ = None |- _ ] - => apply find_Name_and_val_None_iff in H - (* destructers *) - | [ |- context[find_Name_and_val ?tdec ?ndec ?t ?n ?N ?V ?default] ] - => destruct (find_Name_and_val tdec ndec t n N V default) eqn:? - | [ H : context[match find_Name_and_val ?tdec ?ndec ?t ?n ?N ?V ?default with _ => _ end] |- _ ] - => destruct (find_Name_and_val tdec ndec t n N V default) eqn:? - | [ H : context[match find_Name ?ndec ?n ?N with _ => _ end] |- _ ] - => destruct (find_Name ndec n N) eqn:? - | [ H : context[match base_type_dec ?x ?y with _ => _ end] |- _ ] - => destruct (base_type_dec x y) - | [ H : context[match Name_dec ?x ?y with _ => _ end] |- _ ] - => destruct (Name_dec x y) - end. - - Local Ltac handle_exists_in_goal := - lazymatch goal with - | [ |- exists v, Some ?k = Some v /\ @?B v ] - => exists k; split; [ reflexivity | ] - | [ |- (exists v, None = Some v /\ @?B v) ] - => exfalso - | [ |- ?A /\ (exists v, Some ?k = Some v /\ @?B v) ] - => cut (A /\ B k); [ clear; solve [ intuition eauto ] | cbv beta ] - | [ |- ?A /\ (exists v, None = Some v /\ @?B v) ] - => exfalso - end. - Local Ltac fin_inbounds_cast_back_t_step := - match goal with - | [ |- inboundsb _ _ _ /\ _ ] - => split; [ eapply interp_flat_type_rel_pointwise__find_Name_and_val; eassumption | ] - | [ |- cast_backb _ _ _ = _ ] - => eapply find_Name_and_val__SmartFlatTypeMapInterp2__SmartFlatTypeMapUnInterp__Some_Some; [ | eassumption.. ] - end. - Local Ltac specializer_t_step := - match goal with - | [ H : ?T, H' : ?T |- _ ] => clear H - | [ H : forall x, Some _ = Some x -> _ |- _ ] => specialize (H _ eq_refl) - | [ H : ?x = Some _, IH : forall a b, ?x = Some _ -> _ |- _ ] - => specialize (IH _ _ H) - | [ H : ?x = Some _, IH : forall a, ?x = Some _ -> _ |- _ ] - => specialize (IH _ H) - | [ H : forall t n v, lookupb ?ctx n = _ -> _, H' : lookupb ?ctx ?n' = _ |- _ ] - => specialize (H _ _ _ H') - | _ => progress specialize_by auto - end. - - Local Ltac break_t_step := - first [ progress destruct_head'_ex - | progress destruct_head'_and ]. - - Local Ltac t_step := - first [ progress intros - | break_t_step - | handle_lookupb_step - | handle_exists_in_goal - | solve [ auto ] - | specializer_t_step - | fin_inbounds_cast_back_t_step ]. - Local Ltac t := repeat t_step. - - Local Ltac do_specialize_IHe := - repeat match goal with - | [ IH : context[interpf ?e], H' : interpf (ctx:=?ctx) ?e = _ |- _ ] - => let check_tac _ := (rewrite H' in IH) in - first [ specialize (IH ctx); check_tac () - | specialize (fun a => IH a ctx); check_tac () - | specialize (fun a b => IH a b ctx); check_tac () ] - | [ IH : context[mapf_cast _ ?e], H' : mapf_cast ?ctx ?e = _ |- _ ] - => let check_tac _ := (rewrite H' in IH) in - first [ specialize (IH ctx); check_tac () - | specialize (fun a => IH a ctx); check_tac () - | specialize (fun a b => IH a b ctx); check_tac () ] - | [ H : forall x y z, Some _ = Some _ -> _ |- _ ] - => first [ specialize (H _ _ _ eq_refl) - | specialize (fun x => H x _ _ eq_refl) ] - | [ H : forall x y, Some _ = Some _ -> _ |- _ ] - => first [ specialize (H _ _ eq_refl) - | specialize (fun x => H x _ eq_refl) ] - | _ => progress specialize_by_assumption - end. - - Lemma mapf_cast_correct - {t} (e:exprf base_type_code op Name t) - : forall - (oldValues:Context) - (newValues:Context) - (varBounds:BoundsContext) - {b} e' (He':mapf_cast varBounds e = Some (existT _ b e')) - (Hctx:forall {t} n v, - lookupb (t:=t) oldValues n = Some v - -> exists b, lookupb (t:=t) varBounds n = Some b - /\ @inboundsb _ b v - /\ exists v', lookupb (t:=pick_typeb t b) newValues n = Some v' - /\ cast_backb t b v' = v) - r (Hr:interpf (interp_op:=interp_op) (ctx:=oldValues) e = Some r) - r' (Hr':interpf (interp_op:=interp_op) (ctx:=newValues) e' = Some r') - , interpf (interp_op:=interp_op_bounds) (ctx:=varBounds) e = Some b - /\ @inbounds _ b r /\ cast_back _ _ r' = r. - Proof using Type*. - induction e; simpl interpf; simpl mapf_cast; unfold option_map, cast_back in *; intros; - repeat (break_match_hyps; inversion_option; inversion_sigma; simpl in *; unfold option_map in *; subst; try tauto). - { destruct (Hctx _ _ _ Hr) as [b' [Hb'[Hb'v[v'[Hv' Hv'v]]]]]; clear Hctx Hr; subst. - repeat match goal with - [H: ?e = Some ?x, G:?e = Some ?x' |- _] => - pose proof (eq_trans (eq_sym G) H); clear G; inversion_option; subst - end. - auto. } - { do_specialize_IHe. - destruct_head and; subst; intuition eauto; symmetry; rewrite_hyp ?*; eauto. } - { cbv [LetIn.Let_In] in *. - do_specialize_IHe. - destruct IHe1 as [IHe1_eq IHe1]; rewrite_hyp *. - { apply IHe2; clear IHe2; try reflexivity. - intros ??? H. - let b := fresh "b" in - let H' := fresh "H'" in - match goal with |- exists b0, ?v = Some b0 /\ _ => destruct v as [b|] eqn:H' end; - [ exists b; split; [ reflexivity | ] | exfalso ]; - revert H H'; t. } } - { do_specialize_IHe. - t. } - Qed. - - Lemma map_cast_correct - {t} (e:expr base_type_code op Name t) - (input_bounds : interp_flat_type interp_base_type_bounds (domain t)) - : forall - (oldValues:Context) - (newValues:Context) - (varBounds:BoundsContext) - {b} e' (He':map_cast varBounds e input_bounds = Some (existT _ b e')) - (Hctx:forall {t} n v, - lookupb (t:=t) oldValues n = Some v - -> exists b, lookupb (t:=t) varBounds n = Some b - /\ @inboundsb _ b v - /\ exists v', lookupb (t:=pick_typeb t b) newValues n = Some v' - /\ cast_backb t b v' = v) - v v' (Hv : @inbounds _ input_bounds v /\ cast_back _ _ v' = v) - r (Hr:interp (interp_op:=interp_op) (ctx:=oldValues) e v = Some r) - r' (Hr':interp (interp_op:=interp_op) (ctx:=newValues) e' v' = Some r') - , interp (interp_op:=interp_op_bounds) (ctx:=varBounds) e input_bounds = Some b - /\ @inbounds _ b r /\ cast_back _ _ r' = r. - Proof using Type*. - unfold map_cast, option_map, interp; simpl; intros. - repeat first [ progress subst - | progress inversion_option - | progress inversion_sigma - | progress break_match_hyps - | progress destruct_head' sigT - | progress simpl in * ]. - eapply mapf_cast_correct; try eassumption. - t. - Qed. -End language. diff --git a/src/Reflection/Named/MapCastWf.v b/src/Reflection/Named/MapCastWf.v deleted file mode 100644 index f05df34c1..000000000 --- a/src/Reflection/Named/MapCastWf.v +++ /dev/null @@ -1,285 +0,0 @@ -Require Import Coq.Bool.Sumbool. -Require Import Coq.Logic.Eqdep_dec. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.ContextDefinitions. -Require Import Crypto.Reflection.Named.ContextProperties. -Require Import Crypto.Reflection.Named.ContextProperties.SmartMap. -Require Import Crypto.Reflection.Named.Wf. -Require Import Crypto.Reflection.Named.MapCast. -Require Import Crypto.Util.PointedProp. -Require Import Crypto.Util.ZUtil. -Require Import Crypto.Util.Bool. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Prod. -Require Import Crypto.Util.Sigma. -Require Import Crypto.Util.Decidable. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.SpecializeBy. -Require Import Crypto.Util.Tactics.DestructHead. - -Local Open Scope nexpr_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - {Name : Type} - {interp_base_type_bounds : base_type_code -> Type} - (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst) - (pick_typeb : forall t, interp_base_type_bounds t -> base_type_code). - Local Notation pick_type t v := (SmartFlatTypeMap pick_typeb (t:=t) v). - Context (cast_op : forall t tR (opc : op t tR) args_bs, - op (pick_type _ args_bs) (pick_type _ (interp_op_bounds t tR opc args_bs))) - {BoundsContext : Context Name interp_base_type_bounds} - (BoundsContextOk : ContextOk BoundsContext) - {interp_base_type : base_type_code -> Type} - (interp_op : forall src dst, - op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst) - {FullContext : Context Name (fun t => { b : interp_base_type_bounds t & interp_base_type (pick_typeb t b) }%type)} - (FullContextOk : ContextOk FullContext) - {Context : Context Name interp_base_type} - (ContextOk : ContextOk Context) - (base_type_dec : DecidableRel (@eq base_type_code)) - (Name_dec : DecidableRel (@eq Name)). - - Local Notation mapf_cast := (@mapf_cast _ op Name _ interp_op_bounds pick_typeb cast_op BoundsContext). - Local Notation map_cast := (@map_cast _ op Name _ interp_op_bounds pick_typeb cast_op BoundsContext). - - Local Ltac handle_options_step := - match goal with - | _ => progress inversion_option - | [ H : ?x = Some _ |- context[?x] ] => rewrite H - | [ H : ?x = None |- context[?x] ] => rewrite H - | [ H : ?x = Some _, H' : context[?x] |- _ ] => rewrite H in H' - | [ H : ?x = None, H' : context[?x] |- _ ] => rewrite H in H' - | [ H : Some _ <> None \/ _ |- _ ] => clear H - | [ H : Some ?x <> Some ?y |- _ ] => assert (x <> y) by congruence; clear H - | [ H : None <> Some _ |- _ ] => clear H - | [ H : Some _ <> None |- _ ] => clear H - | [ H : ?x <> ?x \/ _ |- _ ] => destruct H; [ exfalso; apply H; reflexivity | ] - | [ H : _ \/ None = Some _ |- _ ] => destruct H; [ | exfalso; clear -H; congruence ] - | [ H : _ \/ Some _ = None |- _ ] => destruct H; [ | exfalso; clear -H; congruence ] - | [ H : ?x = Some ?y, H' : ?x = Some ?y' |- _ ] - => assert (y = y') by congruence; (subst y' || subst y) - | _ => progress simpl @option_map - | _ => progress unfold option_map in * - end. - - Local Ltac handle_lookupb_step_extra := fail. - Local Ltac handle_lookupb_step := - let do_eq_dec dec t t' := - first [ constr_eq t t'; fail 1 - | lazymatch goal with - | [ H : t = t' |- _ ] => fail 1 - | [ H : t <> t' |- _ ] => fail 1 - | [ H : t = t' -> False |- _ ] => fail 1 - | _ => destruct (dec t t') - end ] in - let do_type_dec := do_eq_dec base_type_dec in - match goal with - | _ => progress unfold dec in * - | _ => handle_options_step - (* preprocess *) - | [ H : context[lookupb (extend _ _ _) _] |- _ ] - => first [ rewrite (fun C => lookupb_extend C base_type_dec Name_dec) in H by assumption - | setoid_rewrite (fun C => lookupb_extend C base_type_dec Name_dec) in H; [ | assumption.. ] ] - | [ |- context[lookupb (extend _ _ _) _] ] - => first [ rewrite (fun C => lookupb_extend C base_type_dec Name_dec) by assumption - | setoid_rewrite (fun C => lookupb_extend C base_type_dec Name_dec); [ | assumption.. ] ] - | _ => progress subst - (* handle multiple hypotheses *) - | [ H : find_Name _ ?n ?N = Some ?t', H'' : context[find_Name_and_val _ _ ?t ?n ?N ?x ?default] |- _ ] - => do_type_dec t t' - (* clear the default value *) - | [ H : context[find_Name_and_val ?tdec ?ndec ?t ?n (T:=?T) ?N ?V ?default] |- _ ] - => lazymatch default with None => fail | _ => idtac end; - rewrite find_Name_and_val_split in H - (* generic handlers *) - | [ H : find_Name _ ?n ?N = Some ?t', H' : ?t <> ?t', H'' : context[find_Name_and_val _ _ ?t ?n ?N ?x ?default] |- _ ] - => erewrite find_Name_and_val_wrong_type in H'' by eassumption - | [ H : context[find_Name _ _ (SmartFlatTypeMapInterp2 _ _ _)] |- _ ] - => rewrite find_Name_SmartFlatTypeMapInterp2 with (base_type_code_dec:=base_type_dec) in H - | [ H : find_Name_and_val _ _ _ _ _ _ _ = None |- _ ] - => apply find_Name_and_val_None_iff in H - | _ => progress handle_lookupb_step_extra - (* destructers *) - | [ |- context[find_Name_and_val ?tdec ?ndec ?t ?n ?N ?V ?default] ] - => destruct (find_Name_and_val tdec ndec t n N V default) eqn:? - | [ H : context[match find_Name_and_val ?tdec ?ndec ?t ?n ?N ?V ?default with _ => _ end] |- _ ] - => destruct (find_Name_and_val tdec ndec t n N V default) eqn:? - | [ H : context[match find_Name ?ndec ?n ?N with _ => _ end] |- _ ] - => destruct (find_Name ndec n N) eqn:? - | [ H : context[match base_type_dec ?x ?y with _ => _ end] |- _ ] - => destruct (base_type_dec x y) - | [ H : context[match Name_dec ?x ?y with _ => _ end] |- _ ] - => destruct (Name_dec x y) - end. - - Local Ltac handle_exists_in_goal := - lazymatch goal with - | [ |- exists v, Some ?k = Some v /\ @?B v ] - => exists k; split; [ reflexivity | ] - | [ |- exists v, Some ?k = Some v ] - => exists k; reflexivity - | [ |- (exists v, None = Some v /\ @?B v) ] - => exfalso - | [ |- ?A /\ (exists v, Some ?k = Some v /\ @?B v) ] - => cut (A /\ B k); [ clear; solve [ intuition eauto ] | cbv beta ] - | [ |- ?A /\ (exists v, None = Some v /\ @?B v) ] - => exfalso - end. - Local Ltac specializer_t_step := - match goal with - | [ H : ?T, H' : ?T |- _ ] => clear H - | [ H : forall x, Some _ = Some x -> _ |- _ ] => specialize (H _ eq_refl) - | [ H : ?x = Some _, IH : forall a b c, ?x = Some _ -> _ |- _ ] - => specialize (IH _ _ _ H) - | [ H : ?x = Some _, IH : forall a b, ?x = Some _ -> _ |- _ ] - => specialize (IH _ _ H) - | [ H : ?x = Some _, IH : forall a, ?x = Some _ -> _ |- _ ] - => specialize (IH _ H) - | [ H : forall t n x y z, lookupb ?ctx n = _ -> _, H' : lookupb ?ctx ?n' = _ |- _ ] - => specialize (H _ _ _ _ _ H') - | [ H : forall t n x y, lookupb ?ctx n = _ -> _, H' : lookupb ?ctx ?n' = _ |- _ ] - => specialize (H _ _ _ _ H') - | [ H : forall t n v, lookupb ?ctx n = _ -> _, H' : lookupb ?ctx ?n' = _ |- _ ] - => specialize (H _ _ _ H') - | _ => progress specialize_by auto - end. - - Local Ltac break_t_step := - first [ progress subst - | progress destruct_head'_ex - | progress destruct_head'_and - | progress inversion_option - | progress inversion_prod - | progress inversion_sigma - | progress autorewrite with push_prop_of_option in * - | progress break_match_hyps ]. - - Local Ltac do_specialize_IHe_step := - match goal with - | [ IH : context[mapf_cast _ ?e], H' : mapf_cast ?ctx ?e = _ |- _ ] - => let check_tac _ := (rewrite H' in IH) in - first [ specialize (IH ctx); check_tac () - | specialize (fun a => IH a ctx); check_tac () - | specialize (fun a b => IH a b ctx); check_tac () ] - | [ H : forall x y z w, Some _ = Some _ -> _ |- _ ] - => first [ specialize (H _ _ _ _ eq_refl) - | specialize (fun x y => H x y _ _ eq_refl) ] - | [ H : forall x y z, Some _ = Some _ -> _ |- _ ] - => first [ specialize (H _ _ _ eq_refl) - | specialize (fun x => H x _ _ eq_refl) ] - | [ H : forall x y, Some _ = Some _ -> _ |- _ ] - => first [ specialize (H _ _ eq_refl) - | specialize (fun x => H x _ eq_refl) ] - | _ => progress specialize_by_assumption - | [ H : forall a b, prop_of_option (Named.wff a ?e) -> _, H' : prop_of_option (Named.wff _ ?e) |- _ ] - => specialize (fun b => H _ b H') - | [ H : forall b v, _ -> prop_of_option (Named.wff b ?e) |- prop_of_option (Named.wff ?ctx ?e) ] - => specialize (H ctx) - | [ H : forall b v, _ -> _ -> prop_of_option (Named.wff b ?e) |- prop_of_option (Named.wff ?ctx ?e) ] - => specialize (H ctx) - | [ H : forall a b, _ -> _ -> _ -> prop_of_option (Named.wff b ?e) |- prop_of_option (Named.wff ?ctx ?e) ] - => specialize (fun a => H a ctx) - | [ H : forall a b, prop_of_option (Named.wff a ?e) -> _, H' : forall v, prop_of_option (Named.wff _ ?e) |- _ ] - => specialize (fun b v => H _ b (H' v)) - end. - Ltac do_specialize_IHe := repeat do_specialize_IHe_step. - - Definition make_fContext_value {t} {b : interp_flat_type interp_base_type_bounds t} - (v : interp_flat_type interp_base_type (pick_type t b)) - : interp_flat_type - (fun t => { b : interp_base_type_bounds t & interp_base_type (pick_typeb t b)}) - t - := SmartFlatTypeMapUnInterp2 - (fun t b (v : interp_flat_type _ (Tbase _)) - => existT (fun b => interp_base_type (pick_typeb t b)) b v) - v. - - Local Ltac t_step := - first [ progress intros - | progress simpl in * - | break_t_step - | handle_lookupb_step - | handle_exists_in_goal - | apply conj - | solve [ auto | exfalso; auto ] - | specializer_t_step - | progress do_specialize_IHe - | match goal with - | [ IH : forall v, _ -> ?T, v' : interp_flat_type _ _ |- ?T ] - => apply (IH (make_fContext_value v')); clear IH - end ]. - Local Ltac t := repeat t_step. - - Lemma find_Name_and_val_make_fContext_value_Some {T} - {N : interp_flat_type (fun _ : base_type_code => Name) T} - {B : interp_flat_type interp_base_type_bounds T} - {V : interp_flat_type interp_base_type (pick_type T B)} - {n : Name} - {t : base_type_code} - {v : { b : interp_base_type_bounds t & interp_base_type (pick_typeb t b)}} - {b} - (Hn : find_Name Name_dec n N = Some t) - (Hf : find_Name_and_val base_type_dec Name_dec t n N (make_fContext_value V) None = Some v) - (Hb : find_Name_and_val base_type_dec Name_dec t n N B None = Some b) - (N' := SmartFlatTypeMapInterp2 (var'':=fun _ => Name) (f:=pick_typeb) (fun _ _ n => n) _ N) - : b = projT1 v /\ find_Name_and_val base_type_dec Name_dec (pick_typeb t (projT1 v)) n N' V None = Some (projT2 v). - Proof using Type. - eapply (find_Name_and_val_SmartFlatTypeMapUnInterp2_Some_Some base_type_dec Name_dec (h:=@projT1 _ _) (i:=@projT2 _ _) (f:=pick_typeb) (g:=fun _ => existT _)); - auto. - Qed. - - Local Ltac handle_lookupb_step_extra ::= - lazymatch goal with - | [ H : find_Name _ ?n ?N = Some ?t, - H' : find_Name_and_val _ _ ?t ?n ?N (@make_fContext_value ?T ?B ?v) None = Some ?v', - H'' : find_Name_and_val _ _ ?t ?n ?N ?B None = Some _ - |- _ ] - => pose proof (find_Name_and_val_make_fContext_value_Some H H' H''); clear H' - end. - - Lemma wff_mapf_cast - {t} (e:exprf base_type_code op Name t) - : forall - (fValues:FullContext) - (newValues:Context) - (varBounds:BoundsContext) - {b} e' (He':mapf_cast varBounds e = Some (existT _ b e')) - (Hwf : prop_of_option (Named.wff fValues e)) - (Hctx:forall {t} n v, - lookupb (t:=t) fValues n = Some v - -> lookupb (t:=t) varBounds n = Some (projT1 v) - /\ lookupb (t:=pick_typeb t (projT1 v)) newValues n = Some (projT2 v)), - prop_of_option (Named.wff newValues e'). - Proof using BoundsContextOk ContextOk FullContextOk Name_dec base_type_dec. induction e; t. Qed. - - Lemma wf_map_cast - {t} (e:expr base_type_code op Name t) - (input_bounds : interp_flat_type interp_base_type_bounds (domain t)) - : forall - (fValues:FullContext) - (newValues:Context) - (varBounds:BoundsContext) - {b} e' (He':map_cast varBounds e input_bounds = Some (existT _ b e')) - (Hwf : Named.wf fValues e) - (Hctx:forall {t} n v, - lookupb (t:=t) fValues n = Some v - -> lookupb (t:=t) varBounds n = Some (projT1 v) - /\ lookupb (t:=pick_typeb t (projT1 v)) newValues n = Some (projT2 v)), - Named.wf newValues e'. - Proof using BoundsContextOk ContextOk FullContextOk Name_dec base_type_dec. - unfold Named.wf, map_cast, option_map, interp; simpl; intros. - repeat first [ progress subst - | progress inversion_option - | progress inversion_sigma - | progress break_match_hyps - | progress destruct_head' sigT - | progress simpl in * ]. - match goal with v : _ |- _ => specialize (Hwf (make_fContext_value v)) end. - eapply wff_mapf_cast; eauto; []. - t. - Qed. -End language. diff --git a/src/Reflection/Named/NameUtil.v b/src/Reflection/Named/NameUtil.v deleted file mode 100644 index 5356cd132..000000000 --- a/src/Reflection/Named/NameUtil.v +++ /dev/null @@ -1,56 +0,0 @@ -Require Import Coq.Lists.List. -Require Import Crypto.Reflection.Syntax. - -Local Open Scope core_scope. -Local Notation eta x := (fst x, snd x). - -Section language. - Context {base_type_code : Type} - {Name : Type}. - - Section monad. - Context (MName : Type) (force : MName -> option Name). - Fixpoint split_mnames - (t : flat_type base_type_code) (ls : list MName) - : option (interp_flat_type (fun _ => Name) t) * list MName - := match t return option (@interp_flat_type base_type_code (fun _ => Name) t) * _ with - | Tbase _ - => match ls with - | cons n ls' - => match force n with - | Some n => (Some n, ls') - | None => (None, ls') - end - | nil => (None, nil) - end - | Unit => (Some tt, ls) - | Prod A B - => let '(a, ls) := eta (@split_mnames A ls) in - let '(b, ls) := eta (@split_mnames B ls) in - (match a, b with - | Some a', Some b' => Some (a', b') - | _, _ => None - end, - ls) - end. - Definition mname_list_unique (ls : list MName) : Prop - := forall k n, - List.In (Some n) (firstn k (List.map force ls)) - -> List.In (Some n) (skipn k (List.map force ls)) - -> False. - End monad. - Definition split_onames := @split_mnames (option Name) (fun x => x). - Definition split_names := @split_mnames Name (@Some _). - - Definition oname_list_unique (ls : list (option Name)) : Prop - := mname_list_unique (option Name) (fun x => x) ls. - Definition name_list_unique (ls : list Name) : Prop - := oname_list_unique (List.map (@Some Name) ls). -End language. - -Global Arguments split_mnames {_ _ MName} force _ _, {_ _} MName force _ _. -Global Arguments split_onames {_ _} _ _. -Global Arguments split_names {_ _} _ _. -Global Arguments mname_list_unique {_ MName} force ls, {_} MName force ls. -Global Arguments oname_list_unique {_} ls. -Global Arguments name_list_unique {_} ls. diff --git a/src/Reflection/Named/NameUtilProperties.v b/src/Reflection/Named/NameUtilProperties.v deleted file mode 100644 index 9a52ff49d..000000000 --- a/src/Reflection/Named/NameUtilProperties.v +++ /dev/null @@ -1,223 +0,0 @@ -Require Import Coq.omega.Omega. -Require Import Coq.Arith.Arith. -Require Import Coq.Lists.List. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.CountLets. -Require Import Crypto.Reflection.Named.NameUtil. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.RewriteHyp. -Require Import Crypto.Util.Tactics.SplitInContext. -Require Import Crypto.Util.ListUtil. -Require Import Crypto.Util.NatUtil. -Require Import Crypto.Util.Prod. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Tactics.SplitInContext. -Require Import Crypto.Util.Tactics.SpecializeBy. - -Local Open Scope core_scope. -Section language. - Context {base_type_code : Type} - {Name : Type}. - - Section monad. - Context (MName : Type) (force : MName -> option Name). - - Lemma split_mnames_firstn_skipn - (t : flat_type base_type_code) (ls : list MName) - : split_mnames force t ls - = (fst (split_mnames force t (firstn (count_pairs t) ls)), - skipn (count_pairs t) ls). - Proof using Type. - apply path_prod_uncurried; simpl. - revert ls; induction t; split; split_prod; - repeat first [ progress simpl in * - | progress intros - | rewrite <- skipn_skipn - | reflexivity - | progress break_innermost_match_step - | apply (f_equal2 (@pair _ _)) - | rewrite_hyp <- !* - | match goal with - | [ H : forall ls, snd (split_mnames _ _ _) = _, H' : context[snd (split_mnames _ _ _)] |- _ ] - => rewrite H in H' - | [ H : _ |- _ ] => first [ rewrite <- firstn_skipn_add in H ] - | [ H : forall ls', fst (split_mnames _ _ _) = _, H' : context[fst (split_mnames _ _ (skipn ?n ?ls))] |- _ ] - => rewrite (H (skipn n ls)) in H' - | [ H : forall ls', fst (split_mnames _ _ _) = _, H' : context[fst (split_mnames _ ?t (firstn (count_pairs ?t + ?n) ?ls))] |- _ ] - => rewrite (H (firstn (count_pairs t + n) ls)), firstn_firstn in H' by omega - | [ H : forall ls', fst (split_mnames _ _ _) = _, H' : context[fst (split_mnames _ ?t ?ls)] |- _ ] - => is_var ls; rewrite (H ls) in H' - | [ H : ?x = Some _, H' : ?x = None |- _ ] => congruence - | [ H : ?x = Some ?a, H' : ?x = Some ?b |- _ ] - => assert (a = b) by congruence; (subst a || subst b) - end ]. - Qed. - - Lemma snd_split_mnames_skipn - (t : flat_type base_type_code) (ls : list MName) - : snd (split_mnames force t ls) = skipn (count_pairs t) ls. - Proof using Type. rewrite split_mnames_firstn_skipn; reflexivity. Qed. - Lemma fst_split_mnames_firstn - (t : flat_type base_type_code) (ls : list MName) - : fst (split_mnames force t ls) = fst (split_mnames force t (firstn (count_pairs t) ls)). - Proof using Type. rewrite split_mnames_firstn_skipn at 1; reflexivity. Qed. - - Lemma mname_list_unique_firstn_skipn n ls - : mname_list_unique force ls - -> (mname_list_unique force (firstn n ls) - /\ mname_list_unique force (skipn n ls)). - Proof using Type. - unfold mname_list_unique; intro H; split; intros k N; - rewrite <- ?firstn_map, <- ?skipn_map, ?skipn_skipn, ?firstn_firstn_min, ?firstn_skipn_add; - intros; eapply H; try eassumption. - { apply Min.min_case_strong. - { match goal with H : _ |- _ => rewrite skipn_firstn in H end; - eauto using In_firstn. } - { intro; match goal with H : _ |- _ => rewrite skipn_all in H by (rewrite firstn_length; omega * ) end. - simpl in *; tauto. } } - { eauto using In_skipn. } - Qed. - Definition mname_list_unique_firstn n ls - : mname_list_unique force ls -> mname_list_unique force (firstn n ls) - := fun H => proj1 (@mname_list_unique_firstn_skipn n ls H). - Definition mname_list_unique_skipn n ls - : mname_list_unique force ls -> mname_list_unique force (skipn n ls) - := fun H => proj2 (@mname_list_unique_firstn_skipn n ls H). - Lemma mname_list_unique_nil - : mname_list_unique force nil. - Proof using Type. - unfold mname_list_unique; simpl; intros ??. - rewrite firstn_nil, skipn_nil; simpl; auto. - Qed. - End monad. - - Lemma split_onames_firstn_skipn - (t : flat_type base_type_code) (ls : list (option Name)) - : split_onames t ls - = (fst (split_onames t (firstn (count_pairs t) ls)), - skipn (count_pairs t) ls). - Proof using Type. apply split_mnames_firstn_skipn. Qed. - Lemma snd_split_onames_skipn - (t : flat_type base_type_code) (ls : list (option Name)) - : snd (split_onames t ls) = skipn (count_pairs t) ls. - Proof using Type. apply snd_split_mnames_skipn. Qed. - Lemma fst_split_onames_firstn - (t : flat_type base_type_code) (ls : list (option Name)) - : fst (split_onames t ls) = fst (split_onames t (firstn (count_pairs t) ls)). - Proof using Type. apply fst_split_mnames_firstn. Qed. - - Lemma oname_list_unique_firstn n (ls : list (option Name)) - : oname_list_unique ls -> oname_list_unique (firstn n ls). - Proof using Type. apply mname_list_unique_firstn. Qed. - Lemma oname_list_unique_skipn n (ls : list (option Name)) - : oname_list_unique ls -> oname_list_unique (skipn n ls). - Proof using Type. apply mname_list_unique_skipn. Qed. - Lemma oname_list_unique_specialize (ls : list (option Name)) - : oname_list_unique ls - -> forall k n, - List.In (Some n) (firstn k ls) - -> List.In (Some n) (skipn k ls) - -> False. - Proof using Type. - intros H k n; specialize (H k n). - rewrite map_id in H; assumption. - Qed. - Definition oname_list_unique_nil : oname_list_unique (@nil (option Name)) - := mname_list_unique_nil _ (fun x => x). - - - Lemma split_names_firstn_skipn - (t : flat_type base_type_code) (ls : list Name) - : split_names t ls - = (fst (split_names t (firstn (count_pairs t) ls)), - skipn (count_pairs t) ls). - Proof using Type. apply split_mnames_firstn_skipn. Qed. - Lemma snd_split_names_skipn - (t : flat_type base_type_code) (ls : list Name) - : snd (split_names t ls) = skipn (count_pairs t) ls. - Proof using Type. apply snd_split_mnames_skipn. Qed. - Lemma fst_split_names_firstn - (t : flat_type base_type_code) (ls : list Name) - : fst (split_names t ls) = fst (split_names t (firstn (count_pairs t) ls)). - Proof using Type. apply fst_split_mnames_firstn. Qed. - - Lemma name_list_unique_firstn n (ls : list Name) - : name_list_unique ls -> name_list_unique (firstn n ls). - Proof using Type. - unfold name_list_unique; intro H; apply oname_list_unique_firstn with (n:=n) in H. - rewrite <- firstn_map; assumption. - Qed. - Lemma name_list_unique_skipn n (ls : list Name) - : name_list_unique ls -> name_list_unique (skipn n ls). - Proof using Type. - unfold name_list_unique; intro H; apply oname_list_unique_skipn with (n:=n) in H. - rewrite <- skipn_map; assumption. - Qed. - Lemma name_list_unique_specialize (ls : list Name) - : name_list_unique ls - -> forall k n, - List.In n (firstn k ls) - -> List.In n (skipn k ls) - -> False. - Proof using Type. - intros H k n; specialize (H k n). - rewrite !map_id, !firstn_map, !skipn_map in H. - eauto using in_map. - Qed. - Definition name_list_unique_nil : name_list_unique nil - := mname_list_unique_nil _ (@Some Name). - - Lemma length_fst_split_names_Some_iff - (t : flat_type base_type_code) (ls : list Name) - : fst (split_names t ls) <> None <-> List.length ls >= count_pairs t. - Proof using Type. - revert ls; induction t; intros; - try solve [ destruct ls; simpl; intuition (omega || congruence) ]. - repeat first [ progress simpl in * - | progress break_innermost_match_step - | progress specialize_by congruence - | progress specialize_by omega - | rewrite snd_split_names_skipn in * - | progress intros - | congruence - | omega - | match goal with - | [ H : forall ls, fst (split_names ?t ls) <> None <-> _, H' : fst (split_names ?t ?ls') = _ |- _ ] - => specialize (H ls'); rewrite H' in H - | [ H : _ |- _ ] => rewrite skipn_length in H - end - | progress split_iff - | match goal with - | [ |- iff _ _ ] => split - end ]. - Qed. - - Lemma length_fst_split_names_None_iff - (t : flat_type base_type_code) (ls : list Name) - : fst (split_names t ls) = None <-> List.length ls < count_pairs t. - Proof using Type. - destruct (length_fst_split_names_Some_iff t ls). - destruct (le_lt_dec (count_pairs t) (List.length ls)); specialize_by omega; - destruct (fst (split_names t ls)); split; try intuition (congruence || omega). - Qed. - - Lemma split_onames_split_names (t : flat_type base_type_code) (ls : list Name) - : split_onames t (List.map Some ls) - = (fst (split_names t ls), List.map Some (snd (split_names t ls))). - Proof using Type. - revert ls; induction t; - try solve [ destruct ls; reflexivity ]. - repeat first [ progress simpl in * - | progress intros - | rewrite snd_split_names_skipn - | rewrite snd_split_onames_skipn - | rewrite skipn_map - | match goal with - | [ H : forall ls, split_onames ?t (map Some ls) = _ |- context[split_onames ?t (map Some ?ls')] ] - => specialize (H ls') - end - | break_innermost_match_step - | progress inversion_prod - | congruence ]. - Qed. -End language. diff --git a/src/Reflection/Named/PositiveContext.v b/src/Reflection/Named/PositiveContext.v deleted file mode 100644 index 4356a174a..000000000 --- a/src/Reflection/Named/PositiveContext.v +++ /dev/null @@ -1,9 +0,0 @@ -Require Import Coq.FSets.FMapPositive. -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.FMapContext. - -Module PositiveContext := FMapContext PositiveMap. -Notation PositiveContext := PositiveContext.FMapContext. -Notation PositiveContext_nd := PositiveContext.FMapContext_nd. -Definition PositiveContextOk := PositiveContext.FMapContextOk (fun x y pf => pf). -Global Existing Instance PositiveContextOk. diff --git a/src/Reflection/Named/PositiveContext/Defaults.v b/src/Reflection/Named/PositiveContext/Defaults.v deleted file mode 100644 index 34ce169f2..000000000 --- a/src/Reflection/Named/PositiveContext/Defaults.v +++ /dev/null @@ -1,16 +0,0 @@ -Require Import Coq.Lists.List. -Require Import Coq.Numbers.BinNums. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Named.PositiveContext. -Require Import Crypto.Reflection.CountLets. - -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type}. - Definition default_names_forf {var} (dummy : forall t, var t) {t} (e : exprf base_type_code op (var:=var) t) : list positive - := map BinPos.Pos.of_succ_nat (seq 0 (count_let_bindersf dummy e)). - Definition default_names_for {var} (dummy : forall t, var t) {t} (e : expr base_type_code op (var:=var) t) : list positive - := map BinPos.Pos.of_succ_nat (seq 0 (count_binders dummy e)). - Definition DefaultNamesFor {t} (e : Expr base_type_code op t) : list positive - := map BinPos.Pos.of_succ_nat (seq 0 (CountBinders e)). -End language. diff --git a/src/Reflection/Named/PositiveContext/DefaultsProperties.v b/src/Reflection/Named/PositiveContext/DefaultsProperties.v deleted file mode 100644 index 435a4c74c..000000000 --- a/src/Reflection/Named/PositiveContext/DefaultsProperties.v +++ /dev/null @@ -1,38 +0,0 @@ -Require Import Coq.Lists.List. -Require Import Coq.Numbers.BinNums. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Named.PositiveContext. -Require Import Crypto.Reflection.CountLets. -Require Import Crypto.Reflection.Named.NameUtil. -Require Import Crypto.Reflection.Named.PositiveContext.Defaults. -Require Import Crypto.Util.ListUtil. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.NatUtil. -Require Import Crypto.Util.Tactics.DestructHead. - -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type}. - - Lemma name_list_unique_map_pos_of_succ_nat_seq a b - : name_list_unique (map BinPos.Pos.of_succ_nat (seq a b)). - Proof using Type. - unfold name_list_unique, oname_list_unique, mname_list_unique. - intros k n. - rewrite !map_map, firstn_map, skipn_map, firstn_seq, skipn_seq. - rewrite !in_map_iff; intros; destruct_head' ex; destruct_head' and; inversion_option; subst. - match goal with H : _ |- _ => apply Pnat.SuccNat2Pos.inj in H end; subst. - rewrite in_seq in *. - omega *. - Qed. - - Lemma name_list_unique_default_names_forf {var dummy t e} - : name_list_unique (@default_names_forf base_type_code op var dummy t e). - Proof using Type. apply name_list_unique_map_pos_of_succ_nat_seq. Qed. - Lemma name_list_unique_default_names_for {var dummy t e} - : name_list_unique (@default_names_for base_type_code op var dummy t e). - Proof using Type. apply name_list_unique_map_pos_of_succ_nat_seq. Qed. - Lemma name_list_unique_DefaultNamesFor {t e} - : name_list_unique (@DefaultNamesFor base_type_code op t e). - Proof using Type. apply name_list_unique_map_pos_of_succ_nat_seq. Qed. -End language. diff --git a/src/Reflection/Named/RegisterAssign.v b/src/Reflection/Named/RegisterAssign.v deleted file mode 100644 index 18e15519a..000000000 --- a/src/Reflection/Named/RegisterAssign.v +++ /dev/null @@ -1,88 +0,0 @@ -(** * Reassign registers *) -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Named.PositiveContext. -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.NameUtil. -Require Import Crypto.Util.Decidable. - -Local Notation eta x := (fst x, snd x). - -Local Open Scope ctype_scope. -Delimit Scope nexpr_scope with nexpr. -Section language. - Context (base_type_code : Type) - (op : flat_type base_type_code -> flat_type base_type_code -> Type). - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation exprf := (@exprf base_type_code op). - Local Notation expr := (@expr base_type_code op). - - Section internal. - Context (InName OutName : Type) - {InContext : Context InName (fun _ : base_type_code => OutName)} - {ReverseContext : Context OutName (fun _ : base_type_code => InName)} - (InName_beq : InName -> InName -> bool). - - Definition register_reassignf_step - (register_reassignf : forall (ctxi : InContext) (ctxr : ReverseContext) - {t} (e : exprf InName t) (new_names : list (option OutName)), - option (exprf OutName t)) - (ctxi : InContext) (ctxr : ReverseContext) - {t} (e : exprf InName t) (new_names : list (option OutName)) - : option (exprf OutName t) - := match e in Named.exprf _ _ _ t return option (exprf _ t) with - | TT => Some TT - | Var t' name => match lookupb ctxi name t' with - | Some new_name - => match lookupb ctxr new_name t' with - | Some name' - => if InName_beq name name' - then Some (Var new_name) - else None - | None => None - end - | None => None - end - | Op _ _ op args - => option_map (Op op) (@register_reassignf ctxi ctxr _ args new_names) - | LetIn tx n ex _ eC - => let '(n', new_names') := eta (split_onames tx new_names) in - match n', @register_reassignf ctxi ctxr _ ex nil with - | Some n', Some x - => let ctxi := extend ctxi n n' in - let ctxr := extend ctxr n' n in - option_map (LetIn tx n' x) (@register_reassignf ctxi ctxr _ eC new_names') - | _, _ - => let ctxi := remove ctxi n in - @register_reassignf ctxi ctxr _ eC new_names' - end - | Pair _ ex _ ey - => match @register_reassignf ctxi ctxr _ ex nil, @register_reassignf ctxi ctxr _ ey nil with - | Some x, Some y - => Some (Pair x y) - | _, _ => None - end - end. - Fixpoint register_reassignf ctxi ctxr {t} e new_names - := @register_reassignf_step (@register_reassignf) ctxi ctxr t e new_names. - - Definition register_reassign (ctxi : InContext) (ctxr : ReverseContext) - {t} (e : expr InName t) (new_names : list (option OutName)) - : option (expr OutName t) - := match e in Named.expr _ _ _ t return option (expr _ t) with - | Abs src _ n f - => let '(n', new_names') := eta (split_onames src new_names) in - match n' with - | Some n' - => let ctxi := extend (t:=src) ctxi n n' in - let ctxr := extend (t:=src) ctxr n' n in - option_map (Abs n') (register_reassignf ctxi ctxr f new_names') - | None => None - end - end. - End internal. -End language. - -Global Arguments register_reassign {_ _ _ _ _ _} _ ctxi ctxr {t} e _. -Global Arguments register_reassignf {_ _ _ _ _ _} _ ctxi ctxr {t} e _. diff --git a/src/Reflection/Named/SmartMap.v b/src/Reflection/Named/SmartMap.v deleted file mode 100644 index 3cacf7a1b..000000000 --- a/src/Reflection/Named/SmartMap.v +++ /dev/null @@ -1,20 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Named.Syntax. - -Module Export Named. - Section language. - Context {base_type_code : Type} - {interp_base_type : base_type_code -> Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - {Name : Type}. - - (** [SmartVar] is like [Var], except that it inserts - pair-projections and [Pair] as necessary to handle - [flat_type], and not just [base_type_code] *) - Definition SmartVar {t} : interp_flat_type (fun _ => Name) t -> @exprf base_type_code op Name t - := smart_interp_flat_map (f:=fun _ => Name) (g:=@exprf _ _ _) (fun t => Var) TT (fun A B x y => Pair x y). - End language. -End Named. - -Global Arguments SmartVar {_ _ _ _} _. diff --git a/src/Reflection/Named/Syntax.v b/src/Reflection/Named/Syntax.v deleted file mode 100644 index b4846be9a..000000000 --- a/src/Reflection/Named/Syntax.v +++ /dev/null @@ -1,145 +0,0 @@ -(** * Named Representation of Gallina *) -Require Import Coq.Classes.RelationClasses. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Util.PointedProp. -Require Import Crypto.Util.Tuple. -(*Require Import Crypto.Util.Tactics.*) -Require Import Crypto.Util.Notations. -Require Import Crypto.Util.LetIn. - -Record Context {base_type_code} (Name : Type) (var : base_type_code -> Type) := - { ContextT : Type; - lookupb : ContextT -> Name -> forall {t : base_type_code}, option (var t); - extendb : ContextT -> Name -> forall {t : base_type_code}, var t -> ContextT; - removeb : ContextT -> Name -> base_type_code -> ContextT; - empty : ContextT }. -Coercion ContextT : Context >-> Sortclass. -Arguments ContextT {_ _ _ _}, {_ _ _} _. -Arguments lookupb {_ _ _ _} _ _ {_}, {_ _ _ _} _ _ _. -Arguments extendb {_ _ _ _} _ _ [_] _. -Arguments removeb {_ _ _ _} _ _ _. -Arguments empty {_ _ _ _}. - -Local Open Scope ctype_scope. -Local Open Scope expr_scope. -Delimit Scope nexpr_scope with nexpr. -Module Export Named. - Section language. - Context (base_type_code : Type) - (interp_base_type : base_type_code -> Type) - (op : flat_type base_type_code -> flat_type base_type_code -> Type) - (Name : Type). - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation interp_type := (interp_type interp_base_type). - Local Notation interp_flat_type_gen := interp_flat_type. - Local Notation interp_flat_type := (interp_flat_type interp_base_type). - - Inductive exprf : flat_type -> Type := - | TT : exprf Unit - | Var {t : base_type_code} : Name -> exprf (Tbase t) - | Op {t1 tR} : op t1 tR -> exprf t1 -> exprf tR - | LetIn : forall {tx}, interp_flat_type_gen (fun _ => Name) tx -> exprf tx -> forall {tC}, exprf tC -> exprf tC - | Pair : forall {t1}, exprf t1 -> forall {t2}, exprf t2 -> exprf (Prod t1 t2). - Bind Scope nexpr_scope with exprf. - Inductive expr : type -> Type := - | Abs {src dst} : interp_flat_type_gen (fun _ => Name) src -> exprf dst -> expr (Arrow src dst). - Bind Scope nexpr_scope with expr. - Definition Abs_name {t} (e : expr t) : interp_flat_type_gen (fun _ => Name) (domain t) - := match e with Abs _ _ n f => n end. - Definition invert_Abs {t} (e : expr t) : exprf (codomain t) - := match e with Abs _ _ n f => f end. - - Section with_context. - Context {var : base_type_code -> Type} - {Context : Context Name var}. - - Fixpoint extend (ctx : Context) {t : flat_type} - (n : interp_flat_type_gen (fun _ => Name) t) (v : interp_flat_type_gen var t) - : Context - := match t return interp_flat_type_gen (fun _ => Name) t -> interp_flat_type_gen var t -> Context with - | Tbase t => fun n v => extendb ctx n v - | Unit => fun _ _ => ctx - | Prod A B => fun n v - => let ctx := @extend ctx A (fst n) (fst v) in - let ctx := @extend ctx B (snd n) (snd v) in - ctx - end n v. - - Fixpoint remove (ctx : Context) {t : flat_type} - (n : interp_flat_type_gen (fun _ => Name) t) - : Context - := match t return interp_flat_type_gen (fun _ => Name) t -> Context with - | Tbase t => fun n => removeb ctx n t - | Unit => fun _ => ctx - | Prod A B => fun n - => let ctx := @remove ctx A (fst n) in - let ctx := @remove ctx B (snd n) in - ctx - end n. - - Definition lookup (ctx : Context) {t} - : interp_flat_type_gen (fun _ => Name) t -> option (interp_flat_type_gen var t) - := smart_interp_flat_map - (g := fun t => option (interp_flat_type_gen var t)) - (fun t v => lookupb ctx v) - (Some tt) - (fun A B x y => match x, y with - | Some x', Some y' => Some (x', y')%core - | _, _ => None - end). - End with_context. - - Section with_val_context. - Context (Context : Context Name interp_base_type) - (interp_op : forall src dst, op src dst -> interp_flat_type src -> interp_flat_type dst). - - Fixpoint interpf - (ctx : Context) {t} (e : exprf t) - : option (interp_flat_type t) - := match e in exprf t return option (interp_flat_type t) with - | Var t' x => lookupb ctx x t' - | TT => Some tt - | Pair _ ex _ ey - => match @interpf ctx _ ex, @interpf ctx _ ey with - | Some xv, Some yv => Some (xv, yv)%core - | None, _ | _, None => None - end - | Op _ _ opc args - => option_map (@interp_op _ _ opc) (@interpf ctx _ args) - | LetIn _ n ex _ eC - => match @interpf ctx _ ex with - | Some xv - => dlet x := xv in - @interpf (extend ctx n x) _ eC - | None => None - end - end. - - Definition interp (ctx : Context) {t} (e : expr t) - : interp_flat_type (domain t) -> option (interp_flat_type (codomain t)) - := fun v => @interpf (extend ctx (Abs_name e) v) _ (invert_Abs e). - End with_val_context. - End language. -End Named. - -Global Arguments TT {_ _ _}. -Global Arguments Var {_ _ _ _} _. -Global Arguments Op {_ _ _ _ _} _ _. -Global Arguments LetIn {_ _ _} _ _ _ {_} _. -Global Arguments Pair {_ _ _ _} _ {_} _. -Global Arguments Abs {_ _ _ _ _} _ _. -Global Arguments invert_Abs {_ _ _ _} _. -Global Arguments Abs_name {_ _ _ _} _. -Global Arguments extend {_ _ _ _} ctx {_} _ _. -Global Arguments remove {_ _ _ _} ctx {_} _. -Global Arguments lookup {_ _ _ _} ctx {_} _, {_ _ _ _} ctx _ _. -Global Arguments interpf {_ _ _ _ _ interp_op ctx t} _. -Global Arguments interp {_ _ _ _ _ interp_op ctx t} _ _. - -Notation "'slet' x := A 'in' b" := (LetIn _ x A%nexpr b%nexpr) : nexpr_scope. -Notation "'λn' x .. y , t" := (Abs x .. (Abs y t%nexpr) .. ) : nexpr_scope. -Notation "( x , y , .. , z )" := (Pair .. (Pair x%nexpr y%nexpr) .. z%nexpr) : nexpr_scope. -Notation "()" := TT : nexpr_scope. diff --git a/src/Reflection/Named/Wf.v b/src/Reflection/Named/Wf.v deleted file mode 100644 index 6b1e68e65..000000000 --- a/src/Reflection/Named/Wf.v +++ /dev/null @@ -1,36 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Util.PointedProp. - -Module Export Named. - Section language. - Context {base_type_code Name : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type}. - Section with_var. - Context {var} - (Context : @Context base_type_code Name var). - - Fixpoint wff (ctx : Context) {t} (e : @exprf base_type_code op Name t) : option pointed_Prop - := match e with - | TT => Some trivial - | Var t n => match lookupb ctx n t return bool with - | Some _ => true - | None => false - end - | Op _ _ op args => @wff ctx _ args - | LetIn _ n ex _ eC => @wff ctx _ ex /\ inject (forall v, prop_of_option (@wff (extend ctx n v) _ eC)) - | Pair _ ex _ ey => @wff ctx _ ex /\ @wff ctx _ ey - end%option_pointed_prop. - - Definition wf (ctx : Context) {t} (e : @expr base_type_code op Name t) : Prop - := forall v, prop_of_option (@wff (extend ctx (Abs_name e) v) _ (invert_Abs e)). - End with_var. - - Definition Wf (Context : forall var, @Context base_type_code Name var) {t} (e : @expr base_type_code op Name t) - := forall var, wf (Context var) empty e. - End language. -End Named. - -Global Arguments wff {_ _ _ _ _} ctx {t} _. -Global Arguments wf {_ _ _ _ _} ctx {t} _. -Global Arguments Wf {_ _ _} Context {t} _. diff --git a/src/Reflection/Named/WfInterp.v b/src/Reflection/Named/WfInterp.v deleted file mode 100644 index c5fe2bb3a..000000000 --- a/src/Reflection/Named/WfInterp.v +++ /dev/null @@ -1,40 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.Wf. -Require Import Crypto.Util.PointedProp. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.SpecializeBy. -Require Import Crypto.Util.Tactics.DestructHead. - -Section language. - Context {base_type_code Name interp_base_type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - {interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst} - {Context : @Context base_type_code Name interp_base_type}. - - Lemma wff_interpf_not_None {ctx : Context} {t} {e : @exprf base_type_code op Name t} - (Hwf : prop_of_option (wff ctx e)) - : @interpf base_type_code interp_base_type op Name Context interp_op ctx t e <> None. - Proof using Type. - revert dependent ctx; induction e; - repeat first [ progress intros - | progress simpl in * - | progress unfold option_map, LetIn.Let_In in * - | congruence - | progress specialize_by_assumption - | progress destruct_head' and - | progress break_innermost_match_step - | progress break_match_hyps - | progress autorewrite with push_prop_of_option in * - | progress specialize_by auto - | solve [ intuition eauto ] ]. - Qed. - - Lemma wf_interp_not_None {ctx : Context} {t} {e : @expr base_type_code op Name t} - (Hwf : wf ctx e) - v - : @interp base_type_code interp_base_type op Name Context interp_op ctx t e v <> None. - Proof using Type. - destruct e; unfold interp, wf in *; apply wff_interpf_not_None; auto. - Qed. -End language. diff --git a/src/Reflection/Reify.v b/src/Reflection/Reify.v deleted file mode 100644 index adc3feec8..000000000 --- a/src/Reflection/Reify.v +++ /dev/null @@ -1,483 +0,0 @@ -(** * Exact reification of PHOAS Representation of Gallina *) -(** The reification procedure goes through [InputSyntax], which allows - judgmental equality of the denotation of the reified term. *) -Require Import Coq.Strings.String. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Reflection.InputSyntax. -Require Import Crypto.Util.Tuple. -Require Import Crypto.Util.Tactics.DebugPrint. -(*Require Import Crypto.Util.Tactics.PrintContext.*) -Require Import Crypto.Util.Tactics.Head. -Require Import Crypto.Util.LetIn. -Require Import Crypto.Util.Notations. -Require Import Crypto.Util.Tactics.TransparentAssert. - -(** Change this with [Ltac reify_debug_level ::= constr:(1).] to get - more debugging. *) -Ltac reify_debug_level := constr:(0). -Module Import ReifyDebugNotations. - Export Reflection.Syntax.Notations. - Export Util.LetIn. - Open Scope string_scope. -End ReifyDebugNotations. - -Ltac debug_enter_reify_idtac funname e := - let s := (eval compute in (String.append funname ": Attempting to reify:")) in - cidtac2 s e. -Ltac debug_leave_reify_success_idtac funname e := - let s := (eval compute in (String.append funname ": Success in reifying:")) in - cidtac2 s e. -Ltac debug_leave_reify_failure_idtac funname e := - let s := (eval compute in (String.append funname ": Failure in reifying:")) in - cfail2 s e. -Ltac debug_reifyf_case_idtac case := - let s := (eval compute in (String.append "reifyf: " case)) in - cidtac s. -Ltac check_debug_level_then_Set _ := - let lvl := reify_debug_level in - lazymatch type of lvl with - | nat => constr:(Set) - | ?T => cfail2 "reify_debug_level should have type nat but instead has type" T - end. -Ltac debug1 tac := - let lvl := reify_debug_level in - match lvl with - | S _ => tac () - | _ => check_debug_level_then_Set () - end. -Ltac debug2 tac := - let lvl := reify_debug_level in - match lvl with - | S (S _) => tac () - | _ => check_debug_level_then_Set () - end. -Ltac debug3 tac := - let lvl := reify_debug_level in - match lvl with - | S (S (S _)) => tac () - | _ => check_debug_level_then_Set () - end. -Ltac debug_enter_reify2 funname e := debug2 ltac:(fun _ => debug_enter_reify_idtac funname e). -Ltac debug_leave_reify3_success funname e := debug3 ltac:(fun _ => debug_leave_reify_success_idtac funname e). -Ltac debug_enter_reify3 funname e := debug2 ltac:(fun _ => debug_enter_reify_idtac funname e). -Ltac debug_enter_reify_flat_type e := debug_enter_reify3 "reify_flat_type" e. -Ltac debug_enter_reify_type e := debug_enter_reify3 "reify_type" e. -Ltac debug_enter_reifyf e := debug_enter_reify2 "reifyf" e. -Ltac debug_leave_reifyf_success e := debug_leave_reify3_success "reifyf" e. -Ltac debug_leave_reifyf_failure e := debug_leave_reify_failure_idtac "reifyf" e. -Ltac debug_reifyf_case case := debug3 ltac:(fun _ => debug_reifyf_case_idtac case). -Ltac debug_enter_reify_abs e := debug_enter_reify2 "reify_abs" e. - -Class reify {varT} (var : varT) {eT} (e : eT) {T : Type} := Build_reify : T. -Definition reify_var_for_in_is base_type_code {T} (x : T) (t : flat_type base_type_code) {eT} (e : eT) := False. -Arguments reify_var_for_in_is _ {T} _ _ {eT} _. - -(** [reify] assumes that operations can be reified via the [reify_op] - typeclass, which gets passed the type family of operations, the - expression which is headed by an operation, and expects resolution - to fill in a number of arguments (which [reifyf] will - automatically curry), as well as the reified operator. - - We also assume that types can be reified via the [reify] typeclass - with arguments [reify type <type to be reified>]. *) -Class reify_op {opTF} (op_family : opTF) {opExprT} (opExpr : opExprT) (nargs : nat) {opT} (reified_op : opT) - := Build_reify_op : True. -Ltac strip_type_cast term := lazymatch term with ?term' => term' end. -(** Override this to get a faster [reify_type] *) -Ltac base_reify_type T := - strip_type_cast (_ : reify type T). -Ltac reify_base_type T := base_reify_type T. -Ltac reify_flat_type T := - let dummy := debug_enter_reify_flat_type T in - lazymatch T with - | prod ?A ?B - => let a := reify_flat_type A in - let b := reify_flat_type B in - constr:(@Prod _ a b) - | Syntax.interp_type _ (Tflat ?T) - => T - | Syntax.interp_flat_type _ ?T - => T - | _ - => let v := reify_base_type T in - constr:(@Tbase _ v) - end. -Ltac reify_input_type T := - let dummy := debug_enter_reify_type T in - lazymatch T with - | (?A -> ?B)%type - => let a := reify_flat_type A in - let b := reify_input_type B in - constr:(@Arrow _ a b) - | InputSyntax.interp_type _ ?T - => T - end. -Ltac reify_type T := - let dummy := debug_enter_reify_type T in - lazymatch T with - | (?A -> ?B)%type - => let a := reify_flat_type A in - let b := reify_flat_type B in - constr:(@Syntax.Arrow _ a b) - | Syntax.interp_type _ ?T - => T - end. - -Ltac reifyf_var x mkVar := - lazymatch goal with - | _ : reify_var_for_in_is _ x ?t ?v |- _ => mkVar t v - | _ => lazymatch x with - | fst ?x' => reifyf_var x' ltac:(fun t v => lazymatch t with - | Prod ?A ?B => mkVar A (fst v) - end) - | snd ?x' => reifyf_var x' ltac:(fun t v => lazymatch t with - | Prod ?A ?B => mkVar B (snd v) - end) - end - end. - -Inductive reify_result_helper := -| finished_value {T} (res : T) -| context_value {TF} (resF : TF) {argT} (arg : argT) -| op_info {T} (res : T) -| reification_unsuccessful. - -(** Override this to get a faster [reify_op] *) -Ltac base_reify_op op op_head expr := - let r := constr:(_ : reify_op op op_head _ _) in - type of r. -Ltac reify_op op op_head expr := - let t := base_reify_op op op_head expr in - constr:(op_info t). - -Ltac debug_enter_reify_rec := - let lvl := reify_debug_level in - match lvl with - | S _ => idtac_goal - | _ => idtac - end. -Ltac debug_leave_reify_rec e := - let lvl := reify_debug_level in - match lvl with - | S _ => idtac "<infomsg>reifyf success:" e "</infomsg>" - | _ => idtac - end. - -Ltac reifyf base_type_code interp_base_type op var e := - let reify_rec e := reifyf base_type_code interp_base_type op var e in - let mkLetIn ex eC := constr:(LetIn (base_type_code:=base_type_code) (interp_base_type:=interp_base_type) (op:=op) (var:=var) ex eC) in - let mkPair ex ey := constr:(Pair (base_type_code:=base_type_code) (interp_base_type:=interp_base_type) (op:=op) (var:=var) ex ey) in - let mkVar T ex := constr:(Var (base_type_code:=base_type_code) (interp_base_type:=interp_base_type) (op:=op) (var:=var) (t:=T) ex) in - let mkConst T ex := constr:(Const (base_type_code:=base_type_code) (interp_base_type:=interp_base_type) (op:=op) (var:=var) (t:=T) ex) in - let mkOp T retT op_code args := constr:(Op (base_type_code:=base_type_code) (interp_base_type:=interp_base_type) (op:=op) (var:=var) (t1:=T) (tR:=retT) op_code args) in - let mkMatchPair tC ex eC := constr:(MatchPair (base_type_code:=base_type_code) (interp_base_type:=interp_base_type) (op:=op) (var:=var) (tC:=tC) ex eC) in - let mkFst ex := constr:(Fst (base_type_code:=base_type_code) (interp_base_type:=interp_base_type) (op:=op) (var:=var) ex) in - let mkSnd ex := constr:(Snd (base_type_code:=base_type_code) (interp_base_type:=interp_base_type) (op:=op) (var:=var) ex) in - let reify_pretag := constr:(@exprf base_type_code interp_base_type op) in - let reify_tag := constr:(reify_pretag var) in - let dummy := debug_enter_reifyf e in - match constr:(Set) with - | _ => - let ret := - lazymatch e with - | let x := ?ex in @?eC x => - let dummy := debug_reifyf_case "let in" in - let ex := reify_rec ex in - let eC := reify_rec eC in - mkLetIn ex eC - | (dlet x := ?ex in @?eC x) => - let dummy := debug_reifyf_case "dlet in" in - let ex := reify_rec ex in - let eC := reify_rec eC in - mkLetIn ex eC - | pair ?a ?b => - let dummy := debug_reifyf_case "pair" in - let a := reify_rec a in - let b := reify_rec b in - mkPair a b - | (fun x : ?T => ?C) => - let dummy := debug_reifyf_case "fun" in - let t := reify_flat_type T in - (* Work around Coq 8.5 and 8.6 bug *) - (* <https://coq.inria.fr/bugs/show_bug.cgi?id=4998> *) - (* Avoid re-binding the Gallina variable referenced by Ltac [x] *) - (* even if its Gallina name matches a Ltac in this tactic. *) - let maybe_x := fresh x in - let not_x := fresh x in - let C' := match constr:(Set) with - | _ => constr:(fun (x : T) (not_x : var t) (_ : reify_var_for_in_is base_type_code x t not_x) => - (_ : reify reify_tag C)) (* [C] here is an open term that references "x" by name *) - | _ => cfail2 "reifyf: Failed to reify by typeclasses:"%string e - end in - match constr:(Set) with - | _ => lazymatch C' - with fun _ v _ => @?C v => C end - | _ => cfail2 "reifyf: Failed to eliminate function dependencies of:"%string C' - end - | match ?ev with pair a b => @?eC a b end => - let dummy := debug_reifyf_case "matchpair" in - let T := type of eC in - let t := (let T := match (eval cbv beta in T) with _ -> _ -> ?T => T end in reify_flat_type T) in - let v := reify_rec ev in - let C := reify_rec eC in - let ret := mkMatchPair t v C in - ret - | @fst ?A ?B ?ev => - let dummy := debug_reifyf_case "fst" in - let v := reify_rec ev in - mkFst v - | @snd ?A ?B ?ev => - let dummy := debug_reifyf_case "snd" in - let v := reify_rec ev in - mkSnd v - | ?x => - let dummy := debug_reifyf_case "generic" in - let t := lazymatch type of x with ?t => reify_flat_type t end in - let retv := match constr:(Set) with - | _ => let retv := reifyf_var x mkVar in constr:(finished_value retv) - | _ => let op_head := head x in - reify_op op op_head x - | _ => lazymatch x with - | ?F ?args - => lazymatch goal with - | [ rF : forall x not_x, reify reify_tag (F x) |- _ ] - => constr:(context_value rF args) - | [ rF : forall var' x (not_x : var' _), reify (reify_pretag var') (F x) |- _ ] - => constr:(context_value (rF var) args) - end - end - | _ => let c := mkConst t x in - constr:(finished_value c) - | _ => constr:(reification_unsuccessful) - end in - lazymatch retv with - | finished_value ?v => v - | context_value ?rFH ?eargs - => let dummy := debug_reifyf_case "context_value" in - let args := reify_rec eargs in - let F_head := head rFH in - let F := lazymatch (eval cbv beta delta [F_head] in rFH) with - | fun _ => ?C => C - end in - mkLetIn args F - | op_info (reify_op _ _ ?nargs ?op_code) - => let tR := (let tR := type of x in reify_flat_type tR) in - lazymatch nargs with - | 1%nat - => lazymatch x with - | ?f ?x0 - => let a0T := (let t := type of x0 in reify_flat_type t) in - let a0 := reify_rec x0 in - mkOp a0T tR op_code a0 - end - | 2%nat - => lazymatch x with - | ?f ?x0 ?x1 - => let a0T := (let t := type of x0 in reify_flat_type t) in - let a0 := reify_rec x0 in - let a1T := (let t := type of x1 in reify_flat_type t) in - let a1 := reify_rec x1 in - let args := mkPair a0 a1 in - mkOp (@Prod _ a0T a1T) tR op_code args - end - | 3%nat - => lazymatch x with - | ?f ?x0 ?x1 ?x2 - => let a0T := (let t := type of x0 in reify_flat_type t) in - let a0 := reify_rec x0 in - let a1T := (let t := type of x1 in reify_flat_type t) in - let a1 := reify_rec x1 in - let a2T := (let t := type of x2 in reify_flat_type t) in - let a2 := reify_rec x2 in - let args := let a01 := mkPair a0 a1 in mkPair a01 a2 in - mkOp (@Prod _ (@Prod _ a0T a1T) a2T) tR op_code args - end - | 4%nat - => lazymatch x with - | ?f ?x0 ?x1 ?x2 ?x3 - => let a0T := (let t := type of x0 in reify_flat_type t) in - let a0 := reify_rec x0 in - let a1T := (let t := type of x1 in reify_flat_type t) in - let a1 := reify_rec x1 in - let a2T := (let t := type of x2 in reify_flat_type t) in - let a2 := reify_rec x2 in - let a3T := (let t := type of x3 in reify_flat_type t) in - let a3 := reify_rec x3 in - let args := let a01 := mkPair a0 a1 in let a012 := mkPair a01 a2 in mkPair a012 a3 in - mkOp (@Prod _ (@Prod _ (@Prod _ a0T a1T) a2T) a3T) tR op_code args - end - | _ => cfail2 "Unsupported number of operation arguments in reifyf:"%string nargs - end - | reification_unsuccessful - => cfail2 "Failed to reify:"%string x - end - end in - let dummy := debug_leave_reifyf_success e in - ret - | _ => debug_leave_reifyf_failure e - end. - -Hint Extern 0 (reify (@exprf ?base_type_code ?interp_base_type ?op ?var) ?e) -=> (debug_enter_reify_rec; let e := reifyf base_type_code interp_base_type op var e in debug_leave_reify_rec e; eexact e) - : typeclass_instances. - -(** For reification including [Abs] *) -Class reify_abs {varT} (var : varT) {eT} (e : eT) {T : Type} := Build_reify_abs : T. -Ltac reify_abs base_type_code interp_base_type op var e := - let reify_rec e := reify_abs base_type_code interp_base_type op var e in - let reifyf_term e := reifyf base_type_code interp_base_type op var e in - let mkReturn ef := constr:(Return (base_type_code:=base_type_code) (interp_base_type:=interp_base_type) (op:=op) (var:=var) ef) in - let mkAbs src ef := constr:(Abs (base_type_code:=base_type_code) (interp_base_type:=interp_base_type) (op:=op) (var:=var) (src:=src) ef) in - let reify_tag := constr:(@exprf base_type_code interp_base_type op var) in - let dummy := debug_enter_reify_abs e in - lazymatch e with - | (fun x : ?T => ?C) => - let t := reify_flat_type T in - (* Work around Coq 8.5 and 8.6 bug *) - (* <https://coq.inria.fr/bugs/show_bug.cgi?id=4998> *) - (* Avoid re-binding the Gallina variable referenced by Ltac [x] *) - (* even if its Gallina name matches a Ltac in this tactic. *) - let maybe_x := fresh x in - let not_x := fresh x in - lazymatch constr:(fun (x : T) (not_x : var t) (_ : reify_var_for_in_is base_type_code x t not_x) => - (_ : reify_abs reify_tag C)) (* [C] here is an open term that references "x" by name *) - with fun _ v _ => @?C v => mkAbs t C end - | ?x => - let xv := reifyf_term x in - mkReturn xv - end. - -Hint Extern 0 (reify_abs (@exprf ?base_type_code ?interp_base_type ?op ?var) ?e) -=> (debug_enter_reify_rec; let e := reify_abs base_type_code interp_base_type op var e in debug_leave_reify_rec e; eexact e) : typeclass_instances. - -Ltac Reify' base_type_code interp_base_type op e := - lazymatch constr:(fun (var : flat_type base_type_code -> Type) => (_ : reify_abs (@exprf base_type_code interp_base_type op var) e)) with - (fun var => ?C) => constr:(fun (var : flat_type base_type_code -> Type) => C) (* copy the term but not the type cast *) - end. -Ltac Reify base_type_code interp_base_type op make_const e := - let r := Reify' base_type_code interp_base_type op e in - let r := lazymatch type of r with - | forall var, exprf _ _ _ _ => constr:(fun var => Abs (src:=Unit) (fun _ => r var)) - | _ => r - end in - constr:(@InputSyntax.Compile base_type_code interp_base_type op make_const _ r). - -Ltac rhs_of_goal := - lazymatch goal with - | [ |- ?R ?LHS ?RHS ] => RHS - | [ |- forall x, ?R (@?LHS x) (@?RHS x) ] => RHS - end. - -Ltac transitivity_tt term := - first [ transitivity term - | transitivity (term tt) - | let x := fresh in intro x; transitivity (term x); revert x ]. - -Ltac Reify_rhs_gen Reify prove_interp_compile_correct interp_op try_tac := - let rhs := rhs_of_goal in - let RHS := Reify rhs in - let RHS' := (eval vm_compute in RHS) in - transitivity_tt (Syntax.Interp interp_op RHS'); - [ - | transitivity_tt (Syntax.Interp interp_op RHS); - [ lazymatch goal with - | [ |- ?R ?x ?y ] - => cut (x = y) - | [ |- forall k, ?R (?x k) (?y k) ] - => cut (x = y) - end; - [ let H := fresh in - intro H; rewrite H; reflexivity - | apply f_equal; vm_compute; reflexivity ] - | intros; etransitivity; (* first we strip off the [InputSyntax.Compile] - bit; Coq is bad at inferring the type, so we - help it out by providing it *) - [ cbv [InputSyntax.compilet]; - prove_interp_compile_correct () - | try_tac - ltac:(fun _ - => (* now we unfold the interpretation function, - including the parameterized bits; we assume that - [hnf] is enough to unfold the interpretation - functions that we're parameterized over. *) - clear; - abstract ( - lazymatch goal with - | [ |- appcontext[@InputSyntax.Interp ?base_type_code ?interp_base_type ?op ?interp_op ?t ?e] ] - => let interp_base_type' := (eval hnf in interp_base_type) in - let interp_op' := (eval hnf in interp_op) in - change interp_base_type with interp_base_type'; - change interp_op with interp_op' - end; - cbv iota beta delta [InputSyntax.Interp interp_type interp_type_gen interp_type_gen_hetero interp_flat_type interp interpf]; reflexivity)) ] ] ]. - -Ltac prove_compile_correct_using tac := - fun _ => intros; - lazymatch goal with - | [ |- @Syntax.Interp ?base_type_code ?interp_base_type ?op ?interp_op _ (@Compile _ _ _ ?make_const (InputSyntax.Arrow ?src (Tflat ?dst)) ?e) ?x = _ ] - => apply (fun pf => @InputSyntax.Compile_correct base_type_code interp_base_type op make_const interp_op pf src dst e x); - solve [ tac () ] - | [ |- @Syntax.Interp ?base_type_code ?interp_base_type ?op ?interp_op _ (@Compile _ _ _ ?make_const (Tflat ?T) ?e) ?x = _ ] - => apply (fun pf => @InputSyntax.Compile_flat_correct_flat base_type_code interp_base_type op make_const interp_op pf T e x); - solve [ tac () ] - end. -Ltac prove_compile_correct := - prove_compile_correct_using - ltac:(fun _ => let T := fresh in intro T; destruct T; reflexivity). - -Ltac Reify_rhs base_type_code interp_base_type op make_const interp_op := - Reify_rhs_gen - ltac:(Reify base_type_code interp_base_type op make_const) - prove_compile_correct - interp_op - ltac:(fun tac => tac ()). - -(** Reification of context variables of the form [F := _ : - Syntax.interp_type _ _] *) -Ltac unique_reify_context_variable base_type_code interp_base_type op F Fbody rT := - let reify_pretag := constr:(@exprf base_type_code interp_base_type op) in - lazymatch goal with - | [ H : forall var x not_x, reify _ (F x) |- _ ] - => fail - | _ - => let H' := fresh in - let src := lazymatch rT with Syntax.Arrow ?src ?dst => src end in - lazymatch Fbody with - | fun x : ?X => ?Fbody' - => let maybe_x := fresh x in - let not_x := fresh maybe_x in - let rF := lazymatch constr:(fun var' (x : X) (not_x : var' src) (_ : reify_var_for_in_is base_type_code x src not_x) - => (_ : reify (reify_pretag var') Fbody')) - with - | fun (var' : ?VAR) (x : ?X) (v : ?V) _ => ?C - => constr:(fun (var' : VAR) (v : V) => C) - end in - let F' := fresh F in - pose rF as F'; - pose ((fun var (x : X) => F' var) : forall var (x : X) (not_x : var src), reify (reify_pretag var) (F x)) as H'; - cbv beta in (value of H') - end - end. -Ltac prereify_context_variables interp_base_type := - (** N.B. this assumes that [interp_base_type] is a transparent - definition; minor reorganization may be needed if this is changed - (moving the burden of reifying [interp_base_type T] to - [reify_base_type], rather than keeping it here) *) - cbv beta iota delta [interp_base_type] in *. -Ltac reify_context_variable base_type_code interp_base_type op := - (** [match reverse] so that we respect the chain of dependencies in - context variables; otherwise we're going to be trying the last - context variable many times, and bottlenecking there. *) - match reverse goal with - | [ F := ?Fbody : Syntax.interp_type _ ?rT |- _ ] - => unique_reify_context_variable base_type_code interp_base_type op F Fbody rT - end. -Ltac lazy_reify_context_variable base_type_code interp_base_type op := - lazymatch reverse goal with - | [ F := ?Fbody : Syntax.interp_type _ ?rT |- _ ] - => unique_reify_context_variable base_type_code interp_base_type op F Fbody rT - end. -Ltac reify_context_variables base_type_code interp_base_type op := - prereify_context_variables interp_base_type; - repeat reify_context_variable base_type_code interp_base_type op. diff --git a/src/Reflection/Relations.v b/src/Reflection/Relations.v deleted file mode 100644 index 9a927243d..000000000 --- a/src/Reflection/Relations.v +++ /dev/null @@ -1,368 +0,0 @@ -Require Import Coq.Lists.List Coq.Classes.RelationClasses Coq.Classes.Morphisms. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Util.Tactics.RewriteHyp. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Tactics.SplitInContext. -Require Import Crypto.Util.Prod. -Require Import Crypto.Util.Sigma. - -Local Coercion is_true : bool >-> Sortclass. - -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type}. - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - - Local Ltac rel_relb_t := - repeat first [ progress simpl in * - | reflexivity - | intuition congruence - | setoid_rewrite Bool.andb_true_iff - | intro - | rewrite_hyp <- !* ]. - - Section flat_type. - Context {interp_base_type1 interp_base_type2 : base_type_code -> Type}. - Local Notation interp_flat_type1 := (interp_flat_type interp_base_type1). - Local Notation interp_flat_type2 := (interp_flat_type interp_base_type2). - - Section gen_Prop. - Context (P : Type) - (and : P -> P -> P) - (True : P) - (False : P). - Section pointwise1. - Context (R : forall t, interp_base_type1 t -> P). - Fixpoint interp_flat_type_rel_pointwise1_gen_Prop (t : flat_type) - : interp_flat_type1 t -> P := - match t with - | Tbase t => R t - | Unit => fun _ => True - | Prod A B => fun x : interp_flat_type _ A * interp_flat_type _ B - => and (interp_flat_type_rel_pointwise1_gen_Prop _ (fst x)) - (interp_flat_type_rel_pointwise1_gen_Prop _ (snd x)) - end. - End pointwise1. - Section pointwise2. - Context (R : forall t, interp_base_type1 t -> interp_base_type2 t -> P). - Fixpoint interp_flat_type_rel_pointwise_gen_Prop (t : flat_type) - : interp_flat_type1 t -> interp_flat_type2 t -> P := - match t with - | Tbase t => R t - | Unit => fun _ _ => True - | Prod A B - => fun (x : interp_flat_type _ A * interp_flat_type _ B) - (y : interp_flat_type _ A * interp_flat_type _ B) - => and (interp_flat_type_rel_pointwise_gen_Prop _ (fst x) (fst y)) - (interp_flat_type_rel_pointwise_gen_Prop _ (snd x) (snd y)) - end. - End pointwise2. - Section pointwise2_hetero. - Context (R : forall t1 t2, interp_base_type1 t1 -> interp_base_type2 t2 -> P). - Fixpoint interp_flat_type_rel_pointwise_hetero_gen_Prop (t1 t2 : flat_type) - : interp_flat_type1 t1 -> interp_flat_type2 t2 -> P - := match t1, t2 with - | Tbase t1, Tbase t2 => R t1 t2 - | Unit, Unit => fun _ _ => True - | Prod x1 y1, Prod x2 y2 - => fun (a b : interp_flat_type _ _ * interp_flat_type _ _) - => and (interp_flat_type_rel_pointwise_hetero_gen_Prop x1 x2 (fst a) (fst b)) - (interp_flat_type_rel_pointwise_hetero_gen_Prop y1 y2 (snd a) (snd b)) - | Tbase _, _ - | Unit, _ - | Prod _ _, _ - => fun _ _ => False - end. - End pointwise2_hetero. - End gen_Prop. - - Definition interp_flat_type_relb_pointwise1 - := @interp_flat_type_rel_pointwise1_gen_Prop bool andb true. - Global Arguments interp_flat_type_relb_pointwise1 _ !_ _ / . - Definition interp_flat_type_rel_pointwise1 - := @interp_flat_type_rel_pointwise1_gen_Prop Prop and True. - Global Arguments interp_flat_type_rel_pointwise1 _ !_ _ / . - Lemma interp_flat_type_rel_pointwise1_iff_relb {R} t x - : interp_flat_type_relb_pointwise1 R t x <-> interp_flat_type_rel_pointwise1 R t x. - Proof using Type. clear; induction t; rel_relb_t. Qed. - Definition interp_flat_type_rel_pointwise1_gen_Prop_iff_bool - : forall {R} t x, - interp_flat_type_rel_pointwise1_gen_Prop bool _ _ R t x - <-> interp_flat_type_rel_pointwise1_gen_Prop Prop _ _ R t x - := @interp_flat_type_rel_pointwise1_iff_relb. - Definition interp_flat_type_relb_pointwise - := @interp_flat_type_rel_pointwise_gen_Prop bool andb true. - Global Arguments interp_flat_type_relb_pointwise _ !_ _ _ / . - Definition interp_flat_type_rel_pointwise - := @interp_flat_type_rel_pointwise_gen_Prop Prop and True. - Global Arguments interp_flat_type_rel_pointwise _ !_ _ _ / . - Lemma interp_flat_type_rel_pointwise_iff_relb {R} t x y - : interp_flat_type_relb_pointwise R t x y <-> interp_flat_type_rel_pointwise R t x y. - Proof using Type. clear; induction t; rel_relb_t. Qed. - Definition interp_flat_type_rel_pointwise_gen_Prop_iff_bool - : forall {R} t x y, - interp_flat_type_rel_pointwise_gen_Prop bool _ _ R t x y - <-> interp_flat_type_rel_pointwise_gen_Prop Prop _ _ R t x y - := @interp_flat_type_rel_pointwise_iff_relb. - Definition interp_flat_type_relb_pointwise_hetero - := @interp_flat_type_rel_pointwise_hetero_gen_Prop bool andb true false. - Global Arguments interp_flat_type_relb_pointwise_hetero _ !_ !_ _ _ / . - Definition interp_flat_type_rel_pointwise_hetero - := @interp_flat_type_rel_pointwise_hetero_gen_Prop Prop and True False. - Global Arguments interp_flat_type_rel_pointwise_hetero _ !_ !_ _ _ / . - Lemma interp_flat_type_rel_pointwise_hetero_iff_relb {R} t1 t2 x y - : interp_flat_type_relb_pointwise_hetero R t1 t2 x y <-> interp_flat_type_rel_pointwise_hetero R t1 t2 x y. - Proof using Type. clear; revert dependent t2; induction t1, t2; rel_relb_t. Qed. - Definition interp_flat_type_rel_pointwise_hetero_gen_Prop_iff_bool - : forall {R} t1 t2 x y, - interp_flat_type_rel_pointwise_hetero_gen_Prop bool _ _ _ R t1 t2 x y - <-> interp_flat_type_rel_pointwise_hetero_gen_Prop Prop _ _ _ R t1 t2 x y - := @interp_flat_type_rel_pointwise_hetero_iff_relb. - - Lemma interp_flat_type_rel_pointwise_hetero_iff {R t} x y - : interp_flat_type_rel_pointwise (fun t => R t t) t x y - <-> interp_flat_type_rel_pointwise_hetero R t t x y. - Proof using Type. induction t; simpl; rewrite_hyp ?*; reflexivity. Qed. - - Lemma interp_flat_type_rel_pointwise_impl {R1 R2 : forall t, _ -> _ -> Prop} t x y - : interp_flat_type_rel_pointwise (fun t x y => (R1 t x y -> R2 t x y)%type) t x y - -> (interp_flat_type_rel_pointwise R1 t x y - -> interp_flat_type_rel_pointwise R2 t x y). - Proof using Type. induction t; simpl; intuition. Qed. - - Lemma interp_flat_type_rel_pointwise_always {R : forall t, _ -> _ -> Prop} - : (forall t x y, R t x y) - -> forall t x y, interp_flat_type_rel_pointwise R t x y. - Proof using Type. induction t; simpl; intuition. Qed. - End flat_type. - Section flat_type_extra. - Context {interp_base_type1 interp_base_type2 : base_type_code -> Type}. - Lemma interp_flat_type_rel_pointwise_impl' {R1 R2 : forall t, _ -> _ -> Prop} t x y - : @interp_flat_type_rel_pointwise - interp_base_type1 interp_base_type2 - (fun t x y => (R1 t y x -> R2 t x y)%type) t x y - -> (interp_flat_type_rel_pointwise R1 t y x - -> interp_flat_type_rel_pointwise R2 t x y). - Proof using Type. induction t; simpl; intuition. Qed. - - Global Instance interp_flat_type_rel_pointwise_Reflexive {R : forall t, _ -> _ -> Prop} {H : forall t, Reflexive (R t)} - : forall t, Reflexive (@interp_flat_type_rel_pointwise interp_base_type1 interp_base_type1 R t). - Proof using Type. - induction t; intro; simpl; try apply conj; try reflexivity. - Qed. - - Lemma interp_flat_type_rel_pointwise_SmartVarfMap - {interp_base_type1' interp_base_type2'} - {R : forall t, _ -> _ -> Prop} - t f g x y - : @interp_flat_type_rel_pointwise interp_base_type1 interp_base_type2 R t (SmartVarfMap f x) (SmartVarfMap g y) - <-> @interp_flat_type_rel_pointwise interp_base_type1' interp_base_type2' (fun t x y => R t (f _ x) (g _ y)) t x y. - Proof using Type. - induction t; simpl; try reflexivity. - rewrite_hyp <- !*; reflexivity. - Qed. - End flat_type_extra. - - Section type. - Section hetero. - Context (interp_src1 interp_src2 : flat_type -> Type) - (interp_dst1 interp_dst2 : flat_type -> Type). - Section hetero. - Context (Rsrc : forall t, interp_src1 t -> interp_src2 t -> Prop) - (Rdst : forall t, interp_dst1 t -> interp_dst2 t -> Prop). - - Definition interp_type_gen_rel_pointwise_hetero (t : type) - : interp_type_gen_hetero interp_src1 interp_dst1 t - -> interp_type_gen_hetero interp_src2 interp_dst2 t - -> Prop - := @respectful_hetero _ _ _ _ (Rsrc _) (fun _ _ => Rdst _). - Global Arguments interp_type_gen_rel_pointwise_hetero _ _ _ / . - End hetero. - Section hetero_hetero. - Context (Rsrc : forall t1 t2, interp_src1 t1 -> interp_src2 t2 -> Prop) - (Rdst : forall t1 t2, interp_dst1 t1 -> interp_dst2 t2 -> Prop). - - Fixpoint interp_type_gen_rel_pointwise_hetero_hetero (t1 t2 : type) - : interp_type_gen_hetero interp_src1 interp_dst1 t1 - -> interp_type_gen_hetero interp_src2 interp_dst2 t2 - -> Prop - := @respectful_hetero _ _ _ _ (Rsrc _ _) (fun _ _ => Rdst _ _). - Global Arguments interp_type_gen_rel_pointwise_hetero_hetero _ _ _ _ / . - End hetero_hetero. - End hetero. - - Section partially_hetero. - Context (interp_flat_type1 interp_flat_type2 : flat_type -> Type) - (R : forall t, interp_flat_type1 t -> interp_flat_type2 t -> Prop). - - Definition interp_type_gen_rel_pointwise - : forall t, - interp_type_gen interp_flat_type1 t - -> interp_type_gen interp_flat_type2 t - -> Prop - := interp_type_gen_rel_pointwise_hetero - interp_flat_type1 interp_flat_type2 - interp_flat_type1 interp_flat_type2 - R R. - Global Arguments interp_type_gen_rel_pointwise _ _ _ / . - End partially_hetero. - End type. - - Section specialized_type. - Section hetero. - Context (interp_base_type1 interp_base_type2 : base_type_code -> Type). - Definition interp_type_rel_pointwise R - : forall t, interp_type interp_base_type1 t - -> interp_type interp_base_type2 t - -> Prop - := interp_type_gen_rel_pointwise _ _ (interp_flat_type_rel_pointwise R). - Global Arguments interp_type_rel_pointwise _ !_ _ _ / . - - Definition interp_type_rel_pointwise_hetero R - : forall t1 t2, interp_type interp_base_type1 t1 - -> interp_type interp_base_type2 t2 - -> Prop - := interp_type_gen_rel_pointwise_hetero_hetero _ _ _ _ (interp_flat_type_rel_pointwise_hetero R) (interp_flat_type_rel_pointwise_hetero R). - Global Arguments interp_type_rel_pointwise_hetero _ !_ !_ _ _ / . - End hetero. - End specialized_type. - - Section lifting. - Context {interp_base_type1 interp_base_type2 : base_type_code -> Type}. - Local Notation interp_flat_type1 := (interp_flat_type interp_base_type1). - Local Notation interp_flat_type2 := (interp_flat_type interp_base_type2). - Let Tbase := (@Tbase base_type_code). - Local Coercion Tbase : base_type_code >-> flat_type. - - Section with_rel. - Context (R : forall t, interp_flat_type1 t -> interp_flat_type2 t -> Prop) - (RUnit : R Unit tt tt). - Section RProd. - Context (RProd : forall A B x y, R A (fst x) (fst y) /\ R B (snd x) (snd y) -> R (Prod A B) x y) - (RProd' : forall A B x y, R (Prod A B) x y -> R A (fst x) (fst y) /\ R B (snd x) (snd y)). - Lemma lift_interp_flat_type_rel_pointwise1 t (x : interp_flat_type1 t) (y : interp_flat_type2 t) - : interp_flat_type_rel_pointwise R t x y -> R t x y. - Proof using RProd RUnit. clear RProd'; induction t; simpl; destruct_head_hnf' unit; intuition. Qed. - Lemma lift_interp_flat_type_rel_pointwise2 t (x : interp_flat_type1 t) (y : interp_flat_type2 t) - : R t x y -> interp_flat_type_rel_pointwise R t x y. - Proof using RProd'. clear RProd; induction t; simpl; destruct_head_hnf' unit; split_and; intuition. Qed. - End RProd. - Section RProd_iff. - Context (RProd : forall A B x y, R A (fst x) (fst y) /\ R B (snd x) (snd y) <-> R (Prod A B) x y). - Lemma lift_interp_flat_type_rel_pointwise t (x : interp_flat_type1 t) (y : interp_flat_type2 t) - : interp_flat_type_rel_pointwise R t x y <-> R t x y. - Proof using RProd RUnit. - split_iff; split; auto using lift_interp_flat_type_rel_pointwise1, lift_interp_flat_type_rel_pointwise2. - Qed. - End RProd_iff. - End with_rel. - Lemma lift_interp_flat_type_rel_pointwise_f_eq {T} (f g : forall t, _ -> T t) t x y - : @interp_flat_type_rel_pointwise - interp_base_type1 interp_base_type2 - (fun t x y => f t x = g t y) - t x y - <-> SmartVarfMap f x = SmartVarfMap g y. - Proof using Type. - induction t; unfold SmartVarfMap in *; simpl in *; destruct_head_hnf unit; try tauto. - rewrite_hyp !*; intuition congruence. - Qed. - Lemma lift_interp_flat_type_rel_pointwise_f_eq_id1 (f : forall t, _ -> _) t x y - : @interp_flat_type_rel_pointwise - interp_base_type1 interp_base_type2 - (fun t x y => x = f t y) - t x y - <-> x = SmartVarfMap f y. - Proof using Type. rewrite lift_interp_flat_type_rel_pointwise_f_eq, SmartVarfMap_id; reflexivity. Qed. - Lemma lift_interp_flat_type_rel_pointwise_f_eq_id2 (f : forall t, _ -> _) t x y - : @interp_flat_type_rel_pointwise - interp_base_type1 interp_base_type2 - (fun t x y => f t x = y) - t x y - <-> SmartVarfMap f x = y. - Proof using Type. rewrite lift_interp_flat_type_rel_pointwise_f_eq, SmartVarfMap_id; reflexivity. Qed. - Lemma lift_interp_flat_type_rel_pointwise_f_eq2 {T} (f g : forall t, _ -> _ -> T t) t x y - : @interp_flat_type_rel_pointwise - interp_base_type1 interp_base_type2 - (fun t x y => f t x y = g t x y) - t x y - <-> SmartVarfMap2 f x y = SmartVarfMap2 g x y. - Proof using Type. - induction t; unfold SmartVarfMap2 in *; simpl in *; destruct_head_hnf unit; try tauto. - rewrite_hyp !*; intuition congruence. - Qed. - Lemma lift_interp_type_rel_pointwise_f_eq {T} (f g : forall t, _ -> T t) t x y - : interp_type_rel_pointwise - interp_base_type1 interp_base_type2 - (fun t x y => f t x = g t y) - t x y - <-> (forall a b, SmartVarfMap f a = SmartVarfMap g b -> SmartVarfMap f (x a) = SmartVarfMap g (y b)). - Proof using Type. - destruct t; simpl; unfold interp_type_rel_pointwise, respectful_hetero. - setoid_rewrite lift_interp_flat_type_rel_pointwise_f_eq; reflexivity. - Qed. - Lemma lift_interp_type_rel_pointwise_f_eq_id1 (f : forall t, _ -> _) t x y - : interp_type_rel_pointwise - interp_base_type1 interp_base_type2 - (fun t x y => x = f t y) - t x y - <-> (forall a, x (SmartVarfMap f a) = SmartVarfMap f (y a)). - Proof using Type. rewrite lift_interp_type_rel_pointwise_f_eq; setoid_rewrite SmartVarfMap_id; firstorder (subst; eauto). Qed. - Lemma lift_interp_type_rel_pointwise_f_eq_id2 (f : forall t, _ -> _) t x y - : interp_type_rel_pointwise - interp_base_type1 interp_base_type2 - (fun t x y => f t x = y) - t x y - <-> (forall a, SmartVarfMap f (x a) = y (SmartVarfMap f a)). - Proof using Type. rewrite lift_interp_type_rel_pointwise_f_eq; setoid_rewrite SmartVarfMap_id; firstorder (subst; eauto). Qed. - End lifting. - - Local Ltac t := - repeat match goal with - | _ => intro - | [ H : False |- _ ] => exfalso; assumption - | _ => progress subst - | _ => assumption - | _ => progress inversion_sigma - | _ => progress inversion_prod - | _ => progress simpl in * - | _ => progress destruct_head_hnf' and - | [ H : context[List.In _ (_ ++ _)] |- _ ] - => rewrite List.in_app_iff in H - | _ => progress destruct_head' or - | _ => solve [ eauto ] - end. - - Lemma interp_flat_type_rel_pointwise_flatten_binding_list - {interp_base_type1 interp_base_type2 t T} R' e1 e2 v1 v2 - (H : List.In (existT _ t (v1, v2)%core) (flatten_binding_list e1 e2)) - (HR : @interp_flat_type_rel_pointwise interp_base_type1 interp_base_type2 R' T e1 e2) - : R' t v1 v2. - Proof using Type. induction T; t. Qed. - - Lemma interp_flat_type_rel_pointwise_hetero_flatten_binding_list2 - {interp_base_type1 interp_base_type2 t1 t2 T1 T2} R' e1 e2 v1 v2 - (H : List.In (existT _ (t1, t2)%core (v1, v2)%core) (flatten_binding_list2 e1 e2)) - (HR : @interp_flat_type_rel_pointwise_hetero interp_base_type1 interp_base_type2 R' T1 T2 e1 e2) - : R' t1 t2 v1 v2. - Proof using Type. - revert dependent T2; induction T1, T2; t. - Qed. -End language. - -Global Arguments interp_type_rel_pointwise {_ _ _} R {t} _ _. -Global Arguments interp_type_rel_pointwise_hetero {_ _ _} R {t1 t2} _ _. -Global Arguments interp_type_gen_rel_pointwise_hetero_hetero {_ _ _ _ _} Rsrc Rdst {t1 t2} _ _. -Global Arguments interp_type_gen_rel_pointwise_hetero {_ _ _ _ _} Rsrc Rdst {t} _ _. -Global Arguments interp_type_gen_rel_pointwise {_ _ _} R {t} _ _. -Global Arguments interp_flat_type_rel_pointwise_gen_Prop {_ _ _ P} and True R {t} _ _. -Global Arguments interp_flat_type_rel_pointwise_hetero_gen_Prop {_ _ _ P} and True False R {t1 t2} _ _. -Global Arguments interp_flat_type_rel_pointwise_hetero {_ _ _} R {t1 t2} _ _. -Global Arguments interp_flat_type_relb_pointwise_hetero {_ _ _} R {t1 t2} _ _. -Global Arguments interp_flat_type_rel_pointwise1 {_ _} R {t} _. -Global Arguments interp_flat_type_relb_pointwise1 {_ _} R {t} _. -Global Arguments interp_flat_type_rel_pointwise {_ _ _} R {t} _ _. -Global Arguments interp_flat_type_relb_pointwise {_ _ _} R {t} _ _. diff --git a/src/Reflection/RenameBinders.v b/src/Reflection/RenameBinders.v deleted file mode 100644 index cd40e4366..000000000 --- a/src/Reflection/RenameBinders.v +++ /dev/null @@ -1,78 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.ExprInversion. - -Ltac uncurry_f f := - let t := type of f in - lazymatch eval compute in t with - | prod ?a ?b -> ?R - => uncurry_f (fun x y => f (@pair a b x y)) - | ?a -> ?R - => let x := fresh in - constr:(fun x : a => ltac:(let v := uncurry_f (f x) in exact v)) - | _ => f - end. -Ltac make_destruct_specialize t with_destruct_specialize_tac := - let do_tac T1 T2 n1 mk_n2 := - pose tt as n1; - make_destruct_specialize - T1 - ltac:(fun destruct_specialize_ab - => let n2 := mk_n2 () in - pose tt as n2; - make_destruct_specialize - T2 - ltac:(fun destruct_specialize_cd - => with_destruct_specialize_tac - ltac:(fun arg f cont => - clear n1 n2; - refine (let '(n1, n2)%core := arg in _); - clear arg; - destruct_specialize_ab - n1 f - ltac:(fun f => destruct_specialize_cd n2 f cont)))) in - lazymatch eval compute in t with - | prod (prod ?a ?b) (prod ?c ?d) - => let arg1 := fresh "arg" in - do_tac (prod a b) (prod c d) arg1 ltac:(fun _ => fresh "arg") - | prod (prod ?a ?b) ?c - => let arg1 := fresh "arg" in - do_tac (prod a b) c arg1 ltac:(fun _ => fresh "x") - | prod ?a (prod ?c ?d) - => let arg1 := fresh "x" in - do_tac a (prod c d) arg1 ltac:(fun _ => fresh "arg") - | prod ?a ?b - => let arg1 := fresh "x" in - do_tac a b arg1 ltac:(fun _ => fresh "x") - | _ - => with_destruct_specialize_tac ltac:(fun arg f cont => cont (f arg)) - end. -Ltac renamify input := - let t := type of input in - let t := (eval compute in t) in - let ret := - constr:(ltac:( - let var := fresh "var" in - intro var; - let input := constr:(input var) in - let input := (eval compute in input) in - let arg := fresh "arg" in - refine (Abs (fun arg => _)); - let input := constr:(invert_Abs input) in - let t := type of arg in - let t := (eval compute in t) in - let input := uncurry_f input in - let input := (eval cbv iota beta delta [invert_Abs] in input) in - make_destruct_specialize - t ltac:(fun do_destruct_specialize - => do_destruct_specialize - arg input - ltac:(fun input => let input := (eval cbv beta in input) in - exact input)) - ) : t) in - (eval cbv beta zeta in ret). -Notation renamify f := - (let t := _ in - let renamify_F0 : t := f in - ((fun renamify_F : t => ltac:(let v := renamify renamify_F in exact v)) - renamify_F0)) - (only parsing). diff --git a/src/Reflection/Rewriter.v b/src/Reflection/Rewriter.v deleted file mode 100644 index b53d0903d..000000000 --- a/src/Reflection/Rewriter.v +++ /dev/null @@ -1,39 +0,0 @@ -Require Import Crypto.Reflection.Syntax. - -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type}. - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation exprf := (@exprf base_type_code op). - Local Notation expr := (@expr base_type_code op). - Local Notation Expr := (@Expr base_type_code op). - - Section with_var. - Context {var : base_type_code -> Type}. - Context (rewrite_op_expr : forall src dst (opc : op src dst), - exprf (var:=var) src -> exprf (var:=var) dst). - - Fixpoint rewrite_opf {t} (e : @exprf var t) : @exprf var t - := match e in Syntax.exprf _ _ t return @exprf var t with - | LetIn tx ex tC eC - => LetIn (@rewrite_opf tx ex) (fun x => @rewrite_opf tC (eC x)) - | Var _ x => Var x - | TT => TT - | Pair tx ex ty ey - => Pair (@rewrite_opf tx ex) (@rewrite_opf ty ey) - | Op t1 tR opc args => rewrite_op_expr _ _ opc (@rewrite_opf t1 args) - end. - - Definition rewrite_op {t} (e : @expr var t) : @expr var t - := match e in Syntax.expr _ _ t return @expr var t with - | Abs _ _ f => Abs (fun x => rewrite_opf (f x)) - end. - End with_var. - - Definition RewriteOp - (rewrite_op_expr : forall var src dst, op src dst -> @exprf var src -> @exprf var dst) - {t} (e : Expr t) - : Expr t - := fun var => rewrite_op (rewrite_op_expr _) (e _). -End language. diff --git a/src/Reflection/RewriterInterp.v b/src/Reflection/RewriterInterp.v deleted file mode 100644 index 4a18c0a47..000000000 --- a/src/Reflection/RewriterInterp.v +++ /dev/null @@ -1,50 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Rewriter. -Require Import Crypto.Util.Tactics.RewriteHyp. - -Section language. - Context {base_type_code : Type} - {interp_base_type : base_type_code -> Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - {interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst}. - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation interp_type := (interp_type interp_base_type). - Local Notation interp_flat_type := (interp_flat_type interp_base_type). - Local Notation exprf := (@exprf base_type_code op interp_base_type). - Local Notation expr := (@expr base_type_code op interp_base_type). - Local Notation Expr := (@Expr base_type_code op). - - Section specialized. - Context {rewrite_op_expr : forall src dst (opc : op src dst), exprf src -> exprf dst} - (Hrewrite : forall src dst opc args, - interpf interp_op (rewrite_op_expr src dst opc args) - = interp_op _ _ opc (interpf interp_op args)). - - Lemma interpf_rewrite_opf {t} (e : exprf t) - : interpf interp_op (rewrite_opf rewrite_op_expr e) = interpf interp_op e. - Proof using Type*. - induction e; simpl; unfold LetIn.Let_In; rewrite_hyp ?*; reflexivity. - Qed. - - Lemma interp_rewrite_op {t} (e : expr t) - : forall x, interp interp_op (rewrite_op rewrite_op_expr e) x = interp interp_op e x. - Proof using Type*. - destruct e; intro x; apply interpf_rewrite_opf. - Qed. - End specialized. - - Lemma InterpRewriteOp - {rewrite_op_expr} - (Hrewrite : forall src dst opc args, - interpf interp_op (rewrite_op_expr interp_base_type src dst opc args) - = interp_op _ _ opc (interpf interp_op args)) - {t} (e : Expr t) - : forall x, Interp interp_op (RewriteOp rewrite_op_expr e) x = Interp interp_op e x. - Proof using Type. - apply interp_rewrite_op; assumption. - Qed. -End language. - -Hint Rewrite @InterpRewriteOp using assumption : reflective_interp. diff --git a/src/Reflection/RewriterWf.v b/src/Reflection/RewriterWf.v deleted file mode 100644 index a7ac86851..000000000 --- a/src/Reflection/RewriterWf.v +++ /dev/null @@ -1,61 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.WfInversion. -Require Import Crypto.Reflection.Rewriter. - -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type}. - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation wff := (@wff base_type_code op). - Local Notation wf := (@wf base_type_code op). - Local Notation Wf := (@Wf base_type_code op). - Local Notation exprf := (@exprf base_type_code op). - Local Notation expr := (@expr base_type_code op). - Local Notation Expr := (@Expr base_type_code op). - - Section with_var. - Context {var1 var2 : base_type_code -> Type} - {rewrite_op_expr1 : forall src dst (opc : op src dst), - exprf (var:=var1) src -> exprf (var:=var1) dst} - {rewrite_op_expr2 : forall src dst (opc : op src dst), - exprf (var:=var2) src -> exprf (var:=var2) dst} - (Hrewrite_wf : forall G src dst opc args1 args2, - wff G args1 args2 - -> wff G - (rewrite_op_expr1 src dst opc args1) - (rewrite_op_expr2 src dst opc args2)). - - Lemma wff_rewrite_opf {t} G (e1 : @exprf var1 t) (e2 : @exprf var2 t) - (Hwf : wff G e1 e2) - : wff G (rewrite_opf rewrite_op_expr1 e1) (rewrite_opf rewrite_op_expr2 e2). - Proof using Type*. - induction Hwf; simpl; try constructor; auto. - Qed. - - Lemma wf_rewrite_opf {t} (e1 : @expr var1 t) (e2 : @expr var2 t) - (Hwf : wf e1 e2) - : wf (rewrite_op rewrite_op_expr1 e1) (rewrite_op rewrite_op_expr2 e2). - Proof using Type*. - destruct Hwf; simpl; constructor; intros; apply wff_rewrite_opf; auto. - Qed. - End with_var. - - Lemma Wf_RewriteOp - {rewrite_op_expr} - (Hrewrite_wff : forall var1 var2 G src dst opc args1 args2, - wff G args1 args2 - -> wff G - (rewrite_op_expr var1 src dst opc args1) - (rewrite_op_expr var2 src dst opc args2)) - {t} (e : Expr t) - (Hwf : Wf e) - : Wf (RewriteOp rewrite_op_expr e). - Proof using Type. - intros var1 var2; apply wf_rewrite_opf; auto. - Qed. -End language. - -Hint Resolve Wf_RewriteOp : wf. diff --git a/src/Reflection/SmartBound.v b/src/Reflection/SmartBound.v deleted file mode 100644 index 56014c7b6..000000000 --- a/src/Reflection/SmartBound.v +++ /dev/null @@ -1,135 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.ExprInversion. -Require Import Crypto.Reflection.TypeUtil. -Require Import Crypto.Reflection.SmartCast. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Util.Notations. - -Local Open Scope expr_scope. -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - (interp_base_type_bounds : base_type_code -> Type) - (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst) - (bound_base_type : forall t, interp_base_type_bounds t -> base_type_code) - (base_type_beq : base_type_code -> base_type_code -> bool) - (base_type_bl_transparent : forall x y, base_type_beq x y = true -> x = y) - (base_type_leb : base_type_code -> base_type_code -> bool) - (Cast : forall var A A', exprf base_type_code op (var:=var) (Tbase A) -> exprf base_type_code op (var:=var) (Tbase A')) - (genericize_op : forall src dst (opc : op src dst) (new_bounded_type_in new_bounded_type_out : base_type_code), - option { src'dst' : _ & op (fst src'dst') (snd src'dst') }) - (failf : forall var t, @exprf base_type_code op var (Tbase t)). - Local Infix "<=?" := base_type_leb : expr_scope. - Local Infix "=?" := base_type_beq : expr_scope. - - Local Notation flat_type_max := (flat_type_max base_type_leb). - Local Notation SmartCast := (@SmartCast _ op _ base_type_bl_transparent Cast). - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation exprf := (@exprf base_type_code op). - Local Notation expr := (@expr base_type_code op). - Local Notation Expr := (@Expr base_type_code op). - - Definition bound_flat_type {t} : interp_flat_type interp_base_type_bounds t - -> flat_type - := @SmartFlatTypeMap _ interp_base_type_bounds (fun t v => bound_base_type t v) t. - Definition bound_type {t} - (e_bounds : interp_type interp_base_type_bounds t) - (input_bounds : interp_flat_type interp_base_type_bounds (domain t)) - : type - := Arrow (@bound_flat_type (domain t) input_bounds) - (@bound_flat_type (codomain t) (e_bounds input_bounds)). - Definition bound_op - ovar src1 dst1 src2 dst2 (opc1 : op src1 dst1) (opc2 : op src2 dst2) - : exprf (var:=ovar) src1 - -> interp_flat_type interp_base_type_bounds src2 - -> exprf (var:=ovar) dst1 - := fun args input_bounds - => let output_bounds := interp_op_bounds _ _ opc2 input_bounds in - let input_ts := SmartVarfMap bound_base_type input_bounds in - let output_ts := SmartVarfMap bound_base_type output_bounds in - let new_type_in := flat_type_max input_ts in - let new_type_out := flat_type_max output_ts in - let new_opc := match new_type_in, new_type_out with - | Some new_type_in, Some new_type_out - => genericize_op _ _ opc1 new_type_in new_type_out - | None, _ | _, None => None - end in - match new_opc with - | Some (existT _ new_opc) - => match SmartCast _ _, SmartCast _ _ with - | Some SmartCast_args, Some SmartCast_result - => LetIn args - (fun args - => LetIn (Op new_opc (SmartCast_args args)) - (fun opv => SmartCast_result opv)) - | None, _ - | _, None - => Op opc1 args - end - | None - => Op opc1 args - end. - - Section smart_bound. - Definition interpf_smart_bound_exprf {var t} - (e : interp_flat_type var t) (bounds : interp_flat_type interp_base_type_bounds t) - : interp_flat_type (fun t => exprf (var:=var) (Tbase t)) (bound_flat_type bounds) - := SmartFlatTypeMap2Interp2 - (f:=fun t v => Tbase _) - (fun t bs v => Cast _ t (bound_base_type t bs) (Var v)) - bounds e. - Definition interpf_smart_unbound_exprf {var t} - (bounds : interp_flat_type interp_base_type_bounds t) - (e : interp_flat_type (fun t => exprf (var:=var) (Tbase t)) (bound_flat_type bounds)) - : interp_flat_type (fun t => @exprf var (Tbase t)) t - := SmartFlatTypeMapUnInterp2 - (f:=fun t v => Tbase (bound_base_type t _)) - (fun t bs v => Cast _ (bound_base_type t bs) t v) - e. - - Definition interpf_smart_bound - {interp_base_type} - (cast_val : forall A A', interp_base_type A -> interp_base_type A') - {t} - (e : interp_flat_type interp_base_type t) - (bounds : interp_flat_type interp_base_type_bounds t) - : interp_flat_type interp_base_type (bound_flat_type bounds) - := SmartFlatTypeMap2Interp2 - (f:=fun t v => Tbase _) - (fun t bs v => cast_val t (bound_base_type t bs) v) - bounds e. - Definition interpf_smart_unbound - {interp_base_type} - (cast_val : forall A A', interp_base_type A -> interp_base_type A') - {t} - (bounds : interp_flat_type interp_base_type_bounds t) - (e : interp_flat_type interp_base_type (bound_flat_type bounds)) - : interp_flat_type interp_base_type t - := SmartFlatTypeMapUnInterp2 (f:=fun _ _ => Tbase _) (fun t b v => cast_val _ _ v) e. - - Definition smart_boundf {var t1} (e1 : exprf (var:=var) t1) (bounds : interp_flat_type interp_base_type_bounds t1) - : exprf (var:=var) (bound_flat_type bounds) - := LetIn e1 (fun e1' => SmartPairf (var:=var) (interpf_smart_bound_exprf e1' bounds)). - Definition smart_bound {var t1} (e1 : expr (var:=var) t1) - (e_bounds : interp_type interp_base_type_bounds t1) - (input_bounds : interp_flat_type interp_base_type_bounds (domain t1)) - : expr (var:=var) (bound_type e_bounds input_bounds) - := Abs - (fun args - => LetIn - (SmartPairf (interpf_smart_unbound_exprf input_bounds (SmartVarfMap (fun _ => Var) args))) - (fun v => smart_boundf - (invert_Abs e1 v) - (e_bounds input_bounds))). - Definition SmartBound {t1} (e : Expr t1) - (input_bounds : interp_flat_type interp_base_type_bounds (domain t1)) - : Expr (bound_type _ input_bounds) - := fun var => smart_bound (e var) (interp (@interp_op_bounds) (e _)) input_bounds. - End smart_bound. -End language. - -Global Arguments bound_flat_type _ _ _ !_ _ / . -Global Arguments bound_type _ _ _ !_ _ _ / . diff --git a/src/Reflection/SmartBoundInterp.v b/src/Reflection/SmartBoundInterp.v deleted file mode 100644 index 0262ef615..000000000 --- a/src/Reflection/SmartBoundInterp.v +++ /dev/null @@ -1,144 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.InterpWfRel. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Reflection.SmartMap. -(*Require Import Crypto.Reflection.TypeUtil. -Require Import Crypto.Reflection.BoundByCast.*) -Require Import Crypto.Reflection.SmartBound. -Require Import Crypto.Reflection.ExprInversion. -(*Require Import Crypto.Reflection.SmartBoundWf. -Require Import Crypto.Reflection.InlineCastInterp. -Require Import Crypto.Reflection.InlineInterp. -Require Import Crypto.Reflection.LinearizeInterp. -Require Import Crypto.Reflection.LinearizeWf. -Require Import Crypto.Reflection.MapCastInterp. -Require Import Crypto.Reflection.MapCastWf. -Require Import Crypto.Reflection.EtaInterp.*) -Require Import Crypto.Util.Tactics.DestructHead. - -Local Open Scope expr_scope. -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - (interp_base_type interp_base_type_bounds : base_type_code -> Type) - (interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst) - (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst) - (bound_base_type : forall t, interp_base_type_bounds t -> base_type_code) - (base_type_beq : base_type_code -> base_type_code -> bool) - (base_type_bl_transparent : forall x y, base_type_beq x y = true -> x = y) - (base_type_leb : base_type_code -> base_type_code -> bool) - (Cast : forall var A A', exprf base_type_code op (var:=var) (Tbase A) -> exprf base_type_code op (var:=var) (Tbase A')) - (cast_val : forall A A', interp_base_type A -> interp_base_type A') - (genericize_op : forall src dst (opc : op src dst) (new_bounded_type_in new_bounded_type_out : base_type_code), - option { src'dst' : _ & op (fst src'dst') (snd src'dst') }) - (failf : forall var t, @exprf base_type_code op var (Tbase t)) - (is_bounded_by_base : forall t, interp_base_type t -> interp_base_type_bounds t -> Prop) - (interpf_cast : forall A A' e, interpf interp_op (Cast _ A A' e) = cast_val A A' (interpf interp_op e)) - (strip_cast_val - : forall t x y, - is_bounded_by_base t y x -> - cast_val (bound_base_type t x) t (cast_val t (bound_base_type t x) y) = y). -(* - (wff_Cast : forall var1 var2 G A A' e1 e2, - wff G e1 e2 -> wff G (Cast var1 A A' e1) (Cast var2 A A' e2)).*) - - Local Notation is_bounded_by (*{T} : interp_flat_type interp_base_type T -> interp_flat_type interp_base_type_bounds T -> Prop*) - := (interp_flat_type_rel_pointwise is_bounded_by_base). - Context (is_bounded_by_interp_op - : forall src dst opc sv1 sv2, - is_bounded_by sv1 sv2 -> - is_bounded_by (interp_op src dst opc sv1) (interp_op_bounds src dst opc sv2)). - Local Notation Expr := (@Expr base_type_code op). - Local Notation expr := (@expr base_type_code op). - Local Notation exprf := (@exprf base_type_code op). - Local Notation SmartBound := (@SmartBound _ _ _ interp_op_bounds bound_base_type Cast). - Local Notation smart_bound := (@smart_bound _ _ interp_base_type_bounds bound_base_type Cast). - Local Notation interpf_smart_bound := (@interpf_smart_bound _ interp_base_type_bounds bound_base_type interp_base_type cast_val). - Local Notation interpf_smart_unbound := (@interpf_smart_unbound _ interp_base_type_bounds bound_base_type interp_base_type cast_val). - Local Notation interpf_smart_bound_exprf := (@interpf_smart_bound_exprf _ op interp_base_type_bounds bound_base_type Cast). - Local Notation interpf_smart_unbound_exprf := (@interpf_smart_unbound_exprf _ op interp_base_type_bounds bound_base_type Cast). - Local Notation bound_op := (@bound_op _ _ _ interp_op_bounds bound_base_type _ base_type_bl_transparent base_type_leb Cast genericize_op). - - Local Ltac t := - unfold SmartPairf, SmartBound.interpf_smart_bound, SmartBound.interpf_smart_bound_exprf; - repeat first [ reflexivity - | progress destruct_head' unit - | progress simpl in * - | rewrite !interpf_cast - | match goal with H : _ |- _ => setoid_rewrite H end ]. - Lemma interpf_SmartPairf_interpf_smart_bound_exprf - {t} e bounds - : interpf interp_op (SmartPairf (interpf_smart_bound_exprf (t:=t) e bounds)) - = interpf_smart_bound e bounds. - Proof using interpf_cast. clear -interpf_cast; induction t; t. Qed. - - Lemma interpf_SmartPairf_interpf_smart_unbound_exprf - {t} bounds e - : interpf interp_op (SmartPairf (interpf_smart_unbound_exprf (t:=t) bounds e)) - = interpf_smart_unbound bounds (SmartVarfMap (fun _ e => interpf interp_op e) e). - Proof using interpf_cast. clear -interpf_cast; induction t; t. Qed. - - Lemma interp_smart_bound_and_rel {t} - (e : expr t) (ebounds : expr t) - (Hwf : wf e ebounds) - (input_bounds : interp_flat_type interp_base_type_bounds (domain t)) - (output_bounds := interp interp_op_bounds ebounds input_bounds) - (e' := smart_bound e (interp interp_op_bounds ebounds) input_bounds) - : forall x, - is_bounded_by (interpf_smart_unbound input_bounds x) input_bounds - -> is_bounded_by (interp interp_op e (interpf_smart_unbound input_bounds x)) output_bounds - /\ interpf_smart_unbound _ (interp interp_op e' x) - = interp interp_op e (interpf_smart_unbound input_bounds x). - Proof using interpf_cast is_bounded_by_interp_op strip_cast_val. - intros; subst e' output_bounds. - match goal with |- ?A /\ ?B => cut (A /\ (A -> B)); [ tauto | ] end. - split. - { apply interp_wf; auto. } - { intro Hbounded_out. - unfold smart_bound; simpl. - cbv [LetIn.Let_In]. - rewrite interpf_invert_Abs, interpf_SmartPairf_interpf_smart_bound_exprf, interpf_SmartPairf_interpf_smart_unbound_exprf, SmartVarfMap_compose; simpl. - rewrite SmartVarfMap_id. - setoid_rewrite SmartFlatTypeMapUnInterp2_SmartFlatTypeMap2Interp2. - etransitivity; [ | eapply SmartVarfMap2_snd_arg ]. - apply lift_interp_flat_type_rel_pointwise_f_eq2. - eauto using interp_flat_type_rel_pointwise_impl', interp_flat_type_rel_pointwise_always. } - Qed. - - Lemma InterpSmartBoundAndRel {t} - (e : Expr t) - (Hwf : Wf e) - (input_bounds : interp_flat_type interp_base_type_bounds (domain t)) - (output_bounds := Interp interp_op_bounds e input_bounds) - (e' := SmartBound e input_bounds) - (*(Hgood : bounds_are_recursively_good - (@interp_op_bounds) bound_is_good - (invert_Abs (e _) input_bounds))*) - : forall x, - is_bounded_by (interpf_smart_unbound input_bounds x) input_bounds - -> is_bounded_by (Interp interp_op e (interpf_smart_unbound input_bounds x)) output_bounds - /\ interpf_smart_unbound _ (Interp interp_op e' x) - = Interp interp_op e (interpf_smart_unbound input_bounds x). - Proof using interpf_cast is_bounded_by_interp_op strip_cast_val. - apply interp_smart_bound_and_rel; auto. - Qed. - - Lemma InterpSmartBound {t} - (e : Expr t) - (Hwf : Wf e) - (input_bounds : interp_flat_type interp_base_type_bounds (domain t)) - (output_bounds := Interp interp_op_bounds e input_bounds) - (e' := SmartBound e input_bounds) - (*(Hgood : bounds_are_recursively_good - (@interp_op_bounds) bound_is_good - (invert_Abs (e _) input_bounds))*) - : forall x, - is_bounded_by (interpf_smart_unbound input_bounds x) input_bounds - -> interpf_smart_unbound _ (Interp interp_op e' x) - = Interp interp_op e (interpf_smart_unbound input_bounds x). - Proof using interpf_cast is_bounded_by_interp_op strip_cast_val. - intros; eapply InterpSmartBoundAndRel; auto. - Qed. -End language. diff --git a/src/Reflection/SmartBoundWf.v b/src/Reflection/SmartBoundWf.v deleted file mode 100644 index 72c5c1475..000000000 --- a/src/Reflection/SmartBoundWf.v +++ /dev/null @@ -1,140 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.TypeInversion. -Require Import Crypto.Reflection.ExprInversion. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.WfProofs. -Require Import Crypto.Reflection.SmartBound. -Require Import Crypto.Reflection.TypeUtil. -Require Import Crypto.Reflection.SmartCastWf. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Notations. - -Local Open Scope expr_scope. -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - (interp_base_type_bounds : base_type_code -> Type) - (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst) - (bound_base_type : forall t, interp_base_type_bounds t -> base_type_code) - (base_type_beq : base_type_code -> base_type_code -> bool) - (base_type_bl_transparent : forall x y, base_type_beq x y = true -> x = y) - (base_type_leb : base_type_code -> base_type_code -> bool) - (Cast : forall var A A', exprf base_type_code op (var:=var) (Tbase A) -> exprf base_type_code op (var:=var) (Tbase A')) - (genericize_op : forall src dst (opc : op src dst) (new_bounded_type_in new_bounded_type_out : base_type_code), - option { src'dst' : _ & op (fst src'dst') (snd src'dst') }) - (failf : forall var t, @exprf base_type_code op var (Tbase t)) - (wff_Cast : forall var1 var2 G A A' e1 e2, - wff G e1 e2 -> wff G (Cast var1 A A' e1) (Cast var2 A A' e2)). - - Local Notation Expr := (@Expr base_type_code op). - Local Notation SmartBound := (@SmartBound _ _ _ interp_op_bounds bound_base_type Cast). - Local Notation smart_bound := (@smart_bound _ _ interp_base_type_bounds bound_base_type Cast). - Local Notation interpf_smart_bound_exprf := (@interpf_smart_bound_exprf _ op interp_base_type_bounds bound_base_type Cast). - Local Notation interpf_smart_unbound_exprf := (@interpf_smart_unbound_exprf _ op interp_base_type_bounds bound_base_type Cast). - Local Notation bound_op := (@bound_op _ _ _ interp_op_bounds bound_base_type _ base_type_bl_transparent base_type_leb Cast genericize_op). - Local Notation wff_SmartCast_match := (@wff_SmartCast_match _ op _ base_type_bl_transparent Cast wff_Cast). - - Local Hint Resolve List.in_or_app wff_in_impl_Proper. - - Lemma wff_bound_op - ovar1 ovar2 G src1 dst1 src2 dst2 opc1 opc2 e1 e2 args2 - (Hwf : wff G (var1:=ovar1) (var2:=ovar2) e1 e2) - : wff G - (@bound_op ovar1 src1 dst1 src2 dst2 opc1 opc2 e1 args2) - (@bound_op ovar2 src1 dst1 src2 dst2 opc1 opc2 e2 args2). - Proof using wff_Cast. - unfold SmartBound.bound_op; - repeat first [ progress break_innermost_match - | assumption - | constructor - | intro - | eapply wff_in_impl_Proper; [ eapply wff_SmartCast; eassumption | ] - | match goal with - | [ H0 : SmartCast.SmartCast _ _ _ ?x ?y = Some _, H1 : SmartCast.SmartCast _ _ _ ?x ?y = None |- _ ] - => let H := fresh in - refine (let H := wff_SmartCast_match x y in _); - erewrite H0, H1 in H; exfalso; exact H - end - | solve [ auto ] ]. - Qed. - - Local Hint Resolve List.in_app_or List.in_or_app. - - Lemma wff_SmartPairf_interpf_smart_unbound_exprf var1 var2 t input_bounds x1 x2 - : wff (flatten_binding_list x1 x2) - (SmartPairf - (var:=var1) - (interpf_smart_unbound_exprf input_bounds - (SmartVarfMap (fun t => Var) x1))) - (SmartPairf - (var:=var2) - (t:=t) - (interpf_smart_unbound_exprf input_bounds - (SmartVarfMap (fun t => Var) x2))). - Proof using wff_Cast. - clear -wff_Cast. - unfold SmartPairf, SmartVarfMap, interpf_smart_unbound_exprf; induction t; - repeat match goal with - | _ => progress simpl in * - | [ |- wff _ (Cast _ _ _ _) (Cast _ _ _ _) ] - => apply wff_Cast - | [ |- wff _ _ _ ] - => constructor - | _ => solve [ auto with wf ] - | _ => eapply wff_in_impl_Proper; [ solve [ eauto ] | ] - | _ => intro - end. - Qed. - - Local Hint Resolve wff_SmartPairf_interpf_smart_unbound_exprf : wf. - - Lemma wff_SmartPairf_interpf_smart_bound_exprf var1 var2 t x1 x2 output_bounds - : wff (flatten_binding_list x1 x2) - (SmartPairf - (var:=var1) - (interpf_smart_bound_exprf (t:=t) x1 output_bounds)) - (SmartPairf - (var:=var2) - (interpf_smart_bound_exprf x2 output_bounds)). - Proof using wff_Cast. - clear -wff_Cast. - unfold SmartPairf, SmartVarfMap, interpf_smart_bound_exprf; induction t; - repeat match goal with - | _ => progress simpl in * - | [ |- wff _ (Cast _ _ _ _) (Cast _ _ _ _) ] - => apply wff_Cast - | [ |- wff _ _ _ ] - => constructor - | _ => solve [ auto with wf ] - | _ => eapply wff_in_impl_Proper; [ solve [ eauto ] | ] - | _ => intro - end. - Qed. - - Local Hint Resolve wff_SmartPairf_interpf_smart_bound_exprf : wf. - - Lemma wf_smart_bound {var1 var2 t1} e1 e2 e_bounds input_bounds - (Hwf : wf e1 e2) - : wf (@smart_bound var1 t1 e1 e_bounds input_bounds) - (@smart_bound var2 t1 e2 e_bounds input_bounds). - Proof using wff_Cast. - clear -wff_Cast Hwf. - destruct Hwf; unfold SmartBound.smart_bound. - repeat constructor; auto with wf; intros; - try (eapply wff_in_impl_Proper; [ solve [ eauto with wf ] | ]); - auto. - Qed. - - Lemma Wf_SmartBound {t1} e input_bounds - (Hwf : Wf e) - : Wf (@SmartBound t1 e input_bounds). - Proof using wff_Cast. - intros var1 var2; specialize (Hwf var1 var2). - unfold SmartBound.SmartBound. - apply wf_smart_bound; assumption. - Qed. -End language. - -Hint Resolve Wf_SmartBound wff_bound_op : wf. diff --git a/src/Reflection/SmartCast.v b/src/Reflection/SmartCast.v deleted file mode 100644 index ee3712954..000000000 --- a/src/Reflection/SmartCast.v +++ /dev/null @@ -1,41 +0,0 @@ -Require Import Coq.Bool.Sumbool. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.TypeUtil. -Require Import Crypto.Util.Notations. - -Local Open Scope expr_scope. -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - (base_type_beq : base_type_code -> base_type_code -> bool) - (base_type_bl_transparent : forall x y, base_type_beq x y = true -> x = y) - (Cast : forall var A A', exprf base_type_code op (var:=var) (Tbase A) -> exprf base_type_code op (var:=var) (Tbase A')). - - Local Notation exprf := (@exprf base_type_code op). - - Definition SmartCast_base {var A A'} (x : exprf (var:=var) (Tbase A)) - : exprf (var:=var) (Tbase A') - := match sumbool_of_bool (base_type_beq A A') with - | left pf => match base_type_bl_transparent _ _ pf with - | eq_refl => x - end - | right _ => Cast _ _ A' x - end. - - Fixpoint SmartCast {var} A B - : option (interp_flat_type var A -> exprf (var:=var) B) - := match A, B return option (interp_flat_type var A -> exprf (var:=var) B) with - | Tbase A, Tbase B => Some (fun v => SmartCast_base (Var (var:=var) v)) - | Prod A0 A1, Prod B0 B1 - => match @SmartCast _ A0 B0, @SmartCast _ A1 B1 with - | Some f, Some g => Some (fun xy => Pair (f (fst xy)) (g (snd xy))) - | _, _ => None - end - | Unit, Unit => Some (fun _ => TT) - | Tbase _, _ - | Prod _ _, _ - | Unit, _ - => None - end. -End language. diff --git a/src/Reflection/SmartCastInterp.v b/src/Reflection/SmartCastInterp.v deleted file mode 100644 index 92ca265e1..000000000 --- a/src/Reflection/SmartCastInterp.v +++ /dev/null @@ -1,37 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.TypeUtil. -Require Import Crypto.Reflection.SmartCast. -Require Import Crypto.Util.Notations. - -Local Open Scope expr_scope. -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - {interp_base_type : base_type_code -> Type} - {interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst} - {base_type_beq : base_type_code -> base_type_code -> bool} - {base_type_bl_transparent : forall x y, base_type_beq x y = true -> x = y} - {Cast : forall var A A', exprf base_type_code op (var:=var) (Tbase A) -> exprf base_type_code op (var:=var) (Tbase A')} - (interpf_Cast_id : forall A x, interpf interp_op (Cast _ A A x) = interpf interp_op x) - {cast_val : forall A A', interp_base_type A -> interp_base_type A'} - (interpf_cast : forall A A' e, interpf interp_op (Cast _ A A' e) = cast_val A A' (interpf interp_op e)). - - Local Notation exprf := (@exprf base_type_code op). - Local Notation SmartCast_base := (@SmartCast_base _ _ _ base_type_bl_transparent Cast). - Local Notation SmartCast := (@SmartCast _ _ _ base_type_bl_transparent Cast). - - Lemma interpf_SmartCast_base {A A'} (x : exprf (Tbase A)) - : interpf interp_op (SmartCast_base x) = interpf interp_op (Cast _ A A' x). - Proof using interpf_Cast_id. - clear dependent cast_val. - unfold SmartCast_base. - destruct (Sumbool.sumbool_of_bool (base_type_beq A A')) as [H|H]. - { destruct (base_type_bl_transparent A A' H). - rewrite interpf_Cast_id; reflexivity. } - { reflexivity. } - Qed. -End language. - -Hint Rewrite @interpf_SmartCast_base using solve [ eassumption | eauto ] : reflective_interp. diff --git a/src/Reflection/SmartCastWf.v b/src/Reflection/SmartCastWf.v deleted file mode 100644 index 4c5601669..000000000 --- a/src/Reflection/SmartCastWf.v +++ /dev/null @@ -1,84 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.WfProofs. -Require Import Crypto.Reflection.TypeUtil. -Require Import Crypto.Reflection.SmartCast. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Notations. - -Local Open Scope expr_scope. -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - {interp_base_type : base_type_code -> Type} - {interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst} - (base_type_beq : base_type_code -> base_type_code -> bool) - (base_type_bl_transparent : forall x y, base_type_beq x y = true -> x = y) - (Cast : forall var A A', exprf base_type_code op (var:=var) (Tbase A) -> exprf base_type_code op (var:=var) (Tbase A')) - (wff_Cast : forall var1 var2 G A A' e1 e2, - wff G e1 e2 -> wff G (Cast var1 A A' e1) (Cast var2 A A' e2)). - - Local Notation exprf := (@exprf base_type_code op). - Local Notation SmartCast_base := (@SmartCast_base _ _ _ base_type_bl_transparent Cast). - Local Notation SmartCast := (@SmartCast _ _ _ base_type_bl_transparent Cast). - - Lemma wff_SmartCast_base {var1 var2 A A'} G e1 e2 - (Hwf : wff (var1:=var1) (var2:=var2) G (t:=Tbase A) e1 e2) - : wff G (t:=Tbase A') (SmartCast_base e1) (SmartCast_base e2). - Proof using wff_Cast. - unfold SmartCast_base; destruct (Sumbool.sumbool_of_bool (base_type_beq A A')) as [H|H]. - { destruct (base_type_bl_transparent A A' H); assumption. } - { auto. } - Qed. - - Local Hint Resolve List.in_or_app wff_in_impl_Proper. - Local Hint Extern 1 => progress simpl. - - Lemma wff_SmartCast_match {var1 var2} A B - : match SmartCast A B, SmartCast A B with - | Some f1, Some f2 - => forall e1 e2, - wff (var1:=var1) (var2:=var2) (flatten_binding_list e1 e2) (f1 e1) (f2 e2) - | None, None => True - | Some _, None | None, Some _ => False - end. - Proof using wff_Cast. - break_innermost_match; revert dependent B; induction A, B; - repeat match goal with - | _ => progress simpl in * - | _ => intro - | _ => progress subst - | _ => progress inversion_option - | [ |- wff _ (SmartCast_base _) (SmartCast_base _) ] - => apply wff_SmartCast_base - | _ => progress break_match_hyps - | _ => solve [ eauto with wf ] - | [ H : forall B f1 f2, SmartCast ?A B = Some f1 -> SmartCast ?A B = Some f2 -> _, - H' : SmartCast ?A ?Bv = Some _, H'' : SmartCast ?A ?Bv = Some _ |- _ ] - => specialize (H _ _ _ H' H'') - | [ |- wff _ (Pair _ _) (Pair _ _) ] => constructor - | [ |- wff _ _ _ ] => solve [ eauto with wf ] - end. - Qed. - - Lemma wff_SmartCast {var1 var2} A B f1 f2 - : SmartCast A B = Some f1 -> SmartCast A B = Some f2 - -> forall e1 e2, - wff (var1:=var1) (var2:=var2) (flatten_binding_list e1 e2) (f1 e1) (f2 e2). - Proof using wff_Cast. - intros H1 H2; generalize (@wff_SmartCast_match var1 var2 A B). - rewrite H1, H2; trivial. - Qed. - - Lemma wff_SmartCast_app {var1 var2} G A B f1 f2 - : SmartCast A B = Some f1 -> SmartCast A B = Some f2 - -> forall e1 e2, - wff (var1:=var1) (var2:=var2) (flatten_binding_list e1 e2 ++ G) (f1 e1) (f2 e2). - Proof using wff_Cast. - intros; eapply wff_in_impl_Proper; [ eapply wff_SmartCast; eassumption | auto ]. - Qed. -End language. - -Hint Resolve wff_SmartCast_base wff_SmartCast wff_SmartCast_app : wf. diff --git a/src/Reflection/SmartMap.v b/src/Reflection/SmartMap.v deleted file mode 100644 index 934497f65..000000000 --- a/src/Reflection/SmartMap.v +++ /dev/null @@ -1,313 +0,0 @@ -Require Import Coq.Classes.Morphisms. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Util.Tactics.RewriteHyp. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Notations. - -Section homogenous_type. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type} - {var : base_type_code -> Type}. - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation interp_flat_type := (@interp_flat_type base_type_code). - Local Notation exprf := (@exprf base_type_code op var). - Local Notation expr := (@expr base_type_code op var). - - (** Sometimes, we want to deal with partially-interpreted - expressions, things like [prod (exprf A) (exprf B)] rather than - [exprf (Prod A B)], or like [prod (var A) (var B)] when we start - with the type [Prod A B]. These convenience functions let us - recurse on the type in only one place, and replace one kind of - pairing operator (be it [pair] or [Pair] or anything else) with - another kind, and simultaneously mapping a function over the - base values (e.g., [Var] (for turning [var] into [exprf]) or - [Const] (for turning [interp_base_type] into [exprf])). *) - Fixpoint smart_interp_flat_map {f g} - (h : forall x, f x -> g (Tbase x)) - (tt : g Unit) - (pair : forall A B, g A -> g B -> g (Prod A B)) - {t} - : interp_flat_type f t -> g t - := match t return interp_flat_type f t -> g t with - | Syntax.Tbase _ => h _ - | Unit => fun _ => tt - | Prod A B => fun v : interp_flat_type _ A * interp_flat_type _ B - => pair _ _ - (@smart_interp_flat_map f g h tt pair A (fst v)) - (@smart_interp_flat_map f g h tt pair B (snd v)) - end. - Fixpoint smart_interp_flat_map2 {f1 f2 g} - (h : forall x, f1 x -> f2 x -> g (Tbase x)) - (tt : g Unit) - (pair : forall A B, g A -> g B -> g (Prod A B)) - {t} - : interp_flat_type f1 t -> interp_flat_type f2 t -> g t - := match t return interp_flat_type f1 t -> interp_flat_type f2 t -> g t with - | Syntax.Tbase _ => h _ - | Unit => fun _ _ => tt - | Prod A B => fun (v1 : interp_flat_type _ A * interp_flat_type _ B) - (v2 : interp_flat_type _ A * interp_flat_type _ B) - => pair _ _ - (@smart_interp_flat_map2 f1 f2 g h tt pair A (fst v1) (fst v2)) - (@smart_interp_flat_map2 f1 f2 g h tt pair B (snd v1) (snd v2)) - end. - Fixpoint smart_interp_flat_map3 {f1 f2 f3 g} - (h : forall x, f1 x -> f2 x -> f3 x -> g (Tbase x)) - (tt : g Unit) - (pair : forall A B, g A -> g B -> g (Prod A B)) - {t} - : interp_flat_type f1 t -> interp_flat_type f2 t -> interp_flat_type f3 t -> g t - := match t return interp_flat_type f1 t -> interp_flat_type f2 t -> interp_flat_type f3 t -> g t with - | Syntax.Tbase _ => h _ - | Unit => fun _ _ _ => tt - | Prod A B => fun (v1 : interp_flat_type _ A * interp_flat_type _ B) - (v2 : interp_flat_type _ A * interp_flat_type _ B) - (v3 : interp_flat_type _ A * interp_flat_type _ B) - => pair _ _ - (@smart_interp_flat_map3 f1 f2 f3 g h tt pair A (fst v1) (fst v2) (fst v3)) - (@smart_interp_flat_map3 f1 f2 f3 g h tt pair B (snd v1) (snd v2) (snd v3)) - end. - Definition smart_interp_map_hetero {f g g'} - (h : forall x, f x -> g (Tbase x)) - (tt : g Unit) - (pair : forall A B, g A -> g B -> g (Prod A B)) - (abs : forall A B, (g A -> g B) -> g' (Arrow A B)) - {t} - : interp_type_gen_hetero g (interp_flat_type f) t -> g' t - := match t return interp_type_gen_hetero g (interp_flat_type f) t -> g' t with - | Arrow A B => fun v => abs _ _ - (fun x => @smart_interp_flat_map f g h tt pair _ (v x)) - end. - Fixpoint SmartValf {T} (val : forall t : base_type_code, T t) t : interp_flat_type T t - := match t return interp_flat_type T t with - | Syntax.Tbase _ => val _ - | Unit => tt - | Prod A B => (@SmartValf T val A, @SmartValf T val B) - end. - - (** [SmartVar] is like [Var], except that it inserts - pair-projections and [Pair] as necessary to handle [flat_type], - and not just [base_type_code] *) - Local Notation exprfb := (fun t => exprf (Tbase t)). - Definition SmartPairf {t} : interp_flat_type exprfb t -> exprf t - := @smart_interp_flat_map exprfb exprf (fun t x => x) TT (fun A B x y => Pair x y) t. - Lemma SmartPairf_Pair {A B} (e1 : interp_flat_type _ A) (e2 : interp_flat_type _ B) - : SmartPairf (t:=Prod A B) (e1, e2)%core = Pair (SmartPairf e1) (SmartPairf e2). - Proof using Type. reflexivity. Qed. - Definition SmartVarf {t} : interp_flat_type var t -> exprf t - := @smart_interp_flat_map var exprf (fun t => Var) TT (fun A B x y => Pair x y) t. - Definition SmartVarf_Pair {A B v} - : @SmartVarf (Prod A B) v = Pair (SmartVarf (fst v)) (SmartVarf (snd v)) - := eq_refl. - Definition SmartVarfMap {var var'} (f : forall t, var t -> var' t) {t} - : interp_flat_type var t -> interp_flat_type var' t - := @smart_interp_flat_map var (interp_flat_type var') f tt (fun A B x y => pair x y) t. - Lemma SmartVarfMap_compose {var' var'' var''' t} f g x - : @SmartVarfMap var'' var''' g t (@SmartVarfMap var' var'' f t x) - = @SmartVarfMap _ _ (fun t v => g t (f t v)) t x. - Proof using Type. - unfold SmartVarfMap; clear; induction t; simpl; destruct_head_hnf unit; destruct_head_hnf prod; - rewrite_hyp ?*; congruence. - Qed. - Lemma SmartVarfMap_id {var' t} x : @SmartVarfMap var' var' (fun _ x => x) t x = x. - Proof using Type. - unfold SmartVarfMap; clear; induction t; simpl; destruct_head_hnf unit; destruct_head_hnf prod; - rewrite_hyp ?*; congruence. - Qed. - Global Instance smart_interp_flat_map_Proper {f g} - : Proper ((forall_relation (fun t => pointwise_relation _ eq)) - ==> eq - ==> (forall_relation (fun A => forall_relation (fun B => pointwise_relation _ (pointwise_relation _ eq)))) - ==> forall_relation (fun t => eq ==> eq)) - (@smart_interp_flat_map f g). - Proof using Type. - unfold forall_relation, pointwise_relation, respectful. - intros F G HFG x y ? Q R HQR t a b ?; subst y b. - induction t; simpl in *; auto. - rewrite_hyp !*; reflexivity. - Qed. - Global Instance SmartVarfMap_Proper {var' var''} - : Proper (forall_relation (fun t => pointwise_relation _ eq) ==> forall_relation (fun t => eq ==> eq)) - (@SmartVarfMap var' var''). - Proof using Type. - repeat intro; eapply smart_interp_flat_map_Proper; trivial; repeat intro; reflexivity. - Qed. - Definition SmartVarfMap2 {var var' var''} (f : forall t, var t -> var' t -> var'' t) {t} - : interp_flat_type var t -> interp_flat_type var' t -> interp_flat_type var'' t - := @smart_interp_flat_map2 var var' (interp_flat_type var'') f tt (fun A B x y => pair x y) t. - Lemma SmartVarfMap2_fst_arg {var' var''} {t} - (x : interp_flat_type var' t) - (y : interp_flat_type var'' t) - : SmartVarfMap2 (fun _ a b => a) x y = x. - Proof using Type. - unfold SmartVarfMap2; clear; induction t; simpl; destruct_head_hnf unit; destruct_head_hnf prod; - rewrite_hyp ?*; congruence. - Qed. - Lemma SmartVarfMap2_snd_arg {var' var''} {t} - (x : interp_flat_type var' t) - (y : interp_flat_type var'' t) - : SmartVarfMap2 (fun _ a b => b) x y = y. - Proof using Type. - unfold SmartVarfMap2; clear; induction t; simpl; destruct_head_hnf unit; destruct_head_hnf prod; - rewrite_hyp ?*; congruence. - Qed. - Definition SmartVarfMap3 {var var' var'' var'''} (f : forall t, var t -> var' t -> var'' t -> var''' t) {t} - : interp_flat_type var t -> interp_flat_type var' t -> interp_flat_type var'' t -> interp_flat_type var''' t - := @smart_interp_flat_map3 var var' var'' (interp_flat_type var''') f tt (fun A B x y => pair x y) t. - Definition SmartVarfTypeMap {var} (f : forall t, var t -> Type) {t} - : interp_flat_type var t -> Type - := @smart_interp_flat_map var (fun _ => Type) f unit (fun _ _ P Q => P * Q)%type t. - Definition SmartVarfPropMap {var} (f : forall t, var t -> Prop) {t} - : interp_flat_type var t -> Prop - := @smart_interp_flat_map var (fun _ => Prop) f True (fun _ _ P Q => P /\ Q)%type t. - Definition SmartVarfTypeMap2 {var var'} (f : forall t, var t -> var' t -> Type) {t} - : interp_flat_type var t -> interp_flat_type var' t -> Type - := @smart_interp_flat_map2 var var' (fun _ => Type) f unit (fun _ _ P Q => P * Q)%type t. - Definition SmartVarfPropMap2 {var var'} (f : forall t, var t -> var' t -> Prop) {t} - : interp_flat_type var t -> interp_flat_type var' t -> Prop - := @smart_interp_flat_map2 var var' (fun _ => Prop) f True (fun _ _ P Q => P /\ Q)%type t. - Definition SmartFlatTypeMap {var'} (f : forall t, var' t -> base_type_code) {t} - : interp_flat_type var' t -> flat_type - := @smart_interp_flat_map var' (fun _ => flat_type) (fun t v => Tbase (f t v)) Unit (fun _ _ => Prod) t. - Definition SmartFlatTypeUnMap (t : flat_type) - : interp_flat_type (fun _ => base_type_code) t - := SmartValf (fun t => t) t. - Fixpoint SmartFlatTypeMapInterp {var' var''} (f : forall t, var' t -> base_type_code) - (fv : forall t v, var'' (f t v)) t {struct t} - : forall v, interp_flat_type var'' (SmartFlatTypeMap f (t:=t) v) - := match t return forall v, interp_flat_type var'' (SmartFlatTypeMap f (t:=t) v) with - | Syntax.Tbase x => fv _ - | Unit => fun v => v - | Prod A B => fun xy : interp_flat_type _ A * interp_flat_type _ B - => (@SmartFlatTypeMapInterp _ _ f fv A (fst xy), - @SmartFlatTypeMapInterp _ _ f fv B (snd xy)) - end. - Fixpoint SmartFlatTypeMapInterp2 {var' var'' var'''} (f : forall t, var' t -> base_type_code) - (fv : forall t v, var'' t -> var''' (f t v)) t {struct t} - : forall v, interp_flat_type var'' t -> interp_flat_type var''' (SmartFlatTypeMap f (t:=t) v) - := match t return forall v, interp_flat_type var'' t -> interp_flat_type var''' (SmartFlatTypeMap f (t:=t) v) with - | Syntax.Tbase x => fv _ - | Unit => fun v _ => v - | Prod A B => fun (xy : interp_flat_type _ A * interp_flat_type _ B) - (x'y' : interp_flat_type _ A * interp_flat_type _ B) - => (@SmartFlatTypeMapInterp2 _ _ _ f fv A (fst xy) (fst x'y'), - @SmartFlatTypeMapInterp2 _ _ _ f fv B (snd xy) (snd x'y')) - end. - Fixpoint SmartFlatTypeMapUnInterp var' var'' var''' (f : forall t, var' t -> base_type_code) - (fv : forall t (v : var' t), var'' (f t v) -> var''' t) - {t} {struct t} - : forall v, interp_flat_type var'' (SmartFlatTypeMap f (t:=t) v) - -> interp_flat_type var''' t - := match t return forall v, interp_flat_type var'' (SmartFlatTypeMap f (t:=t) v) - -> interp_flat_type var''' t with - | Syntax.Tbase x => fv _ - | Unit => fun _ v => v - | Prod A B => fun (v : interp_flat_type _ A * interp_flat_type _ B) - (xy : interp_flat_type _ (SmartFlatTypeMap _ (fst v)) * interp_flat_type _ (SmartFlatTypeMap _ (snd v))) - => (@SmartFlatTypeMapUnInterp _ _ _ f fv A _ (fst xy), - @SmartFlatTypeMapUnInterp _ _ _ f fv B _ (snd xy)) - end. - Definition SmartVarMap {var' var''} (f : forall t, var' t -> var'' t) (f' : forall t, var'' t -> var' t) {t} - : interp_type_gen (interp_flat_type var') t -> interp_type_gen (interp_flat_type var'') t - := match t return interp_type_gen (interp_flat_type var') t -> interp_type_gen (interp_flat_type var'') t with - | Arrow src dst => fun F x => SmartVarfMap f (F (SmartVarfMap f' x)) - end. - Lemma SmartVarMap_id {var' t} x v : @SmartVarMap var' var' (fun _ x => x) (fun _ x => x) t x v = x v. - Proof using Type. destruct t; simpl; rewrite !SmartVarfMap_id; reflexivity. Qed. - Definition SmartVarVarf {t} : interp_flat_type var t -> interp_flat_type exprfb t - := SmartVarfMap (fun t => Var). -End homogenous_type. - -Global Arguments SmartVarf {_ _ _ _} _. -Global Arguments SmartPairf {_ _ _ t} _. -Global Arguments SmartValf {_} T _ t. -Global Arguments SmartVarVarf {_ _ _ _} _. -Global Arguments SmartVarfMap {_ _ _} _ {!_} _ / . -Global Arguments SmartVarfMap2 {_ _ _ _} _ {!t} _ _ / . -Global Arguments SmartVarfMap3 {_ _ _ _ _} _ {!t} _ _ _ / . -Global Arguments SmartVarfTypeMap {_ _} _ {_} _. -Global Arguments SmartVarfPropMap {_ _} _ {_} _. -Global Arguments SmartVarfTypeMap2 {_ _ _} _ {t} _ _. -Global Arguments SmartVarfPropMap2 {_ _ _} _ {t} _ _. -Global Arguments SmartFlatTypeMap {_ _} _ {_} _. -Global Arguments SmartFlatTypeUnMap {_} _. -Global Arguments SmartFlatTypeMapInterp {_ _ _ _} _ {_} _. -Global Arguments SmartFlatTypeMapInterp2 {_ _ _ _ f} fv {t} _ _. -Global Arguments SmartFlatTypeMapUnInterp {_ _ _ _ _} fv {_ _} _. -Global Arguments SmartVarMap {_ _ _} _ _ {!_} _ / _. - -Section hetero_type. - Fixpoint flatten_flat_type {base_type_code} (t : flat_type (flat_type base_type_code)) : flat_type base_type_code - := match t with - | Tbase T => T - | Unit => Unit - | Prod A B => Prod (@flatten_flat_type _ A) (@flatten_flat_type _ B) - end. - - Section smart_flat_type_map2. - Context {base_type_code1 base_type_code2 : Type}. - - Definition SmartFlatTypeMap2 {var' : base_type_code1 -> Type} (f : forall t, var' t -> flat_type base_type_code2) {t} - : interp_flat_type var' t -> flat_type base_type_code2 - := @smart_interp_flat_map base_type_code1 var' (fun _ => flat_type base_type_code2) f Unit (fun _ _ => Prod) t. - Fixpoint SmartFlatTypeMap2Interp {var' var''} (f : forall t, var' t -> flat_type base_type_code2) - (fv : forall t v, interp_flat_type var'' (f t v)) t {struct t} - : forall v, interp_flat_type var'' (SmartFlatTypeMap2 f (t:=t) v) - := match t return forall v, interp_flat_type var'' (SmartFlatTypeMap2 f (t:=t) v) with - | Tbase x => fv _ - | Unit => fun v => v - | Prod A B => fun xy : interp_flat_type _ A * interp_flat_type _ B - => (@SmartFlatTypeMap2Interp _ _ f fv A (fst xy), - @SmartFlatTypeMap2Interp _ _ f fv B (snd xy)) - end. - Fixpoint SmartFlatTypeMapUnInterp2 var' var'' var''' (f : forall t, var' t -> flat_type base_type_code2) - (fv : forall t (v : var' t), interp_flat_type var'' (f t v) -> var''' t) - {t} {struct t} - : forall v, interp_flat_type var'' (SmartFlatTypeMap2 f (t:=t) v) - -> interp_flat_type var''' t - := match t return forall v, interp_flat_type var'' (SmartFlatTypeMap2 f (t:=t) v) - -> interp_flat_type var''' t with - | Tbase x => fv _ - | Unit => fun _ v => v - | Prod A B => fun (v : interp_flat_type _ A * interp_flat_type _ B) - (xy : interp_flat_type _ (SmartFlatTypeMap2 _ (fst v)) * interp_flat_type _ (SmartFlatTypeMap2 _ (snd v))) - => (@SmartFlatTypeMapUnInterp2 _ _ _ f fv A _ (fst xy), - @SmartFlatTypeMapUnInterp2 _ _ _ f fv B _ (snd xy)) - end. - Fixpoint SmartFlatTypeMap2Interp2 {var' var'' var'''} (f : forall t, var' t -> flat_type base_type_code2) - (fv : forall t v, var'' t -> interp_flat_type var''' (f t v)) t {struct t} - : forall v, interp_flat_type var'' t -> interp_flat_type var''' (SmartFlatTypeMap2 f (t:=t) v) - := match t return forall v, interp_flat_type var'' t -> interp_flat_type var''' (SmartFlatTypeMap2 f (t:=t) v) with - | Tbase x => fv _ - | Unit => fun v _ => v - | Prod A B => fun (xy : interp_flat_type _ A * interp_flat_type _ B) - (x'y' : interp_flat_type _ A * interp_flat_type _ B) - => (@SmartFlatTypeMap2Interp2 _ _ _ f fv A (fst xy) (fst x'y'), - @SmartFlatTypeMap2Interp2 _ _ _ f fv B (snd xy) (snd x'y')) - end. - - Lemma SmartFlatTypeMapUnInterp2_SmartFlatTypeMap2Interp2 - var' var'' var''' - (f : forall t, var' t -> flat_type base_type_code2) - (fv : forall t (v : var' t), interp_flat_type var'' (f t v) -> var''' t) - (gv : forall t v, var''' t -> interp_flat_type var'' (f t v)) - {t} v - (e : interp_flat_type var''' t) - : @SmartFlatTypeMapUnInterp2 - _ _ _ f fv t v - (@SmartFlatTypeMap2Interp2 - _ _ _ f gv t v e) - = SmartVarfMap2 (fun t v e => fv t v (gv t v e)) v e. - Proof using Type. - induction t; simpl in *; destruct_head' unit; - rewrite_hyp ?*; reflexivity. - Qed. - End smart_flat_type_map2. -End hetero_type. - -Global Arguments SmartFlatTypeMap2 {_ _ _} _ {!_} _ / . -Global Arguments SmartFlatTypeMap2Interp {_ _ _ _ _} fv {_} _. -Global Arguments SmartFlatTypeMap2Interp2 {_ _ _ _ _ _} fv {t} v _. -Global Arguments SmartFlatTypeMapUnInterp2 {_ _ _ _ _ _} fv {_ _} _. diff --git a/src/Reflection/Syntax.v b/src/Reflection/Syntax.v deleted file mode 100644 index d8b88e560..000000000 --- a/src/Reflection/Syntax.v +++ /dev/null @@ -1,153 +0,0 @@ -(** * PHOAS Representation of Gallina *) -Require Import Crypto.Util.LetIn. -Require Import Crypto.Util.Notations. - -(** We parameterize the language over a type of basic type codes (for - things like [Z], [word], [bool]), as well as a type of n-ary - operations returning one value, and n-ary operations returning two - values. *) -Delimit Scope ctype_scope with ctype. -Local Open Scope ctype_scope. -Delimit Scope expr_scope with expr. -Local Open Scope expr_scope. -Section language. - Context (base_type_code : Type). - - Inductive flat_type := Tbase (T : base_type_code) | Unit | Prod (A B : flat_type). - Bind Scope ctype_scope with flat_type. - - Inductive type := Arrow (A : flat_type) (B : flat_type). - Bind Scope ctype_scope with type. - - Infix "*" := Prod : ctype_scope. - Notation "A -> B" := (Arrow A B) : ctype_scope. - Local Coercion Tbase : base_type_code >-> flat_type. - - Section tuple. - Context (T : flat_type). - Fixpoint tuple' n := - match n with - | O => T - | S n' => (tuple' n' * T)%ctype - end. - Definition tuple n := - match n with - | O => Unit - | S n' => tuple' n' - end. - End tuple. - - Definition domain (t : type) : flat_type - := match t with Arrow src dst => src end. - Definition codomain (t : type) : flat_type - := match t with Arrow src dst => dst end. - - Section interp. - Definition interp_type_gen_hetero (interp_src interp_dst : flat_type -> Type) (t : type) := - (interp_src match t with Arrow x y => x end -> interp_dst match t with Arrow x y => y end)%type. - Definition interp_type_gen (interp_flat_type : flat_type -> Type) - := interp_type_gen_hetero interp_flat_type interp_flat_type. - Section flat_type. - Context (interp_base_type : base_type_code -> Type). - Fixpoint interp_flat_type (t : flat_type) := - match t with - | Tbase t => interp_base_type t - | Unit => unit - | Prod x y => prod (interp_flat_type x) (interp_flat_type y) - end. - Definition interp_type := interp_type_gen interp_flat_type. - End flat_type. - End interp. - - Section expr_param. - Context (interp_base_type : base_type_code -> Type). - Context (op : flat_type (* input tuple *) -> flat_type (* output type *) -> Type). - Local Notation interp_type := (interp_type interp_base_type). - Local Notation interp_flat_type_gen := interp_flat_type. - Local Notation interp_flat_type := (interp_flat_type interp_base_type). - Section expr. - Context {var : base_type_code -> Type}. - - (** N.B. [Let] binds the components of a pair to separate variables, and does so recursively *) - Inductive exprf : flat_type -> Type := - | TT : exprf Unit - | Var {t} (v : var t) : exprf t - | Op {t1 tR} (opc : op t1 tR) (args : exprf t1) : exprf tR - | LetIn {tx} (ex : exprf tx) {tC} (eC : interp_flat_type_gen var tx -> exprf tC) : exprf tC - | Pair {tx} (ex : exprf tx) {ty} (ey : exprf ty) : exprf (Prod tx ty). - Bind Scope expr_scope with exprf. - Inductive expr : type -> Type := - | Abs {src dst} (f : interp_flat_type_gen var src -> exprf dst) : expr (Arrow src dst). - Bind Scope expr_scope with expr. - End expr. - - Definition Expr (t : type) := forall var, @expr var t. - - Section interp. - Context (interp_op : forall src dst, op src dst -> interp_flat_type src -> interp_flat_type dst). - - Definition interpf_step - (interpf : forall {t} (e : @exprf interp_flat_type t), interp_flat_type t) - {t} (e : @exprf interp_flat_type t) : interp_flat_type t - := match e in exprf t return interp_flat_type t with - | TT => tt - | Var _ x => x - | Op _ _ op args => @interp_op _ _ op (@interpf _ args) - | LetIn _ ex _ eC => dlet x := @interpf _ ex in @interpf _ (eC x) - | Pair _ ex _ ey => (@interpf _ ex, @interpf _ ey) - end. - - Fixpoint interpf {t} e - := @interpf_step (@interpf) t e. - - Definition interp {t} (e : @expr interp_base_type t) : interp_type t - := fun x - => @interpf - _ - (match e in @expr _ t - return interp_flat_type (domain t) - -> exprf (codomain t) - with - | Abs _ _ f => f - end x). - - Definition Interp {t} (E : Expr t) : interp_type t := interp (E _). - End interp. - End expr_param. -End language. -Global Arguments tuple' {_}%type_scope _%ctype_scope _%nat_scope. -Global Arguments tuple {_}%type_scope _%ctype_scope _%nat_scope. -Global Arguments Unit {_}%type_scope. -Global Arguments Prod {_}%type_scope (_ _)%ctype_scope. -Global Arguments Arrow {_}%type_scope (_ _)%ctype_scope. -Global Arguments Tbase {_}%type_scope _%ctype_scope. -Global Arguments domain {_}%type_scope _%ctype_scope. -Global Arguments codomain {_}%type_scope _%ctype_scope. - -Global Arguments Var {_ _ _ _} _. -Global Arguments TT {_ _ _}. -Global Arguments Op {_ _ _ _ _} _ _. -Global Arguments LetIn {_ _ _ _} _ {_} _. -Global Arguments Pair {_ _ _ _} _ {_} _. -Global Arguments Abs {_ _ _ _ _} _. -Global Arguments interp_type_gen_hetero {_} _ _ _. -Global Arguments interp_type_gen {_} _ _. -Global Arguments interp_flat_type {_} _ _. -Global Arguments interp_type {_} _ _. -Global Arguments Interp {_ _ _} interp_op {t} _ _. -Global Arguments interp {_ _ _} interp_op {t} _ _. -Global Arguments interpf {_ _ _} interp_op {t} _. -Global Arguments interp _ _ _ _ _ !_ / _. - -Module Export Notations. - Notation "()" := (@Unit _) : ctype_scope. - Notation "A * B" := (@Prod _ A B) : ctype_scope. - Notation "A -> B" := (@Arrow _ A B) : ctype_scope. - Notation "'slet' x := A 'in' b" := (LetIn A (fun x => b)) : expr_scope. - Notation "'λ' x .. y , t" := (Abs (fun x => .. (Abs (fun y => t%expr)) ..)) : expr_scope. - Notation "( x , y , .. , z )" := (Pair .. (Pair x%expr y%expr) .. z%expr) : expr_scope. - Notation "( )" := TT : expr_scope. - Notation "()" := TT : expr_scope. - Bind Scope ctype_scope with flat_type. - Bind Scope ctype_scope with type. -End Notations. diff --git a/src/Reflection/TestCase.v b/src/Reflection/TestCase.v deleted file mode 100644 index cf759d7e9..000000000 --- a/src/Reflection/TestCase.v +++ /dev/null @@ -1,249 +0,0 @@ -Require Import Coq.omega.Omega Coq.micromega.Psatz. -Require Import Coq.PArith.BinPos Coq.Lists.List. -Require Import Crypto.Reflection.Named.Syntax. -Require Import Crypto.Reflection.Named.Compile. -Require Import Crypto.Reflection.Named.RegisterAssign. -Require Import Crypto.Reflection.Named.PositiveContext. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.Equality. -Require Export Crypto.Reflection.Reify. -Require Import Crypto.Reflection.InputSyntax. -Require Import Crypto.Reflection.CommonSubexpressionElimination. -Require Crypto.Reflection.Linearize Crypto.Reflection.Inline. -Require Import Crypto.Reflection.WfReflective. -Require Import Crypto.Reflection.Conversion. -Require Import Crypto.Util.NatUtil. - -Import ReifyDebugNotations. - -Local Set Boolean Equality Schemes. -Local Set Decidable Equality Schemes. -Inductive base_type := Tnat. -Definition interp_base_type (v : base_type) : Type := - match v with - | Tnat => nat - end. -Local Notation tnat := (Tbase Tnat). -Inductive op : flat_type base_type -> flat_type base_type -> Type := -| Const (v : nat) : op Unit tnat -| Add : op (Prod tnat tnat) tnat -| Mul : op (Prod tnat tnat) tnat -| Sub : op (Prod tnat tnat) tnat. -Definition is_const s d (v : op s d) : bool := match v with Const _ => true | _ => false end. -Definition interp_op src dst (f : op src dst) : interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst - := match f with - | Const v => fun _ => v - | Add => fun xy => fst xy + snd xy - | Mul => fun xy => fst xy * snd xy - | Sub => fun xy => fst xy - snd xy - end%nat. - -Global Instance: reify_op op plus 2 Add := I. -Global Instance: reify_op op mult 2 Mul := I. -Global Instance: reify_op op minus 2 Sub := I. -Global Instance: reify type nat := Tnat. - -Definition make_const (t : base_type) : interp_base_type t -> op Unit (Tbase t) - := match t with - | Tnat => fun v => Const v - end. -Ltac Reify' e := Reify.Reify' base_type interp_base_type op e. -Ltac Reify e := Reify.Reify base_type interp_base_type op make_const e. -Ltac Reify_rhs := Reify.Reify_rhs base_type interp_base_type op make_const interp_op. -Ltac reify_context_variables := - Reify.reify_context_variables base_type interp_base_type op. - -(*Ltac reify_debug_level ::= constr:(2).*) - -Goal (flat_type base_type -> Type) -> False. - intro var. - let x := reifyf base_type interp_base_type op var 1%nat in pose x. - let x := Reify' 1%nat in unify x (fun var => Return (InputSyntax.Const (interp_base_type:=interp_base_type) (var:=var) (t:=Tbase Tnat) (op:=op) 1)). - let x := reifyf base_type interp_base_type op var (1 + 1)%nat in pose x. - let x := Reify' (1 + 1)%nat in unify x (fun var => Return (Op Add (Pair (InputSyntax.Const (interp_base_type:=interp_base_type) (var:=var) (t:=Tbase Tnat) (op:=op) 1) (InputSyntax.Const (interp_base_type:=interp_base_type) (var:=var) (t:=Tbase Tnat) (op:=op) 1)))). - let x := reify_abs base_type interp_base_type op var (fun x => x + 1)%nat in pose x. - let x := Reify' (fun x => x + 1)%nat in unify x (fun var => Abs (fun y => Return (Op Add (Pair (Var y) (InputSyntax.Const (interp_base_type:=interp_base_type) (var:=var) (t:=Tbase Tnat) (op:=op) 1))))). - let x := reifyf base_type interp_base_type op var (let '(a, b) := (1, 1) in a + b)%nat in pose x. - let x := reifyf base_type interp_base_type op var (let '(a, b, c) := (1, 1, 1) in a + b + c)%nat in pose x. - let x := Reify' (fun x => let '(a, b) := (1, 1) in a + x)%nat in let x := (eval vm_compute in x) in pose x. - let x := Reify' (fun x => let '(a, b, c, (d, e), f) := x in a + b + c + d + e + f)%nat in let x := (eval vm_compute in x) in pose x. - let x := Reify' (fun x => let '(a, b) := x in let '(a, c) := a in let '(a, d) := a in a + b + c + d)%nat in let x := (eval vm_compute in x) in pose x. - let x := Reify' (fun ab0 : nat * nat * nat * nat => let (f, g6) := fst ab0 in - let (f0, g7) := f in - let ab3 := (1, 1) in - let ab21 := (1, 1) in - let z := snd ab3 + snd ab21 in z + z)%nat in let x := (eval vm_compute in x) in pose x. - let x := Reify' (fun ab0 : nat * nat * nat => let (f, g7) := fst ab0 in 1 + 1) in let x := (eval vm_compute in x) in pose x. - let x := Reify' (fun x => let '(a, b) := (1, 1) in a + x)%nat in - unify x (fun var => Abs (fun x' => - let c1 := (InputSyntax.Const (interp_base_type:=interp_base_type) (var:=var) (t:=Tbase Tnat) (op:=op) 1) in - Return (MatchPair (tC:=tnat) (Pair c1 c1) - (fun x0 y0 : var tnat => Op Add (Pair (Var x0) (Var x')))))). - let x := reifyf base_type interp_base_type op var (let x := 5 in let y := 6 in (let a := 1 in let '(c, d) := (2, 3) in a + x + c + d) + y)%nat in pose x. - let x := Reify' (let x := 1 in let y := 1 in (let a := 1 in let '(c, d) := (2, 3) in a + x + c + d) + y)%nat in pose x. - let x := Reify' (fun xy => let '(x, y) := xy in (let a := 1 in let '(c, d) := (2, 3) in a + x + c + d) + y)%nat in pose x. -Abort. - - -Goal (0 = let x := 1+2 in x*3)%nat. - Reify_rhs. -Abort. - -Goal (0 = let x := 1 in let y := 2 in x * y)%nat. - Reify_rhs. -Abort. - -Import Linearize Inline. - -Goal True. - let x := Reify (fun xy => let '(x, y) := xy in (let a := 1 in let '(c, d) := (2, 3) in a + x - a + c + d) + y)%nat in - pose (InlineConst is_const (Linearize x)) as e. - vm_compute in e. -Abort. - -Definition example_expr : Syntax.Expr base_type op (Syntax.Arrow (tnat * tnat) tnat). -Proof. - let x := Reify (fun zw => let '(z, w) := zw in let unused := 1 + 1 in let x := 1 in let y := 1 in (let a := 1 in let '(c, d) := (2, 3) in a + x + (x + x) + (x + x) - (x + x) - a + c + d) + y + z + w)%nat in - exact x. -Defined. - -Definition example_expr_ctx : Syntax.Expr base_type op (Syntax.Arrow (tnat * tnat) tnat). -Proof. - pose (((fun ab => let '(a, b) := ab in a + b)%nat) - : Syntax.interp_type interp_base_type (Syntax.Arrow (tnat * tnat) tnat)) - as F. - reify_context_variables. - let x := Reify (fun zw => let '(z, w) := zw in F (z, w))%nat in - exact x. -Defined. - -Definition base_type_eq_semidec_transparent : forall t1 t2, option (t1 = t2) - := fun t1 t2 => match t1, t2 with - | Tnat, Tnat => Some eq_refl - end. -Lemma base_type_eq_semidec_is_dec : forall t1 t2, - base_type_eq_semidec_transparent t1 t2 = None -> t1 <> t2. -Proof. - intros t1 t2; destruct t1, t2; simpl; intros; congruence. -Qed. -Definition op_beq t1 tR : op t1 tR -> op t1 tR -> reified_Prop - := fun x y => match x, y return bool with - | Const a, Const b => NatUtil.nat_beq a b - | Const _, _ => false - | Add, Add => true - | Add, _ => false - | Mul, Mul => true - | Mul, _ => false - | Sub, Sub => true - | Sub, _ => false - end. -Lemma op_beq_bl t1 tR (x y : op t1 tR) - : to_prop (op_beq t1 tR x y) -> x = y. -Proof. - destruct x; simpl; - refine match y with Add => _ | _ => _ end; - repeat match goal with - | _ => progress simpl in * - | _ => progress unfold op_beq in * - | [ |- context[reified_Prop_of_bool ?b] ] - => destruct b eqn:?; unfold reified_Prop_of_bool - | _ => progress nat_beq_to_eq - | _ => congruence - | _ => tauto - end. -Qed. - -Ltac reflect_Wf := WfReflective.reflect_Wf base_type_eq_semidec_is_dec op_beq_bl. - -Lemma example_expr_wf_slow : Wf example_expr. -Proof. - Time (vm_compute; intros; - repeat match goal with - | [ |- wf _ _ ] => constructor; intros - | [ |- wff _ _ _ ] => constructor; intros - | [ |- List.In _ _ ] => vm_compute - | [ |- ?x = ?x \/ _ ] => left; reflexivity - | [ |- ?x = ?y \/ _ ] => right - end). (* 0.036 s *) -Qed. - -Lemma example_expr_wf : Wf example_expr. -Proof. Time reflect_Wf. (* 0.008 s *) Qed. - -Section cse. - Let SConstT := nat. - Inductive op_code : Set := SConst (v : nat) | SAdd | SMul | SSub. - Definition symbolicify_op s d (v : op s d) : op_code - := match v with - | Const v => SConst v - | Add => SAdd - | Mul => SMul - | Sub => SSub - end. - Definition CSE {t} e := @CSE base_type op_code base_type_beq op_code_beq internal_base_type_dec_bl op symbolicify_op t e (fun _ => nil). -End cse. - -Definition example_expr_simplified := Eval vm_compute in InlineConst is_const (Linearize example_expr). -Compute CSE example_expr_simplified. - -Definition example_expr_compiled - := Eval vm_compute in - match Named.Compile.compile (example_expr_simplified _) (List.map Pos.of_nat (seq 1 20)) as v return match v with Some _ => _ | _ => _ end with - | Some v => v - | None => True - end. - -Compute register_reassign (InContext:=PositiveContext_nd) (ReverseContext:=PositiveContext_nd) Pos.eqb empty empty example_expr_compiled (Some 1%positive :: Some 2%positive :: None :: List.map (@Some _) (List.map Pos.of_nat (seq 3 20))). - -Module bounds. - Record bounded := { lower : nat ; value : nat ; upper : nat }. - Definition map_bounded_f2 (f : nat -> nat -> nat) (swap_on_arg2 : bool) (x y : bounded) - := {| lower := f (lower x) (if swap_on_arg2 then upper y else lower y); - value := f (value x) (value y); - upper := f (upper x) (if swap_on_arg2 then lower y else upper y) |}. - Definition bounded_pf := { b : bounded | lower b <= value b <= upper b }. - Definition add_bounded_pf (x y : bounded_pf) : bounded_pf. - Proof. - exists (map_bounded_f2 plus false (proj1_sig x) (proj1_sig y)). - simpl; abstract (destruct x, y; simpl; omega). - Defined. - Definition mul_bounded_pf (x y : bounded_pf) : bounded_pf. - Proof. - exists (map_bounded_f2 mult false (proj1_sig x) (proj1_sig y)). - simpl; abstract (destruct x, y; simpl; nia). - Defined. - Definition sub_bounded_pf (x y : bounded_pf) : bounded_pf. - Proof. - exists (map_bounded_f2 minus true (proj1_sig x) (proj1_sig y)). - simpl; abstract (destruct x, y; simpl; omega). - Defined. - Definition interp_base_type_bounds (v : base_type) : Type := - match v with - | Tnat => { b : bounded | lower b <= value b <= upper b } - end. - Definition constant_bounded t (x : interp_base_type t) : interp_base_type_bounds t. - Proof. - destruct t. - exists {| lower := x ; value := x ; upper := x |}. - simpl; split; reflexivity. - Defined. - Definition interp_op_bounds src dst (f : op src dst) : interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst - := match f with - | Const v => fun _ => constant_bounded Tnat v - | Add => fun xy => add_bounded_pf (fst xy) (snd xy) - | Mul => fun xy => mul_bounded_pf (fst xy) (snd xy) - | Sub => fun xy => sub_bounded_pf (fst xy) (snd xy) - end%nat. - Fixpoint constant_bounds t - : interp_flat_type interp_base_type t -> interp_flat_type interp_base_type_bounds t - := match t with - | Tbase t => constant_bounded t - | Unit => fun _ => tt - | Prod _ _ => fun x => (constant_bounds _ (fst x), constant_bounds _ (snd x)) - end. - - Compute (fun x xpf y ypf => proj1_sig (Syntax.Interp interp_op_bounds example_expr - (exist _ {| lower := 0 ; value := x ; upper := 10 |} xpf, - exist _ {| lower := 100 ; value := y ; upper := 1000 |} ypf))). -End bounds. diff --git a/src/Reflection/Tuple.v b/src/Reflection/Tuple.v deleted file mode 100644 index 519325b82..000000000 --- a/src/Reflection/Tuple.v +++ /dev/null @@ -1,62 +0,0 @@ -Require Import Crypto.Util.Tuple. -Require Import Crypto.Reflection.Syntax. - -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type}. - - Local Notation flat_type := (flat_type base_type_code). - - Section interp. - Section flat_type. - Context {interp_base_type : base_type_code -> Type}. - Local Notation interp_flat_type := (interp_flat_type interp_base_type). - - Fixpoint flat_interp_tuple' {T n} : interp_flat_type (tuple' T n) -> Tuple.tuple' (interp_flat_type T) n - := match n return interp_flat_type (tuple' T n) -> Tuple.tuple' (interp_flat_type T) n with - | O => fun x => x - | S n' => fun xy => (@flat_interp_tuple' _ n' (fst xy), snd xy) - end. - Definition flat_interp_tuple {T n} : interp_flat_type (tuple T n) -> Tuple.tuple (interp_flat_type T) n - := match n return interp_flat_type (tuple T n) -> Tuple.tuple (interp_flat_type T) n with - | O => fun x => x - | S n' => @flat_interp_tuple' T n' - end. - Fixpoint flat_interp_untuple' {T n} : Tuple.tuple' (interp_flat_type T) n -> interp_flat_type (tuple' T n) - := match n return Tuple.tuple' (interp_flat_type T) n -> interp_flat_type (tuple' T n) with - | O => fun x => x - | S n' => fun xy => (@flat_interp_untuple' _ n' (fst xy), snd xy) - end. - Definition flat_interp_untuple {T n} : Tuple.tuple (interp_flat_type T) n -> interp_flat_type (tuple T n) - := match n return Tuple.tuple (interp_flat_type T) n -> interp_flat_type (tuple T n) with - | O => fun x => x - | S n' => @flat_interp_untuple' T n' - end. - Lemma flat_interp_untuple'_tuple' {T n v} - : @flat_interp_untuple' T n (flat_interp_tuple' v) = v. - Proof using Type. induction n; [ reflexivity | simpl; rewrite IHn; destruct v; reflexivity ]. Qed. - Lemma flat_interp_untuple_tuple {T n v} - : flat_interp_untuple (@flat_interp_tuple T n v) = v. - Proof using Type. destruct n; [ reflexivity | apply flat_interp_untuple'_tuple' ]. Qed. - Lemma flat_interp_tuple'_untuple' {T n v} - : @flat_interp_tuple' T n (flat_interp_untuple' v) = v. - Proof using Type. induction n; [ reflexivity | simpl; rewrite IHn; destruct v; reflexivity ]. Qed. - Lemma flat_interp_tuple_untuple {T n v} - : @flat_interp_tuple T n (flat_interp_untuple v) = v. - Proof using Type. destruct n; [ reflexivity | apply flat_interp_tuple'_untuple' ]. Qed. - - Definition tuple_map {A B n} (f : interp_flat_type A -> interp_flat_type B) (v : interp_flat_type (tuple A n)) - : interp_flat_type (tuple B n) - := let fv := Tuple.map f (flat_interp_tuple v) in - match n return interp_flat_type (tuple A n) -> Tuple.tuple (interp_flat_type B) n -> interp_flat_type (tuple B n) with - | 0 => fun v x => x - | S _ => fun v fv => flat_interp_untuple' fv - end v fv. - End flat_type. - End interp. -End language. -Global Arguments flat_interp_tuple' {_ _ _ _} _. -Global Arguments flat_interp_tuple {_ _ _ _} _. -Global Arguments flat_interp_untuple' {_ _ _ _} _. -Global Arguments flat_interp_untuple {_ _ _ _} _. -Global Arguments tuple_map {_ _ _ _ n} _ _. diff --git a/src/Reflection/TypeInversion.v b/src/Reflection/TypeInversion.v deleted file mode 100644 index 2138a3788..000000000 --- a/src/Reflection/TypeInversion.v +++ /dev/null @@ -1,193 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Util.FixCoqMistakes. - -Section language. - Context {base_type_code : Type}. - - Section flat. - Context (P : flat_type base_type_code -> Type). - - Local Ltac t := - let H := fresh in - intro H; intros; - match goal with - | [ p : _ |- _ ] => specialize (H _ p) - end; - cbv beta iota in *; - try specialize (H eq_refl); simpl in *; - try assumption. - - Definition preinvert_Tbase (Q : forall t, P (Tbase t) -> Type) - : (forall t (p : P t), match t return P t -> Type with Tbase _ => Q _ | _ => fun _ => True end p) - -> forall t p, Q t p. - Proof. t. Defined. - - Definition preinvert_Unit (Q : P Unit -> Type) - : (forall t (p : P t), match t return P t -> Type with Unit => Q | _ => fun _ => True end p) - -> forall p, Q p. - Proof. t. Defined. - - Definition preinvert_Prod (Q : forall A B, P (Prod A B) -> Type) - : (forall t (p : P t), match t return P t -> Type with Prod _ _ => Q _ _ | _ => fun _ => True end p) - -> forall A B p, Q A B p. - Proof. t. Defined. - - Definition preinvert_Prod2 (Q : forall A B, P (Prod (Tbase A) (Tbase B)) -> Type) - : (forall t (p : P t), match t return P t -> Type with Prod (Tbase _) (Tbase _) => Q _ _ | _ => fun _ => True end p) - -> forall A B p, Q A B p. - Proof. t. Defined. - - Definition preinvert_Prod2_same (Q : forall A, P (Prod (Tbase A) (Tbase A)) -> Type) - : (forall t (p : P t), match t return P t -> Type with - | Prod (Tbase A) (Tbase B) - => fun p => forall pf : A = B, Q B (eq_rect _ (fun a => P (Prod (Tbase a) (Tbase B))) p _ pf) - | _ => fun _ => True - end p) - -> forall A p, Q A p. - Proof. t. Defined. - - Definition preinvert_Prod3 (Q : forall A B C, P (Tbase A * Tbase B * Tbase C)%ctype -> Type) - : (forall t (p : P t), match t return P t -> Type with Prod (Prod (Tbase _) (Tbase _)) (Tbase _) => Q _ _ _ | _ => fun _ => True end p) - -> forall A B C p, Q A B C p. - Proof. t. Defined. - - Definition preinvert_Prod4 (Q : forall A B C D, P (Tbase A * Tbase B * Tbase C * Tbase D)%ctype -> Type) - : (forall t (p : P t), match t return P t -> Type with Prod (Prod (Prod (Tbase _) (Tbase _)) (Tbase _)) (Tbase _) => Q _ _ _ _ | _ => fun _ => True end p) - -> forall A B C D p, Q A B C D p. - Proof. t. Defined. - End flat. - - Definition preinvert_Arrow (P : type base_type_code -> Type) (Q : forall A B, P (Arrow A B) -> Type) - : (forall t (p : P t), match t return P t -> Type with - | Arrow A B => Q A B - end p) - -> forall A B p, Q A B p. - Proof. - intros H A B p; specialize (H _ p); assumption. - Defined. - - Section encode_decode. - Definition flat_type_code (t1 t2 : flat_type base_type_code) : Prop - := match t1, t2 with - | Unit, Unit => True - | Tbase t1, Tbase t2 => t1 = t2 - | Prod A B, Prod A' B' => A = A' /\ B = B' - | Unit, _ - | Tbase _, _ - | Prod _ _, _ - => False - end. - - Definition type_code (t1 t2 : type base_type_code) : Prop - := domain t1 = domain t2 /\ codomain t1 = codomain t2. - - Definition flat_type_encode (x y : flat_type base_type_code) : x = y -> flat_type_code x y. - Proof. intro p; destruct p, x; repeat constructor. Defined. - Definition type_encode (x y : type base_type_code) : x = y -> type_code x y. - Proof. intro p; destruct p, x; repeat constructor. Defined. - - Definition flat_type_decode (x y : flat_type base_type_code) : flat_type_code x y -> x = y. - Proof. - destruct x, y; simpl in *; intro H; - try first [ apply f_equal; assumption - | exfalso; assumption - | reflexivity - | apply f_equal2; destruct H; assumption ]. - Defined. - Definition type_decode (x y : type base_type_code) : type_code x y -> x = y. - Proof. - destruct x, y; simpl; intro H; - try first [ exfalso; assumption - | apply f_equal; assumption - | apply f_equal2; destruct H; assumption ]. - Defined. - Definition path_flat_type_rect {x y : flat_type base_type_code} (Q : x = y -> Type) - (f : forall p, Q (flat_type_decode x y p)) - : forall p, Q p. - Proof. intro p; specialize (f (flat_type_encode x y p)); destruct x, p; exact f. Defined. - Definition path_type_rect {x y : type base_type_code} (Q : x = y -> Type) - (f : forall p, Q (type_decode x y p)) - : forall p, Q p. - Proof. intro p; specialize (f (type_encode x y p)); destruct x, p; exact f. Defined. - End encode_decode. -End language. - -Ltac preinvert_one_type e := - lazymatch type of e with - | ?P (Tbase ?T) - => is_var T; - move e at top; - revert dependent T; - refine (preinvert_Tbase P _ _) - | ?P (Prod (Tbase ?A) (Tbase ?A)) - => is_var A; - move e at top; revert dependent A; - refine (preinvert_Prod2_same P _ _) - | ?P (Prod (Tbase ?A) (Tbase ?B)) - => is_var A; is_var B; - move e at top; revert dependent A; intros A e; - move e at top; revert dependent B; revert A; - refine (preinvert_Prod2 P _ _) - | ?P (Prod (Prod (Tbase ?A) (Tbase ?B)) (Tbase ?C)) - => is_var A; is_var B; is_var C; - move e at top; revert dependent A; intros A e; - move e at top; revert dependent B; intros B e; - move e at top; revert dependent C; revert A B; - refine (preinvert_Prod3 P _ _) - | ?P (Prod (Prod (Prod (Tbase ?A) (Tbase ?B)) (Tbase ?C)) (Tbase ?D)) - => is_var A; is_var B; is_var C; is_var D; - move e at top; revert dependent A; intros A e; - move e at top; revert dependent B; intros B e; - move e at top; revert dependent C; intros C e; - move e at top; revert dependent D; revert A B C; - refine (preinvert_Prod4 P _ _) - | ?P (Prod ?A ?B) - => is_var A; is_var B; - move e at top; revert dependent A; intros A e; - move e at top; revert dependent B; revert A; - refine (preinvert_Prod P _ _) - | ?P Unit - => revert dependent e; - refine (preinvert_Unit P _ _) - | ?P (Arrow ?A ?B) - => is_var A; is_var B; - move e at top; revert dependent A; intros A e; - move e at top; revert dependent B; revert A; - refine (preinvert_Arrow P _ _) - end. - -Ltac induction_type_in_using H rect := - induction H as [H] using (rect _ _ _); - cbv [flat_type_code type_code] in H; - let H1 := fresh H in - let H2 := fresh H in - try lazymatch type of H with - | False => exfalso; exact H - | True => destruct H - | _ /\ _ => destruct H as [H1 H2] - end. -Ltac inversion_flat_type_step := - lazymatch goal with - | [ H : _ = Tbase _ |- _ ] - => induction_type_in_using H @path_flat_type_rect - | [ H : Tbase _ = _ |- _ ] - => induction_type_in_using H @path_flat_type_rect - | [ H : _ = Prod _ _ |- _ ] - => induction_type_in_using H @path_flat_type_rect - | [ H : Prod _ _ = _ |- _ ] - => induction_type_in_using H @path_flat_type_rect - | [ H : _ = Unit |- _ ] - => induction_type_in_using H @path_flat_type_rect - | [ H : Unit = _ |- _ ] - => induction_type_in_using H @path_flat_type_rect - end. -Ltac inversion_flat_type := repeat inversion_flat_type_step. - -Ltac inversion_type_step := - lazymatch goal with - | [ H : _ = Arrow _ _ |- _ ] - => induction_type_in_using H @path_type_rect - | [ H : Arrow _ _ = _ |- _ ] - => induction_type_in_using H @path_type_rect - end. -Ltac inversion_type := repeat inversion_type_step. diff --git a/src/Reflection/TypeUtil.v b/src/Reflection/TypeUtil.v deleted file mode 100644 index 8f7661bde..000000000 --- a/src/Reflection/TypeUtil.v +++ /dev/null @@ -1,35 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Util.Notations. - -Local Open Scope expr_scope. - -Section language. - Context {base_type_code : Type} - (base_type_beq : base_type_code -> base_type_code -> bool) - (base_type_leb : base_type_code -> base_type_code -> bool). - Local Infix "<=?" := base_type_leb : expr_scope. - Local Infix "=?" := base_type_beq : expr_scope. - - Definition base_type_min (a b : base_type_code) : base_type_code - := if a <=? b then a else b. - Definition base_type_max (a b : base_type_code) : base_type_code - := if a <=? b then b else a. - Section gen. - Context (join : base_type_code -> base_type_code -> base_type_code). - Fixpoint flat_type_join {t : flat_type base_type_code} - : interp_flat_type (fun _ => base_type_code) t -> option base_type_code - := match t with - | Tbase _ => fun v => Some v - | Unit => fun _ => None - | Prod A B - => fun v => match @flat_type_join A (fst v), @flat_type_join B (snd v) with - | Some a, Some b => Some (join a b) - | Some a, None => Some a - | None, Some b => Some b - | None, None => None - end - end. - End gen. - Definition flat_type_min {t} := @flat_type_join base_type_min t. - Definition flat_type_max {t} := @flat_type_join base_type_max t. -End language. diff --git a/src/Reflection/Wf.v b/src/Reflection/Wf.v deleted file mode 100644 index 91a99b150..000000000 --- a/src/Reflection/Wf.v +++ /dev/null @@ -1,70 +0,0 @@ -Require Import Coq.Lists.List. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Util.Notations. - -Create HintDb wf discriminated. - -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type}. - Local Notation exprf := (@exprf base_type_code op). - Local Notation expr := (@expr base_type_code op). - Local Notation Expr := (@Expr base_type_code op). - - Section with_var. - Context {var1 var2 : base_type_code -> Type}. - - Local Notation eP2 := (fun t1t2 => var1 (fst t1t2) * var2 (snd t1t2))%type (only parsing). - Local Notation eP := (fun t => var1 t * var2 t)%type (only parsing). - Local Notation "x == y" := (existT eP _ (x, y)%core). - Fixpoint flatten_binding_list2 {t1 t2} (x : interp_flat_type var1 t1) (y : interp_flat_type var2 t2) : list (sigT eP2) - := (match t1, t2 return interp_flat_type var1 t1 -> interp_flat_type var2 t2 -> list _ with - | Tbase t1, Tbase t2 => fun x y => existT eP2 (t1, t2)%core (x, y)%core :: nil - | Unit, Unit => fun x y => nil - | Prod t0 t1, Prod t0' t1' - => fun x y => @flatten_binding_list2 _ _ (snd x) (snd y) ++ @flatten_binding_list2 _ _ (fst x) (fst y) - | Tbase _, _ - | Unit, _ - | Prod _ _, _ - => fun _ _ => nil - end x y)%list. - Fixpoint flatten_binding_list {t} (x : interp_flat_type var1 t) (y : interp_flat_type var2 t) : list (sigT eP) - := (match t return interp_flat_type var1 t -> interp_flat_type var2 t -> list _ with - | Tbase _ => fun x y => (x == y) :: nil - | Unit => fun x y => nil - | Prod t0 t1 => fun x y => @flatten_binding_list _ (snd x) (snd y) ++ @flatten_binding_list _ (fst x) (fst y) - end x y)%list. - - Inductive wff : list (sigT eP) -> forall {t}, @exprf var1 t -> @exprf var2 t -> Prop := - | WfTT : forall G, @wff G _ TT TT - | WfVar : forall G (t : base_type_code) x x', List.In (x == x') G -> @wff G (Tbase t) (Var x) (Var x') - | WfOp : forall G {t} {tR} (e : @exprf var1 t) (e' : @exprf var2 t) op, - wff G e e' - -> wff G (Op (tR := tR) op e) (Op (tR := tR) op e') - | WfLetIn : forall G t1 t2 e1 e1' (e2 : interp_flat_type var1 t1 -> @exprf var1 t2) e2', - wff G e1 e1' - -> (forall x1 x2, wff (flatten_binding_list x1 x2 ++ G) (e2 x1) (e2' x2)) - -> wff G (LetIn e1 e2) (LetIn e1' e2') - | WfPair : forall G {t1} {t2} (e1: @exprf var1 t1) (e2: @exprf var1 t2) - (e1': @exprf var2 t1) (e2': @exprf var2 t2), - wff G e1 e1' - -> wff G e2 e2' - -> wff G (Pair e1 e2) (Pair e1' e2'). - Inductive wf : forall {t}, @expr var1 t -> @expr var2 t -> Prop := - | WfAbs : forall A B e e', - (forall x x', @wff (flatten_binding_list x x') B (e x) (e' x')) - -> @wf (Arrow A B) (Abs e) (Abs e'). - End with_var. - - Definition Wf {t} (E : @Expr t) := forall var1 var2, wf (E var1) (E var2). - - Axiom Wf_admitted : forall {t} (E:Expr t), @Wf t E. -End language. - -Ltac admit_Wf := apply Wf_admitted. - -Global Arguments wff {_ _ _ _} G {t} _ _. -Global Arguments wf {_ _ _ _ t} _ _. -Global Arguments Wf {_ _ t} _. - -Hint Constructors wf wff : wf. diff --git a/src/Reflection/WfInversion.v b/src/Reflection/WfInversion.v deleted file mode 100644 index d76fd90f4..000000000 --- a/src/Reflection/WfInversion.v +++ /dev/null @@ -1,205 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.ExprInversion. -Require Import Crypto.Util.Sigma. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Equality. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Notations. - -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type}. - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation exprf := (@exprf base_type_code op). - Local Notation expr := (@expr base_type_code op). - Local Notation Expr := (@Expr base_type_code op). - Local Notation wff := (@wff base_type_code op). - Local Notation wf := (@wf base_type_code op). - Local Notation Wf := (@Wf base_type_code op). - - Section with_var. - Context {var1 var2 : base_type_code -> Type}. - - Local Notation eP := (fun t => var1 t * var2 t)%type (only parsing). - Local Notation "x == y" := (existT eP _ (x, y)). - - Definition wff_code (G : list (sigT eP)) {t} (e1 : @exprf var1 t) : forall (e2 : @exprf var2 t), Prop - := match e1 in Syntax.exprf _ _ t return exprf t -> Prop with - | TT - => fun e2 - => TT = e2 - | Var t v1 - => fun e2 - => match invert_Var e2 with - | Some v2 => List.In (v1 == v2) G - | None => False - end - | Op t1 tR opc1 args1 - => fun e2 - => match invert_Op e2 with - | Some (existT t2 (opc2, args2)) - => { pf : t1 = t2 - | eq_rect _ (fun t => op t tR) opc1 _ pf = opc2 - /\ wff G (eq_rect _ exprf args1 _ pf) args2 } - | None => False - end - | LetIn tx1 ex1 tC1 eC1 - => fun e2 - => match invert_LetIn e2 with - | Some (existT tx2 (ex2, eC2)) - => { pf : tx1 = tx2 - | wff G (eq_rect _ exprf ex1 _ pf) ex2 - /\ (forall x1 x2, - wff (flatten_binding_list x1 x2 ++ G)%list - (eC1 x1) (eC2 (eq_rect _ _ x2 _ pf))) } - | None => False - end - | Pair tx1 ex1 ty1 ey1 - => fun e2 - => match invert_Pair e2 with - | Some (ex2, ey2) => wff G ex1 ex2 /\ wff G ey1 ey2 - | None => False - end - end. - - Local Ltac t := - repeat match goal with - | _ => progress simpl in * - | _ => progress subst - | _ => progress inversion_option - | _ => progress invert_expr_subst - | [ H : Some _ = _ |- _ ] => symmetry in H - | _ => assumption - | _ => reflexivity - | _ => constructor - | _ => progress destruct_head False - | _ => progress destruct_head and - | _ => progress destruct_head sig - | _ => progress break_match_hyps - | _ => progress break_match - | [ |- and _ _ ] => split - | _ => exists eq_refl - | _ => intro - | [ e : expr (Arrow _ _) |- _ ] - => let H := fresh in - let f := fresh in - remember (invert_Abs e) as f eqn:H; - symmetry in H; - apply invert_Abs_Some in H - end. - - Definition wff_encode {G t e1 e2} (v : @wff var1 var2 G t e1 e2) : @wff_code G t e1 e2. - Proof. - destruct v; t. - Defined. - - Definition wff_decode {G t e1 e2} (v : @wff_code G t e1 e2) : @wff var1 var2 G t e1 e2. - Proof. - destruct e1; t. - Defined. - - Definition wff_endecode {G t e1 e2} v : @wff_decode G t e1 e2 (@wff_encode G t e1 e2 v) = v. - Proof using Type. - destruct v; reflexivity. - Qed. - - Definition wff_deencode {G t e1 e2} v : @wff_encode G t e1 e2 (@wff_decode G t e1 e2 v) = v. - Proof using Type. - destruct e1; simpl in *; - move e2 at top; - lazymatch type of e2 with - | exprf Unit - => subst; reflexivity - | exprf (Tbase ?t) - => revert dependent t; - intros ? e2 - | exprf (Prod ?A ?B) - => revert dependent A; - intros ? e2; - move e2 at top; - revert dependent B; - intros ? e2 - | exprf ?t - => revert dependent t; - intros ? e2 - end; - refine match e2 with - | TT => _ - | _ => _ - end; - t. - Qed. - - Definition wf_code {t} (e1 : @expr var1 t) : forall (e2 : @expr var2 t), Prop - := match e1 in Syntax.expr _ _ t return expr t -> Prop with - | Abs src dst f1 - => fun e2 - => let f2 := invert_Abs e2 in - forall (x : interp_flat_type var1 src) (x' : interp_flat_type var2 src), - wff (flatten_binding_list x x') (f1 x) (f2 x') - end. - - Definition wf_encode {t e1 e2} (v : @wf var1 var2 t e1 e2) : @wf_code t e1 e2. - Proof. - destruct v; t. - Defined. - - Definition wf_decode {t e1 e2} (v : @wf_code t e1 e2) : @wf var1 var2 t e1 e2. - Proof. - destruct e1; t. - Defined. - - Definition wf_endecode {t e1 e2} v : @wf_decode t e1 e2 (@wf_encode t e1 e2 v) = v. - Proof using Type. - destruct v; reflexivity. - Qed. - - Definition wf_deencode {t e1 e2} v : @wf_encode t e1 e2 (@wf_decode t e1 e2 v) = v. - Proof using Type. - destruct e1 as [src dst f1]. - revert dependent f1. - refine match e2 with - | Abs _ _ f2 => _ - end. - reflexivity. - Qed. - End with_var. -End language. - -Ltac is_expr_constructor arg := - lazymatch arg with - | Op _ _ => idtac - | TT => idtac - | Var _ => idtac - | LetIn _ _ => idtac - | Pair _ _ => idtac - | Abs _ => idtac - end. - -Ltac inversion_wf_step_gen guard_tac := - let postprocess H := - (cbv [wff_code wf_code] in H; - simpl in H; - try match type of H with - | True => clear H - | False => exfalso; exact H - end) in - match goal with - | [ H : wff _ ?x ?y |- _ ] - => guard_tac x y; - apply wff_encode in H; postprocess H - | [ H : wf ?x ?y |- _ ] - => guard_tac x y; - apply wf_encode in H; postprocess H - end. -Ltac inversion_wf_step_constr := - inversion_wf_step_gen ltac:(fun x y => is_expr_constructor x; is_expr_constructor y). -Ltac inversion_wf_step_var := - inversion_wf_step_gen ltac:(fun x y => first [ is_var x; is_var y; fail 1 | idtac ]). -Ltac inversion_wf_step := first [ inversion_wf_step_constr | inversion_wf_step_var ]. -Ltac inversion_wf_constr := repeat inversion_wf_step_constr. -Ltac inversion_wf := repeat inversion_wf_step. diff --git a/src/Reflection/WfProofs.v b/src/Reflection/WfProofs.v deleted file mode 100644 index ca1f50478..000000000 --- a/src/Reflection/WfProofs.v +++ /dev/null @@ -1,237 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.WfInversion. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.ExprInversion. -Require Import Crypto.Util.Sigma Crypto.Util.Prod. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Tactics.RewriteHyp. -Require Import Crypto.Util.Tactics.SplitInContext. - -Local Open Scope ctype_scope. -Section language. - Context {base_type_code : Type} - {op : flat_type base_type_code -> flat_type base_type_code -> Type}. - - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation exprf := (@exprf base_type_code op). - Local Notation expr := (@expr base_type_code op). - Local Notation Expr := (@Expr base_type_code op). - Local Notation wff := (@wff base_type_code op). - - Section with_var. - Context {var1 var2 : base_type_code -> Type}. - Local Hint Constructors Wf.wff. - - Lemma wff_app' {g G0 G1 t e1 e2} - (wf : @wff var1 var2 (G0 ++ G1) t e1 e2) - : wff (G0 ++ g ++ G1) e1 e2. - Proof using Type. - rewrite !List.app_assoc. - revert wf; remember (G0 ++ G1)%list as G eqn:?; intro wf. - revert dependent G0. revert dependent G1. - induction wf; simpl in *; constructor; simpl; eauto. - { subst; rewrite !List.in_app_iff in *; intuition. } - { intros; subst. - rewrite !List.app_assoc; eauto using List.app_assoc. } - Qed. - - Lemma wff_app_pre {g G t e1 e2} - (wf : @wff var1 var2 G t e1 e2) - : wff (g ++ G) e1 e2. - Proof using Type. - apply (@wff_app' _ nil); assumption. - Qed. - - Lemma wff_app_post {g G t e1 e2} - (wf : @wff var1 var2 G t e1 e2) - : wff (G ++ g) e1 e2. - Proof using Type. - pose proof (@wff_app' g G nil t e1 e2) as H. - rewrite !List.app_nil_r in *; auto. - Qed. - - Lemma wff_in_impl_Proper G0 G1 {t} e1 e2 - : @wff var1 var2 G0 t e1 e2 - -> (forall x, List.In x G0 -> List.In x G1) - -> @wff var1 var2 G1 t e1 e2. - Proof using Type. - intro wf; revert G1; induction wf; - repeat match goal with - | _ => setoid_rewrite List.in_app_iff - | _ => progress intros - | _ => progress simpl in * - | [ |- wff _ _ _ ] => constructor - | [ H : _ |- _ ] => apply H - | _ => solve [ intuition eauto ] - end. - Qed. - - Local Hint Resolve List.in_app_or List.in_or_app. - Local Hint Extern 1 => progress unfold List.In in *. - Local Hint Resolve wff_in_impl_Proper. - - Lemma wff_SmartVarf {t} x1 x2 - : @wff var1 var2 (flatten_binding_list x1 x2) t (SmartVarf x1) (SmartVarf x2). - Proof using Type. - unfold SmartVarf. - induction t; simpl; constructor; eauto. - Qed. - - Local Hint Resolve wff_SmartVarf. - - Lemma wff_SmartVarVarf G {t t'} v1 v2 x1 x2 - (Hin : List.In (existT (fun t : base_type_code => (exprf (Tbase t) * exprf (Tbase t))%type) t (x1, x2)) - (flatten_binding_list (SmartVarVarf v1) (SmartVarVarf v2))) - : @wff var1 var2 (flatten_binding_list (t:=t') v1 v2 ++ G) (Tbase t) x1 x2. - Proof using Type. - revert dependent G; induction t'; intros; simpl in *; try tauto. - { intuition (inversion_sigma; inversion_prod; subst; simpl; eauto). - constructor; eauto. } - { unfold SmartVarVarf in *; simpl in *. - apply List.in_app_iff in Hin. - intuition (inversion_sigma; inversion_prod; subst; eauto). - { rewrite <- !List.app_assoc; eauto. } } - Qed. - - Lemma wff_SmartVarVarf_nil {t t'} v1 v2 x1 x2 - (Hin : List.In (existT (fun t : base_type_code => (exprf (Tbase t) * exprf (Tbase t))%type) t (x1, x2)) - (flatten_binding_list (SmartVarVarf v1) (SmartVarVarf v2))) - : @wff var1 var2 (flatten_binding_list (t:=t') v1 v2) (Tbase t) x1 x2. - Proof using Type. - apply wff_SmartVarVarf with (G:=nil) in Hin. - rewrite List.app_nil_r in Hin; assumption. - Qed. - - Lemma In_G_wff_SmartVarf G t v1 v2 e - (Hwf : @wff var1 var2 G t (SmartVarf v1) (SmartVarf v2)) - (Hin : List.In e (flatten_binding_list v1 v2)) - : List.In e G. - Proof using Type. - induction t; - repeat match goal with - | _ => assumption - | [ H : False |- _ ] => exfalso; assumption - | _ => progress subst - | _ => progress destruct_head' and - | [ H : context[List.In _ (_ ++ _)] |- _ ] => rewrite List.in_app_iff in H - | [ H : context[SmartVarf _] |- _ ] => rewrite SmartVarf_Pair in H - | _ => progress simpl in * - | _ => progress destruct_head' or - | _ => solve [ eauto with nocore ] - | _ => progress inversion_wf - end. - Qed. - End with_var. - - Definition duplicate_type {var1 var2} - : { t : base_type_code & (var1 t * var2 t)%type } - -> { t1t2 : _ & (var1 (fst t1t2) * var2 (snd t1t2))%type } - := fun txy => existT _ (projT1 txy, projT1 txy) (projT2 txy). - Definition duplicate_types {var1 var2} - := List.map (@duplicate_type var1 var2). - - Lemma flatten_binding_list_flatten_binding_list2 - {var1 var2 t1} x1 x2 - : duplicate_types (@flatten_binding_list base_type_code var1 var2 t1 x1 x2) - = @flatten_binding_list2 base_type_code var1 var2 t1 t1 x1 x2. - Proof using Type. - induction t1; simpl; try reflexivity. - rewrite_hyp <- !*. - unfold duplicate_types; rewrite List.map_app; reflexivity. - Qed. - - Local Ltac flatten_t := - repeat first [ reflexivity - | intro - | progress simpl @flatten_binding_list - | progress simpl @flatten_binding_list2 - | rewrite !List.map_app - | progress simpl in * - | rewrite_hyp <- !*; reflexivity - | rewrite_hyp !*; reflexivity ]. - - Lemma flatten_binding_list2_SmartVarfMap - {var1 var1' var2 var2' t1 t2} f g (x1 : interp_flat_type var1 t1) (x2 : interp_flat_type var2 t2) - : flatten_binding_list2 (var1:=var1') (var2:=var2') (base_type_code:=base_type_code) (SmartVarfMap f x1) (SmartVarfMap g x2) - = List.map (fun txy => existT _ (projT1 txy) (f _ (fst (projT2 txy)), g _ (snd (projT2 txy)))%core) - (flatten_binding_list2 x1 x2). - Proof using Type. - revert dependent t2; induction t1, t2; flatten_t. - Qed. - - Lemma flatten_binding_list2_SmartVarfMap1 - {var1 var1' var2' t1 t2} f (x1 : interp_flat_type var1 t1) (x2 : interp_flat_type var2' t2) - : flatten_binding_list2 (var1:=var1') (var2:=var2') (base_type_code:=base_type_code) (SmartVarfMap f x1) x2 - = List.map (fun txy => existT _ (projT1 txy) (f _ (fst (projT2 txy)), snd (projT2 txy))%core) - (flatten_binding_list2 x1 x2). - Proof using Type. - revert dependent t2; induction t1, t2; flatten_t. - Qed. - - Lemma flatten_binding_list2_SmartVarfMap2 - {var1' var2 var2' t1 t2} g (x1 : interp_flat_type var1' t1) (x2 : interp_flat_type var2 t2) - : flatten_binding_list2 (var1:=var1') (var2:=var2') (base_type_code:=base_type_code) x1 (SmartVarfMap g x2) - = List.map (fun txy => existT _ (projT1 txy) (fst (projT2 txy), g _ (snd (projT2 txy)))%core) - (flatten_binding_list2 x1 x2). - Proof using Type. - revert dependent t2; induction t1, t2; flatten_t. - Qed. - - Lemma flatten_binding_list_SmartVarfMap - {var1 var1' var2 var2' t} f g (x1 : interp_flat_type var1 t) (x2 : interp_flat_type var2 t) - : flatten_binding_list (var1:=var1') (var2:=var2') (base_type_code:=base_type_code) (SmartVarfMap f x1) (SmartVarfMap g x2) - = List.map (fun txy => existT _ (projT1 txy) (f _ (fst (projT2 txy)), g _ (snd (projT2 txy)))%core) - (flatten_binding_list x1 x2). - Proof using Type. induction t; flatten_t. Qed. - - Lemma flatten_binding_list2_SmartValf - {T1 T2} f g t1 t2 - : flatten_binding_list2 (base_type_code:=base_type_code) (SmartValf T1 f t1) (SmartValf T2 g t2) - = List.map (fun txy => existT _ (projT1 txy) (f _, g _)%core) - (flatten_binding_list2 (SmartFlatTypeUnMap t1) (SmartFlatTypeUnMap t2)). - Proof using Type. - revert dependent t2; induction t1, t2; flatten_t. - Qed. - - Lemma flatten_binding_list_SmartValf - {T1 T2} f g t - : flatten_binding_list (base_type_code:=base_type_code) (SmartValf T1 f t) (SmartValf T2 g t) - = List.map (fun txy => existT _ (projT1 txy) (f _, g _)%core) - (flatten_binding_list (SmartFlatTypeUnMap t) (SmartFlatTypeUnMap t)). - Proof using Type. induction t; flatten_t. Qed. - - Lemma flatten_binding_list_In_eq_iff - {var} T x y - : (forall t a b, List.In (existT _ t (a, b)) (@flatten_binding_list base_type_code var var T x y) -> a = b) - <-> x = y. - Proof using Type. - induction T; - repeat first [ exfalso; assumption - | progress subst - | progress inversion_sigma - | progress inversion_prod - | progress destruct_head' unit - | progress destruct_head' prod - | split - | progress simpl in * - | intro - | progress destruct_head or - | apply (f_equal2 (@pair _ _)) - | progress split_iff - | solve [ auto using List.in_or_app ] - | match goal with - | [ H : List.In _ (_ ++ _) |- _ ] => rewrite List.in_app_iff in H - | [ H : forall x y, x = y -> forall t a b, List.In _ _ -> _, H' : List.In _ _ |- _ ] - => specialize (H _ _ eq_refl _ _ _ H') - end ]. - Qed. - - Lemma flatten_binding_list_same_in_eq - {var} {T x t a b} - : List.In (existT _ t (a, b)) (@flatten_binding_list base_type_code var var T x x) -> a = b. - Proof using Type. intro; eapply flatten_binding_list_In_eq_iff; eauto. Qed. -End language. - -Hint Resolve wff_SmartVarf wff_SmartVarVarf wff_SmartVarVarf_nil : wf. diff --git a/src/Reflection/WfReflective.v b/src/Reflection/WfReflective.v deleted file mode 100644 index c54537fa2..000000000 --- a/src/Reflection/WfReflective.v +++ /dev/null @@ -1,280 +0,0 @@ -(** * A reflective Version of [Wf] proofs *) -(** Because every constructor of [Syntax.wff] stores the syntax tree - being proven well-formed, a proof that a syntax tree is - well-formed is quadratic in the size of the syntax tree. (Tacking - an extra term on to the head of the syntax tree requires an extra - constructor of [Syntax.wff], and that constructor stores the - entirety of the new syntax tree.) - - In practice, this makes proving well-formedness of large trees - very slow. To remedy this, we provide an alternative type - ([reflect_wffT]) that implies [Syntax.wff], but is only linear in - the size of the syntax tree, with a coefficient less than 1. - - The idea is that, since we already know the syntax-tree arguments - to the constructors (and, moreover, already fully know the shape - of the [Syntax.wff] proof, because it will exactly match the shape - of the syntax tree), the proof doesn't have to store any of that - information. It only has to store the genuinely new information - in [Syntax.wff], namely, that the constants don't depend on the - [var] argument (i.e., that the constants in the same location in - the two expressions are equal), and that there are no free nor - mismatched variables (i.e., that the variables in the same - location in the two expressions are in the relevant list of - binders). We can make the further optimization of storing the - location in the list of each binder, so that all that's left to - verify is that the locations line up correctly. - - Since there is no way to assign list locations (De Bruijn indices) - after the fact (that is, once we have an [exprf var t] rather than - an [Expr t]), we instead start from an expression where [var] is - enriched with De Bruijn indices, and talk about [Syntax.wff] of - that expression stripped of its De Bruijn indices. Since this - procedure is only expected to work on concrete syntax trees, we - will be able to simply check by unification to check that - stripping the indices results in the term that we started with. - - The interface of this file is that, to prove a [Syntax.Wf] goal, - you invoke the tactic [reflect_Wf base_type_eq_semidec_is_dec - op_beq_bl], where: - - - [base_type_eq_semidec_is_dec : forall t1 t2, - base_type_eq_semidec_transparent t1 t2 = None -> t1 <> t2] for - some [base_type_eq_semidec_transparent : forall t1 t2 : - base_type_code, option (t1 = t2)], and - - - [op_beq_bl : forall t1 tR x y, prop_of_option (op_beq t1 tR x y) - -> x = y] for some [op_beq : forall t1 tR, op t1 tR -> op t1 tR - -> reified_Prop] *) - -Require Import Coq.Arith.Arith Coq.Logic.Eqdep_dec. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.EtaWf. -Require Import Crypto.Reflection.WfReflectiveGen. -Require Import Crypto.Util.Notations Crypto.Util.Option Crypto.Util.Sigma Crypto.Util.Prod Crypto.Util.Decidable Crypto.Util.ListUtil. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.SpecializeBy. -Require Export Crypto.Util.PartiallyReifiedProp. (* export for the [bool >-> reified_Prop] coercion *) -Require Export Crypto.Util.FixCoqMistakes. - - -Section language. - (** To be able to optimize away so much of the [Syntax.wff] proof, - we must be able to decide a few things: equality of base types, - and equality of operator codes. Since we will be casting across - the equality proofs of base types, we require that this - semi-decider give transparent proofs. (This requirement is not - enforced, but it will block [vm_compute] when trying to use the - lemma in this file.) *) - Context (base_type_code : Type). - Context (base_type_eq_semidec_transparent : forall t1 t2 : base_type_code, option (t1 = t2)). - Context (base_type_eq_semidec_is_dec : forall t1 t2, base_type_eq_semidec_transparent t1 t2 = None -> t1 <> t2). - Context (op : flat_type base_type_code -> flat_type base_type_code -> Type). - (** In practice, semi-deciding equality of operators should either - return [Some trivial] or [None], and not make use of the - generality of [pointed_Prop]. However, we need to use - [pointed_Prop] internally because we need to talk about equality - of things of type [var t], for [var : base_type_code -> Type]. - It does not hurt to allow extra generality in [op_beq]. *) - Context (op_beq : forall t1 tR, op t1 tR -> op t1 tR -> reified_Prop). - Context (op_beq_bl : forall t1 tR x y, to_prop (op_beq t1 tR x y) -> x = y). - Context {var1 var2 : base_type_code -> Type}. - - Local Notation eP := (fun t => var1 (fst t) * var2 (snd t))%type (only parsing). - - (* convenience notations that fill in some arguments used across the section *) - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation exprf := (@exprf base_type_code op). - Local Notation expr := (@expr base_type_code op). - Local Notation duplicate_type := (@duplicate_type base_type_code var1 var2). - Local Notation reflect_wffT := (@reflect_wffT base_type_code base_type_eq_semidec_transparent op op_beq var1 var2). - Local Notation reflect_wfT := (@reflect_wfT base_type_code base_type_eq_semidec_transparent op op_beq var1 var2). - Local Notation flat_type_eq_semidec_transparent := (@flat_type_eq_semidec_transparent base_type_code base_type_eq_semidec_transparent). - Local Notation preflatten_binding_list2 := (@preflatten_binding_list2 base_type_code base_type_eq_semidec_transparent var1 var2). - Local Notation type_eq_semidec_transparent := (@type_eq_semidec_transparent base_type_code base_type_eq_semidec_transparent). - - Local Ltac handle_op_beq_correct := - repeat match goal with - | [ H : to_prop (op_beq ?t1 ?tR ?x ?y) |- _ ] - => apply op_beq_bl in H - end. - Local Ltac t_step := - match goal with - | [ |- True ] => exact I - | _ => progress cbv beta delta [eq_type_and_var op_beq' flatten_binding_list2 WfReflectiveGen.preflatten_binding_list2 option_map eq_semidec_and_gen] in * - | _ => progress simpl in * - | _ => progress subst - | _ => progress break_innermost_match_step - | _ => progress inversion_option - | _ => progress inversion_prod - | _ => progress inversion_reified_Prop - | _ => congruence - | _ => tauto - | _ => progress intros - | _ => progress handle_op_beq_correct - | _ => progress specialize_by tauto - | [ v : ex _ |- _ ] => destruct v - | [ v : sigT _ |- _ ] => destruct v - | [ v : prod _ _ |- _ ] => destruct v - | [ H : forall x x', _ |- wff (flatten_binding_list ?x1 ?x2 ++ _)%list _ _ ] - => specialize (H x1 x2) - | [ H : forall x x', _ |- wf (existT _ _ (?x1, ?x2) :: _)%list _ _ ] - => specialize (H x1 x2) - | [ H : and _ _ |- _ ] => destruct H - | [ H : to_prop (_ /\ _) |- _ ] => apply to_prop_and_reified_Prop in H; destruct H - | [ H : context[duplicate_type (_ ++ _)%list] |- _ ] - => rewrite duplicate_type_app in H - | [ H : context[List.length (duplicate_type _)] |- _ ] - => rewrite duplicate_type_length in H - | [ H : context[List.length (_ ++ _)%list] |- _ ] - => rewrite List.app_length in H - | [ |- wff _ (unnatize_exprf (fst _) _) (unnatize_exprf (fst _) _) ] - => erewrite length_natize_interp_flat_type1, length_natize_interp_flat_type2; eassumption - | [ |- wf _ (unnatize_exprf (fst _) _) (unnatize_exprf (fst _) _) ] - => erewrite length_natize_interp_flat_type1, length_natize_interp_flat_type2; eassumption - | [ H : base_type_eq_semidec_transparent _ _ = None |- False ] => eapply duplicate_type_not_in; eassumption - | [ H : List.nth_error _ _ = Some _ |- _ ] => apply List.nth_error_In in H - | [ H : List.In _ (duplicate_type _) |- _ ] => eapply duplicate_type_in in H; [ | eassumption.. ] - | [ H : context[match _ with _ => _ end] |- _ ] => revert H; progress break_innermost_match - | [ |- wff _ _ _ ] => constructor - | [ |- wf _ _ ] => constructor - | _ => progress unfold and_reified_Prop in * - | [ |- wff (flatten_binding_list ?x ?y) _ _ ] - => rewrite <- (List.app_nil_r (flatten_binding_list x y)) - end. - Local Ltac t := repeat t_step. - Fixpoint reflect_wff (G : list (sigT (fun t => var1 t * var2 t)%type)) - {t1 t2 : flat_type} - (e1 : @exprf (fun t => nat * var1 t)%type t1) (e2 : @exprf (fun t => nat * var2 t)%type t2) - {struct e1} - : let reflective_obligation := reflect_wffT (duplicate_type G) e1 e2 in - match flat_type_eq_semidec_transparent t1 t2 with - | Some p - => to_prop reflective_obligation - -> @wff base_type_code op var1 var2 G t2 (eq_rect _ exprf (unnatize_exprf (List.length G) e1) _ p) (unnatize_exprf (List.length G) e2) - | None => True - end. - Proof using base_type_eq_semidec_is_dec op_beq_bl. - cbv zeta. - destruct e1 as [ | | ? ? ? args | tx ex tC eC | ? ex ? ey ], - e2 as [ | | ? ? ? args' | tx' ex' tC' eC' | ? ex' ? ey' ]; simpl; - try solve [ break_match; solve [ exact I | intros [] ] ]; - [ clear reflect_wff - | clear reflect_wff - | specialize (reflect_wff G _ _ args args') - | pose proof (reflect_wff G _ _ ex ex'); - pose proof (fun x x' - => match preflatten_binding_list2 tx tx' as v return match v with Some _ => _ | None => True end with - | Some G0 - => reflect_wff - (G0 x x' ++ G)%list _ _ - (eC (snd (natize_interp_flat_type (length (duplicate_type G)) x))) - (eC' (snd (natize_interp_flat_type (length (duplicate_type G)) x'))) - | None => I - end); - clear reflect_wff - | pose proof (reflect_wff G _ _ ex ex'); pose proof (reflect_wff G _ _ ey ey'); clear reflect_wff ]. - { t. } - { t. } - { t. } - { t. } - { t. } - Qed. - Definition reflect_wf - {t1 t2 : type} - (e1 : @expr (fun t => nat * var1 t)%type t1) (e2 : @expr (fun t => nat * var2 t)%type t2) - : let reflective_obligation := reflect_wfT nil e1 e2 in - match type_eq_semidec_transparent t1 t2 with - | Some p - => to_prop reflective_obligation - -> @wf base_type_code op var1 var2 t2 (eq_rect _ expr (unnatize_expr 0 e1) _ p) (unnatize_expr 0 e2) - | None => True - end. - Proof using base_type_eq_semidec_is_dec op_beq_bl. - destruct e1 as [ tx tR f ], - e2 as [ tx' tR' f' ]; simpl; try solve [ exact I ]. - pose proof (fun x x' - => match preflatten_binding_list2 tx tx' as v return match v with Some _ => _ | None => True end with - | Some G0 - => reflect_wff - (G0 x x' ++ nil)%list - (f (snd (natize_interp_flat_type 0 x))) - (f' (snd (natize_interp_flat_type 0 x'))) - | None => I - end). - t. - Qed. -End language. - -Section Wf. - Context (base_type_code : Type) - (base_type_eq_semidec_transparent : forall t1 t2 : base_type_code, option (t1 = t2)) - (base_type_eq_semidec_is_dec : forall t1 t2, base_type_eq_semidec_transparent t1 t2 = None -> t1 <> t2) - (op : flat_type base_type_code -> flat_type base_type_code -> Type) - (op_beq : forall t1 tR, op t1 tR -> op t1 tR -> reified_Prop) - (op_beq_bl : forall t1 tR x y, to_prop (op_beq t1 tR x y) -> x = y) - {t : type base_type_code} - (e : @Expr base_type_code op t). - - (** Leads to smaller proofs, but is less generally applicable *) - Theorem reflect_Wf_unnatize - : (forall var1 var2, - to_prop (@reflect_wfT base_type_code base_type_eq_semidec_transparent op op_beq var1 var2 nil t t (e _) (e _))) - -> Wf (fun var => unnatize_expr 0 (e (fun t => (nat * var t)%type))). - Proof using base_type_eq_semidec_is_dec op_beq_bl. - intros H var1 var2; specialize (H var1 var2). - pose proof (@reflect_wf base_type_code base_type_eq_semidec_transparent base_type_eq_semidec_is_dec op op_beq op_beq_bl var1 var2 t t (e _) (e _)) as H'. - rewrite type_eq_semidec_transparent_refl in H' by assumption; simpl in *. - edestruct @reflect_wfT; simpl in *; tauto. - Qed. - - (** Leads to larger proofs (an extra constant factor which is the - size of the expression tree), but more generally applicable *) - Theorem reflect_Wf - : (forall var1 var2, - unnatize_expr 0 (e (fun t => (nat * var1 t)%type)) = e _ - /\ to_prop (@reflect_wfT base_type_code base_type_eq_semidec_transparent op op_beq var1 var2 nil t t (e _) (e _))) - -> Wf e. - Proof using base_type_eq_semidec_is_dec op_beq_bl. - intros H var1 var2. - rewrite <- (proj1 (H var1 var2)), <- (proj1 (H var2 var2)). - apply reflect_Wf_unnatize, H. - Qed. -End Wf. - -(** Using [ExprEta'] ensures that reduction and conversion don't block - on destructuring the variable arguments. *) -Ltac preapply_eta'_Wf := - lazymatch goal with - | [ |- @Wf ?base_type_code ?op ?t ?e ] - => apply (proj1 (@Wf_ExprEta'_iff base_type_code op t e)) - end. -Ltac generalize_reflect_Wf base_type_eq_semidec_is_dec op_beq_bl := - lazymatch goal with - | [ |- @Wf ?base_type_code ?op ?t ?e ] - => generalize (@reflect_Wf_unnatize base_type_code _ base_type_eq_semidec_is_dec op _ op_beq_bl t e) - end. -Ltac use_reflect_Wf := - let H := fresh in - intro H; - lazymatch type of H with - | ?A -> ?B - => cut A - end; - [ abstract vm_cast_no_check H - | clear H ]. -Ltac fin_reflect_Wf := - intros; - lazymatch goal with - | [ |- to_prop ?P ] - => replace P with (trueify P) by abstract vm_cast_no_check (eq_refl P) - end; - apply trueify_true. -(** The tactic [reflect_Wf] is the main tactic of this file, used to - prove [Syntax.Wf] goals *) -Ltac reflect_Wf base_type_eq_semidec_is_dec op_beq_bl := - preapply_eta'_Wf; - generalize_reflect_Wf base_type_eq_semidec_is_dec op_beq_bl; - use_reflect_Wf; fin_reflect_Wf. diff --git a/src/Reflection/WfReflectiveGen.v b/src/Reflection/WfReflectiveGen.v deleted file mode 100644 index 23cdd8691..000000000 --- a/src/Reflection/WfReflectiveGen.v +++ /dev/null @@ -1,334 +0,0 @@ -(** * A reflective version of [Wf]/[WfRel] proofs *) -(** Because every constructor of [Syntax.wff] stores the syntax tree - being proven well-formed, a proof that a syntax tree is - well-formed is quadratic in the size of the syntax tree. (Tacking - an extra term on to the head of the syntax tree requires an extra - constructor of [Syntax.wff], and that constructor stores the - entirety of the new syntax tree.) - - In practice, this makes proving well-formedness of large trees - very slow. To remedy this, we provide an alternative type - ([reflect_wffT]) that implies [Syntax.wff], but is only linear in - the size of the syntax tree, with a coefficient less than 1. - - The idea is that, since we already know the syntax-tree arguments - to the constructors (and, moreover, already fully know the shape - of the [Syntax.wff] proof, because it will exactly match the shape - of the syntax tree), the proof doesn't have to store any of that - information. It only has to store the genuinely new information - in [Syntax.wff], namely, that the constants don't depend on the - [var] argument (i.e., that the constants in the same location in - the two expressions are equal), and that there are no free nor - mismatched variables (i.e., that the variables in the same - location in the two expressions are in the relevant list of - binders). We can make the further optimization of storing the - location in the list of each binder, so that all that's left to - verify is that the locations line up correctly. - - Since there is no way to assign list locations (De Bruijn indices) - after the fact (that is, once we have an [exprf var t] rather than - an [Expr t]), we instead start from an expression where [var] is - enriched with De Bruijn indices, and talk about [Syntax.wff] of - that expression stripped of its De Bruijn indices. Since this - procedure is only expected to work on concrete syntax trees, we - will be able to simply check by unification to check that - stripping the indices results in the term that we started with. - - The interface of this file is that, to prove a [Syntax.Wf] goal, - you invoke the tactic [reflect_Wf base_type_eq_semidec_is_dec - op_beq_bl], where: - - - [base_type_eq_semidec_is_dec : forall t1 t2, - base_type_eq_semidec_transparent t1 t2 = None -> t1 <> t2] for - some [base_type_eq_semidec_transparent : forall t1 t2 : - base_type_code, option (t1 = t2)], and - - - [op_beq_bl : forall t1 tR x y, prop_of_option (op_beq t1 tR x y) - -> x = y] for some [op_beq : forall t1 tR, op t1 tR -> op t1 tR - -> option pointed_Prop] *) - -Require Import Coq.Arith.Arith Coq.Logic.Eqdep_dec. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Util.Notations Crypto.Util.Option Crypto.Util.Sigma Crypto.Util.Prod Crypto.Util.Decidable Crypto.Util.ListUtil. -Require Import Crypto.Util.Tactics.RewriteHyp. -Require Import Crypto.Reflection.Wf. -Require Export Crypto.Util.PartiallyReifiedProp. (* export for the [bool >-> reified_Prop] coercion *) -Require Export Crypto.Util.FixCoqMistakes. - - -Section language. - (** To be able to optimize away so much of the [Syntax.wff] proof, - we must be able to decide a few things: equality of base types, - and equality of operator codes. Since we will be casting across - the equality proofs of base types, we require that this - semi-decider give transparent proofs. (This requirement is not - enforced, but it will block [vm_compute] when trying to use the - lemma in this file.) *) - Context (base_type_code : Type) - (base_type_eq_semidec_transparent : forall t1 t2 : base_type_code, option (t1 = t2)) - (base_type_eq_semidec_is_dec : forall t1 t2, base_type_eq_semidec_transparent t1 t2 = None -> t1 <> t2) - (op : flat_type base_type_code -> flat_type base_type_code -> Type). - (** In practice, semi-deciding equality of operators should either - return [Some trivial] or [None], and not make use of the - generality of [pointed_Prop]. However, we need to use - [pointed_Prop] internally because we need to talk about equality - of things of type [var t], for [var : base_type_code -> Type]. - It does not hurt to allow extra generality in [op_beq]. *) - Context (op_beq : forall t1 tR, op t1 tR -> op t1 tR -> reified_Prop). - Context (op_beq_bl : forall t1 tR x y, to_prop (op_beq t1 tR x y) -> x = y). - Context {var1 var2 : base_type_code -> Type}. - - Local Notation eP := (fun t => var1 (fst t) * var2 (snd t))%type (only parsing). - - (* convenience notations that fill in some arguments used across the section *) - Local Notation flat_type := (flat_type base_type_code). - Local Notation type := (type base_type_code). - Local Notation exprf := (@exprf base_type_code op). - Local Notation expr := (@expr base_type_code op). - - Local Ltac inversion_base_type_code_step := - match goal with - | [ H : ?x = ?x :> base_type_code |- _ ] - => assert (H = eq_refl) by eapply UIP_dec, dec_rel_of_semidec_rel, base_type_eq_semidec_is_dec; subst H - | [ H : ?x = ?y :> base_type_code |- _ ] => subst x || subst y - end. - Local Ltac inversion_base_type_code := repeat inversion_base_type_code_step. - - (* lift [base_type_eq_semidec_transparent] across [flat_type] *) - Fixpoint flat_type_eq_semidec_transparent (t1 t2 : flat_type) : option (t1 = t2) - := match t1, t2 return option (t1 = t2) with - | Tbase t1, Tbase t2 - => option_map (@f_equal _ _ Tbase _ _) - (base_type_eq_semidec_transparent t1 t2) - | Tbase _, _ => None - | Unit, Unit => Some eq_refl - | Unit, _ => None - | Prod A B, Prod A' B' - => match flat_type_eq_semidec_transparent A A', flat_type_eq_semidec_transparent B B' with - | Some p, Some q => Some (f_equal2 Prod p q) - | _, _ => None - end - | Prod _ _, _ => None - end. - Definition type_eq_semidec_transparent (t1 t2 : type) : option (t1 = t2) - := match t1, t2 return option (t1 = t2) with - | Arrow A B, Arrow A' B' - => match flat_type_eq_semidec_transparent A A', flat_type_eq_semidec_transparent B B' with - | Some p, Some q => Some (f_equal2 (@Arrow base_type_code) p q) - | _, _ => None - end - end. - Lemma base_type_eq_semidec_transparent_refl t : base_type_eq_semidec_transparent t t = Some eq_refl. - Proof using base_type_eq_semidec_is_dec. - clear -base_type_eq_semidec_is_dec. - pose proof (base_type_eq_semidec_is_dec t t). - destruct (base_type_eq_semidec_transparent t t); intros; try intuition congruence. - inversion_base_type_code; reflexivity. - Qed. - Lemma flat_type_eq_semidec_transparent_refl t : flat_type_eq_semidec_transparent t t = Some eq_refl. - Proof using base_type_eq_semidec_is_dec. - clear -base_type_eq_semidec_is_dec. - induction t as [t | | A B IHt]; simpl; try reflexivity. - { rewrite base_type_eq_semidec_transparent_refl; reflexivity. } - { rewrite_hyp !*; reflexivity. } - Qed. - Lemma type_eq_semidec_transparent_refl t : type_eq_semidec_transparent t t = Some eq_refl. - Proof using base_type_eq_semidec_is_dec. - clear -base_type_eq_semidec_is_dec. - destruct t; simpl; rewrite !flat_type_eq_semidec_transparent_refl; reflexivity. - Qed. - - - Definition op_beq' t1 tR t1' tR' (x : op t1 tR) (y : op t1' tR') : reified_Prop - := match flat_type_eq_semidec_transparent t1 t1', flat_type_eq_semidec_transparent tR tR' with - | Some p, Some q - => match p in (_ = t1'), q in (_ = tR') return op t1' tR' -> _ with - | eq_refl, eq_refl => fun y => op_beq _ _ x y - end y - | _, _ => rFalse - end. - - (** While [Syntax.wff] is parameterized over a list of [sigT (fun t - => var1 t * var2 t)], it is simpler here to make everything - heterogenous, rather than trying to mix homogenous and - heterogenous things.† Thus we parameterize our [reflect_wffT] - over a list of [sigT (fun t => var1 (fst t) * var2 (snd t))], - and write a function ([duplicate_type]) that turns the former - into the latter. - - † This is an instance of the general theme that abstraction - barriers are important. Here we enforce the abstraction - barrier that our input decision procedures are homogenous, but - all of our internal code is strictly heterogenous. This - allows us to contain the conversions between homogenous and - heterogenous code to a few functions: [op_beq'], - [eq_type_and_var], [eq_type_and_const], and to the statement - about [Syntax.wff] itself. *) - - Definition eq_semidec_and_gen {T} (semidec : forall x y : T, option (x = y)) - (t t' : T) (f g : T -> Type) (R : forall t, f t -> g t -> reified_Prop) - (x : f t) (x' : g t') - : reified_Prop - := match semidec t t' with - | Some p - => R _ (eq_rect _ f x _ p) x' - | None => rFalse - end. - - (* Here is where we use the generality of [pointed_Prop], to say - that two things of type [var1] are equal, and two things of type - [var2] are equal. *) - Definition eq_type_and_var : sigT eP -> sigT eP -> reified_Prop - := fun x y => (eq_semidec_and_gen - base_type_eq_semidec_transparent _ _ var1 var1 (fun _ => rEq) (fst (projT2 x)) (fst (projT2 y)) - /\ eq_semidec_and_gen - base_type_eq_semidec_transparent _ _ var2 var2 (fun _ => rEq) (snd (projT2 x)) (snd (projT2 y)))%reified_prop. - - Definition duplicate_type (ls : list (sigT (fun t => var1 t * var2 t)%type)) : list (sigT eP) - := List.map (fun v => existT eP (projT1 v, projT1 v) (projT2 v)) ls. - - Lemma duplicate_type_app ls ls' - : (duplicate_type (ls ++ ls') = duplicate_type ls ++ duplicate_type ls')%list. - Proof using Type. apply List.map_app. Qed. - Lemma duplicate_type_length ls - : List.length (duplicate_type ls) = List.length ls. - Proof using Type. apply List.map_length. Qed. - Lemma duplicate_type_in t v ls - : List.In (existT _ (t, t) v) (duplicate_type ls) -> List.In (existT _ t v) ls. - Proof using base_type_eq_semidec_is_dec. - unfold duplicate_type; rewrite List.in_map_iff. - intros [ [? ?] [? ?] ]. - inversion_sigma; inversion_prod; inversion_base_type_code; subst; simpl. - assumption. - Qed. - Lemma duplicate_type_not_in G t t0 v (H : base_type_eq_semidec_transparent t t0 = None) - : ~List.In (existT _ (t, t0) v) (duplicate_type G). - Proof using base_type_eq_semidec_is_dec. - apply base_type_eq_semidec_is_dec in H. - clear -H; intro H'. - induction G as [|? ? IHG]; simpl in *; destruct H'; - intuition; congruence. - Qed. - - Definition preflatten_binding_list2 t1 t2 : option (forall (x : interp_flat_type var1 t1) (y : interp_flat_type var2 t2), list (sigT (fun t => var1 t * var2 t)%type)) - := match flat_type_eq_semidec_transparent t1 t2 with - | Some p - => Some (fun x y - => let x := eq_rect _ (interp_flat_type var1) x _ p in - flatten_binding_list x y) - | None => None - end. - Definition flatten_binding_list2 t1 t2 : option (forall (x : interp_flat_type var1 t1) (y : interp_flat_type var2 t2), list (sigT eP)) - := option_map (fun f x y => duplicate_type (f x y)) (preflatten_binding_list2 t1 t2). - (** This function adds De Bruijn indices to variables *) - Fixpoint natize_interp_flat_type var t (base : nat) (v : interp_flat_type var t) {struct t} - : nat * interp_flat_type (fun t : base_type_code => nat * var t)%type t - := match t return interp_flat_type var t -> nat * interp_flat_type _ t with - | Prod A B => fun v => let ret := @natize_interp_flat_type _ A base (fst v) in - let base := fst ret in - let a := snd ret in - let ret := @natize_interp_flat_type _ B base (snd v) in - let base := fst ret in - let b := snd ret in - (base, (a, b)) - | Unit => fun v => (base, v) - | Tbase t => fun v => (S base, (base, v)) - end v. - Arguments natize_interp_flat_type {var t} _ _. - Lemma length_natize_interp_flat_type1 {t} (base : nat) (v1 : interp_flat_type var1 t) (v2 : interp_flat_type var2 t) - : fst (natize_interp_flat_type base v1) = length (flatten_binding_list v1 v2) + base. - Proof using Type. - revert base; induction t; simpl; [ reflexivity | reflexivity | ]. - intros; rewrite List.app_length, <- plus_assoc. - rewrite_hyp <- ?*; reflexivity. - Qed. - Lemma length_natize_interp_flat_type2 {t} (base : nat) (v1 : interp_flat_type var1 t) (v2 : interp_flat_type var2 t) - : fst (natize_interp_flat_type base v2) = length (flatten_binding_list v1 v2) + base. - Proof using Type. - revert base; induction t; simpl; [ reflexivity | reflexivity | ]. - intros; rewrite List.app_length, <- plus_assoc. - rewrite_hyp <- ?*; reflexivity. - Qed. - - (* This function strips De Bruijn indices from expressions *) - Fixpoint unnatize_exprf {var t} (base : nat) - (e : @Syntax.exprf base_type_code op (fun t => nat * var t)%type t) - : @Syntax.exprf base_type_code op var t - := match e in @Syntax.exprf _ _ _ t return Syntax.exprf _ _ t with - | TT => TT - | Var _ x => Var (snd x) - | Op _ _ op args => Op op (@unnatize_exprf _ _ base args) - | LetIn _ ex _ eC - => LetIn (@unnatize_exprf _ _ base ex) - (fun x => let v := natize_interp_flat_type base x in - @unnatize_exprf _ _ (fst v) (eC (snd v))) - | Pair _ x _ y - => Pair (@unnatize_exprf _ _ base x) (@unnatize_exprf _ _ base y) - end. - Definition unnatize_expr {var t} (base : nat) - (e : @Syntax.expr base_type_code op (fun t => nat * var t)%type t) - : @Syntax.expr base_type_code op var t - := match e in @Syntax.expr _ _ _ t return Syntax.expr _ _ t with - | Abs tx tR f => Abs (fun x : interp_flat_type var tx => - let v := natize_interp_flat_type (t:=tx) base x in - @unnatize_exprf _ _ (fst v) (f (snd v))) - end. - - Fixpoint reflect_wffT (G : list (sigT (fun t => var1 (fst t) * var2 (snd t))%type)) - {t1 t2 : flat_type} - (e1 : @exprf (fun t => nat * var1 t)%type t1) - (e2 : @exprf (fun t => nat * var2 t)%type t2) - {struct e1} - : reified_Prop - := match e1, e2 with - | TT, TT => rTrue - | TT, _ => rFalse - | Var t0 x, Var t1 y - => match beq_nat (fst x) (fst y), List.nth_error G (List.length G - S (fst x)) with - | true, Some v => eq_type_and_var v (existT _ (t0, t1) (snd x, snd y)) - | _, _ => rFalse - end - | Var _ _, _ => rFalse - | Op t1 tR op args, Op t1' tR' op' args' - => (@reflect_wffT G t1 t1' args args' /\ op_beq' t1 tR t1' tR' op op')%reified_prop - | Op _ _ _ _, _ => rFalse - | LetIn tx ex tC eC, LetIn tx' ex' tC' eC' - => let p := @reflect_wffT G tx tx' ex ex' in - match @flatten_binding_list2 tx tx', flat_type_eq_semidec_transparent tC tC' with - | Some G0, Some _ - => p - /\ (∀ (x : interp_flat_type var1 tx) (x' : interp_flat_type var2 tx'), - @reflect_wffT (G0 x x' ++ G)%list _ _ - (eC (snd (natize_interp_flat_type (List.length G) x))) - (eC' (snd (natize_interp_flat_type (List.length G) x')))) - | _, _ => rFalse - end - | LetIn _ _ _ _, _ => rFalse - | Pair tx ex ty ey, Pair tx' ex' ty' ey' - => @reflect_wffT G tx tx' ex ex' /\ @reflect_wffT G ty ty' ey ey' - | Pair _ _ _ _, _ => rFalse - end%reified_prop. - - Definition reflect_wfT (G : list (sigT (fun t => var1 (fst t) * var2 (snd t))%type)) - {t1 t2 : type} - (e1 : @expr (fun t => nat * var1 t)%type t1) - (e2 : @expr (fun t => nat * var2 t)%type t2) - : reified_Prop - := match e1, e2 with - | Abs tx tR f, Abs tx' tR' f' - => match @flatten_binding_list2 tx tx', flat_type_eq_semidec_transparent tR tR' with - | Some G0, Some _ - => ∀ (x : interp_flat_type var1 tx) (x' : interp_flat_type var2 tx'), - @reflect_wffT (G0 x x' ++ G)%list _ _ - (f (snd (natize_interp_flat_type (List.length G) x))) - (f' (snd (natize_interp_flat_type (List.length G) x'))) - | _, _ => rFalse - end - end%reified_prop. -End language. - -Global Arguments reflect_wffT {_} _ {op} op_beq {var1 var2} G {t1 t2} _ _. -Global Arguments reflect_wfT {_} _ {op} op_beq {var1 var2} G {t1 t2} _ _. -Global Arguments unnatize_exprf {_ _ _ _} _ _. -Global Arguments unnatize_expr {_ _ _ _} _ _. -Global Arguments natize_interp_flat_type {_ _ t} _ _. diff --git a/src/Reflection/Z/ArithmeticSimplifier.v b/src/Reflection/Z/ArithmeticSimplifier.v deleted file mode 100644 index 821ef8459..000000000 --- a/src/Reflection/Z/ArithmeticSimplifier.v +++ /dev/null @@ -1,184 +0,0 @@ -(** * SimplifyArith: Remove things like (_ * 1), (_ + 0), etc *) -Require Import Coq.ZArith.ZArith. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Rewriter. -Require Import Crypto.Reflection.Z.Syntax. - -Section language. - Local Notation exprf := (@exprf base_type op). - Local Notation Expr := (@Expr base_type op). - - Section with_var. - Context {var : base_type -> Type}. - - Inductive inverted_expr t := - | const_of (v : Z) - | gen_expr (e : exprf (var:=var) (Tbase t)) - | neg_expr (e : exprf (var:=var) (Tbase t)). - - Fixpoint interp_as_expr_or_const {t} (x : exprf (var:=var) t) - : option (interp_flat_type inverted_expr t) - := match x in Syntax.exprf _ _ t return option (interp_flat_type _ t) with - | Op t1 (Tbase _) opc args - => Some (match opc in op src dst return exprf dst -> exprf src -> inverted_expr match dst with Tbase t => t | _ => TZ end with - | OpConst _ z => fun _ _ => const_of _ z - | Opp TZ TZ => fun _ args => neg_expr _ args - | _ => fun e _ => gen_expr _ e - end (Op opc args) args) - | TT => Some tt - | Var t v => Some (gen_expr _ (Var v)) - | Op _ _ _ _ - | LetIn _ _ _ _ - => None - | Pair tx ex ty ey - => match @interp_as_expr_or_const tx ex, @interp_as_expr_or_const ty ey with - | Some vx, Some vy => Some (vx, vy) - | _, None | None, _ => None - end - end. - - Definition simplify_op_expr {src dst} (opc : op src dst) - : exprf (var:=var) src -> exprf (var:=var) dst - := match opc in op src dst return exprf src -> exprf dst with - | Add TZ TZ TZ as opc - => fun args - => match interp_as_expr_or_const args with - | Some (const_of l, const_of r) - => Op (OpConst (interp_op _ _ opc (l, r))) TT - | Some (const_of v, gen_expr e) - | Some (gen_expr e, const_of v) - => if (v =? 0)%Z - then e - else Op opc args - | Some (const_of v, neg_expr e) - | Some (neg_expr e, const_of v) - => if (v =? 0)%Z - then Op (Opp _ _) e - else Op opc args - | Some (gen_expr ep, neg_expr en) - | Some (neg_expr en, gen_expr ep) - => Op (Sub _ _ _) (Pair ep en) - | _ => Op opc args - end - | Sub TZ TZ TZ as opc - => fun args - => match interp_as_expr_or_const args with - | Some (const_of l, const_of r) - => Op (OpConst (interp_op _ _ opc (l, r))) TT - | Some (gen_expr e, const_of v) - => if (v =? 0)%Z - then e - else Op opc args - | Some (neg_expr e, const_of v) - => if (v =? 0)%Z - then Op (Opp _ _) e - else Op opc args - | Some (gen_expr e1, neg_expr e2) - => Op (Add _ _ _) (Pair e1 e2) - | Some (neg_expr e1, neg_expr e2) - => Op (Sub _ _ _) (Pair e2 e1) - | _ => Op opc args - end - | Mul TZ TZ TZ as opc - => fun args - => match interp_as_expr_or_const args with - | Some (const_of l, const_of r) - => Op (OpConst (interp_op _ _ opc (l, r))) TT - | Some (const_of v, gen_expr e) - | Some (gen_expr e, const_of v) - => if (v =? 0)%Z - then Op (OpConst 0%Z) TT - else if (v =? 1)%Z - then e - else if (v =? -1)%Z - then Op (Opp _ _) e - else Op opc args - | Some (const_of v, neg_expr e) - | Some (neg_expr e, const_of v) - => if (v =? 0)%Z - then Op (OpConst 0%Z) TT - else if (v =? 1)%Z - then Op (Opp _ _) e - else if (v =? -1)%Z - then e - else Op opc args - | Some (gen_expr e1, neg_expr e2) - | Some (neg_expr e1, gen_expr e2) - => Op (Opp _ _) (Op (Mul _ _ TZ) (Pair e1 e2)) - | Some (neg_expr e1, neg_expr e2) - => Op (Mul _ _ _) (Pair e1 e2) - | _ => Op opc args - end - | Shl TZ TZ TZ as opc - | Shr TZ TZ TZ as opc - => fun args - => match interp_as_expr_or_const args with - | Some (const_of l, const_of r) - => Op (OpConst (interp_op _ _ opc (l, r))) TT - | Some (gen_expr e, const_of v) - => if (v =? 0)%Z - then e - else Op opc args - | Some (neg_expr e, const_of v) - => if (v =? 0)%Z - then Op (Opp _ _) e - else Op opc args - | _ => Op opc args - end - | Land TZ TZ TZ as opc - => fun args - => match interp_as_expr_or_const args with - | Some (const_of l, const_of r) - => Op (OpConst (interp_op _ _ opc (l, r))) TT - | Some (const_of v, gen_expr _) - | Some (gen_expr _, const_of v) - | Some (const_of v, neg_expr _) - | Some (neg_expr _, const_of v) - => if (v =? 0)%Z - then Op (OpConst 0%Z) TT - else Op opc args - | _ => Op opc args - end - | Lor TZ TZ TZ as opc - => fun args - => match interp_as_expr_or_const args with - | Some (const_of l, const_of r) - => Op (OpConst (interp_op _ _ opc (l, r))) TT - | Some (const_of v, gen_expr e) - | Some (gen_expr e, const_of v) - => if (v =? 0)%Z - then e - else Op opc args - | Some (const_of v, neg_expr e) - | Some (neg_expr e, const_of v) - => if (v =? 0)%Z - then Op (Opp _ _) e - else Op opc args - | _ => Op opc args - end - | Opp TZ TZ as opc - => fun args - => match interp_as_expr_or_const args with - | Some (const_of v) - => Op (OpConst (interp_op _ _ opc v)) TT - | Some (neg_expr e) - => e - | _ - => Op opc args - end - | Add _ _ _ as opc - | Sub _ _ _ as opc - | Mul _ _ _ as opc - | Shl _ _ _ as opc - | Shr _ _ _ as opc - | Land _ _ _ as opc - | Lor _ _ _ as opc - | OpConst _ _ as opc - | Opp _ _ as opc - => Op opc - end. - End with_var. - - Definition SimplifyArith {t} (e : Expr t) : Expr t - := @RewriteOp base_type op (@simplify_op_expr) t e. -End language. diff --git a/src/Reflection/Z/ArithmeticSimplifierInterp.v b/src/Reflection/Z/ArithmeticSimplifierInterp.v deleted file mode 100644 index 0c77d8179..000000000 --- a/src/Reflection/Z/ArithmeticSimplifierInterp.v +++ /dev/null @@ -1,120 +0,0 @@ -Require Import Coq.micromega.Psatz. -Require Import Coq.ZArith.ZArith. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.TypeInversion. -Require Import Crypto.Reflection.ExprInversion. -Require Import Crypto.Reflection.RewriterInterp. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.OpInversion. -Require Import Crypto.Reflection.Z.ArithmeticSimplifier. -Require Import Crypto.Reflection.Z.ArithmeticSimplifierUtil. -Require Import Crypto.Reflection.Z.Syntax.Equality. -Require Import Crypto.Util.ZUtil. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Prod. -Require Import Crypto.Util.Sum. -Require Import Crypto.Util.HProp. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.DestructHead. - -Local Notation exprf := (@exprf base_type op interp_base_type). -Local Notation expr := (@expr base_type op interp_base_type). -Local Notation Expr := (@Expr base_type op). - -Local Ltac fin_t := - first [ exact I - | reflexivity - | congruence - | assumption - | lia - | exfalso; assumption ]. -Local Ltac break_t_step := - first [ progress subst - | progress inversion_option - | progress inversion_sum - | progress inversion_expr - | progress inversion_prod - | progress inversion_inverted_expr - | progress inversion_flat_type - | progress destruct_head'_and - | progress destruct_head'_prod - | progress eliminate_hprop_eq - | progress break_innermost_match_step - | progress break_match_hyps ]. - - -Lemma interp_as_expr_or_const_correct_base {t} e z - : @interp_as_expr_or_const interp_base_type (Tbase t) e = Some z - -> interpf interp_op e = match z with - | const_of z => cast_const (t1:=TZ) z - | gen_expr e => interpf interp_op e - | neg_expr e => interpf interp_op (Op (Opp _ _) e) - end. -Proof. - destruct z. - { repeat first [ fin_t - | progress simpl in * - | progress intros - | break_t_step - | progress invert_expr - | progress invert_op ]. } - { do 2 (invert_expr; break_innermost_match; intros); - repeat first [ fin_t - | progress simpl in * - | progress intros - | break_t_step - | progress invert_op ]. } - { do 2 (invert_expr; break_innermost_match; intros); - repeat first [ fin_t - | progress simpl in * - | progress intros - | break_t_step - | progress invert_op ]. } -Qed. - -Lemma interp_as_expr_or_const_correct_prod_base {A B} e (v : _ * _) - : @interp_as_expr_or_const interp_base_type (Prod (Tbase A) (Tbase B)) e = Some v - -> interpf interp_op e = (match fst v with - | const_of z => cast_const (t1:=TZ) z - | gen_expr e => interpf interp_op e - | neg_expr e => interpf interp_op (Op (Opp _ _) e) - end, - match snd v with - | const_of z => cast_const (t1:=TZ) z - | gen_expr e => interpf interp_op e - | neg_expr e => interpf interp_op (Op (Opp _ _) e) - end). -Proof. - invert_expr; - repeat first [ fin_t - | progress simpl in * - | progress intros - | break_t_step - | erewrite !interp_as_expr_or_const_correct_base by eassumption; cbv beta iota ]. -Qed. - -Local Arguments Z.mul !_ !_. -Local Arguments Z.add !_ !_. -Local Arguments Z.sub !_ !_. -Local Arguments Z.opp !_. - -Lemma InterpSimplifyArith {t} (e : Expr t) - : forall x, Interp interp_op (SimplifyArith e) x = Interp interp_op e x. -Proof. - apply InterpRewriteOp; intros; unfold simplify_op_expr. - break_innermost_match; - repeat first [ fin_t - | progress simpl in * - | progress subst - | erewrite !interp_as_expr_or_const_correct_prod_base by eassumption; cbv beta iota - | erewrite !interp_as_expr_or_const_correct_base by eassumption; cbv beta iota - | match goal with - | [ |- context[interpf _ ?e] ] - => erewrite !(@interp_as_expr_or_const_correct_base _ e) by eassumption; cbv beta iota - end - | progress unfold interp_op, lift_op - | progress Z.ltb_to_lt - | progress rewrite ?Z.land_0_l, ?Z.land_0_r, ?Z.lor_0_l, ?Z.lor_0_r ]. -Qed. - -Hint Rewrite @InterpSimplifyArith : reflective_interp. diff --git a/src/Reflection/Z/ArithmeticSimplifierUtil.v b/src/Reflection/Z/ArithmeticSimplifierUtil.v deleted file mode 100644 index 10cf87eaa..000000000 --- a/src/Reflection/Z/ArithmeticSimplifierUtil.v +++ /dev/null @@ -1,79 +0,0 @@ -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.ArithmeticSimplifier. - -(** ** Equality for [inverted_expr] *) -Section inverted_expr. - Context {var : base_type -> Type}. - Local Notation inverted_expr := (@inverted_expr var). - Local Notation inverted_expr_code u v - := (match u, v with - | const_of u', const_of v' - | gen_expr u', gen_expr v' - | neg_expr u', neg_expr v' - => u' = v' - | const_of _, _ - | gen_expr _, _ - | neg_expr _, _ - => False - end). - - (** *** Equality of [inverted_expr] is a [match] *) - Definition path_inverted_expr {T} (u v : inverted_expr T) (p : inverted_expr_code u v) - : u = v. - Proof. destruct u, v; first [ apply f_equal | exfalso ]; exact p. Defined. - - (** *** Equivalence of equality of [inverted_expr] with [inverted_expr_code] *) - Definition unpath_inverted_expr {T} {u v : inverted_expr T} (p : u = v) - : inverted_expr_code u v. - Proof. subst v; destruct u; reflexivity. Defined. - - Definition path_inverted_expr_iff {T} - (u v : @inverted_expr T) - : u = v <-> inverted_expr_code u v. - Proof. - split; [ apply unpath_inverted_expr | apply path_inverted_expr ]. - Defined. - - (** *** Eta-expansion of [@eq (inverted_expr _ _)] *) - Definition path_inverted_expr_eta {T} {u v : @inverted_expr T} (p : u = v) - : p = path_inverted_expr u v (unpath_inverted_expr p). - Proof. destruct u, p; reflexivity. Defined. - - (** *** Induction principle for [@eq (inverted_expr _ _)] *) - Definition path_inverted_expr_rect {T} {u v : @inverted_expr T} (P : u = v -> Type) - (f : forall p, P (path_inverted_expr u v p)) - : forall p, P p. - Proof. intro p; specialize (f (unpath_inverted_expr p)); destruct u, p; exact f. Defined. - Definition path_inverted_expr_rec {T u v} (P : u = v :> @inverted_expr T -> Set) := path_inverted_expr_rect P. - Definition path_inverted_expr_ind {T u v} (P : u = v :> @inverted_expr T -> Prop) := path_inverted_expr_rec P. -End inverted_expr. - -(** ** Useful Tactics *) -(** *** [inversion_inverted_expr] *) -Ltac induction_path_inverted_expr H := - induction H as [H] using path_inverted_expr_rect; - try match type of H with - | False => exfalso; exact H - end. -Ltac inversion_inverted_expr_step := - match goal with - | [ H : const_of _ _ = const_of _ _ |- _ ] - => induction_path_inverted_expr H - | [ H : const_of _ _ = gen_expr _ _ |- _ ] - => induction_path_inverted_expr H - | [ H : const_of _ _ = neg_expr _ _ |- _ ] - => induction_path_inverted_expr H - | [ H : gen_expr _ _ = const_of _ _ |- _ ] - => induction_path_inverted_expr H - | [ H : gen_expr _ _ = gen_expr _ _ |- _ ] - => induction_path_inverted_expr H - | [ H : gen_expr _ _ = neg_expr _ _ |- _ ] - => induction_path_inverted_expr H - | [ H : neg_expr _ _ = const_of _ _ |- _ ] - => induction_path_inverted_expr H - | [ H : neg_expr _ _ = gen_expr _ _ |- _ ] - => induction_path_inverted_expr H - | [ H : neg_expr _ _ = neg_expr _ _ |- _ ] - => induction_path_inverted_expr H - end. -Ltac inversion_inverted_expr := repeat inversion_inverted_expr_step. diff --git a/src/Reflection/Z/ArithmeticSimplifierWf.v b/src/Reflection/Z/ArithmeticSimplifierWf.v deleted file mode 100644 index 70e47f24f..000000000 --- a/src/Reflection/Z/ArithmeticSimplifierWf.v +++ /dev/null @@ -1,168 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.WfInversion. -Require Import Crypto.Reflection.TypeInversion. -Require Import Crypto.Reflection.ExprInversion. -Require Import Crypto.Reflection.RewriterWf. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.OpInversion. -Require Import Crypto.Reflection.Z.ArithmeticSimplifier. -Require Import Crypto.Reflection.Z.Syntax.Equality. -Require Import Crypto.Util.ZUtil. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Sum. -Require Import Crypto.Util.Prod. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Tactics.SpecializeBy. -Require Import Crypto.Util.HProp. - -Local Notation exprf := (@exprf base_type op). -Local Notation expr := (@expr base_type op). -Local Notation Expr := (@Expr base_type op). -Local Notation wff := (@wff base_type op). -Local Notation Wf := (@Wf base_type op). - -Local Ltac fin_t := - first [ exact I - | reflexivity - | congruence - | assumption - | exfalso; assumption ]. -Local Ltac break_t_step := - first [ progress subst - | progress inversion_option - | progress inversion_sum - | progress inversion_expr - | progress inversion_prod - | progress invert_op - | progress inversion_flat_type - | progress destruct_head'_and - | progress destruct_head' iff - | progress destruct_head'_prod - | progress destruct_head'_sig - | progress specialize_by reflexivity - | progress eliminate_hprop_eq - | progress break_innermost_match_step - | progress break_match_hyps - | progress inversion_wf_constr ]. - - -Lemma interp_as_expr_or_const_None_iff {var1 var2 t} {G e1 e2} - (Hwf : @wff var1 var2 G t e1 e2) - : @interp_as_expr_or_const var1 t e1 = None - <-> @interp_as_expr_or_const var2 t e2 = None. -Proof. - induction Hwf; - repeat first [ fin_t - | split; congruence - | progress simpl in * - | progress intros - | break_t_step ]. -Qed. - -Lemma interp_as_expr_or_const_None_Some {var1 var2 t} {G e1 e2 v} - (Hwf : @wff var1 var2 G t e1 e2) - : @interp_as_expr_or_const var1 t e1 = None - -> @interp_as_expr_or_const var2 t e2 = Some v - -> False. -Proof. - erewrite interp_as_expr_or_const_None_iff by eassumption; congruence. -Qed. - -Lemma interp_as_expr_or_const_Some_None {var1 var2 t} {G e1 e2 v} - (Hwf : @wff var1 var2 G t e1 e2) - : @interp_as_expr_or_const var1 t e1 = Some v - -> @interp_as_expr_or_const var2 t e2 = None - -> False. -Proof. - erewrite <- interp_as_expr_or_const_None_iff by eassumption; congruence. -Qed. - -Lemma wff_interp_as_expr_or_const_base {var1 var2 t} {G e1 e2 v1 v2} - (Hwf : @wff var1 var2 G (Tbase t) e1 e2) - : @interp_as_expr_or_const var1 (Tbase t) e1 = Some v1 - -> @interp_as_expr_or_const var2 (Tbase t) e2 = Some v2 - -> match v1, v2 with - | const_of z1, const_of z2 => z1 = z2 - | gen_expr e1, gen_expr e2 - | neg_expr e1, neg_expr e2 - => wff G e1 e2 - | const_of _, _ - | gen_expr _, _ - | neg_expr _, _ - => False - end. -Proof. - invert_one_expr e1; intros; break_innermost_match; intros; - try invert_one_expr e2; intros; - repeat first [ fin_t - | progress simpl in * - | progress intros - | break_t_step - | match goal with - | [ H : wff _ _ ?e |- _ ] => is_var e; invert_one_expr e - end ]. -Qed. - -Lemma wff_interp_as_expr_or_const_prod_base {var1 var2 A B} {G e1 e2} {v1 v2 : _ * _} - (Hwf : wff G e1 e2) - : @interp_as_expr_or_const var1 (Prod (Tbase A) (Tbase B)) e1 = Some v1 - -> @interp_as_expr_or_const var2 (Prod (Tbase A) (Tbase B)) e2 = Some v2 - -> match fst v1, fst v2 with - | const_of z1, const_of z2 => z1 = z2 - | gen_expr e1, gen_expr e2 - | neg_expr e1, neg_expr e2 - => wff G e1 e2 - | const_of _, _ - | gen_expr _, _ - | neg_expr _, _ - => False - end - /\ match snd v1, snd v2 with - | const_of z1, const_of z2 => z1 = z2 - | gen_expr e1, gen_expr e2 - | neg_expr e1, neg_expr e2 - => wff G e1 e2 - | const_of _, _ - | gen_expr _, _ - | neg_expr _, _ - => False - end. -Proof. - invert_one_expr e1; intros; break_innermost_match; intros; try exact I; - try invert_one_expr e2; intros; break_innermost_match; intros; try exact I; - repeat first [ fin_t - | progress simpl in * - | break_t_step - | match goal with - | [ H1 : _ = Some _, H2 : _ = Some _, Hwf : wff _ _ _ |- _ ] - => pose proof (wff_interp_as_expr_or_const_base Hwf H1 H2); clear H1 H2 - | [ |- and _ _ ] => split - end ]. -Qed. - -Lemma Wf_SimplifyArith {t} (e : Expr t) - (Hwf : Wf e) - : Wf (SimplifyArith e). -Proof. - apply Wf_RewriteOp; [ | assumption ]. - intros ???????? Hwf'; unfold simplify_op_expr; - break_innermost_match; repeat constructor; auto; - repeat first [ fin_t - | progress simpl in * - | progress subst - | progress Z.ltb_to_lt - | match goal with - | [ H1 : _ = Some _, H2 : _ = Some _, Hwf : wff _ _ _ |- _ ] - => pose proof (wff_interp_as_expr_or_const_base Hwf H1 H2); clear H1 H2 - | [ H1 : _ = Some _, H2 : _ = Some _, Hwf : wff _ _ _ |- _ ] - => pose proof (wff_interp_as_expr_or_const_prod_base Hwf H1 H2); clear H1 H2 - | [ H1 : _ = Some _, H2 : _ = None, Hwf : wff _ _ _ |- _ ] - => pose proof (interp_as_expr_or_const_Some_None Hwf H1 H2); clear H1 H2 - | [ H1 : _ = None, H2 : _ = Some _, Hwf : wff _ _ _ |- _ ] - => pose proof (interp_as_expr_or_const_None_Some Hwf H1 H2); clear H1 H2 - | [ |- wff _ _ _ ] => constructor - end - | break_t_step ]. -Qed. diff --git a/src/Reflection/Z/BinaryNotationConstants.v b/src/Reflection/Z/BinaryNotationConstants.v deleted file mode 100644 index 32a993e08..000000000 --- a/src/Reflection/Z/BinaryNotationConstants.v +++ /dev/null @@ -1,91 +0,0 @@ -Require Export Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Z.Syntax. -Require Export Bedrock.Word. -Require Export Crypto.Util.Notations. - -Local Notation Const x := (Op (OpConst x) TT). -(* python: -<< -print('\n'.join('''Notation "'%s'" (* %d (%s) *)\n := (Const %s).''' % (b, d, h, i) - for d, h, b, i in sorted([(eval(bv), hex(eval(bv)), bv, i) - for (bv, i) in (('0b' + i[2:].replace('~', ''), i) - for i in r"""WO~0~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1 -WO~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~1~1~0~1~0 -WO~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0 -WO~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1 -WO~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0 -WO~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1 -WO~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~1~1~0~1~0 -WO~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~1~1~1~0 -WO~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0 -WO~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1 -WO~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0 -WO~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1 -WO~0~0~0~1~0~0~1~1 -WO~0~0~0~1~1~0~0~1 -WO~0~0~0~1~1~0~1~0 -WO~0~0~0~1~1~0~1~1 -WO~0~0~0~1~1~1~0~0 -WO~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~1~0 -WO~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0 -WO~0~0~1~1~0~0~1~1 -WO~1~0 -WO~1~0~0~1 -WO~0~0~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1 -WO~0~0~0~1~0~0~0~1 -WO~0~0~0~1~0~1~1~1 -WO~1~1""".split('\n'))]))) ->> - *) -Notation "'0b10'" (* 2 (0x2) *) - := (Const WO~1~0). -Notation "'0b11'" (* 3 (0x3) *) - := (Const WO~1~1). -Notation "'0b1001'" (* 9 (0x9) *) - := (Const WO~1~0~0~1). -Notation "'0b00010001'" (* 17 (0x11) *) - := (Const WO~0~0~0~1~0~0~0~1). -Notation "'0b00010011'" (* 19 (0x13) *) - := (Const WO~0~0~0~1~0~0~1~1). -Notation "'0b00010111'" (* 23 (0x17) *) - := (Const WO~0~0~0~1~0~1~1~1). -Notation "'0b00011001'" (* 25 (0x19) *) - := (Const WO~0~0~0~1~1~0~0~1). -Notation "'0b00011010'" (* 26 (0x1a) *) - := (Const WO~0~0~0~1~1~0~1~0). -Notation "'0b00011011'" (* 27 (0x1b) *) - := (Const WO~0~0~0~1~1~0~1~1). -Notation "'0b00011100'" (* 28 (0x1c) *) - := (Const WO~0~0~0~1~1~1~0~0). -Notation "'0b00110011'" (* 51 (0x33) *) - := (Const WO~0~0~1~1~0~0~1~1). -Notation "'0b00000000011111111111111111111111'" (* 8388607 (0x7fffff) *) - := (Const WO~0~0~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1). -Notation "'0b00000001111111111111111111111111'" (* 33554431 (0x1ffffff) *) - := (Const WO~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1). -Notation "'0b00000011111111111111111111111110'" (* 67108862 (0x3fffffe) *) - := (Const WO~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0). -Notation "'0b00000011111111111111111111111111'" (* 67108863 (0x3ffffff) *) - := (Const WO~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1). -Notation "'0b00000111111111111111111111011010'" (* 134217690 (0x7ffffda) *) - := (Const WO~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~1~1~0~1~0). -Notation "'0b00000111111111111111111111101110'" (* 134217710 (0x7ffffee) *) - := (Const WO~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~1~1~1~0). -Notation "'0b00000111111111111111111111111110'" (* 134217726 (0x7fffffe) *) - := (Const WO~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0). -Notation "'0b00000111111111111111111111111111'" (* 134217727 (0x7ffffff) *) - := (Const WO~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1). -Notation "'0b00001111111111111111111111111110'" (* 268435454 (0xffffffe) *) - := (Const WO~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0). -Notation "'0b00001111111111111111111111111111'" (* 268435455 (0xfffffff) *) - := (Const WO~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1). -Notation "'0b00011111111111111111111111111010'" (* 536870906 (0x1ffffffa) *) - := (Const WO~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~1~0). -Notation "'0b00011111111111111111111111111110'" (* 536870910 (0x1ffffffe) *) - := (Const WO~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0). -Notation "'0b0000000000000111111111111111111111111111111111111111111111111111'" (* 2251799813685247 (0x7ffffffffffffL) *) - := (Const WO~0~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1). -Notation "'0b0000000000001111111111111111111111111111111111111111111111011010'" (* 4503599627370458 (0xfffffffffffdaL) *) - := (Const WO~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~1~1~0~1~0). -Notation "'0b0000000000001111111111111111111111111111111111111111111111111110'" (* 4503599627370494 (0xffffffffffffeL) *) - := (Const WO~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0). diff --git a/src/Reflection/Z/Bounds/Interpretation.v b/src/Reflection/Z/Bounds/Interpretation.v deleted file mode 100644 index 69670bee0..000000000 --- a/src/Reflection/Z/Bounds/Interpretation.v +++ /dev/null @@ -1,177 +0,0 @@ -Require Import Coq.ZArith.ZArith. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Util.Notations. -Require Import Crypto.Util.Decidable. -Require Import Crypto.Util.ZRange. -Require Import Crypto.Util.Tactics.DestructHead. -Export Reflection.Syntax.Notations. - -Local Notation eta x := (fst x, snd x). -Local Notation eta3 x := (eta (fst x), snd x). -Local Notation eta4 x := (eta3 (fst x), snd x). - -Notation bounds := zrange. -Delimit Scope bounds_scope with bounds. -Local Open Scope Z_scope. - -Module Import Bounds. - Definition t := bounds. - Bind Scope bounds_scope with t. - Local Coercion Z.of_nat : nat >-> Z. - Section with_bitwidth. - Context (bit_width : option Z). - Definition four_corners (f : Z -> Z -> Z) : t -> t -> t - := fun x y - => let (lx, ux) := x in - let (ly, uy) := y in - {| lower := Z.min (f lx ly) (Z.min (f lx uy) (Z.min (f ux ly) (f ux uy))); - upper := Z.max (f lx ly) (Z.max (f lx uy) (Z.max (f ux ly) (f ux uy))) |}. - Definition two_corners (f : Z -> Z) : t -> t - := fun x - => let (lx, ux) := x in - {| lower := Z.min (f lx) (f ux); - upper := Z.max (f lx) (f ux) |}. - Definition truncation_bounds (b : t) - := match bit_width with - | Some bit_width => if ((0 <=? lower b) && (upper b <? 2^bit_width))%bool - then b - else {| lower := 0 ; upper := 2^bit_width - 1 |} - | None => b - end. - Definition BuildTruncated_bounds (l u : Z) : t - := truncation_bounds {| lower := l ; upper := u |}. - Definition t_map1 (f : Z -> Z) (x : t) - := truncation_bounds (two_corners f x). - Definition t_map2 (f : Z -> Z -> Z) : t -> t -> t - := fun x y => truncation_bounds (four_corners f x y). - Definition t_map4 (f : bounds -> bounds -> bounds -> bounds -> bounds) (x y z w : t) - := truncation_bounds (f x y z w). - Definition add : t -> t -> t := t_map2 Z.add. - Definition sub : t -> t -> t := t_map2 Z.sub. - Definition mul : t -> t -> t := t_map2 Z.mul. - Definition shl : t -> t -> t := t_map2 Z.shiftl. - Definition shr : t -> t -> t := t_map2 Z.shiftr. - Definition extreme_lor_land_bounds (x y : t) : t - := let (lx, ux) := x in - let (ly, uy) := y in - let lx := Z.abs lx in - let ly := Z.abs ly in - let ux := Z.abs ux in - let uy := Z.abs uy in - let max := Z.max (Z.max lx ly) (Z.max ux uy) in - {| lower := -2^(1 + Z.log2_up max) ; upper := 2^(1 + Z.log2_up max) |}. - Definition extermization_bounds (f : t -> t -> t) (x y : t) : t - := truncation_bounds - (let (lx, ux) := x in - let (ly, uy) := y in - if ((lx <? 0) || (ly <? 0))%Z%bool - then extreme_lor_land_bounds x y - else f x y). - Definition land : t -> t -> t - := extermization_bounds - (fun x y - => let (lx, ux) := x in - let (ly, uy) := y in - {| lower := Z.min 0 (Z.min lx ly) ; upper := Z.max 0 (Z.min ux uy) |}). - Definition lor : t -> t -> t - := extermization_bounds - (fun x y - => let (lx, ux) := x in - let (ly, uy) := y in - {| lower := Z.max lx ly; - upper := 2^(Z.max (Z.log2_up (ux+1)) (Z.log2_up (uy+1))) - 1 |}). - Definition opp : t -> t := t_map1 Z.opp. - Definition neg' (int_width : Z) : t -> t - := fun v - => let (lb, ub) := v in - let might_be_one := ((lb <=? 1) && (1 <=? ub))%Z%bool in - let must_be_one := ((lb =? 1) && (ub =? 1))%Z%bool in - if must_be_one - then {| lower := Z.ones int_width ; upper := Z.ones int_width |} - else if might_be_one - then {| lower := Z.min 0 (Z.ones int_width) ; upper := Z.max 0 (Z.ones int_width) |} - else {| lower := 0 ; upper := 0 |}. - Definition neg (int_width : Z) : t -> t - := fun v - => truncation_bounds (neg' int_width v). - Definition cmovne' (r1 r2 : t) : t - := let (lr1, ur1) := r1 in - let (lr2, ur2) := r2 in - {| lower := Z.min lr1 lr2 ; upper := Z.max ur1 ur2 |}. - Definition cmovne (x y r1 r2 : t) : t - := truncation_bounds (cmovne' r1 r2). - Definition cmovle' (r1 r2 : t) : t - := let (lr1, ur1) := r1 in - let (lr2, ur2) := r2 in - {| lower := Z.min lr1 lr2 ; upper := Z.max ur1 ur2 |}. - Definition cmovle (x y r1 r2 : t) : t - := truncation_bounds (cmovle' r1 r2). - End with_bitwidth. - - Module Export Notations. - Export Util.ZRange.Notations. - Infix "+" := (add _) : bounds_scope. - Infix "-" := (sub _) : bounds_scope. - Infix "*" := (mul _) : bounds_scope. - Infix "<<" := (shl _) : bounds_scope. - Infix ">>" := (shr _) : bounds_scope. - Infix "&'" := (land _) : bounds_scope. - Notation "- x" := (opp _ x) : bounds_scope. - End Notations. - - Definition interp_base_type (ty : base_type) : Set := t. - - Definition bit_width_of_base_type ty : option Z - := match ty with - | TZ => None - | TWord logsz => Some (2^Z.of_nat logsz)%Z - end. - - Definition interp_op {src dst} (f : op src dst) : interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst - := match f in op src dst return interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst with - | OpConst T v => fun _ => BuildTruncated_bounds (bit_width_of_base_type T) v v - | Add _ _ T => fun xy => add (bit_width_of_base_type T) (fst xy) (snd xy) - | Sub _ _ T => fun xy => sub (bit_width_of_base_type T) (fst xy) (snd xy) - | Mul _ _ T => fun xy => mul (bit_width_of_base_type T) (fst xy) (snd xy) - | Shl _ _ T => fun xy => shl (bit_width_of_base_type T) (fst xy) (snd xy) - | Shr _ _ T => fun xy => shr (bit_width_of_base_type T) (fst xy) (snd xy) - | Land _ _ T => fun xy => land (bit_width_of_base_type T) (fst xy) (snd xy) - | Lor _ _ T => fun xy => lor (bit_width_of_base_type T) (fst xy) (snd xy) - | Opp _ T => fun x => opp (bit_width_of_base_type T) x - end%bounds. - - Definition of_Z (z : Z) : t := ZToZRange z. - - Definition of_interp t (z : Syntax.interp_base_type t) : interp_base_type t - := ZToZRange (interpToZ z). - - Definition bounds_to_base_type (b : t) : base_type - := if (0 <=? lower b)%Z - then TWord (Z.to_nat (Z.log2_up (Z.log2_up (1 + upper b)))) - else TZ. - - Definition ComputeBounds {t} (e : Expr base_type op t) - (input_bounds : interp_flat_type interp_base_type (domain t)) - : interp_flat_type interp_base_type (codomain t) - := Interp (@interp_op) e input_bounds. - - Definition is_tighter_thanb' {T} : interp_base_type T -> interp_base_type T -> bool - := is_tighter_than_bool. - - Definition is_bounded_by' {T} : interp_base_type T -> Syntax.interp_base_type T -> Prop - := fun bounds val => is_bounded_by' (bit_width_of_base_type T) bounds (interpToZ val). - - Definition is_tighter_thanb {T} : interp_flat_type interp_base_type T -> interp_flat_type interp_base_type T -> bool - := interp_flat_type_relb_pointwise (@is_tighter_thanb'). - - Definition is_bounded_by {T} : interp_flat_type interp_base_type T -> interp_flat_type Syntax.interp_base_type T -> Prop - := interp_flat_type_rel_pointwise (@is_bounded_by'). - - Local Arguments interp_base_type !_ / . - Global Instance dec_eq_interp_flat_type {T} : DecidableRel (@eq (interp_flat_type interp_base_type T)) | 10. - Proof. - induction T; destruct_head base_type; simpl; exact _. - Defined. -End Bounds. diff --git a/src/Reflection/Z/Bounds/InterpretationLemmas.v b/src/Reflection/Z/Bounds/InterpretationLemmas.v deleted file mode 100644 index 11a6ea91e..000000000 --- a/src/Reflection/Z/Bounds/InterpretationLemmas.v +++ /dev/null @@ -1,433 +0,0 @@ -Require Import Coq.ZArith.ZArith. -Require Import Coq.micromega.Psatz. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.Syntax.Util. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Z.Bounds.Interpretation. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Util.ZUtil. -Require Import Crypto.Util.Bool. -Require Import Crypto.Util.FixedWordSizesEquality. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Tactics.SpecializeBy. -Require Import Crypto.Util.Tactics.SplitInContext. -Require Import Crypto.Util.Tactics.UniquePose. - -Local Notation pick_typeb := Bounds.bounds_to_base_type (only parsing). -Local Notation pick_type v := (SmartFlatTypeMap (fun _ => pick_typeb) v). - -Local Open Scope Z_scope. - -Local Ltac break_t_step := - first [ progress destruct_head'_and - | progress destruct_head'_or - | progress destruct_head'_prod - | progress split_andb - | break_innermost_match_step ]. - -Local Ltac fin_t := - first [ reflexivity - | assumption - | match goal with - | [ |- and _ _ ] - => first [ split; [ | solve [ fin_t ] ] - | split; [ solve [ fin_t ] | ] ]; - try solve [ fin_t ] - end - | omega ]. - -Local Ltac specializer_t_step := - first [ progress specialize_by_assumption - | progress specialize_by fin_t ]. - -Local Ltac Zarith_t_step := - first [ match goal with - | [ H : (?x <= ?y)%Z, H' : (?y <= ?x)%Z |- _ ] - => assert (x = y) by omega; clear H H' - end - | progress Z.ltb_to_lt_in_context ]. -Local Ltac Zarith_land_lor_t_step := - match goal with - | [ |- _ <= Z.lor _ _ <= _ ] - => split; etransitivity; [ | apply Z.lor_bounds; omega | apply Z.lor_bounds; omega | ] - | [ |- 2^Z.log2_up (?x + 1) - 1 <= 2^Z.log2_up (?y + 1) - 1 ] - => let H := fresh in assert (H : x <= y) by omega; rewrite H; reflexivity - end. -Local Ltac word_arith_t := - match goal with - | [ |- (0 <= FixedWordSizes.wordToZ ?w <= 2^2^Z.of_nat ?logsz - 1)%Z ] - => clear; pose proof (@wordToZ_range logsz w); autorewrite with push_Zof_nat zsimplify_const in *; try omega - end. - -Local Ltac revert_min_max := - repeat match goal with - | [ H : context[Z.min _ _] |- _ ] => revert H - | [ H : context[Z.max _ _] |- _ ] => revert H - end. -Local Ltac split_min_max := - repeat match goal with - | [ H : (?a <= ?b)%Z |- context[Z.max ?a ?b] ] - => rewrite (Z.max_r a b) by omega - | [ H : (?b <= ?a)%Z |- context[Z.max ?a ?b] ] - => rewrite (Z.max_l a b) by omega - | [ H : (?a <= ?b)%Z |- context[Z.min ?a ?b] ] - => rewrite (Z.min_l a b) by omega - | [ H : (?b <= ?a)%Z |- context[Z.min ?a ?b] ] - => rewrite (Z.min_r a b) by omega - | [ |- context[Z.max ?a ?b] ] - => first [ rewrite (Z.max_l a b) by omega - | rewrite (Z.max_r a b) by omega ] - | [ |- context[Z.min ?a ?b] ] - => first [ rewrite (Z.min_l a b) by omega - | rewrite (Z.min_r a b) by omega ] - | _ => revert_min_max; progress repeat apply Z.min_case_strong; intros - | _ => revert_min_max; progress repeat apply Z.max_case_strong; intros - end. - -Local Ltac case_Zvar_nonneg_on x := - is_var x; - lazymatch type of x with - | Z => lazymatch goal with - | [ H : (0 <= x)%Z |- _ ] => fail - | [ H : (x < 0)%Z |- _ ] => fail - | _ => destruct (Z_lt_le_dec x 0); try omega - end - end. -Local Ltac case_Zvar_nonneg_step := - match goal with - | [ |- context[?x] ] - => case_Zvar_nonneg_on x - end. -Local Ltac case_Zvar_nonneg := repeat case_Zvar_nonneg_step. - -Local Ltac remove_binary_operation_le_hyps_step := - match goal with - | [ H : (?f ?x ?y <= ?f ?x ?y')%Z |- _ ] - => assert ((y = y') \/ (y < y' /\ 0 <= x))%Z by (assert (y <= y')%Z by omega; nia); - clear H - | [ H : (?f ?y ?x <= ?f ?y' ?x)%Z |- _ ] - => assert ((y = y') \/ (y < y' /\ 0 <= x))%Z by (assert (y <= y')%Z by omega; nia); - clear H - | [ H : (?f ?x ?y <= ?f ?x ?y')%Z |- _ ] - => assert ((y = y') \/ (y' < y /\ x <= 0))%Z by (assert (y' <= y)%Z by omega; nia); - clear H - | [ H : (?f ?y ?x <= ?f ?y' ?x)%Z |- _ ] - => assert ((y = y') \/ (y' < y /\ x <= 0))%Z by (assert (y' <= y)%Z by omega; nia); - clear H - | [ H : ?T, H' : ?T |- _ ] => clear H' - | [ H : ?A \/ (~?A /\ ?B), H' : ?A \/ (~?A /\ ?C) |- _ ] - => assert (A \/ (~A /\ (B /\ C))) by (clear -H H'; tauto); clear H H' - | _ => progress destruct_head' or; destruct_head' and; subst; try omega - | [ |- (_ <= _ <= _)%Z ] => split - | _ => case_Zvar_nonneg_step - end. - -Local Ltac saturate_with_shift_facts := - repeat match goal with - | [ H : ?x <= ?y, H' : ?x' <= ?y' |- context[?x << ?x'] ] - => unique assert (x << x' <= y << y') by (apply Z.shiftl_le_mono; omega) - | [ H : ?x <= ?y, H' : ?x' <= ?y' |- context[?y << ?y'] ] - => unique assert (x << x' <= y << y') by (apply Z.shiftl_le_mono; omega) - | [ H : ?x <= ?y, H' : ?x' <= ?y' |- context[?x >> ?x'] ] - => unique assert (x >> x' <= y >> y') by (apply Z.shiftr_le_mono; omega) - | [ H : ?x <= ?y, H' : ?x' <= ?y' |- context[?y >> ?y'] ] - => unique assert (x >> x' <= y >> y') by (apply Z.shiftr_le_mono; omega) - end. -Local Ltac saturate_with_all_shift_facts := - repeat match goal with - | _ => progress saturate_with_shift_facts - | [ H : ?x <= ?y, H' : ?x' <= ?y' |- context[Z.shiftl _ _] ] - => unique assert (x << x' <= y << y') by (apply Z.shiftl_le_mono; omega) - | [ H : ?x <= ?y, H' : ?x' <= ?y' |- context[Z.shiftr _ _] ] - => unique assert (x >> x' <= y >> y') by (apply Z.shiftr_le_mono; omega) - end. -Local Ltac saturate_land_lor_facts := - repeat match goal with - | [ |- context[Z.land ?x ?y] ] - => let H := fresh in - let H' := fresh in - assert (H : 0 <= x) by omega; - assert (H' : 0 <= y) by omega; - unique pose proof (Z.land_upper_bound_r x y H H'); - unique pose proof (Z.land_upper_bound_l x y H H') - | [ |- context[Z.land ?x ?y] ] - => unique assert (0 <= Z.land x y) by (apply Z.land_nonneg; omega) - | [ |- context[Z.land ?x ?y] ] - => case_Zvar_nonneg_on x; case_Zvar_nonneg_on y - | [ |- context[Z.lor ?x ?y] ] - => let H := fresh in - let H' := fresh in - assert (H : 0 <= x) by omega; - assert (H' : 0 <= y) by omega; - unique pose proof (proj1 (Z.lor_bounds x y H H')); - unique pose proof (proj2 (Z.lor_bounds x y H H')) - | [ |- context[Z.lor ?x ?y] ] - => unique assert (0 <= Z.lor x y) by (apply Z.lor_nonneg; omega) - | [ |- context[Z.lor ?x ?y] ] - => case_Zvar_nonneg_on x; case_Zvar_nonneg_on y - end. -Local Ltac clean_neg := - repeat match goal with - | [ H : (-?x) < 0 |- _ ] => assert (0 <= x) by omega; assert (x <> 0) by omega; clear H - | [ H : -?x <= -?y |- _ ] => apply Z.opp_le_mono in H - | [ |- -?x <= -?y ] => apply Z.opp_le_mono - | _ => progress rewrite <- Z.opp_le_mono in * - end. -Local Ltac replace_with_neg x := - assert (x = -(-x)) by omega; generalize dependent (-x); - let x' := fresh in - rename x into x'; intro x; intros; subst x'; - clean_neg. -Local Ltac replace_all_neg_with_pos := - repeat match goal with - | [ H : ?x < 0 |- _ ] => replace_with_neg x - end. -Local Ltac handle_shift_neg := - repeat first [ rewrite !Z.shiftr_opp_r - | rewrite !Z.shiftl_opp_r ]. - -Local Ltac handle_four_corners_step_fast := - first [ progress destruct_head Bounds.t - | progress cbv [Bounds.four_corners] in * - | progress subst - | Zarith_t_step - | progress split_min_max - | omega - | nia ]. -Local Ltac handle_four_corners_step := - first [ handle_four_corners_step_fast - | remove_binary_operation_le_hyps_step ]. -Local Ltac handle_four_corners := - lazymatch goal with - | [ |- (ZRange.lower (Bounds.four_corners _ _ _) <= _ <= _)%Z ] - => idtac - end; - repeat handle_four_corners_step. - -Local Ltac rewriter_t := - first [ rewrite !Bool.andb_true_iff - | rewrite !Bool.andb_false_iff - | rewrite !Bool.orb_true_iff - | rewrite !Bool.orb_false_iff - | rewrite !Z.abs_opp - | rewrite !Z.max_log2_up - | rewrite !Z.add_max_distr_r - | rewrite !Z.add_max_distr_l - | rewrite wordToZ_ZToWord by (autorewrite with push_Zof_nat zsimplify_const; omega) - | match goal with - | [ H : _ |- _ ] - => first [ rewrite !Bool.andb_true_iff in H - | rewrite !Bool.andb_false_iff in H - | rewrite !Bool.orb_true_iff in H - | rewrite !Bool.orb_false_iff in H ] - end ]. - -Local Arguments Bounds.is_bounded_by' !_ _ _ / . - -Lemma is_bounded_by_truncation_bounds Tout bs v - (H : Bounds.is_bounded_by (T:=Tbase TZ) bs v) - : Bounds.is_bounded_by (T:=Tbase Tout) - (Bounds.truncation_bounds (Bounds.bit_width_of_base_type Tout) bs) - (ZToInterp v). -Proof. - destruct bs as [l u]; cbv [Bounds.truncation_bounds Bounds.is_bounded_by Bounds.is_bounded_by' Bounds.bit_width_of_base_type ZRange.is_bounded_by'] in *; simpl in *. - repeat first [ break_t_step - | fin_t - | progress simpl in * - | Zarith_t_step - | rewriter_t - | word_arith_t ]. -Qed. - -Local Arguments Z.pow : simpl never. -Local Arguments Z.add !_ !_. -Local Existing Instances Z.add_le_Proper Z.log2_up_le_Proper Z.pow_Zpos_le_Proper Z.sub_le_eq_Proper. -Lemma is_bounded_by_interp_op t tR (opc : op t tR) - (bs : interp_flat_type Bounds.interp_base_type _) - (v : interp_flat_type interp_base_type _) - (H : Bounds.is_bounded_by bs v) - : Bounds.is_bounded_by (Bounds.interp_op opc bs) (Syntax.interp_op _ _ opc v). -Proof. - destruct opc; apply is_bounded_by_truncation_bounds; - repeat first [ progress simpl in * - | progress cbv [interp_op lift_op cast_const Bounds.interp_base_type Bounds.is_bounded_by' ZRange.is_bounded_by'] in * - | progress destruct_head'_prod - | progress destruct_head'_and - | omega - | match goal with - | [ |- context[interpToZ ?x] ] - => generalize dependent (interpToZ x); clear x; intros - | [ |- _ /\ True ] => split; [ | tauto ] - end ]. - { handle_four_corners. } - { handle_four_corners. } - { handle_four_corners. } - { destruct_head Bounds.t. - case_Zvar_nonneg; replace_all_neg_with_pos; handle_shift_neg; - autorewrite with Zshift_to_pow; - rewrite ?Z.div_opp_l_complete by auto with zarith; - autorewrite with Zpow_to_shift. - 16:split_min_max; saturate_with_shift_facts; omega. - all:admit. } - { destruct_head Bounds.t. - case_Zvar_nonneg; replace_all_neg_with_pos; handle_shift_neg; admit. } - { repeat first [ progress destruct_head Bounds.t - | progress simpl in * - | break_t_step - | Zarith_t_step - | rewriter_t - | progress replace_all_neg_with_pos - | progress saturate_land_lor_facts - | split_min_max; omega ]; - admit. } - { repeat first [ progress destruct_head Bounds.t - | progress simpl in * - | break_t_step - | Zarith_t_step - | rewriter_t - | progress replace_all_neg_with_pos - | progress saturate_land_lor_facts - | progress Zarith_land_lor_t_step - | solve [ split_min_max; try omega; try Zarith_land_lor_t_step ] ]; - admit. } - { repeat first [ progress destruct_head Bounds.t - | progress simpl in * - | progress split_min_max - | omega ]. } -Admitted. - -Local Arguments lift_op : simpl never. -Local Arguments cast_back_flat_const : simpl never. -Local Arguments unzify_op : simpl never. -Local Arguments Z.pow : simpl never. -Local Arguments Z.add !_ !_. -Local Existing Instance Z.pow_Zpos_le_Proper. -Lemma pull_cast_genericize_op t tR (opc : op t tR) - (bs : interp_flat_type Bounds.interp_base_type t) - (v : interp_flat_type interp_base_type (pick_type bs)) - (H : Bounds.is_bounded_by bs - (SmartFlatTypeMapUnInterp - (fun (t1 : base_type) (b0 : Bounds.interp_base_type t1) => cast_const) v)) - : interp_op t tR opc (cast_back_flat_const v) - = cast_back_flat_const (interp_op (pick_type bs) (pick_type (Bounds.interp_op opc bs)) (genericize_op opc) v). -Proof. - pose proof (is_bounded_by_interp_op t tR opc bs). - unfold interp_op in *. - rewrite Zinterp_op_genericize_op. - generalize dependent (Zinterp_op t tR opc). - generalize dependent (Bounds.interp_op opc bs); clear opc; simpl; intros. - revert dependent t; induction tR as [tR| |]; intros; - [ - | repeat first [ match goal with - | [ |- ?x = ?y ] - => transitivity tt; destruct x, y; reflexivity - end - | reflexivity - | progress simpl @Bounds.is_bounded_by in * - | rewrite !lift_op_prod_dst - | rewrite !cast_back_flat_const_prod - | progress split_and - | match goal with - | [ H : _ |- _ ] => first [ setoid_rewrite lift_op_prod_dst in H - | setoid_rewrite cast_back_flat_const_prod in H ] - end - | setoid_rewrite lift_op_prod_dst - | match goal with - | [ H : _ |- _ ] => erewrite H by eassumption - end ].. ]. - revert dependent tR; induction t as [t| |]; intros; - [ - | repeat first [ match goal with - | [ |- ?x = ?y ] - => transitivity tt; destruct x, y; reflexivity - end - | reflexivity - | progress simpl @Bounds.is_bounded_by in * - | rewrite !lift_op_prod_dst - | rewrite !cast_back_flat_const_prod - | progress split_and - | match goal with - | [ H : _ |- _ ] => first [ setoid_rewrite lift_op_prod_dst in H - | setoid_rewrite cast_back_flat_const_prod in H ] - end - | setoid_rewrite lift_op_prod_dst - | match goal with - | [ H : _ |- _ ] => erewrite H by eassumption - end ].. ]. - { simpl in *; unfold unzify_op, cast_back_flat_const, SmartFlatTypeMap, Bounds.interp_base_type, cast_const, Bounds.is_bounded_by', lift_op, SmartFlatTypeMapUnInterp, SmartFlatTypeMapInterp2, cast_const in *; simpl in *. - unfold Bounds.is_bounded_by', cast_const, ZToInterp, interpToZ, Bounds.bounds_to_base_type, ZRange.is_bounded_by' in *; simpl in *. - destruct_head base_type; break_innermost_match; Z.ltb_to_lt; destruct_head Bounds.t; - repeat match goal with - | _ => progress destruct_head'_and - | _ => reflexivity - | [ H : forall v, _ /\ True -> _ |- _ ] => specialize (fun v pf => H v (conj pf I)) - | [ H : forall v, _ -> _ /\ True |- _ ] => pose proof (fun v pf => proj1 (H v pf)); clear H - | [ H : True |- _ ] => clear H - | [ H : ?T, H' : ?T |- _ ] => clear H - | [ H : forall v, _ -> _ <= ?f v <= _ |- ?f ?v' = _ ] - => specialize (H v') - | [ H : forall v, _ -> _ <= ?f (?g v) <= _ |- ?f (?g ?v') = _ ] - => specialize (H v') - | [ H : forall v, _ -> _ <= ?f (?g (?h v)) <= _ /\ _ /\ _ |- context[?h ?v'] ] - => specialize (H v') - | [ H : forall v, _ -> _ <= ?f (?g (?h (?i v))) <= _ /\ _ /\ _ |- context[?h (?i ?v')] ] - => specialize (H v') - | _ => progress specialize_by omega - | _ => rewrite wordToZ_ZToWord - by repeat match goal with - | [ |- and _ _ ] => split - | [ |- ?x < ?y ] => cut (1 + x <= y); [ omega | ] - | _ => omega - | _ => progress autorewrite with push_Zof_nat zsimplify_const - | _ => rewrite Z2Nat.id by auto with zarith - | _ => rewrite <- !Z.log2_up_le_full - end - | _ => rewrite wordToZ_ZToWord in * - by repeat match goal with - | [ |- and _ _ ] => split - | [ |- ?x < ?y ] => cut (1 + x <= y); [ omega | ] - | _ => omega - | _ => progress autorewrite with push_Zof_nat zsimplify_const - | _ => rewrite Z2Nat.id by auto with zarith - | _ => rewrite <- !Z.log2_up_le_full - end - | _ => rewrite wordToZ_ZToWord_wordToZ - by (rewrite Nat2Z.inj_le, Z2Nat.id, <- !Z.log2_up_le_pow2_full by auto with zarith; omega) - | _ => rewrite wordToZ_ZToWord_wordToZ in * - by (rewrite Nat2Z.inj_le, Z2Nat.id, <- !Z.log2_up_le_pow2_full by auto with zarith; omega) - end. - all:admit. } - { simpl in *. - specialize (H0 tt I). - simpl in *. - hnf in H0. - unfold cast_back_flat_const, lift_op, unzify_op in *; simpl in *. - unfold interpToZ in *. - unfold Bounds.bounds_to_base_type in *. - destruct_head base_type; simpl in *. - split_andb. - Z.ltb_to_lt. - all:destruct_head' and. - all:simpl in *. - all:break_innermost_match; break_match_hyps; split_andb; Z.ltb_to_lt; try reflexivity. - all:try (simpl in *; - rewrite wordToZ_ZToWord - by (autorewrite with push_Zof_nat zsimplify_const; - rewrite Z2Nat.id by auto with zarith; - split; try omega; - match goal with - | [ |- (?x < ?y)%Z ] - => apply (Z.lt_le_trans x (x + 1) y); [ omega | ] - end; - rewrite <- !Z.log2_up_le_full; - omega)). - all:try reflexivity. - unfold interpToZ, cast_const. - simpl. - rewrite ZToWord_wordToZ_ZToWord; [ reflexivity | ]. - apply Nat2Z.inj_le. - rewrite Z2Nat.id by auto with zarith. - -Admitted. diff --git a/src/Reflection/Z/Bounds/MapCastByDeBruijn.v b/src/Reflection/Z/Bounds/MapCastByDeBruijn.v deleted file mode 100644 index d99133e51..000000000 --- a/src/Reflection/Z/Bounds/MapCastByDeBruijn.v +++ /dev/null @@ -1,23 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Z.MapCastByDeBruijn. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.Syntax.Util. -Require Import Crypto.Reflection.Z.Bounds.Interpretation. - -Section language. - Context {t : type base_type}. - - Definition MapCastCompile := @MapCastCompile t. - Definition MapCastDoCast - := @MapCastDoCast - (@Bounds.interp_base_type) (@Bounds.interp_op) - (fun _ => @Bounds.bounds_to_base_type) - (fun _ _ opc _ => @genericize_op _ _ _ opc _ _ _) - t. - Definition MapCastDoInterp - := @MapCastDoInterp - (@Bounds.interp_base_type) (fun _ => @Bounds.bounds_to_base_type) - t. - Definition MapCast e input_bounds - := MapCastDoInterp input_bounds (MapCastDoCast input_bounds (MapCastCompile e)). -End language. diff --git a/src/Reflection/Z/Bounds/MapCastByDeBruijnInterp.v b/src/Reflection/Z/Bounds/MapCastByDeBruijnInterp.v deleted file mode 100644 index a7dc016bd..000000000 --- a/src/Reflection/Z/Bounds/MapCastByDeBruijnInterp.v +++ /dev/null @@ -1,25 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Reflection.Z.MapCastByDeBruijnInterp. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.Syntax.Util. -Require Import Crypto.Reflection.Z.Bounds.Interpretation. -Require Import Crypto.Reflection.Z.Bounds.InterpretationLemmas. -Require Import Crypto.Reflection.Z.Bounds.MapCastByDeBruijn. - -Lemma MapCastCorrect - {t} (e : Expr base_type op t) - (Hwf : Wf e) - (input_bounds : interp_flat_type Bounds.interp_base_type (domain t)) - : forall {b} e' (He':MapCast e input_bounds = Some (existT _ b e')) - v v' (Hv : Bounds.is_bounded_by input_bounds v /\ cast_back_flat_const v' = v), - Interp (@Bounds.interp_op) e input_bounds = b - /\ Bounds.is_bounded_by b (Interp interp_op e v) - /\ cast_back_flat_const (Interp interp_op e' v') = (Interp interp_op e v). -Proof. - apply MapCastCorrect; auto. - { apply is_bounded_by_interp_op. } - { apply pull_cast_genericize_op. } -Qed. diff --git a/src/Reflection/Z/Bounds/MapCastByDeBruijnWf.v b/src/Reflection/Z/Bounds/MapCastByDeBruijnWf.v deleted file mode 100644 index 57b45f68a..000000000 --- a/src/Reflection/Z/Bounds/MapCastByDeBruijnWf.v +++ /dev/null @@ -1,41 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Reflection.Z.MapCastByDeBruijnWf. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.Syntax.Util. -Require Import Crypto.Reflection.Z.Bounds.Interpretation. -Require Import Crypto.Reflection.Z.Bounds.InterpretationLemmas. -Require Import Crypto.Reflection.Z.Bounds.MapCastByDeBruijn. - -Definition Wf_MapCast - {t} (e : Expr base_type op t) - (input_bounds : interp_flat_type Bounds.interp_base_type (domain t)) - {b} e' (He' : MapCast e input_bounds = Some (existT _ b e')) - (Hwf : Wf e) - : Wf e' - := @Wf_MapCast - (@Bounds.interp_base_type) (@Bounds.interp_op) - (fun _ => @Bounds.bounds_to_base_type) - (fun _ _ opc _ => @genericize_op _ _ _ opc _ _ _) - t e input_bounds b e' He' Hwf. - -Definition Wf_MapCast_arrow - {s d} (e : Expr base_type op (Arrow s d)) - (input_bounds : interp_flat_type Bounds.interp_base_type s) - {b} e' (He' : MapCast e input_bounds = Some (existT _ b e')) - (Hwf : Wf e) - : Wf e' - := @Wf_MapCast_arrow - (@Bounds.interp_base_type) (@Bounds.interp_op) - (fun _ => @Bounds.bounds_to_base_type) - (fun _ _ opc _ => @genericize_op _ _ _ opc _ _ _) - s d e input_bounds b e' He' Hwf. - -Hint Extern 1 (Wf ?e') -=> match goal with - | [ He : MapCast _ _ = Some (existT _ _ e') |- _ ] - => first [ refine (@Wf_MapCast _ _ _ _ _ He _) - | refine (@Wf_MapCast_arrow _ _ _ _ _ _ He _) ] - end : wf. diff --git a/src/Reflection/Z/Bounds/Pipeline.v b/src/Reflection/Z/Bounds/Pipeline.v deleted file mode 100644 index 11bce1444..000000000 --- a/src/Reflection/Z/Bounds/Pipeline.v +++ /dev/null @@ -1,20 +0,0 @@ -(** * Reflective Pipeline *) -Require Import Crypto.Reflection.Z.Bounds.Pipeline.Glue. -Require Import Crypto.Reflection.Z.Bounds.Pipeline.ReflectiveTactics. -(** This file combines the various PHOAS modules in tactics, - culminating in a tactic [refine_reflectively], which solves a goal of the form -<< -cast_back_flat_const (?x args) = f (cast_back_flat_const args) - /\ Bounds.is_bounded_by ?bounds (?x args) ->> -while instantiating [?x] and [?bounds] with nicely-reduced constants. - *) - -Module Export Exports. - Export Glue.Exports. - Export ReflectiveTactics.Exports. -End Exports. - -Ltac refine_reflectively := - refine_to_reflective_glue; - do_reflective_pipeline. diff --git a/src/Reflection/Z/Bounds/Pipeline/Definition.v b/src/Reflection/Z/Bounds/Pipeline/Definition.v deleted file mode 100644 index 98d3078c3..000000000 --- a/src/Reflection/Z/Bounds/Pipeline/Definition.v +++ /dev/null @@ -1,177 +0,0 @@ -(** * Reflective Pipeline: Main Pipeline Definition *) -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.Bounds.Pipeline.OutputType. -(** This file contains the definitions of the assembling of the - various transformations that are used in the pipeline. There are - two stages to the reflective pipeline, with different - requirements. - - The pre-Wf stage is intended to consist of transformations that - make the term smaller, and, importantly, should only consist of - transformations whose interpretation-correctness proofs do not - require well-founded hypotheses. Generally this is the case for - transformations whose input and output [var] types match. The - correctness condition for this stage is that the interpretation of - the transformed term must equal the interpretation of the original - term, with no side-conditions. - - The post-Wf stage is the rest of the pipeline; its correctness - condition must have the shape of the correctness condition for - word-size selection. We define a record to hold the transformed - term, so that we can get bounds and similar out of it, without - running into issues with slowness of conversion. *) - -(** ** Pre-Wf Stage *) -(** *** Pre-Wf Pipeline Imports *) -Require Import Crypto.Reflection.Eta. -Require Import Crypto.Reflection.EtaInterp. -Require Import Crypto.Reflection.Z.ArithmeticSimplifier. -Require Import Crypto.Reflection.Z.ArithmeticSimplifierInterp. - -(** *** Definition of the Pre-Wf Pipeline *) -(** Do not change the name or the type of this definition *) -Definition PreWfPipeline {t} (e : Expr base_type op t) : Expr base_type op _ - := ExprEta (SimplifyArith e). - -(** *** Correctness proof of the Pre-Wf Pipeline *) -(** Do not change the statement of this lemma. You shouldn't need to - change it's proof, either; all of the relevant lemmas should be in - the [reflective_interp] rewrite database. If they're not, you - should find the file where they are defined and add them. *) -Lemma InterpPreWfPipeline {t} (e : Expr base_type op t) - : forall x, Interp interp_op (PreWfPipeline e) x = Interp interp_op e x. -Proof. - unfold PreWfPipeline; intro. - repeat autorewrite with reflective_interp. - reflexivity. -Qed. - - - -(** ** Post-Wf Stage *) -(** *** Post-Wf Pipeline Imports *) -Require Import Crypto.Reflection.Z.Bounds.Interpretation. -Require Import Crypto.Reflection.EtaWf. -Require Import Crypto.Reflection.Z.Inline. -Require Import Crypto.Reflection.Z.InlineInterp. -Require Import Crypto.Reflection.Z.InlineWf. -Require Import Crypto.Reflection.Linearize. -Require Import Crypto.Reflection.LinearizeInterp. -Require Import Crypto.Reflection.LinearizeWf. -Require Import Crypto.Reflection.Z.Bounds.MapCastByDeBruijn. -Require Import Crypto.Reflection.Z.Bounds.MapCastByDeBruijnInterp. -Require Import Crypto.Reflection.Z.Bounds.MapCastByDeBruijnWf. -Require Import Crypto.Util.Sigma.MapProjections. - -(** *** Definition of the Post-Wf Pipeline *) -(** Do not change the name or the type of this definition *) -Definition PostWfPipeline - {t} (e : Expr base_type op t) - (input_bounds : interp_flat_type Bounds.interp_base_type (domain t)) - : option ProcessedReflectivePackage - := Build_ProcessedReflectivePackage_from_option_sigma - e input_bounds - (let e := Linearize e in - let e := InlineConst e in - let e := MapCast e input_bounds in - option_map - (projT2_map - (fun b e' - => let e' := InlineConst e' in - let e' := ExprEta e' in - e')) - e). - -(** *** Correctness proof of the Pre-Wf Pipeline *) -(** Do not change the statement of this lemma. *) -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.Equality. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Z.Syntax.Util. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.Sigma. -Require Import Crypto.Util.Prod. -Require Import Crypto.Util.HProp. -Require Import Crypto.Util.Decidable. - -Local Notation pick_typeb := Bounds.bounds_to_base_type (only parsing). -Local Notation pick_type v := (SmartFlatTypeMap (fun _ => pick_typeb) v). -Definition PostWfPipelineCorrect - {t} - (e : Expr base_type op t) - (input_bounds : interp_flat_type Bounds.interp_base_type (domain t)) - (Hwf : Wf e) - {b e'} (He : PostWfPipeline e input_bounds - = Some {| input_expr := e ; input_bounds := input_bounds ; output_bounds := b ; output_expr := e' |}) - (v : interp_flat_type Syntax.interp_base_type (domain t)) - (v' : interp_flat_type Syntax.interp_base_type (pick_type input_bounds)) - (Hv : Bounds.is_bounded_by input_bounds v /\ cast_back_flat_const v' = v) - : Interp (@Bounds.interp_op) e input_bounds = b - /\ Bounds.is_bounded_by b (Interp interp_op e v) - /\ cast_back_flat_const (Interp interp_op e' v') = Interp interp_op e v. -Proof. - (** These first two lines probably shouldn't change much *) - unfold PostWfPipeline, Build_ProcessedReflectivePackage_from_option_sigma, option_map, projT2_map in *. - repeat (break_match_hyps || inversion_option || inversion_ProcessedReflectivePackage - || inversion_sigma || eliminate_hprop_eq || inversion_prod - || simpl in * || subst). - (** Now handle all the transformations that come after the word-size selection *) - rewrite InterpExprEta_arrow, InterpInlineConst - by eauto with wf. - (** Now handle all the transformations that come before the word-size selection *) - rewrite <- !InterpLinearize with (e:=e), <- !(@InterpInlineConst _ _ _ (Linearize e)) - by eauto with wf. - (** Now handle word-size selection itself *) - eapply MapCastCorrect; eauto with wf. -Qed. - - -(** ** Constant Simplification and Unfolding *) -(** The reflective pipeline may introduce constants that you want to - unfold before instantiating the refined term; you can control that - here. A number of reflection-specific constants are always - unfolded (in ReflectiveTactics.v). Currently, we also reduce - expressions of the form [wordToZ (ZToWord Z_literal)], as - specified here. *) -Require Import Coq.ZArith.ZArith. -Require Import Crypto.Util.FixedWordSizes. -Require Import Bedrock.Word. - -Module Export Exports. (* export unfolding strategy *) - (* iota is probably (hopefully?) the cheapest reduction. - Unfortunately, we can't say no-op here. This is meant to be - extended. *) - Declare Reduction extra_interp_red := cbv iota. - - (** Overload this to change reduction behavior of constants of the - form [wordToZ (ZToWord Z_literal)]. You might want to set this - to false if your term is very large, to speed things up. *) - Ltac do_constant_simplification := constr:(true). - - Global Arguments ZToWord !_ !_ / . - Global Arguments wordToZ !_ !_ / . - Global Arguments word_case_dep _ !_ _ _ _ _ / . - Global Arguments ZToWord32 !_ / . - Global Arguments ZToWord64 !_ / . - Global Arguments ZToWord128 !_ / . - Global Arguments ZToWord_gen !_ !_ / . - Global Arguments word32ToZ !_ / . - Global Arguments word64ToZ !_ / . - Global Arguments word128ToZ !_ / . - Global Arguments wordToZ_gen !_ !_ / . - Global Arguments Z.to_N !_ / . - Global Arguments Z.of_N !_ / . - Global Arguments Word.NToWord !_ !_ / . - Global Arguments Word.wordToN !_ !_ / . - Global Arguments Word.posToWord !_ !_ / . - Global Arguments N.succ_double !_ / . - Global Arguments Word.wzero' !_ / . - Global Arguments N.double !_ . - Global Arguments Nat.pow !_ !_ / . - Global Arguments Nat.mul !_ !_ / . - Global Arguments Nat.add !_ !_ / . - - Declare Reduction constant_simplification := cbn [FixedWordSizes.wordToZ FixedWordSizes.ZToWord word_case_dep ZToWord32 ZToWord64 ZToWord128 ZToWord_gen word32ToZ word64ToZ word128ToZ wordToZ_gen Word.NToWord Word.wordToN Word.posToWord Word.wzero' Z.to_N Z.of_N N.succ_double N.double Nat.pow Nat.mul Nat.add]. -End Exports. diff --git a/src/Reflection/Z/Bounds/Pipeline/Glue.v b/src/Reflection/Z/Bounds/Pipeline/Glue.v deleted file mode 100644 index 8219a6fb6..000000000 --- a/src/Reflection/Z/Bounds/Pipeline/Glue.v +++ /dev/null @@ -1,456 +0,0 @@ -(** * Reflective Pipeline: Glue Code *) -(** This file defines the tactics that transform a non-reflective goal - into a goal the that the reflective machinery can handle. *) -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Reify. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.Syntax.Util. -Require Import Crypto.Reflection.Z.Reify. -Require Import Crypto.Reflection.Z.Bounds.Interpretation. -Require Import Crypto.Util.Tactics.Head. -Require Import Crypto.Util.Curry. -Require Import Crypto.Util.FixedWordSizes. -Require Import Crypto.Util.BoundedWord. -Require Import Crypto.Util.Tuple. -Require Import Crypto.Util.Sigma.Associativity. -Require Import Crypto.Util.Sigma.MapProjections. -Require Import Crypto.Util.Tactics.EvarExists. -Require Import Crypto.Util.Tactics.GetGoal. -Require Import Crypto.Util.Tactics.PrintContext. -Require Import Crypto.Util.Tactics.MoveLetIn. - -Module Export Exports. - Export Crypto.Reflection.Z.Reify. (* export for the tactic redefinitions *) -End Exports. - -(** ** [reassoc_sig_and_eexists] *) -(** The [reassoc_sig_and_eexists] tactic operates on a goal convertible with -<< -{ f : { a | is_bounded_by bounds a } -| BoundedWordToZ f = rexprZ (BoundedWordToZ a) ... (BoundedWordToZ z) } ->> - and leaves a goal of the form -<< -is_bounded_by bounds (map wordToZ ?f) - /\ map wordToZ ?f = rexprZ (map wordToZ (proj1_sig a)) ... (map wordToZ (proj1_sig z)) ->> - where [?f] is a context variable set to a new evar. This tactic - relies on the exact definition of [BoundedWordToZ]. *) - - -(** The tactic [unfold_paired_tuple_map] unfolds any [Tuple.map]s - applied to [pair]s. *) -Ltac unfold_paired_tuple_map := - repeat match goal with - | [ |- context[Tuple.map (n:=S ?N) _ (pair _ _)] ] - => progress change (@Tuple.map (S N)) with (fun A B f => @Tuple.map' A B f N); cbv beta iota delta [Tuple.map'] - end. -(** The tactic [change_to_reified_type f] reifies the type of a - context variable [f] and changes [f] to the interpretation of that - type. *) -Ltac change_to_reified_type f := - let T := type of f in - let cT := (eval compute in T) in - let rT := reify_type cT in - change (interp_type Syntax.interp_base_type rT) in (type of f). - -(** The tactic [sig_dlet_in_rhs_to_context_curried] moves to the - context any [dlet x := y in ...] on the rhs of a goal of the form - [{ a | lhs = rhs }], curries each such moved definition, and then - reifies the type of each such context variable. *) -Ltac sig_dlet_in_rhs_to_context_curried := - lazymatch goal with - | [ |- { a | _ = @Let_In ?A ?B ?x _ } ] - => let f := fresh in - sig_dlet_in_rhs_to_context_step f; - change_with_curried f; - change_to_reified_type f; - sig_dlet_in_rhs_to_context_curried - | _ => idtac - end. -(** The tactic [preunfold_and_dlet_to_context] will unfold - [BoundedWordToZ] and [Tuple.map]s applied to [pair]s, and then - look for a [dlet x := y in ...] in the RHS of a goal of shape [{a - | LHS = RHS }] and replace it with a context variable. *) -Ltac preunfold_and_dlet_to_context := - unfold_paired_tuple_map; - cbv [BoundedWordToZ]; cbn [fst snd proj1_sig]; - sig_dlet_in_rhs_to_context_curried. -(** The tactic [pattern_proj1_sig_in_lhs_of_sig] takes a goal of the form -<< -{ a : A | P } ->> - where [A] is a sigma type, and leaves a goal of the form -<< -{ a : A | dlet p := P' in p (proj1_sig a) ->> - where all occurrences of [proj1_sig a] have been abstracted out of - [P] to make [P']. *) -Ltac pattern_proj1_sig_in_sig := - eapply proj2_sig_map; - [ let a := fresh in - let H := fresh in - intros a H; pattern (proj1_sig a); - lazymatch goal with - | [ |- ?P ?p1a ] - => cut (dlet p := P in p p1a); - [ clear; abstract (cbv [Let_In]; exact (fun x => x)) | ] - end; - exact H - | cbv beta ]. -(** The tactic [pattern_sig_sig_assoc] takes a goal of the form -<< -{ a : { a' : A | P } | Q } ->> - where [Q] mentions [proj1_sig a] but not [proj2_sig a], and leaves - a goal of the form -<< -{ a : A | P /\ Q } ->> - *) -Ltac pattern_sig_sig_assoc := - pattern_proj1_sig_in_sig; - let f := fresh in - goal_dlet_to_context_step f; - apply sig_sig_assoc; - subst f; cbv beta. -(** The tactic [reassoc_sig_and_eexists] will unfold [BoundedWordToZ] - and move any [dlet x := ... in ...] to context variables, and then - take a goal of the form -<< -{ a : { a' : A | P a' } | Q (proj1_sig a) } ->> - where [Q] mentions [proj1_sig a] but not [proj2_sig a], and leave - a goal of the form -<< -P ?a /\ Q ?a ->> - *) -Ltac reassoc_sig_and_eexists := - preunfold_and_dlet_to_context; - pattern_sig_sig_assoc; - evar_exists. - - -(** ** [do_curry_rhs] *) -(** The [do_curry_rhs] tactic takes a goal of the form -<< -_ /\ _ = F A B ... Z ->> - and turns it into a goal of the form -<< -_ /\ _ = F' (A, B, ..., Z) ->> - *) -Ltac do_curry_rhs := - lazymatch goal with - | [ |- _ /\ _ = ?f_Z ] - => let f_Z := head f_Z in - change_with_curried f_Z - end. - -(** ** [split_BoundedWordToZ] *) -(** The [split_BoundedWordToZ] tactic takes a goal of the form -<< -_ /\ (map wordToZ (proj1_sig f1), ... map wordToZ (proj1_sig fn)) = F ARGS ->> - and splits [f1] ... [fn] and any arguments in ARGS into two - parts, one part about the computational behavior, and another part - about the boundedness. - - This pipeline relies on the specific definition of - [BoundedWordToZ], and requires [f] to be a context variable which - is set to a single evar. *) -(** First we ensure the goal has the right shape, and give helpful - error messages if it does not *) -Ltac check_fW_type descr top_fW fW := - lazymatch fW with - | fst ?fW => check_fW_type descr top_fW fW - | snd ?fW => check_fW_type descr top_fW fW - | _ => let G := get_goal in - let shape := uconstr:(map wordToZ ?fW) in - let efW := uconstr:(?fW) in - first [ is_var fW - | fail 1 "In the goal" G - descr shape - "where" efW "must be a repeated application of fst and snd" - "to a single context variable which is defined to be an evar." - "The term" top_fW "is based on" fW "which is not a variable" ]; - match goal with - | [ fW' := ?e |- _ ] - => constr_eq fW' fW; - first [ is_evar e - | fail 2 "In the goal" G - descr shape - "where" efW "must be a repeated application of fst and snd" - "to a single context variable which is defined to be an evar." - "The term" top_fW "is based on" fW' "which is a context variable" - "with body" e "which is not a bare evar" ] - | [ fW' : _ |- _ ] - => constr_eq fW fW'; - fail 1 "In the goal" G - descr shape - "where" efW "must be a repeated application of fst and snd" - "to a single context variable which is defined to be an evar." - "The term" top_fW "is based on" fW' "which is a context variable without a body" - | _ => fail 1 "In the goal" G - descr shape - "where" efW "must be a repeated application of fst and snd" - "to a single context variable which is defined to be an evar." - "The term" top_fW "is based on" fW "which is not a context variable" - end - end. -Tactic Notation "check_fW_type" string(descr) constr(fW) - := check_fW_type descr fW fW. -Ltac check_is_bounded_by_shape subterm_type := - lazymatch subterm_type with - | ZRange.is_bounded_by None ?bounds (map wordToZ ?fW) - => check_fW_type "The ℤ argument to is_bounded_by must have the shape" fW - | ?A /\ ?B - => check_is_bounded_by_shape A; - check_is_bounded_by_shape B - | _ => let G := get_goal in - let shape := uconstr:(ZRange.is_bounded_by None ?bounds (map wordToZ ?fW)) in - fail "In the goal" G - "The first conjunct of the goal is expected to be a conjunction of things of the shape" shape - "but a subterm not matching this shape was found:" subterm_type - end. -Ltac check_LHS_Z_shape subterm := - lazymatch subterm with - | map wordToZ ?fW - => check_fW_type "The left-hand side of the second conjunct of the goal must be a tuple of terms with shape" fW - | (?A, ?B) - => check_LHS_Z_shape A; - check_LHS_Z_shape B - | _ => let G := get_goal in - let shape := uconstr:(map wordToZ ?fW) in - fail "In the goal" G - "The second conjunct of the goal is expected to be a equality whose" - "left-hand side is a tuple of terms of the shape" shape - "but a subterm not matching this shape was found:" subterm - end. -Ltac check_RHS_Z_shape_rec subterm := - lazymatch subterm with - | map wordToZ ?fW - => idtac - | (?A, ?B) - => check_RHS_Z_shape_rec A; - check_RHS_Z_shape_rec B - | _ => let G := get_goal in - let shape := uconstr:(map wordToZ ?fW) in - fail "In the goal" G - "The second conjunct of the goal is expected to be a equality whose" - "right-hand side is the application of a function to a tuple of terms of the shape" shape - "but a subterm not matching this shape was found:" subterm - end. -Ltac check_RHS_Z_shape RHS := - lazymatch RHS with - | ?f ?args - => let G := get_goal in - first [ is_var f - | fail 1 "In the goal" G - "The second conjunct of the goal is expected to be a equality whose" - "right-hand side is the application of a single context-variable to a tuple" - "but the right-hand side is" RHS - "which is an application of something which is not a context variable:" f ]; - check_RHS_Z_shape_rec args - | _ => let G := get_goal in - let shape := uconstr:(map wordToZ ?fW) in - fail "In the goal" G - "The second conjunct of the goal is expected to be a equality whose" - "right-hand side is the application of a function to a tuple of terms of the shape" shape - "but the right-hand side is not a function application:" RHS - end. -Ltac check_precondition _ := - lazymatch goal with - | [ |- ?is_bounded_by /\ ?LHS = ?RHS ] - => check_is_bounded_by_shape is_bounded_by; - check_LHS_Z_shape LHS; - check_RHS_Z_shape RHS - | [ |- ?G ] - => let shape := uconstr:(?is_bounded /\ ?LHS = ?RHS) in - fail "The goal has the wrong shape for reflective gluing; expected" shape "but found" G - end. -Ltac split_BoundedWordToZ := - (** first revert the context definition which is an evar named [f] - in the docs above, so that it becomes evar 1 (for - [instantiate]), and so that [make_evar_for_first_projection] - works. It's not the most robust way to find the right term; - maybe we should modify some of the checks above to assert that - the evar found is a particular one? *) - check_precondition (); - lazymatch goal with - | [ |- _ /\ ?LHS = _ ] - => match goal with - | [ f := ?e |- _ ] - => is_evar e; match LHS with context[f] => idtac end; - revert f - end - end; - repeat match goal with - | [ |- context[map wordToZ (proj1_sig ?x)] ] - => is_var x; - first [ clearbody x; fail 1 - | (** we want to keep the same context variable in - the evar that we reverted above, and in the - current goal; hence the instantiate trick *) - instantiate (1:=ltac:(destruct x)); destruct x ] - | [ H := context[map wordToZ (proj1_sig ?x)] |- _ ] - => is_var x; - first [ clearbody x; fail 1 - | (** we want to keep the same context variable in - the evar that we reverted above, and in the - current goal; hence the instantiate trick *) - instantiate (1:=ltac:(destruct x)); destruct x ] - | [ |- context[fst ?x] ] - => is_var x; - first [ clearbody x; fail 1 - | (** we want to keep the same context variable in - the evar that we reverted above, and in the - current goal; hence the instantiate trick *) - change (fst x) with (let (a, b) := x in a); - change (snd x) with (let (a, b) := x in b); - instantiate (1:=ltac:(destruct x)); destruct x ]; - cbv beta iota - end; - cbv beta iota in *; intro; (* put [f] back in the context so that [cbn] doesn't remove this let-in *) - cbn [proj1_sig] in *. - -(** ** [zrange_to_reflective] *) -(** The [zrange_to_reflective] tactic takes a goal of the form -<< -(is_bounded_by _ bounds (map wordToZ (?fW args)) /\ ...) - /\ (map wordToZ (?fW args), ...) = fZ argsZ ->> - and uses [cut] and a small lemma to turn it into a goal that the - reflective machinery can handle. The goal left by this tactic - should be fully solvable by the reflective pipeline. *) - -Lemma adjust_goal_for_reflective {T P} (LHS RHS : T) - : P RHS /\ LHS = RHS -> P LHS /\ LHS = RHS. -Proof. intros [? ?]; subst; tauto. Qed. -Ltac adjust_goal_for_reflective := apply adjust_goal_for_reflective. -Ltac unmap_wordToZ_tuple term := - lazymatch term with - | (?x, ?y) => let x' := unmap_wordToZ_tuple x in - let y' := unmap_wordToZ_tuple y in - constr:((x', y')) - | map wordToZ ?x => x - end. -Ltac bounds_from_is_bounded_by T := - lazymatch T with - | ?A /\ ?B => let a := bounds_from_is_bounded_by A in - let b := bounds_from_is_bounded_by B in - constr:((a, b)) - | ZRange.is_bounded_by _ ?bounds _ - => bounds - end. -Ltac pose_proof_bounded_from_Zargs_hyps Zargs H := - lazymatch Zargs with - | (?a, ?b) - => let Ha := fresh in - let Hb := fresh in - pose_proof_bounded_from_Zargs_hyps a Ha; - pose_proof_bounded_from_Zargs_hyps b Hb; - let pf := constr:(conj Ha Hb) in - lazymatch type of pf with - | @Bounds.is_bounded_by ?A ?boundsA (@cast_back_flat_const ?var ?tA ?f ?VA ?argsA) - /\ @Bounds.is_bounded_by ?B ?boundsB (@cast_back_flat_const ?var ?tB ?f ?VB ?argsB) - => pose proof - ((pf : @Bounds.is_bounded_by - (Prod A B) (boundsA, boundsB) - (@cast_back_flat_const var (Prod tA tB) f (VA, VB) (argsA, argsB)))) - as H; - clear Ha Hb - | ?pfT - => let shape - := uconstr:(@Bounds.is_bounded_by ?A ?boundsA (@cast_back_flat_const ?var ?tA ?f ?VA ?argsA) - /\ @Bounds.is_bounded_by ?B ?boundsB (@cast_back_flat_const ?var ?tB ?f ?VB ?argsB)) in - fail 1 "Returned value from recursive call of bounded_from_Zargs_hyps has the wrong type" - "Cannot match type" pfT - "with shape" shape - end - | Tuple.map wordToZ ?arg - => lazymatch goal with - | [ H' : Bounds.is_bounded_by ?bounds (cast_back_flat_const arg) |- _ ] - => rename H' into H - | _ => let shape := uconstr:(Bounds.is_bounded_by _ (cast_back_flat_const arg)) in - idtac "In the context:"; print_context (); - fail 1 "Could not find bounds in the context for" arg - "when looking for a hypothesis of shape" shape - end - end. -Ltac find_reified_f_evar LHS := - lazymatch LHS with - | fst ?x => find_reified_f_evar x - | snd ?x => find_reified_f_evar x - | (?x, _) => find_reified_f_evar x - | map wordToZ ?x => find_reified_f_evar x - | _ => LHS - end. -Ltac zrange_to_reflective_hyps_step := - match goal with - | [ H : @ZRange.is_bounded_by ?option_bit_width ?count ?bounds (Tuple.map wordToZ ?arg) |- _ ] - => let rT := constr:(Syntax.tuple (Tbase TZ) count) in - let is_bounded_by' := constr:(@Bounds.is_bounded_by rT) in - let map' := constr:(@cast_back_flat_const (@Bounds.interp_base_type) rT (fun _ => Bounds.bounds_to_base_type) bounds) in - (* we use [assert] and [abstract] rather than [change] to catch - inefficiencies in conversion early, rather than allowing - [Defined] to take forever *) - let H' := fresh H in - rename H into H'; - assert (H : is_bounded_by' bounds (map' arg)) by (clear -H'; abstract exact H'); - clear H'; move H at top - | [ H := context Hv[@Tuple.map ?a ?b ?c (@wordToZ ?d) ?x], Hbounded : Bounds.is_bounded_by ?bounds (cast_back_flat_const ?x) |- _ ] - => let T := type of (@Tuple.map a b c (@wordToZ d) x) in - let T := (eval compute in T) in - let rT := reify_flat_type T in - let map_t := constr:(fun t bs => @cast_back_flat_const (@Bounds.interp_base_type) t (fun _ => Bounds.bounds_to_base_type) bs) in - let map' := constr:(map_t rT bounds) in - let Hv' := context Hv[map' x] in - progress change Hv' in (value of H); cbv beta in H - end. -Ltac zrange_to_reflective_hyps := repeat zrange_to_reflective_hyps_step. -Ltac zrange_to_reflective_goal Hbounded := - lazymatch goal with - | [ |- ?is_bounded_by_T /\ ?LHS = ?f ?Zargs ] - => let T := type of f in - let f_domain := lazymatch eval hnf in T with ?A -> ?B => A end in - let T := (eval compute in T) in - let rT := reify_type T in - let is_bounded_by' := constr:(@Bounds.is_bounded_by (codomain rT)) in - let output_bounds := bounds_from_is_bounded_by is_bounded_by_T in - pose_proof_bounded_from_Zargs_hyps Zargs Hbounded; - let input_bounds := lazymatch type of Hbounded with Bounds.is_bounded_by ?bounds _ => bounds end in - let map_t := constr:(fun t bs => @cast_back_flat_const (@Bounds.interp_base_type) t (fun _ => Bounds.bounds_to_base_type) bs) in - let map_output := constr:(map_t (codomain rT) output_bounds) in - let map_input := constr:(map_t (domain rT) input_bounds) in - let args := unmap_wordToZ_tuple Zargs in - let reified_f_evar := find_reified_f_evar LHS in - (* we use [cut] and [abstract] rather than [change] to catch - inefficiencies in conversion early, rather than allowing - [Defined] to take forever *) - cut (is_bounded_by' output_bounds (map_output reified_f_evar) /\ map_output reified_f_evar = f (map_input args)); - [ generalize reified_f_evar; clear; clearbody f; clear; let x := fresh in intros ? x; abstract exact x - | ]; - cbv beta - end; - adjust_goal_for_reflective. -Ltac zrange_to_reflective Hbounded := zrange_to_reflective_hyps; zrange_to_reflective_goal Hbounded. - -(** ** [refine_to_reflective_glue] *) -(** The tactic [refine_to_reflective_glue] is the public-facing one; - it takes a goal of the form -<< -BoundedWordToZ ?f = F (BoundedWordToZ A) (BoundedWordToZ B) ... (BoundedWordToZ Z) ->> - where [?f] is an evar, and turns it into a goal the that - reflective automation pipeline can handle. *) -Ltac refine_to_reflective_glue' Hbounded := - reassoc_sig_and_eexists; - do_curry_rhs; - split_BoundedWordToZ; - zrange_to_reflective Hbounded. -Ltac refine_to_reflective_glue := - let Hbounded := fresh "Hbounded" in - refine_to_reflective_glue' Hbounded. diff --git a/src/Reflection/Z/Bounds/Pipeline/OutputType.v b/src/Reflection/Z/Bounds/Pipeline/OutputType.v deleted file mode 100644 index 301ee9e9c..000000000 --- a/src/Reflection/Z/Bounds/Pipeline/OutputType.v +++ /dev/null @@ -1,51 +0,0 @@ -(** * Definition of the output type of the post-Wf pipeline *) -(** Do not change these definitions unless you're hacking on the - entire reflective pipeline tactic automation. *) -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.Bounds.Interpretation. -Require Import Crypto.Util.Sigma. -Require Import Crypto.Util.Prod. -Local Notation pick_typeb := Bounds.bounds_to_base_type (only parsing). -Local Notation pick_type v := (SmartFlatTypeMap (fun _ => pick_typeb) v). - -Record ProcessedReflectivePackage - := { InputType : _; - input_expr : Expr base_type op InputType; - input_bounds : interp_flat_type Bounds.interp_base_type (domain InputType); - output_bounds :> interp_flat_type Bounds.interp_base_type (codomain InputType); - output_expr :> Expr base_type op (Arrow (pick_type input_bounds) (pick_type output_bounds)) }. - -Notation OutputType pkg - := (Arrow (pick_type (@input_bounds pkg)) (pick_type (@output_bounds pkg))) - (only parsing). - -Definition Build_ProcessedReflectivePackage_from_option_sigma - {t} (e : Expr base_type op t) - (input_bounds : interp_flat_type Bounds.interp_base_type (domain t)) - (result : option { output_bounds : interp_flat_type Bounds.interp_base_type (codomain t) - & Expr base_type op (Arrow (pick_type input_bounds) (pick_type output_bounds)) }) - : option ProcessedReflectivePackage - := option_map - (fun be - => let 'existT b e' := be in - {| InputType := t ; input_expr := e ; input_bounds := input_bounds ; output_bounds := b ; output_expr := e' |}) - result. - -Definition ProcessedReflectivePackage_to_sigT (x : ProcessedReflectivePackage) - : { InputType : _ - & Expr base_type op InputType - * { bounds : interp_flat_type Bounds.interp_base_type (domain InputType) - * interp_flat_type Bounds.interp_base_type (codomain InputType) - & Expr base_type op (Arrow (pick_type (fst bounds)) (pick_type (snd bounds))) } }%type - := let (a, b, c, d, e) := x in - existT _ a (b, (existT _ (c, d) e)). - -Ltac inversion_ProcessedReflectivePackage := - repeat match goal with - | [ H : _ = _ :> ProcessedReflectivePackage |- _ ] - => apply (f_equal ProcessedReflectivePackage_to_sigT) in H; - cbv [ProcessedReflectivePackage_to_sigT] in H - end; - inversion_sigma; inversion_prod. diff --git a/src/Reflection/Z/Bounds/Pipeline/ReflectiveTactics.v b/src/Reflection/Z/Bounds/Pipeline/ReflectiveTactics.v deleted file mode 100644 index b082353da..000000000 --- a/src/Reflection/Z/Bounds/Pipeline/ReflectiveTactics.v +++ /dev/null @@ -1,288 +0,0 @@ -(** * Reflective Pipeline: Tactics that execute the pipeline *) -(** N.B. This file should not need to be changed in normal - modifications of the reflective transformations; to modify the - transformations performed in the reflective pipeline; see - Pipeline/Definition.v. If the input format of the pre-reflective - goal changes, prefer adding complexity to Pipeline/Glue.v to - transform the goal and hypotheses into a uniform syntax to - modifying this file. This file will need to be modified if you - perform heavy changes in the shape of the generic or ℤ-specific - reflective machinery itself, or if you find bugs or slowness. *) -(** ** Preamble *) -Require Import Coq.ZArith.ZArith. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.WfReflective. -Require Import Crypto.Reflection.RenameBinders. -Require Import Crypto.Reflection.Eta. -Require Import Crypto.Reflection.EtaInterp. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.Syntax.Util. -Require Import Crypto.Reflection.Z.Bounds.Interpretation. -Require Import Crypto.Reflection.Z.Bounds.Relax. -Require Import Crypto.Reflection.Reify. -Require Import Crypto.Reflection.Z.Reify. -Require Import Crypto.Reflection.Z.Bounds.Pipeline.Definition. -Require Import Crypto.Util.Tactics.Head. -Require Import Crypto.Util.Tactics.SubstLet. -Require Import Crypto.Util.Tactics.UnifyAbstractReflexivity. -Require Import Crypto.Util.FixedWordSizes. -Require Import Crypto.Util.Option. -Require Import Bedrock.Word. - -(** The final tactic in this file, [do_reflective_pipeline], takes a - goal of the form -<< -@Bounds.is_bounded_by (codomain T) bounds (fZ (cast_back_flat_const v)) - /\ cast_back_flat_const fW = fZ (cast_back_flat_const v) ->> - - where [fW] must be a context definition which is a single evar, - and all other terms must be evar-free. It fully solves the goal, - instantiating [fW] with an appropriately-unfolded - (reflection-definition-free) version of [fZ (cast_back_flat_const - v)] which has been transformed by the reflective pipeline. *) - -Module Export Exports. - Export Crypto.Reflection.Reify. (* export for the instances for recursing under binders *) - Export Crypto.Reflection.Z.Reify. (* export for the tactic redefinitions *) - Export Crypto.Reflection.Z.Bounds.Pipeline.Definition.Exports. -End Exports. - -(** ** Reification *) -(** The [do_reify] tactic handles goals of the form -<< -forall x, Interp _ ?e x = F ->> - by reifying [F]. *) -Ltac do_reify := - cbv beta iota delta [Tuple.tuple Tuple.tuple'] in *; - cbv beta iota delta [Syntax.interp_flat_type Syntax.interp_base_type]; - reify_context_variables; - Reify_rhs; reflexivity. -(** ** Input Boundedness Side-Conditions *) -(** The tactic [handle_bounds_from_hyps] handles goals of the form -<< -Bounds.is_bounded_by (_, _, ..., _) _ ->> - by splitting them apart and looking in the context for hypotheses - that prove the bounds. *) -Ltac handle_bounds_from_hyps := - repeat match goal with - | _ => assumption - | [ |- cast_back_flat_const _ = cast_back_flat_const _ ] => reflexivity - | [ |- _ /\ _ ] => split - | [ |- Bounds.is_bounded_by (_, _) _ ] => split - end. -(** ** Unfolding [Interp] *) -(** The reduction strategies [interp_red], [extra_interp_red], and - [constant_simplification] (the latter two defined in - Pipeline/Definition.v) define the constants that get unfolded - before instantiating the original evar with [Interp _ - vm_computed_reified_expression arguments]. *) -Declare Reduction interp_red - := cbv [fst snd - Interp InterpEta interp_op interp interp_eta interpf interpf_step - interp_flat_type_eta interp_flat_type_eta_gen interp_flat_type - interp_base_type interp_op - SmartMap.SmartFlatTypeMap SmartMap.SmartFlatTypeMapUnInterp SmartMap.SmartFlatTypeMapInterp2 - SmartMap.smart_interp_flat_map - codomain domain - lift_op Zinterp_op cast_const - ZToInterp interpToZ - ]. - -(** ** Solving Side-Conditions of Equality *) -(** This section defines a number of different ways to solve goals of - the form [LHS = RHS] where [LHS] may contain evars and [RHS] must - not contain evars. Most tactics use [abstract] to reduce the load - on [Defined] and to catch looping behavior early. *) - -(** The tactic [unify_abstract_renamify_rhs_reflexivity] calls [renamify] on [RHS] and unifies - that with [LHS]; and then costs one [vm_compute] to prove the - equality. *) -Ltac unify_abstract_renamify_rhs_reflexivity := - unify_transformed_rhs_abstract_tac - ltac:(renamify) - unify_tac - vm_cast_no_check. -(** The tactic [unify_abstract_cbv_interp_rhs_reflexivity] runs the interpretation - reduction strategies in [RHS] and unifies the result with [LHS], - and does not use the vm (and hence does not fully reduce things, - which is important for efficiency). *) -Ltac unify_abstract_cbv_interp_rhs_reflexivity := - intros; clear; - lazymatch goal with - | [ |- ?LHS = ?RHS ] - => let RHS' := (eval interp_red in RHS) in - let RHS' := (eval extra_interp_red in RHS') in - let RHS' := lazymatch do_constant_simplification with - | true => (eval constant_simplification in RHS') - | _ => RHS' - end in - unify LHS RHS'; abstract exact_no_check (eq_refl RHS') - end. - - -(** ** Assemble the parts of Pipeline.Definition, in Gallina *) -(** In this section, we assemble [PreWfPipeline] and [PostWfPipeline], - and add extra equality hypotheses to minimize the work we have to - do in Ltac. *) -(** *** Gallina assembly imports *) -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.WfReflectiveGen. -Require Import Crypto.Reflection.WfReflective. -Require Import Crypto.Reflection.Eta. -Require Import Crypto.Reflection.EtaWf. -Require Import Crypto.Reflection.EtaInterp. -Require Import Crypto.Reflection.Z.Bounds.Pipeline.OutputType. -Require Import Crypto.Reflection.Z.Bounds.Pipeline.Definition. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.Syntax.Equality. -Require Import Crypto.Reflection.Z.Syntax.Util. -Require Import Crypto.Reflection.Z.Bounds.Interpretation. -Require Import Crypto.Reflection.Z.Bounds.Relax. -Require Import Crypto.Util.PartiallyReifiedProp. -Require Import Crypto.Util.Equality. - -(** *** Gallina assembly *) -Local Notation pick_typeb := Bounds.bounds_to_base_type (only parsing). -Local Notation pick_type v := (SmartFlatTypeMap (fun _ => pick_typeb) v). -Definition PipelineCorrect - {t} - {input_bounds : interp_flat_type Bounds.interp_base_type (domain t)} - {given_output_bounds : interp_flat_type Bounds.interp_base_type (codomain t)} - {v' : interp_flat_type Syntax.interp_base_type (pick_type input_bounds)} - {b e' e_final e_final_newtype} - {fZ} - {final_e_evar : interp_flat_type Syntax.interp_base_type (pick_type given_output_bounds)} - {e} - {e_pkg} - (** ** reification *) - (rexpr_sig : { rexpr : Expr base_type op t | forall x, Interp Syntax.interp_op rexpr x = fZ x }) - (** ** pre-wf pipeline *) - (He : e = PreWfPipeline (proj1_sig rexpr_sig)) - (** ** proving wf *) - (He_unnatize_for_wf : forall var, unnatize_expr 0 (ExprEta' e (fun t => (nat * var t)%type)) = ExprEta' e _) - (Hwf : forall var1 var2, - let P := (@reflect_wfT base_type base_type_eq_semidec_transparent op op_beq var1 var2 nil _ _ (ExprEta' e _) (ExprEta' e _)) in - trueify P = P) - (** ** post-wf-pipeline *) - (Hpost : e_pkg = PostWfPipeline e input_bounds) - (Hpost_correct : Some {| input_expr := e ; input_bounds := input_bounds ; output_bounds := b ; output_expr := e' |} = e_pkg) - (** ** renaming *) - (Hrenaming : e_final = e') - (** ** bounds relaxation *) - (Hbounds_sane : pick_type given_output_bounds = pick_type b) - (Hbounds_relax : Bounds.is_tighter_thanb b given_output_bounds = true) - (Hbounds_sane_refl - : e_final_newtype - = eq_rect _ (fun t => Expr base_type op (Arrow (pick_type input_bounds) t)) e' _ (eq_sym Hbounds_sane)) - (** ** instantiation of original evar *) - (Hevar : final_e_evar = Interp (t:=Arrow _ _) Syntax.interp_op e_final_newtype v') - (** ** side condition *) - (Hv : Bounds.is_bounded_by input_bounds (cast_back_flat_const v')) - : Bounds.is_bounded_by given_output_bounds (fZ (cast_back_flat_const v')) - /\ cast_back_flat_const final_e_evar = fZ (cast_back_flat_const v'). -Proof. - destruct rexpr_sig as [? Hrexpr]. - assert (Hwf' : Wf e) - by (apply (proj1 (@Wf_ExprEta'_iff _ _ _ e)); - eapply reflect_Wf; - [ .. | intros; split; [ eapply He_unnatize_for_wf | rewrite <- Hwf; apply trueify_true ] ]; - auto using base_type_eq_semidec_is_dec, op_beq_bl). - clear Hwf He_unnatize_for_wf. - symmetry in Hpost_correct. - subst; cbv [proj1_sig] in *. - rewrite <- Hrexpr. - eapply PostWfPipelineCorrect in Hpost_correct; [ | solve [ eauto ].. ]. - rewrite !@InterpPreWfPipeline in Hpost_correct. - unshelve eapply relax_output_bounds; try eassumption; []. - match goal with - | [ |- context[Interp _ (@eq_rect ?A ?x ?P ?k ?y ?pf) ?v] ] - => rewrite (@ap_transport A P _ x y pf (fun t e => Interp interp_op e v) k) - end. - rewrite <- transport_pp, concat_Vp; simpl. - apply Hpost_correct. -Qed. - - -(** ** Assembling the Pipeline, in Ltac *) -(** The tactic [refine_with_pipeline_correct] uses the - [PipelineCorrect] lemma to create side-conditions. It assumes the - goal is in exactly the form given in the conclusion of the - [PipelineCorrect] lemma. *) -Ltac refine_with_pipeline_correct := - lazymatch goal with - | [ |- _ /\ ?castback ?fW = ?fZ ?arg ] - => let lem := open_constr:(@PipelineCorrect _ _ _ _ _ _ _ _ _ _ _ _) in - simple refine (lem _ _ _ _ _ _ _ _ _ _ _ _); - subst fW fZ - end; - [ eexists - | cbv [proj1_sig].. ]. - -(** The tactic [solve_side_conditions] uses the above - reduction-and-proving-equality tactics to prove the - side-conditions of [PipelineCorrect]. The order must match with - [PipelineCorrect]. Which tactic to use was chosen in the - following way: - - - The default is [unify_abstract_vm_compute_rhs_reflexivity] - - - If the [RHS] is already in [vm_compute]d form, use - [unify_abstract_rhs_reflexivity] (saves a needless [vm_compute] which would be a - costly no-op) - - - If the proof needs to be transparent and there are no evars and - you want the user to see the fully [vm_compute]d term on error, - use [vm_compute; reflexivity] - - - If the user should see an unreduced term and you're proving [_ = - true], use [abstract vm_cast_no_check (eq_refl true)] - - - If you want to preserve binder names, use [unify_abstract_cbv_rhs_reflexivity] - - The other choices are tactics that are specialized to the specific - side-condition for which they are used (reification, boundedness - of input, reduction of [Interp], renaming). *) -Ltac solve_side_conditions := - [> - (** ** reification *) - do_reify | - (** ** pre-wf pipeline *) - unify_abstract_vm_compute_rhs_reflexivity | - (** ** reflective wf side-condition 1 *) - unify_abstract_vm_compute_rhs_reflexivity | - (** ** reflective wf side-condition 2 *) - unify_abstract_vm_compute_rhs_reflexivity | - (** ** post-wf pipeline *) - unify_abstract_vm_compute_rhs_reflexivity | - (** ** post-wf pipeline gives [Some _] *) - unify_abstract_rhs_reflexivity | - (** ** renaming binders *) - unify_abstract_renamify_rhs_reflexivity | - (** ** types computed from given output bounds are the same as types computed from computed output bounds *) - (** N.B. the proof must be exactly [eq_refl] because it's used in a - later goal and needs to reduce *) - subst_let; clear; vm_compute; reflexivity | - (** ** computed output bounds are not looser than the given output bounds *) - (** we do subst and we don't [vm_compute] first because we want to - get an error message that displays the bounds *) - subst_let; clear; abstract vm_cast_no_check (eq_refl true) | - (** ** removal of a cast across the equality proof above *) - unify_abstract_compute_rhs_reflexivity | - (** ** unfolding of [interp] constants *) - unify_abstract_cbv_interp_rhs_reflexivity | - (** ** boundedness of inputs *) - abstract handle_bounds_from_hyps ]. - - -(** ** The Entire Pipeline *) -(** The [do_reflective_pipeline] tactic solves a goal of the form that - is described at the top of this file, and is the public interface - of this file. *) -Ltac do_reflective_pipeline := - refine_with_pipeline_correct; solve_side_conditions. diff --git a/src/Reflection/Z/Bounds/Relax.v b/src/Reflection/Z/Bounds/Relax.v deleted file mode 100644 index e77ef423a..000000000 --- a/src/Reflection/Z/Bounds/Relax.v +++ /dev/null @@ -1,127 +0,0 @@ -Require Import Coq.ZArith.ZArith. -Require Import Coq.Classes.Morphisms. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.TypeInversion. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.Syntax.Equality. -Require Import Crypto.Reflection.Z.Syntax.Util. -Require Import Crypto.Reflection.Z.Bounds.Interpretation. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Tactics.SpecializeBy. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.SplitInContext. -Require Import Crypto.Util.ZUtil. -Require Import Crypto.Util.Bool. - -Local Lemma helper logsz v - : (v < 2 ^ 2 ^ Z.of_nat logsz)%Z <-> (Z.to_nat (Z.log2_up (Z.log2_up (1 + v))) <= logsz)%nat. -Proof. - rewrite Nat2Z.inj_le, Z2Nat.id by auto with zarith. - transitivity (1 + v <= 2^2^Z.of_nat logsz)%Z; [ omega | ]. - rewrite !Z.log2_up_le_pow2_full by auto with zarith. - reflexivity. -Qed. - -Local Arguments Z.pow : simpl never. -Local Arguments Z.sub !_ !_. -Local Arguments Z.add !_ !_. -Local Arguments Z.mul !_ !_. -Lemma relax_output_bounds' - t (tight_output_bounds relaxed_output_bounds : interp_flat_type Bounds.interp_base_type t) - (Hv : SmartFlatTypeMap (fun _ => Bounds.bounds_to_base_type) relaxed_output_bounds - = SmartFlatTypeMap (fun _ => Bounds.bounds_to_base_type) tight_output_bounds) - v k - (v' := eq_rect _ (interp_flat_type _) v _ Hv) - (Htighter : @Bounds.is_bounded_by - t tight_output_bounds - (@cast_back_flat_const - (@Bounds.interp_base_type) t (fun _ => Bounds.bounds_to_base_type) tight_output_bounds - v') - /\ @cast_back_flat_const - (@Bounds.interp_base_type) t (fun _ => Bounds.bounds_to_base_type) tight_output_bounds - v' - = k) - (Hrelax : Bounds.is_tighter_thanb tight_output_bounds relaxed_output_bounds = true) - : @Bounds.is_bounded_by - t relaxed_output_bounds - (@cast_back_flat_const - (@Bounds.interp_base_type) t (fun _ => Bounds.bounds_to_base_type) relaxed_output_bounds - v) - /\ @cast_back_flat_const - (@Bounds.interp_base_type) t (fun _ => Bounds.bounds_to_base_type) relaxed_output_bounds - v - = k. -Proof. - destruct Htighter as [H0 H1]; subst v' k. - cbv [Bounds.is_bounded_by cast_back_flat_const Bounds.is_tighter_thanb] in *. - apply interp_flat_type_rel_pointwise_iff_relb in Hrelax. - induction t; unfold SmartFlatTypeMap in *; simpl @smart_interp_flat_map in *; inversion_flat_type. - { cbv [Bounds.is_tighter_thanb' ZRange.is_tighter_than_bool is_true SmartFlatTypeMap Bounds.bounds_to_base_type ZRange.is_bounded_by' ZRange.is_bounded_by Bounds.is_bounded_by' Bounds.bit_width_of_base_type] in *; simpl in *. - repeat first [ progress inversion_flat_type - | progress inversion_base_type - | progress destruct_head bounds - | progress split_andb - | progress Z.ltb_to_lt - | progress break_match_hyps - | progress destruct_head'_and - | progress simpl in * - | rewrite helper in * - | omega - | tauto - | congruence - | progress destruct_head @eq; (reflexivity || omega) - | progress break_innermost_match_step - | apply conj ]. } - { compute in *; tauto. } - { simpl in *. - specialize (fun Hv => IHt1 (fst tight_output_bounds) (fst relaxed_output_bounds) Hv (fst v)). - specialize (fun Hv => IHt2 (snd tight_output_bounds) (snd relaxed_output_bounds) Hv (snd v)). - do 2 match goal with - | [ H : _ = _, H' : forall x, _ |- _ ] => specialize (H' H) - end. - simpl in *. - split_and. - repeat apply conj; - [ match goal with H : _ |- _ => apply H end.. - | apply (f_equal2 (@pair _ _)); (etransitivity; [ match goal with H : _ |- _ => apply H end | ]) ]; - repeat first [ progress destruct_head prod - | progress simpl in * - | reflexivity - | assumption - | match goal with - | [ |- ?P (eq_rect _ _ _ _ _) = ?P _ ] - => apply f_equal; clear - | [ H : interp_flat_type_rel_pointwise (@Bounds.is_bounded_by') ?x ?y |- interp_flat_type_rel_pointwise (@Bounds.is_bounded_by') ?x ?y' ] - => clear -H; - match goal with |- ?R _ _ => generalize dependent R; intros end - | [ H : ?x = ?y |- _ ] - => first [ generalize dependent x | generalize dependent y ]; - let k := fresh in intro k; intros; subst k - end ]. } -Qed. - -Lemma relax_output_bounds - t (tight_output_bounds relaxed_output_bounds : interp_flat_type Bounds.interp_base_type t) - (Hv : SmartFlatTypeMap (fun _ => Bounds.bounds_to_base_type) relaxed_output_bounds - = SmartFlatTypeMap (fun _ => Bounds.bounds_to_base_type) tight_output_bounds) - v k - (v' := eq_rect _ (interp_flat_type _) v _ Hv) - (Htighter : @Bounds.is_bounded_by t tight_output_bounds k - /\ @cast_back_flat_const - (@Bounds.interp_base_type) t (fun _ => Bounds.bounds_to_base_type) tight_output_bounds - v' - = k) - (Hrelax : Bounds.is_tighter_thanb tight_output_bounds relaxed_output_bounds = true) - : @Bounds.is_bounded_by t relaxed_output_bounds k - /\ @cast_back_flat_const - (@Bounds.interp_base_type) t (fun _ => Bounds.bounds_to_base_type) relaxed_output_bounds - v - = k. -Proof. - pose proof (fun pf => @relax_output_bounds' t tight_output_bounds relaxed_output_bounds Hv v k (conj pf (proj2 Htighter)) Hrelax) as H. - destruct H as [H1 H2]; [ | rewrite <- H2; tauto ]. - subst v'. - destruct Htighter; subst k; assumption. -Qed. diff --git a/src/Reflection/Z/CNotations.v b/src/Reflection/Z/CNotations.v deleted file mode 100644 index 77220a7bf..000000000 --- a/src/Reflection/Z/CNotations.v +++ /dev/null @@ -1,773 +0,0 @@ -Require Export Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Z.Syntax. -Require Export Crypto.Reflection.Z.HexNotationConstants. -Require Export Crypto.Util.Notations. - -Reserved Notation "T x = A ; b" (at level 200, b at level 200, format "T x = A ; '//' b"). -Reserved Notation "x & y" (at level 40). - -Global Open Scope expr_scope. - -Notation "T x = A ; b" := (LetIn (tx:=T) A (fun x => b)) : expr_scope. -(* python: -<< -types = ('bool', 'uint8_t', 'uint8_t', 'uint8_t', 'uint16_t', 'uint32_t', 'uint64_t', 'uint128_t') -for lgwordsz in range(0, len(types)): - print('Notation "\'%s\'" := (Tbase (TWord %d)).' % (types[lgwordsz], lgwordsz)) -print('Notation ℤ := (Tbase TZ).') -print('') -cast_pat = "'(%s)' %s" -for opn, op, lvl in (('*', 'Mul', 40), ('+', 'Add', 50), ('-', 'Sub', 50), ('&', 'Land', 40), ('<<', 'Shl', 30)): - for v1 in (False, True): - for v2 in (False, True): - lhs = ('x' if not v1 else '(Var x)') - rhs = ('y' if not v2 else '(Var y)') - print('Notation "x %s y" := (Op (%s _ _ _) (Pair %s %s)).' % (opn, op, lhs, rhs)) - for lgwordsz in range(0, len(types)): - for v1 in (False, True): - for v2 in (False, True): - lhs = ('x' if not v1 else '(Var x)') - rhs = ('y' if not v2 else '(Var y)') - print('Notation "%s %s %s" := (Op (%s (TWord _) (TWord _) (TWord %d)) (Pair %s %s)) (at level %d).' - % (cast_pat % (types[lgwordsz], 'x'), opn, cast_pat % (types[lgwordsz], 'y'), - op, lgwordsz, lhs, rhs, lvl)) - for v1 in (False, True): - for v2 in (False, True): - lhs = ('x' if not v1 else '(Var x)') - rhs = ('y' if not v2 else '(Var y)') - print('Notation "%s %s %s" := (Op (%s (TWord %d) (TWord _) (TWord %d)) (Pair %s %s)) (at level %d).' - % ('x', opn, cast_pat % (types[lgwordsz], 'y'), - op, lgwordsz, lgwordsz, lhs, rhs, lvl)) - print('Notation "%s %s %s" := (Op (%s (TWord _) (TWord %d) (TWord %d)) (Pair %s %s)) (at level %d).' - % (cast_pat % (types[lgwordsz], 'x'), opn, 'y', - op, lgwordsz, lgwordsz, lhs, rhs, lvl)) - for v1 in (False, True): - for v2 in (False, True): - lhs = ('x' if not v1 else '(Var x)') - rhs = ('y' if not v2 else '(Var y)') - print('Notation "x %s y" := (Op (%s (TWord %d) (TWord %d) (TWord %d)) (Pair %s %s)).' - % (opn, op, lgwordsz, lgwordsz, lgwordsz, lhs, rhs)) -for opn, op, lvl in (('>>', 'Shr', 30),): - for v1 in (False, True): - for v2 in (False, True): - lhs = ('x' if not v1 else '(Var x)') - rhs = ('y' if not v2 else '(Var y)') - print('Notation "x %s y" := (Op (%s _ _ _) (Pair %s %s)).' % (opn, op, lhs, rhs)) - for lgwordsz in range(0, len(types)): - for v1 in (False, True): - for v2 in (False, True): - lhs = ('x' if not v1 else '(Var x)') - rhs = ('y' if not v2 else '(Var y)') - print('Notation "\'(%s)\' ( x %s y )" := (Op (%s (TWord _) (TWord _) (TWord %d)) (Pair %s %s)) (at level %d).' - % (types[lgwordsz], opn, op, lgwordsz, lhs, rhs, lvl)) -print('Notation Return x := (Var x).') -print('Notation C_like := (Expr base_type op _).') ->> *) -Notation "'bool'" := (Tbase (TWord 0)). -Notation "'uint8_t'" := (Tbase (TWord 1)). -Notation "'uint8_t'" := (Tbase (TWord 2)). -Notation "'uint8_t'" := (Tbase (TWord 3)). -Notation "'uint16_t'" := (Tbase (TWord 4)). -Notation "'uint32_t'" := (Tbase (TWord 5)). -Notation "'uint64_t'" := (Tbase (TWord 6)). -Notation "'uint128_t'" := (Tbase (TWord 7)). -Notation ℤ := (Tbase TZ). - -Notation "x * y" := (Op (Mul _ _ _) (Pair x y)). -Notation "x * y" := (Op (Mul _ _ _) (Pair x (Var y))). -Notation "x * y" := (Op (Mul _ _ _) (Pair (Var x) y)). -Notation "x * y" := (Op (Mul _ _ _) (Pair (Var x) (Var y))). -Notation "'(bool)' x * '(bool)' y" := (Op (Mul (TWord _) (TWord _) (TWord 0)) (Pair x y)) (at level 40). -Notation "'(bool)' x * '(bool)' y" := (Op (Mul (TWord _) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 40). -Notation "'(bool)' x * '(bool)' y" := (Op (Mul (TWord _) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 40). -Notation "'(bool)' x * '(bool)' y" := (Op (Mul (TWord _) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * '(bool)' y" := (Op (Mul (TWord 0) (TWord _) (TWord 0)) (Pair x y)) (at level 40). -Notation "'(bool)' x * y" := (Op (Mul (TWord _) (TWord 0) (TWord 0)) (Pair x y)) (at level 40). -Notation "x * '(bool)' y" := (Op (Mul (TWord 0) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 40). -Notation "'(bool)' x * y" := (Op (Mul (TWord _) (TWord 0) (TWord 0)) (Pair x (Var y))) (at level 40). -Notation "x * '(bool)' y" := (Op (Mul (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 40). -Notation "'(bool)' x * y" := (Op (Mul (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) y)) (at level 40). -Notation "x * '(bool)' y" := (Op (Mul (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(bool)' x * y" := (Op (Mul (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * y" := (Op (Mul (TWord 0) (TWord 0) (TWord 0)) (Pair x y)). -Notation "x * y" := (Op (Mul (TWord 0) (TWord 0) (TWord 0)) (Pair x (Var y))). -Notation "x * y" := (Op (Mul (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) y)). -Notation "x * y" := (Op (Mul (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))). -Notation "'(uint8_t)' x * '(uint8_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 1)) (Pair x y)) (at level 40). -Notation "'(uint8_t)' x * '(uint8_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 40). -Notation "'(uint8_t)' x * '(uint8_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 40). -Notation "'(uint8_t)' x * '(uint8_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * '(uint8_t)' y" := (Op (Mul (TWord 1) (TWord _) (TWord 1)) (Pair x y)) (at level 40). -Notation "'(uint8_t)' x * y" := (Op (Mul (TWord _) (TWord 1) (TWord 1)) (Pair x y)) (at level 40). -Notation "x * '(uint8_t)' y" := (Op (Mul (TWord 1) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 40). -Notation "'(uint8_t)' x * y" := (Op (Mul (TWord _) (TWord 1) (TWord 1)) (Pair x (Var y))) (at level 40). -Notation "x * '(uint8_t)' y" := (Op (Mul (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 40). -Notation "'(uint8_t)' x * y" := (Op (Mul (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) y)) (at level 40). -Notation "x * '(uint8_t)' y" := (Op (Mul (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(uint8_t)' x * y" := (Op (Mul (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * y" := (Op (Mul (TWord 1) (TWord 1) (TWord 1)) (Pair x y)). -Notation "x * y" := (Op (Mul (TWord 1) (TWord 1) (TWord 1)) (Pair x (Var y))). -Notation "x * y" := (Op (Mul (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) y)). -Notation "x * y" := (Op (Mul (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))). -Notation "'(uint8_t)' x * '(uint8_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 2)) (Pair x y)) (at level 40). -Notation "'(uint8_t)' x * '(uint8_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 40). -Notation "'(uint8_t)' x * '(uint8_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 40). -Notation "'(uint8_t)' x * '(uint8_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * '(uint8_t)' y" := (Op (Mul (TWord 2) (TWord _) (TWord 2)) (Pair x y)) (at level 40). -Notation "'(uint8_t)' x * y" := (Op (Mul (TWord _) (TWord 2) (TWord 2)) (Pair x y)) (at level 40). -Notation "x * '(uint8_t)' y" := (Op (Mul (TWord 2) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 40). -Notation "'(uint8_t)' x * y" := (Op (Mul (TWord _) (TWord 2) (TWord 2)) (Pair x (Var y))) (at level 40). -Notation "x * '(uint8_t)' y" := (Op (Mul (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 40). -Notation "'(uint8_t)' x * y" := (Op (Mul (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) y)) (at level 40). -Notation "x * '(uint8_t)' y" := (Op (Mul (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(uint8_t)' x * y" := (Op (Mul (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * y" := (Op (Mul (TWord 2) (TWord 2) (TWord 2)) (Pair x y)). -Notation "x * y" := (Op (Mul (TWord 2) (TWord 2) (TWord 2)) (Pair x (Var y))). -Notation "x * y" := (Op (Mul (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) y)). -Notation "x * y" := (Op (Mul (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))). -Notation "'(uint8_t)' x * '(uint8_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 3)) (Pair x y)) (at level 40). -Notation "'(uint8_t)' x * '(uint8_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 40). -Notation "'(uint8_t)' x * '(uint8_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 40). -Notation "'(uint8_t)' x * '(uint8_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * '(uint8_t)' y" := (Op (Mul (TWord 3) (TWord _) (TWord 3)) (Pair x y)) (at level 40). -Notation "'(uint8_t)' x * y" := (Op (Mul (TWord _) (TWord 3) (TWord 3)) (Pair x y)) (at level 40). -Notation "x * '(uint8_t)' y" := (Op (Mul (TWord 3) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 40). -Notation "'(uint8_t)' x * y" := (Op (Mul (TWord _) (TWord 3) (TWord 3)) (Pair x (Var y))) (at level 40). -Notation "x * '(uint8_t)' y" := (Op (Mul (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 40). -Notation "'(uint8_t)' x * y" := (Op (Mul (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) y)) (at level 40). -Notation "x * '(uint8_t)' y" := (Op (Mul (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(uint8_t)' x * y" := (Op (Mul (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * y" := (Op (Mul (TWord 3) (TWord 3) (TWord 3)) (Pair x y)). -Notation "x * y" := (Op (Mul (TWord 3) (TWord 3) (TWord 3)) (Pair x (Var y))). -Notation "x * y" := (Op (Mul (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) y)). -Notation "x * y" := (Op (Mul (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))). -Notation "'(uint16_t)' x * '(uint16_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 4)) (Pair x y)) (at level 40). -Notation "'(uint16_t)' x * '(uint16_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 40). -Notation "'(uint16_t)' x * '(uint16_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 40). -Notation "'(uint16_t)' x * '(uint16_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * '(uint16_t)' y" := (Op (Mul (TWord 4) (TWord _) (TWord 4)) (Pair x y)) (at level 40). -Notation "'(uint16_t)' x * y" := (Op (Mul (TWord _) (TWord 4) (TWord 4)) (Pair x y)) (at level 40). -Notation "x * '(uint16_t)' y" := (Op (Mul (TWord 4) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 40). -Notation "'(uint16_t)' x * y" := (Op (Mul (TWord _) (TWord 4) (TWord 4)) (Pair x (Var y))) (at level 40). -Notation "x * '(uint16_t)' y" := (Op (Mul (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 40). -Notation "'(uint16_t)' x * y" := (Op (Mul (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) y)) (at level 40). -Notation "x * '(uint16_t)' y" := (Op (Mul (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(uint16_t)' x * y" := (Op (Mul (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * y" := (Op (Mul (TWord 4) (TWord 4) (TWord 4)) (Pair x y)). -Notation "x * y" := (Op (Mul (TWord 4) (TWord 4) (TWord 4)) (Pair x (Var y))). -Notation "x * y" := (Op (Mul (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) y)). -Notation "x * y" := (Op (Mul (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))). -Notation "'(uint32_t)' x * '(uint32_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 5)) (Pair x y)) (at level 40). -Notation "'(uint32_t)' x * '(uint32_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 40). -Notation "'(uint32_t)' x * '(uint32_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 40). -Notation "'(uint32_t)' x * '(uint32_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * '(uint32_t)' y" := (Op (Mul (TWord 5) (TWord _) (TWord 5)) (Pair x y)) (at level 40). -Notation "'(uint32_t)' x * y" := (Op (Mul (TWord _) (TWord 5) (TWord 5)) (Pair x y)) (at level 40). -Notation "x * '(uint32_t)' y" := (Op (Mul (TWord 5) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 40). -Notation "'(uint32_t)' x * y" := (Op (Mul (TWord _) (TWord 5) (TWord 5)) (Pair x (Var y))) (at level 40). -Notation "x * '(uint32_t)' y" := (Op (Mul (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 40). -Notation "'(uint32_t)' x * y" := (Op (Mul (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) y)) (at level 40). -Notation "x * '(uint32_t)' y" := (Op (Mul (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(uint32_t)' x * y" := (Op (Mul (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * y" := (Op (Mul (TWord 5) (TWord 5) (TWord 5)) (Pair x y)). -Notation "x * y" := (Op (Mul (TWord 5) (TWord 5) (TWord 5)) (Pair x (Var y))). -Notation "x * y" := (Op (Mul (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) y)). -Notation "x * y" := (Op (Mul (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))). -Notation "'(uint64_t)' x * '(uint64_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 6)) (Pair x y)) (at level 40). -Notation "'(uint64_t)' x * '(uint64_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 40). -Notation "'(uint64_t)' x * '(uint64_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 40). -Notation "'(uint64_t)' x * '(uint64_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * '(uint64_t)' y" := (Op (Mul (TWord 6) (TWord _) (TWord 6)) (Pair x y)) (at level 40). -Notation "'(uint64_t)' x * y" := (Op (Mul (TWord _) (TWord 6) (TWord 6)) (Pair x y)) (at level 40). -Notation "x * '(uint64_t)' y" := (Op (Mul (TWord 6) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 40). -Notation "'(uint64_t)' x * y" := (Op (Mul (TWord _) (TWord 6) (TWord 6)) (Pair x (Var y))) (at level 40). -Notation "x * '(uint64_t)' y" := (Op (Mul (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 40). -Notation "'(uint64_t)' x * y" := (Op (Mul (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) y)) (at level 40). -Notation "x * '(uint64_t)' y" := (Op (Mul (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(uint64_t)' x * y" := (Op (Mul (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * y" := (Op (Mul (TWord 6) (TWord 6) (TWord 6)) (Pair x y)). -Notation "x * y" := (Op (Mul (TWord 6) (TWord 6) (TWord 6)) (Pair x (Var y))). -Notation "x * y" := (Op (Mul (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) y)). -Notation "x * y" := (Op (Mul (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))). -Notation "'(uint128_t)' x * '(uint128_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 7)) (Pair x y)) (at level 40). -Notation "'(uint128_t)' x * '(uint128_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 40). -Notation "'(uint128_t)' x * '(uint128_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 40). -Notation "'(uint128_t)' x * '(uint128_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * '(uint128_t)' y" := (Op (Mul (TWord 7) (TWord _) (TWord 7)) (Pair x y)) (at level 40). -Notation "'(uint128_t)' x * y" := (Op (Mul (TWord _) (TWord 7) (TWord 7)) (Pair x y)) (at level 40). -Notation "x * '(uint128_t)' y" := (Op (Mul (TWord 7) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 40). -Notation "'(uint128_t)' x * y" := (Op (Mul (TWord _) (TWord 7) (TWord 7)) (Pair x (Var y))) (at level 40). -Notation "x * '(uint128_t)' y" := (Op (Mul (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 40). -Notation "'(uint128_t)' x * y" := (Op (Mul (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) y)) (at level 40). -Notation "x * '(uint128_t)' y" := (Op (Mul (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(uint128_t)' x * y" := (Op (Mul (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * y" := (Op (Mul (TWord 7) (TWord 7) (TWord 7)) (Pair x y)). -Notation "x * y" := (Op (Mul (TWord 7) (TWord 7) (TWord 7)) (Pair x (Var y))). -Notation "x * y" := (Op (Mul (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) y)). -Notation "x * y" := (Op (Mul (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))). -Notation "x + y" := (Op (Add _ _ _) (Pair x y)). -Notation "x + y" := (Op (Add _ _ _) (Pair x (Var y))). -Notation "x + y" := (Op (Add _ _ _) (Pair (Var x) y)). -Notation "x + y" := (Op (Add _ _ _) (Pair (Var x) (Var y))). -Notation "'(bool)' x + '(bool)' y" := (Op (Add (TWord _) (TWord _) (TWord 0)) (Pair x y)) (at level 50). -Notation "'(bool)' x + '(bool)' y" := (Op (Add (TWord _) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 50). -Notation "'(bool)' x + '(bool)' y" := (Op (Add (TWord _) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 50). -Notation "'(bool)' x + '(bool)' y" := (Op (Add (TWord _) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + '(bool)' y" := (Op (Add (TWord 0) (TWord _) (TWord 0)) (Pair x y)) (at level 50). -Notation "'(bool)' x + y" := (Op (Add (TWord _) (TWord 0) (TWord 0)) (Pair x y)) (at level 50). -Notation "x + '(bool)' y" := (Op (Add (TWord 0) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 50). -Notation "'(bool)' x + y" := (Op (Add (TWord _) (TWord 0) (TWord 0)) (Pair x (Var y))) (at level 50). -Notation "x + '(bool)' y" := (Op (Add (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 50). -Notation "'(bool)' x + y" := (Op (Add (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) y)) (at level 50). -Notation "x + '(bool)' y" := (Op (Add (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(bool)' x + y" := (Op (Add (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + y" := (Op (Add (TWord 0) (TWord 0) (TWord 0)) (Pair x y)). -Notation "x + y" := (Op (Add (TWord 0) (TWord 0) (TWord 0)) (Pair x (Var y))). -Notation "x + y" := (Op (Add (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) y)). -Notation "x + y" := (Op (Add (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))). -Notation "'(uint8_t)' x + '(uint8_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 1)) (Pair x y)) (at level 50). -Notation "'(uint8_t)' x + '(uint8_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 50). -Notation "'(uint8_t)' x + '(uint8_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 50). -Notation "'(uint8_t)' x + '(uint8_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + '(uint8_t)' y" := (Op (Add (TWord 1) (TWord _) (TWord 1)) (Pair x y)) (at level 50). -Notation "'(uint8_t)' x + y" := (Op (Add (TWord _) (TWord 1) (TWord 1)) (Pair x y)) (at level 50). -Notation "x + '(uint8_t)' y" := (Op (Add (TWord 1) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 50). -Notation "'(uint8_t)' x + y" := (Op (Add (TWord _) (TWord 1) (TWord 1)) (Pair x (Var y))) (at level 50). -Notation "x + '(uint8_t)' y" := (Op (Add (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 50). -Notation "'(uint8_t)' x + y" := (Op (Add (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) y)) (at level 50). -Notation "x + '(uint8_t)' y" := (Op (Add (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(uint8_t)' x + y" := (Op (Add (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + y" := (Op (Add (TWord 1) (TWord 1) (TWord 1)) (Pair x y)). -Notation "x + y" := (Op (Add (TWord 1) (TWord 1) (TWord 1)) (Pair x (Var y))). -Notation "x + y" := (Op (Add (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) y)). -Notation "x + y" := (Op (Add (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))). -Notation "'(uint8_t)' x + '(uint8_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 2)) (Pair x y)) (at level 50). -Notation "'(uint8_t)' x + '(uint8_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 50). -Notation "'(uint8_t)' x + '(uint8_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 50). -Notation "'(uint8_t)' x + '(uint8_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + '(uint8_t)' y" := (Op (Add (TWord 2) (TWord _) (TWord 2)) (Pair x y)) (at level 50). -Notation "'(uint8_t)' x + y" := (Op (Add (TWord _) (TWord 2) (TWord 2)) (Pair x y)) (at level 50). -Notation "x + '(uint8_t)' y" := (Op (Add (TWord 2) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 50). -Notation "'(uint8_t)' x + y" := (Op (Add (TWord _) (TWord 2) (TWord 2)) (Pair x (Var y))) (at level 50). -Notation "x + '(uint8_t)' y" := (Op (Add (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 50). -Notation "'(uint8_t)' x + y" := (Op (Add (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) y)) (at level 50). -Notation "x + '(uint8_t)' y" := (Op (Add (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(uint8_t)' x + y" := (Op (Add (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + y" := (Op (Add (TWord 2) (TWord 2) (TWord 2)) (Pair x y)). -Notation "x + y" := (Op (Add (TWord 2) (TWord 2) (TWord 2)) (Pair x (Var y))). -Notation "x + y" := (Op (Add (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) y)). -Notation "x + y" := (Op (Add (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))). -Notation "'(uint8_t)' x + '(uint8_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 3)) (Pair x y)) (at level 50). -Notation "'(uint8_t)' x + '(uint8_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 50). -Notation "'(uint8_t)' x + '(uint8_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 50). -Notation "'(uint8_t)' x + '(uint8_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + '(uint8_t)' y" := (Op (Add (TWord 3) (TWord _) (TWord 3)) (Pair x y)) (at level 50). -Notation "'(uint8_t)' x + y" := (Op (Add (TWord _) (TWord 3) (TWord 3)) (Pair x y)) (at level 50). -Notation "x + '(uint8_t)' y" := (Op (Add (TWord 3) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 50). -Notation "'(uint8_t)' x + y" := (Op (Add (TWord _) (TWord 3) (TWord 3)) (Pair x (Var y))) (at level 50). -Notation "x + '(uint8_t)' y" := (Op (Add (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 50). -Notation "'(uint8_t)' x + y" := (Op (Add (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) y)) (at level 50). -Notation "x + '(uint8_t)' y" := (Op (Add (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(uint8_t)' x + y" := (Op (Add (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + y" := (Op (Add (TWord 3) (TWord 3) (TWord 3)) (Pair x y)). -Notation "x + y" := (Op (Add (TWord 3) (TWord 3) (TWord 3)) (Pair x (Var y))). -Notation "x + y" := (Op (Add (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) y)). -Notation "x + y" := (Op (Add (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))). -Notation "'(uint16_t)' x + '(uint16_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 4)) (Pair x y)) (at level 50). -Notation "'(uint16_t)' x + '(uint16_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 50). -Notation "'(uint16_t)' x + '(uint16_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 50). -Notation "'(uint16_t)' x + '(uint16_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + '(uint16_t)' y" := (Op (Add (TWord 4) (TWord _) (TWord 4)) (Pair x y)) (at level 50). -Notation "'(uint16_t)' x + y" := (Op (Add (TWord _) (TWord 4) (TWord 4)) (Pair x y)) (at level 50). -Notation "x + '(uint16_t)' y" := (Op (Add (TWord 4) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 50). -Notation "'(uint16_t)' x + y" := (Op (Add (TWord _) (TWord 4) (TWord 4)) (Pair x (Var y))) (at level 50). -Notation "x + '(uint16_t)' y" := (Op (Add (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 50). -Notation "'(uint16_t)' x + y" := (Op (Add (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) y)) (at level 50). -Notation "x + '(uint16_t)' y" := (Op (Add (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(uint16_t)' x + y" := (Op (Add (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + y" := (Op (Add (TWord 4) (TWord 4) (TWord 4)) (Pair x y)). -Notation "x + y" := (Op (Add (TWord 4) (TWord 4) (TWord 4)) (Pair x (Var y))). -Notation "x + y" := (Op (Add (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) y)). -Notation "x + y" := (Op (Add (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))). -Notation "'(uint32_t)' x + '(uint32_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 5)) (Pair x y)) (at level 50). -Notation "'(uint32_t)' x + '(uint32_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 50). -Notation "'(uint32_t)' x + '(uint32_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 50). -Notation "'(uint32_t)' x + '(uint32_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + '(uint32_t)' y" := (Op (Add (TWord 5) (TWord _) (TWord 5)) (Pair x y)) (at level 50). -Notation "'(uint32_t)' x + y" := (Op (Add (TWord _) (TWord 5) (TWord 5)) (Pair x y)) (at level 50). -Notation "x + '(uint32_t)' y" := (Op (Add (TWord 5) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 50). -Notation "'(uint32_t)' x + y" := (Op (Add (TWord _) (TWord 5) (TWord 5)) (Pair x (Var y))) (at level 50). -Notation "x + '(uint32_t)' y" := (Op (Add (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 50). -Notation "'(uint32_t)' x + y" := (Op (Add (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) y)) (at level 50). -Notation "x + '(uint32_t)' y" := (Op (Add (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(uint32_t)' x + y" := (Op (Add (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + y" := (Op (Add (TWord 5) (TWord 5) (TWord 5)) (Pair x y)). -Notation "x + y" := (Op (Add (TWord 5) (TWord 5) (TWord 5)) (Pair x (Var y))). -Notation "x + y" := (Op (Add (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) y)). -Notation "x + y" := (Op (Add (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))). -Notation "'(uint64_t)' x + '(uint64_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 6)) (Pair x y)) (at level 50). -Notation "'(uint64_t)' x + '(uint64_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 50). -Notation "'(uint64_t)' x + '(uint64_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 50). -Notation "'(uint64_t)' x + '(uint64_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + '(uint64_t)' y" := (Op (Add (TWord 6) (TWord _) (TWord 6)) (Pair x y)) (at level 50). -Notation "'(uint64_t)' x + y" := (Op (Add (TWord _) (TWord 6) (TWord 6)) (Pair x y)) (at level 50). -Notation "x + '(uint64_t)' y" := (Op (Add (TWord 6) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 50). -Notation "'(uint64_t)' x + y" := (Op (Add (TWord _) (TWord 6) (TWord 6)) (Pair x (Var y))) (at level 50). -Notation "x + '(uint64_t)' y" := (Op (Add (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 50). -Notation "'(uint64_t)' x + y" := (Op (Add (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) y)) (at level 50). -Notation "x + '(uint64_t)' y" := (Op (Add (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(uint64_t)' x + y" := (Op (Add (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + y" := (Op (Add (TWord 6) (TWord 6) (TWord 6)) (Pair x y)). -Notation "x + y" := (Op (Add (TWord 6) (TWord 6) (TWord 6)) (Pair x (Var y))). -Notation "x + y" := (Op (Add (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) y)). -Notation "x + y" := (Op (Add (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))). -Notation "'(uint128_t)' x + '(uint128_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 7)) (Pair x y)) (at level 50). -Notation "'(uint128_t)' x + '(uint128_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 50). -Notation "'(uint128_t)' x + '(uint128_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 50). -Notation "'(uint128_t)' x + '(uint128_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + '(uint128_t)' y" := (Op (Add (TWord 7) (TWord _) (TWord 7)) (Pair x y)) (at level 50). -Notation "'(uint128_t)' x + y" := (Op (Add (TWord _) (TWord 7) (TWord 7)) (Pair x y)) (at level 50). -Notation "x + '(uint128_t)' y" := (Op (Add (TWord 7) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 50). -Notation "'(uint128_t)' x + y" := (Op (Add (TWord _) (TWord 7) (TWord 7)) (Pair x (Var y))) (at level 50). -Notation "x + '(uint128_t)' y" := (Op (Add (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 50). -Notation "'(uint128_t)' x + y" := (Op (Add (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) y)) (at level 50). -Notation "x + '(uint128_t)' y" := (Op (Add (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(uint128_t)' x + y" := (Op (Add (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + y" := (Op (Add (TWord 7) (TWord 7) (TWord 7)) (Pair x y)). -Notation "x + y" := (Op (Add (TWord 7) (TWord 7) (TWord 7)) (Pair x (Var y))). -Notation "x + y" := (Op (Add (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) y)). -Notation "x + y" := (Op (Add (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))). -Notation "x - y" := (Op (Sub _ _ _) (Pair x y)). -Notation "x - y" := (Op (Sub _ _ _) (Pair x (Var y))). -Notation "x - y" := (Op (Sub _ _ _) (Pair (Var x) y)). -Notation "x - y" := (Op (Sub _ _ _) (Pair (Var x) (Var y))). -Notation "'(bool)' x - '(bool)' y" := (Op (Sub (TWord _) (TWord _) (TWord 0)) (Pair x y)) (at level 50). -Notation "'(bool)' x - '(bool)' y" := (Op (Sub (TWord _) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 50). -Notation "'(bool)' x - '(bool)' y" := (Op (Sub (TWord _) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 50). -Notation "'(bool)' x - '(bool)' y" := (Op (Sub (TWord _) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - '(bool)' y" := (Op (Sub (TWord 0) (TWord _) (TWord 0)) (Pair x y)) (at level 50). -Notation "'(bool)' x - y" := (Op (Sub (TWord _) (TWord 0) (TWord 0)) (Pair x y)) (at level 50). -Notation "x - '(bool)' y" := (Op (Sub (TWord 0) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 50). -Notation "'(bool)' x - y" := (Op (Sub (TWord _) (TWord 0) (TWord 0)) (Pair x (Var y))) (at level 50). -Notation "x - '(bool)' y" := (Op (Sub (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 50). -Notation "'(bool)' x - y" := (Op (Sub (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) y)) (at level 50). -Notation "x - '(bool)' y" := (Op (Sub (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(bool)' x - y" := (Op (Sub (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - y" := (Op (Sub (TWord 0) (TWord 0) (TWord 0)) (Pair x y)). -Notation "x - y" := (Op (Sub (TWord 0) (TWord 0) (TWord 0)) (Pair x (Var y))). -Notation "x - y" := (Op (Sub (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) y)). -Notation "x - y" := (Op (Sub (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))). -Notation "'(uint8_t)' x - '(uint8_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 1)) (Pair x y)) (at level 50). -Notation "'(uint8_t)' x - '(uint8_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 50). -Notation "'(uint8_t)' x - '(uint8_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 50). -Notation "'(uint8_t)' x - '(uint8_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - '(uint8_t)' y" := (Op (Sub (TWord 1) (TWord _) (TWord 1)) (Pair x y)) (at level 50). -Notation "'(uint8_t)' x - y" := (Op (Sub (TWord _) (TWord 1) (TWord 1)) (Pair x y)) (at level 50). -Notation "x - '(uint8_t)' y" := (Op (Sub (TWord 1) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 50). -Notation "'(uint8_t)' x - y" := (Op (Sub (TWord _) (TWord 1) (TWord 1)) (Pair x (Var y))) (at level 50). -Notation "x - '(uint8_t)' y" := (Op (Sub (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 50). -Notation "'(uint8_t)' x - y" := (Op (Sub (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) y)) (at level 50). -Notation "x - '(uint8_t)' y" := (Op (Sub (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(uint8_t)' x - y" := (Op (Sub (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - y" := (Op (Sub (TWord 1) (TWord 1) (TWord 1)) (Pair x y)). -Notation "x - y" := (Op (Sub (TWord 1) (TWord 1) (TWord 1)) (Pair x (Var y))). -Notation "x - y" := (Op (Sub (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) y)). -Notation "x - y" := (Op (Sub (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))). -Notation "'(uint8_t)' x - '(uint8_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 2)) (Pair x y)) (at level 50). -Notation "'(uint8_t)' x - '(uint8_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 50). -Notation "'(uint8_t)' x - '(uint8_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 50). -Notation "'(uint8_t)' x - '(uint8_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - '(uint8_t)' y" := (Op (Sub (TWord 2) (TWord _) (TWord 2)) (Pair x y)) (at level 50). -Notation "'(uint8_t)' x - y" := (Op (Sub (TWord _) (TWord 2) (TWord 2)) (Pair x y)) (at level 50). -Notation "x - '(uint8_t)' y" := (Op (Sub (TWord 2) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 50). -Notation "'(uint8_t)' x - y" := (Op (Sub (TWord _) (TWord 2) (TWord 2)) (Pair x (Var y))) (at level 50). -Notation "x - '(uint8_t)' y" := (Op (Sub (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 50). -Notation "'(uint8_t)' x - y" := (Op (Sub (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) y)) (at level 50). -Notation "x - '(uint8_t)' y" := (Op (Sub (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(uint8_t)' x - y" := (Op (Sub (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - y" := (Op (Sub (TWord 2) (TWord 2) (TWord 2)) (Pair x y)). -Notation "x - y" := (Op (Sub (TWord 2) (TWord 2) (TWord 2)) (Pair x (Var y))). -Notation "x - y" := (Op (Sub (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) y)). -Notation "x - y" := (Op (Sub (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))). -Notation "'(uint8_t)' x - '(uint8_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 3)) (Pair x y)) (at level 50). -Notation "'(uint8_t)' x - '(uint8_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 50). -Notation "'(uint8_t)' x - '(uint8_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 50). -Notation "'(uint8_t)' x - '(uint8_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - '(uint8_t)' y" := (Op (Sub (TWord 3) (TWord _) (TWord 3)) (Pair x y)) (at level 50). -Notation "'(uint8_t)' x - y" := (Op (Sub (TWord _) (TWord 3) (TWord 3)) (Pair x y)) (at level 50). -Notation "x - '(uint8_t)' y" := (Op (Sub (TWord 3) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 50). -Notation "'(uint8_t)' x - y" := (Op (Sub (TWord _) (TWord 3) (TWord 3)) (Pair x (Var y))) (at level 50). -Notation "x - '(uint8_t)' y" := (Op (Sub (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 50). -Notation "'(uint8_t)' x - y" := (Op (Sub (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) y)) (at level 50). -Notation "x - '(uint8_t)' y" := (Op (Sub (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(uint8_t)' x - y" := (Op (Sub (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - y" := (Op (Sub (TWord 3) (TWord 3) (TWord 3)) (Pair x y)). -Notation "x - y" := (Op (Sub (TWord 3) (TWord 3) (TWord 3)) (Pair x (Var y))). -Notation "x - y" := (Op (Sub (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) y)). -Notation "x - y" := (Op (Sub (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))). -Notation "'(uint16_t)' x - '(uint16_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 4)) (Pair x y)) (at level 50). -Notation "'(uint16_t)' x - '(uint16_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 50). -Notation "'(uint16_t)' x - '(uint16_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 50). -Notation "'(uint16_t)' x - '(uint16_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - '(uint16_t)' y" := (Op (Sub (TWord 4) (TWord _) (TWord 4)) (Pair x y)) (at level 50). -Notation "'(uint16_t)' x - y" := (Op (Sub (TWord _) (TWord 4) (TWord 4)) (Pair x y)) (at level 50). -Notation "x - '(uint16_t)' y" := (Op (Sub (TWord 4) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 50). -Notation "'(uint16_t)' x - y" := (Op (Sub (TWord _) (TWord 4) (TWord 4)) (Pair x (Var y))) (at level 50). -Notation "x - '(uint16_t)' y" := (Op (Sub (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 50). -Notation "'(uint16_t)' x - y" := (Op (Sub (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) y)) (at level 50). -Notation "x - '(uint16_t)' y" := (Op (Sub (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(uint16_t)' x - y" := (Op (Sub (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - y" := (Op (Sub (TWord 4) (TWord 4) (TWord 4)) (Pair x y)). -Notation "x - y" := (Op (Sub (TWord 4) (TWord 4) (TWord 4)) (Pair x (Var y))). -Notation "x - y" := (Op (Sub (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) y)). -Notation "x - y" := (Op (Sub (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))). -Notation "'(uint32_t)' x - '(uint32_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 5)) (Pair x y)) (at level 50). -Notation "'(uint32_t)' x - '(uint32_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 50). -Notation "'(uint32_t)' x - '(uint32_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 50). -Notation "'(uint32_t)' x - '(uint32_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - '(uint32_t)' y" := (Op (Sub (TWord 5) (TWord _) (TWord 5)) (Pair x y)) (at level 50). -Notation "'(uint32_t)' x - y" := (Op (Sub (TWord _) (TWord 5) (TWord 5)) (Pair x y)) (at level 50). -Notation "x - '(uint32_t)' y" := (Op (Sub (TWord 5) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 50). -Notation "'(uint32_t)' x - y" := (Op (Sub (TWord _) (TWord 5) (TWord 5)) (Pair x (Var y))) (at level 50). -Notation "x - '(uint32_t)' y" := (Op (Sub (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 50). -Notation "'(uint32_t)' x - y" := (Op (Sub (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) y)) (at level 50). -Notation "x - '(uint32_t)' y" := (Op (Sub (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(uint32_t)' x - y" := (Op (Sub (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - y" := (Op (Sub (TWord 5) (TWord 5) (TWord 5)) (Pair x y)). -Notation "x - y" := (Op (Sub (TWord 5) (TWord 5) (TWord 5)) (Pair x (Var y))). -Notation "x - y" := (Op (Sub (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) y)). -Notation "x - y" := (Op (Sub (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))). -Notation "'(uint64_t)' x - '(uint64_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 6)) (Pair x y)) (at level 50). -Notation "'(uint64_t)' x - '(uint64_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 50). -Notation "'(uint64_t)' x - '(uint64_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 50). -Notation "'(uint64_t)' x - '(uint64_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - '(uint64_t)' y" := (Op (Sub (TWord 6) (TWord _) (TWord 6)) (Pair x y)) (at level 50). -Notation "'(uint64_t)' x - y" := (Op (Sub (TWord _) (TWord 6) (TWord 6)) (Pair x y)) (at level 50). -Notation "x - '(uint64_t)' y" := (Op (Sub (TWord 6) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 50). -Notation "'(uint64_t)' x - y" := (Op (Sub (TWord _) (TWord 6) (TWord 6)) (Pair x (Var y))) (at level 50). -Notation "x - '(uint64_t)' y" := (Op (Sub (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 50). -Notation "'(uint64_t)' x - y" := (Op (Sub (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) y)) (at level 50). -Notation "x - '(uint64_t)' y" := (Op (Sub (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(uint64_t)' x - y" := (Op (Sub (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - y" := (Op (Sub (TWord 6) (TWord 6) (TWord 6)) (Pair x y)). -Notation "x - y" := (Op (Sub (TWord 6) (TWord 6) (TWord 6)) (Pair x (Var y))). -Notation "x - y" := (Op (Sub (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) y)). -Notation "x - y" := (Op (Sub (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))). -Notation "'(uint128_t)' x - '(uint128_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 7)) (Pair x y)) (at level 50). -Notation "'(uint128_t)' x - '(uint128_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 50). -Notation "'(uint128_t)' x - '(uint128_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 50). -Notation "'(uint128_t)' x - '(uint128_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - '(uint128_t)' y" := (Op (Sub (TWord 7) (TWord _) (TWord 7)) (Pair x y)) (at level 50). -Notation "'(uint128_t)' x - y" := (Op (Sub (TWord _) (TWord 7) (TWord 7)) (Pair x y)) (at level 50). -Notation "x - '(uint128_t)' y" := (Op (Sub (TWord 7) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 50). -Notation "'(uint128_t)' x - y" := (Op (Sub (TWord _) (TWord 7) (TWord 7)) (Pair x (Var y))) (at level 50). -Notation "x - '(uint128_t)' y" := (Op (Sub (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 50). -Notation "'(uint128_t)' x - y" := (Op (Sub (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) y)) (at level 50). -Notation "x - '(uint128_t)' y" := (Op (Sub (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(uint128_t)' x - y" := (Op (Sub (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - y" := (Op (Sub (TWord 7) (TWord 7) (TWord 7)) (Pair x y)). -Notation "x - y" := (Op (Sub (TWord 7) (TWord 7) (TWord 7)) (Pair x (Var y))). -Notation "x - y" := (Op (Sub (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) y)). -Notation "x - y" := (Op (Sub (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))). -Notation "x & y" := (Op (Land _ _ _) (Pair x y)). -Notation "x & y" := (Op (Land _ _ _) (Pair x (Var y))). -Notation "x & y" := (Op (Land _ _ _) (Pair (Var x) y)). -Notation "x & y" := (Op (Land _ _ _) (Pair (Var x) (Var y))). -Notation "'(bool)' x & '(bool)' y" := (Op (Land (TWord _) (TWord _) (TWord 0)) (Pair x y)) (at level 40). -Notation "'(bool)' x & '(bool)' y" := (Op (Land (TWord _) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 40). -Notation "'(bool)' x & '(bool)' y" := (Op (Land (TWord _) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 40). -Notation "'(bool)' x & '(bool)' y" := (Op (Land (TWord _) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & '(bool)' y" := (Op (Land (TWord 0) (TWord _) (TWord 0)) (Pair x y)) (at level 40). -Notation "'(bool)' x & y" := (Op (Land (TWord _) (TWord 0) (TWord 0)) (Pair x y)) (at level 40). -Notation "x & '(bool)' y" := (Op (Land (TWord 0) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 40). -Notation "'(bool)' x & y" := (Op (Land (TWord _) (TWord 0) (TWord 0)) (Pair x (Var y))) (at level 40). -Notation "x & '(bool)' y" := (Op (Land (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 40). -Notation "'(bool)' x & y" := (Op (Land (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) y)) (at level 40). -Notation "x & '(bool)' y" := (Op (Land (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(bool)' x & y" := (Op (Land (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & y" := (Op (Land (TWord 0) (TWord 0) (TWord 0)) (Pair x y)). -Notation "x & y" := (Op (Land (TWord 0) (TWord 0) (TWord 0)) (Pair x (Var y))). -Notation "x & y" := (Op (Land (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) y)). -Notation "x & y" := (Op (Land (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))). -Notation "'(uint8_t)' x & '(uint8_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 1)) (Pair x y)) (at level 40). -Notation "'(uint8_t)' x & '(uint8_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 40). -Notation "'(uint8_t)' x & '(uint8_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 40). -Notation "'(uint8_t)' x & '(uint8_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & '(uint8_t)' y" := (Op (Land (TWord 1) (TWord _) (TWord 1)) (Pair x y)) (at level 40). -Notation "'(uint8_t)' x & y" := (Op (Land (TWord _) (TWord 1) (TWord 1)) (Pair x y)) (at level 40). -Notation "x & '(uint8_t)' y" := (Op (Land (TWord 1) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 40). -Notation "'(uint8_t)' x & y" := (Op (Land (TWord _) (TWord 1) (TWord 1)) (Pair x (Var y))) (at level 40). -Notation "x & '(uint8_t)' y" := (Op (Land (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 40). -Notation "'(uint8_t)' x & y" := (Op (Land (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) y)) (at level 40). -Notation "x & '(uint8_t)' y" := (Op (Land (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(uint8_t)' x & y" := (Op (Land (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & y" := (Op (Land (TWord 1) (TWord 1) (TWord 1)) (Pair x y)). -Notation "x & y" := (Op (Land (TWord 1) (TWord 1) (TWord 1)) (Pair x (Var y))). -Notation "x & y" := (Op (Land (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) y)). -Notation "x & y" := (Op (Land (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))). -Notation "'(uint8_t)' x & '(uint8_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 2)) (Pair x y)) (at level 40). -Notation "'(uint8_t)' x & '(uint8_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 40). -Notation "'(uint8_t)' x & '(uint8_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 40). -Notation "'(uint8_t)' x & '(uint8_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & '(uint8_t)' y" := (Op (Land (TWord 2) (TWord _) (TWord 2)) (Pair x y)) (at level 40). -Notation "'(uint8_t)' x & y" := (Op (Land (TWord _) (TWord 2) (TWord 2)) (Pair x y)) (at level 40). -Notation "x & '(uint8_t)' y" := (Op (Land (TWord 2) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 40). -Notation "'(uint8_t)' x & y" := (Op (Land (TWord _) (TWord 2) (TWord 2)) (Pair x (Var y))) (at level 40). -Notation "x & '(uint8_t)' y" := (Op (Land (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 40). -Notation "'(uint8_t)' x & y" := (Op (Land (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) y)) (at level 40). -Notation "x & '(uint8_t)' y" := (Op (Land (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(uint8_t)' x & y" := (Op (Land (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & y" := (Op (Land (TWord 2) (TWord 2) (TWord 2)) (Pair x y)). -Notation "x & y" := (Op (Land (TWord 2) (TWord 2) (TWord 2)) (Pair x (Var y))). -Notation "x & y" := (Op (Land (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) y)). -Notation "x & y" := (Op (Land (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))). -Notation "'(uint8_t)' x & '(uint8_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 3)) (Pair x y)) (at level 40). -Notation "'(uint8_t)' x & '(uint8_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 40). -Notation "'(uint8_t)' x & '(uint8_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 40). -Notation "'(uint8_t)' x & '(uint8_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & '(uint8_t)' y" := (Op (Land (TWord 3) (TWord _) (TWord 3)) (Pair x y)) (at level 40). -Notation "'(uint8_t)' x & y" := (Op (Land (TWord _) (TWord 3) (TWord 3)) (Pair x y)) (at level 40). -Notation "x & '(uint8_t)' y" := (Op (Land (TWord 3) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 40). -Notation "'(uint8_t)' x & y" := (Op (Land (TWord _) (TWord 3) (TWord 3)) (Pair x (Var y))) (at level 40). -Notation "x & '(uint8_t)' y" := (Op (Land (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 40). -Notation "'(uint8_t)' x & y" := (Op (Land (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) y)) (at level 40). -Notation "x & '(uint8_t)' y" := (Op (Land (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(uint8_t)' x & y" := (Op (Land (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & y" := (Op (Land (TWord 3) (TWord 3) (TWord 3)) (Pair x y)). -Notation "x & y" := (Op (Land (TWord 3) (TWord 3) (TWord 3)) (Pair x (Var y))). -Notation "x & y" := (Op (Land (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) y)). -Notation "x & y" := (Op (Land (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))). -Notation "'(uint16_t)' x & '(uint16_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 4)) (Pair x y)) (at level 40). -Notation "'(uint16_t)' x & '(uint16_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 40). -Notation "'(uint16_t)' x & '(uint16_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 40). -Notation "'(uint16_t)' x & '(uint16_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & '(uint16_t)' y" := (Op (Land (TWord 4) (TWord _) (TWord 4)) (Pair x y)) (at level 40). -Notation "'(uint16_t)' x & y" := (Op (Land (TWord _) (TWord 4) (TWord 4)) (Pair x y)) (at level 40). -Notation "x & '(uint16_t)' y" := (Op (Land (TWord 4) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 40). -Notation "'(uint16_t)' x & y" := (Op (Land (TWord _) (TWord 4) (TWord 4)) (Pair x (Var y))) (at level 40). -Notation "x & '(uint16_t)' y" := (Op (Land (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 40). -Notation "'(uint16_t)' x & y" := (Op (Land (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) y)) (at level 40). -Notation "x & '(uint16_t)' y" := (Op (Land (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(uint16_t)' x & y" := (Op (Land (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & y" := (Op (Land (TWord 4) (TWord 4) (TWord 4)) (Pair x y)). -Notation "x & y" := (Op (Land (TWord 4) (TWord 4) (TWord 4)) (Pair x (Var y))). -Notation "x & y" := (Op (Land (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) y)). -Notation "x & y" := (Op (Land (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))). -Notation "'(uint32_t)' x & '(uint32_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 5)) (Pair x y)) (at level 40). -Notation "'(uint32_t)' x & '(uint32_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 40). -Notation "'(uint32_t)' x & '(uint32_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 40). -Notation "'(uint32_t)' x & '(uint32_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & '(uint32_t)' y" := (Op (Land (TWord 5) (TWord _) (TWord 5)) (Pair x y)) (at level 40). -Notation "'(uint32_t)' x & y" := (Op (Land (TWord _) (TWord 5) (TWord 5)) (Pair x y)) (at level 40). -Notation "x & '(uint32_t)' y" := (Op (Land (TWord 5) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 40). -Notation "'(uint32_t)' x & y" := (Op (Land (TWord _) (TWord 5) (TWord 5)) (Pair x (Var y))) (at level 40). -Notation "x & '(uint32_t)' y" := (Op (Land (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 40). -Notation "'(uint32_t)' x & y" := (Op (Land (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) y)) (at level 40). -Notation "x & '(uint32_t)' y" := (Op (Land (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(uint32_t)' x & y" := (Op (Land (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & y" := (Op (Land (TWord 5) (TWord 5) (TWord 5)) (Pair x y)). -Notation "x & y" := (Op (Land (TWord 5) (TWord 5) (TWord 5)) (Pair x (Var y))). -Notation "x & y" := (Op (Land (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) y)). -Notation "x & y" := (Op (Land (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))). -Notation "'(uint64_t)' x & '(uint64_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 6)) (Pair x y)) (at level 40). -Notation "'(uint64_t)' x & '(uint64_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 40). -Notation "'(uint64_t)' x & '(uint64_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 40). -Notation "'(uint64_t)' x & '(uint64_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & '(uint64_t)' y" := (Op (Land (TWord 6) (TWord _) (TWord 6)) (Pair x y)) (at level 40). -Notation "'(uint64_t)' x & y" := (Op (Land (TWord _) (TWord 6) (TWord 6)) (Pair x y)) (at level 40). -Notation "x & '(uint64_t)' y" := (Op (Land (TWord 6) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 40). -Notation "'(uint64_t)' x & y" := (Op (Land (TWord _) (TWord 6) (TWord 6)) (Pair x (Var y))) (at level 40). -Notation "x & '(uint64_t)' y" := (Op (Land (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 40). -Notation "'(uint64_t)' x & y" := (Op (Land (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) y)) (at level 40). -Notation "x & '(uint64_t)' y" := (Op (Land (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(uint64_t)' x & y" := (Op (Land (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & y" := (Op (Land (TWord 6) (TWord 6) (TWord 6)) (Pair x y)). -Notation "x & y" := (Op (Land (TWord 6) (TWord 6) (TWord 6)) (Pair x (Var y))). -Notation "x & y" := (Op (Land (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) y)). -Notation "x & y" := (Op (Land (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))). -Notation "'(uint128_t)' x & '(uint128_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 7)) (Pair x y)) (at level 40). -Notation "'(uint128_t)' x & '(uint128_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 40). -Notation "'(uint128_t)' x & '(uint128_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 40). -Notation "'(uint128_t)' x & '(uint128_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & '(uint128_t)' y" := (Op (Land (TWord 7) (TWord _) (TWord 7)) (Pair x y)) (at level 40). -Notation "'(uint128_t)' x & y" := (Op (Land (TWord _) (TWord 7) (TWord 7)) (Pair x y)) (at level 40). -Notation "x & '(uint128_t)' y" := (Op (Land (TWord 7) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 40). -Notation "'(uint128_t)' x & y" := (Op (Land (TWord _) (TWord 7) (TWord 7)) (Pair x (Var y))) (at level 40). -Notation "x & '(uint128_t)' y" := (Op (Land (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 40). -Notation "'(uint128_t)' x & y" := (Op (Land (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) y)) (at level 40). -Notation "x & '(uint128_t)' y" := (Op (Land (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(uint128_t)' x & y" := (Op (Land (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & y" := (Op (Land (TWord 7) (TWord 7) (TWord 7)) (Pair x y)). -Notation "x & y" := (Op (Land (TWord 7) (TWord 7) (TWord 7)) (Pair x (Var y))). -Notation "x & y" := (Op (Land (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) y)). -Notation "x & y" := (Op (Land (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))). -Notation "x << y" := (Op (Shl _ _ _) (Pair x y)). -Notation "x << y" := (Op (Shl _ _ _) (Pair x (Var y))). -Notation "x << y" := (Op (Shl _ _ _) (Pair (Var x) y)). -Notation "x << y" := (Op (Shl _ _ _) (Pair (Var x) (Var y))). -Notation "'(bool)' x << '(bool)' y" := (Op (Shl (TWord _) (TWord _) (TWord 0)) (Pair x y)) (at level 30). -Notation "'(bool)' x << '(bool)' y" := (Op (Shl (TWord _) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 30). -Notation "'(bool)' x << '(bool)' y" := (Op (Shl (TWord _) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 30). -Notation "'(bool)' x << '(bool)' y" := (Op (Shl (TWord _) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << '(bool)' y" := (Op (Shl (TWord 0) (TWord _) (TWord 0)) (Pair x y)) (at level 30). -Notation "'(bool)' x << y" := (Op (Shl (TWord _) (TWord 0) (TWord 0)) (Pair x y)) (at level 30). -Notation "x << '(bool)' y" := (Op (Shl (TWord 0) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 30). -Notation "'(bool)' x << y" := (Op (Shl (TWord _) (TWord 0) (TWord 0)) (Pair x (Var y))) (at level 30). -Notation "x << '(bool)' y" := (Op (Shl (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 30). -Notation "'(bool)' x << y" := (Op (Shl (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) y)) (at level 30). -Notation "x << '(bool)' y" := (Op (Shl (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(bool)' x << y" := (Op (Shl (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << y" := (Op (Shl (TWord 0) (TWord 0) (TWord 0)) (Pair x y)). -Notation "x << y" := (Op (Shl (TWord 0) (TWord 0) (TWord 0)) (Pair x (Var y))). -Notation "x << y" := (Op (Shl (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) y)). -Notation "x << y" := (Op (Shl (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))). -Notation "'(uint8_t)' x << '(uint8_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 1)) (Pair x y)) (at level 30). -Notation "'(uint8_t)' x << '(uint8_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 30). -Notation "'(uint8_t)' x << '(uint8_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 30). -Notation "'(uint8_t)' x << '(uint8_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << '(uint8_t)' y" := (Op (Shl (TWord 1) (TWord _) (TWord 1)) (Pair x y)) (at level 30). -Notation "'(uint8_t)' x << y" := (Op (Shl (TWord _) (TWord 1) (TWord 1)) (Pair x y)) (at level 30). -Notation "x << '(uint8_t)' y" := (Op (Shl (TWord 1) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 30). -Notation "'(uint8_t)' x << y" := (Op (Shl (TWord _) (TWord 1) (TWord 1)) (Pair x (Var y))) (at level 30). -Notation "x << '(uint8_t)' y" := (Op (Shl (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 30). -Notation "'(uint8_t)' x << y" := (Op (Shl (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) y)) (at level 30). -Notation "x << '(uint8_t)' y" := (Op (Shl (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(uint8_t)' x << y" := (Op (Shl (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << y" := (Op (Shl (TWord 1) (TWord 1) (TWord 1)) (Pair x y)). -Notation "x << y" := (Op (Shl (TWord 1) (TWord 1) (TWord 1)) (Pair x (Var y))). -Notation "x << y" := (Op (Shl (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) y)). -Notation "x << y" := (Op (Shl (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))). -Notation "'(uint8_t)' x << '(uint8_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 2)) (Pair x y)) (at level 30). -Notation "'(uint8_t)' x << '(uint8_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 30). -Notation "'(uint8_t)' x << '(uint8_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 30). -Notation "'(uint8_t)' x << '(uint8_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << '(uint8_t)' y" := (Op (Shl (TWord 2) (TWord _) (TWord 2)) (Pair x y)) (at level 30). -Notation "'(uint8_t)' x << y" := (Op (Shl (TWord _) (TWord 2) (TWord 2)) (Pair x y)) (at level 30). -Notation "x << '(uint8_t)' y" := (Op (Shl (TWord 2) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 30). -Notation "'(uint8_t)' x << y" := (Op (Shl (TWord _) (TWord 2) (TWord 2)) (Pair x (Var y))) (at level 30). -Notation "x << '(uint8_t)' y" := (Op (Shl (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 30). -Notation "'(uint8_t)' x << y" := (Op (Shl (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) y)) (at level 30). -Notation "x << '(uint8_t)' y" := (Op (Shl (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(uint8_t)' x << y" := (Op (Shl (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << y" := (Op (Shl (TWord 2) (TWord 2) (TWord 2)) (Pair x y)). -Notation "x << y" := (Op (Shl (TWord 2) (TWord 2) (TWord 2)) (Pair x (Var y))). -Notation "x << y" := (Op (Shl (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) y)). -Notation "x << y" := (Op (Shl (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))). -Notation "'(uint8_t)' x << '(uint8_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 3)) (Pair x y)) (at level 30). -Notation "'(uint8_t)' x << '(uint8_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 30). -Notation "'(uint8_t)' x << '(uint8_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 30). -Notation "'(uint8_t)' x << '(uint8_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << '(uint8_t)' y" := (Op (Shl (TWord 3) (TWord _) (TWord 3)) (Pair x y)) (at level 30). -Notation "'(uint8_t)' x << y" := (Op (Shl (TWord _) (TWord 3) (TWord 3)) (Pair x y)) (at level 30). -Notation "x << '(uint8_t)' y" := (Op (Shl (TWord 3) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 30). -Notation "'(uint8_t)' x << y" := (Op (Shl (TWord _) (TWord 3) (TWord 3)) (Pair x (Var y))) (at level 30). -Notation "x << '(uint8_t)' y" := (Op (Shl (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 30). -Notation "'(uint8_t)' x << y" := (Op (Shl (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) y)) (at level 30). -Notation "x << '(uint8_t)' y" := (Op (Shl (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(uint8_t)' x << y" := (Op (Shl (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << y" := (Op (Shl (TWord 3) (TWord 3) (TWord 3)) (Pair x y)). -Notation "x << y" := (Op (Shl (TWord 3) (TWord 3) (TWord 3)) (Pair x (Var y))). -Notation "x << y" := (Op (Shl (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) y)). -Notation "x << y" := (Op (Shl (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))). -Notation "'(uint16_t)' x << '(uint16_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 4)) (Pair x y)) (at level 30). -Notation "'(uint16_t)' x << '(uint16_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 30). -Notation "'(uint16_t)' x << '(uint16_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 30). -Notation "'(uint16_t)' x << '(uint16_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << '(uint16_t)' y" := (Op (Shl (TWord 4) (TWord _) (TWord 4)) (Pair x y)) (at level 30). -Notation "'(uint16_t)' x << y" := (Op (Shl (TWord _) (TWord 4) (TWord 4)) (Pair x y)) (at level 30). -Notation "x << '(uint16_t)' y" := (Op (Shl (TWord 4) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 30). -Notation "'(uint16_t)' x << y" := (Op (Shl (TWord _) (TWord 4) (TWord 4)) (Pair x (Var y))) (at level 30). -Notation "x << '(uint16_t)' y" := (Op (Shl (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 30). -Notation "'(uint16_t)' x << y" := (Op (Shl (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) y)) (at level 30). -Notation "x << '(uint16_t)' y" := (Op (Shl (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(uint16_t)' x << y" := (Op (Shl (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << y" := (Op (Shl (TWord 4) (TWord 4) (TWord 4)) (Pair x y)). -Notation "x << y" := (Op (Shl (TWord 4) (TWord 4) (TWord 4)) (Pair x (Var y))). -Notation "x << y" := (Op (Shl (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) y)). -Notation "x << y" := (Op (Shl (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))). -Notation "'(uint32_t)' x << '(uint32_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 5)) (Pair x y)) (at level 30). -Notation "'(uint32_t)' x << '(uint32_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 30). -Notation "'(uint32_t)' x << '(uint32_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 30). -Notation "'(uint32_t)' x << '(uint32_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << '(uint32_t)' y" := (Op (Shl (TWord 5) (TWord _) (TWord 5)) (Pair x y)) (at level 30). -Notation "'(uint32_t)' x << y" := (Op (Shl (TWord _) (TWord 5) (TWord 5)) (Pair x y)) (at level 30). -Notation "x << '(uint32_t)' y" := (Op (Shl (TWord 5) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 30). -Notation "'(uint32_t)' x << y" := (Op (Shl (TWord _) (TWord 5) (TWord 5)) (Pair x (Var y))) (at level 30). -Notation "x << '(uint32_t)' y" := (Op (Shl (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 30). -Notation "'(uint32_t)' x << y" := (Op (Shl (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) y)) (at level 30). -Notation "x << '(uint32_t)' y" := (Op (Shl (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(uint32_t)' x << y" := (Op (Shl (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << y" := (Op (Shl (TWord 5) (TWord 5) (TWord 5)) (Pair x y)). -Notation "x << y" := (Op (Shl (TWord 5) (TWord 5) (TWord 5)) (Pair x (Var y))). -Notation "x << y" := (Op (Shl (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) y)). -Notation "x << y" := (Op (Shl (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))). -Notation "'(uint64_t)' x << '(uint64_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 6)) (Pair x y)) (at level 30). -Notation "'(uint64_t)' x << '(uint64_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 30). -Notation "'(uint64_t)' x << '(uint64_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 30). -Notation "'(uint64_t)' x << '(uint64_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << '(uint64_t)' y" := (Op (Shl (TWord 6) (TWord _) (TWord 6)) (Pair x y)) (at level 30). -Notation "'(uint64_t)' x << y" := (Op (Shl (TWord _) (TWord 6) (TWord 6)) (Pair x y)) (at level 30). -Notation "x << '(uint64_t)' y" := (Op (Shl (TWord 6) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 30). -Notation "'(uint64_t)' x << y" := (Op (Shl (TWord _) (TWord 6) (TWord 6)) (Pair x (Var y))) (at level 30). -Notation "x << '(uint64_t)' y" := (Op (Shl (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 30). -Notation "'(uint64_t)' x << y" := (Op (Shl (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) y)) (at level 30). -Notation "x << '(uint64_t)' y" := (Op (Shl (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(uint64_t)' x << y" := (Op (Shl (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << y" := (Op (Shl (TWord 6) (TWord 6) (TWord 6)) (Pair x y)). -Notation "x << y" := (Op (Shl (TWord 6) (TWord 6) (TWord 6)) (Pair x (Var y))). -Notation "x << y" := (Op (Shl (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) y)). -Notation "x << y" := (Op (Shl (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))). -Notation "'(uint128_t)' x << '(uint128_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 7)) (Pair x y)) (at level 30). -Notation "'(uint128_t)' x << '(uint128_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 30). -Notation "'(uint128_t)' x << '(uint128_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 30). -Notation "'(uint128_t)' x << '(uint128_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << '(uint128_t)' y" := (Op (Shl (TWord 7) (TWord _) (TWord 7)) (Pair x y)) (at level 30). -Notation "'(uint128_t)' x << y" := (Op (Shl (TWord _) (TWord 7) (TWord 7)) (Pair x y)) (at level 30). -Notation "x << '(uint128_t)' y" := (Op (Shl (TWord 7) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 30). -Notation "'(uint128_t)' x << y" := (Op (Shl (TWord _) (TWord 7) (TWord 7)) (Pair x (Var y))) (at level 30). -Notation "x << '(uint128_t)' y" := (Op (Shl (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 30). -Notation "'(uint128_t)' x << y" := (Op (Shl (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) y)) (at level 30). -Notation "x << '(uint128_t)' y" := (Op (Shl (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(uint128_t)' x << y" := (Op (Shl (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << y" := (Op (Shl (TWord 7) (TWord 7) (TWord 7)) (Pair x y)). -Notation "x << y" := (Op (Shl (TWord 7) (TWord 7) (TWord 7)) (Pair x (Var y))). -Notation "x << y" := (Op (Shl (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) y)). -Notation "x << y" := (Op (Shl (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))). -Notation "x >> y" := (Op (Shr _ _ _) (Pair x y)). -Notation "x >> y" := (Op (Shr _ _ _) (Pair x (Var y))). -Notation "x >> y" := (Op (Shr _ _ _) (Pair (Var x) y)). -Notation "x >> y" := (Op (Shr _ _ _) (Pair (Var x) (Var y))). -Notation "'(bool)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 0)) (Pair x y)) (at level 30). -Notation "'(bool)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 30). -Notation "'(bool)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 30). -Notation "'(bool)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(uint8_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 1)) (Pair x y)) (at level 30). -Notation "'(uint8_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 30). -Notation "'(uint8_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 30). -Notation "'(uint8_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(uint8_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 2)) (Pair x y)) (at level 30). -Notation "'(uint8_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 30). -Notation "'(uint8_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 30). -Notation "'(uint8_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(uint8_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 3)) (Pair x y)) (at level 30). -Notation "'(uint8_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 30). -Notation "'(uint8_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 30). -Notation "'(uint8_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(uint16_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 4)) (Pair x y)) (at level 30). -Notation "'(uint16_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 30). -Notation "'(uint16_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 30). -Notation "'(uint16_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(uint32_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 5)) (Pair x y)) (at level 30). -Notation "'(uint32_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 30). -Notation "'(uint32_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 30). -Notation "'(uint32_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(uint64_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 6)) (Pair x y)) (at level 30). -Notation "'(uint64_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 30). -Notation "'(uint64_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 30). -Notation "'(uint64_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(uint128_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 7)) (Pair x y)) (at level 30). -Notation "'(uint128_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 30). -Notation "'(uint128_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 30). -Notation "'(uint128_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 30). -Notation Return x := (Var x). -Notation C_like := (Expr base_type op _). diff --git a/src/Reflection/Z/FoldTypes.v b/src/Reflection/Z/FoldTypes.v deleted file mode 100644 index 776f000f5..000000000 --- a/src/Reflection/Z/FoldTypes.v +++ /dev/null @@ -1,17 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.Syntax.Util. -Require Import Crypto.Reflection.FoldTypes. - -Section min_or_max. - Context (f : base_type -> base_type -> base_type) - (init : base_type). - - Definition TypeFold {t} (e : Expr base_type op t) : base_type - := TypeFold (fun t => t) f init e. -End min_or_max. - -Definition MaxTypeUsed {t} (e : Expr base_type op t) : base_type - := TypeFold base_type_max (TWord 0) e. -Definition MinTypeUsed {t} (e : Expr base_type op t) : base_type - := TypeFold base_type_min TZ e. diff --git a/src/Reflection/Z/HexNotationConstants.v b/src/Reflection/Z/HexNotationConstants.v deleted file mode 100644 index 8c03945cb..000000000 --- a/src/Reflection/Z/HexNotationConstants.v +++ /dev/null @@ -1,144 +0,0 @@ -Require Import Coq.ZArith.ZArith. -Require Export Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Z.Syntax. -Require Export Bedrock.Word. -Require Export Crypto.Util.Notations. - -Notation Const x := (Op (OpConst x) TT). -(* python: -<< -print('\n'.join('''Notation "'%s'" (* %d (%s) *)\n := (Const %s%%Z).\nNotation "'%s'" (* %d (%s) *)\n := (Const %s).''' % (h, d, h, d, h, d, h, w) - for d, h, b, w in sorted([(eval(bv), hex(eval(bv)), bv, i) - for (bv, i) in (('0b' + i[2:].replace('~', ''), i) - for i in r"""WO~0~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1 -WO~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~1~1~0~1~0 -WO~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0 -WO~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1 -WO~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0 -WO~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1 -WO~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~1~1~0~1~0 -WO~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~1~1~1~0 -WO~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0 -WO~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1 -WO~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0 -WO~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1 -WO~0~0~0~1~0~0~1~1 -WO~0~0~0~1~1~0~0~1 -WO~0~0~0~1~1~0~1~0 -WO~0~0~0~1~1~0~1~1 -WO~0~0~0~1~1~1~0~0 -WO~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~1~0 -WO~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0 -WO~0~0~1~1~0~0~1~1 -WO~1~0 -WO~1~0~0~1 -WO~0~0~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1 -WO~0~0~0~1~0~0~0~1 -WO~0~0~0~1~0~1~1~1 -WO~1~1""".split('\n'))]))) ->> - *) -Notation "'0x2'" (* 2 (0x2) *) - := (Const 2%Z). -Notation "'0x2'" (* 2 (0x2) *) - := (Const WO~1~0). -Notation "'0x3'" (* 3 (0x3) *) - := (Const 3%Z). -Notation "'0x3'" (* 3 (0x3) *) - := (Const WO~1~1). -Notation "'0x9'" (* 9 (0x9) *) - := (Const 9%Z). -Notation "'0x9'" (* 9 (0x9) *) - := (Const WO~1~0~0~1). -Notation "'0x11'" (* 17 (0x11) *) - := (Const 17%Z). -Notation "'0x11'" (* 17 (0x11) *) - := (Const WO~0~0~0~1~0~0~0~1). -Notation "'0x13'" (* 19 (0x13) *) - := (Const 19%Z). -Notation "'0x13'" (* 19 (0x13) *) - := (Const WO~0~0~0~1~0~0~1~1). -Notation "'0x17'" (* 23 (0x17) *) - := (Const 23%Z). -Notation "'0x17'" (* 23 (0x17) *) - := (Const WO~0~0~0~1~0~1~1~1). -Notation "'0x19'" (* 25 (0x19) *) - := (Const 25%Z). -Notation "'0x19'" (* 25 (0x19) *) - := (Const WO~0~0~0~1~1~0~0~1). -Notation "'0x1a'" (* 26 (0x1a) *) - := (Const 26%Z). -Notation "'0x1a'" (* 26 (0x1a) *) - := (Const WO~0~0~0~1~1~0~1~0). -Notation "'0x1b'" (* 27 (0x1b) *) - := (Const 27%Z). -Notation "'0x1b'" (* 27 (0x1b) *) - := (Const WO~0~0~0~1~1~0~1~1). -Notation "'0x1c'" (* 28 (0x1c) *) - := (Const 28%Z). -Notation "'0x1c'" (* 28 (0x1c) *) - := (Const WO~0~0~0~1~1~1~0~0). -Notation "'0x33'" (* 51 (0x33) *) - := (Const 51%Z). -Notation "'0x33'" (* 51 (0x33) *) - := (Const WO~0~0~1~1~0~0~1~1). -Notation "'0x7fffff'" (* 8388607 (0x7fffff) *) - := (Const 8388607%Z). -Notation "'0x7fffff'" (* 8388607 (0x7fffff) *) - := (Const WO~0~0~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1). -Notation "'0x1ffffff'" (* 33554431 (0x1ffffff) *) - := (Const 33554431%Z). -Notation "'0x1ffffff'" (* 33554431 (0x1ffffff) *) - := (Const WO~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1). -Notation "'0x3fffffe'" (* 67108862 (0x3fffffe) *) - := (Const 67108862%Z). -Notation "'0x3fffffe'" (* 67108862 (0x3fffffe) *) - := (Const WO~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0). -Notation "'0x3ffffff'" (* 67108863 (0x3ffffff) *) - := (Const 67108863%Z). -Notation "'0x3ffffff'" (* 67108863 (0x3ffffff) *) - := (Const WO~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1). -Notation "'0x7ffffda'" (* 134217690 (0x7ffffda) *) - := (Const 134217690%Z). -Notation "'0x7ffffda'" (* 134217690 (0x7ffffda) *) - := (Const WO~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~1~1~0~1~0). -Notation "'0x7ffffee'" (* 134217710 (0x7ffffee) *) - := (Const 134217710%Z). -Notation "'0x7ffffee'" (* 134217710 (0x7ffffee) *) - := (Const WO~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~1~1~1~0). -Notation "'0x7fffffe'" (* 134217726 (0x7fffffe) *) - := (Const 134217726%Z). -Notation "'0x7fffffe'" (* 134217726 (0x7fffffe) *) - := (Const WO~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0). -Notation "'0x7ffffff'" (* 134217727 (0x7ffffff) *) - := (Const 134217727%Z). -Notation "'0x7ffffff'" (* 134217727 (0x7ffffff) *) - := (Const WO~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1). -Notation "'0xffffffe'" (* 268435454 (0xffffffe) *) - := (Const 268435454%Z). -Notation "'0xffffffe'" (* 268435454 (0xffffffe) *) - := (Const WO~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0). -Notation "'0xfffffff'" (* 268435455 (0xfffffff) *) - := (Const 268435455%Z). -Notation "'0xfffffff'" (* 268435455 (0xfffffff) *) - := (Const WO~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1). -Notation "'0x1ffffffa'" (* 536870906 (0x1ffffffa) *) - := (Const 536870906%Z). -Notation "'0x1ffffffa'" (* 536870906 (0x1ffffffa) *) - := (Const WO~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~1~0). -Notation "'0x1ffffffe'" (* 536870910 (0x1ffffffe) *) - := (Const 536870910%Z). -Notation "'0x1ffffffe'" (* 536870910 (0x1ffffffe) *) - := (Const WO~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0). -Notation "'0x7ffffffffffff'" (* 2251799813685247 (0x7ffffffffffff) *) - := (Const 2251799813685247%Z). -Notation "'0x7ffffffffffff'" (* 2251799813685247 (0x7ffffffffffff) *) - := (Const WO~0~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1). -Notation "'0xfffffffffffda'" (* 4503599627370458 (0xfffffffffffda) *) - := (Const 4503599627370458%Z). -Notation "'0xfffffffffffda'" (* 4503599627370458 (0xfffffffffffda) *) - := (Const WO~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0~1~1~0~1~0). -Notation "'0xffffffffffffe'" (* 4503599627370494 (0xffffffffffffe) *) - := (Const 4503599627370494%Z). -Notation "'0xffffffffffffe'" (* 4503599627370494 (0xffffffffffffe) *) - := (Const WO~0~0~0~0~0~0~0~0~0~0~0~0~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~0). diff --git a/src/Reflection/Z/Inline.v b/src/Reflection/Z/Inline.v deleted file mode 100644 index 989286232..000000000 --- a/src/Reflection/Z/Inline.v +++ /dev/null @@ -1,7 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Inline. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.Syntax.Util. - -Definition InlineConst {t} (e : Expr base_type op t) : Expr base_type op t - := @InlineConst base_type op (is_const) t e. diff --git a/src/Reflection/Z/InlineInterp.v b/src/Reflection/Z/InlineInterp.v deleted file mode 100644 index e3fc9b45d..000000000 --- a/src/Reflection/Z/InlineInterp.v +++ /dev/null @@ -1,11 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.InlineInterp. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.Inline. - -Definition InterpInlineConst {interp_base_type interp_op} {t} (e : Expr base_type op t) (Hwf : Wf e) - : forall x, Interp interp_op (InlineConst e) x = Interp interp_op e x - := @InterpInlineConst _ interp_base_type _ _ _ t e Hwf. - -Hint Rewrite @InterpInlineConst using solve [ eassumption | eauto with wf ] : reflective_interp. diff --git a/src/Reflection/Z/InlineWf.v b/src/Reflection/Z/InlineWf.v deleted file mode 100644 index 5d5eb0617..000000000 --- a/src/Reflection/Z/InlineWf.v +++ /dev/null @@ -1,11 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.InlineWf. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.Inline. - -Definition Wf_InlineConst {t} (e : Expr base_type op t) (Hwf : Wf e) - : Wf (InlineConst e) - := @Wf_InlineConst _ _ _ t e Hwf. - -Hint Resolve Wf_InlineConst : wf. diff --git a/src/Reflection/Z/JavaNotations.v b/src/Reflection/Z/JavaNotations.v deleted file mode 100644 index 0a28387df..000000000 --- a/src/Reflection/Z/JavaNotations.v +++ /dev/null @@ -1,792 +0,0 @@ -Require Export Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Z.Syntax. -Require Export Crypto.Reflection.Z.HexNotationConstants. -Require Export Crypto.Util.Notations. - -Reserved Notation "T x = A ; b" (at level 200, b at level 200, format "T x = A ; '//' b"). -Reserved Notation "x & y" (at level 40). -(* N.B. M32 is 0xFFFFFFFFL, and is how to cast a 64-bit thing to a 32-bit thing in Java *) -Reserved Notation "'M32' & x" (at level 200, x at level 9). - -Global Open Scope expr_scope. - -Notation "T x = A ; b" := (LetIn (tx:=T) A (fun x => b)) : expr_scope. -(* ??? Did I get M32 wrong? *) -(*Notation "'(int)' x" := (Op (Cast _ (TWord 0)) x). -Notation "'(int)' x" := (Op (Cast _ (TWord 1)) x). -Notation "'(int)' x" := (Op (Cast _ (TWord 2)) x). -Notation "'(int)' x" := (Op (Cast _ (TWord 3)) x). -Notation "'(int)' x" := (Op (Cast _ (TWord 4)) x). -Notation "'(int)' x" := (Op (Cast _ (TWord 5)) x). -Notation "'M32' & x" := (Op (Cast _ (TWord 6)) x). -Notation "'(uint128_t)' x" := (Op (Cast _ (TWord 7)) x). -Notation "'(int)' x" := (Op (Cast _ (TWord 0)) (Var x)). -Notation "'(int)' x" := (Op (Cast _ (TWord 1)) (Var x)). -Notation "'(int)' x" := (Op (Cast _ (TWord 2)) (Var x)). -Notation "'(int)' x" := (Op (Cast _ (TWord 3)) (Var x)). -Notation "'(int)' x" := (Op (Cast _ (TWord 4)) (Var x)). -Notation "'(int)' x" := (Op (Cast _ (TWord 5)) (Var x)). -Notation "'M32' & x" := (Op (Cast _ (TWord 6)) (Var x)). -Notation "'(uint128_t)' x" := (Op (Cast _ (TWord 7)) (Var x)).*) -(* python: -<< -types = ('int', 'int', 'int', 'int', 'int', 'int', 'long', 'uint128_t') -for lgwordsz in range(0, len(types)): - print('Notation "\'%s\'" := (Tbase (TWord %d)).' % (types[lgwordsz], lgwordsz)) -print('Notation ℤ := (Tbase TZ).') -print('') -cast_pat = "'(%s)' %s" -for opn, op, lvl in (('*', 'Mul', 40), ('+', 'Add', 50), ('-', 'Sub', 50), ('&', 'Land', 40), ('<<', 'Shl', 30)): - for v1 in (False, True): - for v2 in (False, True): - lhs = ('x' if not v1 else '(Var x)') - rhs = ('y' if not v2 else '(Var y)') - print('Notation "x %s y" := (Op (%s _ _ _) (Pair %s %s)).' % (opn, op, lhs, rhs)) - for lgwordsz in range(0, len(types)): - for v1 in (False, True): - for v2 in (False, True): - lhs = ('x' if not v1 else '(Var x)') - rhs = ('y' if not v2 else '(Var y)') - print('Notation "%s %s %s" := (Op (%s (TWord _) (TWord _) (TWord %d)) (Pair %s %s)) (at level %d).' - % (cast_pat % (types[lgwordsz], 'x'), opn, cast_pat % (types[lgwordsz], 'y'), - op, lgwordsz, lhs, rhs, lvl)) - for v1 in (False, True): - for v2 in (False, True): - lhs = ('x' if not v1 else '(Var x)') - rhs = ('y' if not v2 else '(Var y)') - print('Notation "%s %s %s" := (Op (%s (TWord %d) (TWord _) (TWord %d)) (Pair %s %s)) (at level %d).' - % ('x', opn, cast_pat % (types[lgwordsz], 'y'), - op, lgwordsz, lgwordsz, lhs, rhs, lvl)) - print('Notation "%s %s %s" := (Op (%s (TWord _) (TWord %d) (TWord %d)) (Pair %s %s)) (at level %d).' - % (cast_pat % (types[lgwordsz], 'x'), opn, 'y', - op, lgwordsz, lgwordsz, lhs, rhs, lvl)) - for v1 in (False, True): - for v2 in (False, True): - lhs = ('x' if not v1 else '(Var x)') - rhs = ('y' if not v2 else '(Var y)') - print('Notation "x %s y" := (Op (%s (TWord %d) (TWord %d) (TWord %d)) (Pair %s %s)).' - % (opn, op, lgwordsz, lgwordsz, lgwordsz, lhs, rhs)) -for opn, op, lvl in (('>>', 'Shr', 30),): - for v1 in (False, True): - for v2 in (False, True): - lhs = ('x' if not v1 else '(Var x)') - rhs = ('y' if not v2 else '(Var y)') - print('Notation "x %s y" := (Op (%s _ _ _) (Pair %s %s)).' % (opn, op, lhs, rhs)) - for lgwordsz in range(0, len(types)): - for v1 in (False, True): - for v2 in (False, True): - lhs = ('x' if not v1 else '(Var x)') - rhs = ('y' if not v2 else '(Var y)') - print('Notation "\'(%s)\' ( x %s y )" := (Op (%s (TWord _) (TWord _) (TWord %d)) (Pair %s %s)) (at level %d).' - % (types[lgwordsz], opn, op, lgwordsz, lhs, rhs, lvl)) -print('Notation Return x := (Var x).') -print('Notation Java_like := (Expr base_type op _).') ->> *) -Notation "'int'" := (Tbase (TWord 0)). -Notation "'int'" := (Tbase (TWord 1)). -Notation "'int'" := (Tbase (TWord 2)). -Notation "'int'" := (Tbase (TWord 3)). -Notation "'int'" := (Tbase (TWord 4)). -Notation "'int'" := (Tbase (TWord 5)). -Notation "'long'" := (Tbase (TWord 6)). -Notation "'uint128_t'" := (Tbase (TWord 7)). -Notation ℤ := (Tbase TZ). - -Notation "x * y" := (Op (Mul _ _ _) (Pair x y)). -Notation "x * y" := (Op (Mul _ _ _) (Pair x (Var y))). -Notation "x * y" := (Op (Mul _ _ _) (Pair (Var x) y)). -Notation "x * y" := (Op (Mul _ _ _) (Pair (Var x) (Var y))). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 0)) (Pair x y)) (at level 40). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 0) (TWord _) (TWord 0)) (Pair x y)) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 0) (TWord 0)) (Pair x y)) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 0) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 0) (TWord 0)) (Pair x (Var y))) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) y)) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * y" := (Op (Mul (TWord 0) (TWord 0) (TWord 0)) (Pair x y)). -Notation "x * y" := (Op (Mul (TWord 0) (TWord 0) (TWord 0)) (Pair x (Var y))). -Notation "x * y" := (Op (Mul (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) y)). -Notation "x * y" := (Op (Mul (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 1)) (Pair x y)) (at level 40). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 1) (TWord _) (TWord 1)) (Pair x y)) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 1) (TWord 1)) (Pair x y)) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 1) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 1) (TWord 1)) (Pair x (Var y))) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) y)) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * y" := (Op (Mul (TWord 1) (TWord 1) (TWord 1)) (Pair x y)). -Notation "x * y" := (Op (Mul (TWord 1) (TWord 1) (TWord 1)) (Pair x (Var y))). -Notation "x * y" := (Op (Mul (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) y)). -Notation "x * y" := (Op (Mul (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 2)) (Pair x y)) (at level 40). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 2) (TWord _) (TWord 2)) (Pair x y)) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 2) (TWord 2)) (Pair x y)) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 2) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 2) (TWord 2)) (Pair x (Var y))) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) y)) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * y" := (Op (Mul (TWord 2) (TWord 2) (TWord 2)) (Pair x y)). -Notation "x * y" := (Op (Mul (TWord 2) (TWord 2) (TWord 2)) (Pair x (Var y))). -Notation "x * y" := (Op (Mul (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) y)). -Notation "x * y" := (Op (Mul (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 3)) (Pair x y)) (at level 40). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 3) (TWord _) (TWord 3)) (Pair x y)) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 3) (TWord 3)) (Pair x y)) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 3) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 3) (TWord 3)) (Pair x (Var y))) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) y)) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * y" := (Op (Mul (TWord 3) (TWord 3) (TWord 3)) (Pair x y)). -Notation "x * y" := (Op (Mul (TWord 3) (TWord 3) (TWord 3)) (Pair x (Var y))). -Notation "x * y" := (Op (Mul (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) y)). -Notation "x * y" := (Op (Mul (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 4)) (Pair x y)) (at level 40). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 4) (TWord _) (TWord 4)) (Pair x y)) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 4) (TWord 4)) (Pair x y)) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 4) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 4) (TWord 4)) (Pair x (Var y))) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) y)) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * y" := (Op (Mul (TWord 4) (TWord 4) (TWord 4)) (Pair x y)). -Notation "x * y" := (Op (Mul (TWord 4) (TWord 4) (TWord 4)) (Pair x (Var y))). -Notation "x * y" := (Op (Mul (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) y)). -Notation "x * y" := (Op (Mul (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 5)) (Pair x y)) (at level 40). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x * '(int)' y" := (Op (Mul (TWord _) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 5) (TWord _) (TWord 5)) (Pair x y)) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 5) (TWord 5)) (Pair x y)) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 5) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 5) (TWord 5)) (Pair x (Var y))) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) y)) (at level 40). -Notation "x * '(int)' y" := (Op (Mul (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(int)' x * y" := (Op (Mul (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * y" := (Op (Mul (TWord 5) (TWord 5) (TWord 5)) (Pair x y)). -Notation "x * y" := (Op (Mul (TWord 5) (TWord 5) (TWord 5)) (Pair x (Var y))). -Notation "x * y" := (Op (Mul (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) y)). -Notation "x * y" := (Op (Mul (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))). -Notation "'(long)' x * '(long)' y" := (Op (Mul (TWord _) (TWord _) (TWord 6)) (Pair x y)) (at level 40). -Notation "'(long)' x * '(long)' y" := (Op (Mul (TWord _) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 40). -Notation "'(long)' x * '(long)' y" := (Op (Mul (TWord _) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 40). -Notation "'(long)' x * '(long)' y" := (Op (Mul (TWord _) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * '(long)' y" := (Op (Mul (TWord 6) (TWord _) (TWord 6)) (Pair x y)) (at level 40). -Notation "'(long)' x * y" := (Op (Mul (TWord _) (TWord 6) (TWord 6)) (Pair x y)) (at level 40). -Notation "x * '(long)' y" := (Op (Mul (TWord 6) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 40). -Notation "'(long)' x * y" := (Op (Mul (TWord _) (TWord 6) (TWord 6)) (Pair x (Var y))) (at level 40). -Notation "x * '(long)' y" := (Op (Mul (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 40). -Notation "'(long)' x * y" := (Op (Mul (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) y)) (at level 40). -Notation "x * '(long)' y" := (Op (Mul (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(long)' x * y" := (Op (Mul (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * y" := (Op (Mul (TWord 6) (TWord 6) (TWord 6)) (Pair x y)). -Notation "x * y" := (Op (Mul (TWord 6) (TWord 6) (TWord 6)) (Pair x (Var y))). -Notation "x * y" := (Op (Mul (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) y)). -Notation "x * y" := (Op (Mul (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))). -Notation "'(uint128_t)' x * '(uint128_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 7)) (Pair x y)) (at level 40). -Notation "'(uint128_t)' x * '(uint128_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 40). -Notation "'(uint128_t)' x * '(uint128_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 40). -Notation "'(uint128_t)' x * '(uint128_t)' y" := (Op (Mul (TWord _) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * '(uint128_t)' y" := (Op (Mul (TWord 7) (TWord _) (TWord 7)) (Pair x y)) (at level 40). -Notation "'(uint128_t)' x * y" := (Op (Mul (TWord _) (TWord 7) (TWord 7)) (Pair x y)) (at level 40). -Notation "x * '(uint128_t)' y" := (Op (Mul (TWord 7) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 40). -Notation "'(uint128_t)' x * y" := (Op (Mul (TWord _) (TWord 7) (TWord 7)) (Pair x (Var y))) (at level 40). -Notation "x * '(uint128_t)' y" := (Op (Mul (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 40). -Notation "'(uint128_t)' x * y" := (Op (Mul (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) y)) (at level 40). -Notation "x * '(uint128_t)' y" := (Op (Mul (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(uint128_t)' x * y" := (Op (Mul (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))) (at level 40). -Notation "x * y" := (Op (Mul (TWord 7) (TWord 7) (TWord 7)) (Pair x y)). -Notation "x * y" := (Op (Mul (TWord 7) (TWord 7) (TWord 7)) (Pair x (Var y))). -Notation "x * y" := (Op (Mul (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) y)). -Notation "x * y" := (Op (Mul (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))). -Notation "x + y" := (Op (Add _ _ _) (Pair x y)). -Notation "x + y" := (Op (Add _ _ _) (Pair x (Var y))). -Notation "x + y" := (Op (Add _ _ _) (Pair (Var x) y)). -Notation "x + y" := (Op (Add _ _ _) (Pair (Var x) (Var y))). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 0)) (Pair x y)) (at level 50). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 0) (TWord _) (TWord 0)) (Pair x y)) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 0) (TWord 0)) (Pair x y)) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 0) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 0) (TWord 0)) (Pair x (Var y))) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) y)) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + y" := (Op (Add (TWord 0) (TWord 0) (TWord 0)) (Pair x y)). -Notation "x + y" := (Op (Add (TWord 0) (TWord 0) (TWord 0)) (Pair x (Var y))). -Notation "x + y" := (Op (Add (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) y)). -Notation "x + y" := (Op (Add (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 1)) (Pair x y)) (at level 50). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 1) (TWord _) (TWord 1)) (Pair x y)) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 1) (TWord 1)) (Pair x y)) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 1) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 1) (TWord 1)) (Pair x (Var y))) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) y)) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + y" := (Op (Add (TWord 1) (TWord 1) (TWord 1)) (Pair x y)). -Notation "x + y" := (Op (Add (TWord 1) (TWord 1) (TWord 1)) (Pair x (Var y))). -Notation "x + y" := (Op (Add (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) y)). -Notation "x + y" := (Op (Add (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 2)) (Pair x y)) (at level 50). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 2) (TWord _) (TWord 2)) (Pair x y)) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 2) (TWord 2)) (Pair x y)) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 2) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 2) (TWord 2)) (Pair x (Var y))) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) y)) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + y" := (Op (Add (TWord 2) (TWord 2) (TWord 2)) (Pair x y)). -Notation "x + y" := (Op (Add (TWord 2) (TWord 2) (TWord 2)) (Pair x (Var y))). -Notation "x + y" := (Op (Add (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) y)). -Notation "x + y" := (Op (Add (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 3)) (Pair x y)) (at level 50). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 3) (TWord _) (TWord 3)) (Pair x y)) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 3) (TWord 3)) (Pair x y)) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 3) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 3) (TWord 3)) (Pair x (Var y))) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) y)) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + y" := (Op (Add (TWord 3) (TWord 3) (TWord 3)) (Pair x y)). -Notation "x + y" := (Op (Add (TWord 3) (TWord 3) (TWord 3)) (Pair x (Var y))). -Notation "x + y" := (Op (Add (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) y)). -Notation "x + y" := (Op (Add (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 4)) (Pair x y)) (at level 50). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 4) (TWord _) (TWord 4)) (Pair x y)) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 4) (TWord 4)) (Pair x y)) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 4) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 4) (TWord 4)) (Pair x (Var y))) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) y)) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + y" := (Op (Add (TWord 4) (TWord 4) (TWord 4)) (Pair x y)). -Notation "x + y" := (Op (Add (TWord 4) (TWord 4) (TWord 4)) (Pair x (Var y))). -Notation "x + y" := (Op (Add (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) y)). -Notation "x + y" := (Op (Add (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 5)) (Pair x y)) (at level 50). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x + '(int)' y" := (Op (Add (TWord _) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 5) (TWord _) (TWord 5)) (Pair x y)) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 5) (TWord 5)) (Pair x y)) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 5) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 5) (TWord 5)) (Pair x (Var y))) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) y)) (at level 50). -Notation "x + '(int)' y" := (Op (Add (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(int)' x + y" := (Op (Add (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + y" := (Op (Add (TWord 5) (TWord 5) (TWord 5)) (Pair x y)). -Notation "x + y" := (Op (Add (TWord 5) (TWord 5) (TWord 5)) (Pair x (Var y))). -Notation "x + y" := (Op (Add (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) y)). -Notation "x + y" := (Op (Add (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))). -Notation "'(long)' x + '(long)' y" := (Op (Add (TWord _) (TWord _) (TWord 6)) (Pair x y)) (at level 50). -Notation "'(long)' x + '(long)' y" := (Op (Add (TWord _) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 50). -Notation "'(long)' x + '(long)' y" := (Op (Add (TWord _) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 50). -Notation "'(long)' x + '(long)' y" := (Op (Add (TWord _) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + '(long)' y" := (Op (Add (TWord 6) (TWord _) (TWord 6)) (Pair x y)) (at level 50). -Notation "'(long)' x + y" := (Op (Add (TWord _) (TWord 6) (TWord 6)) (Pair x y)) (at level 50). -Notation "x + '(long)' y" := (Op (Add (TWord 6) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 50). -Notation "'(long)' x + y" := (Op (Add (TWord _) (TWord 6) (TWord 6)) (Pair x (Var y))) (at level 50). -Notation "x + '(long)' y" := (Op (Add (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 50). -Notation "'(long)' x + y" := (Op (Add (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) y)) (at level 50). -Notation "x + '(long)' y" := (Op (Add (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(long)' x + y" := (Op (Add (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + y" := (Op (Add (TWord 6) (TWord 6) (TWord 6)) (Pair x y)). -Notation "x + y" := (Op (Add (TWord 6) (TWord 6) (TWord 6)) (Pair x (Var y))). -Notation "x + y" := (Op (Add (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) y)). -Notation "x + y" := (Op (Add (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))). -Notation "'(uint128_t)' x + '(uint128_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 7)) (Pair x y)) (at level 50). -Notation "'(uint128_t)' x + '(uint128_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 50). -Notation "'(uint128_t)' x + '(uint128_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 50). -Notation "'(uint128_t)' x + '(uint128_t)' y" := (Op (Add (TWord _) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + '(uint128_t)' y" := (Op (Add (TWord 7) (TWord _) (TWord 7)) (Pair x y)) (at level 50). -Notation "'(uint128_t)' x + y" := (Op (Add (TWord _) (TWord 7) (TWord 7)) (Pair x y)) (at level 50). -Notation "x + '(uint128_t)' y" := (Op (Add (TWord 7) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 50). -Notation "'(uint128_t)' x + y" := (Op (Add (TWord _) (TWord 7) (TWord 7)) (Pair x (Var y))) (at level 50). -Notation "x + '(uint128_t)' y" := (Op (Add (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 50). -Notation "'(uint128_t)' x + y" := (Op (Add (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) y)) (at level 50). -Notation "x + '(uint128_t)' y" := (Op (Add (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(uint128_t)' x + y" := (Op (Add (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))) (at level 50). -Notation "x + y" := (Op (Add (TWord 7) (TWord 7) (TWord 7)) (Pair x y)). -Notation "x + y" := (Op (Add (TWord 7) (TWord 7) (TWord 7)) (Pair x (Var y))). -Notation "x + y" := (Op (Add (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) y)). -Notation "x + y" := (Op (Add (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))). -Notation "x - y" := (Op (Sub _ _ _) (Pair x y)). -Notation "x - y" := (Op (Sub _ _ _) (Pair x (Var y))). -Notation "x - y" := (Op (Sub _ _ _) (Pair (Var x) y)). -Notation "x - y" := (Op (Sub _ _ _) (Pair (Var x) (Var y))). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 0)) (Pair x y)) (at level 50). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 0) (TWord _) (TWord 0)) (Pair x y)) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 0) (TWord 0)) (Pair x y)) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 0) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 0) (TWord 0)) (Pair x (Var y))) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) y)) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - y" := (Op (Sub (TWord 0) (TWord 0) (TWord 0)) (Pair x y)). -Notation "x - y" := (Op (Sub (TWord 0) (TWord 0) (TWord 0)) (Pair x (Var y))). -Notation "x - y" := (Op (Sub (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) y)). -Notation "x - y" := (Op (Sub (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 1)) (Pair x y)) (at level 50). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 1) (TWord _) (TWord 1)) (Pair x y)) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 1) (TWord 1)) (Pair x y)) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 1) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 1) (TWord 1)) (Pair x (Var y))) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) y)) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - y" := (Op (Sub (TWord 1) (TWord 1) (TWord 1)) (Pair x y)). -Notation "x - y" := (Op (Sub (TWord 1) (TWord 1) (TWord 1)) (Pair x (Var y))). -Notation "x - y" := (Op (Sub (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) y)). -Notation "x - y" := (Op (Sub (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 2)) (Pair x y)) (at level 50). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 2) (TWord _) (TWord 2)) (Pair x y)) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 2) (TWord 2)) (Pair x y)) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 2) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 2) (TWord 2)) (Pair x (Var y))) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) y)) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - y" := (Op (Sub (TWord 2) (TWord 2) (TWord 2)) (Pair x y)). -Notation "x - y" := (Op (Sub (TWord 2) (TWord 2) (TWord 2)) (Pair x (Var y))). -Notation "x - y" := (Op (Sub (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) y)). -Notation "x - y" := (Op (Sub (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 3)) (Pair x y)) (at level 50). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 3) (TWord _) (TWord 3)) (Pair x y)) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 3) (TWord 3)) (Pair x y)) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 3) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 3) (TWord 3)) (Pair x (Var y))) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) y)) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - y" := (Op (Sub (TWord 3) (TWord 3) (TWord 3)) (Pair x y)). -Notation "x - y" := (Op (Sub (TWord 3) (TWord 3) (TWord 3)) (Pair x (Var y))). -Notation "x - y" := (Op (Sub (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) y)). -Notation "x - y" := (Op (Sub (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 4)) (Pair x y)) (at level 50). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 4) (TWord _) (TWord 4)) (Pair x y)) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 4) (TWord 4)) (Pair x y)) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 4) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 4) (TWord 4)) (Pair x (Var y))) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) y)) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - y" := (Op (Sub (TWord 4) (TWord 4) (TWord 4)) (Pair x y)). -Notation "x - y" := (Op (Sub (TWord 4) (TWord 4) (TWord 4)) (Pair x (Var y))). -Notation "x - y" := (Op (Sub (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) y)). -Notation "x - y" := (Op (Sub (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 5)) (Pair x y)) (at level 50). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x - '(int)' y" := (Op (Sub (TWord _) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 5) (TWord _) (TWord 5)) (Pair x y)) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 5) (TWord 5)) (Pair x y)) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 5) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 5) (TWord 5)) (Pair x (Var y))) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) y)) (at level 50). -Notation "x - '(int)' y" := (Op (Sub (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(int)' x - y" := (Op (Sub (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - y" := (Op (Sub (TWord 5) (TWord 5) (TWord 5)) (Pair x y)). -Notation "x - y" := (Op (Sub (TWord 5) (TWord 5) (TWord 5)) (Pair x (Var y))). -Notation "x - y" := (Op (Sub (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) y)). -Notation "x - y" := (Op (Sub (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))). -Notation "'(long)' x - '(long)' y" := (Op (Sub (TWord _) (TWord _) (TWord 6)) (Pair x y)) (at level 50). -Notation "'(long)' x - '(long)' y" := (Op (Sub (TWord _) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 50). -Notation "'(long)' x - '(long)' y" := (Op (Sub (TWord _) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 50). -Notation "'(long)' x - '(long)' y" := (Op (Sub (TWord _) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - '(long)' y" := (Op (Sub (TWord 6) (TWord _) (TWord 6)) (Pair x y)) (at level 50). -Notation "'(long)' x - y" := (Op (Sub (TWord _) (TWord 6) (TWord 6)) (Pair x y)) (at level 50). -Notation "x - '(long)' y" := (Op (Sub (TWord 6) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 50). -Notation "'(long)' x - y" := (Op (Sub (TWord _) (TWord 6) (TWord 6)) (Pair x (Var y))) (at level 50). -Notation "x - '(long)' y" := (Op (Sub (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 50). -Notation "'(long)' x - y" := (Op (Sub (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) y)) (at level 50). -Notation "x - '(long)' y" := (Op (Sub (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(long)' x - y" := (Op (Sub (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - y" := (Op (Sub (TWord 6) (TWord 6) (TWord 6)) (Pair x y)). -Notation "x - y" := (Op (Sub (TWord 6) (TWord 6) (TWord 6)) (Pair x (Var y))). -Notation "x - y" := (Op (Sub (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) y)). -Notation "x - y" := (Op (Sub (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))). -Notation "'(uint128_t)' x - '(uint128_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 7)) (Pair x y)) (at level 50). -Notation "'(uint128_t)' x - '(uint128_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 50). -Notation "'(uint128_t)' x - '(uint128_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 50). -Notation "'(uint128_t)' x - '(uint128_t)' y" := (Op (Sub (TWord _) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - '(uint128_t)' y" := (Op (Sub (TWord 7) (TWord _) (TWord 7)) (Pair x y)) (at level 50). -Notation "'(uint128_t)' x - y" := (Op (Sub (TWord _) (TWord 7) (TWord 7)) (Pair x y)) (at level 50). -Notation "x - '(uint128_t)' y" := (Op (Sub (TWord 7) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 50). -Notation "'(uint128_t)' x - y" := (Op (Sub (TWord _) (TWord 7) (TWord 7)) (Pair x (Var y))) (at level 50). -Notation "x - '(uint128_t)' y" := (Op (Sub (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 50). -Notation "'(uint128_t)' x - y" := (Op (Sub (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) y)) (at level 50). -Notation "x - '(uint128_t)' y" := (Op (Sub (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 50). -Notation "'(uint128_t)' x - y" := (Op (Sub (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))) (at level 50). -Notation "x - y" := (Op (Sub (TWord 7) (TWord 7) (TWord 7)) (Pair x y)). -Notation "x - y" := (Op (Sub (TWord 7) (TWord 7) (TWord 7)) (Pair x (Var y))). -Notation "x - y" := (Op (Sub (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) y)). -Notation "x - y" := (Op (Sub (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))). -Notation "x & y" := (Op (Land _ _ _) (Pair x y)). -Notation "x & y" := (Op (Land _ _ _) (Pair x (Var y))). -Notation "x & y" := (Op (Land _ _ _) (Pair (Var x) y)). -Notation "x & y" := (Op (Land _ _ _) (Pair (Var x) (Var y))). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 0)) (Pair x y)) (at level 40). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 0) (TWord _) (TWord 0)) (Pair x y)) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 0) (TWord 0)) (Pair x y)) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 0) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 0) (TWord 0)) (Pair x (Var y))) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) y)) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & y" := (Op (Land (TWord 0) (TWord 0) (TWord 0)) (Pair x y)). -Notation "x & y" := (Op (Land (TWord 0) (TWord 0) (TWord 0)) (Pair x (Var y))). -Notation "x & y" := (Op (Land (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) y)). -Notation "x & y" := (Op (Land (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 1)) (Pair x y)) (at level 40). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 1) (TWord _) (TWord 1)) (Pair x y)) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 1) (TWord 1)) (Pair x y)) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 1) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 1) (TWord 1)) (Pair x (Var y))) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) y)) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & y" := (Op (Land (TWord 1) (TWord 1) (TWord 1)) (Pair x y)). -Notation "x & y" := (Op (Land (TWord 1) (TWord 1) (TWord 1)) (Pair x (Var y))). -Notation "x & y" := (Op (Land (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) y)). -Notation "x & y" := (Op (Land (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 2)) (Pair x y)) (at level 40). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 2) (TWord _) (TWord 2)) (Pair x y)) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 2) (TWord 2)) (Pair x y)) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 2) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 2) (TWord 2)) (Pair x (Var y))) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) y)) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & y" := (Op (Land (TWord 2) (TWord 2) (TWord 2)) (Pair x y)). -Notation "x & y" := (Op (Land (TWord 2) (TWord 2) (TWord 2)) (Pair x (Var y))). -Notation "x & y" := (Op (Land (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) y)). -Notation "x & y" := (Op (Land (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 3)) (Pair x y)) (at level 40). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 3) (TWord _) (TWord 3)) (Pair x y)) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 3) (TWord 3)) (Pair x y)) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 3) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 3) (TWord 3)) (Pair x (Var y))) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) y)) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & y" := (Op (Land (TWord 3) (TWord 3) (TWord 3)) (Pair x y)). -Notation "x & y" := (Op (Land (TWord 3) (TWord 3) (TWord 3)) (Pair x (Var y))). -Notation "x & y" := (Op (Land (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) y)). -Notation "x & y" := (Op (Land (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 4)) (Pair x y)) (at level 40). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 4) (TWord _) (TWord 4)) (Pair x y)) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 4) (TWord 4)) (Pair x y)) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 4) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 4) (TWord 4)) (Pair x (Var y))) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) y)) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & y" := (Op (Land (TWord 4) (TWord 4) (TWord 4)) (Pair x y)). -Notation "x & y" := (Op (Land (TWord 4) (TWord 4) (TWord 4)) (Pair x (Var y))). -Notation "x & y" := (Op (Land (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) y)). -Notation "x & y" := (Op (Land (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 5)) (Pair x y)) (at level 40). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x & '(int)' y" := (Op (Land (TWord _) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 5) (TWord _) (TWord 5)) (Pair x y)) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 5) (TWord 5)) (Pair x y)) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 5) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 5) (TWord 5)) (Pair x (Var y))) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) y)) (at level 40). -Notation "x & '(int)' y" := (Op (Land (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(int)' x & y" := (Op (Land (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & y" := (Op (Land (TWord 5) (TWord 5) (TWord 5)) (Pair x y)). -Notation "x & y" := (Op (Land (TWord 5) (TWord 5) (TWord 5)) (Pair x (Var y))). -Notation "x & y" := (Op (Land (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) y)). -Notation "x & y" := (Op (Land (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))). -Notation "'(long)' x & '(long)' y" := (Op (Land (TWord _) (TWord _) (TWord 6)) (Pair x y)) (at level 40). -Notation "'(long)' x & '(long)' y" := (Op (Land (TWord _) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 40). -Notation "'(long)' x & '(long)' y" := (Op (Land (TWord _) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 40). -Notation "'(long)' x & '(long)' y" := (Op (Land (TWord _) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & '(long)' y" := (Op (Land (TWord 6) (TWord _) (TWord 6)) (Pair x y)) (at level 40). -Notation "'(long)' x & y" := (Op (Land (TWord _) (TWord 6) (TWord 6)) (Pair x y)) (at level 40). -Notation "x & '(long)' y" := (Op (Land (TWord 6) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 40). -Notation "'(long)' x & y" := (Op (Land (TWord _) (TWord 6) (TWord 6)) (Pair x (Var y))) (at level 40). -Notation "x & '(long)' y" := (Op (Land (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 40). -Notation "'(long)' x & y" := (Op (Land (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) y)) (at level 40). -Notation "x & '(long)' y" := (Op (Land (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(long)' x & y" := (Op (Land (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & y" := (Op (Land (TWord 6) (TWord 6) (TWord 6)) (Pair x y)). -Notation "x & y" := (Op (Land (TWord 6) (TWord 6) (TWord 6)) (Pair x (Var y))). -Notation "x & y" := (Op (Land (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) y)). -Notation "x & y" := (Op (Land (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))). -Notation "'(uint128_t)' x & '(uint128_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 7)) (Pair x y)) (at level 40). -Notation "'(uint128_t)' x & '(uint128_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 40). -Notation "'(uint128_t)' x & '(uint128_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 40). -Notation "'(uint128_t)' x & '(uint128_t)' y" := (Op (Land (TWord _) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & '(uint128_t)' y" := (Op (Land (TWord 7) (TWord _) (TWord 7)) (Pair x y)) (at level 40). -Notation "'(uint128_t)' x & y" := (Op (Land (TWord _) (TWord 7) (TWord 7)) (Pair x y)) (at level 40). -Notation "x & '(uint128_t)' y" := (Op (Land (TWord 7) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 40). -Notation "'(uint128_t)' x & y" := (Op (Land (TWord _) (TWord 7) (TWord 7)) (Pair x (Var y))) (at level 40). -Notation "x & '(uint128_t)' y" := (Op (Land (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 40). -Notation "'(uint128_t)' x & y" := (Op (Land (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) y)) (at level 40). -Notation "x & '(uint128_t)' y" := (Op (Land (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 40). -Notation "'(uint128_t)' x & y" := (Op (Land (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))) (at level 40). -Notation "x & y" := (Op (Land (TWord 7) (TWord 7) (TWord 7)) (Pair x y)). -Notation "x & y" := (Op (Land (TWord 7) (TWord 7) (TWord 7)) (Pair x (Var y))). -Notation "x & y" := (Op (Land (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) y)). -Notation "x & y" := (Op (Land (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))). -Notation "x << y" := (Op (Shl _ _ _) (Pair x y)). -Notation "x << y" := (Op (Shl _ _ _) (Pair x (Var y))). -Notation "x << y" := (Op (Shl _ _ _) (Pair (Var x) y)). -Notation "x << y" := (Op (Shl _ _ _) (Pair (Var x) (Var y))). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 0)) (Pair x y)) (at level 30). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 30). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 30). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 0) (TWord _) (TWord 0)) (Pair x y)) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 0) (TWord 0)) (Pair x y)) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 0) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 0) (TWord 0)) (Pair x (Var y))) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) y)) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 0) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << y" := (Op (Shl (TWord 0) (TWord 0) (TWord 0)) (Pair x y)). -Notation "x << y" := (Op (Shl (TWord 0) (TWord 0) (TWord 0)) (Pair x (Var y))). -Notation "x << y" := (Op (Shl (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) y)). -Notation "x << y" := (Op (Shl (TWord 0) (TWord 0) (TWord 0)) (Pair (Var x) (Var y))). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 1)) (Pair x y)) (at level 30). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 30). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 30). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 1) (TWord _) (TWord 1)) (Pair x y)) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 1) (TWord 1)) (Pair x y)) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 1) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 1) (TWord 1)) (Pair x (Var y))) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) y)) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 1) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << y" := (Op (Shl (TWord 1) (TWord 1) (TWord 1)) (Pair x y)). -Notation "x << y" := (Op (Shl (TWord 1) (TWord 1) (TWord 1)) (Pair x (Var y))). -Notation "x << y" := (Op (Shl (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) y)). -Notation "x << y" := (Op (Shl (TWord 1) (TWord 1) (TWord 1)) (Pair (Var x) (Var y))). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 2)) (Pair x y)) (at level 30). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 30). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 30). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 2) (TWord _) (TWord 2)) (Pair x y)) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 2) (TWord 2)) (Pair x y)) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 2) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 2) (TWord 2)) (Pair x (Var y))) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) y)) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 2) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << y" := (Op (Shl (TWord 2) (TWord 2) (TWord 2)) (Pair x y)). -Notation "x << y" := (Op (Shl (TWord 2) (TWord 2) (TWord 2)) (Pair x (Var y))). -Notation "x << y" := (Op (Shl (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) y)). -Notation "x << y" := (Op (Shl (TWord 2) (TWord 2) (TWord 2)) (Pair (Var x) (Var y))). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 3)) (Pair x y)) (at level 30). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 30). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 30). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 3) (TWord _) (TWord 3)) (Pair x y)) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 3) (TWord 3)) (Pair x y)) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 3) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 3) (TWord 3)) (Pair x (Var y))) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) y)) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 3) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << y" := (Op (Shl (TWord 3) (TWord 3) (TWord 3)) (Pair x y)). -Notation "x << y" := (Op (Shl (TWord 3) (TWord 3) (TWord 3)) (Pair x (Var y))). -Notation "x << y" := (Op (Shl (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) y)). -Notation "x << y" := (Op (Shl (TWord 3) (TWord 3) (TWord 3)) (Pair (Var x) (Var y))). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 4)) (Pair x y)) (at level 30). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 30). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 30). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 4) (TWord _) (TWord 4)) (Pair x y)) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 4) (TWord 4)) (Pair x y)) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 4) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 4) (TWord 4)) (Pair x (Var y))) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) y)) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 4) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << y" := (Op (Shl (TWord 4) (TWord 4) (TWord 4)) (Pair x y)). -Notation "x << y" := (Op (Shl (TWord 4) (TWord 4) (TWord 4)) (Pair x (Var y))). -Notation "x << y" := (Op (Shl (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) y)). -Notation "x << y" := (Op (Shl (TWord 4) (TWord 4) (TWord 4)) (Pair (Var x) (Var y))). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 5)) (Pair x y)) (at level 30). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 30). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 30). -Notation "'(int)' x << '(int)' y" := (Op (Shl (TWord _) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 5) (TWord _) (TWord 5)) (Pair x y)) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 5) (TWord 5)) (Pair x y)) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 5) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 5) (TWord 5)) (Pair x (Var y))) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) y)) (at level 30). -Notation "x << '(int)' y" := (Op (Shl (TWord 5) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(int)' x << y" := (Op (Shl (TWord _) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << y" := (Op (Shl (TWord 5) (TWord 5) (TWord 5)) (Pair x y)). -Notation "x << y" := (Op (Shl (TWord 5) (TWord 5) (TWord 5)) (Pair x (Var y))). -Notation "x << y" := (Op (Shl (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) y)). -Notation "x << y" := (Op (Shl (TWord 5) (TWord 5) (TWord 5)) (Pair (Var x) (Var y))). -Notation "'(long)' x << '(long)' y" := (Op (Shl (TWord _) (TWord _) (TWord 6)) (Pair x y)) (at level 30). -Notation "'(long)' x << '(long)' y" := (Op (Shl (TWord _) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 30). -Notation "'(long)' x << '(long)' y" := (Op (Shl (TWord _) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 30). -Notation "'(long)' x << '(long)' y" := (Op (Shl (TWord _) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << '(long)' y" := (Op (Shl (TWord 6) (TWord _) (TWord 6)) (Pair x y)) (at level 30). -Notation "'(long)' x << y" := (Op (Shl (TWord _) (TWord 6) (TWord 6)) (Pair x y)) (at level 30). -Notation "x << '(long)' y" := (Op (Shl (TWord 6) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 30). -Notation "'(long)' x << y" := (Op (Shl (TWord _) (TWord 6) (TWord 6)) (Pair x (Var y))) (at level 30). -Notation "x << '(long)' y" := (Op (Shl (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 30). -Notation "'(long)' x << y" := (Op (Shl (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) y)) (at level 30). -Notation "x << '(long)' y" := (Op (Shl (TWord 6) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(long)' x << y" := (Op (Shl (TWord _) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << y" := (Op (Shl (TWord 6) (TWord 6) (TWord 6)) (Pair x y)). -Notation "x << y" := (Op (Shl (TWord 6) (TWord 6) (TWord 6)) (Pair x (Var y))). -Notation "x << y" := (Op (Shl (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) y)). -Notation "x << y" := (Op (Shl (TWord 6) (TWord 6) (TWord 6)) (Pair (Var x) (Var y))). -Notation "'(uint128_t)' x << '(uint128_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 7)) (Pair x y)) (at level 30). -Notation "'(uint128_t)' x << '(uint128_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 30). -Notation "'(uint128_t)' x << '(uint128_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 30). -Notation "'(uint128_t)' x << '(uint128_t)' y" := (Op (Shl (TWord _) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << '(uint128_t)' y" := (Op (Shl (TWord 7) (TWord _) (TWord 7)) (Pair x y)) (at level 30). -Notation "'(uint128_t)' x << y" := (Op (Shl (TWord _) (TWord 7) (TWord 7)) (Pair x y)) (at level 30). -Notation "x << '(uint128_t)' y" := (Op (Shl (TWord 7) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 30). -Notation "'(uint128_t)' x << y" := (Op (Shl (TWord _) (TWord 7) (TWord 7)) (Pair x (Var y))) (at level 30). -Notation "x << '(uint128_t)' y" := (Op (Shl (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 30). -Notation "'(uint128_t)' x << y" := (Op (Shl (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) y)) (at level 30). -Notation "x << '(uint128_t)' y" := (Op (Shl (TWord 7) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(uint128_t)' x << y" := (Op (Shl (TWord _) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))) (at level 30). -Notation "x << y" := (Op (Shl (TWord 7) (TWord 7) (TWord 7)) (Pair x y)). -Notation "x << y" := (Op (Shl (TWord 7) (TWord 7) (TWord 7)) (Pair x (Var y))). -Notation "x << y" := (Op (Shl (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) y)). -Notation "x << y" := (Op (Shl (TWord 7) (TWord 7) (TWord 7)) (Pair (Var x) (Var y))). -Notation "x >> y" := (Op (Shr _ _ _) (Pair x y)). -Notation "x >> y" := (Op (Shr _ _ _) (Pair x (Var y))). -Notation "x >> y" := (Op (Shr _ _ _) (Pair (Var x) y)). -Notation "x >> y" := (Op (Shr _ _ _) (Pair (Var x) (Var y))). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 0)) (Pair x y)) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 0)) (Pair x (Var y))) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 0)) (Pair (Var x) y)) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 0)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 1)) (Pair x y)) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 1)) (Pair x (Var y))) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 1)) (Pair (Var x) y)) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 1)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 2)) (Pair x y)) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 2)) (Pair x (Var y))) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 2)) (Pair (Var x) y)) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 2)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 3)) (Pair x y)) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 3)) (Pair x (Var y))) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 3)) (Pair (Var x) y)) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 3)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 4)) (Pair x y)) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 4)) (Pair x (Var y))) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 4)) (Pair (Var x) y)) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 4)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 5)) (Pair x y)) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 5)) (Pair x (Var y))) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 5)) (Pair (Var x) y)) (at level 30). -Notation "'(int)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 5)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(long)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 6)) (Pair x y)) (at level 30). -Notation "'(long)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 6)) (Pair x (Var y))) (at level 30). -Notation "'(long)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 6)) (Pair (Var x) y)) (at level 30). -Notation "'(long)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 6)) (Pair (Var x) (Var y))) (at level 30). -Notation "'(uint128_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 7)) (Pair x y)) (at level 30). -Notation "'(uint128_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 7)) (Pair x (Var y))) (at level 30). -Notation "'(uint128_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 7)) (Pair (Var x) y)) (at level 30). -Notation "'(uint128_t)' ( x >> y )" := (Op (Shr (TWord _) (TWord _) (TWord 7)) (Pair (Var x) (Var y))) (at level 30). -Notation Return x := (Var x). -Notation Java_like := (Expr base_type op _). diff --git a/src/Reflection/Z/MapCastByDeBruijn.v b/src/Reflection/Z/MapCastByDeBruijn.v deleted file mode 100644 index 4ccfe6d2d..000000000 --- a/src/Reflection/Z/MapCastByDeBruijn.v +++ /dev/null @@ -1,28 +0,0 @@ -Require Import Coq.ZArith.ZArith. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.MapCastByDeBruijn. -Require Import Crypto.Reflection.Z.Syntax. - -Section language. - Context {interp_base_type_bounds : base_type -> Type} - (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst) - (pick_typeb : forall t, interp_base_type_bounds t -> base_type). - Local Notation pick_type v := (SmartFlatTypeMap pick_typeb v). - Context (cast_op : forall t tR (opc : op t tR) args_bs, - op (pick_type args_bs) (pick_type (interp_op_bounds t tR opc args_bs))). - Context {t : type base_type}. - - Definition MapCastCompile := @MapCastCompile base_type op t. - Definition MapCastDoCast - := @MapCastDoCast - base_type op base_type_beq internal_base_type_dec_bl - interp_base_type_bounds interp_op_bounds pick_typeb cast_op t. - Definition MapCastDoInterp - := @MapCastDoInterp - base_type op base_type_beq internal_base_type_dec_bl - (fun _ t => Op (OpConst 0%Z) TT) - interp_base_type_bounds pick_typeb t. - Definition MapCast e input_bounds - := MapCastDoInterp input_bounds (MapCastDoCast input_bounds (MapCastCompile e)). -End language. diff --git a/src/Reflection/Z/MapCastByDeBruijnInterp.v b/src/Reflection/Z/MapCastByDeBruijnInterp.v deleted file mode 100644 index 6e57136ab..000000000 --- a/src/Reflection/Z/MapCastByDeBruijnInterp.v +++ /dev/null @@ -1,50 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Reflection.MapCastByDeBruijnInterp. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.MapCastByDeBruijn. - -Section language. - Context {interp_base_type_bounds : base_type -> Type} - (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst) - (pick_typeb : forall t, interp_base_type_bounds t -> base_type). - Local Notation pick_type v := (SmartFlatTypeMap pick_typeb v). - Context (cast_op : forall t tR (opc : op t tR) args_bs, - op (pick_type args_bs) (pick_type (interp_op_bounds t tR opc args_bs))) - (cast_backb: forall t b, interp_base_type (pick_typeb t b) -> interp_base_type t). - Let cast_back : forall t b, interp_flat_type interp_base_type (pick_type b) -> interp_flat_type interp_base_type t - := fun t b => SmartFlatTypeMapUnInterp cast_backb. - Context (inboundsb : forall t, interp_base_type_bounds t -> interp_base_type t -> Prop). - Let inbounds : forall t, interp_flat_type interp_base_type_bounds t -> interp_flat_type interp_base_type t -> Prop - := fun t => interp_flat_type_rel_pointwise inboundsb (t:=t). - Context (interp_op_bounds_correct - : forall t tR opc bs - (v : interp_flat_type interp_base_type t) - (H : inbounds t bs v), - inbounds tR (interp_op_bounds t tR opc bs) (interp_op t tR opc v)) - (pull_cast_back - : forall t tR opc bs - (v : interp_flat_type interp_base_type (pick_type bs)) - (H : inbounds t bs (cast_back t bs v)), - interp_op t tR opc (cast_back t bs v) - = - cast_back _ _ (interp_op _ _ (cast_op _ _ opc bs) v)). - - Local Notation MapCast - := (@MapCast interp_base_type_bounds interp_op_bounds pick_typeb cast_op). - - Lemma MapCastCorrect - {t} (e : Expr base_type op t) - (Hwf : Wf e) - (input_bounds : interp_flat_type interp_base_type_bounds (domain t)) - : forall {b} e' (He':MapCast e input_bounds = Some (existT _ b e')) - v v' (Hv : @inbounds _ input_bounds v /\ cast_back _ _ v' = v), - Interp interp_op_bounds e input_bounds = b - /\ @inbounds _ b (Interp interp_op e v) - /\ cast_back _ _ (Interp interp_op e' v') = (Interp interp_op e v). - Proof using Type*. - apply MapCastCorrect; auto using internal_base_type_dec_lb. - Qed. -End language. diff --git a/src/Reflection/Z/MapCastByDeBruijnWf.v b/src/Reflection/Z/MapCastByDeBruijnWf.v deleted file mode 100644 index 1173d8186..000000000 --- a/src/Reflection/Z/MapCastByDeBruijnWf.v +++ /dev/null @@ -1,56 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Relations. -Require Import Crypto.Reflection.MapCastByDeBruijnWf. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.MapCastByDeBruijn. - -Section language. - Context {interp_base_type_bounds : base_type -> Type} - (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst) - (pick_typeb : forall t, interp_base_type_bounds t -> base_type). - Local Notation pick_type v := (SmartFlatTypeMap pick_typeb v). - Context (cast_op : forall t tR (opc : op t tR) args_bs, - op (pick_type args_bs) (pick_type (interp_op_bounds t tR opc args_bs))) - (cast_backb: forall t b, interp_base_type (pick_typeb t b) -> interp_base_type t). - Let cast_back : forall t b, interp_flat_type interp_base_type (pick_type b) -> interp_flat_type interp_base_type t - := fun t b => SmartFlatTypeMapUnInterp cast_backb. - Context (inboundsb : forall t, interp_base_type_bounds t -> interp_base_type t -> Prop). - Let inbounds : forall t, interp_flat_type interp_base_type_bounds t -> interp_flat_type interp_base_type t -> Prop - := fun t => interp_flat_type_rel_pointwise inboundsb (t:=t). - Context (interp_op_bounds_correct - : forall t tR opc bs - (v : interp_flat_type interp_base_type t) - (H : inbounds t bs v), - inbounds tR (interp_op_bounds t tR opc bs) (interp_op t tR opc v)) - (pull_cast_back - : forall t tR opc bs - (v : interp_flat_type interp_base_type (pick_type bs)) - (H : inbounds t bs (cast_back t bs v)), - interp_op t tR opc (cast_back t bs v) - = - cast_back _ _ (interp_op _ _ (cast_op _ _ opc bs) v)). - - Local Notation MapCast - := (@MapCast interp_base_type_bounds interp_op_bounds pick_typeb cast_op). - - Definition Wf_MapCast - {t} (e : Expr base_type op t) - (input_bounds : interp_flat_type interp_base_type_bounds (domain t)) - {b} e' (He' : MapCast e input_bounds = Some (existT _ b e')) - (Hwf : Wf e) - : Wf e' - := @Wf_MapCast - _ _ _ internal_base_type_dec_bl internal_base_type_dec_lb _ _ _ _ _ - t e input_bounds b e' He' Hwf. - Definition Wf_MapCast_arrow - {s d} (e : Expr base_type op (Arrow s d)) - (input_bounds : interp_flat_type interp_base_type_bounds s) - {b} e' (He' : MapCast e input_bounds = Some (existT _ b e')) - (Hwf : Wf e) - : Wf e' - := @Wf_MapCast_arrow - _ _ _ internal_base_type_dec_bl internal_base_type_dec_lb _ _ _ _ _ - s d e input_bounds b e' He' Hwf. -End language. diff --git a/src/Reflection/Z/OpInversion.v b/src/Reflection/Z/OpInversion.v deleted file mode 100644 index 6b2cdd85b..000000000 --- a/src/Reflection/Z/OpInversion.v +++ /dev/null @@ -1,28 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.TypeInversion. -Require Import Crypto.Reflection.Z.Syntax. - -Ltac invert_one_op e := - preinvert_one_type e; - intros ? e; - destruct e; - try exact I. - -Ltac invert_op_step := - match goal with - | [ e : op _ (Tbase _) |- _ ] => invert_one_op e - | [ e : op _ (Prod _ _) |- _ ] => invert_one_op e - | [ e : op _ Unit |- _ ] => invert_one_op e - end. - -Ltac invert_op := repeat invert_op_step. - -Ltac invert_match_op_step := - match goal with - | [ |- appcontext[match ?e with OpConst _ _ => _ | _ => _ end] ] - => invert_one_op e - | [ H : appcontext[match ?e with OpConst _ _ => _ | _ => _ end] |- _ ] - => invert_one_op e - end. - -Ltac invert_match_op := repeat invert_match_op_step. diff --git a/src/Reflection/Z/Reify.v b/src/Reflection/Z/Reify.v deleted file mode 100644 index 439a1df8c..000000000 --- a/src/Reflection/Z/Reify.v +++ /dev/null @@ -1,50 +0,0 @@ -Require Import Coq.ZArith.ZArith. -Require Import Crypto.Reflection.InputSyntax. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Reflection.Z.Syntax.Equality. -Require Import Crypto.Reflection.Z.Syntax.Util. -Require Import Crypto.Reflection.WfReflective. -Require Import Crypto.Reflection.Reify. -Require Import Crypto.Reflection.Inline. -Require Import Crypto.Reflection.InlineInterp. -Require Import Crypto.Reflection.Linearize. -Require Import Crypto.Reflection.LinearizeInterp. -Require Import Crypto.Reflection.Eta. -Require Import Crypto.Reflection.EtaInterp. - -Ltac base_reify_op op op_head extra ::= - lazymatch op_head with - | @Z.add => constr:(reify_op op op_head 2 (Add TZ TZ TZ)) - | @Z.mul => constr:(reify_op op op_head 2 (Mul TZ TZ TZ)) - | @Z.sub => constr:(reify_op op op_head 2 (Sub TZ TZ TZ)) - | @Z.shiftl => constr:(reify_op op op_head 2 (Shl TZ TZ TZ)) - | @Z.shiftr => constr:(reify_op op op_head 2 (Shr TZ TZ TZ)) - | @Z.land => constr:(reify_op op op_head 2 (Land TZ TZ TZ)) - | @Z.lor => constr:(reify_op op op_head 2 (Lor TZ TZ TZ)) - | @Z.opp => constr:(reify_op op op_head 1 (Opp TZ TZ)) - end. -Ltac base_reify_type T ::= - lazymatch T with - | Z => TZ - end. -Ltac Reify' e := Reflection.Reify.Reify' base_type interp_base_type op e. -Ltac Reify e := - let v := Reflection.Reify.Reify base_type interp_base_type op make_const e in - constr:(ExprEta v). -Ltac prove_ExprEta_Compile_correct := - fun _ - => intros; - rewrite ?InterpExprEta; - prove_compile_correct_using ltac:(fun _ => apply make_const_correct) (). - -Ltac Reify_rhs := - Reflection.Reify.Reify_rhs_gen Reify prove_ExprEta_Compile_correct interp_op ltac:(fun tac => tac ()). - -Ltac prereify_context_variables := - Reflection.Reify.prereify_context_variables interp_base_type. -Ltac reify_context_variable := - Reflection.Reify.reify_context_variable base_type interp_base_type op. -Ltac lazy_reify_context_variable := - Reflection.Reify.lazy_reify_context_variable base_type interp_base_type op. -Ltac reify_context_variables := - Reflection.Reify.reify_context_variables base_type interp_base_type op. diff --git a/src/Reflection/Z/Syntax.v b/src/Reflection/Z/Syntax.v deleted file mode 100644 index 58c55bc06..000000000 --- a/src/Reflection/Z/Syntax.v +++ /dev/null @@ -1,84 +0,0 @@ -(** * PHOAS Syntax for expression trees on ℤ *) -Require Import Coq.ZArith.ZArith. -Require Import Bedrock.Word. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.TypeUtil. -Require Import Crypto.Util.FixedWordSizes. -Require Import Crypto.Util.Option. -Require Import Crypto.Util.NatUtil. (* for nat_beq for equality schemes *) -Export Syntax.Notations. - -Local Set Boolean Equality Schemes. -Local Set Decidable Equality Schemes. -Inductive base_type := TZ | TWord (logsz : nat). - -Local Notation tZ := (Tbase TZ). -Local Notation tWord logsz := (Tbase (TWord logsz)). - -Inductive op : flat_type base_type -> flat_type base_type -> Type := -| OpConst {T} (z : Z) : op Unit (Tbase T) -| Add T1 T2 Tout : op (Tbase T1 * Tbase T2) (Tbase Tout) -| Sub T1 T2 Tout : op (Tbase T1 * Tbase T2) (Tbase Tout) -| Mul T1 T2 Tout : op (Tbase T1 * Tbase T2) (Tbase Tout) -| Shl T1 T2 Tout : op (Tbase T1 * Tbase T2) (Tbase Tout) -| Shr T1 T2 Tout : op (Tbase T1 * Tbase T2) (Tbase Tout) -| Land T1 T2 Tout : op (Tbase T1 * Tbase T2) (Tbase Tout) -| Lor T1 T2 Tout : op (Tbase T1 * Tbase T2) (Tbase Tout) -| Opp T Tout : op (Tbase T) (Tbase Tout) -. - -Definition interp_base_type (v : base_type) : Type := - match v with - | TZ => Z - | TWord logsz => wordT logsz - end. - -Definition interpToZ {t} : interp_base_type t -> Z - := match t with - | TZ => fun x => x - | TWord _ => wordToZ - end. -Definition ZToInterp {t} : Z -> interp_base_type t - := match t return Z -> interp_base_type t with - | TZ => fun x => x - | TWord _ => ZToWord - end. -Definition cast_const {t1 t2} (v : interp_base_type t1) : interp_base_type t2 - := ZToInterp (interpToZ v). - -Local Notation eta x := (fst x, snd x). -Local Notation eta3 x := (eta (fst x), snd x). -Local Notation eta4 x := (eta3 (fst x), snd x). - -Definition lift_op {src dst} - (srcv:=SmartValf (fun _ => base_type) (fun t => t) src) - (dstv:=SmartValf (fun _ => base_type) (fun t => t) dst) - (ff:=fun t0 (v : interp_flat_type _ t0) t => SmartFlatTypeMap (var':=fun _ => base_type) (fun _ _ => t) v) - (srcf:=ff src srcv) (dstf:=ff dst dstv) - (srcZ:=srcf TZ) (dstZ:=dstf TZ) - (opZ : interp_flat_type interp_base_type srcZ -> interp_flat_type interp_base_type dstZ) - : interp_flat_type interp_base_type src - -> interp_flat_type interp_base_type dst - := fun xy - => SmartFlatTypeMapUnInterp - (fun _ _ => cast_const) - (opZ (SmartFlatTypeMapInterp2 (fun _ _ => cast_const) _ xy)). - -Definition Zinterp_op src dst (f : op src dst) - (asZ := fun t0 => SmartFlatTypeMap (var':=fun _ => base_type) (fun _ _ => TZ) (SmartValf (fun _ => base_type) (fun t => t) t0)) - : interp_flat_type interp_base_type (asZ src) -> interp_flat_type interp_base_type (asZ dst) - := match f in op src dst return interp_flat_type interp_base_type (asZ src) -> interp_flat_type interp_base_type (asZ dst) with - | OpConst _ v => fun _ => cast_const (t1:=TZ) v - | Add _ _ _ => fun xy => fst xy + snd xy - | Sub _ _ _ => fun xy => fst xy - snd xy - | Mul _ _ _ => fun xy => fst xy * snd xy - | Shl _ _ _ => fun xy => Z.shiftl (fst xy) (snd xy) - | Shr _ _ _ => fun xy => Z.shiftr (fst xy) (snd xy) - | Land _ _ _ => fun xy => Z.land (fst xy) (snd xy) - | Lor _ _ _ => fun xy => Z.lor (fst xy) (snd xy) - | Opp _ _ => fun x => Z.opp x - end%Z. - -Definition interp_op src dst (f : op src dst) : interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst - := lift_op (Zinterp_op src dst f). diff --git a/src/Reflection/Z/Syntax/Equality.v b/src/Reflection/Z/Syntax/Equality.v deleted file mode 100644 index 17822d7ec..000000000 --- a/src/Reflection/Z/Syntax/Equality.v +++ /dev/null @@ -1,176 +0,0 @@ -Require Import Coq.ZArith.ZArith. -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.TypeInversion. -Require Import Crypto.Reflection.Equality. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Util.Decidable. -Require Import Crypto.Util.PartiallyReifiedProp. -Require Import Crypto.Util.HProp. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.FixedWordSizesEquality. -Require Import Crypto.Util.NatUtil. - -Global Instance dec_eq_base_type : DecidableRel (@eq base_type) - := base_type_eq_dec. -Global Instance dec_eq_flat_type : DecidableRel (@eq (flat_type base_type)) := _. -Global Instance dec_eq_type : DecidableRel (@eq (type base_type)) := _. - -Definition base_type_eq_semidec_transparent (t1 t2 : base_type) - : option (t1 = t2) - := match base_type_eq_dec t1 t2 with - | left pf => Some pf - | right _ => None - end. -Lemma base_type_eq_semidec_is_dec t1 t2 : base_type_eq_semidec_transparent t1 t2 = None -> t1 <> t2. -Proof. - unfold base_type_eq_semidec_transparent; break_match; congruence. -Qed. - -Definition op_beq_hetero {t1 tR t1' tR'} (f : op t1 tR) (g : op t1' tR') : bool - := match f, g return bool with - | OpConst T1 v, OpConst T2 v' - => base_type_beq T1 T2 && Z.eqb v v' - | Add T1 T2 Tout, Add T1' T2' Tout' - | Sub T1 T2 Tout, Sub T1' T2' Tout' - | Mul T1 T2 Tout, Mul T1' T2' Tout' - | Shl T1 T2 Tout, Shl T1' T2' Tout' - | Shr T1 T2 Tout, Shr T1' T2' Tout' - | Land T1 T2 Tout, Land T1' T2' Tout' - | Lor T1 T2 Tout, Lor T1' T2' Tout' - => base_type_beq T1 T1' && base_type_beq T2 T2' && base_type_beq Tout Tout' - | Opp Tin Tout, Opp Tin' Tout' - => base_type_beq Tin Tin' && base_type_beq Tout Tout' - | OpConst _ _, _ - | Add _ _ _, _ - | Sub _ _ _, _ - | Mul _ _ _, _ - | Shl _ _ _, _ - | Shr _ _ _, _ - | Land _ _ _, _ - | Lor _ _ _, _ - | Opp _ _, _ - => false - end%bool. - -Definition op_beq t1 tR (f g : op t1 tR) : bool - := Eval cbv [op_beq_hetero] in op_beq_hetero f g. - -Definition op_beq_hetero_type_eq {t1 tR t1' tR'} f g : to_prop (@op_beq_hetero t1 tR t1' tR' f g) -> t1 = t1' /\ tR = tR'. -Proof. - destruct f, g; - repeat match goal with - | _ => progress unfold op_beq_hetero in * - | _ => simpl; intro; exfalso; assumption - | _ => solve [ repeat constructor ] - | [ |- context[reified_Prop_of_bool ?b] ] - => let H := fresh in destruct (Sumbool.sumbool_of_bool b) as [H|H]; rewrite H - | [ H : nat_beq _ _ = true |- _ ] => apply internal_nat_dec_bl in H; subst - | [ H : base_type_beq _ _ = true |- _ ] => apply internal_base_type_dec_bl in H; subst - | [ H : wordT_beq_hetero _ _ = true |- _ ] => apply wordT_beq_bl in H; subst - | [ H : wordT_beq_hetero _ _ = true |- _ ] => apply wordT_beq_hetero_bl in H; destruct H; subst - | [ H : andb ?x ?y = true |- _ ] - => assert (x = true /\ y = true) by (destruct x, y; simpl in *; repeat constructor; exfalso; clear -H; abstract congruence); - clear H - | [ H : and _ _ |- _ ] => destruct H - | [ H : false = true |- _ ] => exfalso; clear -H; abstract congruence - | [ H : true = false |- _ ] => exfalso; clear -H; abstract congruence - | _ => progress break_match_hyps - end. -Defined. - -Definition op_beq_hetero_type_eqs {t1 tR t1' tR'} f g : to_prop (@op_beq_hetero t1 tR t1' tR' f g) -> t1 = t1' - := fun H => let (p, q) := @op_beq_hetero_type_eq t1 tR t1' tR' f g H in p. -Definition op_beq_hetero_type_eqd {t1 tR t1' tR'} f g : to_prop (@op_beq_hetero t1 tR t1' tR' f g) -> tR = tR' - := fun H => let (p, q) := @op_beq_hetero_type_eq t1 tR t1' tR' f g H in q. - -Definition op_beq_hetero_eq {t1 tR t1' tR'} f g - : forall pf : to_prop (@op_beq_hetero t1 tR t1' tR' f g), - eq_rect - _ (fun src => op src tR') - (eq_rect _ (fun dst => op t1 dst) f _ (op_beq_hetero_type_eqd f g pf)) - _ (op_beq_hetero_type_eqs f g pf) - = g. -Proof. - destruct f, g; - repeat match goal with - | _ => solve [ intros [] ] - | _ => reflexivity - | [ H : False |- _ ] => exfalso; assumption - | _ => intro - | [ |- context[op_beq_hetero_type_eqd ?f ?g ?pf] ] - => generalize (op_beq_hetero_type_eqd f g pf), (op_beq_hetero_type_eqs f g pf) - | _ => intro - | _ => progress eliminate_hprop_eq - | _ => progress inversion_flat_type - | _ => progress unfold op_beq_hetero in * - | _ => progress simpl in * - | [ H : context[andb ?x ?y] |- _ ] - => destruct x eqn:?, y eqn:?; simpl in H - | [ H : Z.eqb _ _ = true |- _ ] => apply Z.eqb_eq in H - | [ H : to_prop (reified_Prop_of_bool ?b) |- _ ] => destruct b eqn:?; compute in H - | _ => progress subst - | _ => progress break_match_hyps - | [ H : wordT_beq_hetero _ _ = true |- _ ] => apply wordT_beq_bl in H; subst - | [ H : wordT_beq_hetero _ _ = true |- _ ] => apply wordT_beq_hetero_bl in H; destruct H; subst - | _ => congruence - end. -Qed. - -Lemma op_beq_bl : forall t1 tR x y, to_prop (op_beq t1 tR x y) -> x = y. -Proof. - intros ?? f g H. - pose proof (op_beq_hetero_eq f g H) as H'. - generalize dependent (op_beq_hetero_type_eqd f g H). - generalize dependent (op_beq_hetero_type_eqs f g H). - intros; eliminate_hprop_eq; simpl in *; assumption. -Qed. - -Section encode_decode. - Definition base_type_code (t1 t2 : base_type) : Prop - := match t1, t2 with - | TZ, TZ => True - | TWord s1, TWord s2 => s1 = s2 - | TZ, _ - | TWord _, _ - => False - end. - - Definition base_type_encode (x y : base_type) : x = y -> base_type_code x y. - Proof. intro p; destruct p, x; repeat constructor. Defined. - - Definition base_type_decode (x y : base_type) : base_type_code x y -> x = y. - Proof. - destruct x, y; simpl in *; intro H; - try first [ apply f_equal; assumption - | exfalso; assumption - | reflexivity - | apply f_equal2; destruct H; assumption ]. - Defined. - Definition path_base_type_rect {x y : base_type} (Q : x = y -> Type) - (f : forall p, Q (base_type_decode x y p)) - : forall p, Q p. - Proof. intro p; specialize (f (base_type_encode x y p)); destruct x, p; exact f. Defined. -End encode_decode. - -Ltac induction_type_in_using H rect := - induction H as [H] using (rect _ _); - cbv [base_type_code] in H; - let H1 := fresh H in - let H2 := fresh H in - try lazymatch type of H with - | False => exfalso; exact H - | True => destruct H - end. -Ltac inversion_base_type_step := - lazymatch goal with - | [ H : _ = TWord _ |- _ ] - => induction_type_in_using H @path_base_type_rect - | [ H : TWord _ = _ |- _ ] - => induction_type_in_using H @path_base_type_rect - | [ H : _ = TZ |- _ ] - => induction_type_in_using H @path_base_type_rect - | [ H : TZ = _ |- _ ] - => induction_type_in_using H @path_base_type_rect - end. -Ltac inversion_base_type := repeat inversion_base_type_step. diff --git a/src/Reflection/Z/Syntax/Util.v b/src/Reflection/Z/Syntax/Util.v deleted file mode 100644 index b5862c72f..000000000 --- a/src/Reflection/Z/Syntax/Util.v +++ /dev/null @@ -1,170 +0,0 @@ -Require Import Crypto.Reflection.Syntax. -Require Import Crypto.Reflection.SmartMap. -Require Import Crypto.Reflection.Wf. -Require Import Crypto.Reflection.TypeUtil. -Require Import Crypto.Reflection.TypeInversion. -Require Import Crypto.Reflection.Z.Syntax. -Require Import Crypto.Util.FixedWordSizesEquality. -Require Import Crypto.Util.NatUtil. -Require Import Crypto.Util.HProp. -Require Import Crypto.Util.Tactics.BreakMatch. -Require Import Crypto.Util.Tactics.DestructHead. -Require Import Crypto.Util.Notations. - -Definition make_const t : interp_base_type t -> op Unit (Tbase t) - := fun v => OpConst (cast_const (t2:=TZ) v). -Definition is_const s d (v : op s d) : bool - := match v with OpConst _ _ => true | _ => false end. -Arguments is_const [s d] v. - -Definition cast_back_flat_const {var t f V} - (v : interp_flat_type interp_base_type (@SmartFlatTypeMap base_type var f t V)) - : interp_flat_type interp_base_type t - := @SmartFlatTypeMapUnInterp - _ var interp_base_type interp_base_type - f (fun _ _ => cast_const) - t V v. - -Definition cast_flat_const {var t f V} - (v : interp_flat_type interp_base_type t) - : interp_flat_type interp_base_type (@SmartFlatTypeMap base_type var f t V) - := @SmartFlatTypeMapInterp2 - _ var interp_base_type interp_base_type - f (fun _ _ => cast_const) - t V v. - -Definition base_type_leb (v1 v2 : base_type) : bool - := match v1, v2 with - | _, TZ => true - | TZ, _ => false - | TWord logsz1, TWord logsz2 => Compare_dec.leb logsz1 logsz2 - end. - -Definition base_type_min := base_type_min base_type_leb. -Definition base_type_max := base_type_max base_type_leb. -Global Arguments base_type_min !_ !_ / . -Global Arguments base_type_max !_ !_ / . -Global Arguments TypeUtil.base_type_min _ _ _ / _. -Global Arguments TypeUtil.base_type_max _ _ _ / _. - -Definition genericize_op {var' src dst} (opc : op src dst) {f} - : forall {vs vd}, op (@SmartFlatTypeMap _ var' f src vs) (@SmartFlatTypeMap _ var' f dst vd) - := match opc with - | OpConst _ z => fun _ _ => OpConst z - | Add _ _ _ => fun _ _ => Add _ _ _ - | Sub _ _ _ => fun _ _ => Sub _ _ _ - | Mul _ _ _ => fun _ _ => Mul _ _ _ - | Shl _ _ _ => fun _ _ => Shl _ _ _ - | Shr _ _ _ => fun _ _ => Shr _ _ _ - | Land _ _ _ => fun _ _ => Land _ _ _ - | Lor _ _ _ => fun _ _ => Lor _ _ _ - | Opp _ _ => fun _ _ => Opp _ _ - end. - -Lemma cast_const_id {t} v - : @cast_const t t v = v. -Proof. - destruct t; simpl; trivial. - rewrite ZToWord_wordToZ; reflexivity. -Qed. - -Lemma cast_const_idempotent {a b c} v - : base_type_min b (base_type_min a c) = base_type_min a c - -> @cast_const b c (@cast_const a b v) = @cast_const a c v. -Proof. - repeat first [ reflexivity - | congruence - | progress destruct_head' base_type - | progress simpl - | progress break_match - | progress subst - | intro - | match goal with - | [ H : ?leb _ _ = true |- _ ] => apply Compare_dec.leb_complete in H - | [ H : ?leb _ _ = false |- _ ] => apply Compare_dec.leb_iff_conv in H - | [ H : TWord _ = TWord _ |- _ ] => inversion H; clear H - end - | rewrite ZToWord_wordToZ_ZToWord by omega * - | rewrite wordToZ_ZToWord_wordToZ by omega * ]. -Qed. - -Lemma make_const_correct : forall T v, interp_op Unit (Tbase T) (make_const T v) tt = v. -Proof. - destruct T; cbv -[FixedWordSizes.ZToWord FixedWordSizes.wordToZ FixedWordSizes.wordT]; - intro; rewrite ?ZToWord_wordToZ; reflexivity. -Qed. - -Local Notation iffT A B := ((A -> B) * (B -> A))%type (only parsing). - -Section unzify. - Context {var'} {f : forall t : base_type, var' t -> base_type}. - Let asZ := fun t => SmartFlatTypeMap - (fun _ _ => TZ) - (SmartValf (fun _ => base_type) (fun t => t) t). - Definition unzify_op_helper_step - (unzify_op_helper - : forall {t : flat_type base_type} - {vs : interp_flat_type var' t}, - iffT (interp_flat_type - interp_base_type - (asZ t)) - (interp_flat_type - interp_base_type - (asZ (SmartFlatTypeMap f vs)))) - {t : flat_type base_type} - : forall {vs : interp_flat_type var' t}, - iffT (interp_flat_type - interp_base_type - (asZ t)) - (interp_flat_type - interp_base_type - (asZ (SmartFlatTypeMap f vs))) - := match t with - | Tbase T => fun _ => (fun x => x, fun x => x) - | Unit => fun _ => (fun x => x, fun x => x) - | Prod A B - => fun (vs : interp_flat_type _ A * interp_flat_type _ B) - => let f1 := @unzify_op_helper A (fst vs) in - let f2 := @unzify_op_helper B (snd vs) in - ((fun x : interp_flat_type _ (asZ A) * interp_flat_type _ (asZ B) - => (fst f1 (fst x), fst f2 (snd x))), - (fun x : interp_flat_type _ (asZ (SmartFlatTypeMap f (fst vs))) - * interp_flat_type _ (asZ (SmartFlatTypeMap f (snd vs))) - => (snd f1 (fst x), snd f2 (snd x)))) - end. - Fixpoint unzify_op_helper {t vs} - := @unzify_op_helper_step (@unzify_op_helper) t vs. - - Definition unzify_op - {src dst : flat_type base_type} - {vs : interp_flat_type var' src} {vd : interp_flat_type var' dst} - (F : interp_flat_type interp_base_type (asZ src) -> interp_flat_type interp_base_type (asZ dst)) - (x : interp_flat_type interp_base_type (asZ (SmartFlatTypeMap f vs))) - : interp_flat_type interp_base_type (asZ (SmartFlatTypeMap f vd)) - := fst unzify_op_helper (F (snd unzify_op_helper x)). -End unzify. - -Arguments unzify_op_helper_step _ _ _ !_ _ / . -Arguments unzify_op_helper _ _ !_ _ / . - -Lemma Zinterp_op_genericize_op {var' src dst opc f vs vd} - : Zinterp_op _ _ (@genericize_op var' src dst opc f vs vd) - = unzify_op (Zinterp_op _ _ opc). -Proof. - destruct opc; unfold unzify_op; reflexivity. -Qed. - -Lemma lift_op_prod_dst {src dstA dstB} - {f : _ -> interp_flat_type _ (SmartFlatTypeMap _ (SmartValf _ _ _)) * interp_flat_type _ (SmartFlatTypeMap _ (SmartValf _ _ _))} - {x} - : @lift_op src (Prod dstA dstB) f x - = (@lift_op src dstA (fun y => fst (f y)) x, @lift_op src dstB (fun y => snd (f y)) x). -Proof. reflexivity. Qed. - -Lemma cast_back_flat_const_prod {var A B f} {V : _ * _} - (v : interp_flat_type interp_base_type (@SmartFlatTypeMap base_type var f A (fst V)) - * interp_flat_type interp_base_type (@SmartFlatTypeMap base_type var f B (snd V))) - : @cast_back_flat_const var (Prod A B) f V v - = (@cast_back_flat_const var A f (fst V) (fst v), - @cast_back_flat_const var B f (snd V) (snd v)). -Proof. reflexivity. Qed. |