From ead4864de8f4425a19b6c45dc8917f4a91a34598 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Tue, 26 Mar 2024 11:27:44 -0700 Subject: [PATCH 01/42] restrict injectivity of inductives based on a simpler but more restrictive check --- .../generated/FStar_SMTEncoding_Encode.ml | 19 +------------------ src/smtencoding/FStar.SMTEncoding.Encode.fst | 9 +++++---- 2 files changed, 6 insertions(+), 22 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index 74187ca1445..66443a1be87 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -4632,24 +4632,7 @@ and (encode_sigelt' : let t_tp = (tp.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in let uu___10 = u_leq_u_k u_tp in - if uu___10 - then true - else - (let uu___12 = - FStar_Syntax_Util.arrow_formals - t_tp in - match uu___12 with - | (formals, uu___13) -> - let uu___14 = - FStar_TypeChecker_TcTerm.tc_binders - env_tps formals in - (match uu___14 with - | (uu___15, uu___16, uu___17, - u_formals) -> - FStar_Compiler_Util.for_all - (fun u_formal -> - u_leq_u_k u_formal) - u_formals)) in + if uu___10 then true else false in FStar_Compiler_List.forall2 tp_ok tps3 us)))) in ((let uu___4 = diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst index 47f762e1787..642346e63fe 100644 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ b/src/smtencoding/FStar.SMTEncoding.Encode.fst @@ -1273,10 +1273,11 @@ and encode_sigelt' (env:env_t) (se:sigelt) : (decls_t * env_t) = let t_tp = tp.binder_bv.sort in if u_leq_u_k u_tp then true - else let formals, _ = U.arrow_formals t_tp in - let _, _, _, u_formals = TcTerm.tc_binders env_tps formals in - //List.iter (fun u -> BU.print1 "Universe of formal: %s\n" (Print.univ_to_string u)) u_formals; - BU.for_all (fun u_formal -> u_leq_u_k u_formal) u_formals + else false + // let formals, _ = U.arrow_formals t_tp in + // let _, _, _, u_formals = TcTerm.tc_binders env_tps formals in + // //List.iter (fun u -> BU.print1 "Universe of formal: %s\n" (Print.univ_to_string u)) u_formals; + // BU.for_all (fun u_formal -> u_leq_u_k u_formal) u_formals in List.forall2 tp_ok tps us in From 2c50dcdee0c7bcfd500073e296debbaa5dbe13b2 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Tue, 26 Mar 2024 22:52:57 -0700 Subject: [PATCH 02/42] a refinement of the injectivity constraint --- .../generated/FStar_SMTEncoding_Encode.ml | 50 +++++++++++++++++-- src/smtencoding/FStar.SMTEncoding.Encode.fst | 38 +++++++++++--- ulib/FStar.ModifiesGen.fst | 15 ++++-- ulib/FStar.WellFounded.Util.fst | 4 +- ulib/FStar.WellFounded.fst | 25 ++++++++-- ulib/FStar.WellFoundedRelation.fst | 9 +++- ulib/legacy/FStar.Constructive.fst | 5 +- 7 files changed, 122 insertions(+), 24 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index 66443a1be87..35d0d0218db 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -4491,6 +4491,7 @@ and (encode_sigelt' : FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = uu___2; FStar_Syntax_Syntax.ds = datas;_} -> + let t_lid = t in let tcenv = env.FStar_SMTEncoding_Env.tcenv in let is_injective = let uu___3 = FStar_Syntax_Subst.univ_var_opening universe_names in @@ -4624,15 +4625,58 @@ and (encode_sigelt' : uu___12 | uu___10 -> false in let u_leq_u_k u = - let uu___10 = + let u1 = FStar_TypeChecker_Normalize.normalize_universe env_tps u in - universe_leq uu___10 u_k in + universe_leq u1 u_k in let tp_ok tp u_tp = let t_tp = (tp.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in let uu___10 = u_leq_u_k u_tp in - if uu___10 then true else false in + if uu___10 + then true + else + (let t_tp1 = + FStar_TypeChecker_Normalize.normalize + [FStar_TypeChecker_Env.Unrefine; + FStar_TypeChecker_Env.Unascribe; + FStar_TypeChecker_Env.Unmeta; + FStar_TypeChecker_Env.Primops; + FStar_TypeChecker_Env.HNF; + FStar_TypeChecker_Env.UnfoldUntil + FStar_Syntax_Syntax.delta_constant; + FStar_TypeChecker_Env.Beta] + env_tps t_tp in + let uu___12 = + FStar_Syntax_Util.arrow_formals + t_tp1 in + match uu___12 with + | (formals, t1) -> + let uu___13 = + FStar_TypeChecker_TcTerm.tc_binders + env_tps formals in + (match uu___13 with + | (uu___14, uu___15, uu___16, + u_formals) -> + let inj = + FStar_Compiler_Util.for_all + (fun u_formal -> + u_leq_u_k u_formal) + u_formals in + if inj + then + let uu___17 = + let uu___18 = + FStar_Syntax_Subst.compress + t1 in + uu___18.FStar_Syntax_Syntax.n in + (match uu___17 with + | FStar_Syntax_Syntax.Tm_type + uu___18 -> true + | FStar_Syntax_Syntax.Tm_name + uu___18 -> true + | uu___18 -> false) + else false)) in FStar_Compiler_List.forall2 tp_ok tps3 us)))) in ((let uu___4 = diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst index 642346e63fe..5bc47758a5f 100644 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ b/src/smtencoding/FStar.SMTEncoding.Encode.fst @@ -1228,6 +1228,7 @@ and encode_sigelt' (env:env_t) (se:sigelt) : (decls_t * env_t) = params=tps; t=k; ds=datas} -> + let t_lid = t in let tcenv = env.tcenv in let is_injective = let usubst, uvs = SS.univ_var_opening universe_names in @@ -1267,17 +1268,42 @@ and encode_sigelt' (env:env_t) (se:sigelt) : (decls_t * env_t) = | _ -> false in let u_leq_u_k u = - universe_leq (N.normalize_universe env_tps u) u_k + let u = N.normalize_universe env_tps u in + universe_leq u u_k in let tp_ok (tp:S.binder) (u_tp:universe) = let t_tp = tp.binder_bv.sort in if u_leq_u_k u_tp then true - else false - // let formals, _ = U.arrow_formals t_tp in - // let _, _, _, u_formals = TcTerm.tc_binders env_tps formals in - // //List.iter (fun u -> BU.print1 "Universe of formal: %s\n" (Print.univ_to_string u)) u_formals; - // BU.for_all (fun u_formal -> u_leq_u_k u_formal) u_formals + else ( + let t_tp = + N.normalize + [Unrefine; Unascribe; Unmeta; + Primops; HNF; UnfoldUntil delta_constant; Beta] + env_tps t_tp + in + let formals, t = U.arrow_formals t_tp in + let _, _, _, u_formals = TcTerm.tc_binders env_tps formals in + let inj = BU.for_all (fun u_formal -> u_leq_u_k u_formal) u_formals in + if inj + then ( + match (SS.compress t).n with + | Tm_type _ -> (* this parameter is an "arity", i.e., a type function *) + true + | Tm_name _ -> (* this is a value of another type parameter in scope *) + true + | _ -> + // BU.print5 "No injectivity for %s because of parameter %s : %s @ universe %s GSet.mem (ALoc x.region x.addr (if None? x.loc then None else Some (make_cls_union_aloc b (Some?.v x.loc)))) (union_aux_of_aux_left c b aux)) [SMTPat (GSet.mem x aux)] -= () += let ALoc _ _ _ = x in () let mem_union_aux_of_aux_left_elim (#al: (bool -> HS.rid -> nat -> Tot Type)) @@ -2118,12 +2122,12 @@ let upgrade_aloc (#al: aloc_t u#a) (#c: cls al) (a: aloc c) : Tot (aloc (raise_c let downgrade_aloc_upgrade_aloc (#al: aloc_t u#a) (#c: cls al) (a: aloc c) : Lemma (downgrade_aloc (upgrade_aloc u#a u#b a) == a) [SMTPat (downgrade_aloc (upgrade_aloc u#a u#b a))] -= () += let ALoc _ _ _ = a in () let upgrade_aloc_downgrade_aloc (#al: aloc_t u#a) (#c: cls al) (a: aloc (raise_cls u#a u#b c)) : Lemma (upgrade_aloc (downgrade_aloc a) == a) [SMTPat (upgrade_aloc u#a u#b (downgrade_aloc a))] -= () += let ALoc _ _ _ = a in () let raise_loc_aux_pred (#al: aloc_t u#a) @@ -2166,6 +2170,7 @@ let raise_loc_includes #al #c l1 l2 = #pop-options let raise_loc_disjoint #al #c l1 l2 = + // let ALoc _ _ _ = al in let l1' = raise_loc l1 in let l2' = raise_loc l2 in assert (forall (x: aloc (raise_cls c)) . GSet.mem x (Ghost.reveal (Loc?.aux l1')) <==> GSet.mem (downgrade_aloc x) (Ghost.reveal (Loc?.aux l1))); diff --git a/ulib/FStar.WellFounded.Util.fst b/ulib/FStar.WellFounded.Util.fst index a738123731b..a4fc7cdf1e2 100644 --- a/ulib/FStar.WellFounded.Util.fst +++ b/ulib/FStar.WellFounded.Util.fst @@ -52,7 +52,7 @@ let lift_binrel_well_founded (#a:Type u#a) : Tot (acc (lift_binrel r) y) (decreases pf) = AccIntro (fun (z:top) (p:lift_binrel r z y) -> - aux z (pf.access_smaller (dsnd z) (lower_binrel z y p))) + aux z (match pf with | AccIntro access_smaller -> access_smaller (dsnd z) (lower_binrel z y p))) in let aux' (y:top{dfst y =!= a}) : acc (lift_binrel r) y @@ -83,7 +83,7 @@ let lift_binrel_squashed_well_founded (#a:Type u#a) (decreases pf) = AccIntro (fun (z:top) (p:lift_binrel_squashed r z y) -> let p = lower_binrel_squashed z y p in - aux z (pf.access_smaller (dsnd z) (FStar.Squash.join_squash p))) + aux z (match pf with AccIntro access_smaller -> access_smaller (dsnd z) (FStar.Squash.join_squash p))) in let aux' (y:top{dfst y =!= a}) : acc (lift_binrel_squashed r) y diff --git a/ulib/FStar.WellFounded.fst b/ulib/FStar.WellFounded.fst index 97ee6223a4b..639ea3324dd 100644 --- a/ulib/FStar.WellFounded.fst +++ b/ulib/FStar.WellFounded.fst @@ -50,7 +50,13 @@ let rec fix_F (#aa:Type) (#r:binrel aa) (#p:(aa -> Type)) (f: (x:aa -> (y:aa -> r y x -> p y) -> p x)) (x:aa) (a:acc r x) : Tot (p x) (decreases a) - = f x (fun y h -> fix_F f y (a.access_smaller y h)) + = f x (fun y h -> + let v : acc r y = + match a with + | AccIntro access_smaller -> + access_smaller y h + in + fix_F f y v) let fix (#aa:Type) (#r:binrel aa) (rwf:well_founded r) (p:aa -> Type) (f:(x:aa -> (y:aa -> r y x -> p y) -> p x)) @@ -101,9 +107,12 @@ let subrelation_squash_wf (#a:Type u#a) let rec acc_y (x:a) (acc_r:acc r x) (y:a) (p:sub_r y x) : Tot (acc sub_r y) (decreases acc_r) - = AccIntro (acc_y y (acc_r.access_smaller - y - (elim_squash (sub_w y x p)))) + = let v : acc _ y = + match acc_r with + | AccIntro access_smaller -> + access_smaller y (elim_squash (sub_w y x p)) + in + AccIntro (acc_y y v) in FStar.Squash.return_squash (FStar.Squash.return_squash (AccIntro (acc_y x (r_wf x)))) ) @@ -126,6 +135,12 @@ let inverse_image_wf (#a:Type u#a) (#b:Type u#b) (#r_b:binrel u#b u#r b) = let rec aux (x:a) (acc_r_b:acc r_b (f x)) : Tot (acc (inverse_image r_b f) x) (decreases acc_r_b) = - AccIntro (fun y p -> aux y (acc_r_b.access_smaller (f y) p)) + AccIntro (fun y p -> + let v = + match acc_r_b with + | AccIntro access_smaller -> + access_smaller (f y) p + in + aux y v) in fun x -> aux x (r_b_wf (f x)) diff --git a/ulib/FStar.WellFoundedRelation.fst b/ulib/FStar.WellFoundedRelation.fst index 3460dfb52f3..ea8f6217d86 100644 --- a/ulib/FStar.WellFoundedRelation.fst +++ b/ulib/FStar.WellFoundedRelation.fst @@ -62,7 +62,14 @@ let rec acc_decreaser let smaller (y: a{(acc_relation r) y x}) : (acc_classical (acc_relation r) y) = ( eliminate exists (p: r y x). True returns f y << f x - with _. assert ((f x).access_smaller y p == f y); + with _. assert ( + let v = + match f x with + | WF.AccIntro access_smaller -> + access_smaller y p + in + v == f y + ); acc_decreaser r f y ) in AccClassicalIntro smaller diff --git a/ulib/legacy/FStar.Constructive.fst b/ulib/legacy/FStar.Constructive.fst index 249b52e6ca8..7a50cb8ba8d 100644 --- a/ulib/legacy/FStar.Constructive.fst +++ b/ulib/legacy/FStar.Constructive.fst @@ -14,6 +14,7 @@ limitations under the License. *) module FStar.Constructive + type cand p1 p2 = | Conj : h1:p1 -> h2:p2 -> cand p1 p2 @@ -39,10 +40,10 @@ type ceq_type (a:Type) : Type -> Type = | ReflType : ceq_type a a val eq_ind : #a:Type -> x:a -> p:(a -> Type) -> f:p x -> y:a -> e:ceq x y -> Tot (p y) -let eq_ind #a x p f y _ = f +let eq_ind #a x p f y e = let Refl = e in f val ceq_eq : #a:Type{hasEq a} -> #x:a -> #y:a -> h:(ceq x y) -> Lemma (x = y) -let ceq_eq #a #x #y h = () +let ceq_eq #a #x #y h = let Refl = h in () val ceq_congruence : #a:Type -> #b:Type -> #x:a -> #y:a -> ceq x y -> f:(a -> GTot b) -> GTot (ceq (f x) (f y)) From 92f768a28fd33b02a20ef19e30d46256be50bb5d Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Wed, 27 Mar 2024 11:50:08 -0700 Subject: [PATCH 03/42] retain equations on indices even if parameters are in a universe too high; dd support for --ext 'compat:injectivity' for assisting with breakages --- .../generated/FStar_SMTEncoding_Encode.ml | 56 ++++++++++++++++--- src/smtencoding/FStar.SMTEncoding.Encode.fst | 16 ++++-- 2 files changed, 60 insertions(+), 12 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index 35d0d0218db..3a3fd75033a 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -4493,7 +4493,7 @@ and (encode_sigelt' : -> let t_lid = t in let tcenv = env.FStar_SMTEncoding_Env.tcenv in - let is_injective = + let is_injective_on_params = let uu___3 = FStar_Syntax_Subst.univ_var_opening universe_names in match uu___3 with | (usubst, uvs) -> @@ -4686,7 +4686,7 @@ and (encode_sigelt' : then let uu___5 = FStar_Ident.string_of_lid t in FStar_Compiler_Util.print2 "%s injectivity for %s\n" - (if is_injective then "YES" else "NO") uu___5 + (if is_injective_on_params then "YES" else "NO") uu___5 else ()); (let quals = se.FStar_Syntax_Syntax.sigquals in let is_logical = @@ -4794,21 +4794,61 @@ and (encode_sigelt' : "Impossible" else (); (let eqs = - if is_injective + let uu___14 = + is_injective_on_params + || + (let uu___15 = + FStar_Options.ext_getv + "compat:injectivity" in + uu___15 <> "") in + if uu___14 then FStar_Compiler_List.map2 (fun v -> fun a -> - let uu___14 = - let uu___15 + let uu___15 = + let uu___16 = FStar_SMTEncoding_Util.mkFreeV v in - (uu___15, a) in + (uu___16, a) in FStar_SMTEncoding_Util.mkEq - uu___14) + uu___15) vars indices1 - else [] in + else + (let num_params = + FStar_Compiler_List.length + tps in + let uu___16 = + FStar_Compiler_List.splitAt + num_params vars in + match uu___16 with + | (_var_params, + var_indices) -> + let uu___17 = + FStar_Compiler_List.splitAt + num_params + indices1 in + (match uu___17 + with + | (_i_params, + indices2) -> + FStar_Compiler_List.map2 + ( + fun v -> + fun a -> + let uu___18 + = + let uu___19 + = + FStar_SMTEncoding_Util.mkFreeV + v in + (uu___19, + a) in + FStar_SMTEncoding_Util.mkEq + uu___18) + var_indices + indices2)) in let uu___14 = let uu___15 = let uu___16 = diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst index 5bc47758a5f..238058ea5d6 100644 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ b/src/smtencoding/FStar.SMTEncoding.Encode.fst @@ -1230,7 +1230,7 @@ and encode_sigelt' (env:env_t) (se:sigelt) : (decls_t * env_t) = ds=datas} -> let t_lid = t in let tcenv = env.tcenv in - let is_injective = + let is_injective_on_params = let usubst, uvs = SS.univ_var_opening universe_names in let env, tps, k = Env.push_univ_vars tcenv uvs, @@ -1309,7 +1309,7 @@ and encode_sigelt' (env:env_t) (se:sigelt) : (decls_t * env_t) = in if Env.debug env.tcenv <| Options.Other "SMTEncoding" then BU.print2 "%s injectivity for %s\n" - (if is_injective then "YES" else "NO") + (if is_injective_on_params then "YES" else "NO") (Ident.string_of_lid t); let quals = se.sigquals in let is_logical = quals |> BU.for_some (function Logic | Assumption -> true | _ -> false) in @@ -1333,9 +1333,17 @@ and encode_sigelt' (env:env_t) (se:sigelt) : (decls_t * env_t) = if List.length indices <> List.length vars then failwith "Impossible"; let eqs = - if is_injective + if is_injective_on_params + || Options.ext_getv "compat:injectivity" <> "" then List.map2 (fun v a -> mkEq(mkFreeV v, a)) vars indices - else [] in + else ( + //only injectivity on indices + let num_params = List.length tps in + let _var_params, var_indices = List.splitAt num_params vars in + let _i_params, indices = List.splitAt num_params indices in + List.map2 (fun v a -> mkEq(mkFreeV v, a)) var_indices indices + ) + in mkOr(out, mkAnd(mk_data_tester env l xx, eqs |> mk_and_l)), decls@decls') (mkFalse, []) in let ffsym, ff = fresh_fvar env.current_module_name "f" Fuel_sort in let fuel_guarded_inversion = From fb34777cecf5ade03ab0d3209adb1a18000b7760 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Mon, 15 Apr 2024 17:02:10 -0700 Subject: [PATCH 04/42] restrict the universe of type-function parameters when enabling injectivity --- .../generated/FStar_SMTEncoding_Encode.ml | 53 ++++++++++++-- src/smtencoding/FStar.SMTEncoding.Encode.fst | 18 ++--- tests/bug-reports/BugBoxInjectivity.fst | 72 +++++++++++++++++++ 3 files changed, 130 insertions(+), 13 deletions(-) create mode 100644 tests/bug-reports/BugBoxInjectivity.fst diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index c69be924340..b46d457c17f 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -4672,11 +4672,56 @@ and (encode_sigelt' : uu___18.FStar_Syntax_Syntax.n in (match uu___17 with | FStar_Syntax_Syntax.Tm_type - uu___18 -> true + u -> u_leq_u_k u | FStar_Syntax_Syntax.Tm_name - uu___18 -> true - | uu___18 -> false) - else false)) in + uu___18 -> + ((let uu___20 = + FStar_Syntax_Print.binder_to_string + tp in + let uu___21 = + FStar_Syntax_Print.term_to_string + t_tp1 in + FStar_Compiler_Util.print2 + "Retaining injectivity for name parameter %s : %s\n" + uu___20 uu___21); + true) + | uu___18 -> + ((let uu___20 = + FStar_Ident.string_of_lid + t_lid in + let uu___21 = + FStar_Syntax_Print.binder_to_string + tp in + let uu___22 = + FStar_Syntax_Print.term_to_string + t_tp1 in + let uu___23 = + let uu___24 = + FStar_TypeChecker_Normalize.normalize_universe + env_tps + u_tp in + FStar_Syntax_Print.univ_to_string + uu___24 in + let uu___24 = + FStar_Syntax_Print.univ_to_string + u_k in + FStar_Compiler_Util.print5 + "No injectivity for %s because of parameter %s : %s @ universe %s (* this parameter is an "arity", i.e., a type function *) - true + | Tm_type u -> + (* retain injectivity for parameters that are type functions + from small universes (i.e., all formals are smaller than the constructed type) + to a universe <= the universe of the constructed type. + See BugBoxInjectivity.fst *) + u_leq_u_k u | Tm_name _ -> (* this is a value of another type parameter in scope *) true | _ -> - // BU.print5 "No injectivity for %s because of parameter %s : %s @ universe %s Type u#1) : Type u#1 = + | Mk : test a + +let const (f:Type u#1) : Type u#0 -> Type u#1 = fun _ -> f +let itest (f:Type u#1) : Type u#1 = test (const f) +let itest_inhabited (f:Type u#1) : itest f = Mk +let const_inversion (f0 f1:Type u#1) +: Lemma + (requires const f0 == const f1) + (ensures f0 == f1) += let _f0 = const f0 int in + let _f1 = const f1 int in + assert (_f0 == _f1); + () +let itest_injective (f0 f1:Type u#1) +: Lemma + (ensures itest f0 == itest f1 ==> const f0 == const f1) += let x : test (const f0) = itest_inhabited f0 in + let Mk #_ = x in + () +open FStar.Functions +let itest_injective' : squash (is_inj itest) = + introduce forall f0 f1. + itest f0 == itest f1 ==> f0 == f1 + with introduce _ ==> _ + with _ . ( + itest_injective f0 f1; + const_inversion f0 f1 + ) +[@@expect_failure [189]] //itest is not in the right universe to use this lemma +let fals : squash False = + CC.no_inj_universes itest + + +#push-options "--ext 'compat:injectivity'" +noeq +type test2 (a:Type u#0 -> Type u#2) : Type u#1 = + | Mk2 : test2 a +#pop-options +let const2 (f:Type u#2) : Type u#0 -> Type u#2 = fun _ -> f +let itest2 (f:Type u#2) : Type u#1 = test2 (const2 f) +let itest2_inhabited (f:Type u#2) : itest2 f = Mk2 +let const2_inversion (f0 f1:Type u#2) +: Lemma + (requires const2 f0 == const2 f1) + (ensures f0 == f1) += let _f0 = const2 f0 (FStar.Universe.raise_t int) in + let _f1 = const2 f1 (FStar.Universe.raise_t int) in + assert (_f0 == _f1); + () +let itest2_injective (f0 f1:Type u#2) +: Lemma + (ensures itest2 f0 == itest2 f1 ==> const2 f0 == const2 f1) += let x : test2 (const2 f0) = itest2_inhabited f0 in + let Mk2 #_ = x in + () +open FStar.Functions +let itest2_injective' : squash (is_inj itest2) = + introduce forall f0 f1. + itest2 f0 == itest2 f1 ==> f0 == f1 + with introduce _ ==> _ + with _ . ( + itest2_injective f0 f1; + const2_inversion f0 f1 + ) +let fals () : squash False = + CC.no_inj_universes itest2 \ No newline at end of file From 773cdc39cfda1eef546179989f41c2ffc1b439f0 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Mon, 15 Apr 2024 17:02:42 -0700 Subject: [PATCH 05/42] snap --- .../generated/FStar_SMTEncoding_Encode.ml | 51 ++----------------- 1 file changed, 3 insertions(+), 48 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index b46d457c17f..36f8ff0e76f 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -4674,54 +4674,9 @@ and (encode_sigelt' : | FStar_Syntax_Syntax.Tm_type u -> u_leq_u_k u | FStar_Syntax_Syntax.Tm_name - uu___18 -> - ((let uu___20 = - FStar_Syntax_Print.binder_to_string - tp in - let uu___21 = - FStar_Syntax_Print.term_to_string - t_tp1 in - FStar_Compiler_Util.print2 - "Retaining injectivity for name parameter %s : %s\n" - uu___20 uu___21); - true) - | uu___18 -> - ((let uu___20 = - FStar_Ident.string_of_lid - t_lid in - let uu___21 = - FStar_Syntax_Print.binder_to_string - tp in - let uu___22 = - FStar_Syntax_Print.term_to_string - t_tp1 in - let uu___23 = - let uu___24 = - FStar_TypeChecker_Normalize.normalize_universe - env_tps - u_tp in - FStar_Syntax_Print.univ_to_string - uu___24 in - let uu___24 = - FStar_Syntax_Print.univ_to_string - u_k in - FStar_Compiler_Util.print5 - "No injectivity for %s because of parameter %s : %s @ universe %s true + | uu___18 -> false) + else false)) in FStar_Compiler_List.forall2 tp_ok tps3 us)))) in ((let uu___4 = From df6fb0d52e52289db625cbdbc7c34d975801d819 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Mon, 15 Apr 2024 17:47:42 -0700 Subject: [PATCH 06/42] need to explicitly destruct Refl --- ulib/legacy/FStar.Constructive.fst | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/ulib/legacy/FStar.Constructive.fst b/ulib/legacy/FStar.Constructive.fst index 7a50cb8ba8d..55dc7bbd980 100644 --- a/ulib/legacy/FStar.Constructive.fst +++ b/ulib/legacy/FStar.Constructive.fst @@ -47,13 +47,15 @@ let ceq_eq #a #x #y h = let Refl = h in () val ceq_congruence : #a:Type -> #b:Type -> #x:a -> #y:a -> ceq x y -> f:(a -> GTot b) -> GTot (ceq (f x) (f y)) -let ceq_congruence #a #b #x #y h f = Refl #_ #(f x) //refuse to infer terms with non-Tot effect +let ceq_congruence #a #b #x #y h f = + let Refl = h in + Refl #_ #(f x) //refuse to infer terms with non-Tot effect val ceq_symm : #a:Type -> #x:a -> #y:a -> ceq x y -> Tot (ceq y x) -let ceq_symm #a #x #y h = Refl +let ceq_symm #a #x #y h = let Refl = h in Refl val ceq_trans : #a:Type -> #x:a -> #y:a -> #z:a -> ceq x y -> ceq y z -> Tot (ceq x z) -let ceq_trans #a #x #y #z hxy hyz = Refl +let ceq_trans #a #x #y #z hxy hyz = let Refl = hxy in let Refl = hyz in Refl type ctrue = | I : ctrue From 13cb2d3c3c51fbfc1a17880576a41039f55f79ea Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Mon, 15 Apr 2024 18:05:48 -0700 Subject: [PATCH 07/42] another explicit Refl destruction --- tests/bug-reports/Bug3186.fst | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/tests/bug-reports/Bug3186.fst b/tests/bug-reports/Bug3186.fst index 4ce06ae1a4d..544473db34a 100644 --- a/tests/bug-reports/Bug3186.fst +++ b/tests/bug-reports/Bug3186.fst @@ -3,7 +3,14 @@ module Bug3186 let base (x:int) (_: unit {equals x 0}) = assert (x == 0) -let base2 (x:int) (_: equals x 0) = +let base2 (x:int) (hyp: equals x 0) = + let Refl = hyp in + assert (x == 0) + + //fails since the inversion on equals is not strong enough + //to be usable directly, since df6fb0d52e52289db625cbdbc7c34d975801d819 +[@@expect_failure [19]] +let base2' (x:int) (hyp: equals x 0) = assert (x == 0) [@@expect_failure [19]] From 3a4b5186e5cb4f0d125ed6f627bc3d9c2d52a003 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Mon, 15 Apr 2024 21:01:02 -0700 Subject: [PATCH 08/42] snap --- .../fstar-lib/generated/FStar_InteractiveHelpers_Effectful.ml | 2 +- .../generated/FStar_InteractiveHelpers_ExploreTerm.ml | 2 +- ocaml/fstar-lib/generated/FStar_Reflection_V2_Formula.ml | 2 +- ocaml/fstar-lib/generated/FStar_Tactics_Typeclasses.ml | 4 ++-- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Effectful.ml b/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Effectful.ml index fc4f80aa92c..8abdb5a53e0 100644 --- a/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Effectful.ml +++ b/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Effectful.ml @@ -1676,7 +1676,7 @@ let (compute_eterm_info : (Obj.repr (FStar_InteractiveHelpers_Base.mfail_doc (FStar_List_Tot_Base.op_At - [FStar_Errors_Msg.text + [FStar_Pprint.arbitrary_string "compute_eterm_info: failure"] msg))) | e1 -> diff --git a/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_ExploreTerm.ml b/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_ExploreTerm.ml index f9e8d468089..f12d76e5caf 100644 --- a/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_ExploreTerm.ml +++ b/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_ExploreTerm.ml @@ -1820,7 +1820,7 @@ let rec (inst_comp : (Obj.repr (FStar_InteractiveHelpers_Base.mfail_doc (FStar_List_Tot_Base.op_At - [FStar_Errors_Msg.text + [FStar_Pprint.arbitrary_string "inst_comp: error"] msg))) | err -> diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Formula.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Formula.ml index 9e81e052229..e166c0ab4f1 100644 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Formula.ml +++ b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Formula.ml @@ -986,7 +986,7 @@ let (term_as_formula' : (Obj.repr (FStar_Tactics_Effect.raise (FStar_Tactics_Common.TacticFailure - (FStar_Errors_Msg.mkmsg "???"))))) uu___) + [FStar_Pprint.arbitrary_string "???"])))) uu___) let _ = FStar_Tactics_Native.register_tactic "FStar.Reflection.V2.Formula.term_as_formula'" (Prims.of_int (2)) diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Typeclasses.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Typeclasses.ml index 3a82a0cda51..25c69d85574 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Typeclasses.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_Typeclasses.ml @@ -1211,7 +1211,7 @@ let (tcresolve : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one - (FStar_Errors_Msg.text + (FStar_Pprint.arbitrary_string "Could not solve constraint") uu___4)))) (fun @@ -1233,7 +1233,7 @@ let (tcresolve : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = ( (op_At ()) [ - FStar_Errors_Msg.text + FStar_Pprint.arbitrary_string "Typeclass resolution failed"] msg))) | e -> From 87e5d17aae83a992dbf739c4fcecfc771fc0e4ea Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Thu, 18 Apr 2024 11:52:50 -0700 Subject: [PATCH 09/42] trying to simplify the handling of Tm_name --- ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml | 2 -- src/smtencoding/FStar.SMTEncoding.Encode.fst | 4 ++-- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index 36f8ff0e76f..c97ddd3f23a 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -4673,8 +4673,6 @@ and (encode_sigelt' : (match uu___17 with | FStar_Syntax_Syntax.Tm_type u -> u_leq_u_k u - | FStar_Syntax_Syntax.Tm_name - uu___18 -> true | uu___18 -> false) else false)) in FStar_Compiler_List.forall2 tp_ok tps3 diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst index e6c25cd519b..f5599cd589e 100644 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ b/src/smtencoding/FStar.SMTEncoding.Encode.fst @@ -1294,8 +1294,8 @@ and encode_sigelt' (env:env_t) (se:sigelt) : (decls_t * env_t) = to a universe <= the universe of the constructed type. See BugBoxInjectivity.fst *) u_leq_u_k u - | Tm_name _ -> (* this is a value of another type parameter in scope *) - true + // | Tm_name _ -> (* this is a value of another type parameter in scope *) + // true | _ -> false ) From 84d1251b7d09fcb234424e46c769fa25ea86deac Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Thu, 18 Apr 2024 13:48:31 -0700 Subject: [PATCH 10/42] simplify a counterexample; add it to the test suite --- tests/bug-reports/BugBoxInjectivity.fst | 36 +++++++++---------------- tests/bug-reports/Makefile | 3 ++- 2 files changed, 15 insertions(+), 24 deletions(-) diff --git a/tests/bug-reports/BugBoxInjectivity.fst b/tests/bug-reports/BugBoxInjectivity.fst index f46c8bd2a4e..67a21c24591 100644 --- a/tests/bug-reports/BugBoxInjectivity.fst +++ b/tests/bug-reports/BugBoxInjectivity.fst @@ -1,6 +1,6 @@ module BugBoxInjectivity -// #restart-solver -// #push-options "--log_queries --query_stats --debug BugBoxInjectivity --debug_level SMTEncoding" +#restart-solver +#push-options "--log_queries --query_stats --debug BugBoxInjectivity --debug_level SMTEncoding" module CC = FStar.Cardinality.Universes noeq type test (a:Type u#0 -> Type u#1) : Type u#1 = @@ -34,39 +34,29 @@ let itest_injective' : squash (is_inj itest) = ) [@@expect_failure [189]] //itest is not in the right universe to use this lemma let fals : squash False = - CC.no_inj_universes itest + CC.no_inj_universes_suc itest #push-options "--ext 'compat:injectivity'" noeq -type test2 (a:Type u#0 -> Type u#2) : Type u#1 = +type test2 (a:Type u#2) : Type u#1 = | Mk2 : test2 a #pop-options -let const2 (f:Type u#2) : Type u#0 -> Type u#2 = fun _ -> f -let itest2 (f:Type u#2) : Type u#1 = test2 (const2 f) -let itest2_inhabited (f:Type u#2) : itest2 f = Mk2 -let const2_inversion (f0 f1:Type u#2) -: Lemma - (requires const2 f0 == const2 f1) - (ensures f0 == f1) -= let _f0 = const2 f0 (FStar.Universe.raise_t int) in - let _f1 = const2 f1 (FStar.Universe.raise_t int) in - assert (_f0 == _f1); - () -let itest2_injective (f0 f1:Type u#2) + +let test2_inhabited (f:Type u#2) : test2 f = Mk2 +let test2_injective (f0 f1:Type u#2) : Lemma - (ensures itest2 f0 == itest2 f1 ==> const2 f0 == const2 f1) -= let x : test2 (const2 f0) = itest2_inhabited f0 in + (ensures test2 f0 == test2 f1 ==> f0 == f1) += let x : test2 f0 = test2_inhabited f0 in let Mk2 #_ = x in () open FStar.Functions -let itest2_injective' : squash (is_inj itest2) = +let itest2_injective' : squash (is_inj test2) = introduce forall f0 f1. - itest2 f0 == itest2 f1 ==> f0 == f1 + test2 f0 == test2 f1 ==> f0 == f1 with introduce _ ==> _ with _ . ( - itest2_injective f0 f1; - const2_inversion f0 f1 + test2_injective f0 f1 ) let fals () : squash False = - CC.no_inj_universes itest2 \ No newline at end of file + CC.no_inj_universes_suc test2 \ No newline at end of file diff --git a/tests/bug-reports/Makefile b/tests/bug-reports/Makefile index 02fdf17ac2f..db27584366d 100644 --- a/tests/bug-reports/Makefile +++ b/tests/bug-reports/Makefile @@ -56,7 +56,8 @@ SHOULD_VERIFY_CLOSED=Bug022.fst Bug024.fst Bug025.fst Bug026.fst Bug026b.fst Bug Bug2415.fst Bug3028.fst Bug2954.fst Bug3089.fst Bug3102.fst Bug2981.fst Bug2980.fst Bug3115.fst \ Bug2083.fst Bug2002.fst Bug1482.fst Bug1066.fst Bug3120a.fst Bug3120b.fst Bug3186.fst Bug3185.fst Bug3210.fst \ Bug3213.fst Bug3213b.fst Bug3207.fst Bug3207b.fst Bug3207c.fst Bug2155.fst Bug3224a.fst Bug3224b.fst Bug3236.fst - + BugBoxInjectivity.fst + SHOULD_VERIFY_INTERFACE_CLOSED=Bug771.fsti Bug771b.fsti SHOULD_VERIFY_AND_WARN_CLOSED=Bug016.fst From 5c011d5c5fef1fee29f5fbcd85152f24801dddeb Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Fri, 19 Apr 2024 10:28:49 -0700 Subject: [PATCH 11/42] current check is not strict enough; can still break it using injectivity of _data_ constructor on the type parameter --- tests/bug-reports/BugBoxInjectivity.fst | 160 +++++++++++++++--------- 1 file changed, 101 insertions(+), 59 deletions(-) diff --git a/tests/bug-reports/BugBoxInjectivity.fst b/tests/bug-reports/BugBoxInjectivity.fst index 67a21c24591..740d264677a 100644 --- a/tests/bug-reports/BugBoxInjectivity.fst +++ b/tests/bug-reports/BugBoxInjectivity.fst @@ -1,62 +1,104 @@ module BugBoxInjectivity -#restart-solver -#push-options "--log_queries --query_stats --debug BugBoxInjectivity --debug_level SMTEncoding" -module CC = FStar.Cardinality.Universes -noeq -type test (a:Type u#0 -> Type u#1) : Type u#1 = - | Mk : test a - -let const (f:Type u#1) : Type u#0 -> Type u#1 = fun _ -> f -let itest (f:Type u#1) : Type u#1 = test (const f) -let itest_inhabited (f:Type u#1) : itest f = Mk -let const_inversion (f0 f1:Type u#1) -: Lemma - (requires const f0 == const f1) - (ensures f0 == f1) -= let _f0 = const f0 int in - let _f1 = const f1 int in - assert (_f0 == _f1); - () -let itest_injective (f0 f1:Type u#1) -: Lemma - (ensures itest f0 == itest f1 ==> const f0 == const f1) -= let x : test (const f0) = itest_inhabited f0 in - let Mk #_ = x in - () open FStar.Functions -let itest_injective' : squash (is_inj itest) = - introduce forall f0 f1. - itest f0 == itest f1 ==> f0 == f1 - with introduce _ ==> _ - with _ . ( - itest_injective f0 f1; - const_inversion f0 f1 - ) -[@@expect_failure [189]] //itest is not in the right universe to use this lemma -let fals : squash False = - CC.no_inj_universes_suc itest - - -#push-options "--ext 'compat:injectivity'" -noeq -type test2 (a:Type u#2) : Type u#1 = - | Mk2 : test2 a -#pop-options - -let test2_inhabited (f:Type u#2) : test2 f = Mk2 -let test2_injective (f0 f1:Type u#2) +module CC = FStar.Cardinality.Universes + +type t (a:Type u#1) : Type u#0 = + | Mk : t a + +//We can get the problematic axiom by +//relying on an equation introduced by the pattern +//match and give it to SMT +let inj_t (#a:Type u#1) (x:t a) +: Lemma (x == Mk #a) + [SMTPat (has_type x (t a))] += let Mk #_ = x in () + +#push-options "--log_queries" +#restart-solver +let t_injective_alt (f0 f1:Type u#1) (x: t f0) (y:t f1) : Lemma - (ensures test2 f0 == test2 f1 ==> f0 == f1) -= let x : test2 f0 = test2_inhabited f0 in - let Mk2 #_ = x in - () -open FStar.Functions -let itest2_injective' : squash (is_inj test2) = - introduce forall f0 f1. - test2 f0 == test2 f1 ==> f0 == f1 - with introduce _ ==> _ - with _ . ( - test2_injective f0 f1 - ) -let fals () : squash False = - CC.no_inj_universes_suc test2 \ No newline at end of file + (ensures t f0 == t f1 ==> f0 == f1) += () + +// let t_injective (f0 f1:Type u#1) +// : Lemma +// (ensures t f0 == t f1 ==> f0 == f1) +// = t_injective_alt f0 f1 Mk Mk + +// let t_injective' : squash (is_inj t) = +// introduce forall f0 f1. +// t f0 == t f1 ==> f0 == f1 +// with introduce _ ==> _ +// with _ . ( +// t_injective f0 f1 +// ) +// let fals : squash False = +// CC.no_inj_universes_suc t + +// /////////////////// +// let test (#a:Type) (x:t a) = +// match x with +// | Mkt #_ f -> +// assert (x == Mkt #a f) + +// #restart-solver +// #push-options "--log_queries --query_stats --debug BugBoxInjectivity --debug_level SMTEncoding" +// module CC = FStar.Cardinality.Universes +// noeq +// type test (a:Type u#0 -> Type u#1) : Type u#1 = +// | Mk : test a + +// let const (f:Type u#1) : Type u#0 -> Type u#1 = fun _ -> f +// let itest (f:Type u#1) : Type u#1 = test (const f) +// let itest_inhabited (f:Type u#1) : itest f = Mk +// let const_inversion (f0 f1:Type u#1) +// : Lemma +// (requires const f0 == const f1) +// (ensures f0 == f1) +// = let _f0 = const f0 int in +// let _f1 = const f1 int in +// assert (_f0 == _f1); +// () +// let itest_injective (f0 f1:Type u#1) +// : Lemma +// (ensures itest f0 == itest f1 ==> const f0 == const f1) +// = let x : test (const f0) = itest_inhabited f0 in +// let Mk #_ = x in +// () +// open FStar.Functions +// let itest_injective' : squash (is_inj itest) = +// introduce forall f0 f1. +// itest f0 == itest f1 ==> f0 == f1 +// with introduce _ ==> _ +// with _ . ( +// itest_injective f0 f1; +// const_inversion f0 f1 +// ) +// [@@expect_failure [189]] //itest is not in the right universe to use this lemma +// let fals : squash False = +// CC.no_inj_universes_suc itest + + +// #push-options "--ext 'compat:injectivity'" +// noeq +// type test2 (a:Type u#2) : Type u#1 = +// | Mk2 : test2 a +// #pop-options + +// let test2_inhabited (f:Type u#2) : test2 f = Mk2 +// let test2_injective (f0 f1:Type u#2) +// : Lemma +// (ensures test2 f0 == test2 f1 ==> f0 == f1) +// = let x : test2 f0 = test2_inhabited f0 in +// let Mk2 #_ = x in +// () +// open FStar.Functions +// let itest2_injective' : squash (is_inj test2) = +// introduce forall f0 f1. +// test2 f0 == test2 f1 ==> f0 == f1 +// with introduce _ ==> _ +// with _ . ( +// test2_injective f0 f1 +// ) +// let fals () : squash False = +// CC.no_inj_universes_suc test2 \ No newline at end of file From 35380d320ca9719564145e5e1f9d3269e26d372f Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Fri, 19 Apr 2024 10:29:18 -0700 Subject: [PATCH 12/42] refactoring encoding of inductive type and datacon to prepare for a revised check --- .../generated/FStar_SMTEncoding_Encode.ml | 3829 +++++++++-------- src/smtencoding/FStar.SMTEncoding.Encode.fst | 1136 ++--- 2 files changed, 2542 insertions(+), 2423 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index dbfe7f06e7b..5fa3195d52e 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -3761,1275 +3761,567 @@ let (encode_top_level_let : (Prims.strcat "let rec unencodeable: Skipping: " msg) in let uu___2 = FStar_SMTEncoding_Term.mk_decls_trivial [decl] in (uu___2, env)) -let rec (encode_sigelt : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.sigelt -> - (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.env_t)) - = +let (is_sig_inductive_injective_on_params : + FStar_SMTEncoding_Env.env_t -> FStar_Syntax_Syntax.sigelt -> Prims.bool) = fun env -> fun se -> - let nm = FStar_Syntax_Print.sigelt_to_string_short se in - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Print.sigelt_to_string_short se in - FStar_Compiler_Util.format1 - "While encoding top-level declaration `%s`" uu___2 in - FStar_Errors.with_ctx uu___1 (fun uu___2 -> encode_sigelt' env se) in + let uu___ = se.FStar_Syntax_Syntax.sigel in match uu___ with - | (g, env1) -> - let g1 = - match g with - | [] -> - ((let uu___2 = - FStar_TypeChecker_Env.debug - env1.FStar_SMTEncoding_Env.tcenv - (FStar_Options.Other "SMTEncoding") in - if uu___2 - then - FStar_Compiler_Util.print1 "Skipped encoding of %s\n" nm - else ()); - (let uu___2 = - let uu___3 = - let uu___4 = - FStar_Compiler_Util.format1 "" nm in - FStar_SMTEncoding_Term.Caption uu___4 in - [uu___3] in - FStar_SMTEncoding_Term.mk_decls_trivial uu___2)) - | uu___1 -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_Util.format1 "" nm in - FStar_SMTEncoding_Term.Caption uu___5 in - [uu___4] in - FStar_SMTEncoding_Term.mk_decls_trivial uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Compiler_Util.format1 "" nm in - FStar_SMTEncoding_Term.Caption uu___7 in - [uu___6] in - FStar_SMTEncoding_Term.mk_decls_trivial uu___5 in - FStar_Compiler_List.op_At g uu___4 in - FStar_Compiler_List.op_At uu___2 uu___3 in - (g1, env1) -and (encode_sigelt' : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.sigelt -> - (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.env_t)) + | FStar_Syntax_Syntax.Sig_inductive_typ + { FStar_Syntax_Syntax.lid = t; + FStar_Syntax_Syntax.us = universe_names; + FStar_Syntax_Syntax.params = tps; + FStar_Syntax_Syntax.num_uniform_params = uu___1; + FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = uu___2; + FStar_Syntax_Syntax.ds = uu___3;_} + -> + let t_lid = t in + let tcenv = env.FStar_SMTEncoding_Env.tcenv in + let uu___4 = FStar_Syntax_Subst.univ_var_opening universe_names in + (match uu___4 with + | (usubst, uvs) -> + let uu___5 = + let uu___6 = FStar_TypeChecker_Env.push_univ_vars tcenv uvs in + let uu___7 = FStar_Syntax_Subst.subst_binders usubst tps in + let uu___8 = + let uu___9 = + FStar_Syntax_Subst.shift_subst + (FStar_Compiler_List.length tps) usubst in + FStar_Syntax_Subst.subst uu___9 k in + (uu___6, uu___7, uu___8) in + (match uu___5 with + | (tcenv1, tps1, k1) -> + let uu___6 = FStar_Syntax_Subst.open_term tps1 k1 in + (match uu___6 with + | (tps2, k2) -> + let uu___7 = FStar_Syntax_Util.arrow_formals k2 in + (match uu___7 with + | (uu___8, k3) -> + let uu___9 = + FStar_TypeChecker_TcTerm.tc_binders tcenv1 + tps2 in + (match uu___9 with + | (tps3, env_tps, uu___10, us) -> + let u_k = + let uu___11 = + let uu___12 = + FStar_Syntax_Syntax.fvar t + FStar_Pervasives_Native.None in + let uu___13 = + let uu___14 = + FStar_Syntax_Util.args_of_binders + tps3 in + FStar_Pervasives_Native.snd uu___14 in + let uu___14 = + FStar_Ident.range_of_lid t in + FStar_Syntax_Syntax.mk_Tm_app uu___12 + uu___13 uu___14 in + FStar_TypeChecker_TcTerm.level_of_type + env_tps uu___11 k3 in + let rec universe_leq u v = + match (u, v) with + | (FStar_Syntax_Syntax.U_zero, uu___11) + -> true + | (FStar_Syntax_Syntax.U_succ u0, + FStar_Syntax_Syntax.U_succ v0) -> + universe_leq u0 v0 + | (FStar_Syntax_Syntax.U_name u0, + FStar_Syntax_Syntax.U_name v0) -> + FStar_Ident.ident_equals u0 v0 + | (FStar_Syntax_Syntax.U_name uu___11, + FStar_Syntax_Syntax.U_succ v0) -> + universe_leq u v0 + | (FStar_Syntax_Syntax.U_max us1, + uu___11) -> + FStar_Compiler_Util.for_all + (fun u1 -> universe_leq u1 v) us1 + | (uu___11, FStar_Syntax_Syntax.U_max + vs) -> + FStar_Compiler_Util.for_some + (universe_leq u) vs + | (FStar_Syntax_Syntax.U_unknown, + uu___11) -> + let uu___12 = + let uu___13 = + FStar_Ident.string_of_lid t in + let uu___14 = + FStar_Syntax_Print.univ_to_string + u in + let uu___15 = + FStar_Syntax_Print.univ_to_string + v in + FStar_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___13 uu___14 uu___15 in + FStar_Compiler_Effect.failwith + uu___12 + | (uu___11, + FStar_Syntax_Syntax.U_unknown) -> + let uu___12 = + let uu___13 = + FStar_Ident.string_of_lid t in + let uu___14 = + FStar_Syntax_Print.univ_to_string + u in + let uu___15 = + FStar_Syntax_Print.univ_to_string + v in + FStar_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___13 uu___14 uu___15 in + FStar_Compiler_Effect.failwith + uu___12 + | (FStar_Syntax_Syntax.U_unif uu___11, + uu___12) -> + let uu___13 = + let uu___14 = + FStar_Ident.string_of_lid t in + let uu___15 = + FStar_Syntax_Print.univ_to_string + u in + let uu___16 = + FStar_Syntax_Print.univ_to_string + v in + FStar_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___14 uu___15 uu___16 in + FStar_Compiler_Effect.failwith + uu___13 + | (uu___11, FStar_Syntax_Syntax.U_unif + uu___12) -> + let uu___13 = + let uu___14 = + FStar_Ident.string_of_lid t in + let uu___15 = + FStar_Syntax_Print.univ_to_string + u in + let uu___16 = + FStar_Syntax_Print.univ_to_string + v in + FStar_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___14 uu___15 uu___16 in + FStar_Compiler_Effect.failwith + uu___13 + | uu___11 -> false in + let u_leq_u_k u = + let u1 = + FStar_TypeChecker_Normalize.normalize_universe + env_tps u in + universe_leq u1 u_k in + let tp_ok tp u_tp = + let t_tp = + (tp.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in + let uu___11 = u_leq_u_k u_tp in + if uu___11 + then true + else + (let t_tp1 = + FStar_TypeChecker_Normalize.normalize + [FStar_TypeChecker_Env.Unrefine; + FStar_TypeChecker_Env.Unascribe; + FStar_TypeChecker_Env.Unmeta; + FStar_TypeChecker_Env.Primops; + FStar_TypeChecker_Env.HNF; + FStar_TypeChecker_Env.UnfoldUntil + FStar_Syntax_Syntax.delta_constant; + FStar_TypeChecker_Env.Beta] + env_tps t_tp in + let uu___13 = + FStar_Syntax_Util.arrow_formals + t_tp1 in + match uu___13 with + | (formals, t1) -> + let uu___14 = + FStar_TypeChecker_TcTerm.tc_binders + env_tps formals in + (match uu___14 with + | (uu___15, uu___16, uu___17, + u_formals) -> + let inj = + FStar_Compiler_Util.for_all + (fun u_formal -> + u_leq_u_k u_formal) + u_formals in + if inj + then + let uu___18 = + let uu___19 = + FStar_Syntax_Subst.compress + t1 in + uu___19.FStar_Syntax_Syntax.n in + (match uu___18 with + | FStar_Syntax_Syntax.Tm_type + u -> u_leq_u_k u + | uu___19 -> false) + else false)) in + let is_injective_on_params = + FStar_Compiler_List.forall2 tp_ok tps3 + us in + ((let uu___12 = + FStar_TypeChecker_Env.debug + env.FStar_SMTEncoding_Env.tcenv + (FStar_Options.Other "SMTEncoding") in + if uu___12 + then + let uu___13 = + FStar_Ident.string_of_lid t in + FStar_Compiler_Util.print2 + "%s injectivity for %s\n" + (if is_injective_on_params + then "YES" + else "NO") uu___13 + else ()); + is_injective_on_params)))))) +let (encode_sig_inductive : + Prims.bool -> + FStar_SMTEncoding_Env.env_t -> + FStar_Syntax_Syntax.sigelt -> + (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.env_t)) = - fun env -> - fun se -> - (let uu___1 = - FStar_TypeChecker_Env.debug env.FStar_SMTEncoding_Env.tcenv - (FStar_Options.Other "SMTEncoding") in - if uu___1 - then - let uu___2 = FStar_Syntax_Print.sigelt_to_string se in - FStar_Compiler_Util.print1 "@@@Encoding sigelt %s\n" uu___2 - else ()); - (let is_opaque_to_smt t = - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_string - (s, uu___2)) -> s = "opaque_to_smt" - | uu___2 -> false in - let is_uninterpreted_by_smt t = - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_string - (s, uu___2)) -> s = "uninterpreted_by_smt" - | uu___2 -> false in - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_splice uu___1 -> - FStar_Compiler_Effect.failwith - "impossible -- splice should have been removed by Tc.fs" - | FStar_Syntax_Syntax.Sig_fail uu___1 -> - FStar_Compiler_Effect.failwith - "impossible -- Sig_fail should have been removed by Tc.fs" - | FStar_Syntax_Syntax.Sig_pragma uu___1 -> ([], env) - | FStar_Syntax_Syntax.Sig_effect_abbrev uu___1 -> ([], env) - | FStar_Syntax_Syntax.Sig_sub_effect uu___1 -> ([], env) - | FStar_Syntax_Syntax.Sig_polymonadic_bind uu___1 -> ([], env) - | FStar_Syntax_Syntax.Sig_polymonadic_subcomp uu___1 -> ([], env) - | FStar_Syntax_Syntax.Sig_new_effect ed -> - let uu___1 = - let uu___2 = - FStar_SMTEncoding_Util.is_smt_reifiable_effect - env.FStar_SMTEncoding_Env.tcenv ed.FStar_Syntax_Syntax.mname in - Prims.op_Negation uu___2 in - if uu___1 - then ([], env) - else - (let close_effect_params tm = - match ed.FStar_Syntax_Syntax.binders with - | [] -> tm - | uu___3 -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = - (ed.FStar_Syntax_Syntax.binders); - FStar_Syntax_Syntax.body = tm; - FStar_Syntax_Syntax.rc_opt = - (FStar_Pervasives_Native.Some - (FStar_Syntax_Util.mk_residual_comp - FStar_Parser_Const.effect_Tot_lid - FStar_Pervasives_Native.None - [FStar_Syntax_Syntax.TOTAL])) - }) tm.FStar_Syntax_Syntax.pos in - let encode_action env1 a = - let action_defn = - let uu___3 = - close_effect_params a.FStar_Syntax_Syntax.action_defn in - norm_before_encoding env1 uu___3 in + fun is_injective_on_params -> + fun env -> + fun se -> + let uu___ = se.FStar_Syntax_Syntax.sigel in + match uu___ with + | FStar_Syntax_Syntax.Sig_inductive_typ + { FStar_Syntax_Syntax.lid = t; + FStar_Syntax_Syntax.us = universe_names; + FStar_Syntax_Syntax.params = tps; + FStar_Syntax_Syntax.num_uniform_params = uu___1; + FStar_Syntax_Syntax.t = k; + FStar_Syntax_Syntax.mutuals = uu___2; + FStar_Syntax_Syntax.ds = datas;_} + -> + let t_lid = t in + let tcenv = env.FStar_SMTEncoding_Env.tcenv in + let quals = se.FStar_Syntax_Syntax.sigquals in + let is_logical = + FStar_Compiler_Util.for_some + (fun uu___3 -> + match uu___3 with + | FStar_Syntax_Syntax.Logic -> true + | FStar_Syntax_Syntax.Assumption -> true + | uu___4 -> false) quals in + let constructor_or_logic_type_decl c = + if is_logical + then let uu___3 = - FStar_Syntax_Util.arrow_formals_comp - a.FStar_Syntax_Syntax.action_typ in - match uu___3 with - | (formals, uu___4) -> - let arity = FStar_Compiler_List.length formals in + let uu___4 = let uu___5 = - FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid - env1 a.FStar_Syntax_Syntax.action_name arity in - (match uu___5 with - | (aname, atok, env2) -> - let uu___6 = - FStar_SMTEncoding_EncodeTerm.encode_term - action_defn env2 in - (match uu___6 with - | (tm, decls) -> - let a_decls = - let uu___7 = + FStar_Compiler_List.map + (fun f -> f.FStar_SMTEncoding_Term.field_sort) + c.FStar_SMTEncoding_Term.constr_fields in + ((c.FStar_SMTEncoding_Term.constr_name), uu___5, + FStar_SMTEncoding_Term.Term_sort, + FStar_Pervasives_Native.None) in + FStar_SMTEncoding_Term.DeclFun uu___4 in + [uu___3] + else + (let uu___4 = FStar_Ident.range_of_lid t in + FStar_SMTEncoding_Term.constructor_to_decl uu___4 c) in + let inversion_axioms env1 tapp vars = + let uu___3 = + FStar_Compiler_Util.for_some + (fun l -> + let uu___4 = + FStar_TypeChecker_Env.try_lookup_lid + env1.FStar_SMTEncoding_Env.tcenv l in + FStar_Compiler_Option.isNone uu___4) datas in + if uu___3 + then [] + else + (let uu___5 = + FStar_SMTEncoding_Env.fresh_fvar + env1.FStar_SMTEncoding_Env.current_module_name "x" + FStar_SMTEncoding_Term.Term_sort in + match uu___5 with + | (xxsym, xx) -> + let uu___6 = + FStar_Compiler_List.fold_left + (fun uu___7 -> + fun l -> + match uu___7 with + | (out, decls) -> let uu___8 = - let uu___9 = - FStar_Compiler_List.map - (fun uu___10 -> - FStar_SMTEncoding_Term.Term_sort) - formals in - (aname, uu___9, - FStar_SMTEncoding_Term.Term_sort, - (FStar_Pervasives_Native.Some "Action")) in - FStar_SMTEncoding_Term.DeclFun uu___8 in - [uu___7; - FStar_SMTEncoding_Term.DeclFun - (atok, [], - FStar_SMTEncoding_Term.Term_sort, - (FStar_Pervasives_Native.Some - "Action token"))] in - let uu___7 = - let aux uu___8 uu___9 = - match (uu___8, uu___9) with - | ({ FStar_Syntax_Syntax.binder_bv = bv; - FStar_Syntax_Syntax.binder_qual = - uu___10; - FStar_Syntax_Syntax.binder_positivity - = uu___11; - FStar_Syntax_Syntax.binder_attrs = - uu___12;_}, - (env3, acc_sorts, acc)) -> - let uu___13 = - FStar_SMTEncoding_Env.gen_term_var - env3 bv in - (match uu___13 with - | (xxsym, xx, env4) -> - let uu___14 = - let uu___15 = - FStar_SMTEncoding_Term.mk_fv - (xxsym, - FStar_SMTEncoding_Term.Term_sort) in - uu___15 :: acc_sorts in - (env4, uu___14, (xx :: acc))) in - FStar_Compiler_List.fold_right aux formals - (env2, [], []) in - (match uu___7 with - | (uu___8, xs_sorts, xs) -> - let app = - FStar_SMTEncoding_Util.mkApp (aname, xs) in - let a_eq = - let uu___9 = + FStar_TypeChecker_Env.lookup_datacon + env1.FStar_SMTEncoding_Env.tcenv l in + (match uu___8 with + | (uu___9, data_t) -> let uu___10 = - let uu___11 = - FStar_Ident.range_of_lid - a.FStar_Syntax_Syntax.action_name in - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - FStar_SMTEncoding_EncodeTerm.mk_Apply - tm xs_sorts in - (app, uu___15) in - FStar_SMTEncoding_Util.mkEq - uu___14 in - ([[app]], xs_sorts, uu___13) in - FStar_SMTEncoding_Term.mkForall - uu___11 uu___12 in - (uu___10, - (FStar_Pervasives_Native.Some - "Action equality"), - (Prims.strcat aname "_equality")) in - FStar_SMTEncoding_Util.mkAssume uu___9 in - let tok_correspondence = - let tok_term = - let uu___9 = - FStar_SMTEncoding_Term.mk_fv - (atok, - FStar_SMTEncoding_Term.Term_sort) in - FStar_SMTEncoding_Util.mkFreeV uu___9 in - let tok_app = - FStar_SMTEncoding_EncodeTerm.mk_Apply - tok_term xs_sorts in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Ident.range_of_lid - a.FStar_Syntax_Syntax.action_name in - let uu___12 = - let uu___13 = - FStar_SMTEncoding_Util.mkEq - (tok_app, app) in - ([[tok_app]], xs_sorts, uu___13) in - FStar_SMTEncoding_Term.mkForall - uu___11 uu___12 in - (uu___10, - (FStar_Pervasives_Native.Some - "Action token correspondence"), - (Prims.strcat aname - "_token_correspondence")) in - FStar_SMTEncoding_Util.mkAssume uu___9 in + FStar_Syntax_Util.arrow_formals + data_t in + (match uu___10 with + | (args, res) -> + let indices = + let uu___11 = + FStar_Syntax_Util.head_and_args_full + res in + FStar_Pervasives_Native.snd + uu___11 in + let env2 = + FStar_Compiler_List.fold_left + (fun env3 -> + fun uu___11 -> + match uu___11 with + | { + FStar_Syntax_Syntax.binder_bv + = x; + FStar_Syntax_Syntax.binder_qual + = uu___12; + FStar_Syntax_Syntax.binder_positivity + = uu___13; + FStar_Syntax_Syntax.binder_attrs + = uu___14;_} + -> + let uu___15 = + let uu___16 = + let uu___17 = + FStar_SMTEncoding_Env.mk_term_projector_name + l x in + (uu___17, [xx]) in + FStar_SMTEncoding_Util.mkApp + uu___16 in + FStar_SMTEncoding_Env.push_term_var + env3 x uu___15) + env1 args in + let uu___11 = + FStar_SMTEncoding_EncodeTerm.encode_args + indices env2 in + (match uu___11 with + | (indices1, decls') -> + (if + (FStar_Compiler_List.length + indices1) + <> + (FStar_Compiler_List.length + vars) + then + FStar_Compiler_Effect.failwith + "Impossible" + else (); + (let eqs = + let uu___13 = + is_injective_on_params + || + (let uu___14 = + FStar_Options.ext_getv + "compat:injectivity" in + uu___14 <> "") in + if uu___13 + then + FStar_Compiler_List.map2 + (fun v -> + fun a -> + let uu___14 = + let uu___15 = + FStar_SMTEncoding_Util.mkFreeV + v in + (uu___15, a) in + FStar_SMTEncoding_Util.mkEq + uu___14) vars + indices1 + else + (let num_params = + FStar_Compiler_List.length + tps in + let uu___15 = + FStar_Compiler_List.splitAt + num_params vars in + match uu___15 with + | (_var_params, + var_indices) -> + let uu___16 = + FStar_Compiler_List.splitAt + num_params + indices1 in + (match uu___16 + with + | (_i_params, + indices2) -> + FStar_Compiler_List.map2 + (fun v -> + fun a -> + let uu___17 + = + let uu___18 + = + FStar_SMTEncoding_Util.mkFreeV + v in + (uu___18, + a) in + FStar_SMTEncoding_Util.mkEq + uu___17) + var_indices + indices2)) in + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + FStar_SMTEncoding_Env.mk_data_tester + env2 l xx in + let uu___18 = + FStar_SMTEncoding_Util.mk_and_l + eqs in + (uu___17, uu___18) in + FStar_SMTEncoding_Util.mkAnd + uu___16 in + (out, uu___15) in + FStar_SMTEncoding_Util.mkOr + uu___14 in + (uu___13, + (FStar_Compiler_List.op_At + decls decls')))))))) + (FStar_SMTEncoding_Util.mkFalse, []) datas in + (match uu___6 with + | (data_ax, decls) -> + let uu___7 = + FStar_SMTEncoding_Env.fresh_fvar + env1.FStar_SMTEncoding_Env.current_module_name + "f" FStar_SMTEncoding_Term.Fuel_sort in + (match uu___7 with + | (ffsym, ff) -> + let fuel_guarded_inversion = + let xx_has_type_sfuel = + if + (FStar_Compiler_List.length datas) > + Prims.int_one + then + let uu___8 = + FStar_SMTEncoding_Util.mkApp + ("SFuel", [ff]) in + FStar_SMTEncoding_Term.mk_HasTypeFuel + uu___8 xx tapp + else + FStar_SMTEncoding_Term.mk_HasTypeFuel ff + xx tapp in + let uu___8 = let uu___9 = - let uu___10 = - FStar_SMTEncoding_Term.mk_decls_trivial - (FStar_Compiler_List.op_At a_decls - [a_eq; tok_correspondence]) in - FStar_Compiler_List.op_At decls uu___10 in - (env2, uu___9)))) in - let uu___3 = - FStar_Compiler_Util.fold_map encode_action env - ed.FStar_Syntax_Syntax.actions in - match uu___3 with - | (env1, decls2) -> - ((FStar_Compiler_List.flatten decls2), env1)) - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; - FStar_Syntax_Syntax.us2 = uu___1; - FStar_Syntax_Syntax.t2 = uu___2;_} - when FStar_Ident.lid_equals lid FStar_Parser_Const.precedes_lid -> - let uu___3 = - FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid env lid - (Prims.of_int (4)) in - (match uu___3 with | (tname, ttok, env1) -> ([], env1)) - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; - FStar_Syntax_Syntax.us2 = uu___1; FStar_Syntax_Syntax.t2 = t;_} - -> - let quals = se.FStar_Syntax_Syntax.sigquals in - let will_encode_definition = - let uu___2 = - FStar_Compiler_Util.for_some - (fun uu___3 -> - match uu___3 with - | FStar_Syntax_Syntax.Assumption -> true - | FStar_Syntax_Syntax.Projector uu___4 -> true - | FStar_Syntax_Syntax.Discriminator uu___4 -> true - | FStar_Syntax_Syntax.Irreducible -> true - | uu___4 -> false) quals in - Prims.op_Negation uu___2 in - if will_encode_definition - then ([], env) - else - (let fv = - FStar_Syntax_Syntax.lid_as_fv lid - FStar_Pervasives_Native.None in - let uu___3 = - let uu___4 = - FStar_Compiler_Util.for_some is_uninterpreted_by_smt - se.FStar_Syntax_Syntax.sigattrs in - encode_top_level_val uu___4 env fv t quals in - match uu___3 with - | (decls, env1) -> - let tname = FStar_Ident.string_of_lid lid in - let tsym = - let uu___4 = - FStar_SMTEncoding_Env.try_lookup_free_var env1 lid in - FStar_Compiler_Option.get uu___4 in - let uu___4 = + let uu___10 = FStar_Ident.range_of_lid t in + let uu___11 = + let uu___12 = + let uu___13 = + FStar_SMTEncoding_Term.mk_fv + (ffsym, + FStar_SMTEncoding_Term.Fuel_sort) in + let uu___14 = + let uu___15 = + FStar_SMTEncoding_Term.mk_fv + (xxsym, + FStar_SMTEncoding_Term.Term_sort) in + uu___15 :: vars in + FStar_SMTEncoding_Env.add_fuel + uu___13 uu___14 in + let uu___13 = + FStar_SMTEncoding_Util.mkImp + (xx_has_type_sfuel, data_ax) in + ([[xx_has_type_sfuel]], uu___12, + uu___13) in + FStar_SMTEncoding_Term.mkForall uu___10 + uu___11 in + let uu___10 = + let uu___11 = + let uu___12 = + FStar_Ident.string_of_lid t in + Prims.strcat "fuel_guarded_inversion_" + uu___12 in + FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.mk_unique + uu___11 in + (uu___9, + (FStar_Pervasives_Native.Some + "inversion axiom"), uu___10) in + FStar_SMTEncoding_Util.mkAssume uu___8 in + let uu___8 = + FStar_SMTEncoding_Term.mk_decls_trivial + [fuel_guarded_inversion] in + FStar_Compiler_List.op_At decls uu___8))) in + let uu___3 = + let k1 = + match tps with + | [] -> k + | uu___4 -> let uu___5 = let uu___6 = - primitive_type_axioms - env1.FStar_SMTEncoding_Env.tcenv lid tname tsym in - FStar_SMTEncoding_Term.mk_decls_trivial uu___6 in - FStar_Compiler_List.op_At decls uu___5 in - (uu___4, env1)) - | FStar_Syntax_Syntax.Sig_assume - { FStar_Syntax_Syntax.lid3 = l; FStar_Syntax_Syntax.us3 = us; - FStar_Syntax_Syntax.phi1 = f;_} - -> - let uu___1 = FStar_Syntax_Subst.open_univ_vars us f in - (match uu___1 with - | (uvs, f1) -> - let env1 = - let uu___2 = - FStar_TypeChecker_Env.push_univ_vars - env.FStar_SMTEncoding_Env.tcenv uvs in - { - FStar_SMTEncoding_Env.bvar_bindings = - (env.FStar_SMTEncoding_Env.bvar_bindings); - FStar_SMTEncoding_Env.fvar_bindings = - (env.FStar_SMTEncoding_Env.fvar_bindings); - FStar_SMTEncoding_Env.depth = - (env.FStar_SMTEncoding_Env.depth); - FStar_SMTEncoding_Env.tcenv = uu___2; - FStar_SMTEncoding_Env.warn = - (env.FStar_SMTEncoding_Env.warn); - FStar_SMTEncoding_Env.nolabels = - (env.FStar_SMTEncoding_Env.nolabels); - FStar_SMTEncoding_Env.use_zfuel_name = - (env.FStar_SMTEncoding_Env.use_zfuel_name); - FStar_SMTEncoding_Env.encode_non_total_function_typ = - (env.FStar_SMTEncoding_Env.encode_non_total_function_typ); - FStar_SMTEncoding_Env.current_module_name = - (env.FStar_SMTEncoding_Env.current_module_name); - FStar_SMTEncoding_Env.encoding_quantifier = - (env.FStar_SMTEncoding_Env.encoding_quantifier); - FStar_SMTEncoding_Env.global_cache = - (env.FStar_SMTEncoding_Env.global_cache) - } in - let f2 = norm_before_encoding env1 f1 in - let uu___2 = - FStar_SMTEncoding_EncodeTerm.encode_formula f2 env1 in - (match uu___2 with - | (f3, decls) -> - let g = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Print.lid_to_string l in - FStar_Compiler_Util.format1 "Assumption: %s" - uu___8 in - FStar_Pervasives_Native.Some uu___7 in - let uu___7 = - let uu___8 = - let uu___9 = FStar_Ident.string_of_lid l in - Prims.strcat "assumption_" uu___9 in - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.mk_unique - uu___8 in - (f3, uu___6, uu___7) in - FStar_SMTEncoding_Util.mkAssume uu___5 in - [uu___4] in - FStar_SMTEncoding_Term.mk_decls_trivial uu___3 in - ((FStar_Compiler_List.op_At decls g), env1))) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = lbs; - FStar_Syntax_Syntax.lids1 = uu___1;_} - when - (FStar_Compiler_List.contains FStar_Syntax_Syntax.Irreducible - se.FStar_Syntax_Syntax.sigquals) - || - (FStar_Compiler_Util.for_some is_opaque_to_smt - se.FStar_Syntax_Syntax.sigattrs) - -> - let attrs = se.FStar_Syntax_Syntax.sigattrs in - let uu___2 = - FStar_Compiler_Util.fold_map - (fun env1 -> - fun lb -> - let lid = - let uu___3 = - let uu___4 = - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname in - uu___4.FStar_Syntax_Syntax.fv_name in - uu___3.FStar_Syntax_Syntax.v in - let uu___3 = - let uu___4 = - FStar_TypeChecker_Env.try_lookup_val_decl - env1.FStar_SMTEncoding_Env.tcenv lid in - FStar_Compiler_Option.isNone uu___4 in - if uu___3 - then - let val_decl = + let uu___7 = FStar_Syntax_Syntax.mk_Total k in { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_declare_typ - { - FStar_Syntax_Syntax.lid2 = lid; - FStar_Syntax_Syntax.us2 = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.t2 = - (lb.FStar_Syntax_Syntax.lbtyp) - }); - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (FStar_Syntax_Syntax.Irreducible :: - (se.FStar_Syntax_Syntax.sigquals)); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) + FStar_Syntax_Syntax.bs1 = tps; + FStar_Syntax_Syntax.comp = uu___7 } in - let uu___4 = encode_sigelt' env1 val_decl in - match uu___4 with | (decls, env2) -> (env2, decls) - else (env1, [])) env (FStar_Pervasives_Native.snd lbs) in - (match uu___2 with - | (env1, decls) -> ((FStar_Compiler_List.flatten decls), env1)) - | FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = - (uu___1, - { FStar_Syntax_Syntax.lbname = FStar_Pervasives.Inr b2t; - FStar_Syntax_Syntax.lbunivs = uu___2; - FStar_Syntax_Syntax.lbtyp = uu___3; - FStar_Syntax_Syntax.lbeff = uu___4; - FStar_Syntax_Syntax.lbdef = uu___5; - FStar_Syntax_Syntax.lbattrs = uu___6; - FStar_Syntax_Syntax.lbpos = uu___7;_}::[]); - FStar_Syntax_Syntax.lids1 = uu___8;_} - when FStar_Syntax_Syntax.fv_eq_lid b2t FStar_Parser_Const.b2t_lid - -> - let uu___9 = - FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid env - (b2t.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - Prims.int_one in - (match uu___9 with - | (tname, ttok, env1) -> - let xx = - FStar_SMTEncoding_Term.mk_fv - ("x", FStar_SMTEncoding_Term.Term_sort) in - let x = FStar_SMTEncoding_Util.mkFreeV xx in - let b2t_x = FStar_SMTEncoding_Util.mkApp ("Prims.b2t", [x]) in - let valid_b2t_x = - FStar_SMTEncoding_Util.mkApp ("Valid", [b2t_x]) in - let bool_ty = - let uu___10 = - FStar_Syntax_Syntax.withsort FStar_Parser_Const.bool_lid in - FStar_SMTEncoding_Env.lookup_free_var env1 uu___10 in - let decls = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = FStar_Syntax_Syntax.range_of_fv b2t in - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - FStar_SMTEncoding_Util.mkApp - ((FStar_Pervasives_Native.snd - FStar_SMTEncoding_Term.boxBoolFun), - [x]) in - (valid_b2t_x, uu___18) in - FStar_SMTEncoding_Util.mkEq uu___17 in - ([[b2t_x]], [xx], uu___16) in - FStar_SMTEncoding_Term.mkForall uu___14 uu___15 in - (uu___13, (FStar_Pervasives_Native.Some "b2t def"), - "b2t_def") in - FStar_SMTEncoding_Util.mkAssume uu___12 in - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = FStar_Syntax_Syntax.range_of_fv b2t in - let uu___17 = - let uu___18 = - let uu___19 = - let uu___20 = - FStar_SMTEncoding_Term.mk_HasType x - bool_ty in - let uu___21 = - FStar_SMTEncoding_Term.mk_HasType b2t_x - FStar_SMTEncoding_Term.mk_Term_type in - (uu___20, uu___21) in - FStar_SMTEncoding_Util.mkImp uu___19 in - ([[b2t_x]], [xx], uu___18) in - FStar_SMTEncoding_Term.mkForall uu___16 uu___17 in - (uu___15, - (FStar_Pervasives_Native.Some "b2t typing"), - "b2t_typing") in - FStar_SMTEncoding_Util.mkAssume uu___14 in - [uu___13] in - uu___11 :: uu___12 in - (FStar_SMTEncoding_Term.DeclFun - (tname, [FStar_SMTEncoding_Term.Term_sort], - FStar_SMTEncoding_Term.Term_sort, - FStar_Pervasives_Native.None)) - :: uu___10 in - let uu___10 = FStar_SMTEncoding_Term.mk_decls_trivial decls in - (uu___10, env1)) - | FStar_Syntax_Syntax.Sig_let uu___1 when - FStar_Compiler_Util.for_some - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.Discriminator uu___3 -> true - | uu___3 -> false) se.FStar_Syntax_Syntax.sigquals - -> - ((let uu___3 = - FStar_TypeChecker_Env.debug env.FStar_SMTEncoding_Env.tcenv - (FStar_Options.Other "SMTEncoding") in - if uu___3 - then - let uu___4 = FStar_Syntax_Print.sigelt_to_string_short se in - FStar_Compiler_Util.print1 "Not encoding discriminator '%s'\n" - uu___4 - else ()); - ([], env)) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = uu___1; - FStar_Syntax_Syntax.lids1 = lids;_} - when - (FStar_Compiler_Util.for_some - (fun l -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.ns_of_lid l in - FStar_Compiler_List.hd uu___4 in - FStar_Ident.string_of_id uu___3 in - uu___2 = "Prims") lids) - && - (FStar_Compiler_Util.for_some - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.Unfold_for_unification_and_vcgen -> - true - | uu___3 -> false) se.FStar_Syntax_Syntax.sigquals) - -> - ((let uu___3 = - FStar_TypeChecker_Env.debug env.FStar_SMTEncoding_Env.tcenv - (FStar_Options.Other "SMTEncoding") in - if uu___3 - then - let uu___4 = FStar_Syntax_Print.sigelt_to_string_short se in - FStar_Compiler_Util.print1 - "Not encoding unfold let from Prims '%s'\n" uu___4 - else ()); - ([], env)) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (false, lb::[]); - FStar_Syntax_Syntax.lids1 = uu___1;_} - when - FStar_Compiler_Util.for_some - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.Projector uu___3 -> true - | uu___3 -> false) se.FStar_Syntax_Syntax.sigquals - -> - let fv = FStar_Compiler_Util.right lb.FStar_Syntax_Syntax.lbname in - let l = (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let uu___2 = FStar_SMTEncoding_Env.try_lookup_free_var env l in - (match uu___2 with - | FStar_Pervasives_Native.Some uu___3 -> ([], env) - | FStar_Pervasives_Native.None -> - let se1 = - let uu___3 = FStar_Ident.range_of_lid l in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_declare_typ - { - FStar_Syntax_Syntax.lid2 = l; - FStar_Syntax_Syntax.us2 = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.t2 = - (lb.FStar_Syntax_Syntax.lbtyp) - }); - FStar_Syntax_Syntax.sigrng = uu___3; - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - } in - encode_sigelt env se1) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (is_rec, bindings); - FStar_Syntax_Syntax.lids1 = uu___1;_} - -> - let bindings1 = - FStar_Compiler_List.map - (fun lb -> - let def = - norm_before_encoding env lb.FStar_Syntax_Syntax.lbdef in - let typ = - norm_before_encoding env lb.FStar_Syntax_Syntax.lbtyp in - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = typ; - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = def; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - }) bindings in - encode_top_level_let env (is_rec, bindings1) - se.FStar_Syntax_Syntax.sigquals - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses; - FStar_Syntax_Syntax.lids = uu___1;_} - -> - let uu___2 = encode_sigelts env ses in - (match uu___2 with - | (g, env1) -> - let uu___3 = - FStar_Compiler_List.fold_left - (fun uu___4 -> - fun elt -> - match uu___4 with - | (g', inversions) -> - let uu___5 = - FStar_Compiler_List.partition - (fun uu___6 -> - match uu___6 with - | FStar_SMTEncoding_Term.Assume - { - FStar_SMTEncoding_Term.assumption_term - = uu___7; - FStar_SMTEncoding_Term.assumption_caption - = FStar_Pervasives_Native.Some - "inversion axiom"; - FStar_SMTEncoding_Term.assumption_name - = uu___8; - FStar_SMTEncoding_Term.assumption_fact_ids - = uu___9;_} - -> false - | uu___7 -> true) - elt.FStar_SMTEncoding_Term.decls in - (match uu___5 with - | (elt_g', elt_inversions) -> - ((FStar_Compiler_List.op_At g' - [{ - FStar_SMTEncoding_Term.sym_name = - (elt.FStar_SMTEncoding_Term.sym_name); - FStar_SMTEncoding_Term.key = - (elt.FStar_SMTEncoding_Term.key); - FStar_SMTEncoding_Term.decls = - elt_g'; - FStar_SMTEncoding_Term.a_names = - (elt.FStar_SMTEncoding_Term.a_names) - }]), - (FStar_Compiler_List.op_At inversions - elt_inversions)))) ([], []) g in - (match uu___3 with - | (g', inversions) -> - let uu___4 = - FStar_Compiler_List.fold_left - (fun uu___5 -> - fun elt -> - match uu___5 with - | (decls, elts, rest) -> - let uu___6 = - (FStar_Compiler_Util.is_some - elt.FStar_SMTEncoding_Term.key) - && - (FStar_Compiler_List.existsb - (fun uu___7 -> - match uu___7 with - | FStar_SMTEncoding_Term.DeclFun - uu___8 -> true - | uu___8 -> false) - elt.FStar_SMTEncoding_Term.decls) in - if uu___6 - then - (decls, - (FStar_Compiler_List.op_At elts [elt]), - rest) - else - (let uu___8 = - FStar_Compiler_List.partition - (fun uu___9 -> - match uu___9 with - | FStar_SMTEncoding_Term.DeclFun - uu___10 -> true - | uu___10 -> false) - elt.FStar_SMTEncoding_Term.decls in - match uu___8 with - | (elt_decls, elt_rest) -> - ((FStar_Compiler_List.op_At decls - elt_decls), elts, - (FStar_Compiler_List.op_At rest - [{ - FStar_SMTEncoding_Term.sym_name - = - (elt.FStar_SMTEncoding_Term.sym_name); - FStar_SMTEncoding_Term.key = - (elt.FStar_SMTEncoding_Term.key); - FStar_SMTEncoding_Term.decls - = elt_rest; - FStar_SMTEncoding_Term.a_names - = - (elt.FStar_SMTEncoding_Term.a_names) - }])))) ([], [], []) g' in - (match uu___4 with - | (decls, elts, rest) -> - let uu___5 = - let uu___6 = - FStar_SMTEncoding_Term.mk_decls_trivial decls in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_SMTEncoding_Term.mk_decls_trivial - inversions in - FStar_Compiler_List.op_At rest uu___9 in - FStar_Compiler_List.op_At elts uu___8 in - FStar_Compiler_List.op_At uu___6 uu___7 in - (uu___5, env1)))) - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = t; - FStar_Syntax_Syntax.us = universe_names; - FStar_Syntax_Syntax.params = tps; - FStar_Syntax_Syntax.num_uniform_params = uu___1; - FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = uu___2; - FStar_Syntax_Syntax.ds = datas;_} - -> - let t_lid = t in - let tcenv = env.FStar_SMTEncoding_Env.tcenv in - let is_injective_on_params = - let uu___3 = FStar_Syntax_Subst.univ_var_opening universe_names in - match uu___3 with - | (usubst, uvs) -> - let uu___4 = - let uu___5 = - FStar_TypeChecker_Env.push_univ_vars tcenv uvs in - let uu___6 = FStar_Syntax_Subst.subst_binders usubst tps in - let uu___7 = - let uu___8 = - FStar_Syntax_Subst.shift_subst - (FStar_Compiler_List.length tps) usubst in - FStar_Syntax_Subst.subst uu___8 k in - (uu___5, uu___6, uu___7) in - (match uu___4 with - | (env1, tps1, k1) -> - let uu___5 = FStar_Syntax_Subst.open_term tps1 k1 in - (match uu___5 with - | (tps2, k2) -> - let uu___6 = FStar_Syntax_Util.arrow_formals k2 in - (match uu___6 with - | (uu___7, k3) -> - let uu___8 = - FStar_TypeChecker_TcTerm.tc_binders env1 - tps2 in - (match uu___8 with - | (tps3, env_tps, uu___9, us) -> - let u_k = - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.fvar t - FStar_Pervasives_Native.None in - let uu___12 = - let uu___13 = - FStar_Syntax_Util.args_of_binders - tps3 in - FStar_Pervasives_Native.snd - uu___13 in - let uu___13 = - FStar_Ident.range_of_lid t in - FStar_Syntax_Syntax.mk_Tm_app - uu___11 uu___12 uu___13 in - FStar_TypeChecker_TcTerm.level_of_type - env_tps uu___10 k3 in - let rec universe_leq u v = - match (u, v) with - | (FStar_Syntax_Syntax.U_zero, - uu___10) -> true - | (FStar_Syntax_Syntax.U_succ u0, - FStar_Syntax_Syntax.U_succ v0) -> - universe_leq u0 v0 - | (FStar_Syntax_Syntax.U_name u0, - FStar_Syntax_Syntax.U_name v0) -> - FStar_Ident.ident_equals u0 v0 - | (FStar_Syntax_Syntax.U_name uu___10, - FStar_Syntax_Syntax.U_succ v0) -> - universe_leq u v0 - | (FStar_Syntax_Syntax.U_max us1, - uu___10) -> - FStar_Compiler_Util.for_all - (fun u1 -> universe_leq u1 v) - us1 - | (uu___10, FStar_Syntax_Syntax.U_max - vs) -> - FStar_Compiler_Util.for_some - (universe_leq u) vs - | (FStar_Syntax_Syntax.U_unknown, - uu___10) -> - let uu___11 = - let uu___12 = - FStar_Ident.string_of_lid t in - let uu___13 = - FStar_Syntax_Print.univ_to_string - u in - let uu___14 = - FStar_Syntax_Print.univ_to_string - v in - FStar_Compiler_Util.format3 - "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" - uu___12 uu___13 uu___14 in - FStar_Compiler_Effect.failwith - uu___11 - | (uu___10, - FStar_Syntax_Syntax.U_unknown) -> - let uu___11 = - let uu___12 = - FStar_Ident.string_of_lid t in - let uu___13 = - FStar_Syntax_Print.univ_to_string - u in - let uu___14 = - FStar_Syntax_Print.univ_to_string - v in - FStar_Compiler_Util.format3 - "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" - uu___12 uu___13 uu___14 in - FStar_Compiler_Effect.failwith - uu___11 - | (FStar_Syntax_Syntax.U_unif uu___10, - uu___11) -> - let uu___12 = - let uu___13 = - FStar_Ident.string_of_lid t in - let uu___14 = - FStar_Syntax_Print.univ_to_string - u in - let uu___15 = - FStar_Syntax_Print.univ_to_string - v in - FStar_Compiler_Util.format3 - "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" - uu___13 uu___14 uu___15 in - FStar_Compiler_Effect.failwith - uu___12 - | (uu___10, FStar_Syntax_Syntax.U_unif - uu___11) -> - let uu___12 = - let uu___13 = - FStar_Ident.string_of_lid t in - let uu___14 = - FStar_Syntax_Print.univ_to_string - u in - let uu___15 = - FStar_Syntax_Print.univ_to_string - v in - FStar_Compiler_Util.format3 - "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" - uu___13 uu___14 uu___15 in - FStar_Compiler_Effect.failwith - uu___12 - | uu___10 -> false in - let u_leq_u_k u = - let u1 = - FStar_TypeChecker_Normalize.normalize_universe - env_tps u in - universe_leq u1 u_k in - let tp_ok tp u_tp = - let t_tp = - (tp.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let uu___10 = u_leq_u_k u_tp in - if uu___10 - then true - else - (let t_tp1 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Unrefine; - FStar_TypeChecker_Env.Unascribe; - FStar_TypeChecker_Env.Unmeta; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Beta] - env_tps t_tp in - let uu___12 = - FStar_Syntax_Util.arrow_formals - t_tp1 in - match uu___12 with - | (formals, t1) -> - let uu___13 = - FStar_TypeChecker_TcTerm.tc_binders - env_tps formals in - (match uu___13 with - | (uu___14, uu___15, uu___16, - u_formals) -> - let inj = - FStar_Compiler_Util.for_all - (fun u_formal -> - u_leq_u_k u_formal) - u_formals in - if inj - then - let uu___17 = - let uu___18 = - FStar_Syntax_Subst.compress - t1 in - uu___18.FStar_Syntax_Syntax.n in - (match uu___17 with - | FStar_Syntax_Syntax.Tm_type - u -> u_leq_u_k u - | uu___18 -> false) - else false)) in - FStar_Compiler_List.forall2 tp_ok tps3 - us)))) in - ((let uu___4 = - FStar_TypeChecker_Env.debug env.FStar_SMTEncoding_Env.tcenv - (FStar_Options.Other "SMTEncoding") in - if uu___4 - then - let uu___5 = FStar_Ident.string_of_lid t in - FStar_Compiler_Util.print2 "%s injectivity for %s\n" - (if is_injective_on_params then "YES" else "NO") uu___5 - else ()); - (let quals = se.FStar_Syntax_Syntax.sigquals in - let is_logical = - FStar_Compiler_Util.for_some - (fun uu___4 -> - match uu___4 with - | FStar_Syntax_Syntax.Logic -> true - | FStar_Syntax_Syntax.Assumption -> true - | uu___5 -> false) quals in - let constructor_or_logic_type_decl c = - if is_logical - then - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_List.map - (fun f -> f.FStar_SMTEncoding_Term.field_sort) - c.FStar_SMTEncoding_Term.constr_fields in - ((c.FStar_SMTEncoding_Term.constr_name), uu___6, - FStar_SMTEncoding_Term.Term_sort, - FStar_Pervasives_Native.None) in - FStar_SMTEncoding_Term.DeclFun uu___5 in - [uu___4] - else - (let uu___5 = FStar_Ident.range_of_lid t in - FStar_SMTEncoding_Term.constructor_to_decl uu___5 c) in - let inversion_axioms env1 tapp vars = - let uu___4 = - FStar_Compiler_Util.for_some - (fun l -> - let uu___5 = - FStar_TypeChecker_Env.try_lookup_lid - env1.FStar_SMTEncoding_Env.tcenv l in - FStar_Compiler_Option.isNone uu___5) datas in - if uu___4 - then [] - else - (let uu___6 = - FStar_SMTEncoding_Env.fresh_fvar - env1.FStar_SMTEncoding_Env.current_module_name "x" - FStar_SMTEncoding_Term.Term_sort in - match uu___6 with - | (xxsym, xx) -> - let uu___7 = - FStar_Compiler_List.fold_left - (fun uu___8 -> - fun l -> - match uu___8 with - | (out, decls) -> - let uu___9 = - FStar_TypeChecker_Env.lookup_datacon - env1.FStar_SMTEncoding_Env.tcenv l in - (match uu___9 with - | (uu___10, data_t) -> - let uu___11 = - FStar_Syntax_Util.arrow_formals - data_t in - (match uu___11 with - | (args, res) -> - let indices = - let uu___12 = - FStar_Syntax_Util.head_and_args_full - res in - FStar_Pervasives_Native.snd - uu___12 in - let env2 = - FStar_Compiler_List.fold_left - (fun env3 -> - fun uu___12 -> - match uu___12 with - | { - FStar_Syntax_Syntax.binder_bv - = x; - FStar_Syntax_Syntax.binder_qual - = uu___13; - FStar_Syntax_Syntax.binder_positivity - = uu___14; - FStar_Syntax_Syntax.binder_attrs - = uu___15;_} - -> - let uu___16 = - let uu___17 = - let uu___18 = - FStar_SMTEncoding_Env.mk_term_projector_name - l x in - (uu___18, [xx]) in - FStar_SMTEncoding_Util.mkApp - uu___17 in - FStar_SMTEncoding_Env.push_term_var - env3 x uu___16) - env1 args in - let uu___12 = - FStar_SMTEncoding_EncodeTerm.encode_args - indices env2 in - (match uu___12 with - | (indices1, decls') -> - (if - (FStar_Compiler_List.length - indices1) - <> - (FStar_Compiler_List.length - vars) - then - FStar_Compiler_Effect.failwith - "Impossible" - else (); - (let eqs = - let uu___14 = - is_injective_on_params - || - (let uu___15 = - FStar_Options.ext_getv - "compat:injectivity" in - uu___15 <> "") in - if uu___14 - then - FStar_Compiler_List.map2 - (fun v -> - fun a -> - let uu___15 = - let uu___16 - = - FStar_SMTEncoding_Util.mkFreeV - v in - (uu___16, a) in - FStar_SMTEncoding_Util.mkEq - uu___15) - vars indices1 - else - (let num_params = - FStar_Compiler_List.length - tps in - let uu___16 = - FStar_Compiler_List.splitAt - num_params vars in - match uu___16 with - | (_var_params, - var_indices) -> - let uu___17 = - FStar_Compiler_List.splitAt - num_params - indices1 in - (match uu___17 - with - | (_i_params, - indices2) -> - FStar_Compiler_List.map2 - ( - fun v -> - fun a -> - let uu___18 - = - let uu___19 - = - FStar_SMTEncoding_Util.mkFreeV - v in - (uu___19, - a) in - FStar_SMTEncoding_Util.mkEq - uu___18) - var_indices - indices2)) in - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - FStar_SMTEncoding_Env.mk_data_tester - env2 l xx in - let uu___19 = - FStar_SMTEncoding_Util.mk_and_l - eqs in - (uu___18, - uu___19) in - FStar_SMTEncoding_Util.mkAnd - uu___17 in - (out, uu___16) in - FStar_SMTEncoding_Util.mkOr - uu___15 in - (uu___14, - (FStar_Compiler_List.op_At - decls decls')))))))) - (FStar_SMTEncoding_Util.mkFalse, []) datas in - (match uu___7 with - | (data_ax, decls) -> - let uu___8 = - FStar_SMTEncoding_Env.fresh_fvar - env1.FStar_SMTEncoding_Env.current_module_name - "f" FStar_SMTEncoding_Term.Fuel_sort in - (match uu___8 with - | (ffsym, ff) -> - let fuel_guarded_inversion = - let xx_has_type_sfuel = - if - (FStar_Compiler_List.length datas) > - Prims.int_one - then - let uu___9 = - FStar_SMTEncoding_Util.mkApp - ("SFuel", [ff]) in - FStar_SMTEncoding_Term.mk_HasTypeFuel - uu___9 xx tapp - else - FStar_SMTEncoding_Term.mk_HasTypeFuel - ff xx tapp in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Ident.range_of_lid t in - let uu___12 = - let uu___13 = - let uu___14 = - FStar_SMTEncoding_Term.mk_fv - (ffsym, - FStar_SMTEncoding_Term.Fuel_sort) in - let uu___15 = - let uu___16 = - FStar_SMTEncoding_Term.mk_fv - (xxsym, - FStar_SMTEncoding_Term.Term_sort) in - uu___16 :: vars in - FStar_SMTEncoding_Env.add_fuel - uu___14 uu___15 in - let uu___14 = - FStar_SMTEncoding_Util.mkImp - (xx_has_type_sfuel, data_ax) in - ([[xx_has_type_sfuel]], uu___13, - uu___14) in - FStar_SMTEncoding_Term.mkForall uu___11 - uu___12 in - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Ident.string_of_lid t in - Prims.strcat - "fuel_guarded_inversion_" uu___13 in - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.mk_unique - uu___12 in - (uu___10, - (FStar_Pervasives_Native.Some - "inversion axiom"), uu___11) in - FStar_SMTEncoding_Util.mkAssume uu___9 in - let uu___9 = - FStar_SMTEncoding_Term.mk_decls_trivial - [fuel_guarded_inversion] in - FStar_Compiler_List.op_At decls uu___9))) in - let uu___4 = - let k1 = - match tps with - | [] -> k - | uu___5 -> - let uu___6 = - let uu___7 = - let uu___8 = FStar_Syntax_Syntax.mk_Total k in - { - FStar_Syntax_Syntax.bs1 = tps; - FStar_Syntax_Syntax.comp = uu___8 - } in - FStar_Syntax_Syntax.Tm_arrow uu___7 in - FStar_Syntax_Syntax.mk uu___6 k.FStar_Syntax_Syntax.pos in - let k2 = norm_before_encoding env k1 in - FStar_Syntax_Util.arrow_formals k2 in - match uu___4 with - | (formals, res) -> - let uu___5 = - FStar_SMTEncoding_EncodeTerm.encode_binders - FStar_Pervasives_Native.None formals env in - (match uu___5 with - | (vars, guards, env', binder_decls, uu___6) -> - let arity = FStar_Compiler_List.length vars in - let uu___7 = - FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid - env t arity in - (match uu___7 with - | (tname, ttok, env1) -> - let ttok_tm = - FStar_SMTEncoding_Util.mkApp (ttok, []) in - let guard = FStar_SMTEncoding_Util.mk_and_l guards in - let tapp = - let uu___8 = - let uu___9 = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV vars in - (tname, uu___9) in - FStar_SMTEncoding_Util.mkApp uu___8 in - let uu___8 = - let tname_decl = - let uu___9 = - let uu___10 = - FStar_Compiler_List.map - (fun fv -> - let uu___11 = - let uu___12 = - FStar_SMTEncoding_Term.fv_name fv in - Prims.strcat tname uu___12 in - let uu___12 = - FStar_SMTEncoding_Term.fv_sort fv in + FStar_Syntax_Syntax.Tm_arrow uu___6 in + FStar_Syntax_Syntax.mk uu___5 k.FStar_Syntax_Syntax.pos in + let k2 = norm_before_encoding env k1 in + FStar_Syntax_Util.arrow_formals k2 in + (match uu___3 with + | (formals, res) -> + let uu___4 = + FStar_SMTEncoding_EncodeTerm.encode_binders + FStar_Pervasives_Native.None formals env in + (match uu___4 with + | (vars, guards, env', binder_decls, uu___5) -> + let arity = FStar_Compiler_List.length vars in + let uu___6 = + FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid + env t arity in + (match uu___6 with + | (tname, ttok, env1) -> + let ttok_tm = + FStar_SMTEncoding_Util.mkApp (ttok, []) in + let guard = FStar_SMTEncoding_Util.mk_and_l guards in + let tapp = + let uu___7 = + let uu___8 = + FStar_Compiler_List.map + FStar_SMTEncoding_Util.mkFreeV vars in + (tname, uu___8) in + FStar_SMTEncoding_Util.mkApp uu___7 in + let uu___7 = + let tname_decl = + let uu___8 = + let uu___9 = + FStar_Compiler_List.map + (fun fv -> + let uu___10 = + let uu___11 = + FStar_SMTEncoding_Term.fv_name fv in + Prims.strcat tname uu___11 in + let uu___11 = + FStar_SMTEncoding_Term.fv_sort fv in { FStar_SMTEncoding_Term.field_name = - uu___11; + uu___10; FStar_SMTEncoding_Term.field_sort = - uu___12; + uu___11; FStar_SMTEncoding_Term.field_projectible = false }) vars in - let uu___11 = - let uu___12 = + let uu___10 = + let uu___11 = FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id () in - FStar_Pervasives_Native.Some uu___12 in + FStar_Pervasives_Native.Some uu___11 in { FStar_SMTEncoding_Term.constr_name = tname; FStar_SMTEncoding_Term.constr_fields = - uu___10; + uu___9; FStar_SMTEncoding_Term.constr_sort = FStar_SMTEncoding_Term.Term_sort; - FStar_SMTEncoding_Term.constr_id = uu___11 + FStar_SMTEncoding_Term.constr_id = uu___10 } in - constructor_or_logic_type_decl uu___9 in - let uu___9 = + constructor_or_logic_type_decl uu___8 in + let uu___8 = match vars with | [] -> - let uu___10 = - let uu___11 = - let uu___12 = + let uu___9 = + let uu___10 = + let uu___11 = FStar_SMTEncoding_Util.mkApp (tname, []) in - FStar_Pervasives_Native.Some uu___12 in + FStar_Pervasives_Native.Some uu___11 in FStar_SMTEncoding_Env.push_free_var env1 - t arity tname uu___11 in - ([], uu___10) - | uu___10 -> + t arity tname uu___10 in + ([], uu___9) + | uu___9 -> let ttok_decl = FStar_SMTEncoding_Term.DeclFun (ttok, [], @@ -5037,328 +4329,342 @@ and (encode_sigelt' : (FStar_Pervasives_Native.Some "token")) in let ttok_fresh = - let uu___11 = + let uu___10 = FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id () in FStar_SMTEncoding_Term.fresh_token (ttok, FStar_SMTEncoding_Term.Term_sort) - uu___11 in + uu___10 in let ttok_app = FStar_SMTEncoding_EncodeTerm.mk_Apply ttok_tm vars in let pats = [[ttok_app]; [tapp]] in let name_tok_corr = - let uu___11 = - let uu___12 = - let uu___13 = + let uu___10 = + let uu___11 = + let uu___12 = FStar_Ident.range_of_lid t in - let uu___14 = - let uu___15 = + let uu___13 = + let uu___14 = FStar_SMTEncoding_Util.mkEq (ttok_app, tapp) in (pats, FStar_Pervasives_Native.None, - vars, uu___15) in + vars, uu___14) in FStar_SMTEncoding_Term.mkForall' - uu___13 uu___14 in - (uu___12, + uu___12 uu___13 in + (uu___11, (FStar_Pervasives_Native.Some "name-token correspondence"), (Prims.strcat "token_correspondence_" ttok)) in - FStar_SMTEncoding_Util.mkAssume uu___11 in + FStar_SMTEncoding_Util.mkAssume uu___10 in ([ttok_decl; ttok_fresh; name_tok_corr], env1) in - match uu___9 with + match uu___8 with | (tok_decls, env2) -> ((FStar_Compiler_List.op_At tname_decl tok_decls), env2) in - (match uu___8 with + (match uu___7 with | (decls, env2) -> let kindingAx = - let uu___9 = + let uu___8 = FStar_SMTEncoding_EncodeTerm.encode_term_pred FStar_Pervasives_Native.None res env' tapp in - match uu___9 with + match uu___8 with | (k1, decls1) -> let karr = if (FStar_Compiler_List.length formals) > Prims.int_zero then - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = FStar_SMTEncoding_Term.mk_PreType ttok_tm in FStar_SMTEncoding_Term.mk_tester - "Tm_arrow" uu___13 in - (uu___12, + "Tm_arrow" uu___12 in + (uu___11, (FStar_Pervasives_Native.Some "kinding"), (Prims.strcat "pre_kinding_" ttok)) in FStar_SMTEncoding_Util.mkAssume - uu___11 in - [uu___10] + uu___10 in + [uu___9] else [] in let rng = FStar_Ident.range_of_lid t in let tot_fun_axioms = - let uu___10 = + let uu___9 = FStar_Compiler_List.map - (fun uu___11 -> + (fun uu___10 -> FStar_SMTEncoding_Util.mkTrue) vars in FStar_SMTEncoding_EncodeTerm.isTotFun_axioms - rng ttok_tm vars uu___10 true in - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - let uu___19 = + rng ttok_tm vars uu___9 true in + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = FStar_SMTEncoding_Util.mkImp (guard, k1) in ([[tapp]], vars, - uu___19) in + uu___18) in FStar_SMTEncoding_Term.mkForall - rng uu___18 in - (tot_fun_axioms, uu___17) in + rng uu___17 in + (tot_fun_axioms, uu___16) in FStar_SMTEncoding_Util.mkAnd - uu___16 in - (uu___15, + uu___15 in + (uu___14, FStar_Pervasives_Native.None, (Prims.strcat "kinding_" ttok)) in FStar_SMTEncoding_Util.mkAssume - uu___14 in - [uu___13] in + uu___13 in + [uu___12] in FStar_Compiler_List.op_At karr - uu___12 in + uu___11 in FStar_SMTEncoding_Term.mk_decls_trivial - uu___11 in - FStar_Compiler_List.op_At decls1 - uu___10 in + uu___10 in + FStar_Compiler_List.op_At decls1 uu___9 in let aux = - let uu___9 = - let uu___10 = + let uu___8 = + let uu___9 = inversion_axioms env2 tapp vars in - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = FStar_Ident.range_of_lid t in - pretype_axiom uu___14 env2 tapp + pretype_axiom uu___13 env2 tapp vars in - [uu___13] in + [uu___12] in FStar_SMTEncoding_Term.mk_decls_trivial - uu___12 in - FStar_Compiler_List.op_At uu___10 uu___11 in - FStar_Compiler_List.op_At kindingAx uu___9 in - let g = + uu___11 in + FStar_Compiler_List.op_At uu___9 uu___10 in + FStar_Compiler_List.op_At kindingAx uu___8 in + let uu___8 = let uu___9 = FStar_SMTEncoding_Term.mk_decls_trivial decls in FStar_Compiler_List.op_At uu___9 (FStar_Compiler_List.op_At binder_decls aux) in - (g, env2)))))) - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = d; FStar_Syntax_Syntax.us1 = uu___1; - FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___2; - FStar_Syntax_Syntax.num_ty_params = n_tps; - FStar_Syntax_Syntax.mutuals1 = mutuals;_} - -> - let quals = se.FStar_Syntax_Syntax.sigquals in - let t1 = norm_before_encoding env t in - let uu___3 = FStar_Syntax_Util.arrow_formals t1 in - (match uu___3 with - | (formals, t_res) -> - let arity = FStar_Compiler_List.length formals in - let uu___4 = - FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid - env d arity in - (match uu___4 with - | (ddconstrsym, ddtok, env1) -> - let ddtok_tm = FStar_SMTEncoding_Util.mkApp (ddtok, []) in - let uu___5 = - FStar_SMTEncoding_Env.fresh_fvar - env1.FStar_SMTEncoding_Env.current_module_name "f" - FStar_SMTEncoding_Term.Fuel_sort in - (match uu___5 with - | (fuel_var, fuel_tm) -> - let s_fuel_tm = - FStar_SMTEncoding_Util.mkApp ("SFuel", [fuel_tm]) in - let uu___6 = - FStar_SMTEncoding_EncodeTerm.encode_binders - (FStar_Pervasives_Native.Some fuel_tm) formals - env1 in - (match uu___6 with - | (vars, guards, env', binder_decls, names) -> - let fields = - FStar_Compiler_List.mapi - (fun n -> - fun x -> - let uu___7 = - FStar_SMTEncoding_Env.mk_term_projector_name - d x in - { - FStar_SMTEncoding_Term.field_name = - uu___7; - FStar_SMTEncoding_Term.field_sort = - FStar_SMTEncoding_Term.Term_sort; - FStar_SMTEncoding_Term.field_projectible - = true - }) names in - let datacons = - let uu___7 = FStar_Ident.range_of_lid d in - let uu___8 = - let uu___9 = - let uu___10 = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id - () in - FStar_Pervasives_Native.Some uu___10 in - { - FStar_SMTEncoding_Term.constr_name = - ddconstrsym; - FStar_SMTEncoding_Term.constr_fields = - fields; - FStar_SMTEncoding_Term.constr_sort = - FStar_SMTEncoding_Term.Term_sort; - FStar_SMTEncoding_Term.constr_id = - uu___9 - } in - FStar_SMTEncoding_Term.constructor_to_decl - uu___7 uu___8 in - let app = - FStar_SMTEncoding_EncodeTerm.mk_Apply - ddtok_tm vars in - let guard = - FStar_SMTEncoding_Util.mk_and_l guards in - let xvars = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV vars in - let dapp = - FStar_SMTEncoding_Util.mkApp - (ddconstrsym, xvars) in - let uu___7 = - FStar_SMTEncoding_EncodeTerm.encode_term_pred - FStar_Pervasives_Native.None t1 env1 - ddtok_tm in - (match uu___7 with - | (tok_typing, decls3) -> - let tok_typing1 = - match fields with - | uu___8::uu___9 -> - let ff = - FStar_SMTEncoding_Term.mk_fv - ("ty", - FStar_SMTEncoding_Term.Term_sort) in - let f = - FStar_SMTEncoding_Util.mkFreeV ff in - let vtok_app_l = - FStar_SMTEncoding_EncodeTerm.mk_Apply - ddtok_tm [ff] in - let vtok_app_r = - let uu___10 = - let uu___11 = - FStar_SMTEncoding_Term.mk_fv - (ddtok, - FStar_SMTEncoding_Term.Term_sort) in - [uu___11] in - FStar_SMTEncoding_EncodeTerm.mk_Apply - f uu___10 in - let uu___10 = - FStar_Ident.range_of_lid d in - let uu___11 = - let uu___12 = - FStar_SMTEncoding_Term.mk_NoHoist - f tok_typing in - ([[vtok_app_l]; [vtok_app_r]], - [ff], uu___12) in - FStar_SMTEncoding_Term.mkForall - uu___10 uu___11 - | uu___8 -> tok_typing in - let uu___8 = - let uu___9 = - FStar_SMTEncoding_EncodeTerm.encode_term - t_res env' in - match uu___9 with - | (t_res_tm, t_res_decls) -> - let uu___10 = - FStar_SMTEncoding_Term.mk_HasTypeWithFuel - (FStar_Pervasives_Native.Some - fuel_tm) dapp t_res_tm in - (uu___10, t_res_tm, t_res_decls) in - (match uu___8 with - | (ty_pred', t_res_tm, decls_pred) -> - let proxy_fresh = - match formals with - | [] -> [] - | uu___9 -> - let uu___10 = - let uu___11 = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id - () in - FStar_SMTEncoding_Term.fresh_token - (ddtok, - FStar_SMTEncoding_Term.Term_sort) - uu___11 in - [uu___10] in - let encode_elim uu___9 = - let uu___10 = - FStar_Syntax_Util.head_and_args - t_res in - match uu___10 with - | (head, args) -> - let uu___11 = - let uu___12 = - FStar_Syntax_Subst.compress - head in - uu___12.FStar_Syntax_Syntax.n in - (match uu___11 with - | FStar_Syntax_Syntax.Tm_uinst - ({ - FStar_Syntax_Syntax.n - = - FStar_Syntax_Syntax.Tm_fvar - fv; - FStar_Syntax_Syntax.pos - = uu___12; - FStar_Syntax_Syntax.vars - = uu___13; - FStar_Syntax_Syntax.hash_code - = uu___14;_}, - uu___15) - -> - let encoded_head_fvb = - FStar_SMTEncoding_Env.lookup_free_var_name - env' - fv.FStar_Syntax_Syntax.fv_name in - let uu___16 = - FStar_SMTEncoding_EncodeTerm.encode_args - args env' in - (match uu___16 with - | (encoded_args, - arg_decls) -> - let guards_for_parameter - orig_arg arg xv = - let fv1 = - match arg.FStar_SMTEncoding_Term.tm - with - | FStar_SMTEncoding_Term.FreeV - fv2 -> fv2 - | uu___17 -> - let uu___18 - = - let uu___19 + (uu___8, env2))))) +let (encode_datacon : + Prims.bool -> + FStar_SMTEncoding_Env.env_t -> + FStar_Syntax_Syntax.sigelt -> + (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.env_t)) + = + fun is_injective_on_tparams -> + fun env -> + fun se -> + let uu___ = se.FStar_Syntax_Syntax.sigel in + match uu___ with + | FStar_Syntax_Syntax.Sig_datacon + { FStar_Syntax_Syntax.lid1 = d; FStar_Syntax_Syntax.us1 = uu___1; + FStar_Syntax_Syntax.t1 = t; + FStar_Syntax_Syntax.ty_lid = uu___2; + FStar_Syntax_Syntax.num_ty_params = n_tps; + FStar_Syntax_Syntax.mutuals1 = mutuals;_} + -> + let quals = se.FStar_Syntax_Syntax.sigquals in + let t1 = norm_before_encoding env t in + let uu___3 = FStar_Syntax_Util.arrow_formals t1 in + (match uu___3 with + | (formals, t_res) -> + let arity = FStar_Compiler_List.length formals in + let uu___4 = + FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid + env d arity in + (match uu___4 with + | (ddconstrsym, ddtok, env1) -> + let ddtok_tm = FStar_SMTEncoding_Util.mkApp (ddtok, []) in + let uu___5 = + FStar_SMTEncoding_Env.fresh_fvar + env1.FStar_SMTEncoding_Env.current_module_name "f" + FStar_SMTEncoding_Term.Fuel_sort in + (match uu___5 with + | (fuel_var, fuel_tm) -> + let s_fuel_tm = + FStar_SMTEncoding_Util.mkApp + ("SFuel", [fuel_tm]) in + let uu___6 = + FStar_SMTEncoding_EncodeTerm.encode_binders + (FStar_Pervasives_Native.Some fuel_tm) formals + env1 in + (match uu___6 with + | (vars, guards, env', binder_decls, names) -> + let fields = + FStar_Compiler_List.mapi + (fun n -> + fun x -> + let uu___7 = + FStar_SMTEncoding_Env.mk_term_projector_name + d x in + { + FStar_SMTEncoding_Term.field_name + = uu___7; + FStar_SMTEncoding_Term.field_sort + = + FStar_SMTEncoding_Term.Term_sort; + FStar_SMTEncoding_Term.field_projectible + = true + }) names in + let datacons = + let uu___7 = FStar_Ident.range_of_lid d in + let uu___8 = + let uu___9 = + let uu___10 = + FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id + () in + FStar_Pervasives_Native.Some uu___10 in + { + FStar_SMTEncoding_Term.constr_name = + ddconstrsym; + FStar_SMTEncoding_Term.constr_fields = + fields; + FStar_SMTEncoding_Term.constr_sort = + FStar_SMTEncoding_Term.Term_sort; + FStar_SMTEncoding_Term.constr_id = + uu___9 + } in + FStar_SMTEncoding_Term.constructor_to_decl + uu___7 uu___8 in + let app = + FStar_SMTEncoding_EncodeTerm.mk_Apply + ddtok_tm vars in + let guard = + FStar_SMTEncoding_Util.mk_and_l guards in + let xvars = + FStar_Compiler_List.map + FStar_SMTEncoding_Util.mkFreeV vars in + let dapp = + FStar_SMTEncoding_Util.mkApp + (ddconstrsym, xvars) in + let uu___7 = + FStar_SMTEncoding_EncodeTerm.encode_term_pred + FStar_Pervasives_Native.None t1 env1 + ddtok_tm in + (match uu___7 with + | (tok_typing, decls3) -> + let tok_typing1 = + match fields with + | uu___8::uu___9 -> + let ff = + FStar_SMTEncoding_Term.mk_fv + ("ty", + FStar_SMTEncoding_Term.Term_sort) in + let f = + FStar_SMTEncoding_Util.mkFreeV + ff in + let vtok_app_l = + FStar_SMTEncoding_EncodeTerm.mk_Apply + ddtok_tm [ff] in + let vtok_app_r = + let uu___10 = + let uu___11 = + FStar_SMTEncoding_Term.mk_fv + (ddtok, + FStar_SMTEncoding_Term.Term_sort) in + [uu___11] in + FStar_SMTEncoding_EncodeTerm.mk_Apply + f uu___10 in + let uu___10 = + FStar_Ident.range_of_lid d in + let uu___11 = + let uu___12 = + FStar_SMTEncoding_Term.mk_NoHoist + f tok_typing in + ([[vtok_app_l]; [vtok_app_r]], + [ff], uu___12) in + FStar_SMTEncoding_Term.mkForall + uu___10 uu___11 + | uu___8 -> tok_typing in + let uu___8 = + let uu___9 = + FStar_SMTEncoding_EncodeTerm.encode_term + t_res env' in + match uu___9 with + | (t_res_tm, t_res_decls) -> + let uu___10 = + FStar_SMTEncoding_Term.mk_HasTypeWithFuel + (FStar_Pervasives_Native.Some + fuel_tm) dapp t_res_tm in + (uu___10, t_res_tm, t_res_decls) in + (match uu___8 with + | (ty_pred', t_res_tm, decls_pred) -> + let proxy_fresh = + match formals with + | [] -> [] + | uu___9 -> + let uu___10 = + let uu___11 = + FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id + () in + FStar_SMTEncoding_Term.fresh_token + (ddtok, + FStar_SMTEncoding_Term.Term_sort) + uu___11 in + [uu___10] in + let encode_elim uu___9 = + let uu___10 = + FStar_Syntax_Util.head_and_args + t_res in + match uu___10 with + | (head, args) -> + let uu___11 = + let uu___12 = + FStar_Syntax_Subst.compress + head in + uu___12.FStar_Syntax_Syntax.n in + (match uu___11 with + | FStar_Syntax_Syntax.Tm_uinst + ({ + FStar_Syntax_Syntax.n + = + FStar_Syntax_Syntax.Tm_fvar + fv; + FStar_Syntax_Syntax.pos + = uu___12; + FStar_Syntax_Syntax.vars + = uu___13; + FStar_Syntax_Syntax.hash_code + = uu___14;_}, + uu___15) + -> + let encoded_head_fvb = + FStar_SMTEncoding_Env.lookup_free_var_name + env' + fv.FStar_Syntax_Syntax.fv_name in + let uu___16 = + FStar_SMTEncoding_EncodeTerm.encode_args + args env' in + (match uu___16 with + | (encoded_args, + arg_decls) -> + let guards_for_parameter + orig_arg arg xv = + let fv1 = + match arg.FStar_SMTEncoding_Term.tm + with + | FStar_SMTEncoding_Term.FreeV + fv2 -> fv2 + | uu___17 -> + let uu___18 + = + let uu___19 = let uu___20 = @@ -5367,15 +4673,15 @@ and (encode_sigelt' : FStar_Compiler_Util.format1 "Inductive type parameter %s must be a variable ; You may want to change it to an index." uu___20 in - (FStar_Errors_Codes.Fatal_NonVariableInductiveTypeParameter, + (FStar_Errors_Codes.Fatal_NonVariableInductiveTypeParameter, uu___19) in - FStar_Errors.raise_error - uu___18 - orig_arg.FStar_Syntax_Syntax.pos in - let guards1 = - FStar_Compiler_List.collect - (fun g -> - let uu___17 + FStar_Errors.raise_error + uu___18 + orig_arg.FStar_Syntax_Syntax.pos in + let guards1 = + FStar_Compiler_List.collect + (fun g -> + let uu___17 = let uu___18 = @@ -5384,31 +4690,32 @@ and (encode_sigelt' : FStar_Compiler_List.contains fv1 uu___18 in - if uu___17 - then + if uu___17 + then let uu___18 = FStar_SMTEncoding_Term.subst g fv1 xv in [uu___18] - else []) - guards in - FStar_SMTEncoding_Util.mk_and_l - guards1 in - let uu___17 = - let uu___18 = - FStar_Compiler_List.zip - args - encoded_args in - FStar_Compiler_List.fold_left - (fun uu___19 -> - fun uu___20 - -> - match + else []) + guards in + FStar_SMTEncoding_Util.mk_and_l + guards1 in + let uu___17 = + let uu___18 = + FStar_Compiler_List.zip + args + encoded_args in + FStar_Compiler_List.fold_left + (fun uu___19 -> + fun uu___20 + -> + match (uu___19, uu___20) - with - | ((env2, + with + | + ((env2, arg_vars, eqns_or_guards, i), @@ -5458,44 +4765,46 @@ and (encode_sigelt' : eqns, (i + Prims.int_one)))) - (env', [], [], - Prims.int_zero) - uu___18 in - (match uu___17 with - | (uu___18, - arg_vars, - elim_eqns_or_guards, - uu___19) -> - let arg_vars1 = - FStar_Compiler_List.rev - arg_vars in - let ty = - FStar_SMTEncoding_EncodeTerm.maybe_curry_fvb - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.p - encoded_head_fvb - arg_vars1 in - let xvars1 = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV - vars in - let dapp1 = - FStar_SMTEncoding_Util.mkApp - (ddconstrsym, + (env', [], [], + Prims.int_zero) + uu___18 in + (match uu___17 with + | (uu___18, + arg_vars, + elim_eqns_or_guards, + uu___19) -> + let arg_vars1 + = + FStar_Compiler_List.rev + arg_vars in + let ty = + FStar_SMTEncoding_EncodeTerm.maybe_curry_fvb + (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.p + encoded_head_fvb + arg_vars1 in + let xvars1 = + FStar_Compiler_List.map + FStar_SMTEncoding_Util.mkFreeV + vars in + let dapp1 = + FStar_SMTEncoding_Util.mkApp + (ddconstrsym, xvars1) in - let ty_pred = - FStar_SMTEncoding_Term.mk_HasTypeWithFuel - (FStar_Pervasives_Native.Some + let ty_pred = + FStar_SMTEncoding_Term.mk_HasTypeWithFuel + (FStar_Pervasives_Native.Some s_fuel_tm) - dapp1 ty in - let arg_binders - = - FStar_Compiler_List.map - FStar_SMTEncoding_Term.fv_of_term - arg_vars1 in - let typing_inversion - = - let uu___20 = - let uu___21 + dapp1 ty in + let arg_binders + = + FStar_Compiler_List.map + FStar_SMTEncoding_Term.fv_of_term + arg_vars1 in + let typing_inversion + = + let uu___20 + = + let uu___21 = let uu___22 = @@ -5536,19 +4845,18 @@ and (encode_sigelt' : FStar_SMTEncoding_Term.mkForall uu___22 uu___23 in - (uu___21, - ( - FStar_Pervasives_Native.Some + (uu___21, + (FStar_Pervasives_Native.Some "data constructor typing elim"), - ( - Prims.strcat + (Prims.strcat "data_elim_" ddconstrsym)) in - FStar_SMTEncoding_Util.mkAssume - uu___20 in - let lex_t = - let uu___20 = - let uu___21 + FStar_SMTEncoding_Util.mkAssume + uu___20 in + let lex_t = + let uu___20 + = + let uu___21 = let uu___22 = @@ -5556,14 +4864,14 @@ and (encode_sigelt' : FStar_Parser_Const.lex_t_lid in (uu___22, FStar_SMTEncoding_Term.Term_sort) in - FStar_SMTEncoding_Term.mk_fv + FStar_SMTEncoding_Term.mk_fv uu___21 in - FStar_SMTEncoding_Util.mkFreeV - uu___20 in - let subterm_ordering - = - let prec = - let uu___20 + FStar_SMTEncoding_Util.mkFreeV + uu___20 in + let subterm_ordering + = + let prec = + let uu___20 = FStar_Compiler_List.mapi (fun i -> @@ -5585,10 +4893,11 @@ and (encode_sigelt' : dapp1 in [uu___22])) vars in - FStar_Compiler_List.flatten + FStar_Compiler_List.flatten uu___20 in - let uu___20 = - let uu___21 + let uu___20 + = + let uu___21 = let uu___22 = @@ -5627,25 +4936,24 @@ and (encode_sigelt' : FStar_SMTEncoding_Term.mkForall uu___22 uu___23 in - (uu___21, - ( - FStar_Pervasives_Native.Some + (uu___21, + (FStar_Pervasives_Native.Some "subterm ordering"), - ( - Prims.strcat + (Prims.strcat "subterm_ordering_" ddconstrsym)) in - FStar_SMTEncoding_Util.mkAssume - uu___20 in - let uu___20 = - let uu___21 = - FStar_Compiler_Util.first_N + FStar_SMTEncoding_Util.mkAssume + uu___20 in + let uu___20 = + let uu___21 + = + FStar_Compiler_Util.first_N n_tps formals in - match uu___21 - with - | (uu___22, - formals') + match uu___21 + with + | (uu___22, + formals') -> let uu___23 = @@ -6076,41 +5384,41 @@ and (encode_sigelt' : [uu___28] in (uu___27, cod_decls)))) in - (match uu___20 - with - | (codomain_ordering, - codomain_decls) - -> - ((FStar_Compiler_List.op_At + (match uu___20 + with + | (codomain_ordering, + codomain_decls) + -> + ((FStar_Compiler_List.op_At arg_decls codomain_decls), (FStar_Compiler_List.op_At [typing_inversion; subterm_ordering] codomain_ordering))))) - | FStar_Syntax_Syntax.Tm_fvar - fv -> - let encoded_head_fvb = - FStar_SMTEncoding_Env.lookup_free_var_name - env' - fv.FStar_Syntax_Syntax.fv_name in - let uu___12 = - FStar_SMTEncoding_EncodeTerm.encode_args - args env' in - (match uu___12 with - | (encoded_args, - arg_decls) -> - let guards_for_parameter - orig_arg arg xv = - let fv1 = - match arg.FStar_SMTEncoding_Term.tm - with - | FStar_SMTEncoding_Term.FreeV - fv2 -> fv2 - | uu___13 -> - let uu___14 - = - let uu___15 + | FStar_Syntax_Syntax.Tm_fvar + fv -> + let encoded_head_fvb = + FStar_SMTEncoding_Env.lookup_free_var_name + env' + fv.FStar_Syntax_Syntax.fv_name in + let uu___12 = + FStar_SMTEncoding_EncodeTerm.encode_args + args env' in + (match uu___12 with + | (encoded_args, + arg_decls) -> + let guards_for_parameter + orig_arg arg xv = + let fv1 = + match arg.FStar_SMTEncoding_Term.tm + with + | FStar_SMTEncoding_Term.FreeV + fv2 -> fv2 + | uu___13 -> + let uu___14 + = + let uu___15 = let uu___16 = @@ -6119,15 +5427,15 @@ and (encode_sigelt' : FStar_Compiler_Util.format1 "Inductive type parameter %s must be a variable ; You may want to change it to an index." uu___16 in - (FStar_Errors_Codes.Fatal_NonVariableInductiveTypeParameter, + (FStar_Errors_Codes.Fatal_NonVariableInductiveTypeParameter, uu___15) in - FStar_Errors.raise_error - uu___14 - orig_arg.FStar_Syntax_Syntax.pos in - let guards1 = - FStar_Compiler_List.collect - (fun g -> - let uu___13 + FStar_Errors.raise_error + uu___14 + orig_arg.FStar_Syntax_Syntax.pos in + let guards1 = + FStar_Compiler_List.collect + (fun g -> + let uu___13 = let uu___14 = @@ -6136,31 +5444,32 @@ and (encode_sigelt' : FStar_Compiler_List.contains fv1 uu___14 in - if uu___13 - then + if uu___13 + then let uu___14 = FStar_SMTEncoding_Term.subst g fv1 xv in [uu___14] - else []) - guards in - FStar_SMTEncoding_Util.mk_and_l - guards1 in - let uu___13 = - let uu___14 = - FStar_Compiler_List.zip - args - encoded_args in - FStar_Compiler_List.fold_left - (fun uu___15 -> - fun uu___16 - -> - match + else []) + guards in + FStar_SMTEncoding_Util.mk_and_l + guards1 in + let uu___13 = + let uu___14 = + FStar_Compiler_List.zip + args + encoded_args in + FStar_Compiler_List.fold_left + (fun uu___15 -> + fun uu___16 + -> + match (uu___15, uu___16) - with - | ((env2, + with + | + ((env2, arg_vars, eqns_or_guards, i), @@ -6210,44 +5519,46 @@ and (encode_sigelt' : eqns, (i + Prims.int_one)))) - (env', [], [], - Prims.int_zero) - uu___14 in - (match uu___13 with - | (uu___14, - arg_vars, - elim_eqns_or_guards, - uu___15) -> - let arg_vars1 = - FStar_Compiler_List.rev - arg_vars in - let ty = - FStar_SMTEncoding_EncodeTerm.maybe_curry_fvb - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.p - encoded_head_fvb - arg_vars1 in - let xvars1 = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV - vars in - let dapp1 = - FStar_SMTEncoding_Util.mkApp - (ddconstrsym, + (env', [], [], + Prims.int_zero) + uu___14 in + (match uu___13 with + | (uu___14, + arg_vars, + elim_eqns_or_guards, + uu___15) -> + let arg_vars1 + = + FStar_Compiler_List.rev + arg_vars in + let ty = + FStar_SMTEncoding_EncodeTerm.maybe_curry_fvb + (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.p + encoded_head_fvb + arg_vars1 in + let xvars1 = + FStar_Compiler_List.map + FStar_SMTEncoding_Util.mkFreeV + vars in + let dapp1 = + FStar_SMTEncoding_Util.mkApp + (ddconstrsym, xvars1) in - let ty_pred = - FStar_SMTEncoding_Term.mk_HasTypeWithFuel - (FStar_Pervasives_Native.Some + let ty_pred = + FStar_SMTEncoding_Term.mk_HasTypeWithFuel + (FStar_Pervasives_Native.Some s_fuel_tm) - dapp1 ty in - let arg_binders - = - FStar_Compiler_List.map - FStar_SMTEncoding_Term.fv_of_term - arg_vars1 in - let typing_inversion - = - let uu___16 = - let uu___17 + dapp1 ty in + let arg_binders + = + FStar_Compiler_List.map + FStar_SMTEncoding_Term.fv_of_term + arg_vars1 in + let typing_inversion + = + let uu___16 + = + let uu___17 = let uu___18 = @@ -6288,19 +5599,18 @@ and (encode_sigelt' : FStar_SMTEncoding_Term.mkForall uu___18 uu___19 in - (uu___17, - ( - FStar_Pervasives_Native.Some + (uu___17, + (FStar_Pervasives_Native.Some "data constructor typing elim"), - ( - Prims.strcat + (Prims.strcat "data_elim_" ddconstrsym)) in - FStar_SMTEncoding_Util.mkAssume - uu___16 in - let lex_t = - let uu___16 = - let uu___17 + FStar_SMTEncoding_Util.mkAssume + uu___16 in + let lex_t = + let uu___16 + = + let uu___17 = let uu___18 = @@ -6308,14 +5618,14 @@ and (encode_sigelt' : FStar_Parser_Const.lex_t_lid in (uu___18, FStar_SMTEncoding_Term.Term_sort) in - FStar_SMTEncoding_Term.mk_fv + FStar_SMTEncoding_Term.mk_fv uu___17 in - FStar_SMTEncoding_Util.mkFreeV - uu___16 in - let subterm_ordering - = - let prec = - let uu___16 + FStar_SMTEncoding_Util.mkFreeV + uu___16 in + let subterm_ordering + = + let prec = + let uu___16 = FStar_Compiler_List.mapi (fun i -> @@ -6337,10 +5647,11 @@ and (encode_sigelt' : dapp1 in [uu___18])) vars in - FStar_Compiler_List.flatten + FStar_Compiler_List.flatten uu___16 in - let uu___16 = - let uu___17 + let uu___16 + = + let uu___17 = let uu___18 = @@ -6379,25 +5690,24 @@ and (encode_sigelt' : FStar_SMTEncoding_Term.mkForall uu___18 uu___19 in - (uu___17, - ( - FStar_Pervasives_Native.Some + (uu___17, + (FStar_Pervasives_Native.Some "subterm ordering"), - ( - Prims.strcat + (Prims.strcat "subterm_ordering_" ddconstrsym)) in - FStar_SMTEncoding_Util.mkAssume - uu___16 in - let uu___16 = - let uu___17 = - FStar_Compiler_Util.first_N + FStar_SMTEncoding_Util.mkAssume + uu___16 in + let uu___16 = + let uu___17 + = + FStar_Compiler_Util.first_N n_tps formals in - match uu___17 - with - | (uu___18, - formals') + match uu___17 + with + | (uu___18, + formals') -> let uu___19 = @@ -6828,71 +6138,72 @@ and (encode_sigelt' : [uu___24] in (uu___23, cod_decls)))) in - (match uu___16 - with - | (codomain_ordering, - codomain_decls) - -> - ((FStar_Compiler_List.op_At + (match uu___16 + with + | (codomain_ordering, + codomain_decls) + -> + ((FStar_Compiler_List.op_At arg_decls codomain_decls), (FStar_Compiler_List.op_At [typing_inversion; subterm_ordering] codomain_ordering))))) - | uu___12 -> - ((let uu___14 = - let uu___15 = - let uu___16 = - FStar_Syntax_Print.lid_to_string - d in - let uu___17 = - FStar_Syntax_Print.term_to_string - head in - FStar_Compiler_Util.format2 - "Constructor %s builds an unexpected type %s\n" - uu___16 uu___17 in - (FStar_Errors_Codes.Warning_ConstructorBuildsUnexpectedType, - uu___15) in - FStar_Errors.log_issue - se.FStar_Syntax_Syntax.sigrng - uu___14); - ([], []))) in - let uu___9 = encode_elim () in - (match uu___9 with - | (decls2, elim) -> - let data_cons_typing_intro_decl - = - let uu___10 = - match t_res_tm.FStar_SMTEncoding_Term.tm - with - | FStar_SMTEncoding_Term.App - (op, args) -> - let uu___11 = - FStar_Compiler_List.splitAt - n_tps args in - (match uu___11 with - | (targs, iargs) -> - let uu___12 = - let uu___13 = - FStar_Compiler_List.map - (fun uu___14 + | uu___12 -> + ((let uu___14 = + let uu___15 = + let uu___16 = + FStar_Syntax_Print.lid_to_string + d in + let uu___17 = + FStar_Syntax_Print.term_to_string + head in + FStar_Compiler_Util.format2 + "Constructor %s builds an unexpected type %s\n" + uu___16 uu___17 in + (FStar_Errors_Codes.Warning_ConstructorBuildsUnexpectedType, + uu___15) in + FStar_Errors.log_issue + se.FStar_Syntax_Syntax.sigrng + uu___14); + ([], []))) in + let uu___9 = encode_elim () in + (match uu___9 with + | (decls2, elim) -> + let data_cons_typing_intro_decl + = + let uu___10 = + match t_res_tm.FStar_SMTEncoding_Term.tm + with + | FStar_SMTEncoding_Term.App + (op, args) -> + let uu___11 = + FStar_Compiler_List.splitAt + n_tps args in + (match uu___11 with + | (targs, iargs) -> + let uu___12 = + let uu___13 = + FStar_Compiler_List.map + (fun + uu___14 -> FStar_SMTEncoding_Env.fresh_fvar env1.FStar_SMTEncoding_Env.current_module_name "i" FStar_SMTEncoding_Term.Term_sort) - iargs in - FStar_Compiler_List.split - uu___13 in - (match uu___12 - with - | (fresh_ivars, - fresh_iargs) - -> - let additional_guards - = - let uu___13 + iargs in + FStar_Compiler_List.split + uu___13 in + (match uu___12 + with + | (fresh_ivars, + fresh_iargs) + -> + let additional_guards + = + let uu___13 = FStar_Compiler_List.map2 (fun a -> @@ -6904,12 +6215,12 @@ and (encode_sigelt' : fresh_a)) iargs fresh_iargs in - FStar_SMTEncoding_Util.mk_and_l + FStar_SMTEncoding_Util.mk_and_l uu___13 in - let uu___13 = - FStar_SMTEncoding_Term.mk_HasTypeWithFuel - ( - FStar_Pervasives_Native.Some + let uu___13 + = + FStar_SMTEncoding_Term.mk_HasTypeWithFuel + (FStar_Pervasives_Native.Some fuel_tm) dapp { @@ -6927,8 +6238,9 @@ and (encode_sigelt' : = (t_res_tm.FStar_SMTEncoding_Term.rng) } in - let uu___14 = - let uu___15 + let uu___14 + = + let uu___15 = FStar_Compiler_List.map (fun s -> @@ -6936,61 +6248,65 @@ and (encode_sigelt' : (s, FStar_SMTEncoding_Term.Term_sort)) fresh_ivars in - FStar_Compiler_List.op_At + FStar_Compiler_List.op_At vars uu___15 in - let uu___15 = - FStar_SMTEncoding_Util.mkAnd + let uu___15 + = + FStar_SMTEncoding_Util.mkAnd (guard, additional_guards) in - (uu___13, - uu___14, - uu___15))) - | uu___11 -> - (ty_pred', vars, guard) in - match uu___10 with - | (ty_pred'1, vars1, guard1) - -> - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Ident.range_of_lid - d in - let uu___14 = - let uu___15 = - let uu___16 = - FStar_SMTEncoding_Term.mk_fv - (fuel_var, - FStar_SMTEncoding_Term.Fuel_sort) in - FStar_SMTEncoding_Env.add_fuel - uu___16 vars1 in - let uu___16 = - FStar_SMTEncoding_Util.mkImp - (guard1, - ty_pred'1) in - ([[ty_pred'1]], - uu___15, uu___16) in - FStar_SMTEncoding_Term.mkForall - uu___13 uu___14 in - (uu___12, - (FStar_Pervasives_Native.Some - "data constructor typing intro"), - (Prims.strcat - "data_typing_intro_" - ddtok)) in - FStar_SMTEncoding_Util.mkAssume - uu___11 in - let g = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - let uu___19 + (uu___13, + uu___14, + uu___15))) + | uu___11 -> + (ty_pred', vars, + guard) in + match uu___10 with + | (ty_pred'1, vars1, guard1) + -> + let uu___11 = + let uu___12 = + let uu___13 = + FStar_Ident.range_of_lid + d in + let uu___14 = + let uu___15 = + let uu___16 = + FStar_SMTEncoding_Term.mk_fv + (fuel_var, + FStar_SMTEncoding_Term.Fuel_sort) in + FStar_SMTEncoding_Env.add_fuel + uu___16 vars1 in + let uu___16 = + FStar_SMTEncoding_Util.mkImp + (guard1, + ty_pred'1) in + ([[ty_pred'1]], + uu___15, + uu___16) in + FStar_SMTEncoding_Term.mkForall + uu___13 uu___14 in + (uu___12, + (FStar_Pervasives_Native.Some + "data constructor typing intro"), + (Prims.strcat + "data_typing_intro_" + ddtok)) in + FStar_SMTEncoding_Util.mkAssume + uu___11 in + let g = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 + = + let uu___19 = let uu___20 = @@ -6999,36 +6315,35 @@ and (encode_sigelt' : FStar_Compiler_Util.format1 "data constructor proxy: %s" uu___20 in - FStar_Pervasives_Native.Some + FStar_Pervasives_Native.Some uu___19 in - (ddtok, [], - FStar_SMTEncoding_Term.Term_sort, - uu___18) in - FStar_SMTEncoding_Term.DeclFun - uu___17 in - [uu___16] in - FStar_Compiler_List.op_At - uu___15 - proxy_fresh in - FStar_SMTEncoding_Term.mk_decls_trivial - uu___14 in - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - FStar_SMTEncoding_Util.mkAssume - (tok_typing1, - ( - FStar_Pervasives_Native.Some + (ddtok, [], + FStar_SMTEncoding_Term.Term_sort, + uu___18) in + FStar_SMTEncoding_Term.DeclFun + uu___17 in + [uu___16] in + FStar_Compiler_List.op_At + uu___15 + proxy_fresh in + FStar_SMTEncoding_Term.mk_decls_trivial + uu___14 in + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + FStar_SMTEncoding_Util.mkAssume + (tok_typing1, + (FStar_Pervasives_Native.Some "typing for data constructor proxy"), - ( - Prims.strcat + (Prims.strcat "typing_tok_" ddtok)) in - let uu___19 = - let uu___20 = - let uu___21 + let uu___19 = + let uu___20 + = + let uu___21 = let uu___22 = @@ -7055,49 +6370,797 @@ and (encode_sigelt' : (Prims.strcat "equality_tok_" ddtok)) in - FStar_SMTEncoding_Util.mkAssume + FStar_SMTEncoding_Util.mkAssume uu___21 in - [uu___20; - data_cons_typing_intro_decl] in - uu___18 :: - uu___19 in - FStar_Compiler_List.op_At - uu___17 elim in - FStar_SMTEncoding_Term.mk_decls_trivial - uu___16 in - FStar_Compiler_List.op_At - decls_pred uu___15 in - FStar_Compiler_List.op_At - uu___13 uu___14 in - FStar_Compiler_List.op_At - decls3 uu___12 in - FStar_Compiler_List.op_At - decls2 uu___11 in - FStar_Compiler_List.op_At - binder_decls uu___10 in - let uu___10 = - let uu___11 = - FStar_SMTEncoding_Term.mk_decls_trivial - datacons in - FStar_Compiler_List.op_At - uu___11 g in - (uu___10, env1))))))))) -and (encode_sigelts : + [uu___20; + data_cons_typing_intro_decl] in + uu___18 :: + uu___19 in + FStar_Compiler_List.op_At + uu___17 elim in + FStar_SMTEncoding_Term.mk_decls_trivial + uu___16 in + FStar_Compiler_List.op_At + decls_pred uu___15 in + FStar_Compiler_List.op_At + uu___13 uu___14 in + FStar_Compiler_List.op_At + decls3 uu___12 in + FStar_Compiler_List.op_At + decls2 uu___11 in + FStar_Compiler_List.op_At + binder_decls uu___10 in + let uu___10 = + let uu___11 = + FStar_SMTEncoding_Term.mk_decls_trivial + datacons in + FStar_Compiler_List.op_At + uu___11 g in + (uu___10, env1)))))))) +let rec (encode_sigelt : FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.sigelt Prims.list -> + FStar_Syntax_Syntax.sigelt -> (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.env_t)) = fun env -> - fun ses -> - FStar_Compiler_List.fold_left - (fun uu___ -> - fun se -> - match uu___ with - | (g, env1) -> - let uu___1 = encode_sigelt env1 se in - (match uu___1 with - | (g', env2) -> ((FStar_Compiler_List.op_At g g'), env2))) - ([], env) ses + fun se -> + let nm = FStar_Syntax_Print.sigelt_to_string_short se in + let uu___ = + let uu___1 = + let uu___2 = FStar_Syntax_Print.sigelt_to_string_short se in + FStar_Compiler_Util.format1 + "While encoding top-level declaration `%s`" uu___2 in + FStar_Errors.with_ctx uu___1 (fun uu___2 -> encode_sigelt' env se) in + match uu___ with + | (g, env1) -> + let g1 = + match g with + | [] -> + ((let uu___2 = + FStar_TypeChecker_Env.debug + env1.FStar_SMTEncoding_Env.tcenv + (FStar_Options.Other "SMTEncoding") in + if uu___2 + then + FStar_Compiler_Util.print1 "Skipped encoding of %s\n" nm + else ()); + (let uu___2 = + let uu___3 = + let uu___4 = + FStar_Compiler_Util.format1 "" nm in + FStar_SMTEncoding_Term.Caption uu___4 in + [uu___3] in + FStar_SMTEncoding_Term.mk_decls_trivial uu___2)) + | uu___1 -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStar_Compiler_Util.format1 "" nm in + FStar_SMTEncoding_Term.Caption uu___5 in + [uu___4] in + FStar_SMTEncoding_Term.mk_decls_trivial uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStar_Compiler_Util.format1 "" nm in + FStar_SMTEncoding_Term.Caption uu___7 in + [uu___6] in + FStar_SMTEncoding_Term.mk_decls_trivial uu___5 in + FStar_Compiler_List.op_At g uu___4 in + FStar_Compiler_List.op_At uu___2 uu___3 in + (g1, env1) +and (encode_sigelt' : + FStar_SMTEncoding_Env.env_t -> + FStar_Syntax_Syntax.sigelt -> + (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.env_t)) + = + fun env -> + fun se -> + (let uu___1 = + FStar_TypeChecker_Env.debug env.FStar_SMTEncoding_Env.tcenv + (FStar_Options.Other "SMTEncoding") in + if uu___1 + then + let uu___2 = FStar_Syntax_Print.sigelt_to_string se in + FStar_Compiler_Util.print1 "@@@Encoding sigelt %s\n" uu___2 + else ()); + (let is_opaque_to_smt t = + let uu___1 = + let uu___2 = FStar_Syntax_Subst.compress t in + uu___2.FStar_Syntax_Syntax.n in + match uu___1 with + | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_string + (s, uu___2)) -> s = "opaque_to_smt" + | uu___2 -> false in + let is_uninterpreted_by_smt t = + let uu___1 = + let uu___2 = FStar_Syntax_Subst.compress t in + uu___2.FStar_Syntax_Syntax.n in + match uu___1 with + | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_string + (s, uu___2)) -> s = "uninterpreted_by_smt" + | uu___2 -> false in + match se.FStar_Syntax_Syntax.sigel with + | FStar_Syntax_Syntax.Sig_splice uu___1 -> + FStar_Compiler_Effect.failwith + "impossible -- splice should have been removed by Tc.fs" + | FStar_Syntax_Syntax.Sig_fail uu___1 -> + FStar_Compiler_Effect.failwith + "impossible -- Sig_fail should have been removed by Tc.fs" + | FStar_Syntax_Syntax.Sig_pragma uu___1 -> ([], env) + | FStar_Syntax_Syntax.Sig_effect_abbrev uu___1 -> ([], env) + | FStar_Syntax_Syntax.Sig_sub_effect uu___1 -> ([], env) + | FStar_Syntax_Syntax.Sig_polymonadic_bind uu___1 -> ([], env) + | FStar_Syntax_Syntax.Sig_polymonadic_subcomp uu___1 -> ([], env) + | FStar_Syntax_Syntax.Sig_new_effect ed -> + let uu___1 = + let uu___2 = + FStar_SMTEncoding_Util.is_smt_reifiable_effect + env.FStar_SMTEncoding_Env.tcenv ed.FStar_Syntax_Syntax.mname in + Prims.op_Negation uu___2 in + if uu___1 + then ([], env) + else + (let close_effect_params tm = + match ed.FStar_Syntax_Syntax.binders with + | [] -> tm + | uu___3 -> + FStar_Syntax_Syntax.mk + (FStar_Syntax_Syntax.Tm_abs + { + FStar_Syntax_Syntax.bs = + (ed.FStar_Syntax_Syntax.binders); + FStar_Syntax_Syntax.body = tm; + FStar_Syntax_Syntax.rc_opt = + (FStar_Pervasives_Native.Some + (FStar_Syntax_Util.mk_residual_comp + FStar_Parser_Const.effect_Tot_lid + FStar_Pervasives_Native.None + [FStar_Syntax_Syntax.TOTAL])) + }) tm.FStar_Syntax_Syntax.pos in + let encode_action env1 a = + let action_defn = + let uu___3 = + close_effect_params a.FStar_Syntax_Syntax.action_defn in + norm_before_encoding env1 uu___3 in + let uu___3 = + FStar_Syntax_Util.arrow_formals_comp + a.FStar_Syntax_Syntax.action_typ in + match uu___3 with + | (formals, uu___4) -> + let arity = FStar_Compiler_List.length formals in + let uu___5 = + FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid + env1 a.FStar_Syntax_Syntax.action_name arity in + (match uu___5 with + | (aname, atok, env2) -> + let uu___6 = + FStar_SMTEncoding_EncodeTerm.encode_term + action_defn env2 in + (match uu___6 with + | (tm, decls) -> + let a_decls = + let uu___7 = + let uu___8 = + let uu___9 = + FStar_Compiler_List.map + (fun uu___10 -> + FStar_SMTEncoding_Term.Term_sort) + formals in + (aname, uu___9, + FStar_SMTEncoding_Term.Term_sort, + (FStar_Pervasives_Native.Some "Action")) in + FStar_SMTEncoding_Term.DeclFun uu___8 in + [uu___7; + FStar_SMTEncoding_Term.DeclFun + (atok, [], + FStar_SMTEncoding_Term.Term_sort, + (FStar_Pervasives_Native.Some + "Action token"))] in + let uu___7 = + let aux uu___8 uu___9 = + match (uu___8, uu___9) with + | ({ FStar_Syntax_Syntax.binder_bv = bv; + FStar_Syntax_Syntax.binder_qual = + uu___10; + FStar_Syntax_Syntax.binder_positivity + = uu___11; + FStar_Syntax_Syntax.binder_attrs = + uu___12;_}, + (env3, acc_sorts, acc)) -> + let uu___13 = + FStar_SMTEncoding_Env.gen_term_var + env3 bv in + (match uu___13 with + | (xxsym, xx, env4) -> + let uu___14 = + let uu___15 = + FStar_SMTEncoding_Term.mk_fv + (xxsym, + FStar_SMTEncoding_Term.Term_sort) in + uu___15 :: acc_sorts in + (env4, uu___14, (xx :: acc))) in + FStar_Compiler_List.fold_right aux formals + (env2, [], []) in + (match uu___7 with + | (uu___8, xs_sorts, xs) -> + let app = + FStar_SMTEncoding_Util.mkApp (aname, xs) in + let a_eq = + let uu___9 = + let uu___10 = + let uu___11 = + FStar_Ident.range_of_lid + a.FStar_Syntax_Syntax.action_name in + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + FStar_SMTEncoding_EncodeTerm.mk_Apply + tm xs_sorts in + (app, uu___15) in + FStar_SMTEncoding_Util.mkEq + uu___14 in + ([[app]], xs_sorts, uu___13) in + FStar_SMTEncoding_Term.mkForall + uu___11 uu___12 in + (uu___10, + (FStar_Pervasives_Native.Some + "Action equality"), + (Prims.strcat aname "_equality")) in + FStar_SMTEncoding_Util.mkAssume uu___9 in + let tok_correspondence = + let tok_term = + let uu___9 = + FStar_SMTEncoding_Term.mk_fv + (atok, + FStar_SMTEncoding_Term.Term_sort) in + FStar_SMTEncoding_Util.mkFreeV uu___9 in + let tok_app = + FStar_SMTEncoding_EncodeTerm.mk_Apply + tok_term xs_sorts in + let uu___9 = + let uu___10 = + let uu___11 = + FStar_Ident.range_of_lid + a.FStar_Syntax_Syntax.action_name in + let uu___12 = + let uu___13 = + FStar_SMTEncoding_Util.mkEq + (tok_app, app) in + ([[tok_app]], xs_sorts, uu___13) in + FStar_SMTEncoding_Term.mkForall + uu___11 uu___12 in + (uu___10, + (FStar_Pervasives_Native.Some + "Action token correspondence"), + (Prims.strcat aname + "_token_correspondence")) in + FStar_SMTEncoding_Util.mkAssume uu___9 in + let uu___9 = + let uu___10 = + FStar_SMTEncoding_Term.mk_decls_trivial + (FStar_Compiler_List.op_At a_decls + [a_eq; tok_correspondence]) in + FStar_Compiler_List.op_At decls uu___10 in + (env2, uu___9)))) in + let uu___3 = + FStar_Compiler_Util.fold_map encode_action env + ed.FStar_Syntax_Syntax.actions in + match uu___3 with + | (env1, decls2) -> + ((FStar_Compiler_List.flatten decls2), env1)) + | FStar_Syntax_Syntax.Sig_declare_typ + { FStar_Syntax_Syntax.lid2 = lid; + FStar_Syntax_Syntax.us2 = uu___1; + FStar_Syntax_Syntax.t2 = uu___2;_} + when FStar_Ident.lid_equals lid FStar_Parser_Const.precedes_lid -> + let uu___3 = + FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid env lid + (Prims.of_int (4)) in + (match uu___3 with | (tname, ttok, env1) -> ([], env1)) + | FStar_Syntax_Syntax.Sig_declare_typ + { FStar_Syntax_Syntax.lid2 = lid; + FStar_Syntax_Syntax.us2 = uu___1; FStar_Syntax_Syntax.t2 = t;_} + -> + let quals = se.FStar_Syntax_Syntax.sigquals in + let will_encode_definition = + let uu___2 = + FStar_Compiler_Util.for_some + (fun uu___3 -> + match uu___3 with + | FStar_Syntax_Syntax.Assumption -> true + | FStar_Syntax_Syntax.Projector uu___4 -> true + | FStar_Syntax_Syntax.Discriminator uu___4 -> true + | FStar_Syntax_Syntax.Irreducible -> true + | uu___4 -> false) quals in + Prims.op_Negation uu___2 in + if will_encode_definition + then ([], env) + else + (let fv = + FStar_Syntax_Syntax.lid_as_fv lid + FStar_Pervasives_Native.None in + let uu___3 = + let uu___4 = + FStar_Compiler_Util.for_some is_uninterpreted_by_smt + se.FStar_Syntax_Syntax.sigattrs in + encode_top_level_val uu___4 env fv t quals in + match uu___3 with + | (decls, env1) -> + let tname = FStar_Ident.string_of_lid lid in + let tsym = + let uu___4 = + FStar_SMTEncoding_Env.try_lookup_free_var env1 lid in + FStar_Compiler_Option.get uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + primitive_type_axioms + env1.FStar_SMTEncoding_Env.tcenv lid tname tsym in + FStar_SMTEncoding_Term.mk_decls_trivial uu___6 in + FStar_Compiler_List.op_At decls uu___5 in + (uu___4, env1)) + | FStar_Syntax_Syntax.Sig_assume + { FStar_Syntax_Syntax.lid3 = l; FStar_Syntax_Syntax.us3 = us; + FStar_Syntax_Syntax.phi1 = f;_} + -> + let uu___1 = FStar_Syntax_Subst.open_univ_vars us f in + (match uu___1 with + | (uvs, f1) -> + let env1 = + let uu___2 = + FStar_TypeChecker_Env.push_univ_vars + env.FStar_SMTEncoding_Env.tcenv uvs in + { + FStar_SMTEncoding_Env.bvar_bindings = + (env.FStar_SMTEncoding_Env.bvar_bindings); + FStar_SMTEncoding_Env.fvar_bindings = + (env.FStar_SMTEncoding_Env.fvar_bindings); + FStar_SMTEncoding_Env.depth = + (env.FStar_SMTEncoding_Env.depth); + FStar_SMTEncoding_Env.tcenv = uu___2; + FStar_SMTEncoding_Env.warn = + (env.FStar_SMTEncoding_Env.warn); + FStar_SMTEncoding_Env.nolabels = + (env.FStar_SMTEncoding_Env.nolabels); + FStar_SMTEncoding_Env.use_zfuel_name = + (env.FStar_SMTEncoding_Env.use_zfuel_name); + FStar_SMTEncoding_Env.encode_non_total_function_typ = + (env.FStar_SMTEncoding_Env.encode_non_total_function_typ); + FStar_SMTEncoding_Env.current_module_name = + (env.FStar_SMTEncoding_Env.current_module_name); + FStar_SMTEncoding_Env.encoding_quantifier = + (env.FStar_SMTEncoding_Env.encoding_quantifier); + FStar_SMTEncoding_Env.global_cache = + (env.FStar_SMTEncoding_Env.global_cache) + } in + let f2 = norm_before_encoding env1 f1 in + let uu___2 = + FStar_SMTEncoding_EncodeTerm.encode_formula f2 env1 in + (match uu___2 with + | (f3, decls) -> + let g = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStar_Syntax_Print.lid_to_string l in + FStar_Compiler_Util.format1 "Assumption: %s" + uu___8 in + FStar_Pervasives_Native.Some uu___7 in + let uu___7 = + let uu___8 = + let uu___9 = FStar_Ident.string_of_lid l in + Prims.strcat "assumption_" uu___9 in + FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.mk_unique + uu___8 in + (f3, uu___6, uu___7) in + FStar_SMTEncoding_Util.mkAssume uu___5 in + [uu___4] in + FStar_SMTEncoding_Term.mk_decls_trivial uu___3 in + ((FStar_Compiler_List.op_At decls g), env1))) + | FStar_Syntax_Syntax.Sig_let + { FStar_Syntax_Syntax.lbs1 = lbs; + FStar_Syntax_Syntax.lids1 = uu___1;_} + when + (FStar_Compiler_List.contains FStar_Syntax_Syntax.Irreducible + se.FStar_Syntax_Syntax.sigquals) + || + (FStar_Compiler_Util.for_some is_opaque_to_smt + se.FStar_Syntax_Syntax.sigattrs) + -> + let attrs = se.FStar_Syntax_Syntax.sigattrs in + let uu___2 = + FStar_Compiler_Util.fold_map + (fun env1 -> + fun lb -> + let lid = + let uu___3 = + let uu___4 = + FStar_Compiler_Util.right + lb.FStar_Syntax_Syntax.lbname in + uu___4.FStar_Syntax_Syntax.fv_name in + uu___3.FStar_Syntax_Syntax.v in + let uu___3 = + let uu___4 = + FStar_TypeChecker_Env.try_lookup_val_decl + env1.FStar_SMTEncoding_Env.tcenv lid in + FStar_Compiler_Option.isNone uu___4 in + if uu___3 + then + let val_decl = + { + FStar_Syntax_Syntax.sigel = + (FStar_Syntax_Syntax.Sig_declare_typ + { + FStar_Syntax_Syntax.lid2 = lid; + FStar_Syntax_Syntax.us2 = + (lb.FStar_Syntax_Syntax.lbunivs); + FStar_Syntax_Syntax.t2 = + (lb.FStar_Syntax_Syntax.lbtyp) + }); + FStar_Syntax_Syntax.sigrng = + (se.FStar_Syntax_Syntax.sigrng); + FStar_Syntax_Syntax.sigquals = + (FStar_Syntax_Syntax.Irreducible :: + (se.FStar_Syntax_Syntax.sigquals)); + FStar_Syntax_Syntax.sigmeta = + (se.FStar_Syntax_Syntax.sigmeta); + FStar_Syntax_Syntax.sigattrs = + (se.FStar_Syntax_Syntax.sigattrs); + FStar_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); + FStar_Syntax_Syntax.sigopts = + (se.FStar_Syntax_Syntax.sigopts) + } in + let uu___4 = encode_sigelt' env1 val_decl in + match uu___4 with | (decls, env2) -> (env2, decls) + else (env1, [])) env (FStar_Pervasives_Native.snd lbs) in + (match uu___2 with + | (env1, decls) -> ((FStar_Compiler_List.flatten decls), env1)) + | FStar_Syntax_Syntax.Sig_let + { + FStar_Syntax_Syntax.lbs1 = + (uu___1, + { FStar_Syntax_Syntax.lbname = FStar_Pervasives.Inr b2t; + FStar_Syntax_Syntax.lbunivs = uu___2; + FStar_Syntax_Syntax.lbtyp = uu___3; + FStar_Syntax_Syntax.lbeff = uu___4; + FStar_Syntax_Syntax.lbdef = uu___5; + FStar_Syntax_Syntax.lbattrs = uu___6; + FStar_Syntax_Syntax.lbpos = uu___7;_}::[]); + FStar_Syntax_Syntax.lids1 = uu___8;_} + when FStar_Syntax_Syntax.fv_eq_lid b2t FStar_Parser_Const.b2t_lid + -> + let uu___9 = + FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid env + (b2t.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v + Prims.int_one in + (match uu___9 with + | (tname, ttok, env1) -> + let xx = + FStar_SMTEncoding_Term.mk_fv + ("x", FStar_SMTEncoding_Term.Term_sort) in + let x = FStar_SMTEncoding_Util.mkFreeV xx in + let b2t_x = FStar_SMTEncoding_Util.mkApp ("Prims.b2t", [x]) in + let valid_b2t_x = + FStar_SMTEncoding_Util.mkApp ("Valid", [b2t_x]) in + let bool_ty = + let uu___10 = + FStar_Syntax_Syntax.withsort FStar_Parser_Const.bool_lid in + FStar_SMTEncoding_Env.lookup_free_var env1 uu___10 in + let decls = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = FStar_Syntax_Syntax.range_of_fv b2t in + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + FStar_SMTEncoding_Util.mkApp + ((FStar_Pervasives_Native.snd + FStar_SMTEncoding_Term.boxBoolFun), + [x]) in + (valid_b2t_x, uu___18) in + FStar_SMTEncoding_Util.mkEq uu___17 in + ([[b2t_x]], [xx], uu___16) in + FStar_SMTEncoding_Term.mkForall uu___14 uu___15 in + (uu___13, (FStar_Pervasives_Native.Some "b2t def"), + "b2t_def") in + FStar_SMTEncoding_Util.mkAssume uu___12 in + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = FStar_Syntax_Syntax.range_of_fv b2t in + let uu___17 = + let uu___18 = + let uu___19 = + let uu___20 = + FStar_SMTEncoding_Term.mk_HasType x + bool_ty in + let uu___21 = + FStar_SMTEncoding_Term.mk_HasType b2t_x + FStar_SMTEncoding_Term.mk_Term_type in + (uu___20, uu___21) in + FStar_SMTEncoding_Util.mkImp uu___19 in + ([[b2t_x]], [xx], uu___18) in + FStar_SMTEncoding_Term.mkForall uu___16 uu___17 in + (uu___15, + (FStar_Pervasives_Native.Some "b2t typing"), + "b2t_typing") in + FStar_SMTEncoding_Util.mkAssume uu___14 in + [uu___13] in + uu___11 :: uu___12 in + (FStar_SMTEncoding_Term.DeclFun + (tname, [FStar_SMTEncoding_Term.Term_sort], + FStar_SMTEncoding_Term.Term_sort, + FStar_Pervasives_Native.None)) + :: uu___10 in + let uu___10 = FStar_SMTEncoding_Term.mk_decls_trivial decls in + (uu___10, env1)) + | FStar_Syntax_Syntax.Sig_let uu___1 when + FStar_Compiler_Util.for_some + (fun uu___2 -> + match uu___2 with + | FStar_Syntax_Syntax.Discriminator uu___3 -> true + | uu___3 -> false) se.FStar_Syntax_Syntax.sigquals + -> + ((let uu___3 = + FStar_TypeChecker_Env.debug env.FStar_SMTEncoding_Env.tcenv + (FStar_Options.Other "SMTEncoding") in + if uu___3 + then + let uu___4 = FStar_Syntax_Print.sigelt_to_string_short se in + FStar_Compiler_Util.print1 "Not encoding discriminator '%s'\n" + uu___4 + else ()); + ([], env)) + | FStar_Syntax_Syntax.Sig_let + { FStar_Syntax_Syntax.lbs1 = uu___1; + FStar_Syntax_Syntax.lids1 = lids;_} + when + (FStar_Compiler_Util.for_some + (fun l -> + let uu___2 = + let uu___3 = + let uu___4 = FStar_Ident.ns_of_lid l in + FStar_Compiler_List.hd uu___4 in + FStar_Ident.string_of_id uu___3 in + uu___2 = "Prims") lids) + && + (FStar_Compiler_Util.for_some + (fun uu___2 -> + match uu___2 with + | FStar_Syntax_Syntax.Unfold_for_unification_and_vcgen -> + true + | uu___3 -> false) se.FStar_Syntax_Syntax.sigquals) + -> + ((let uu___3 = + FStar_TypeChecker_Env.debug env.FStar_SMTEncoding_Env.tcenv + (FStar_Options.Other "SMTEncoding") in + if uu___3 + then + let uu___4 = FStar_Syntax_Print.sigelt_to_string_short se in + FStar_Compiler_Util.print1 + "Not encoding unfold let from Prims '%s'\n" uu___4 + else ()); + ([], env)) + | FStar_Syntax_Syntax.Sig_let + { FStar_Syntax_Syntax.lbs1 = (false, lb::[]); + FStar_Syntax_Syntax.lids1 = uu___1;_} + when + FStar_Compiler_Util.for_some + (fun uu___2 -> + match uu___2 with + | FStar_Syntax_Syntax.Projector uu___3 -> true + | uu___3 -> false) se.FStar_Syntax_Syntax.sigquals + -> + let fv = FStar_Compiler_Util.right lb.FStar_Syntax_Syntax.lbname in + let l = (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in + let uu___2 = FStar_SMTEncoding_Env.try_lookup_free_var env l in + (match uu___2 with + | FStar_Pervasives_Native.Some uu___3 -> ([], env) + | FStar_Pervasives_Native.None -> + let se1 = + let uu___3 = FStar_Ident.range_of_lid l in + { + FStar_Syntax_Syntax.sigel = + (FStar_Syntax_Syntax.Sig_declare_typ + { + FStar_Syntax_Syntax.lid2 = l; + FStar_Syntax_Syntax.us2 = + (lb.FStar_Syntax_Syntax.lbunivs); + FStar_Syntax_Syntax.t2 = + (lb.FStar_Syntax_Syntax.lbtyp) + }); + FStar_Syntax_Syntax.sigrng = uu___3; + FStar_Syntax_Syntax.sigquals = + (se.FStar_Syntax_Syntax.sigquals); + FStar_Syntax_Syntax.sigmeta = + (se.FStar_Syntax_Syntax.sigmeta); + FStar_Syntax_Syntax.sigattrs = + (se.FStar_Syntax_Syntax.sigattrs); + FStar_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); + FStar_Syntax_Syntax.sigopts = + (se.FStar_Syntax_Syntax.sigopts) + } in + encode_sigelt env se1) + | FStar_Syntax_Syntax.Sig_let + { FStar_Syntax_Syntax.lbs1 = (is_rec, bindings); + FStar_Syntax_Syntax.lids1 = uu___1;_} + -> + let bindings1 = + FStar_Compiler_List.map + (fun lb -> + let def = + norm_before_encoding env lb.FStar_Syntax_Syntax.lbdef in + let typ = + norm_before_encoding env lb.FStar_Syntax_Syntax.lbtyp in + { + FStar_Syntax_Syntax.lbname = + (lb.FStar_Syntax_Syntax.lbname); + FStar_Syntax_Syntax.lbunivs = + (lb.FStar_Syntax_Syntax.lbunivs); + FStar_Syntax_Syntax.lbtyp = typ; + FStar_Syntax_Syntax.lbeff = + (lb.FStar_Syntax_Syntax.lbeff); + FStar_Syntax_Syntax.lbdef = def; + FStar_Syntax_Syntax.lbattrs = + (lb.FStar_Syntax_Syntax.lbattrs); + FStar_Syntax_Syntax.lbpos = + (lb.FStar_Syntax_Syntax.lbpos) + }) bindings in + encode_top_level_let env (is_rec, bindings1) + se.FStar_Syntax_Syntax.sigquals + | FStar_Syntax_Syntax.Sig_bundle + { FStar_Syntax_Syntax.ses = ses; + FStar_Syntax_Syntax.lids = uu___1;_} + -> + let tycon = + FStar_Compiler_List.tryFind + (fun se1 -> + FStar_Syntax_Syntax.uu___is_Sig_inductive_typ + se1.FStar_Syntax_Syntax.sigel) ses in + let is_injective_on_params = + match tycon with + | FStar_Pervasives_Native.None -> + FStar_Compiler_Effect.failwith + "Impossible: Sig_bundle without a Sig_inductive_typ" + | FStar_Pervasives_Native.Some se1 -> + is_sig_inductive_injective_on_params env se1 in + let uu___2 = + FStar_Compiler_List.fold_left + (fun uu___3 -> + fun se1 -> + match uu___3 with + | (g, env1) -> + let uu___4 = + match se1.FStar_Syntax_Syntax.sigel with + | FStar_Syntax_Syntax.Sig_inductive_typ uu___5 -> + encode_sig_inductive is_injective_on_params + env1 se1 + | FStar_Syntax_Syntax.Sig_datacon uu___5 -> + encode_datacon is_injective_on_params env1 se1 + | uu___5 -> encode_sigelt env1 se1 in + (match uu___4 with + | (g', env2) -> + ((FStar_Compiler_List.op_At g g'), env2))) + ([], env) ses in + (match uu___2 with + | (g, env1) -> + let uu___3 = + FStar_Compiler_List.fold_left + (fun uu___4 -> + fun elt -> + match uu___4 with + | (g', inversions) -> + let uu___5 = + FStar_Compiler_List.partition + (fun uu___6 -> + match uu___6 with + | FStar_SMTEncoding_Term.Assume + { + FStar_SMTEncoding_Term.assumption_term + = uu___7; + FStar_SMTEncoding_Term.assumption_caption + = FStar_Pervasives_Native.Some + "inversion axiom"; + FStar_SMTEncoding_Term.assumption_name + = uu___8; + FStar_SMTEncoding_Term.assumption_fact_ids + = uu___9;_} + -> false + | uu___7 -> true) + elt.FStar_SMTEncoding_Term.decls in + (match uu___5 with + | (elt_g', elt_inversions) -> + ((FStar_Compiler_List.op_At g' + [{ + FStar_SMTEncoding_Term.sym_name = + (elt.FStar_SMTEncoding_Term.sym_name); + FStar_SMTEncoding_Term.key = + (elt.FStar_SMTEncoding_Term.key); + FStar_SMTEncoding_Term.decls = + elt_g'; + FStar_SMTEncoding_Term.a_names = + (elt.FStar_SMTEncoding_Term.a_names) + }]), + (FStar_Compiler_List.op_At inversions + elt_inversions)))) ([], []) g in + (match uu___3 with + | (g', inversions) -> + let uu___4 = + FStar_Compiler_List.fold_left + (fun uu___5 -> + fun elt -> + match uu___5 with + | (decls, elts, rest) -> + let uu___6 = + (FStar_Compiler_Util.is_some + elt.FStar_SMTEncoding_Term.key) + && + (FStar_Compiler_List.existsb + (fun uu___7 -> + match uu___7 with + | FStar_SMTEncoding_Term.DeclFun + uu___8 -> true + | uu___8 -> false) + elt.FStar_SMTEncoding_Term.decls) in + if uu___6 + then + (decls, + (FStar_Compiler_List.op_At elts [elt]), + rest) + else + (let uu___8 = + FStar_Compiler_List.partition + (fun uu___9 -> + match uu___9 with + | FStar_SMTEncoding_Term.DeclFun + uu___10 -> true + | uu___10 -> false) + elt.FStar_SMTEncoding_Term.decls in + match uu___8 with + | (elt_decls, elt_rest) -> + ((FStar_Compiler_List.op_At decls + elt_decls), elts, + (FStar_Compiler_List.op_At rest + [{ + FStar_SMTEncoding_Term.sym_name + = + (elt.FStar_SMTEncoding_Term.sym_name); + FStar_SMTEncoding_Term.key = + (elt.FStar_SMTEncoding_Term.key); + FStar_SMTEncoding_Term.decls + = elt_rest; + FStar_SMTEncoding_Term.a_names + = + (elt.FStar_SMTEncoding_Term.a_names) + }])))) ([], [], []) g' in + (match uu___4 with + | (decls, elts, rest) -> + let uu___5 = + let uu___6 = + FStar_SMTEncoding_Term.mk_decls_trivial decls in + let uu___7 = + let uu___8 = + let uu___9 = + FStar_SMTEncoding_Term.mk_decls_trivial + inversions in + FStar_Compiler_List.op_At rest uu___9 in + FStar_Compiler_List.op_At elts uu___8 in + FStar_Compiler_List.op_At uu___6 uu___7 in + (uu___5, env1))))) let (encode_env_bindings : FStar_SMTEncoding_Env.env_t -> FStar_Syntax_Syntax.binding Prims.list -> diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst index dc6e2598d7e..0f55936367d 100644 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ b/src/smtencoding/FStar.SMTEncoding.Encode.fst @@ -1000,6 +1000,542 @@ let encode_top_level_let : [decl] |> mk_decls_trivial, env +let is_sig_inductive_injective_on_params (env:env_t) (se:sigelt) + : bool + = let Sig_inductive_typ { lid=t; us=universe_names; params=tps; t=k } = se.sigel in + let t_lid = t in + let tcenv = env.tcenv in + let usubst, uvs = SS.univ_var_opening universe_names in + let tcenv, tps, k = + Env.push_univ_vars tcenv uvs, + SS.subst_binders usubst tps, + SS.subst (SS.shift_subst (List.length tps) usubst) k + in + let tps, k = SS.open_term tps k in + let _, k = U.arrow_formals k in //don't care about indices here + let tps, env_tps, _, us = TcTerm.tc_binders tcenv tps in + let u_k = + TcTerm.level_of_type + env_tps + (S.mk_Tm_app + (S.fvar t None) + (snd (U.args_of_binders tps)) + (Ident.range_of_lid t)) + k + in + //BU.print2 "Universe of tycon: %s : %s\n" (Ident.string_of_lid t) (Print.univ_to_string u_k); + let rec universe_leq u v = + match u, v with + | U_zero, _ -> true + | U_succ u0, U_succ v0 -> universe_leq u0 v0 + | U_name u0, U_name v0 -> Ident.ident_equals u0 v0 + | U_name _, U_succ v0 -> universe_leq u v0 + | U_max us, _ -> us |> BU.for_all (fun u -> universe_leq u v) + | _, U_max vs -> vs |> BU.for_some (universe_leq u) + | U_unknown, _ + | _, U_unknown + | U_unif _, _ + | _, U_unif _ -> failwith (BU.format3 "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + (Ident.string_of_lid t) + (Print.univ_to_string u) + (Print.univ_to_string v)) + | _ -> false + in + let u_leq_u_k u = + let u = N.normalize_universe env_tps u in + universe_leq u u_k + in + let tp_ok (tp:S.binder) (u_tp:universe) = + let t_tp = tp.binder_bv.sort in + if u_leq_u_k u_tp + then true + else ( + let t_tp = + N.normalize + [Unrefine; Unascribe; Unmeta; + Primops; HNF; UnfoldUntil delta_constant; Beta] + env_tps t_tp + in + let formals, t = U.arrow_formals t_tp in + let _, _, _, u_formals = TcTerm.tc_binders env_tps formals in + let inj = BU.for_all (fun u_formal -> u_leq_u_k u_formal) u_formals in + if inj + then ( + match (SS.compress t).n with + | Tm_type u -> + (* retain injectivity for parameters that are type functions + from small universes (i.e., all formals are smaller than the constructed type) + to a universe <= the universe of the constructed type. + See BugBoxInjectivity.fst *) + u_leq_u_k u + | _ -> + false + ) + else ( + false + ) + + ) + in + let is_injective_on_params = List.forall2 tp_ok tps us in + if Env.debug env.tcenv <| Options.Other "SMTEncoding" + then BU.print2 "%s injectivity for %s\n" + (if is_injective_on_params then "YES" else "NO") + (Ident.string_of_lid t); + is_injective_on_params + + +let encode_sig_inductive (is_injective_on_params:bool) (env:env_t) (se:sigelt) +: decls_t * env_t += let Sig_inductive_typ { lid=t; us=universe_names; params=tps; t=k; ds=datas} = se.sigel in + let t_lid = t in + let tcenv = env.tcenv in + let quals = se.sigquals in + let is_logical = quals |> BU.for_some (function Logic | Assumption -> true | _ -> false) in + let constructor_or_logic_type_decl (c:constructor_t) = + if is_logical + then [Term.DeclFun(c.constr_name, c.constr_fields |> List.map (fun f -> f.field_sort), Term_sort, None)] + else constructor_to_decl (Ident.range_of_lid t) c in + let inversion_axioms env tapp vars = + if datas |> BU.for_some (fun l -> Env.try_lookup_lid env.tcenv l |> Option.isNone) //Q: Why would this happen? + then [] + else ( + let xxsym, xx = fresh_fvar env.current_module_name "x" Term_sort in + let data_ax, decls = + datas |> + List.fold_left + (fun (out, decls) l -> + let _, data_t = Env.lookup_datacon env.tcenv l in + let args, res = U.arrow_formals data_t in + let indices = res |> U.head_and_args_full |> snd in + let env = args |> List.fold_left + (fun env ({binder_bv=x}) -> push_term_var env x (mkApp(mk_term_projector_name l x, [xx]))) + env in + let indices, decls' = encode_args indices env in + if List.length indices <> List.length vars + then failwith "Impossible"; + let eqs = + if is_injective_on_params + || Options.ext_getv "compat:injectivity" <> "" + then List.map2 (fun v a -> mkEq(mkFreeV v, a)) vars indices + else ( + //only injectivity on indices + let num_params = List.length tps in + let _var_params, var_indices = List.splitAt num_params vars in + let _i_params, indices = List.splitAt num_params indices in + List.map2 (fun v a -> mkEq(mkFreeV v, a)) var_indices indices + ) + in + mkOr(out, mkAnd(mk_data_tester env l xx, eqs |> mk_and_l)), decls@decls') + (mkFalse, []) + in + let ffsym, ff = fresh_fvar env.current_module_name "f" Fuel_sort in + let fuel_guarded_inversion = + let xx_has_type_sfuel = + if List.length datas > 1 + then mk_HasTypeFuel (mkApp("SFuel", [ff])) xx tapp + else mk_HasTypeFuel ff xx tapp //no point requiring non-zero fuel if there are no disjunctions + in + Util.mkAssume( + mkForall + (Ident.range_of_lid t) + ([[xx_has_type_sfuel]], + add_fuel (mk_fv (ffsym, Fuel_sort)) (mk_fv (xxsym, Term_sort)::vars), + mkImp(xx_has_type_sfuel, data_ax)), + Some "inversion axiom", //this name matters! see Sig_bundle case near line 1493 + (varops.mk_unique ("fuel_guarded_inversion_"^(string_of_lid t)))) + in + decls + @([fuel_guarded_inversion] |> mk_decls_trivial) + ) + in + let formals, res = + let k = + match tps with + | [] -> k + | _ -> S.mk (Tm_arrow {bs=tps; comp=S.mk_Total k}) k.pos + in + let k = norm_before_encoding env k in + U.arrow_formals k + in + let vars, guards, env', binder_decls, _ = encode_binders None formals env in + let arity = List.length vars in + let tname, ttok, env = new_term_constant_and_tok_from_lid env t arity in + let ttok_tm = mkApp(ttok, []) in + let guard = mk_and_l guards in + let tapp = mkApp(tname, List.map mkFreeV vars) in //arity ok + let decls, env = + //See: https://github.com/FStarLang/FStar/commit/b75225bfbe427c8aef5b59f70ff6d79aa014f0b4 + //See: https://github.com/FStarLang/FStar/issues/349 + let tname_decl = + constructor_or_logic_type_decl + { + constr_name = tname; + constr_fields = vars |> List.map (fun fv -> {field_name=tname^fv_name fv; field_sort=fv_sort fv; field_projectible=false}) ; + //The field_projectible=false above is extremely important; it makes sure that type-formers are not injective + constr_sort=Term_sort; + constr_id=Some (varops.next_id()) + } + in + let tok_decls, env = + match vars with + | [] -> [], push_free_var env t arity tname (Some <| mkApp(tname, [])) + | _ -> + let ttok_decl = Term.DeclFun(ttok, [], Term_sort, Some "token") in + let ttok_fresh = Term.fresh_token (ttok, Term_sort) (varops.next_id()) in + let ttok_app = mk_Apply ttok_tm vars in + let pats = [[ttok_app]; [tapp]] in + // These patterns allow rewriting (ApplyT T@tok args) to (T args) and vice versa + // This seems necessary for some proofs, but the bidirectional rewriting may be inefficient + let name_tok_corr = + Util.mkAssume(mkForall' (Ident.range_of_lid t) (pats, None, vars, mkEq(ttok_app, tapp)), + Some "name-token correspondence", + ("token_correspondence_"^ttok)) in + [ttok_decl; ttok_fresh; name_tok_corr], env + in + tname_decl@tok_decls, env + in + let kindingAx = + let k, decls = encode_term_pred None res env' tapp in + let karr = + if List.length formals > 0 + then [Util.mkAssume(mk_tester "Tm_arrow" (mk_PreType ttok_tm), Some "kinding", ("pre_kinding_"^ttok))] + else [] + in + let rng = Ident.range_of_lid t in + let tot_fun_axioms = EncodeTerm.isTotFun_axioms rng ttok_tm vars (List.map (fun _ -> mkTrue) vars) true in + decls@(karr@[Util.mkAssume(mkAnd(tot_fun_axioms, mkForall rng ([[tapp]], vars, mkImp(guard, k))), + None, + ("kinding_"^ttok))] |> mk_decls_trivial) + in + let aux = + kindingAx + @(inversion_axioms env tapp vars) + @([pretype_axiom (Ident.range_of_lid t) env tapp vars] |> mk_decls_trivial) + in + (decls |> mk_decls_trivial)@binder_decls@aux, env + +let encode_datacon (is_injective_on_tparams:bool) (env:env_t) (se:sigelt) +: decls_t * env_t += let Sig_datacon {lid=d; t; num_ty_params=n_tps; mutuals} = se.sigel in + let quals = se.sigquals in + let t = norm_before_encoding env t in + let formals, t_res = U.arrow_formals t in + let arity = List.length formals in + let ddconstrsym, ddtok, env = new_term_constant_and_tok_from_lid env d arity in + let ddtok_tm = mkApp(ddtok, []) in + let fuel_var, fuel_tm = fresh_fvar env.current_module_name "f" Fuel_sort in + let s_fuel_tm = mkApp("SFuel", [fuel_tm]) in + let vars, guards, env', binder_decls, names = encode_binders (Some fuel_tm) formals env in + let fields = names |> List.mapi (fun n x -> + { field_name=mk_term_projector_name d x; + field_sort=Term_sort; + field_projectible=true }) + in + let datacons = + {constr_name=ddconstrsym; + constr_fields=fields; + constr_sort=Term_sort; + constr_id=Some (varops.next_id()) + } |> Term.constructor_to_decl (Ident.range_of_lid d) in + let app = mk_Apply ddtok_tm vars in + let guard = mk_and_l guards in + let xvars = List.map mkFreeV vars in + let dapp = mkApp(ddconstrsym, xvars) in //arity ok; |xvars| = |formals| = arity + + let tok_typing, decls3 = encode_term_pred None t env ddtok_tm in + let tok_typing = + match fields with + | _::_ -> + let ff = mk_fv ("ty", Term_sort) in + let f = mkFreeV ff in + let vtok_app_l = mk_Apply ddtok_tm [ff] in + let vtok_app_r = mk_Apply f [mk_fv (ddtok, Term_sort)] in + //guard the token typing assumption with a Apply(tok, f) or Apply(f, tok) + //Additionally, the body of the term becomes NoHoist f (HasType tok ...) + // to prevent the Z3 simplifier from hoisting the (HasType tok ...) part out + //Since the top-levels of modules are full of function typed terms + //not guarding it this way causes every typing assumption of an arrow type to be fired immediately + //regardless of whether or not the function is used ... leading to bloat + //these patterns aim to restrict the use of the typing assumption until such point as it is actually needed + mkForall (Ident.range_of_lid d) + ([[vtok_app_l]; [vtok_app_r]], + [ff], + Term.mk_NoHoist f tok_typing) + | _ -> tok_typing in + let ty_pred', t_res_tm, decls_pred = + let t_res_tm, t_res_decls = encode_term t_res env' in + mk_HasTypeWithFuel (Some fuel_tm) dapp t_res_tm, t_res_tm, t_res_decls in + let proxy_fresh = match formals with + | [] -> [] + | _ -> [Term.fresh_token (ddtok, Term_sort) (varops.next_id())] in + + let encode_elim () = + let head, args = U.head_and_args t_res in + match (SS.compress head).n with + | Tm_uinst({n=Tm_fvar fv}, _) + | Tm_fvar fv -> + let encoded_head_fvb = lookup_free_var_name env' fv.fv_name in + let encoded_args, arg_decls = encode_args args env' in + let guards_for_parameter (orig_arg:S.term)(arg:term) xv = + let fv = + match arg.tm with + | FreeV fv -> fv + | _ -> + Errors.raise_error (Errors.Fatal_NonVariableInductiveTypeParameter, + BU.format1 "Inductive type parameter %s must be a variable ; \ + You may want to change it to an index." + (FStar.Syntax.Print.term_to_string orig_arg)) orig_arg.pos + in + let guards = guards |> List.collect (fun g -> + if List.contains fv (Term.free_variables g) + then [Term.subst g fv xv] + else []) + in + mk_and_l guards + in + let _, arg_vars, elim_eqns_or_guards, _ = + List.fold_left + (fun (env, arg_vars, eqns_or_guards, i) (orig_arg, arg) -> + let _, xv, env = gen_term_var env (S.new_bv None tun) in + (* we only get equations induced on the type indices, not parameters; *) + (* Also see https://github.com/FStarLang/FStar/issues/349 *) + let eqns = + if i < n_tps + then guards_for_parameter (fst orig_arg) arg xv::eqns_or_guards + else mkEq(arg, xv)::eqns_or_guards + in + (env, xv::arg_vars, eqns, i + 1)) + (env', [], [], 0) + (FStar.Compiler.List.zip args encoded_args) + in + let arg_vars = List.rev arg_vars in + let ty = maybe_curry_fvb fv.fv_name.p encoded_head_fvb arg_vars in + let xvars = List.map mkFreeV vars in + let dapp = mkApp(ddconstrsym, xvars) in //arity ok; |xvars| = |formals| = arity + let ty_pred = mk_HasTypeWithFuel (Some s_fuel_tm) dapp ty in + let arg_binders = List.map fv_of_term arg_vars in + let typing_inversion = + Util.mkAssume(mkForall (Ident.range_of_lid d) ([[ty_pred]], + add_fuel (mk_fv (fuel_var, Fuel_sort)) (vars@arg_binders), + mkImp(ty_pred, mk_and_l (elim_eqns_or_guards@guards))), + Some "data constructor typing elim", + ("data_elim_" ^ ddconstrsym)) in + let lex_t = mkFreeV <| mk_fv (string_of_lid Const.lex_t_lid, Term_sort) in + let subterm_ordering = + (* subterm ordering *) + let prec = + vars + |> List.mapi (fun i v -> + (* it's a parameter, so it's inaccessible and no need for a sub-term ordering on it *) + if i < n_tps + then [] + else [mk_Precedes lex_t lex_t (mkFreeV v) dapp]) + |> List.flatten + in + Util.mkAssume(mkForall (Ident.range_of_lid d) + ([[ty_pred]], + add_fuel (mk_fv (fuel_var, Fuel_sort)) (vars@arg_binders), + mkImp(ty_pred, mk_and_l prec)), + Some "subterm ordering", + ("subterm_ordering_"^ddconstrsym)) + in + let codomain_ordering, codomain_decls = + let _, formals' = BU.first_N n_tps formals in (* no codomain ordering for the parameters *) + let _, vars' = BU.first_N n_tps vars in + let norm t = + N.unfold_whnf' [Env.AllowUnboundUniverses; + Env.EraseUniverses; + Env.Unascribe; + //we don't know if this will terminate; so don't do recursive steps + Env.Exclude Env.Zeta] + env'.tcenv + t + in + let warn_compat () = + FStar.Errors.log_issue + (S.range_of_fv fv) + (FStar.Errors.Warning_DeprecatedGeneric, + "Using 'compat:2954' to use a permissive encoding of the subterm ordering on the codomain of a constructor.\n\ + This is deprecated and will be removed in a future version of F*.") + in + let codomain_prec_l, cod_decls = + List.fold_left2 + (fun (codomain_prec_l, cod_decls) formal var -> + let rec binder_and_codomain_type t = + let t = U.unrefine t in + match (SS.compress t).n with + | Tm_arrow _ -> + let bs, c = U.arrow_formals_comp (U.unrefine t) in + begin + match bs with + | [] -> None + | _ when not (U.is_tot_or_gtot_comp c) -> None + | _ -> + if U.is_lemma_comp c + then None //not useful for lemmas + else + let t = U.unrefine (U.comp_result c) in + let t = norm t in + if is_type t || U.is_sub_singleton t + then None //ordering on Type and squashed values is not useful + else ( + let head, _ = U.head_and_args_full t in + match (U.un_uinst head).n with + | Tm_fvar fv -> + if BU.for_some (S.fv_eq_lid fv) mutuals + then Some (bs, c) + else if Options.ext_getv "compat:2954" <> "" + then (warn_compat(); Some (bs, c)) //compatibility mode + else None + | _ -> + if Options.ext_getv "compat:2954" <> "" + then (warn_compat(); Some (bs, c)) //compatibility mode + else None + ) + end + | _ -> + let head, _ = U.head_and_args t in + let t' = norm t in + let head', _ = U.head_and_args t' in + match U.eq_tm head head' with + | U.Equal -> None //no progress after whnf + | U.NotEqual -> binder_and_codomain_type t' + | _ -> + //Did we actually make progress? Be conservative to avoid an infinite loop + match (SS.compress head).n with + | Tm_fvar _ + | Tm_name _ + | Tm_uinst _ -> + //The underlying name must have changed, otherwise we would have got Equal + //so, we made some progress + binder_and_codomain_type t' + | _ -> + //unclear if we made progress or not + None + + in + match binder_and_codomain_type formal.binder_bv.sort with + | None -> + codomain_prec_l, cod_decls + | Some (bs, c) -> + //var bs << D ... var ... + let bs', guards', _env', bs_decls, _ = encode_binders None bs env' in + let fun_app = mk_Apply (mkFreeV var) bs' in + mkForall (Ident.range_of_lid d) + ([[mk_Precedes lex_t lex_t fun_app dapp]], + bs', + //need to use ty_pred' here, to avoid variable capture + //Note, ty_pred' is indexed by fuel, not S_fuel + //That's ok, since the outer pattern is guarded on S_fuel + mkImp (mk_and_l (ty_pred'::guards'), + mk_Precedes lex_t lex_t fun_app dapp)) + :: codomain_prec_l, + bs_decls @ cod_decls) + ([],[]) + formals' + vars' + in + match codomain_prec_l with + | [] -> + [], cod_decls + | _ -> + [Util.mkAssume(mkForall (Ident.range_of_lid d) + ([[ty_pred]],//we use ty_pred here as the pattern, which has an S_fuel guard + add_fuel (mk_fv (fuel_var, Fuel_sort)) (vars@arg_binders), + mk_and_l codomain_prec_l), + Some "well-founded ordering on codomain", + ("well_founded_ordering_on_codomain_"^ddconstrsym))], + cod_decls + in + arg_decls @ codomain_decls, + [typing_inversion; subterm_ordering] @ codomain_ordering + + | _ -> + Errors.log_issue se.sigrng + (Errors.Warning_ConstructorBuildsUnexpectedType, + BU.format2 "Constructor %s builds an unexpected type %s\n" + (Print.lid_to_string d) (Print.term_to_string head)); + [], [] + in + let decls2, elim = encode_elim () in + let data_cons_typing_intro_decl = + // + //AR: + // + //Typing intro for the data constructor + // + //We do a bit of manipulation for type indices + //Consider the Cons data constructor of a length-indexed vector type: + // type vector : nat -> Type = | Emp : vector 0 + // | Cons: n:nat -> hd:nat -> tl:vec n -> vec (n+1) + // + //So far we have + // ty_pred' = HasTypeFuel f (Cons n hd tl) (vector (n+1)) + // vars = n, hd, tl + // guard = And of typing guards for n, hd, tl (i.e. (HasType n nat) etc.) + // + //If we emitted the straightforward typing axiom: + // forall n hd tl. HasTypeFuel f (Cons n hd tl) (vector (n+1)) + //with pattern + // HasTypeFuel f (Cons n hd tl) (vecor (n+1)) + // + //It results in too restrictive a pattern, + //Specifically, if we need to prove HasTypeFuel f (Cons 0 1 Emp) (vector 1), + // the axiom will not fire, since the pattern is specifically looking for + // (n+1) in the resulting vector type, whereas here we have a term 1, + // which is not addition syntactically + // + //So we do a little bit of surgery below to emit an axiom of the form: + // forall n hd tl m. m = n + 1 ==> HasTypeFuel f (Cons n hd tl) (vector m) + //where m is a fresh variable + // + //Also see #2456 + // + let ty_pred', vars, guard = + match t_res_tm.tm with + | App (op, args) -> + //iargs are index arguments in the return type of the data constructor + let targs, iargs = List.splitAt n_tps args in + //fresh vars for iargs + let fresh_ivars, fresh_iargs = + iargs |> List.map (fun _ -> fresh_fvar env.current_module_name "i" Term_sort) + |> List.split in + //equality guards + let additional_guards = + mk_and_l (List.map2 (fun a fresh_a -> mkEq (a, fresh_a)) iargs fresh_iargs) in + + mk_HasTypeWithFuel + (Some fuel_tm) + dapp + ({t_res_tm with tm = App (op, targs@fresh_iargs)}), + + vars@(fresh_ivars |> List.map (fun s -> mk_fv (s, Term_sort))), + + mkAnd (guard, additional_guards) + + | _ -> ty_pred', vars, guard in //When will this case arise? + + Util.mkAssume(mkForall (Ident.range_of_lid d) + ([[ty_pred']],add_fuel (mk_fv (fuel_var, Fuel_sort)) vars, mkImp(guard, ty_pred')), + Some "data constructor typing intro", + ("data_typing_intro_"^ddtok)) in + + let g = binder_decls + @decls2 + @decls3 + @([Term.DeclFun(ddtok, [], Term_sort, Some (BU.format1 "data constructor proxy: %s" (Print.lid_to_string d)))] + @proxy_fresh |> mk_decls_trivial) + @decls_pred + @([Util.mkAssume(tok_typing, Some "typing for data constructor proxy", ("typing_tok_"^ddtok)); + Util.mkAssume(mkForall (Ident.range_of_lid d) + ([[app]], vars, + mkEq(app, dapp)), Some "equality for proxy", ("equality_tok_"^ddtok)); + data_cons_typing_intro_decl; + ]@elim |> mk_decls_trivial) in + (datacons |> mk_decls_trivial) @ g, env + + let rec encode_sigelt (env:env_t) (se:sigelt) : (decls_t * env_t) = let nm = Print.sigelt_to_string_short se in let g, env = Errors.with_ctx (BU.format1 "While encoding top-level declaration `%s`" @@ -1214,549 +1750,69 @@ and encode_sigelt' (env:env_t) (se:sigelt) : (decls_t * env_t) = encode_top_level_let env (is_rec, bindings) se.sigquals | Sig_bundle {ses} -> - let g, env = encode_sigelts env ses in - let g', inversions = List.fold_left (fun (g', inversions) elt -> - let elt_g', elt_inversions = elt.decls |> List.partition (function - | Term.Assume({assumption_caption=Some "inversion axiom"}) -> false - | _ -> true) in - g' @ [ { elt with decls = elt_g' } ], inversions @ elt_inversions - ) ([], []) g in - let decls, elts, rest = List.fold_left (fun (decls, elts, rest) elt -> - if elt.key |> BU.is_some && List.existsb (function | Term.DeclFun _ -> true | _ -> false) elt.decls - then decls, elts@[elt], rest - else let elt_decls, elt_rest = elt.decls |> List.partition (function - | Term.DeclFun _ -> true - | _ -> false) in - decls @ elt_decls, elts, rest @ [ { elt with decls = elt_rest }] - ) ([], [], []) g' in - (decls |> mk_decls_trivial) @ elts @ rest @ (inversions |> mk_decls_trivial), env - - | Sig_inductive_typ {lid=t; - us=universe_names; - params=tps; - t=k; - ds=datas} -> - let t_lid = t in - let tcenv = env.tcenv in - let is_injective_on_params = - let usubst, uvs = SS.univ_var_opening universe_names in - let env, tps, k = - Env.push_univ_vars tcenv uvs, - SS.subst_binders usubst tps, - SS.subst (SS.shift_subst (List.length tps) usubst) k - in - let tps, k = SS.open_term tps k in - let _, k = U.arrow_formals k in //don't care about indices here - let tps, env_tps, _, us = TcTerm.tc_binders env tps in - let u_k = - TcTerm.level_of_type - env_tps - (S.mk_Tm_app - (S.fvar t None) - (snd (U.args_of_binders tps)) - (Ident.range_of_lid t)) - k - in - //BU.print2 "Universe of tycon: %s : %s\n" (Ident.string_of_lid t) (Print.univ_to_string u_k); - let rec universe_leq u v = - match u, v with - | U_zero, _ -> true - | U_succ u0, U_succ v0 -> universe_leq u0 v0 - | U_name u0, U_name v0 -> Ident.ident_equals u0 v0 - | U_name _, U_succ v0 -> universe_leq u v0 - | U_max us, _ -> us |> BU.for_all (fun u -> universe_leq u v) - | _, U_max vs -> vs |> BU.for_some (universe_leq u) - | U_unknown, _ - | _, U_unknown - | U_unif _, _ - | _, U_unif _ -> failwith (BU.format3 "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" - (Ident.string_of_lid t) - (Print.univ_to_string u) - (Print.univ_to_string v)) - | _ -> false - in - let u_leq_u_k u = - let u = N.normalize_universe env_tps u in - universe_leq u u_k - in - let tp_ok (tp:S.binder) (u_tp:universe) = - let t_tp = tp.binder_bv.sort in - if u_leq_u_k u_tp - then true - else ( - let t_tp = - N.normalize - [Unrefine; Unascribe; Unmeta; - Primops; HNF; UnfoldUntil delta_constant; Beta] - env_tps t_tp - in - let formals, t = U.arrow_formals t_tp in - let _, _, _, u_formals = TcTerm.tc_binders env_tps formals in - let inj = BU.for_all (fun u_formal -> u_leq_u_k u_formal) u_formals in - if inj - then ( - match (SS.compress t).n with - | Tm_type u -> - (* retain injectivity for parameters that are type functions - from small universes (i.e., all formals are smaller than the constructed type) - to a universe <= the universe of the constructed type. - See BugBoxInjectivity.fst *) - u_leq_u_k u - // | Tm_name _ -> (* this is a value of another type parameter in scope *) - // true - | _ -> - false - ) - else ( - false - ) - - ) - in - List.forall2 tp_ok tps us - in - if Env.debug env.tcenv <| Options.Other "SMTEncoding" - then BU.print2 "%s injectivity for %s\n" - (if is_injective_on_params then "YES" else "NO") - (Ident.string_of_lid t); - let quals = se.sigquals in - let is_logical = quals |> BU.for_some (function Logic | Assumption -> true | _ -> false) in - let constructor_or_logic_type_decl (c:constructor_t) = - if is_logical - then [Term.DeclFun(c.constr_name, c.constr_fields |> List.map (fun f -> f.field_sort), Term_sort, None)] - else constructor_to_decl (Ident.range_of_lid t) c in - let inversion_axioms env tapp vars = - if datas |> BU.for_some (fun l -> Env.try_lookup_lid env.tcenv l |> Option.isNone) //Q: Why would this happen? - then [] - else - let xxsym, xx = fresh_fvar env.current_module_name "x" Term_sort in - let data_ax, decls = datas |> List.fold_left (fun (out, decls) l -> - let _, data_t = Env.lookup_datacon env.tcenv l in - let args, res = U.arrow_formals data_t in - let indices = res |> U.head_and_args_full |> snd in - let env = args |> List.fold_left - (fun env ({binder_bv=x}) -> push_term_var env x (mkApp(mk_term_projector_name l x, [xx]))) - env in - let indices, decls' = encode_args indices env in - if List.length indices <> List.length vars - then failwith "Impossible"; - let eqs = - if is_injective_on_params - || Options.ext_getv "compat:injectivity" <> "" - then List.map2 (fun v a -> mkEq(mkFreeV v, a)) vars indices - else ( - //only injectivity on indices - let num_params = List.length tps in - let _var_params, var_indices = List.splitAt num_params vars in - let _i_params, indices = List.splitAt num_params indices in - List.map2 (fun v a -> mkEq(mkFreeV v, a)) var_indices indices - ) - in - mkOr(out, mkAnd(mk_data_tester env l xx, eqs |> mk_and_l)), decls@decls') (mkFalse, []) in - let ffsym, ff = fresh_fvar env.current_module_name "f" Fuel_sort in - let fuel_guarded_inversion = - let xx_has_type_sfuel = - if List.length datas > 1 - then mk_HasTypeFuel (mkApp("SFuel", [ff])) xx tapp - else mk_HasTypeFuel ff xx tapp in //no point requiring non-zero fuel if there are no disjunctions - Util.mkAssume(mkForall (Ident.range_of_lid t) ([[xx_has_type_sfuel]], add_fuel (mk_fv (ffsym, Fuel_sort)) (mk_fv (xxsym, Term_sort)::vars), - mkImp(xx_has_type_sfuel, data_ax)), - Some "inversion axiom", //this name matters! see Sig_bundle case near line 1493 - (varops.mk_unique ("fuel_guarded_inversion_"^(string_of_lid t)))) in - decls - @([fuel_guarded_inversion] |> mk_decls_trivial) in - - let formals, res = - let k = - match tps with - | [] -> k - | _ -> S.mk (Tm_arrow {bs=tps; comp=S.mk_Total k}) k.pos - in - let k = norm_before_encoding env k in - U.arrow_formals k - in - - let vars, guards, env', binder_decls, _ = encode_binders None formals env in - let arity = List.length vars in - let tname, ttok, env = new_term_constant_and_tok_from_lid env t arity in - let ttok_tm = mkApp(ttok, []) in - let guard = mk_and_l guards in - let tapp = mkApp(tname, List.map mkFreeV vars) in //arity ok - let decls, env = - //See: https://github.com/FStarLang/FStar/commit/b75225bfbe427c8aef5b59f70ff6d79aa014f0b4 - //See: https://github.com/FStarLang/FStar/issues/349 - let tname_decl = - constructor_or_logic_type_decl - { - constr_name = tname; - constr_fields = vars |> List.map (fun fv -> {field_name=tname^fv_name fv; field_sort=fv_sort fv; field_projectible=false}) ; - //The field_projectible=false above is extremely important; it makes sure that type-formers are not injective - constr_sort=Term_sort; - constr_id=Some (varops.next_id()) - } - in - let tok_decls, env = - match vars with - | [] -> [], push_free_var env t arity tname (Some <| mkApp(tname, [])) - | _ -> - let ttok_decl = Term.DeclFun(ttok, [], Term_sort, Some "token") in - let ttok_fresh = Term.fresh_token (ttok, Term_sort) (varops.next_id()) in - let ttok_app = mk_Apply ttok_tm vars in - let pats = [[ttok_app]; [tapp]] in - // These patterns allow rewriting (ApplyT T@tok args) to (T args) and vice versa - // This seems necessary for some proofs, but the bidirectional rewriting may be inefficient - let name_tok_corr = Util.mkAssume(mkForall' (Ident.range_of_lid t) (pats, None, vars, mkEq(ttok_app, tapp)), - Some "name-token correspondence", - ("token_correspondence_"^ttok)) in - [ttok_decl; ttok_fresh; name_tok_corr], env in - tname_decl@tok_decls, env in - let kindingAx = - let k, decls = encode_term_pred None res env' tapp in - let karr = - if List.length formals > 0 - then [Util.mkAssume(mk_tester "Tm_arrow" (mk_PreType ttok_tm), Some "kinding", ("pre_kinding_"^ttok))] - else [] - in - let rng = Ident.range_of_lid t in - let tot_fun_axioms = - EncodeTerm.isTotFun_axioms rng ttok_tm vars (List.map (fun _ -> mkTrue) vars) true + let tycon = List.tryFind (fun se -> Sig_inductive_typ? se.sigel) ses in + let is_injective_on_params = + match tycon with + | None -> failwith "Impossible: Sig_bundle without a Sig_inductive_typ" + | Some se -> + is_sig_inductive_injective_on_params env se + in + let g, env = + ses |> + List.fold_left + (fun (g, env) se -> + let g', env = + match se.sigel with + | Sig_inductive_typ _ -> + encode_sig_inductive is_injective_on_params env se + | Sig_datacon _ -> + encode_datacon is_injective_on_params env se + | _ -> + encode_sigelt env se in - - decls@(karr@[Util.mkAssume(mkAnd(tot_fun_axioms, mkForall rng ([[tapp]], vars, mkImp(guard, k))), None, ("kinding_"^ttok))] - |> mk_decls_trivial) in - let aux = - kindingAx - @(inversion_axioms env tapp vars) - @([pretype_axiom (Ident.range_of_lid t) env tapp vars] |> mk_decls_trivial) in - - let g = (decls |> mk_decls_trivial) - @binder_decls - @aux in - g, env - - | Sig_datacon {lid=d; t; num_ty_params=n_tps; mutuals} -> - let quals = se.sigquals in - let t = norm_before_encoding env t in - let formals, t_res = U.arrow_formals t in - let arity = List.length formals in - let ddconstrsym, ddtok, env = new_term_constant_and_tok_from_lid env d arity in - let ddtok_tm = mkApp(ddtok, []) in - let fuel_var, fuel_tm = fresh_fvar env.current_module_name "f" Fuel_sort in - let s_fuel_tm = mkApp("SFuel", [fuel_tm]) in - let vars, guards, env', binder_decls, names = encode_binders (Some fuel_tm) formals env in - let fields = names |> List.mapi (fun n x -> - { field_name=mk_term_projector_name d x; - field_sort=Term_sort; - field_projectible=true }) - in - let datacons = - {constr_name=ddconstrsym; - constr_fields=fields; - constr_sort=Term_sort; - constr_id=Some (varops.next_id()) - } |> Term.constructor_to_decl (Ident.range_of_lid d) in - let app = mk_Apply ddtok_tm vars in - let guard = mk_and_l guards in - let xvars = List.map mkFreeV vars in - let dapp = mkApp(ddconstrsym, xvars) in //arity ok; |xvars| = |formals| = arity - - let tok_typing, decls3 = encode_term_pred None t env ddtok_tm in - let tok_typing = - match fields with - | _::_ -> - let ff = mk_fv ("ty", Term_sort) in - let f = mkFreeV ff in - let vtok_app_l = mk_Apply ddtok_tm [ff] in - let vtok_app_r = mk_Apply f [mk_fv (ddtok, Term_sort)] in - //guard the token typing assumption with a Apply(tok, f) or Apply(f, tok) - //Additionally, the body of the term becomes NoHoist f (HasType tok ...) - // to prevent the Z3 simplifier from hoisting the (HasType tok ...) part out - //Since the top-levels of modules are full of function typed terms - //not guarding it this way causes every typing assumption of an arrow type to be fired immediately - //regardless of whether or not the function is used ... leading to bloat - //these patterns aim to restrict the use of the typing assumption until such point as it is actually needed - mkForall (Ident.range_of_lid d) - ([[vtok_app_l]; [vtok_app_r]], - [ff], - Term.mk_NoHoist f tok_typing) - | _ -> tok_typing in - let ty_pred', t_res_tm, decls_pred = - let t_res_tm, t_res_decls = encode_term t_res env' in - mk_HasTypeWithFuel (Some fuel_tm) dapp t_res_tm, t_res_tm, t_res_decls in - let proxy_fresh = match formals with - | [] -> [] - | _ -> [Term.fresh_token (ddtok, Term_sort) (varops.next_id())] in - - let encode_elim () = - let head, args = U.head_and_args t_res in - match (SS.compress head).n with - | Tm_uinst({n=Tm_fvar fv}, _) - | Tm_fvar fv -> - let encoded_head_fvb = lookup_free_var_name env' fv.fv_name in - let encoded_args, arg_decls = encode_args args env' in - let guards_for_parameter (orig_arg:S.term)(arg:term) xv = - let fv = - match arg.tm with - | FreeV fv -> fv - | _ -> - Errors.raise_error (Errors.Fatal_NonVariableInductiveTypeParameter, - BU.format1 "Inductive type parameter %s must be a variable ; \ - You may want to change it to an index." - (FStar.Syntax.Print.term_to_string orig_arg)) orig_arg.pos - in - let guards = guards |> List.collect (fun g -> - if List.contains fv (Term.free_variables g) - then [Term.subst g fv xv] - else []) - in - mk_and_l guards - in - let _, arg_vars, elim_eqns_or_guards, _ = - List.fold_left - (fun (env, arg_vars, eqns_or_guards, i) (orig_arg, arg) -> - let _, xv, env = gen_term_var env (S.new_bv None tun) in - (* we only get equations induced on the type indices, not parameters; *) - (* Also see https://github.com/FStarLang/FStar/issues/349 *) - let eqns = - if i < n_tps - then guards_for_parameter (fst orig_arg) arg xv::eqns_or_guards - else mkEq(arg, xv)::eqns_or_guards - in - (env, xv::arg_vars, eqns, i + 1)) - (env', [], [], 0) - (FStar.Compiler.List.zip args encoded_args) + g@g', env) + ([], env) + in + //reorder the generated decls in proper def-use order, + //i.e, declare all the function symbols first + //1. move the inversions last; they rely on all the symbols + let g', inversions = + List.fold_left + (fun (g', inversions) elt -> + let elt_g', elt_inversions = + elt.decls |> + List.partition + (function + | Term.Assume({assumption_caption=Some "inversion axiom"}) -> false + | _ -> true) in - let arg_vars = List.rev arg_vars in - let ty = maybe_curry_fvb fv.fv_name.p encoded_head_fvb arg_vars in - let xvars = List.map mkFreeV vars in - let dapp = mkApp(ddconstrsym, xvars) in //arity ok; |xvars| = |formals| = arity - let ty_pred = mk_HasTypeWithFuel (Some s_fuel_tm) dapp ty in - let arg_binders = List.map fv_of_term arg_vars in - let typing_inversion = - Util.mkAssume(mkForall (Ident.range_of_lid d) ([[ty_pred]], - add_fuel (mk_fv (fuel_var, Fuel_sort)) (vars@arg_binders), - mkImp(ty_pred, mk_and_l (elim_eqns_or_guards@guards))), - Some "data constructor typing elim", - ("data_elim_" ^ ddconstrsym)) in - let lex_t = mkFreeV <| mk_fv (string_of_lid Const.lex_t_lid, Term_sort) in - let subterm_ordering = - (* subterm ordering *) - let prec = - vars - |> List.mapi (fun i v -> - (* it's a parameter, so it's inaccessible and no need for a sub-term ordering on it *) - if i < n_tps - then [] - else [mk_Precedes lex_t lex_t (mkFreeV v) dapp]) - |> List.flatten - in - Util.mkAssume(mkForall (Ident.range_of_lid d) - ([[ty_pred]], - add_fuel (mk_fv (fuel_var, Fuel_sort)) (vars@arg_binders), - mkImp(ty_pred, mk_and_l prec)), - Some "subterm ordering", - ("subterm_ordering_"^ddconstrsym)) - in - let codomain_ordering, codomain_decls = - let _, formals' = BU.first_N n_tps formals in (* no codomain ordering for the parameters *) - let _, vars' = BU.first_N n_tps vars in - let norm t = - N.unfold_whnf' [Env.AllowUnboundUniverses; - Env.EraseUniverses; - Env.Unascribe; - //we don't know if this will terminate; so don't do recursive steps - Env.Exclude Env.Zeta] - env'.tcenv - t - in - let warn_compat () = - FStar.Errors.log_issue - (S.range_of_fv fv) - (FStar.Errors.Warning_DeprecatedGeneric, - "Using 'compat:2954' to use a permissive encoding of the subterm ordering on the codomain of a constructor.\n\ - This is deprecated and will be removed in a future version of F*.") - in - let codomain_prec_l, cod_decls = - List.fold_left2 - (fun (codomain_prec_l, cod_decls) formal var -> - let rec binder_and_codomain_type t = - let t = U.unrefine t in - match (SS.compress t).n with - | Tm_arrow _ -> - let bs, c = U.arrow_formals_comp (U.unrefine t) in - begin - match bs with - | [] -> None - | _ when not (U.is_tot_or_gtot_comp c) -> None - | _ -> - if U.is_lemma_comp c - then None //not useful for lemmas - else - let t = U.unrefine (U.comp_result c) in - let t = norm t in - if is_type t || U.is_sub_singleton t - then None //ordering on Type and squashed values is not useful - else ( - let head, _ = U.head_and_args_full t in - match (U.un_uinst head).n with - | Tm_fvar fv -> - if BU.for_some (S.fv_eq_lid fv) mutuals - then Some (bs, c) - else if Options.ext_getv "compat:2954" <> "" - then (warn_compat(); Some (bs, c)) //compatibility mode - else None - | _ -> - if Options.ext_getv "compat:2954" <> "" - then (warn_compat(); Some (bs, c)) //compatibility mode - else None - ) - end - | _ -> - let head, _ = U.head_and_args t in - let t' = norm t in - let head', _ = U.head_and_args t' in - match U.eq_tm head head' with - | U.Equal -> None //no progress after whnf - | U.NotEqual -> binder_and_codomain_type t' - | _ -> - //Did we actually make progress? Be conservative to avoid an infinite loop - match (SS.compress head).n with - | Tm_fvar _ - | Tm_name _ - | Tm_uinst _ -> - //The underlying name must have changed, otherwise we would have got Equal - //so, we made some progress - binder_and_codomain_type t' - | _ -> - //unclear if we made progress or not - None - - in - match binder_and_codomain_type formal.binder_bv.sort with - | None -> - codomain_prec_l, cod_decls - | Some (bs, c) -> - //var bs << D ... var ... - let bs', guards', _env', bs_decls, _ = encode_binders None bs env' in - let fun_app = mk_Apply (mkFreeV var) bs' in - mkForall (Ident.range_of_lid d) - ([[mk_Precedes lex_t lex_t fun_app dapp]], - bs', - //need to use ty_pred' here, to avoid variable capture - //Note, ty_pred' is indexed by fuel, not S_fuel - //That's ok, since the outer pattern is guarded on S_fuel - mkImp (mk_and_l (ty_pred'::guards'), - mk_Precedes lex_t lex_t fun_app dapp)) - :: codomain_prec_l, - bs_decls @ cod_decls) - ([],[]) - formals' - vars' - in - match codomain_prec_l with - | [] -> - [], cod_decls - | _ -> - [Util.mkAssume(mkForall (Ident.range_of_lid d) - ([[ty_pred]],//we use ty_pred here as the pattern, which has an S_fuel guard - add_fuel (mk_fv (fuel_var, Fuel_sort)) (vars@arg_binders), - mk_and_l codomain_prec_l), - Some "well-founded ordering on codomain", - ("well_founded_ordering_on_codomain_"^ddconstrsym))], - cod_decls + g' @ [ { elt with decls = elt_g' } ], + inversions @ elt_inversions) + ([], []) + g + in + //2. decls are all the function symbol declarations + // elts: not sure what this represents + // rest: all the non-declarations, excepting the inversion axiom which is already identified above + let decls, elts, rest = + List.fold_left + (fun (decls, elts, rest) elt -> + if BU.is_some elt.key //NS: Not sure what this case is for + && List.existsb (function | Term.DeclFun _ -> true | _ -> false) elt.decls + then decls, elts@[elt], rest + else ( //Pull the function symbol decls to the front + let elt_decls, elt_rest = + elt.decls |> + List.partition + (function + | Term.DeclFun _ -> true + | _ -> false) in - arg_decls @ codomain_decls, - [typing_inversion; subterm_ordering] @ codomain_ordering - - | _ -> - Errors.log_issue se.sigrng - (Errors.Warning_ConstructorBuildsUnexpectedType, - BU.format2 "Constructor %s builds an unexpected type %s\n" - (Print.lid_to_string d) (Print.term_to_string head)); - [], [] - in - let decls2, elim = encode_elim () in - let data_cons_typing_intro_decl = - // - //AR: - // - //Typing intro for the data constructor - // - //We do a bit of manipulation for type indices - //Consider the Cons data constructor of a length-indexed vector type: - // type vector : nat -> Type = | Emp : vector 0 - // | Cons: n:nat -> hd:nat -> tl:vec n -> vec (n+1) - // - //So far we have - // ty_pred' = HasTypeFuel f (Cons n hd tl) (vector (n+1)) - // vars = n, hd, tl - // guard = And of typing guards for n, hd, tl (i.e. (HasType n nat) etc.) - // - //If we emitted the straightforward typing axiom: - // forall n hd tl. HasTypeFuel f (Cons n hd tl) (vector (n+1)) - //with pattern - // HasTypeFuel f (Cons n hd tl) (vecor (n+1)) - // - //It results in too restrictive a pattern, - //Specifically, if we need to prove HasTypeFuel f (Cons 0 1 Emp) (vector 1), - // the axiom will not fire, since the pattern is specifically looking for - // (n+1) in the resulting vector type, whereas here we have a term 1, - // which is not addition syntactically - // - //So we do a little bit of surgery below to emit an axiom of the form: - // forall n hd tl m. m = n + 1 ==> HasTypeFuel f (Cons n hd tl) (vector m) - //where m is a fresh variable - // - //Also see #2456 - // - let ty_pred', vars, guard = - match t_res_tm.tm with - | App (op, args) -> - //iargs are index arguments in the return type of the data constructor - let targs, iargs = List.splitAt n_tps args in - //fresh vars for iargs - let fresh_ivars, fresh_iargs = - iargs |> List.map (fun _ -> fresh_fvar env.current_module_name "i" Term_sort) - |> List.split in - //equality guards - let additional_guards = - mk_and_l (List.map2 (fun a fresh_a -> mkEq (a, fresh_a)) iargs fresh_iargs) in - - mk_HasTypeWithFuel - (Some fuel_tm) - dapp - ({t_res_tm with tm = App (op, targs@fresh_iargs)}), - - vars@(fresh_ivars |> List.map (fun s -> mk_fv (s, Term_sort))), - - mkAnd (guard, additional_guards) - - | _ -> ty_pred', vars, guard in //When will this case arise? - - Util.mkAssume(mkForall (Ident.range_of_lid d) - ([[ty_pred']],add_fuel (mk_fv (fuel_var, Fuel_sort)) vars, mkImp(guard, ty_pred')), - Some "data constructor typing intro", - ("data_typing_intro_"^ddtok)) in - - let g = binder_decls - @decls2 - @decls3 - @([Term.DeclFun(ddtok, [], Term_sort, Some (BU.format1 "data constructor proxy: %s" (Print.lid_to_string d)))] - @proxy_fresh |> mk_decls_trivial) - @decls_pred - @([Util.mkAssume(tok_typing, Some "typing for data constructor proxy", ("typing_tok_"^ddtok)); - Util.mkAssume(mkForall (Ident.range_of_lid d) - ([[app]], vars, - mkEq(app, dapp)), Some "equality for proxy", ("equality_tok_"^ddtok)); - data_cons_typing_intro_decl; - ]@elim |> mk_decls_trivial) in - (datacons |> mk_decls_trivial) @ g, env - -and encode_sigelts env ses :(decls_t * env_t) = - ses |> List.fold_left (fun (g, env) se -> - let g', env = encode_sigelt env se in - g@g', env) ([], env) - + decls @ elt_decls, elts, rest @ [ { elt with decls = elt_rest }] + )) + ([], [], []) g' + in + (decls |> mk_decls_trivial) @ elts @ rest @ (inversions |> mk_decls_trivial), env let encode_env_bindings (env:env_t) (bindings:list S.binding) : (decls_t * env_t) = (* Encoding Binding_var and Binding_typ as local constants leads to breakages in hash consing. From 448857d6cf50fa9083ae2f04dd68687131d3e434 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Fri, 19 Apr 2024 11:56:12 -0700 Subject: [PATCH 13/42] restrict injectivity for data constructor type parameters --- .../generated/FStar_SMTEncoding_Encode.ml | 9 +++-- src/smtencoding/FStar.SMTEncoding.Encode.fst | 19 ++++++--- tests/bug-reports/BugBoxInjectivity.fst | 39 +++++-------------- 3 files changed, 28 insertions(+), 39 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index 5fa3195d52e..18fcd51d3de 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -4510,6 +4510,9 @@ let (encode_datacon : FStar_Compiler_List.mapi (fun n -> fun x -> + let field_projectible = + (n >= n_tps) || + is_injective_on_tparams in let uu___7 = FStar_SMTEncoding_Env.mk_term_projector_name d x in @@ -4520,7 +4523,7 @@ let (encode_datacon : = FStar_SMTEncoding_Term.Term_sort; FStar_SMTEncoding_Term.field_projectible - = true + = field_projectible }) names in let datacons = let uu___7 = FStar_Ident.range_of_lid d in @@ -7033,9 +7036,7 @@ and (encode_sigelt' : se1.FStar_Syntax_Syntax.sigel) ses in let is_injective_on_params = match tycon with - | FStar_Pervasives_Native.None -> - FStar_Compiler_Effect.failwith - "Impossible: Sig_bundle without a Sig_inductive_typ" + | FStar_Pervasives_Native.None -> false | FStar_Pervasives_Native.Some se1 -> is_sig_inductive_injective_on_params env se1 in let uu___2 = diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst index 0f55936367d..634967d7279 100644 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ b/src/smtencoding/FStar.SMTEncoding.Encode.fst @@ -1227,10 +1227,17 @@ let encode_datacon (is_injective_on_tparams:bool) (env:env_t) (se:sigelt) let fuel_var, fuel_tm = fresh_fvar env.current_module_name "f" Fuel_sort in let s_fuel_tm = mkApp("SFuel", [fuel_tm]) in let vars, guards, env', binder_decls, names = encode_binders (Some fuel_tm) formals env in - let fields = names |> List.mapi (fun n x -> - { field_name=mk_term_projector_name d x; - field_sort=Term_sort; - field_projectible=true }) + let fields = + names |> + List.mapi + (fun n x -> + let field_projectible = + n >= n_tps || //either this field is not a type parameter + is_injective_on_tparams //or we are allowed to be injective on parameters + in + { field_name=mk_term_projector_name d x; + field_sort=Term_sort; + field_projectible }) in let datacons = {constr_name=ddconstrsym; @@ -1753,7 +1760,9 @@ and encode_sigelt' (env:env_t) (se:sigelt) : (decls_t * env_t) = let tycon = List.tryFind (fun se -> Sig_inductive_typ? se.sigel) ses in let is_injective_on_params = match tycon with - | None -> failwith "Impossible: Sig_bundle without a Sig_inductive_typ" + | None -> + //Exceptions appear as Sig_bundle without an inductive type + false | Some se -> is_sig_inductive_injective_on_params env se in diff --git a/tests/bug-reports/BugBoxInjectivity.fst b/tests/bug-reports/BugBoxInjectivity.fst index 740d264677a..ebf209f7bdf 100644 --- a/tests/bug-reports/BugBoxInjectivity.fst +++ b/tests/bug-reports/BugBoxInjectivity.fst @@ -5,41 +5,20 @@ module CC = FStar.Cardinality.Universes type t (a:Type u#1) : Type u#0 = | Mk : t a -//We can get the problematic axiom by -//relying on an equation introduced by the pattern -//match and give it to SMT let inj_t (#a:Type u#1) (x:t a) : Lemma (x == Mk #a) - [SMTPat (has_type x (t a))] = let Mk #_ = x in () -#push-options "--log_queries" -#restart-solver -let t_injective_alt (f0 f1:Type u#1) (x: t f0) (y:t f1) -: Lemma - (ensures t f0 == t f1 ==> f0 == f1) -= () +[@@expect_failure] +let t_injective : squash (is_inj t) = + introduce forall f0 f1. + t f0 == t f1 ==> f0 == f1 + with introduce _ ==> _ + with _ . ( + inj_t #f0 Mk; + inj_t #f1 (coerce_eq () (Mk #f0)) + ) -// let t_injective (f0 f1:Type u#1) -// : Lemma -// (ensures t f0 == t f1 ==> f0 == f1) -// = t_injective_alt f0 f1 Mk Mk - -// let t_injective' : squash (is_inj t) = -// introduce forall f0 f1. -// t f0 == t f1 ==> f0 == f1 -// with introduce _ ==> _ -// with _ . ( -// t_injective f0 f1 -// ) -// let fals : squash False = -// CC.no_inj_universes_suc t - -// /////////////////// -// let test (#a:Type) (x:t a) = -// match x with -// | Mkt #_ f -> -// assert (x == Mkt #a f) // #restart-solver // #push-options "--log_queries --query_stats --debug BugBoxInjectivity --debug_level SMTEncoding" From ab7931875195c22faba20d56096b914ae150656f Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Fri, 19 Apr 2024 13:47:51 -0700 Subject: [PATCH 14/42] a temporary compat in FStar.ModifiesGen --- ulib/FStar.ModifiesGen.fst | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/ulib/FStar.ModifiesGen.fst b/ulib/FStar.ModifiesGen.fst index 4580060186e..ef75c19d967 100644 --- a/ulib/FStar.ModifiesGen.fst +++ b/ulib/FStar.ModifiesGen.fst @@ -54,6 +54,7 @@ let live_addrs_codom (non_live_addrs_codom regions region_liveness_tags)) (r:addrs_dom regions) = (y: GSet.set nat { GSet.subset (non_live_addrs r) y } ) +#push-options "--ext 'compat:injectivity'" noeq type loc' (#al: aloc_t u#x) (c: cls al) : Type u#x = | Loc: @@ -72,6 +73,7 @@ type loc' (#al: aloc_t u#x) (c: cls al) : Type u#x = Ghost.reveal aux `GSet.subset` (aloc_domain c regions (fun _ -> GSet.complement GSet.empty)) } ) -> loc' c +#pop-options let loc = loc' @@ -618,7 +620,11 @@ let loc_disjoint_aloc_elim #al #c #r1 #a1 #r2 #a2 b1 b2 = #push-options "--z3rlimit 15" let loc_disjoint_addresses_intro #al #c preserve_liveness1 preserve_liveness2 r1 r2 n1 n2 = // FIXME: WHY WHY WHY this assert? - assert (loc_aux_disjoint (Ghost.reveal (Loc?.aux (loc_addresses #_ #c preserve_liveness1 r1 n1))) (Ghost.reveal (Loc?.aux (loc_addresses #_ #c preserve_liveness2 r2 n2)))) + let Loc _ _ _ _ _ = (loc_addresses #_ #c preserve_liveness1 r1 n1) in + let Loc _ _ _ _ _ = (loc_addresses #_ #c preserve_liveness2 r2 n2) in + assert (loc_aux_disjoint + (Ghost.reveal (Loc?.aux (loc_addresses #_ #c preserve_liveness1 r1 n1))) + (Ghost.reveal (Loc?.aux (loc_addresses #_ #c preserve_liveness2 r2 n2)))) #pop-options let loc_disjoint_addresses_elim #al #c preserve_liveness1 preserve_liveness2 r1 r2 n1 n2 = () @@ -947,6 +953,8 @@ let modifies_intro_strong #al #c l h h' regions mrefs lives unused_ins alocs = (Set.mem (HS.frameOf p) (regions_of_loc l) ==> ~ (GSet.mem (HS.as_addr p) (addrs_of_loc l (HS.frameOf p)))))) (ensures (HS.contains h' p /\ HS.sel h' p == HS.sel h p)) = + let Loc _ _ _ _ _ = (loc_mreference #_ #c p) in + let Loc _ _ _ _ _ = l in assert_norm (Loc?.region_liveness_tags (loc_mreference #_ #c p) == Ghost.hide Set.empty); assert (loc_disjoint_region_liveness_tags (loc_mreference p) l); // FIXME: WHY WHY WHY is this assert necessary? From e376ccc6d66bd41874f71dcfe2f6a897801d4a7d Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Fri, 19 Apr 2024 15:38:10 -0700 Subject: [PATCH 15/42] for data constructors on types not injective on their params, add an axiom to prove that the parameter instantiations are irrelevant and remove the projector axiom --- .../generated/FStar_SMTEncoding_Encode.ml | 16 ++- .../generated/FStar_SMTEncoding_Term.ml | 101 +++++++++++++++--- src/smtencoding/FStar.SMTEncoding.Encode.fst | 19 ++-- src/smtencoding/FStar.SMTEncoding.Term.fst | 39 +++++-- src/smtencoding/FStar.SMTEncoding.Term.fsti | 8 +- 5 files changed, 153 insertions(+), 30 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index 18fcd51d3de..5f171b1c4b1 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -4306,7 +4306,8 @@ let (encode_sig_inductive : uu___9; FStar_SMTEncoding_Term.constr_sort = FStar_SMTEncoding_Term.Term_sort; - FStar_SMTEncoding_Term.constr_id = uu___10 + FStar_SMTEncoding_Term.constr_id = uu___10; + FStar_SMTEncoding_Term.constr_base = false } in constructor_or_logic_type_decl uu___8 in let uu___8 = @@ -4506,13 +4507,19 @@ let (encode_datacon : env1 in (match uu___6 with | (vars, guards, env', binder_decls, names) -> + let is_injective_on_tparams1 = + is_injective_on_tparams || + (let uu___7 = + FStar_Options.ext_getv + "compat:injectivity" in + uu___7 <> "") in let fields = FStar_Compiler_List.mapi (fun n -> fun x -> let field_projectible = (n >= n_tps) || - is_injective_on_tparams in + is_injective_on_tparams1 in let uu___7 = FStar_SMTEncoding_Env.mk_term_projector_name d x in @@ -4541,7 +4548,10 @@ let (encode_datacon : FStar_SMTEncoding_Term.constr_sort = FStar_SMTEncoding_Term.Term_sort; FStar_SMTEncoding_Term.constr_id = - uu___9 + uu___9; + FStar_SMTEncoding_Term.constr_base = + (Prims.op_Negation + is_injective_on_tparams1) } in FStar_SMTEncoding_Term.constructor_to_decl uu___7 uu___8 in diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Term.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Term.ml index 99e85a2c75b..63a65a35a73 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Term.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Term.ml @@ -258,27 +258,37 @@ type constructor_t = constr_name: Prims.string ; constr_fields: constructor_field Prims.list ; constr_sort: sort ; - constr_id: Prims.int FStar_Pervasives_Native.option } + constr_id: Prims.int FStar_Pervasives_Native.option ; + constr_base: Prims.bool } let (__proj__Mkconstructor_t__item__constr_name : constructor_t -> Prims.string) = fun projectee -> match projectee with - | { constr_name; constr_fields; constr_sort; constr_id;_} -> constr_name + | { constr_name; constr_fields; constr_sort; constr_id; constr_base;_} -> + constr_name let (__proj__Mkconstructor_t__item__constr_fields : constructor_t -> constructor_field Prims.list) = fun projectee -> match projectee with - | { constr_name; constr_fields; constr_sort; constr_id;_} -> + | { constr_name; constr_fields; constr_sort; constr_id; constr_base;_} -> constr_fields let (__proj__Mkconstructor_t__item__constr_sort : constructor_t -> sort) = fun projectee -> match projectee with - | { constr_name; constr_fields; constr_sort; constr_id;_} -> constr_sort + | { constr_name; constr_fields; constr_sort; constr_id; constr_base;_} -> + constr_sort let (__proj__Mkconstructor_t__item__constr_id : constructor_t -> Prims.int FStar_Pervasives_Native.option) = fun projectee -> match projectee with - | { constr_name; constr_fields; constr_sort; constr_id;_} -> constr_id + | { constr_name; constr_fields; constr_sort; constr_id; constr_base;_} -> + constr_id +let (__proj__Mkconstructor_t__item__constr_base : + constructor_t -> Prims.bool) = + fun projectee -> + match projectee with + | { constr_name; constr_fields; constr_sort; constr_id; constr_base;_} -> + constr_base type constructors = constructor_t Prims.list type fact_db_id = | Name of FStar_Ident.lid @@ -1518,7 +1528,6 @@ let (constructor_to_decl : FStar_Compiler_Range_Type.range -> constructor_t -> decl Prims.list) = fun rng -> fun constr -> - let injective = true in let sort1 = constr.constr_sort in let field_sorts = FStar_Compiler_List.map (fun f -> f.field_sort) constr.constr_fields in @@ -1599,6 +1608,70 @@ let (constructor_to_decl : let projs = injective_constructor rng ((constr.constr_name), (constr.constr_fields), sort1) in + let base = + if Prims.op_Negation constr.constr_base + then [] + else + (let arg_sorts = + let uu___1 = + FStar_Compiler_List.filter (fun f -> f.field_projectible) + constr.constr_fields in + FStar_Compiler_List.map (fun uu___2 -> Term_sort) uu___1 in + let base_name = Prims.strcat constr.constr_name "@base" in + let decl1 = + DeclFun + (base_name, arg_sorts, Term_sort, + (FStar_Pervasives_Native.Some "Constructor base")) in + let formals = + FStar_Compiler_List.mapi + (fun i -> + fun uu___1 -> + let uu___2 = + let uu___3 = + let uu___4 = FStar_Compiler_Util.string_of_int i in + Prims.strcat "x" uu___4 in + (uu___3, Term_sort) in + mk_fv uu___2) constr.constr_fields in + let constructed_term = + let uu___1 = + let uu___2 = + FStar_Compiler_List.map (fun fv1 -> mkFreeV fv1 norng) + formals in + ((constr.constr_name), uu___2) in + mkApp uu___1 norng in + let inj_formals = + let uu___1 = + FStar_Compiler_List.map2 + (fun f -> + fun fld -> if fld.field_projectible then [f] else []) + formals constr.constr_fields in + FStar_Compiler_List.flatten uu___1 in + let base_term = + let uu___1 = + let uu___2 = + FStar_Compiler_List.map (fun fv1 -> mkFreeV fv1 norng) + inj_formals in + (base_name, uu___2) in + mkApp uu___1 norng in + let eq = mkEq (constructed_term, base_term) norng in + let guard = + mkApp ((discriminator_name constr), [constructed_term]) norng in + let q = + let uu___1 = + let uu___2 = mkImp (guard, eq) norng in + ([[constructed_term]], formals, uu___2) in + mkForall rng uu___1 in + let a = + let uu___1 = + escape (Prims.strcat "constructor_base_" constr.constr_name) in + { + assumption_term = q; + assumption_caption = + (FStar_Pervasives_Native.Some "Constructor base"); + assumption_name = uu___1; + assumption_fact_ids = [] + } in + [decl1; Assume a]) in let uu___ = let uu___1 = let uu___2 = @@ -1612,10 +1685,12 @@ let (constructor_to_decl : let uu___4 = let uu___5 = let uu___6 = - FStar_Compiler_Util.format1 "" - constr.constr_name in - Caption uu___6 in - [uu___5] in + let uu___7 = + FStar_Compiler_Util.format1 "" + constr.constr_name in + Caption uu___7 in + [uu___6] in + FStar_Compiler_List.op_At base uu___5 in FStar_Compiler_List.op_At [disc] uu___4 in FStar_Compiler_List.op_At projs uu___3 in FStar_Compiler_List.op_At cid uu___2 in @@ -1939,7 +2014,8 @@ and (mkPrelude : Prims.string -> Prims.string) = constr_name = name; constr_fields = uu___1; constr_sort = sort1; - constr_id = (FStar_Pervasives_Native.Some id) + constr_id = (FStar_Pervasives_Native.Some id); + constr_base = false } in let constrs = FStar_Compiler_List.map as_constr @@ -2018,7 +2094,8 @@ let (mkBvConstructor : constr_name = uu___; constr_fields = uu___1; constr_sort = Term_sort; - constr_id = FStar_Pervasives_Native.None + constr_id = FStar_Pervasives_Native.None; + constr_base = false } in let uu___ = constructor_to_decl norng constr in (uu___, (constr.constr_name), (discriminator_name constr)) diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst index 634967d7279..7396d59bd8c 100644 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ b/src/smtencoding/FStar.SMTEncoding.Encode.fst @@ -1174,7 +1174,8 @@ let encode_sig_inductive (is_injective_on_params:bool) (env:env_t) (se:sigelt) constr_fields = vars |> List.map (fun fv -> {field_name=tname^fv_name fv; field_sort=fv_sort fv; field_projectible=false}) ; //The field_projectible=false above is extremely important; it makes sure that type-formers are not injective constr_sort=Term_sort; - constr_id=Some (varops.next_id()) + constr_id=Some (varops.next_id()); + constr_base=false } in let tok_decls, env = @@ -1227,6 +1228,9 @@ let encode_datacon (is_injective_on_tparams:bool) (env:env_t) (se:sigelt) let fuel_var, fuel_tm = fresh_fvar env.current_module_name "f" Fuel_sort in let s_fuel_tm = mkApp("SFuel", [fuel_tm]) in let vars, guards, env', binder_decls, names = encode_binders (Some fuel_tm) formals env in + let is_injective_on_tparams = + is_injective_on_tparams || Options.ext_getv "compat:injectivity" <> "" + in let fields = names |> List.mapi @@ -1239,12 +1243,13 @@ let encode_datacon (is_injective_on_tparams:bool) (env:env_t) (se:sigelt) field_sort=Term_sort; field_projectible }) in - let datacons = - {constr_name=ddconstrsym; - constr_fields=fields; - constr_sort=Term_sort; - constr_id=Some (varops.next_id()) - } |> Term.constructor_to_decl (Ident.range_of_lid d) in + let datacons = { + constr_name=ddconstrsym; + constr_fields=fields; + constr_sort=Term_sort; + constr_id=Some (varops.next_id()); + constr_base=not is_injective_on_tparams + } |> Term.constructor_to_decl (Ident.range_of_lid d) in let app = mk_Apply ddtok_tm vars in let guard = mk_and_l guards in let xvars = List.map mkFreeV vars in diff --git a/src/smtencoding/FStar.SMTEncoding.Term.fst b/src/smtencoding/FStar.SMTEncoding.Term.fst index caa0b727566..93ceba286ee 100644 --- a/src/smtencoding/FStar.SMTEncoding.Term.fst +++ b/src/smtencoding/FStar.SMTEncoding.Term.fst @@ -18,8 +18,6 @@ module FStar.SMTEncoding.Term open FStar open FStar.Compiler open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Class.Ord module S = FStar.Syntax.Syntax module BU = FStar.Compiler.Util @@ -601,7 +599,6 @@ let injective_constructor let discriminator_name constr = "is-"^constr.constr_name let constructor_to_decl rng constr = - let injective = true in let sort = constr.constr_sort in let field_sorts = constr.constr_fields |> List.map (fun f -> f.field_sort) in let cdecl = DeclFun(constr.constr_name, field_sorts, constr.constr_sort, Some "Constructor") in @@ -638,8 +635,36 @@ let constructor_to_decl rng constr = Some "Discriminator definition") in def in let projs = injective_constructor rng (constr.constr_name, constr.constr_fields, sort) in + let base = + if not constr.constr_base + then [] + else ( + let arg_sorts = + constr.constr_fields + |> List.filter (fun f -> f.field_projectible) + |> List.map (fun _ -> Term_sort) + in + let base_name = constr.constr_name ^ "@base" in + let decl = DeclFun(base_name, arg_sorts, Term_sort, Some "Constructor base") in + let formals = List.mapi (fun i _ -> mk_fv ("x" ^ string_of_int i, Term_sort)) constr.constr_fields in + let constructed_term = mkApp(constr.constr_name, List.map (fun fv -> mkFreeV fv norng) formals) norng in + let inj_formals = List.flatten <| List.map2 (fun f fld -> if fld.field_projectible then [f] else []) formals constr.constr_fields in + let base_term = mkApp(base_name, List.map (fun fv -> mkFreeV fv norng) inj_formals) norng in + let eq = mkEq(constructed_term, base_term) norng in + let guard = mkApp(discriminator_name constr, [constructed_term]) norng in + let q = mkForall rng ([[constructed_term]], formals, mkImp (guard, eq) norng) in + //forall (x0...xn:Term). {:pattern (C x0 ...xn)} is-C (C x0..xn) ==> C x0..xn == C-base x2 x3..xn + let a = { + assumption_name=escape ("constructor_base_" ^ constr.constr_name); + assumption_caption=Some "Constructor base"; + assumption_term=q; + assumption_fact_ids=[] + } in + [decl; Assume a] + ) + in Caption (format1 "" constr.constr_name):: - [cdecl]@cid@projs@[disc] + [cdecl]@cid@projs@[disc]@base @[Caption (format1 "" constr.constr_name)] (****************************************************************************) @@ -906,7 +931,8 @@ and mkPrelude z3options = = { constr_name=name; constr_fields=List.map (fun (field_name, field_sort, field_projectible) -> {field_name; field_sort; field_projectible}) fields; constr_sort=sort; - constr_id=Some id } + constr_id=Some id; + constr_base=false } in let constrs : constructors = List.map as_constr @@ -986,7 +1012,8 @@ let mkBvConstructor (sz : int) = constr_name=fst (boxBitVecFun sz); constr_sort=Term_sort; constr_id=None; - constr_fields=[{field_projectible=true; field_name=snd (boxBitVecFun sz); field_sort=BitVec_sort sz }] + constr_fields=[{field_projectible=true; field_name=snd (boxBitVecFun sz); field_sort=BitVec_sort sz }]; + constr_base=false } in constructor_to_decl norng constr, constr.constr_name, diff --git a/src/smtencoding/FStar.SMTEncoding.Term.fsti b/src/smtencoding/FStar.SMTEncoding.Term.fsti index 462b1c41477..e76808f9dd2 100644 --- a/src/smtencoding/FStar.SMTEncoding.Term.fsti +++ b/src/smtencoding/FStar.SMTEncoding.Term.fsti @@ -20,6 +20,8 @@ open FStar.Compiler open FStar.Compiler.Effect open FStar.Compiler.Util open FStar.Class.Show +open FStar.Compiler.List +open FStar.Class.Ord module S = FStar.Syntax.Syntax @@ -102,8 +104,10 @@ type constructor_t = { constr_name:string; constr_fields:list constructor_field; constr_sort:sort; - constr_id:option int; //Some i, if a term whose head is this constructor is distinct from - //terms with other head constructors + constr_id:option int; + //Some i, if a term whose head is this constructor is distinct from + //terms with other head constructors + constr_base: bool; //generate a base to eliminate non-injective arguments } type constructors = list constructor_t type fact_db_id = From db285dbf6e869df148315fde17c8cc6eecc2ebf8 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Fri, 19 Apr 2024 16:14:32 -0700 Subject: [PATCH 16/42] remove compat options in ModifiesGen --- ulib/FStar.ModifiesGen.fst | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/ulib/FStar.ModifiesGen.fst b/ulib/FStar.ModifiesGen.fst index ef75c19d967..118c6a4b50c 100644 --- a/ulib/FStar.ModifiesGen.fst +++ b/ulib/FStar.ModifiesGen.fst @@ -54,7 +54,6 @@ let live_addrs_codom (non_live_addrs_codom regions region_liveness_tags)) (r:addrs_dom regions) = (y: GSet.set nat { GSet.subset (non_live_addrs r) y } ) -#push-options "--ext 'compat:injectivity'" noeq type loc' (#al: aloc_t u#x) (c: cls al) : Type u#x = | Loc: @@ -73,7 +72,6 @@ type loc' (#al: aloc_t u#x) (c: cls al) : Type u#x = Ghost.reveal aux `GSet.subset` (aloc_domain c regions (fun _ -> GSet.complement GSet.empty)) } ) -> loc' c -#pop-options let loc = loc' @@ -958,9 +956,9 @@ let modifies_intro_strong #al #c l h h' regions mrefs lives unused_ins alocs = assert_norm (Loc?.region_liveness_tags (loc_mreference #_ #c p) == Ghost.hide Set.empty); assert (loc_disjoint_region_liveness_tags (loc_mreference p) l); // FIXME: WHY WHY WHY is this assert necessary? - assert_spinoff (loc_aux_disjoint (Ghost.reveal (Loc?.aux (loc_mreference p))) (Ghost.reveal (Loc?.aux l))); + assert (loc_aux_disjoint (Ghost.reveal (Loc?.aux (loc_mreference p))) (Ghost.reveal (Loc?.aux l))); // FIXME: Now this one is too :) - assert (loc_disjoint_addrs (loc_mreference p) l); + assert_spinoff (loc_disjoint_addrs (loc_mreference p) l); assert ((loc_disjoint (loc_mreference p) l)); mrefs t pre p in @@ -1315,6 +1313,7 @@ let modifies_loc_addresses_intro_weak modifies_preserves_alocs_intro (loc_union (loc_addresses true r s) l) h1 h2 () (fun r' a b -> if r = r' then f a b else () ) +#push-options "--z3rlimit_factor 4" let modifies_loc_addresses_intro #al #c r s l h1 h2 = loc_includes_loc_regions_restrict_to_regions l (Set.singleton r); loc_includes_loc_union_restrict_to_regions l (Set.singleton r); @@ -1472,6 +1471,8 @@ let disjoint_addrs_of_loc_loc_disjoint )) (ensures (loc_disjoint l1 l2)) = // FIXME: WHY WHY WHY do I need this assert? + let Loc _ _ _ _ _ = l1 in + let Loc _ _ _ _ _ = l2 in let l1' = Ghost.reveal (Loc?.aux l1) in let l2' = Ghost.reveal (Loc?.aux l2) in assert (forall (b1 b2: aloc c) . (GSet.mem b1 l1' /\ GSet.mem b2 l2') ==> aloc_disjoint b1 b2) From 9d39962d124814ba7a995af31dc6ec9166281ab9 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Fri, 19 Apr 2024 18:03:10 -0700 Subject: [PATCH 17/42] revise the statement of inversion of data constructor typing to not reference the irrelevant parameters --- .../generated/FStar_SMTEncoding_Encode.ml | 1092 +++++++++-------- src/smtencoding/FStar.SMTEncoding.Encode.fst | 30 +- tests/bug-reports/Bug3186.fst | 3 - tests/bug-reports/BugBoxInjectivity.fst | 45 +- 4 files changed, 634 insertions(+), 536 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index 5f171b1c4b1..8db7327fa61 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -4121,39 +4121,7 @@ let (encode_sig_inductive : FStar_SMTEncoding_Util.mkEq uu___14) vars indices1 - else - (let num_params = - FStar_Compiler_List.length - tps in - let uu___15 = - FStar_Compiler_List.splitAt - num_params vars in - match uu___15 with - | (_var_params, - var_indices) -> - let uu___16 = - FStar_Compiler_List.splitAt - num_params - indices1 in - (match uu___16 - with - | (_i_params, - indices2) -> - FStar_Compiler_List.map2 - (fun v -> - fun a -> - let uu___17 - = - let uu___18 - = - FStar_SMTEncoding_Util.mkFreeV - v in - (uu___18, - a) in - FStar_SMTEncoding_Util.mkEq - uu___17) - var_indices - indices2)) in + else [] in let uu___13 = let uu___14 = let uu___15 = @@ -4669,51 +4637,60 @@ let (encode_datacon : arg_decls) -> let guards_for_parameter orig_arg arg xv = - let fv1 = - match arg.FStar_SMTEncoding_Term.tm - with - | FStar_SMTEncoding_Term.FreeV - fv2 -> fv2 - | uu___17 -> - let uu___18 - = + if + Prims.op_Negation + is_injective_on_tparams1 + then + FStar_SMTEncoding_Util.mkTrue + else + (let fv1 = + match + arg.FStar_SMTEncoding_Term.tm + with + | FStar_SMTEncoding_Term.FreeV + fv2 -> + fv2 + | uu___18 -> let uu___19 = let uu___20 = + let uu___21 + = FStar_Syntax_Print.term_to_string orig_arg in FStar_Compiler_Util.format1 "Inductive type parameter %s must be a variable ; You may want to change it to an index." - uu___20 in + uu___21 in (FStar_Errors_Codes.Fatal_NonVariableInductiveTypeParameter, - uu___19) in - FStar_Errors.raise_error - uu___18 + uu___20) in + FStar_Errors.raise_error + uu___19 orig_arg.FStar_Syntax_Syntax.pos in - let guards1 = - FStar_Compiler_List.collect - (fun g -> - let uu___17 - = + let guards1 = + FStar_Compiler_List.collect + (fun g -> let uu___18 = + let uu___19 + = FStar_SMTEncoding_Term.free_variables g in FStar_Compiler_List.contains fv1 - uu___18 in - if uu___17 - then - let uu___18 + uu___19 in + if + uu___18 + then + let uu___19 = FStar_SMTEncoding_Term.subst g fv1 xv in - [uu___18] - else []) - guards in - FStar_SMTEncoding_Util.mk_and_l - guards1 in + [uu___19] + else []) + guards in + FStar_SMTEncoding_Util.mk_and_l + guards1) in let uu___17 = let uu___18 = FStar_Compiler_List.zip @@ -4790,101 +4767,142 @@ let (encode_datacon : = FStar_Compiler_List.rev arg_vars in - let ty = - FStar_SMTEncoding_EncodeTerm.maybe_curry_fvb - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.p - encoded_head_fvb + let uu___20 = + FStar_Compiler_List.splitAt + n_tps arg_vars1 in - let xvars1 = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV - vars in - let dapp1 = - FStar_SMTEncoding_Util.mkApp - (ddconstrsym, + (match uu___20 + with + | (arg_params, + uu___21) + -> + let uu___22 + = + FStar_Compiler_List.splitAt + n_tps + vars in + (match uu___22 + with + | + (data_arg_params, + uu___23) + -> + let elim_eqns_and_guards + = + let uu___24 + = + FStar_SMTEncoding_Util.mk_and_l + (FStar_Compiler_List.op_At + elim_eqns_or_guards + guards) in + FStar_Compiler_List.fold_left2 + (fun + elim_eqns_and_guards1 + -> + fun + data_arg_param + -> + fun + arg_param + -> + FStar_SMTEncoding_Term.subst + elim_eqns_and_guards1 + data_arg_param + arg_param) + uu___24 + data_arg_params + arg_params in + let ty = + FStar_SMTEncoding_EncodeTerm.maybe_curry_fvb + (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.p + encoded_head_fvb + arg_vars1 in + let xvars1 + = + FStar_Compiler_List.map + FStar_SMTEncoding_Util.mkFreeV + vars in + let dapp1 + = + FStar_SMTEncoding_Util.mkApp + (ddconstrsym, xvars1) in - let ty_pred = - FStar_SMTEncoding_Term.mk_HasTypeWithFuel - (FStar_Pervasives_Native.Some + let ty_pred + = + FStar_SMTEncoding_Term.mk_HasTypeWithFuel + (FStar_Pervasives_Native.Some s_fuel_tm) - dapp1 ty in - let arg_binders - = - FStar_Compiler_List.map - FStar_SMTEncoding_Term.fv_of_term - arg_vars1 in - let typing_inversion - = - let uu___20 - = - let uu___21 + dapp1 ty in + let arg_binders = - let uu___22 + FStar_Compiler_List.map + FStar_SMTEncoding_Term.fv_of_term + arg_vars1 in + let typing_inversion + = + let uu___24 + = + let uu___25 + = + let uu___26 = FStar_Ident.range_of_lid d in - let uu___23 + let uu___27 = - let uu___24 + let uu___28 = - let uu___25 + let uu___29 = FStar_SMTEncoding_Term.mk_fv (fuel_var, FStar_SMTEncoding_Term.Fuel_sort) in FStar_SMTEncoding_Env.add_fuel - uu___25 + uu___29 (FStar_Compiler_List.op_At vars arg_binders) in - let uu___25 - = - let uu___26 - = - let uu___27 + let uu___29 = - FStar_SMTEncoding_Util.mk_and_l - (FStar_Compiler_List.op_At - elim_eqns_or_guards - guards) in - (ty_pred, - uu___27) in FStar_SMTEncoding_Util.mkImp - uu___26 in + (ty_pred, + elim_eqns_and_guards) in ([ [ty_pred]], - uu___24, - uu___25) in + uu___28, + uu___29) in FStar_SMTEncoding_Term.mkForall - uu___22 - uu___23 in - (uu___21, + uu___26 + uu___27 in + (uu___25, (FStar_Pervasives_Native.Some "data constructor typing elim"), (Prims.strcat "data_elim_" ddconstrsym)) in - FStar_SMTEncoding_Util.mkAssume - uu___20 in - let lex_t = - let uu___20 - = - let uu___21 + FStar_SMTEncoding_Util.mkAssume + uu___24 in + let lex_t = - let uu___22 + let uu___24 + = + let uu___25 + = + let uu___26 = FStar_Ident.string_of_lid FStar_Parser_Const.lex_t_lid in - (uu___22, + (uu___26, FStar_SMTEncoding_Term.Term_sort) in - FStar_SMTEncoding_Term.mk_fv - uu___21 in - FStar_SMTEncoding_Util.mkFreeV - uu___20 in - let subterm_ordering - = - let prec = - let uu___20 + FStar_SMTEncoding_Term.mk_fv + uu___25 in + FStar_SMTEncoding_Util.mkFreeV + uu___24 in + let subterm_ordering + = + let prec + = + let uu___24 = FStar_Compiler_List.mapi (fun i -> @@ -4893,90 +4911,92 @@ let (encode_datacon : i < n_tps then [] else - (let uu___22 + (let uu___26 = - let uu___23 + let uu___27 = FStar_SMTEncoding_Util.mkFreeV v in FStar_SMTEncoding_Util.mk_Precedes lex_t lex_t - uu___23 + uu___27 dapp1 in - [uu___22])) + [uu___26])) vars in - FStar_Compiler_List.flatten - uu___20 in - let uu___20 - = - let uu___21 + FStar_Compiler_List.flatten + uu___24 in + let uu___24 = - let uu___22 + let uu___25 + = + let uu___26 = FStar_Ident.range_of_lid d in - let uu___23 + let uu___27 = - let uu___24 + let uu___28 = - let uu___25 + let uu___29 = FStar_SMTEncoding_Term.mk_fv (fuel_var, FStar_SMTEncoding_Term.Fuel_sort) in FStar_SMTEncoding_Env.add_fuel - uu___25 + uu___29 (FStar_Compiler_List.op_At vars arg_binders) in - let uu___25 + let uu___29 = - let uu___26 + let uu___30 = - let uu___27 + let uu___31 = FStar_SMTEncoding_Util.mk_and_l prec in (ty_pred, - uu___27) in + uu___31) in FStar_SMTEncoding_Util.mkImp - uu___26 in + uu___30 in ([ [ty_pred]], - uu___24, - uu___25) in + uu___28, + uu___29) in FStar_SMTEncoding_Term.mkForall - uu___22 - uu___23 in - (uu___21, + uu___26 + uu___27 in + (uu___25, (FStar_Pervasives_Native.Some "subterm ordering"), (Prims.strcat "subterm_ordering_" ddconstrsym)) in - FStar_SMTEncoding_Util.mkAssume - uu___20 in - let uu___20 = - let uu___21 - = - FStar_Compiler_Util.first_N + FStar_SMTEncoding_Util.mkAssume + uu___24 in + let uu___24 + = + let uu___25 + = + FStar_Compiler_Util.first_N n_tps formals in - match uu___21 - with - | (uu___22, + match uu___25 + with + | + (uu___26, formals') -> - let uu___23 + let uu___27 = FStar_Compiler_Util.first_N n_tps vars in - (match uu___23 + (match uu___27 with | - (uu___24, + (uu___28, vars') -> let norm t2 = @@ -4989,26 +5009,26 @@ let (encode_datacon : env'.FStar_SMTEncoding_Env.tcenv t2 in let warn_compat - uu___25 = - let uu___26 + uu___29 = + let uu___30 = FStar_Syntax_Syntax.range_of_fv fv in FStar_Errors.log_issue - uu___26 + uu___30 (FStar_Errors_Codes.Warning_DeprecatedGeneric, "Using 'compat:2954' to use a permissive encoding of the subterm ordering on the codomain of a constructor.\nThis is deprecated and will be removed in a future version of F*.") in - let uu___25 + let uu___29 = FStar_Compiler_List.fold_left2 (fun - uu___26 + uu___30 -> fun formal -> fun var -> - match uu___26 + match uu___30 with | (codomain_prec_l, @@ -5019,28 +5039,28 @@ let (encode_datacon : let t3 = FStar_Syntax_Util.unrefine t2 in - let uu___27 + let uu___31 = - let uu___28 + let uu___32 = FStar_Syntax_Subst.compress t3 in - uu___28.FStar_Syntax_Syntax.n in - match uu___27 + uu___32.FStar_Syntax_Syntax.n in + match uu___31 with | FStar_Syntax_Syntax.Tm_arrow - uu___28 + uu___32 -> - let uu___29 + let uu___33 = - let uu___30 + let uu___34 = FStar_Syntax_Util.unrefine t3 in FStar_Syntax_Util.arrow_formals_comp - uu___30 in - (match uu___29 + uu___34 in + (match uu___33 with | (bs, c) @@ -5051,25 +5071,25 @@ let (encode_datacon : [] -> FStar_Pervasives_Native.None | - uu___30 + uu___34 when - let uu___31 + let uu___35 = FStar_Syntax_Util.is_tot_or_gtot_comp c in Prims.op_Negation - uu___31 + uu___35 -> FStar_Pervasives_Native.None | - uu___30 + uu___34 -> - let uu___31 + let uu___35 = FStar_Syntax_Util.is_lemma_comp c in if - uu___31 + uu___35 then FStar_Pervasives_Native.None else @@ -5079,61 +5099,61 @@ let (encode_datacon : c) in let t5 = norm t4 in - let uu___33 + let uu___37 = (FStar_Syntax_Syntax.is_type t5) || (FStar_Syntax_Util.is_sub_singleton t5) in if - uu___33 + uu___37 then FStar_Pervasives_Native.None else - (let uu___35 + (let uu___39 = FStar_Syntax_Util.head_and_args_full t5 in - match uu___35 + match uu___39 with | (head1, - uu___36) + uu___40) -> - let uu___37 + let uu___41 = - let uu___38 + let uu___42 = FStar_Syntax_Util.un_uinst head1 in - uu___38.FStar_Syntax_Syntax.n in - (match uu___37 + uu___42.FStar_Syntax_Syntax.n in + (match uu___41 with | FStar_Syntax_Syntax.Tm_fvar fv1 -> - let uu___38 + let uu___42 = FStar_Compiler_Util.for_some (FStar_Syntax_Syntax.fv_eq_lid fv1) mutuals in if - uu___38 + uu___42 then FStar_Pervasives_Native.Some (bs, c) else - (let uu___40 + (let uu___44 = - let uu___41 + let uu___45 = FStar_Options.ext_getv "compat:2954" in - uu___41 + uu___45 <> "" in if - uu___40 + uu___44 then (warn_compat (); @@ -5142,18 +5162,18 @@ let (encode_datacon : else FStar_Pervasives_Native.None) | - uu___38 + uu___42 -> - let uu___39 + let uu___43 = - let uu___40 + let uu___44 = FStar_Options.ext_getv "compat:2954" in - uu___40 + uu___44 <> "" in if - uu___39 + uu___43 then (warn_compat (); @@ -5162,36 +5182,36 @@ let (encode_datacon : else FStar_Pervasives_Native.None))))) | - uu___28 + uu___32 -> - let uu___29 + let uu___33 = FStar_Syntax_Util.head_and_args t3 in - (match uu___29 + (match uu___33 with | (head1, - uu___30) + uu___34) -> let t' = norm t3 in - let uu___31 + let uu___35 = FStar_Syntax_Util.head_and_args t' in - (match uu___31 + (match uu___35 with | (head', - uu___32) + uu___36) -> - let uu___33 + let uu___37 = FStar_Syntax_Util.eq_tm head1 head' in - (match uu___33 + (match uu___37 with | FStar_Syntax_Util.Equal @@ -5203,44 +5223,44 @@ let (encode_datacon : binder_and_codomain_type t' | - uu___34 + uu___38 -> - let uu___35 + let uu___39 = - let uu___36 + let uu___40 = FStar_Syntax_Subst.compress head1 in - uu___36.FStar_Syntax_Syntax.n in - (match uu___35 + uu___40.FStar_Syntax_Syntax.n in + (match uu___39 with | FStar_Syntax_Syntax.Tm_fvar - uu___36 + uu___40 -> binder_and_codomain_type t' | FStar_Syntax_Syntax.Tm_name - uu___36 + uu___40 -> binder_and_codomain_type t' | FStar_Syntax_Syntax.Tm_uinst - uu___36 + uu___40 -> binder_and_codomain_type t' | - uu___36 + uu___40 -> FStar_Pervasives_Native.None)))) in - let uu___27 + let uu___31 = binder_and_codomain_type (formal.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - (match uu___27 + (match uu___31 with | FStar_Pervasives_Native.None @@ -5251,90 +5271,90 @@ let (encode_datacon : FStar_Pervasives_Native.Some (bs, c) -> - let uu___28 + let uu___32 = FStar_SMTEncoding_EncodeTerm.encode_binders FStar_Pervasives_Native.None bs env' in - (match uu___28 + (match uu___32 with | (bs', guards', _env', bs_decls, - uu___29) + uu___33) -> let fun_app = - let uu___30 + let uu___34 = FStar_SMTEncoding_Util.mkFreeV var in FStar_SMTEncoding_EncodeTerm.mk_Apply - uu___30 + uu___34 bs' in - let uu___30 + let uu___34 = - let uu___31 + let uu___35 = - let uu___32 + let uu___36 = FStar_Ident.range_of_lid d in - let uu___33 + let uu___37 = - let uu___34 + let uu___38 = - let uu___35 + let uu___39 = - let uu___36 + let uu___40 = FStar_SMTEncoding_Util.mk_Precedes lex_t lex_t fun_app dapp1 in - [uu___36] in - [uu___35] in - let uu___35 + [uu___40] in + [uu___39] in + let uu___39 = - let uu___36 + let uu___40 = - let uu___37 + let uu___41 = FStar_SMTEncoding_Util.mk_and_l (ty_pred' :: guards') in - let uu___38 + let uu___42 = FStar_SMTEncoding_Util.mk_Precedes lex_t lex_t fun_app dapp1 in - (uu___37, - uu___38) in + (uu___41, + uu___42) in FStar_SMTEncoding_Util.mkImp - uu___36 in - (uu___34, + uu___40 in + (uu___38, bs', - uu___35) in + uu___39) in FStar_SMTEncoding_Term.mkForall - uu___32 - uu___33 in - uu___31 + uu___36 + uu___37 in + uu___35 :: codomain_prec_l in - (uu___30, + (uu___34, (FStar_Compiler_List.op_At bs_decls cod_decls))))) ([], []) formals' vars' in - (match uu___25 + (match uu___29 with | (codomain_prec_l, @@ -5347,60 +5367,61 @@ let (encode_datacon : ([], cod_decls) | - uu___26 + uu___30 -> - let uu___27 + let uu___31 = - let uu___28 + let uu___32 = - let uu___29 + let uu___33 = - let uu___30 + let uu___34 = - let uu___31 + let uu___35 = FStar_Ident.range_of_lid d in - let uu___32 + let uu___36 = - let uu___33 + let uu___37 = - let uu___34 + let uu___38 = FStar_SMTEncoding_Term.mk_fv (fuel_var, FStar_SMTEncoding_Term.Fuel_sort) in FStar_SMTEncoding_Env.add_fuel - uu___34 + uu___38 (FStar_Compiler_List.op_At vars arg_binders) in - let uu___34 + let uu___38 = FStar_SMTEncoding_Util.mk_and_l codomain_prec_l in ([ [ty_pred]], - uu___33, - uu___34) in + uu___37, + uu___38) in FStar_SMTEncoding_Term.mkForall - uu___31 - uu___32 in - (uu___30, + uu___35 + uu___36 in + (uu___34, (FStar_Pervasives_Native.Some "well-founded ordering on codomain"), (Prims.strcat "well_founded_ordering_on_codomain_" ddconstrsym)) in FStar_SMTEncoding_Util.mkAssume - uu___29 in - [uu___28] in - (uu___27, + uu___33 in + [uu___32] in + (uu___31, cod_decls)))) in - (match uu___20 - with - | (codomain_ordering, - codomain_decls) + (match uu___24 + with + | + (codomain_ordering, + codomain_decls) -> ((FStar_Compiler_List.op_At arg_decls @@ -5408,7 +5429,7 @@ let (encode_datacon : (FStar_Compiler_List.op_At [typing_inversion; subterm_ordering] - codomain_ordering))))) + codomain_ordering))))))) | FStar_Syntax_Syntax.Tm_fvar fv -> let encoded_head_fvb = @@ -5423,51 +5444,60 @@ let (encode_datacon : arg_decls) -> let guards_for_parameter orig_arg arg xv = - let fv1 = - match arg.FStar_SMTEncoding_Term.tm - with - | FStar_SMTEncoding_Term.FreeV - fv2 -> fv2 - | uu___13 -> - let uu___14 - = + if + Prims.op_Negation + is_injective_on_tparams1 + then + FStar_SMTEncoding_Util.mkTrue + else + (let fv1 = + match + arg.FStar_SMTEncoding_Term.tm + with + | FStar_SMTEncoding_Term.FreeV + fv2 -> + fv2 + | uu___14 -> let uu___15 = let uu___16 = + let uu___17 + = FStar_Syntax_Print.term_to_string orig_arg in FStar_Compiler_Util.format1 "Inductive type parameter %s must be a variable ; You may want to change it to an index." - uu___16 in + uu___17 in (FStar_Errors_Codes.Fatal_NonVariableInductiveTypeParameter, - uu___15) in - FStar_Errors.raise_error - uu___14 + uu___16) in + FStar_Errors.raise_error + uu___15 orig_arg.FStar_Syntax_Syntax.pos in - let guards1 = - FStar_Compiler_List.collect - (fun g -> - let uu___13 - = + let guards1 = + FStar_Compiler_List.collect + (fun g -> let uu___14 = + let uu___15 + = FStar_SMTEncoding_Term.free_variables g in FStar_Compiler_List.contains fv1 - uu___14 in - if uu___13 - then - let uu___14 + uu___15 in + if + uu___14 + then + let uu___15 = FStar_SMTEncoding_Term.subst g fv1 xv in - [uu___14] - else []) - guards in - FStar_SMTEncoding_Util.mk_and_l - guards1 in + [uu___15] + else []) + guards in + FStar_SMTEncoding_Util.mk_and_l + guards1) in let uu___13 = let uu___14 = FStar_Compiler_List.zip @@ -5544,101 +5574,142 @@ let (encode_datacon : = FStar_Compiler_List.rev arg_vars in - let ty = - FStar_SMTEncoding_EncodeTerm.maybe_curry_fvb - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.p - encoded_head_fvb + let uu___16 = + FStar_Compiler_List.splitAt + n_tps arg_vars1 in - let xvars1 = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV - vars in - let dapp1 = - FStar_SMTEncoding_Util.mkApp - (ddconstrsym, + (match uu___16 + with + | (arg_params, + uu___17) + -> + let uu___18 + = + FStar_Compiler_List.splitAt + n_tps + vars in + (match uu___18 + with + | + (data_arg_params, + uu___19) + -> + let elim_eqns_and_guards + = + let uu___20 + = + FStar_SMTEncoding_Util.mk_and_l + (FStar_Compiler_List.op_At + elim_eqns_or_guards + guards) in + FStar_Compiler_List.fold_left2 + (fun + elim_eqns_and_guards1 + -> + fun + data_arg_param + -> + fun + arg_param + -> + FStar_SMTEncoding_Term.subst + elim_eqns_and_guards1 + data_arg_param + arg_param) + uu___20 + data_arg_params + arg_params in + let ty = + FStar_SMTEncoding_EncodeTerm.maybe_curry_fvb + (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.p + encoded_head_fvb + arg_vars1 in + let xvars1 + = + FStar_Compiler_List.map + FStar_SMTEncoding_Util.mkFreeV + vars in + let dapp1 + = + FStar_SMTEncoding_Util.mkApp + (ddconstrsym, xvars1) in - let ty_pred = - FStar_SMTEncoding_Term.mk_HasTypeWithFuel - (FStar_Pervasives_Native.Some + let ty_pred + = + FStar_SMTEncoding_Term.mk_HasTypeWithFuel + (FStar_Pervasives_Native.Some s_fuel_tm) - dapp1 ty in - let arg_binders - = - FStar_Compiler_List.map - FStar_SMTEncoding_Term.fv_of_term - arg_vars1 in - let typing_inversion - = - let uu___16 - = - let uu___17 + dapp1 ty in + let arg_binders = - let uu___18 + FStar_Compiler_List.map + FStar_SMTEncoding_Term.fv_of_term + arg_vars1 in + let typing_inversion + = + let uu___20 + = + let uu___21 + = + let uu___22 = FStar_Ident.range_of_lid d in - let uu___19 + let uu___23 = - let uu___20 + let uu___24 = - let uu___21 + let uu___25 = FStar_SMTEncoding_Term.mk_fv (fuel_var, FStar_SMTEncoding_Term.Fuel_sort) in FStar_SMTEncoding_Env.add_fuel - uu___21 + uu___25 (FStar_Compiler_List.op_At vars arg_binders) in - let uu___21 - = - let uu___22 - = - let uu___23 + let uu___25 = - FStar_SMTEncoding_Util.mk_and_l - (FStar_Compiler_List.op_At - elim_eqns_or_guards - guards) in - (ty_pred, - uu___23) in FStar_SMTEncoding_Util.mkImp - uu___22 in + (ty_pred, + elim_eqns_and_guards) in ([ [ty_pred]], - uu___20, - uu___21) in + uu___24, + uu___25) in FStar_SMTEncoding_Term.mkForall - uu___18 - uu___19 in - (uu___17, + uu___22 + uu___23 in + (uu___21, (FStar_Pervasives_Native.Some "data constructor typing elim"), (Prims.strcat "data_elim_" ddconstrsym)) in - FStar_SMTEncoding_Util.mkAssume - uu___16 in - let lex_t = - let uu___16 - = - let uu___17 + FStar_SMTEncoding_Util.mkAssume + uu___20 in + let lex_t = - let uu___18 + let uu___20 + = + let uu___21 + = + let uu___22 = FStar_Ident.string_of_lid FStar_Parser_Const.lex_t_lid in - (uu___18, + (uu___22, FStar_SMTEncoding_Term.Term_sort) in - FStar_SMTEncoding_Term.mk_fv - uu___17 in - FStar_SMTEncoding_Util.mkFreeV - uu___16 in - let subterm_ordering - = - let prec = - let uu___16 + FStar_SMTEncoding_Term.mk_fv + uu___21 in + FStar_SMTEncoding_Util.mkFreeV + uu___20 in + let subterm_ordering + = + let prec + = + let uu___20 = FStar_Compiler_List.mapi (fun i -> @@ -5647,90 +5718,92 @@ let (encode_datacon : i < n_tps then [] else - (let uu___18 + (let uu___22 = - let uu___19 + let uu___23 = FStar_SMTEncoding_Util.mkFreeV v in FStar_SMTEncoding_Util.mk_Precedes lex_t lex_t - uu___19 + uu___23 dapp1 in - [uu___18])) + [uu___22])) vars in - FStar_Compiler_List.flatten - uu___16 in - let uu___16 - = - let uu___17 + FStar_Compiler_List.flatten + uu___20 in + let uu___20 = - let uu___18 + let uu___21 + = + let uu___22 = FStar_Ident.range_of_lid d in - let uu___19 + let uu___23 = - let uu___20 + let uu___24 = - let uu___21 + let uu___25 = FStar_SMTEncoding_Term.mk_fv (fuel_var, FStar_SMTEncoding_Term.Fuel_sort) in FStar_SMTEncoding_Env.add_fuel - uu___21 + uu___25 (FStar_Compiler_List.op_At vars arg_binders) in - let uu___21 + let uu___25 = - let uu___22 + let uu___26 = - let uu___23 + let uu___27 = FStar_SMTEncoding_Util.mk_and_l prec in (ty_pred, - uu___23) in + uu___27) in FStar_SMTEncoding_Util.mkImp - uu___22 in + uu___26 in ([ [ty_pred]], - uu___20, - uu___21) in + uu___24, + uu___25) in FStar_SMTEncoding_Term.mkForall - uu___18 - uu___19 in - (uu___17, + uu___22 + uu___23 in + (uu___21, (FStar_Pervasives_Native.Some "subterm ordering"), (Prims.strcat "subterm_ordering_" ddconstrsym)) in - FStar_SMTEncoding_Util.mkAssume - uu___16 in - let uu___16 = - let uu___17 - = - FStar_Compiler_Util.first_N + FStar_SMTEncoding_Util.mkAssume + uu___20 in + let uu___20 + = + let uu___21 + = + FStar_Compiler_Util.first_N n_tps formals in - match uu___17 - with - | (uu___18, + match uu___21 + with + | + (uu___22, formals') -> - let uu___19 + let uu___23 = FStar_Compiler_Util.first_N n_tps vars in - (match uu___19 + (match uu___23 with | - (uu___20, + (uu___24, vars') -> let norm t2 = @@ -5743,26 +5816,26 @@ let (encode_datacon : env'.FStar_SMTEncoding_Env.tcenv t2 in let warn_compat - uu___21 = - let uu___22 + uu___25 = + let uu___26 = FStar_Syntax_Syntax.range_of_fv fv in FStar_Errors.log_issue - uu___22 + uu___26 (FStar_Errors_Codes.Warning_DeprecatedGeneric, "Using 'compat:2954' to use a permissive encoding of the subterm ordering on the codomain of a constructor.\nThis is deprecated and will be removed in a future version of F*.") in - let uu___21 + let uu___25 = FStar_Compiler_List.fold_left2 (fun - uu___22 + uu___26 -> fun formal -> fun var -> - match uu___22 + match uu___26 with | (codomain_prec_l, @@ -5773,28 +5846,28 @@ let (encode_datacon : let t3 = FStar_Syntax_Util.unrefine t2 in - let uu___23 + let uu___27 = - let uu___24 + let uu___28 = FStar_Syntax_Subst.compress t3 in - uu___24.FStar_Syntax_Syntax.n in - match uu___23 + uu___28.FStar_Syntax_Syntax.n in + match uu___27 with | FStar_Syntax_Syntax.Tm_arrow - uu___24 + uu___28 -> - let uu___25 + let uu___29 = - let uu___26 + let uu___30 = FStar_Syntax_Util.unrefine t3 in FStar_Syntax_Util.arrow_formals_comp - uu___26 in - (match uu___25 + uu___30 in + (match uu___29 with | (bs, c) @@ -5805,25 +5878,25 @@ let (encode_datacon : [] -> FStar_Pervasives_Native.None | - uu___26 + uu___30 when - let uu___27 + let uu___31 = FStar_Syntax_Util.is_tot_or_gtot_comp c in Prims.op_Negation - uu___27 + uu___31 -> FStar_Pervasives_Native.None | - uu___26 + uu___30 -> - let uu___27 + let uu___31 = FStar_Syntax_Util.is_lemma_comp c in if - uu___27 + uu___31 then FStar_Pervasives_Native.None else @@ -5833,61 +5906,61 @@ let (encode_datacon : c) in let t5 = norm t4 in - let uu___29 + let uu___33 = (FStar_Syntax_Syntax.is_type t5) || (FStar_Syntax_Util.is_sub_singleton t5) in if - uu___29 + uu___33 then FStar_Pervasives_Native.None else - (let uu___31 + (let uu___35 = FStar_Syntax_Util.head_and_args_full t5 in - match uu___31 + match uu___35 with | (head1, - uu___32) + uu___36) -> - let uu___33 + let uu___37 = - let uu___34 + let uu___38 = FStar_Syntax_Util.un_uinst head1 in - uu___34.FStar_Syntax_Syntax.n in - (match uu___33 + uu___38.FStar_Syntax_Syntax.n in + (match uu___37 with | FStar_Syntax_Syntax.Tm_fvar fv1 -> - let uu___34 + let uu___38 = FStar_Compiler_Util.for_some (FStar_Syntax_Syntax.fv_eq_lid fv1) mutuals in if - uu___34 + uu___38 then FStar_Pervasives_Native.Some (bs, c) else - (let uu___36 + (let uu___40 = - let uu___37 + let uu___41 = FStar_Options.ext_getv "compat:2954" in - uu___37 + uu___41 <> "" in if - uu___36 + uu___40 then (warn_compat (); @@ -5896,18 +5969,18 @@ let (encode_datacon : else FStar_Pervasives_Native.None) | - uu___34 + uu___38 -> - let uu___35 + let uu___39 = - let uu___36 + let uu___40 = FStar_Options.ext_getv "compat:2954" in - uu___36 + uu___40 <> "" in if - uu___35 + uu___39 then (warn_compat (); @@ -5916,36 +5989,36 @@ let (encode_datacon : else FStar_Pervasives_Native.None))))) | - uu___24 + uu___28 -> - let uu___25 + let uu___29 = FStar_Syntax_Util.head_and_args t3 in - (match uu___25 + (match uu___29 with | (head1, - uu___26) + uu___30) -> let t' = norm t3 in - let uu___27 + let uu___31 = FStar_Syntax_Util.head_and_args t' in - (match uu___27 + (match uu___31 with | (head', - uu___28) + uu___32) -> - let uu___29 + let uu___33 = FStar_Syntax_Util.eq_tm head1 head' in - (match uu___29 + (match uu___33 with | FStar_Syntax_Util.Equal @@ -5957,44 +6030,44 @@ let (encode_datacon : binder_and_codomain_type t' | - uu___30 + uu___34 -> - let uu___31 + let uu___35 = - let uu___32 + let uu___36 = FStar_Syntax_Subst.compress head1 in - uu___32.FStar_Syntax_Syntax.n in - (match uu___31 + uu___36.FStar_Syntax_Syntax.n in + (match uu___35 with | FStar_Syntax_Syntax.Tm_fvar - uu___32 + uu___36 -> binder_and_codomain_type t' | FStar_Syntax_Syntax.Tm_name - uu___32 + uu___36 -> binder_and_codomain_type t' | FStar_Syntax_Syntax.Tm_uinst - uu___32 + uu___36 -> binder_and_codomain_type t' | - uu___32 + uu___36 -> FStar_Pervasives_Native.None)))) in - let uu___23 + let uu___27 = binder_and_codomain_type (formal.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - (match uu___23 + (match uu___27 with | FStar_Pervasives_Native.None @@ -6005,90 +6078,90 @@ let (encode_datacon : FStar_Pervasives_Native.Some (bs, c) -> - let uu___24 + let uu___28 = FStar_SMTEncoding_EncodeTerm.encode_binders FStar_Pervasives_Native.None bs env' in - (match uu___24 + (match uu___28 with | (bs', guards', _env', bs_decls, - uu___25) + uu___29) -> let fun_app = - let uu___26 + let uu___30 = FStar_SMTEncoding_Util.mkFreeV var in FStar_SMTEncoding_EncodeTerm.mk_Apply - uu___26 + uu___30 bs' in - let uu___26 + let uu___30 = - let uu___27 + let uu___31 = - let uu___28 + let uu___32 = FStar_Ident.range_of_lid d in - let uu___29 + let uu___33 = - let uu___30 + let uu___34 = - let uu___31 + let uu___35 = - let uu___32 + let uu___36 = FStar_SMTEncoding_Util.mk_Precedes lex_t lex_t fun_app dapp1 in - [uu___32] in - [uu___31] in - let uu___31 + [uu___36] in + [uu___35] in + let uu___35 = - let uu___32 + let uu___36 = - let uu___33 + let uu___37 = FStar_SMTEncoding_Util.mk_and_l (ty_pred' :: guards') in - let uu___34 + let uu___38 = FStar_SMTEncoding_Util.mk_Precedes lex_t lex_t fun_app dapp1 in - (uu___33, - uu___34) in + (uu___37, + uu___38) in FStar_SMTEncoding_Util.mkImp - uu___32 in - (uu___30, + uu___36 in + (uu___34, bs', - uu___31) in + uu___35) in FStar_SMTEncoding_Term.mkForall - uu___28 - uu___29 in - uu___27 + uu___32 + uu___33 in + uu___31 :: codomain_prec_l in - (uu___26, + (uu___30, (FStar_Compiler_List.op_At bs_decls cod_decls))))) ([], []) formals' vars' in - (match uu___21 + (match uu___25 with | (codomain_prec_l, @@ -6101,60 +6174,61 @@ let (encode_datacon : ([], cod_decls) | - uu___22 + uu___26 -> - let uu___23 + let uu___27 = - let uu___24 + let uu___28 = - let uu___25 + let uu___29 = - let uu___26 + let uu___30 = - let uu___27 + let uu___31 = FStar_Ident.range_of_lid d in - let uu___28 + let uu___32 = - let uu___29 + let uu___33 = - let uu___30 + let uu___34 = FStar_SMTEncoding_Term.mk_fv (fuel_var, FStar_SMTEncoding_Term.Fuel_sort) in FStar_SMTEncoding_Env.add_fuel - uu___30 + uu___34 (FStar_Compiler_List.op_At vars arg_binders) in - let uu___30 + let uu___34 = FStar_SMTEncoding_Util.mk_and_l codomain_prec_l in ([ [ty_pred]], - uu___29, - uu___30) in + uu___33, + uu___34) in FStar_SMTEncoding_Term.mkForall - uu___27 - uu___28 in - (uu___26, + uu___31 + uu___32 in + (uu___30, (FStar_Pervasives_Native.Some "well-founded ordering on codomain"), (Prims.strcat "well_founded_ordering_on_codomain_" ddconstrsym)) in FStar_SMTEncoding_Util.mkAssume - uu___25 in - [uu___24] in - (uu___23, + uu___29 in + [uu___28] in + (uu___27, cod_decls)))) in - (match uu___16 - with - | (codomain_ordering, - codomain_decls) + (match uu___20 + with + | + (codomain_ordering, + codomain_decls) -> ((FStar_Compiler_List.op_At arg_decls @@ -6162,7 +6236,7 @@ let (encode_datacon : (FStar_Compiler_List.op_At [typing_inversion; subterm_ordering] - codomain_ordering))))) + codomain_ordering))))))) | uu___12 -> ((let uu___14 = let uu___15 = diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst index 7396d59bd8c..5ce63a6c2f3 100644 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ b/src/smtencoding/FStar.SMTEncoding.Encode.fst @@ -1118,13 +1118,13 @@ let encode_sig_inductive (is_injective_on_params:bool) (env:env_t) (se:sigelt) if is_injective_on_params || Options.ext_getv "compat:injectivity" <> "" then List.map2 (fun v a -> mkEq(mkFreeV v, a)) vars indices - else ( - //only injectivity on indices - let num_params = List.length tps in - let _var_params, var_indices = List.splitAt num_params vars in - let _i_params, indices = List.splitAt num_params indices in - List.map2 (fun v a -> mkEq(mkFreeV v, a)) var_indices indices - ) + else [] + // //only injectivity on indices + // let num_params = List.length tps in + // let _var_params, var_indices = List.splitAt num_params vars in + // let _i_params, indices = List.splitAt num_params indices in + // List.map2 (fun v a -> mkEq(mkFreeV v, a)) var_indices indices + // ) in mkOr(out, mkAnd(mk_data_tester env l xx, eqs |> mk_and_l)), decls@decls') (mkFalse, []) @@ -1290,6 +1290,9 @@ let encode_datacon (is_injective_on_tparams:bool) (env:env_t) (se:sigelt) let encoded_head_fvb = lookup_free_var_name env' fv.fv_name in let encoded_args, arg_decls = encode_args args env' in let guards_for_parameter (orig_arg:S.term)(arg:term) xv = + if not is_injective_on_tparams + then mkTrue + else ( let fv = match arg.tm with | FreeV fv -> fv @@ -1305,6 +1308,7 @@ let encode_datacon (is_injective_on_tparams:bool) (env:env_t) (se:sigelt) else []) in mk_and_l guards + ) in let _, arg_vars, elim_eqns_or_guards, _ = List.fold_left @@ -1322,6 +1326,16 @@ let encode_datacon (is_injective_on_tparams:bool) (env:env_t) (se:sigelt) (FStar.Compiler.List.zip args encoded_args) in let arg_vars = List.rev arg_vars in + let arg_params, _ = List.splitAt n_tps arg_vars in + let data_arg_params, _ = List.splitAt n_tps vars in + let elim_eqns_and_guards = + List.fold_left2 + (fun elim_eqns_and_guards data_arg_param arg_param -> + Term.subst elim_eqns_and_guards data_arg_param arg_param) + (mk_and_l (elim_eqns_or_guards@guards)) + data_arg_params + arg_params + in let ty = maybe_curry_fvb fv.fv_name.p encoded_head_fvb arg_vars in let xvars = List.map mkFreeV vars in let dapp = mkApp(ddconstrsym, xvars) in //arity ok; |xvars| = |formals| = arity @@ -1330,7 +1344,7 @@ let encode_datacon (is_injective_on_tparams:bool) (env:env_t) (se:sigelt) let typing_inversion = Util.mkAssume(mkForall (Ident.range_of_lid d) ([[ty_pred]], add_fuel (mk_fv (fuel_var, Fuel_sort)) (vars@arg_binders), - mkImp(ty_pred, mk_and_l (elim_eqns_or_guards@guards))), + mkImp(ty_pred, elim_eqns_and_guards)), Some "data constructor typing elim", ("data_elim_" ^ ddconstrsym)) in let lex_t = mkFreeV <| mk_fv (string_of_lid Const.lex_t_lid, Term_sort) in diff --git a/tests/bug-reports/Bug3186.fst b/tests/bug-reports/Bug3186.fst index 544473db34a..34b0d9ca191 100644 --- a/tests/bug-reports/Bug3186.fst +++ b/tests/bug-reports/Bug3186.fst @@ -7,9 +7,6 @@ let base2 (x:int) (hyp: equals x 0) = let Refl = hyp in assert (x == 0) - //fails since the inversion on equals is not strong enough - //to be usable directly, since df6fb0d52e52289db625cbdbc7c34d975801d819 -[@@expect_failure [19]] let base2' (x:int) (hyp: equals x 0) = assert (x == 0) diff --git a/tests/bug-reports/BugBoxInjectivity.fst b/tests/bug-reports/BugBoxInjectivity.fst index ebf209f7bdf..c488bfbed1d 100644 --- a/tests/bug-reports/BugBoxInjectivity.fst +++ b/tests/bug-reports/BugBoxInjectivity.fst @@ -1,23 +1,36 @@ module BugBoxInjectivity -open FStar.Functions -module CC = FStar.Cardinality.Universes -type t (a:Type u#1) : Type u#0 = - | Mk : t a +noeq +type ceq (#a:Type) x : a -> Type = + | Refl : ceq #a x x -let inj_t (#a:Type u#1) (x:t a) -: Lemma (x == Mk #a) -= let Mk #_ = x in () +let test a (x y:a) (h:ceq #a x y) : Lemma (x == y) = () + +[@expect_failure] +let bad (h0:ceq true true) (h1:ceq false false) : Lemma (true == false) = + let Refl = h0 in + let Refl = h1 in + () -[@@expect_failure] -let t_injective : squash (is_inj t) = - introduce forall f0 f1. - t f0 == t f1 ==> f0 == f1 - with introduce _ ==> _ - with _ . ( - inj_t #f0 Mk; - inj_t #f1 (coerce_eq () (Mk #f0)) - ) +// open FStar.Functions +// module CC = FStar.Cardinality.Universes + +// type t (a:Type u#1) : Type u#0 = +// | Mk : t a + +// let inj_t (#a:Type u#1) (x:t a) +// : Lemma (x == Mk #a) +// = let Mk #_ = x in () + +// [@@expect_failure] +// let t_injective : squash (is_inj t) = +// introduce forall f0 f1. +// t f0 == t f1 ==> f0 == f1 +// with introduce _ ==> _ +// with _ . ( +// inj_t #f0 Mk; +// inj_t #f1 (coerce_eq () (Mk #f0)) +// ) // #restart-solver From ec1ed9d924a7f38fc35a481d539007d883784ac6 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Fri, 19 Apr 2024 19:01:53 -0700 Subject: [PATCH 18/42] remove projector function altogether if it is not injective --- .../generated/FStar_SMTEncoding_Term.ml | 12 +- src/smtencoding/FStar.SMTEncoding.Term.fst | 11 +- tests/bug-reports/BugBoxInjectivity.fst | 116 ++++++------------ 3 files changed, 51 insertions(+), 88 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Term.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Term.ml index 63a65a35a73..7066a54054f 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Term.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Term.ml @@ -1490,13 +1490,13 @@ let (injective_constructor : match uu___2 with | { field_name = name1; field_sort = s; field_projectible = projectible;_} -> - let cproj_app = mkApp (name1, [capp]) norng in - let proj_name = - DeclFun - (name1, [sort1], s, - (FStar_Pervasives_Native.Some "Projector")) in if projectible then + let cproj_app = mkApp (name1, [capp]) norng in + let proj_name = + DeclFun + (name1, [sort1], s, + (FStar_Pervasives_Native.Some "Projector")) in let a = let uu___3 = let uu___4 = @@ -1520,7 +1520,7 @@ let (injective_constructor : assumption_fact_ids = [] } in [proj_name; Assume a] - else [proj_name]) fields in + else []) fields in FStar_Compiler_List.flatten uu___1 let (discriminator_name : constructor_t -> Prims.string) = fun constr -> Prims.strcat "is-" constr.constr_name diff --git a/src/smtencoding/FStar.SMTEncoding.Term.fst b/src/smtencoding/FStar.SMTEncoding.Term.fst index 93ceba286ee..07857606bf2 100644 --- a/src/smtencoding/FStar.SMTEncoding.Term.fst +++ b/src/smtencoding/FStar.SMTEncoding.Term.fst @@ -583,17 +583,18 @@ let injective_constructor let capp = mkApp(name, bvars) norng in fields |> List.mapi (fun i {field_projectible=projectible; field_name=name; field_sort=s} -> - let cproj_app = mkApp(name, [capp]) norng in - let proj_name = DeclFun(name, [sort], s, Some "Projector") in if projectible - then let a = { + then + let cproj_app = mkApp(name, [capp]) norng in + let proj_name = DeclFun(name, [sort], s, Some "Projector") in + let a = { assumption_name = escape ("projection_inverse_"^name); assumption_caption = Some "Projection inverse"; assumption_term = mkForall rng ([[capp]], bvar_names, mkEq(cproj_app, bvar i s norng) norng); assumption_fact_ids = [] } in - [proj_name; Assume a] - else [proj_name]) + [proj_name; Assume a] + else []) |> List.flatten let discriminator_name constr = "is-"^constr.constr_name diff --git a/tests/bug-reports/BugBoxInjectivity.fst b/tests/bug-reports/BugBoxInjectivity.fst index c488bfbed1d..db7f646c1fe 100644 --- a/tests/bug-reports/BugBoxInjectivity.fst +++ b/tests/bug-reports/BugBoxInjectivity.fst @@ -12,85 +12,47 @@ let bad (h0:ceq true true) (h1:ceq false false) : Lemma (true == false) = let Refl = h1 in () -// open FStar.Functions -// module CC = FStar.Cardinality.Universes +open FStar.Functions +module CC = FStar.Cardinality.Universes -// type t (a:Type u#1) : Type u#0 = -// | Mk : t a +type t (a:Type u#1) : Type u#0 = + | Mk : t a -// let inj_t (#a:Type u#1) (x:t a) -// : Lemma (x == Mk #a) -// = let Mk #_ = x in () +let inj_t (#a:Type u#1) (x:t a) +: Lemma (x == Mk #a) += let Mk #_ = x in () -// [@@expect_failure] -// let t_injective : squash (is_inj t) = -// introduce forall f0 f1. -// t f0 == t f1 ==> f0 == f1 -// with introduce _ ==> _ -// with _ . ( -// inj_t #f0 Mk; -// inj_t #f1 (coerce_eq () (Mk #f0)) -// ) +[@@expect_failure] +let t_injective : squash (is_inj t) = + introduce forall f0 f1. + t f0 == t f1 ==> f0 == f1 + with introduce _ ==> _ + with _ . ( + inj_t #f0 Mk; + inj_t #f1 (coerce_eq () (Mk #f0)) + ) -// #restart-solver -// #push-options "--log_queries --query_stats --debug BugBoxInjectivity --debug_level SMTEncoding" -// module CC = FStar.Cardinality.Universes -// noeq -// type test (a:Type u#0 -> Type u#1) : Type u#1 = -// | Mk : test a - -// let const (f:Type u#1) : Type u#0 -> Type u#1 = fun _ -> f -// let itest (f:Type u#1) : Type u#1 = test (const f) -// let itest_inhabited (f:Type u#1) : itest f = Mk -// let const_inversion (f0 f1:Type u#1) -// : Lemma -// (requires const f0 == const f1) -// (ensures f0 == f1) -// = let _f0 = const f0 int in -// let _f1 = const f1 int in -// assert (_f0 == _f1); -// () -// let itest_injective (f0 f1:Type u#1) -// : Lemma -// (ensures itest f0 == itest f1 ==> const f0 == const f1) -// = let x : test (const f0) = itest_inhabited f0 in -// let Mk #_ = x in -// () -// open FStar.Functions -// let itest_injective' : squash (is_inj itest) = -// introduce forall f0 f1. -// itest f0 == itest f1 ==> f0 == f1 -// with introduce _ ==> _ -// with _ . ( -// itest_injective f0 f1; -// const_inversion f0 f1 -// ) -// [@@expect_failure [189]] //itest is not in the right universe to use this lemma -// let fals : squash False = -// CC.no_inj_universes_suc itest - - -// #push-options "--ext 'compat:injectivity'" -// noeq -// type test2 (a:Type u#2) : Type u#1 = -// | Mk2 : test2 a -// #pop-options - -// let test2_inhabited (f:Type u#2) : test2 f = Mk2 -// let test2_injective (f0 f1:Type u#2) -// : Lemma -// (ensures test2 f0 == test2 f1 ==> f0 == f1) -// = let x : test2 f0 = test2_inhabited f0 in -// let Mk2 #_ = x in -// () -// open FStar.Functions -// let itest2_injective' : squash (is_inj test2) = -// introduce forall f0 f1. -// test2 f0 == test2 f1 ==> f0 == f1 -// with introduce _ ==> _ -// with _ . ( -// test2_injective f0 f1 -// ) -// let fals () : squash False = -// CC.no_inj_universes_suc test2 \ No newline at end of file +#push-options "--ext 'compat:injectivity'" +noeq +type test2 (a:Type u#2) : Type u#1 = + | Mk2 : test2 a +#pop-options + +let test2_inhabited (f:Type u#2) : test2 f = Mk2 +let test2_injective (f0 f1:Type u#2) +: Lemma + (ensures test2 f0 == test2 f1 ==> f0 == f1) += let x : test2 f0 = test2_inhabited f0 in + let Mk2 #_ = x in + () +open FStar.Functions +let itest2_injective' : squash (is_inj test2) = + introduce forall f0 f1. + test2 f0 == test2 f1 ==> f0 == f1 + with introduce _ ==> _ + with _ . ( + test2_injective f0 f1 + ) +let fals () : squash False = + CC.no_inj_universes_suc test2 \ No newline at end of file From d1508c85345002daf0d851a2bb260177d8a98a97 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Fri, 19 Apr 2024 19:24:50 -0700 Subject: [PATCH 19/42] try, never injective on params --- ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml | 6 +----- src/smtencoding/FStar.SMTEncoding.Encode.fst | 9 +-------- 2 files changed, 2 insertions(+), 13 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index 8db7327fa61..d881ac473e9 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -7118,11 +7118,7 @@ and (encode_sigelt' : (fun se1 -> FStar_Syntax_Syntax.uu___is_Sig_inductive_typ se1.FStar_Syntax_Syntax.sigel) ses in - let is_injective_on_params = - match tycon with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some se1 -> - is_sig_inductive_injective_on_params env se1 in + let is_injective_on_params = false in let uu___2 = FStar_Compiler_List.fold_left (fun uu___3 -> diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst index 5ce63a6c2f3..4bcf3944deb 100644 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ b/src/smtencoding/FStar.SMTEncoding.Encode.fst @@ -1777,14 +1777,7 @@ and encode_sigelt' (env:env_t) (se:sigelt) : (decls_t * env_t) = | Sig_bundle {ses} -> let tycon = List.tryFind (fun se -> Sig_inductive_typ? se.sigel) ses in - let is_injective_on_params = - match tycon with - | None -> - //Exceptions appear as Sig_bundle without an inductive type - false - | Some se -> - is_sig_inductive_injective_on_params env se - in + let is_injective_on_params = false in let g, env = ses |> List.fold_left From 8ac4ae529d68154c3c48950b850f9f3ebf62dd42 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Sat, 20 Apr 2024 19:36:09 -0700 Subject: [PATCH 20/42] disable compat:injectivity --- .../generated/FStar_SMTEncoding_Encode.ml | 36 ++++++++----------- src/smtencoding/FStar.SMTEncoding.Encode.fst | 17 ++++++--- 2 files changed, 26 insertions(+), 27 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index d881ac473e9..f18f126669d 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -4101,25 +4101,19 @@ let (encode_sig_inductive : "Impossible" else (); (let eqs = - let uu___13 = + if is_injective_on_params - || - (let uu___14 = - FStar_Options.ext_getv - "compat:injectivity" in - uu___14 <> "") in - if uu___13 then FStar_Compiler_List.map2 (fun v -> fun a -> - let uu___14 = - let uu___15 = + let uu___13 = + let uu___14 = FStar_SMTEncoding_Util.mkFreeV v in - (uu___15, a) in + (uu___14, a) in FStar_SMTEncoding_Util.mkEq - uu___14) vars + uu___13) vars indices1 else [] in let uu___13 = @@ -4475,19 +4469,13 @@ let (encode_datacon : env1 in (match uu___6 with | (vars, guards, env', binder_decls, names) -> - let is_injective_on_tparams1 = - is_injective_on_tparams || - (let uu___7 = - FStar_Options.ext_getv - "compat:injectivity" in - uu___7 <> "") in let fields = FStar_Compiler_List.mapi (fun n -> fun x -> let field_projectible = (n >= n_tps) || - is_injective_on_tparams1 in + is_injective_on_tparams in let uu___7 = FStar_SMTEncoding_Env.mk_term_projector_name d x in @@ -4519,7 +4507,7 @@ let (encode_datacon : uu___9; FStar_SMTEncoding_Term.constr_base = (Prims.op_Negation - is_injective_on_tparams1) + is_injective_on_tparams) } in FStar_SMTEncoding_Term.constructor_to_decl uu___7 uu___8 in @@ -4639,7 +4627,7 @@ let (encode_datacon : orig_arg arg xv = if Prims.op_Negation - is_injective_on_tparams1 + is_injective_on_tparams then FStar_SMTEncoding_Util.mkTrue else @@ -5446,7 +5434,7 @@ let (encode_datacon : orig_arg arg xv = if Prims.op_Negation - is_injective_on_tparams1 + is_injective_on_tparams then FStar_SMTEncoding_Util.mkTrue else @@ -7118,7 +7106,11 @@ and (encode_sigelt' : (fun se1 -> FStar_Syntax_Syntax.uu___is_Sig_inductive_typ se1.FStar_Syntax_Syntax.sigel) ses in - let is_injective_on_params = false in + let is_injective_on_params = + match tycon with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some se1 -> + is_sig_inductive_injective_on_params env se1 in let uu___2 = FStar_Compiler_List.fold_left (fun uu___3 -> diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst index 4bcf3944deb..3f2213ade20 100644 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ b/src/smtencoding/FStar.SMTEncoding.Encode.fst @@ -1116,7 +1116,7 @@ let encode_sig_inductive (is_injective_on_params:bool) (env:env_t) (se:sigelt) then failwith "Impossible"; let eqs = if is_injective_on_params - || Options.ext_getv "compat:injectivity" <> "" + // || Options.ext_getv "compat:injectivity" <> "" then List.map2 (fun v a -> mkEq(mkFreeV v, a)) vars indices else [] // //only injectivity on indices @@ -1228,9 +1228,9 @@ let encode_datacon (is_injective_on_tparams:bool) (env:env_t) (se:sigelt) let fuel_var, fuel_tm = fresh_fvar env.current_module_name "f" Fuel_sort in let s_fuel_tm = mkApp("SFuel", [fuel_tm]) in let vars, guards, env', binder_decls, names = encode_binders (Some fuel_tm) formals env in - let is_injective_on_tparams = - is_injective_on_tparams || Options.ext_getv "compat:injectivity" <> "" - in + // let is_injective_on_tparams = + // is_injective_on_tparams || Options.ext_getv "compat:injectivity" <> "" + // in let fields = names |> List.mapi @@ -1777,7 +1777,14 @@ and encode_sigelt' (env:env_t) (se:sigelt) : (decls_t * env_t) = | Sig_bundle {ses} -> let tycon = List.tryFind (fun se -> Sig_inductive_typ? se.sigel) ses in - let is_injective_on_params = false in + let is_injective_on_params = + match tycon with + | None -> + //Exceptions appear as Sig_bundle without an inductive type + false + | Some se -> + is_sig_inductive_injective_on_params env se + in let g, env = ses |> List.fold_left From 0ac8a71bb1a728a29fc2ad99bbd42f5ccc547365 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Mon, 22 Apr 2024 12:56:21 -0700 Subject: [PATCH 21/42] remove duplicated guards --- .../generated/FStar_SMTEncoding_Encode.ml | 122 ++++++++---------- src/smtencoding/FStar.SMTEncoding.Encode.fst | 25 +--- 2 files changed, 55 insertions(+), 92 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index f18f126669d..551f6a7f3d6 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -4625,60 +4625,51 @@ let (encode_datacon : arg_decls) -> let guards_for_parameter orig_arg arg xv = - if - Prims.op_Negation - is_injective_on_tparams - then - FStar_SMTEncoding_Util.mkTrue - else - (let fv1 = - match - arg.FStar_SMTEncoding_Term.tm - with - | FStar_SMTEncoding_Term.FreeV - fv2 -> - fv2 - | uu___18 -> + let fv1 = + match arg.FStar_SMTEncoding_Term.tm + with + | FStar_SMTEncoding_Term.FreeV + fv2 -> fv2 + | uu___17 -> + let uu___18 + = let uu___19 = let uu___20 = - let uu___21 - = FStar_Syntax_Print.term_to_string orig_arg in FStar_Compiler_Util.format1 "Inductive type parameter %s must be a variable ; You may want to change it to an index." - uu___21 in + uu___20 in (FStar_Errors_Codes.Fatal_NonVariableInductiveTypeParameter, - uu___20) in - FStar_Errors.raise_error - uu___19 + uu___19) in + FStar_Errors.raise_error + uu___18 orig_arg.FStar_Syntax_Syntax.pos in - let guards1 = - FStar_Compiler_List.collect - (fun g -> - let uu___18 + let guards1 = + FStar_Compiler_List.collect + (fun g -> + let uu___17 = - let uu___19 + let uu___18 = FStar_SMTEncoding_Term.free_variables g in FStar_Compiler_List.contains fv1 - uu___19 in - if - uu___18 - then - let uu___19 + uu___18 in + if uu___17 + then + let uu___18 = FStar_SMTEncoding_Term.subst g fv1 xv in - [uu___19] - else []) - guards in - FStar_SMTEncoding_Util.mk_and_l - guards1) in + [uu___18] + else []) + guards in + FStar_SMTEncoding_Util.mk_and_l + guards1 in let uu___17 = let uu___18 = FStar_Compiler_List.zip @@ -5432,60 +5423,51 @@ let (encode_datacon : arg_decls) -> let guards_for_parameter orig_arg arg xv = - if - Prims.op_Negation - is_injective_on_tparams - then - FStar_SMTEncoding_Util.mkTrue - else - (let fv1 = - match - arg.FStar_SMTEncoding_Term.tm - with - | FStar_SMTEncoding_Term.FreeV - fv2 -> - fv2 - | uu___14 -> + let fv1 = + match arg.FStar_SMTEncoding_Term.tm + with + | FStar_SMTEncoding_Term.FreeV + fv2 -> fv2 + | uu___13 -> + let uu___14 + = let uu___15 = let uu___16 = - let uu___17 - = FStar_Syntax_Print.term_to_string orig_arg in FStar_Compiler_Util.format1 "Inductive type parameter %s must be a variable ; You may want to change it to an index." - uu___17 in + uu___16 in (FStar_Errors_Codes.Fatal_NonVariableInductiveTypeParameter, - uu___16) in - FStar_Errors.raise_error - uu___15 + uu___15) in + FStar_Errors.raise_error + uu___14 orig_arg.FStar_Syntax_Syntax.pos in - let guards1 = - FStar_Compiler_List.collect - (fun g -> - let uu___14 + let guards1 = + FStar_Compiler_List.collect + (fun g -> + let uu___13 = - let uu___15 + let uu___14 = FStar_SMTEncoding_Term.free_variables g in FStar_Compiler_List.contains fv1 - uu___15 in - if - uu___14 - then - let uu___15 + uu___14 in + if uu___13 + then + let uu___14 = FStar_SMTEncoding_Term.subst g fv1 xv in - [uu___15] - else []) - guards in - FStar_SMTEncoding_Util.mk_and_l - guards1) in + [uu___14] + else []) + guards in + FStar_SMTEncoding_Util.mk_and_l + guards1 in let uu___13 = let uu___14 = FStar_Compiler_List.zip diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst index 3f2213ade20..1b14cfedd9b 100644 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ b/src/smtencoding/FStar.SMTEncoding.Encode.fst @@ -1289,27 +1289,6 @@ let encode_datacon (is_injective_on_tparams:bool) (env:env_t) (se:sigelt) | Tm_fvar fv -> let encoded_head_fvb = lookup_free_var_name env' fv.fv_name in let encoded_args, arg_decls = encode_args args env' in - let guards_for_parameter (orig_arg:S.term)(arg:term) xv = - if not is_injective_on_tparams - then mkTrue - else ( - let fv = - match arg.tm with - | FreeV fv -> fv - | _ -> - Errors.raise_error (Errors.Fatal_NonVariableInductiveTypeParameter, - BU.format1 "Inductive type parameter %s must be a variable ; \ - You may want to change it to an index." - (FStar.Syntax.Print.term_to_string orig_arg)) orig_arg.pos - in - let guards = guards |> List.collect (fun g -> - if List.contains fv (Term.free_variables g) - then [Term.subst g fv xv] - else []) - in - mk_and_l guards - ) - in let _, arg_vars, elim_eqns_or_guards, _ = List.fold_left (fun (env, arg_vars, eqns_or_guards, i) (orig_arg, arg) -> @@ -1318,7 +1297,7 @@ let encode_datacon (is_injective_on_tparams:bool) (env:env_t) (se:sigelt) (* Also see https://github.com/FStarLang/FStar/issues/349 *) let eqns = if i < n_tps - then guards_for_parameter (fst orig_arg) arg xv::eqns_or_guards + then eqns_or_guards else mkEq(arg, xv)::eqns_or_guards in (env, xv::arg_vars, eqns, i + 1)) @@ -1328,6 +1307,8 @@ let encode_datacon (is_injective_on_tparams:bool) (env:env_t) (se:sigelt) let arg_vars = List.rev arg_vars in let arg_params, _ = List.splitAt n_tps arg_vars in let data_arg_params, _ = List.splitAt n_tps vars in + //Express the guards in terms of the parameters of the type constructor + //not the arguments of the data constructor let elim_eqns_and_guards = List.fold_left2 (fun elim_eqns_and_guards data_arg_param arg_param -> From ba8cb90722765a3d2b1b51e62ec6a64d3031b9ae Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Mon, 22 Apr 2024 12:57:56 -0700 Subject: [PATCH 22/42] revert disabling compat options --- .../generated/FStar_SMTEncoding_Encode.ml | 142 +++--------------- src/smtencoding/FStar.SMTEncoding.Encode.fst | 17 +-- 2 files changed, 25 insertions(+), 134 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index 551f6a7f3d6..0cb6a4a5751 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -4101,19 +4101,25 @@ let (encode_sig_inductive : "Impossible" else (); (let eqs = - if + let uu___13 = is_injective_on_params + || + (let uu___14 = + FStar_Options.ext_getv + "compat:injectivity" in + uu___14 <> "") in + if uu___13 then FStar_Compiler_List.map2 (fun v -> fun a -> - let uu___13 = - let uu___14 = + let uu___14 = + let uu___15 = FStar_SMTEncoding_Util.mkFreeV v in - (uu___14, a) in + (uu___15, a) in FStar_SMTEncoding_Util.mkEq - uu___13) vars + uu___14) vars indices1 else [] in let uu___13 = @@ -4469,13 +4475,19 @@ let (encode_datacon : env1 in (match uu___6 with | (vars, guards, env', binder_decls, names) -> + let is_injective_on_tparams1 = + is_injective_on_tparams || + (let uu___7 = + FStar_Options.ext_getv + "compat:injectivity" in + uu___7 <> "") in let fields = FStar_Compiler_List.mapi (fun n -> fun x -> let field_projectible = (n >= n_tps) || - is_injective_on_tparams in + is_injective_on_tparams1 in let uu___7 = FStar_SMTEncoding_Env.mk_term_projector_name d x in @@ -4507,7 +4519,7 @@ let (encode_datacon : uu___9; FStar_SMTEncoding_Term.constr_base = (Prims.op_Negation - is_injective_on_tparams) + is_injective_on_tparams1) } in FStar_SMTEncoding_Term.constructor_to_decl uu___7 uu___8 in @@ -4623,53 +4635,6 @@ let (encode_datacon : (match uu___16 with | (encoded_args, arg_decls) -> - let guards_for_parameter - orig_arg arg xv = - let fv1 = - match arg.FStar_SMTEncoding_Term.tm - with - | FStar_SMTEncoding_Term.FreeV - fv2 -> fv2 - | uu___17 -> - let uu___18 - = - let uu___19 - = - let uu___20 - = - FStar_Syntax_Print.term_to_string - orig_arg in - FStar_Compiler_Util.format1 - "Inductive type parameter %s must be a variable ; You may want to change it to an index." - uu___20 in - (FStar_Errors_Codes.Fatal_NonVariableInductiveTypeParameter, - uu___19) in - FStar_Errors.raise_error - uu___18 - orig_arg.FStar_Syntax_Syntax.pos in - let guards1 = - FStar_Compiler_List.collect - (fun g -> - let uu___17 - = - let uu___18 - = - FStar_SMTEncoding_Term.free_variables - g in - FStar_Compiler_List.contains - fv1 - uu___18 in - if uu___17 - then - let uu___18 - = - FStar_SMTEncoding_Term.subst - g fv1 xv in - [uu___18] - else []) - guards in - FStar_SMTEncoding_Util.mk_and_l - guards1 in let uu___17 = let uu___18 = FStar_Compiler_List.zip @@ -4711,14 +4676,6 @@ let (encode_datacon : if i < n_tps then - let uu___23 - = - guards_for_parameter - (FStar_Pervasives_Native.fst - orig_arg) - arg xv in - uu___23 - :: eqns_or_guards else (let uu___24 @@ -5421,53 +5378,6 @@ let (encode_datacon : (match uu___12 with | (encoded_args, arg_decls) -> - let guards_for_parameter - orig_arg arg xv = - let fv1 = - match arg.FStar_SMTEncoding_Term.tm - with - | FStar_SMTEncoding_Term.FreeV - fv2 -> fv2 - | uu___13 -> - let uu___14 - = - let uu___15 - = - let uu___16 - = - FStar_Syntax_Print.term_to_string - orig_arg in - FStar_Compiler_Util.format1 - "Inductive type parameter %s must be a variable ; You may want to change it to an index." - uu___16 in - (FStar_Errors_Codes.Fatal_NonVariableInductiveTypeParameter, - uu___15) in - FStar_Errors.raise_error - uu___14 - orig_arg.FStar_Syntax_Syntax.pos in - let guards1 = - FStar_Compiler_List.collect - (fun g -> - let uu___13 - = - let uu___14 - = - FStar_SMTEncoding_Term.free_variables - g in - FStar_Compiler_List.contains - fv1 - uu___14 in - if uu___13 - then - let uu___14 - = - FStar_SMTEncoding_Term.subst - g fv1 xv in - [uu___14] - else []) - guards in - FStar_SMTEncoding_Util.mk_and_l - guards1 in let uu___13 = let uu___14 = FStar_Compiler_List.zip @@ -5509,14 +5419,6 @@ let (encode_datacon : if i < n_tps then - let uu___19 - = - guards_for_parameter - (FStar_Pervasives_Native.fst - orig_arg) - arg xv in - uu___19 - :: eqns_or_guards else (let uu___20 @@ -7088,11 +6990,7 @@ and (encode_sigelt' : (fun se1 -> FStar_Syntax_Syntax.uu___is_Sig_inductive_typ se1.FStar_Syntax_Syntax.sigel) ses in - let is_injective_on_params = - match tycon with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some se1 -> - is_sig_inductive_injective_on_params env se1 in + let is_injective_on_params = false in let uu___2 = FStar_Compiler_List.fold_left (fun uu___3 -> diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst index 1b14cfedd9b..0a02ec0de0e 100644 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ b/src/smtencoding/FStar.SMTEncoding.Encode.fst @@ -1116,7 +1116,7 @@ let encode_sig_inductive (is_injective_on_params:bool) (env:env_t) (se:sigelt) then failwith "Impossible"; let eqs = if is_injective_on_params - // || Options.ext_getv "compat:injectivity" <> "" + || Options.ext_getv "compat:injectivity" <> "" then List.map2 (fun v a -> mkEq(mkFreeV v, a)) vars indices else [] // //only injectivity on indices @@ -1228,9 +1228,9 @@ let encode_datacon (is_injective_on_tparams:bool) (env:env_t) (se:sigelt) let fuel_var, fuel_tm = fresh_fvar env.current_module_name "f" Fuel_sort in let s_fuel_tm = mkApp("SFuel", [fuel_tm]) in let vars, guards, env', binder_decls, names = encode_binders (Some fuel_tm) formals env in - // let is_injective_on_tparams = - // is_injective_on_tparams || Options.ext_getv "compat:injectivity" <> "" - // in + let is_injective_on_tparams = + is_injective_on_tparams || Options.ext_getv "compat:injectivity" <> "" + in let fields = names |> List.mapi @@ -1758,14 +1758,7 @@ and encode_sigelt' (env:env_t) (se:sigelt) : (decls_t * env_t) = | Sig_bundle {ses} -> let tycon = List.tryFind (fun se -> Sig_inductive_typ? se.sigel) ses in - let is_injective_on_params = - match tycon with - | None -> - //Exceptions appear as Sig_bundle without an inductive type - false - | Some se -> - is_sig_inductive_injective_on_params env se - in + let is_injective_on_params = false in let g, env = ses |> List.fold_left From f97222bc2a69a1bda3fe803c6567b4f4834b286c Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Mon, 22 Apr 2024 13:23:13 -0700 Subject: [PATCH 23/42] revert disabling injectivity globally --- ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml | 6 +++++- src/smtencoding/FStar.SMTEncoding.Encode.fst | 9 ++++++++- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index 0cb6a4a5751..2c874ea70ca 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -6990,7 +6990,11 @@ and (encode_sigelt' : (fun se1 -> FStar_Syntax_Syntax.uu___is_Sig_inductive_typ se1.FStar_Syntax_Syntax.sigel) ses in - let is_injective_on_params = false in + let is_injective_on_params = + match tycon with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some se1 -> + is_sig_inductive_injective_on_params env se1 in let uu___2 = FStar_Compiler_List.fold_left (fun uu___3 -> diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst index 0a02ec0de0e..007a612881f 100644 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ b/src/smtencoding/FStar.SMTEncoding.Encode.fst @@ -1758,7 +1758,14 @@ and encode_sigelt' (env:env_t) (se:sigelt) : (decls_t * env_t) = | Sig_bundle {ses} -> let tycon = List.tryFind (fun se -> Sig_inductive_typ? se.sigel) ses in - let is_injective_on_params = false in + let is_injective_on_params = + match tycon with + | None -> + //Exceptions appear as Sig_bundle without an inductive type + false + | Some se -> + is_sig_inductive_injective_on_params env se + in let g, env = ses |> List.fold_left From c1170739f99cf821765b610cf9983bf98595f91d Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Mon, 22 Apr 2024 14:37:53 -0700 Subject: [PATCH 24/42] undo ulib changes --- ulib/FStar.ModifiesGen.fst | 30 ++++++++---------------------- ulib/FStar.WellFounded.Util.fst | 4 ++-- ulib/FStar.WellFounded.fst | 25 +++++-------------------- ulib/FStar.WellFoundedRelation.fst | 9 +-------- ulib/legacy/FStar.Constructive.fst | 13 +++++-------- 5 files changed, 21 insertions(+), 60 deletions(-) diff --git a/ulib/FStar.ModifiesGen.fst b/ulib/FStar.ModifiesGen.fst index 118c6a4b50c..29086459d87 100644 --- a/ulib/FStar.ModifiesGen.fst +++ b/ulib/FStar.ModifiesGen.fst @@ -17,7 +17,7 @@ module FStar.ModifiesGen #set-options "--split_queries no" #set-options "--using_facts_from '*,-FStar.Tactics,-FStar.Reflection,-FStar.List'" -#set-options "--z3rlimit_factor 2" + module HS = FStar.HyperStack module HST = FStar.HyperStack.ST @@ -217,11 +217,7 @@ let loc_equal_elim (#al: aloc_t) (#c: cls al) (s1 s2: loc c) : Lemma (ensures (s1 == s2)) [SMTPat (s1 `loc_equal` s2)] = fun_set_equal_elim (Loc?.non_live_addrs s1) (Loc?.non_live_addrs s2); - fun_set_equal_elim (Loc?.live_addrs s1) (Loc?.live_addrs s2); - let Loc regions1 region_liveness_tags1 _ _ aux1 = s1 in - let Loc regions2 region_liveness_tags2 _ _ aux2 = s2 in - assert (regions1 == regions2); - assert (region_liveness_tags1 == region_liveness_tags2) + fun_set_equal_elim (Loc?.live_addrs s1) (Loc?.live_addrs s2) let loc_union_idem #al #c s = @@ -618,11 +614,7 @@ let loc_disjoint_aloc_elim #al #c #r1 #a1 #r2 #a2 b1 b2 = #push-options "--z3rlimit 15" let loc_disjoint_addresses_intro #al #c preserve_liveness1 preserve_liveness2 r1 r2 n1 n2 = // FIXME: WHY WHY WHY this assert? - let Loc _ _ _ _ _ = (loc_addresses #_ #c preserve_liveness1 r1 n1) in - let Loc _ _ _ _ _ = (loc_addresses #_ #c preserve_liveness2 r2 n2) in - assert (loc_aux_disjoint - (Ghost.reveal (Loc?.aux (loc_addresses #_ #c preserve_liveness1 r1 n1))) - (Ghost.reveal (Loc?.aux (loc_addresses #_ #c preserve_liveness2 r2 n2)))) + assert (loc_aux_disjoint (Ghost.reveal (Loc?.aux (loc_addresses #_ #c preserve_liveness1 r1 n1))) (Ghost.reveal (Loc?.aux (loc_addresses #_ #c preserve_liveness2 r2 n2)))) #pop-options let loc_disjoint_addresses_elim #al #c preserve_liveness1 preserve_liveness2 r1 r2 n1 n2 = () @@ -951,14 +943,12 @@ let modifies_intro_strong #al #c l h h' regions mrefs lives unused_ins alocs = (Set.mem (HS.frameOf p) (regions_of_loc l) ==> ~ (GSet.mem (HS.as_addr p) (addrs_of_loc l (HS.frameOf p)))))) (ensures (HS.contains h' p /\ HS.sel h' p == HS.sel h p)) = - let Loc _ _ _ _ _ = (loc_mreference #_ #c p) in - let Loc _ _ _ _ _ = l in assert_norm (Loc?.region_liveness_tags (loc_mreference #_ #c p) == Ghost.hide Set.empty); assert (loc_disjoint_region_liveness_tags (loc_mreference p) l); // FIXME: WHY WHY WHY is this assert necessary? - assert (loc_aux_disjoint (Ghost.reveal (Loc?.aux (loc_mreference p))) (Ghost.reveal (Loc?.aux l))); + assert_spinoff (loc_aux_disjoint (Ghost.reveal (Loc?.aux (loc_mreference p))) (Ghost.reveal (Loc?.aux l))); // FIXME: Now this one is too :) - assert_spinoff (loc_disjoint_addrs (loc_mreference p) l); + assert (loc_disjoint_addrs (loc_mreference p) l); assert ((loc_disjoint (loc_mreference p) l)); mrefs t pre p in @@ -1313,7 +1303,6 @@ let modifies_loc_addresses_intro_weak modifies_preserves_alocs_intro (loc_union (loc_addresses true r s) l) h1 h2 () (fun r' a b -> if r = r' then f a b else () ) -#push-options "--z3rlimit_factor 4" let modifies_loc_addresses_intro #al #c r s l h1 h2 = loc_includes_loc_regions_restrict_to_regions l (Set.singleton r); loc_includes_loc_union_restrict_to_regions l (Set.singleton r); @@ -1471,8 +1460,6 @@ let disjoint_addrs_of_loc_loc_disjoint )) (ensures (loc_disjoint l1 l2)) = // FIXME: WHY WHY WHY do I need this assert? - let Loc _ _ _ _ _ = l1 in - let Loc _ _ _ _ _ = l2 in let l1' = Ghost.reveal (Loc?.aux l1) in let l2' = Ghost.reveal (Loc?.aux l2) in assert (forall (b1 b2: aloc c) . (GSet.mem b1 l1' /\ GSet.mem b2 l2') ==> aloc_disjoint b1 b2) @@ -1770,7 +1757,7 @@ let mem_union_aux_of_aux_left_intro : Lemma (GSet.mem x aux <==> GSet.mem (ALoc x.region x.addr (if None? x.loc then None else Some (make_cls_union_aloc b (Some?.v x.loc)))) (union_aux_of_aux_left c b aux)) [SMTPat (GSet.mem x aux)] -= let ALoc _ _ _ = x in () += () let mem_union_aux_of_aux_left_elim (#al: (bool -> HS.rid -> nat -> Tot Type)) @@ -2131,12 +2118,12 @@ let upgrade_aloc (#al: aloc_t u#a) (#c: cls al) (a: aloc c) : Tot (aloc (raise_c let downgrade_aloc_upgrade_aloc (#al: aloc_t u#a) (#c: cls al) (a: aloc c) : Lemma (downgrade_aloc (upgrade_aloc u#a u#b a) == a) [SMTPat (downgrade_aloc (upgrade_aloc u#a u#b a))] -= let ALoc _ _ _ = a in () += () let upgrade_aloc_downgrade_aloc (#al: aloc_t u#a) (#c: cls al) (a: aloc (raise_cls u#a u#b c)) : Lemma (upgrade_aloc (downgrade_aloc a) == a) [SMTPat (upgrade_aloc u#a u#b (downgrade_aloc a))] -= let ALoc _ _ _ = a in () += () let raise_loc_aux_pred (#al: aloc_t u#a) @@ -2179,7 +2166,6 @@ let raise_loc_includes #al #c l1 l2 = #pop-options let raise_loc_disjoint #al #c l1 l2 = - // let ALoc _ _ _ = al in let l1' = raise_loc l1 in let l2' = raise_loc l2 in assert (forall (x: aloc (raise_cls c)) . GSet.mem x (Ghost.reveal (Loc?.aux l1')) <==> GSet.mem (downgrade_aloc x) (Ghost.reveal (Loc?.aux l1))); diff --git a/ulib/FStar.WellFounded.Util.fst b/ulib/FStar.WellFounded.Util.fst index a4fc7cdf1e2..a738123731b 100644 --- a/ulib/FStar.WellFounded.Util.fst +++ b/ulib/FStar.WellFounded.Util.fst @@ -52,7 +52,7 @@ let lift_binrel_well_founded (#a:Type u#a) : Tot (acc (lift_binrel r) y) (decreases pf) = AccIntro (fun (z:top) (p:lift_binrel r z y) -> - aux z (match pf with | AccIntro access_smaller -> access_smaller (dsnd z) (lower_binrel z y p))) + aux z (pf.access_smaller (dsnd z) (lower_binrel z y p))) in let aux' (y:top{dfst y =!= a}) : acc (lift_binrel r) y @@ -83,7 +83,7 @@ let lift_binrel_squashed_well_founded (#a:Type u#a) (decreases pf) = AccIntro (fun (z:top) (p:lift_binrel_squashed r z y) -> let p = lower_binrel_squashed z y p in - aux z (match pf with AccIntro access_smaller -> access_smaller (dsnd z) (FStar.Squash.join_squash p))) + aux z (pf.access_smaller (dsnd z) (FStar.Squash.join_squash p))) in let aux' (y:top{dfst y =!= a}) : acc (lift_binrel_squashed r) y diff --git a/ulib/FStar.WellFounded.fst b/ulib/FStar.WellFounded.fst index 639ea3324dd..97ee6223a4b 100644 --- a/ulib/FStar.WellFounded.fst +++ b/ulib/FStar.WellFounded.fst @@ -50,13 +50,7 @@ let rec fix_F (#aa:Type) (#r:binrel aa) (#p:(aa -> Type)) (f: (x:aa -> (y:aa -> r y x -> p y) -> p x)) (x:aa) (a:acc r x) : Tot (p x) (decreases a) - = f x (fun y h -> - let v : acc r y = - match a with - | AccIntro access_smaller -> - access_smaller y h - in - fix_F f y v) + = f x (fun y h -> fix_F f y (a.access_smaller y h)) let fix (#aa:Type) (#r:binrel aa) (rwf:well_founded r) (p:aa -> Type) (f:(x:aa -> (y:aa -> r y x -> p y) -> p x)) @@ -107,12 +101,9 @@ let subrelation_squash_wf (#a:Type u#a) let rec acc_y (x:a) (acc_r:acc r x) (y:a) (p:sub_r y x) : Tot (acc sub_r y) (decreases acc_r) - = let v : acc _ y = - match acc_r with - | AccIntro access_smaller -> - access_smaller y (elim_squash (sub_w y x p)) - in - AccIntro (acc_y y v) + = AccIntro (acc_y y (acc_r.access_smaller + y + (elim_squash (sub_w y x p)))) in FStar.Squash.return_squash (FStar.Squash.return_squash (AccIntro (acc_y x (r_wf x)))) ) @@ -135,12 +126,6 @@ let inverse_image_wf (#a:Type u#a) (#b:Type u#b) (#r_b:binrel u#b u#r b) = let rec aux (x:a) (acc_r_b:acc r_b (f x)) : Tot (acc (inverse_image r_b f) x) (decreases acc_r_b) = - AccIntro (fun y p -> - let v = - match acc_r_b with - | AccIntro access_smaller -> - access_smaller (f y) p - in - aux y v) + AccIntro (fun y p -> aux y (acc_r_b.access_smaller (f y) p)) in fun x -> aux x (r_b_wf (f x)) diff --git a/ulib/FStar.WellFoundedRelation.fst b/ulib/FStar.WellFoundedRelation.fst index ea8f6217d86..3460dfb52f3 100644 --- a/ulib/FStar.WellFoundedRelation.fst +++ b/ulib/FStar.WellFoundedRelation.fst @@ -62,14 +62,7 @@ let rec acc_decreaser let smaller (y: a{(acc_relation r) y x}) : (acc_classical (acc_relation r) y) = ( eliminate exists (p: r y x). True returns f y << f x - with _. assert ( - let v = - match f x with - | WF.AccIntro access_smaller -> - access_smaller y p - in - v == f y - ); + with _. assert ((f x).access_smaller y p == f y); acc_decreaser r f y ) in AccClassicalIntro smaller diff --git a/ulib/legacy/FStar.Constructive.fst b/ulib/legacy/FStar.Constructive.fst index 55dc7bbd980..249b52e6ca8 100644 --- a/ulib/legacy/FStar.Constructive.fst +++ b/ulib/legacy/FStar.Constructive.fst @@ -14,7 +14,6 @@ limitations under the License. *) module FStar.Constructive - type cand p1 p2 = | Conj : h1:p1 -> h2:p2 -> cand p1 p2 @@ -40,22 +39,20 @@ type ceq_type (a:Type) : Type -> Type = | ReflType : ceq_type a a val eq_ind : #a:Type -> x:a -> p:(a -> Type) -> f:p x -> y:a -> e:ceq x y -> Tot (p y) -let eq_ind #a x p f y e = let Refl = e in f +let eq_ind #a x p f y _ = f val ceq_eq : #a:Type{hasEq a} -> #x:a -> #y:a -> h:(ceq x y) -> Lemma (x = y) -let ceq_eq #a #x #y h = let Refl = h in () +let ceq_eq #a #x #y h = () val ceq_congruence : #a:Type -> #b:Type -> #x:a -> #y:a -> ceq x y -> f:(a -> GTot b) -> GTot (ceq (f x) (f y)) -let ceq_congruence #a #b #x #y h f = - let Refl = h in - Refl #_ #(f x) //refuse to infer terms with non-Tot effect +let ceq_congruence #a #b #x #y h f = Refl #_ #(f x) //refuse to infer terms with non-Tot effect val ceq_symm : #a:Type -> #x:a -> #y:a -> ceq x y -> Tot (ceq y x) -let ceq_symm #a #x #y h = let Refl = h in Refl +let ceq_symm #a #x #y h = Refl val ceq_trans : #a:Type -> #x:a -> #y:a -> #z:a -> ceq x y -> ceq y z -> Tot (ceq x z) -let ceq_trans #a #x #y #z hxy hyz = let Refl = hxy in let Refl = hyz in Refl +let ceq_trans #a #x #y #z hxy hyz = Refl type ctrue = | I : ctrue From 2a31bd045e3816f96c83e43b79a7f532e3a457dd Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Mon, 22 Apr 2024 15:10:37 -0700 Subject: [PATCH 25/42] reverting Bug3186; cleaning up BugBoxInjectivity --- tests/bug-reports/Bug3186.fst | 6 +-- tests/bug-reports/BugBoxInjectivity.fst | 54 +++++++++++++++++-------- 2 files changed, 39 insertions(+), 21 deletions(-) diff --git a/tests/bug-reports/Bug3186.fst b/tests/bug-reports/Bug3186.fst index 34b0d9ca191..4ce06ae1a4d 100644 --- a/tests/bug-reports/Bug3186.fst +++ b/tests/bug-reports/Bug3186.fst @@ -3,11 +3,7 @@ module Bug3186 let base (x:int) (_: unit {equals x 0}) = assert (x == 0) -let base2 (x:int) (hyp: equals x 0) = - let Refl = hyp in - assert (x == 0) - -let base2' (x:int) (hyp: equals x 0) = +let base2 (x:int) (_: equals x 0) = assert (x == 0) [@@expect_failure [19]] diff --git a/tests/bug-reports/BugBoxInjectivity.fst b/tests/bug-reports/BugBoxInjectivity.fst index db7f646c1fe..506ab6f0633 100644 --- a/tests/bug-reports/BugBoxInjectivity.fst +++ b/tests/bug-reports/BugBoxInjectivity.fst @@ -1,26 +1,32 @@ module BugBoxInjectivity -noeq -type ceq (#a:Type) x : a -> Type = - | Refl : ceq #a x x +//The original bug; using an indirection to subvert the injectivity check +let mytype1 = Type u#1 -let test a (x y:a) (h:ceq #a x y) : Lemma (x == y) = () - -[@expect_failure] -let bad (h0:ceq true true) (h1:ceq false false) : Lemma (true == false) = - let Refl = h0 in - let Refl = h1 in - () +type my_t (a:mytype1) : Type u#0 = + | My : my_t a -open FStar.Functions -module CC = FStar.Cardinality.Universes +let inj_my_t (#a:Type u#1) (x:my_t a) +: Lemma (x == My #a) += () + +[@@expect_failure] +let my_t_injective : squash (is_inj my_t) = + introduce forall f0 f1. + my_t f0 == my_t f1 ==> f0 == f1 + with introduce _ ==> _ + with _ . ( + inj_my_t #f0 My; + inj_my_t #f1 (coerce_eq () (My #f0)) + ) +//Same thing without the indirection type t (a:Type u#1) : Type u#0 = | Mk : t a let inj_t (#a:Type u#1) (x:t a) : Lemma (x == Mk #a) -= let Mk #_ = x in () += () [@@expect_failure] let t_injective : squash (is_inj t) = @@ -32,7 +38,9 @@ let t_injective : squash (is_inj t) = inj_t #f1 (coerce_eq () (Mk #f0)) ) - +open FStar.Functions +module CC = FStar.Cardinality.Universes +//Disabling the injectivity check on parameters is inconsistent #push-options "--ext 'compat:injectivity'" noeq type test2 (a:Type u#2) : Type u#1 = @@ -46,7 +54,6 @@ let test2_injective (f0 f1:Type u#2) = let x : test2 f0 = test2_inhabited f0 in let Mk2 #_ = x in () -open FStar.Functions let itest2_injective' : squash (is_inj test2) = introduce forall f0 f1. test2 f0 == test2 f1 ==> f0 == f1 @@ -55,4 +62,19 @@ let itest2_injective' : squash (is_inj test2) = test2_injective f0 f1 ) let fals () : squash False = - CC.no_inj_universes_suc test2 \ No newline at end of file + CC.no_inj_universes_suc test2 + + +//Another test case to make sure that indexed types can be inverted properly +noeq +type ceq (#a:Type) x : a -> Type = + | Refl : ceq #a x x + +let test a (x y:a) (h:ceq #a x y) : Lemma (x == y) = () + +//But without collapsing +[@expect_failure] +let bad (h0:ceq true true) (h1:ceq false false) : Lemma (true == false) = + let Refl = h0 in + let Refl = h1 in + () From 07b70f77023f5e92806e25d719215b7ae80d8866 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Mon, 22 Apr 2024 15:17:08 -0700 Subject: [PATCH 26/42] update a comment --- src/smtencoding/FStar.SMTEncoding.Encode.fst | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst index 007a612881f..4a0a9a7d5f4 100644 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ b/src/smtencoding/FStar.SMTEncoding.Encode.fst @@ -1119,12 +1119,6 @@ let encode_sig_inductive (is_injective_on_params:bool) (env:env_t) (se:sigelt) || Options.ext_getv "compat:injectivity" <> "" then List.map2 (fun v a -> mkEq(mkFreeV v, a)) vars indices else [] - // //only injectivity on indices - // let num_params = List.length tps in - // let _var_params, var_indices = List.splitAt num_params vars in - // let _i_params, indices = List.splitAt num_params indices in - // List.map2 (fun v a -> mkEq(mkFreeV v, a)) var_indices indices - // ) in mkOr(out, mkAnd(mk_data_tester env l xx, eqs |> mk_and_l)), decls@decls') (mkFalse, []) @@ -1801,7 +1795,7 @@ and encode_sigelt' (env:env_t) (se:sigelt) : (decls_t * env_t) = g in //2. decls are all the function symbol declarations - // elts: not sure what this represents + // elts: all elements that have a key and which contain function declarations (not sure why this class is important to pull out) // rest: all the non-declarations, excepting the inversion axiom which is already identified above let decls, elts, rest = List.fold_left From 89b83ab63974f7abcf4c9952c125bc0e3889d80c Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Mon, 22 Apr 2024 16:33:15 -0700 Subject: [PATCH 27/42] Don't generate spurious declarations that rely on a projector of a type param when it doesn't exist --- .../generated/FStar_SMTEncoding_Encode.ml | 193 +++++++++--------- .../generated/FStar_SMTEncoding_EncodeTerm.ml | 15 +- src/smtencoding/FStar.SMTEncoding.Encode.fst | 34 +-- tests/bug-reports/BugTypeParamProjector.fst | 10 + tests/bug-reports/Makefile | 2 +- 5 files changed, 140 insertions(+), 114 deletions(-) create mode 100644 tests/bug-reports/BugTypeParamProjector.fst diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index 2c874ea70ca..055e9d7c871 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -4043,104 +4043,107 @@ let (encode_sig_inductive : fun l -> match uu___7 with | (out, decls) -> + let is_l = + FStar_SMTEncoding_Env.mk_data_tester env1 + l xx in let uu___8 = - FStar_TypeChecker_Env.lookup_datacon - env1.FStar_SMTEncoding_Env.tcenv l in - (match uu___8 with - | (uu___9, data_t) -> - let uu___10 = - FStar_Syntax_Util.arrow_formals - data_t in - (match uu___10 with - | (args, res) -> - let indices = - let uu___11 = - FStar_Syntax_Util.head_and_args_full - res in - FStar_Pervasives_Native.snd - uu___11 in - let env2 = - FStar_Compiler_List.fold_left - (fun env3 -> - fun uu___11 -> - match uu___11 with - | { - FStar_Syntax_Syntax.binder_bv - = x; - FStar_Syntax_Syntax.binder_qual - = uu___12; - FStar_Syntax_Syntax.binder_positivity - = uu___13; - FStar_Syntax_Syntax.binder_attrs - = uu___14;_} - -> - let uu___15 = - let uu___16 = - let uu___17 = - FStar_SMTEncoding_Env.mk_term_projector_name - l x in - (uu___17, [xx]) in - FStar_SMTEncoding_Util.mkApp - uu___16 in - FStar_SMTEncoding_Env.push_term_var - env3 x uu___15) - env1 args in - let uu___11 = - FStar_SMTEncoding_EncodeTerm.encode_args - indices env2 in - (match uu___11 with - | (indices1, decls') -> - (if - (FStar_Compiler_List.length - indices1) - <> - (FStar_Compiler_List.length - vars) - then - FStar_Compiler_Effect.failwith - "Impossible" - else (); - (let eqs = - let uu___13 = - is_injective_on_params - || - (let uu___14 = - FStar_Options.ext_getv - "compat:injectivity" in - uu___14 <> "") in - if uu___13 + let uu___9 = + is_injective_on_params || + (let uu___10 = + FStar_Options.ext_getv + "compat:injectivity" in + uu___10 <> "") in + if uu___9 + then + let uu___10 = + FStar_TypeChecker_Env.lookup_datacon + env1.FStar_SMTEncoding_Env.tcenv l in + match uu___10 with + | (uu___11, data_t) -> + let uu___12 = + FStar_Syntax_Util.arrow_formals + data_t in + (match uu___12 with + | (args, res) -> + let indices = + let uu___13 = + FStar_Syntax_Util.head_and_args_full + res in + FStar_Pervasives_Native.snd + uu___13 in + let env2 = + FStar_Compiler_List.fold_left + (fun env3 -> + fun uu___13 -> + match uu___13 with + | { + FStar_Syntax_Syntax.binder_bv + = x; + FStar_Syntax_Syntax.binder_qual + = uu___14; + FStar_Syntax_Syntax.binder_positivity + = uu___15; + FStar_Syntax_Syntax.binder_attrs + = uu___16;_} + -> + let uu___17 = + let uu___18 = + let uu___19 = + FStar_SMTEncoding_Env.mk_term_projector_name + l x in + (uu___19, + [xx]) in + FStar_SMTEncoding_Util.mkApp + uu___18 in + FStar_SMTEncoding_Env.push_term_var + env3 x uu___17) + env1 args in + let uu___13 = + FStar_SMTEncoding_EncodeTerm.encode_args + indices env2 in + (match uu___13 with + | (indices1, decls') -> + (if + (FStar_Compiler_List.length + indices1) + <> + (FStar_Compiler_List.length + vars) then - FStar_Compiler_List.map2 - (fun v -> - fun a -> - let uu___14 = - let uu___15 = - FStar_SMTEncoding_Util.mkFreeV + FStar_Compiler_Effect.failwith + "Impossible" + else (); + (let eqs = + FStar_Compiler_List.map2 + (fun v -> + fun a -> + let uu___15 = + let uu___16 + = + FStar_SMTEncoding_Util.mkFreeV v in - (uu___15, a) in - FStar_SMTEncoding_Util.mkEq - uu___14) vars - indices1 - else [] in - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - FStar_SMTEncoding_Env.mk_data_tester - env2 l xx in - let uu___18 = - FStar_SMTEncoding_Util.mk_and_l - eqs in - (uu___17, uu___18) in - FStar_SMTEncoding_Util.mkAnd - uu___16 in - (out, uu___15) in - FStar_SMTEncoding_Util.mkOr - uu___14 in - (uu___13, - (FStar_Compiler_List.op_At - decls decls')))))))) + (uu___16, a) in + FStar_SMTEncoding_Util.mkEq + uu___15) + vars indices1 in + let uu___15 = + let uu___16 = + let uu___17 = + FStar_SMTEncoding_Util.mk_and_l + eqs in + (is_l, uu___17) in + FStar_SMTEncoding_Util.mkAnd + uu___16 in + (uu___15, decls'))))) + else (is_l, []) in + (match uu___8 with + | (inversion_case, decls') -> + let uu___9 = + FStar_SMTEncoding_Util.mkOr + (out, inversion_case) in + (uu___9, + (FStar_Compiler_List.op_At decls + decls')))) (FStar_SMTEncoding_Util.mkFalse, []) datas in (match uu___6 with | (data_ax, decls) -> diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_EncodeTerm.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_EncodeTerm.ml index ec50ccf9f2f..850fdc2eb53 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_EncodeTerm.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_EncodeTerm.ml @@ -2939,9 +2939,18 @@ and (encode_term : FStar_SMTEncoding_Term.mkForall t0.FStar_Syntax_Syntax.pos uu___13 in - (uu___12, - (FStar_Pervasives_Native.Some - a_name), a_name) in + let uu___13 = + let uu___14 = + let uu___15 = + FStar_Class_Show.show + FStar_Syntax_Print.showable_term + t0 in + FStar_Compiler_Util.format2 + "%s\n;; %s\n" a_name + uu___15 in + FStar_Pervasives_Native.Some + uu___14 in + (uu___12, uu___13, a_name) in FStar_SMTEncoding_Util.mkAssume uu___11 in let f_decls = diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst index 4a0a9a7d5f4..b3ae7d55d87 100644 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ b/src/smtencoding/FStar.SMTEncoding.Encode.fst @@ -1105,22 +1105,26 @@ let encode_sig_inductive (is_injective_on_params:bool) (env:env_t) (se:sigelt) datas |> List.fold_left (fun (out, decls) l -> - let _, data_t = Env.lookup_datacon env.tcenv l in - let args, res = U.arrow_formals data_t in - let indices = res |> U.head_and_args_full |> snd in - let env = args |> List.fold_left - (fun env ({binder_bv=x}) -> push_term_var env x (mkApp(mk_term_projector_name l x, [xx]))) - env in - let indices, decls' = encode_args indices env in - if List.length indices <> List.length vars - then failwith "Impossible"; - let eqs = - if is_injective_on_params - || Options.ext_getv "compat:injectivity" <> "" - then List.map2 (fun v a -> mkEq(mkFreeV v, a)) vars indices - else [] + let is_l = mk_data_tester env l xx in + let inversion_case, decls' = + if is_injective_on_params + || Options.ext_getv "compat:injectivity" <> "" + then ( + let _, data_t = Env.lookup_datacon env.tcenv l in + let args, res = U.arrow_formals data_t in + let indices = res |> U.head_and_args_full |> snd in + let env = args |> List.fold_left + (fun env ({binder_bv=x}) -> push_term_var env x (mkApp(mk_term_projector_name l x, [xx]))) + env in + let indices, decls' = encode_args indices env in + if List.length indices <> List.length vars + then failwith "Impossible"; + let eqs = List.map2 (fun v a -> mkEq(mkFreeV v, a)) vars indices in + mkAnd(is_l, mk_and_l eqs), decls' + ) + else is_l, [] in - mkOr(out, mkAnd(mk_data_tester env l xx, eqs |> mk_and_l)), decls@decls') + mkOr(out, inversion_case), decls@decls') (mkFalse, []) in let ffsym, ff = fresh_fvar env.current_module_name "f" Fuel_sort in diff --git a/tests/bug-reports/BugTypeParamProjector.fst b/tests/bug-reports/BugTypeParamProjector.fst new file mode 100644 index 00000000000..67671dc1b55 --- /dev/null +++ b/tests/bug-reports/BugTypeParamProjector.fst @@ -0,0 +1,10 @@ +module BugTypeParamProjector + +type st : Type u#1 = + | MkST: f:int -> st + +noeq +type f (s:st) : (unit -> int) -> Type u#0 = + | MkF : f s (fun _ -> MkST?.f s) + +let test #s #g (x:f s g) = assert (MkF? x) diff --git a/tests/bug-reports/Makefile b/tests/bug-reports/Makefile index 4a9d5850c39..ce2246e09d5 100644 --- a/tests/bug-reports/Makefile +++ b/tests/bug-reports/Makefile @@ -78,7 +78,7 @@ SHOULD_VERIFY_CLOSED=\ Bug3120a.fst Bug3120b.fst Bug3186.fst Bug3185.fst Bug3210.fst \ Bug3213.fst Bug3213b.fst Bug3207.fst Bug3207b.fst Bug3207c.fst \ Bug2155.fst Bug3224a.fst Bug3224b.fst Bug3236.fst Bug3252.fst \ - BugBoxInjectivity.fst + BugBoxInjectivity.fst BugTypeParamProjector.fst SHOULD_VERIFY_INTERFACE_CLOSED=Bug771.fsti Bug771b.fsti SHOULD_VERIFY_AND_WARN_CLOSED=Bug016.fst From 34089dd1d9ad2d6e6d9e9ff87248a2e234a8f295 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Mon, 22 Apr 2024 17:22:57 -0700 Subject: [PATCH 28/42] snap --- .../generated/FStar_SMTEncoding_EncodeTerm.ml | 15 +++------------ 1 file changed, 3 insertions(+), 12 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_EncodeTerm.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_EncodeTerm.ml index 850fdc2eb53..ec50ccf9f2f 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_EncodeTerm.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_EncodeTerm.ml @@ -2939,18 +2939,9 @@ and (encode_term : FStar_SMTEncoding_Term.mkForall t0.FStar_Syntax_Syntax.pos uu___13 in - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t0 in - FStar_Compiler_Util.format2 - "%s\n;; %s\n" a_name - uu___15 in - FStar_Pervasives_Native.Some - uu___14 in - (uu___12, uu___13, a_name) in + (uu___12, + (FStar_Pervasives_Native.Some + a_name), a_name) in FStar_SMTEncoding_Util.mkAssume uu___11 in let f_decls = From 630aadda643b2145146d9ce66a338b4352241b84 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Wed, 24 Apr 2024 12:57:08 -0700 Subject: [PATCH 29/42] try revise pretyping axiom --- .../generated/FStar_SMTEncoding_Encode.ml | 13 +++++++++++-- .../generated/FStar_SMTEncoding_Term.ml | 17 +++++++++++------ src/smtencoding/FStar.SMTEncoding.Encode.fst | 3 ++- 3 files changed, 24 insertions(+), 9 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index 055e9d7c871..85b8263ece0 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -746,8 +746,17 @@ let (pretype_axiom : let uu___9 = let uu___10 = FStar_SMTEncoding_Util.mkApp - ("PreType", [xx]) in - (tapp, uu___10) in + ("Term_constr_id", [tapp]) in + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStar_SMTEncoding_Util.mkApp + ("PreType", [xx]) in + [uu___14] in + ("Term_constr_id", uu___13) in + FStar_SMTEncoding_Util.mkApp uu___12 in + (uu___10, uu___11) in FStar_SMTEncoding_Util.mkEq uu___9 in (xx_has_type, uu___8) in FStar_SMTEncoding_Util.mkImp uu___7 in diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Term.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Term.ml index 7066a54054f..c19788222e9 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Term.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Term.ml @@ -542,12 +542,17 @@ let (fv_eq : fv -> fv -> Prims.bool) = let (fvs_subset_of : fvs -> fvs -> Prims.bool) = fun x -> fun y -> - let cmp_fv x1 y1 = - let uu___ = fv_name x1 in - let uu___1 = fv_name y1 in FStar_Compiler_Util.compare uu___ uu___1 in - let uu___ = FStar_Compiler_Set.from_list ord_fv x in - let uu___1 = FStar_Compiler_Set.from_list ord_fv y in - FStar_Compiler_Set.subset ord_fv uu___ uu___1 + let uu___ = + Obj.magic + (FStar_Class_Setlike.from_list () + (Obj.magic (FStar_Compiler_RBSet.setlike_rbset ord_fv)) x) in + let uu___1 = + Obj.magic + (FStar_Class_Setlike.from_list () + (Obj.magic (FStar_Compiler_RBSet.setlike_rbset ord_fv)) y) in + FStar_Class_Setlike.subset () + (Obj.magic (FStar_Compiler_RBSet.setlike_rbset ord_fv)) + (Obj.magic uu___) (Obj.magic uu___1) let (freevar_eq : term -> term -> Prims.bool) = fun x -> fun y -> diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst index b3ae7d55d87..7ce6a13c8b2 100644 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ b/src/smtencoding/FStar.SMTEncoding.Encode.fst @@ -175,7 +175,8 @@ let pretype_axiom rng env tapp vars = let tapp_hash = Term.hash_of_term tapp in let module_name = env.current_module_name in Util.mkAssume(mkForall rng ([[xx_has_type]], mk_fv (xxsym, Term_sort)::mk_fv (ffsym, Fuel_sort)::vars, - mkImp(xx_has_type, mkEq(tapp, mkApp("PreType", [xx])))), + mkImp(xx_has_type, mkEq(mkApp ("Term_constr_id", [tapp]), + mkApp ("Term_constr_id", [mkApp("PreType", [xx])])))), Some "pretyping", (varops.mk_unique (module_name ^ "_pretyping_" ^ (BU.digest_of_string tapp_hash)))) From 600963d0d191cbfcab87a62d36dd24e2a0770a49 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Wed, 24 Apr 2024 15:37:08 -0700 Subject: [PATCH 30/42] temporary admits --- ulib/LowStar.Monotonic.Buffer.fst | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/ulib/LowStar.Monotonic.Buffer.fst b/ulib/LowStar.Monotonic.Buffer.fst index 9e270442c43..97d428f670f 100644 --- a/ulib/LowStar.Monotonic.Buffer.fst +++ b/ulib/LowStar.Monotonic.Buffer.fst @@ -233,7 +233,7 @@ let live_same_addresses_equal_types_and_preorders' = Heap.lemma_distinct_addrs_distinct_preorders (); Heap.lemma_distinct_addrs_distinct_mm (); let s1 : Seq.seq a1 = as_seq h b1 in - assert (Seq.seq a1 == Seq.seq a2); + assume (Seq.seq a1 == Seq.seq a2); let s1' : Seq.seq a2 = coerce_eq _ s1 in assert (s1 === s1'); lemma_equal_instances_implies_equal_types a1 a2 s1 s1' @@ -1141,7 +1141,7 @@ let modifies_loc_buffer_from_to_intro' #a #rrel #rel b from to l h h' = // prove that the types, rrels, rels are equal Heap.lemma_distinct_addrs_distinct_preorders (); Heap.lemma_distinct_addrs_distinct_mm (); - assert (Seq.seq t' == Seq.seq a); + assume (Seq.seq t' == Seq.seq a); let _s0 : Seq.seq a = as_seq h b in let _s1 : Seq.seq t' = coerce_eq _ _s0 in lemma_equal_instances_implies_equal_types a t' _s0 _s1; @@ -1332,6 +1332,7 @@ let g_upd_seq_as_seq #a #_ #_ b s h = // prove modifies_1_preserves_ubuffers Heap.lemma_distinct_addrs_distinct_preorders (); Heap.lemma_distinct_addrs_distinct_mm (); + admit(); s_lemma_equal_instances_implies_equal_types (); modifies_1_modifies b h h' end @@ -1342,6 +1343,7 @@ let g_upd_modifies_strong #_ #_ #_ b i v h = Heap.lemma_distinct_addrs_distinct_preorders (); Heap.lemma_distinct_addrs_distinct_mm (); s_lemma_equal_instances_implies_equal_types (); + admit(); modifies_1_from_to_modifies b (U32.uint_to_t i) (U32.uint_to_t (i + 1)) h h' #pop-options From 68ad9ab535866747df8f311bd229749a9bd278bb Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Wed, 24 Apr 2024 21:33:18 -0700 Subject: [PATCH 31/42] weaken pretype axiom for non-injective types --- .../generated/FStar_SMTEncoding_Encode.ml | 160 ++++++++++-------- src/smtencoding/FStar.SMTEncoding.Encode.fst | 14 +- 2 files changed, 96 insertions(+), 78 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index 85b8263ece0..d6c777432c3 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -701,79 +701,90 @@ let (prims : prims_t) = | (l', uu___4) -> FStar_Ident.lid_equals l l') prims1 in { mk; is })) let (pretype_axiom : - FStar_Compiler_Range_Type.range -> - FStar_SMTEncoding_Env.env_t -> - FStar_SMTEncoding_Term.term -> - FStar_SMTEncoding_Term.fv Prims.list -> FStar_SMTEncoding_Term.decl) + Prims.bool -> + FStar_Compiler_Range_Type.range -> + FStar_SMTEncoding_Env.env_t -> + FStar_SMTEncoding_Term.term -> + FStar_SMTEncoding_Term.fv Prims.list -> FStar_SMTEncoding_Term.decl) = - fun rng -> - fun env -> - fun tapp -> - fun vars -> - let uu___ = - FStar_SMTEncoding_Env.fresh_fvar - env.FStar_SMTEncoding_Env.current_module_name "x" - FStar_SMTEncoding_Term.Term_sort in - match uu___ with - | (xxsym, xx) -> - let uu___1 = - FStar_SMTEncoding_Env.fresh_fvar - env.FStar_SMTEncoding_Env.current_module_name "f" - FStar_SMTEncoding_Term.Fuel_sort in - (match uu___1 with - | (ffsym, ff) -> - let xx_has_type = - FStar_SMTEncoding_Term.mk_HasTypeFuel ff xx tapp in - let tapp_hash = FStar_SMTEncoding_Term.hash_of_term tapp in - let module_name = - env.FStar_SMTEncoding_Env.current_module_name in - let uu___2 = - let uu___3 = + fun term_constr_eq -> + fun rng -> + fun env -> + fun tapp -> + fun vars -> + let uu___ = + FStar_SMTEncoding_Env.fresh_fvar + env.FStar_SMTEncoding_Env.current_module_name "x" + FStar_SMTEncoding_Term.Term_sort in + match uu___ with + | (xxsym, xx) -> + let uu___1 = + FStar_SMTEncoding_Env.fresh_fvar + env.FStar_SMTEncoding_Env.current_module_name "f" + FStar_SMTEncoding_Term.Fuel_sort in + (match uu___1 with + | (ffsym, ff) -> + let xx_has_type = + FStar_SMTEncoding_Term.mk_HasTypeFuel ff xx tapp in + let tapp_hash = FStar_SMTEncoding_Term.hash_of_term tapp in + let module_name = + env.FStar_SMTEncoding_Env.current_module_name in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStar_SMTEncoding_Term.mk_fv + (xxsym, FStar_SMTEncoding_Term.Term_sort) in + let uu___7 = + let uu___8 = + FStar_SMTEncoding_Term.mk_fv + (ffsym, FStar_SMTEncoding_Term.Fuel_sort) in + uu___8 :: vars in + uu___6 :: uu___7 in + let uu___6 = + let uu___7 = + let uu___8 = + if term_constr_eq + then + let uu___9 = + let uu___10 = + FStar_SMTEncoding_Util.mkApp + ("Term_constr_id", [tapp]) in + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStar_SMTEncoding_Util.mkApp + ("PreType", [xx]) in + [uu___14] in + ("Term_constr_id", uu___13) in + FStar_SMTEncoding_Util.mkApp uu___12 in + (uu___10, uu___11) in + FStar_SMTEncoding_Util.mkEq uu___9 + else + (let uu___10 = + let uu___11 = + FStar_SMTEncoding_Util.mkApp + ("PreType", [xx]) in + (tapp, uu___11) in + FStar_SMTEncoding_Util.mkEq uu___10) in + (xx_has_type, uu___8) in + FStar_SMTEncoding_Util.mkImp uu___7 in + ([[xx_has_type]], uu___5, uu___6) in + FStar_SMTEncoding_Term.mkForall rng uu___4 in let uu___4 = let uu___5 = let uu___6 = - FStar_SMTEncoding_Term.mk_fv - (xxsym, FStar_SMTEncoding_Term.Term_sort) in - let uu___7 = - let uu___8 = - FStar_SMTEncoding_Term.mk_fv - (ffsym, FStar_SMTEncoding_Term.Fuel_sort) in - uu___8 :: vars in - uu___6 :: uu___7 in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_SMTEncoding_Util.mkApp - ("Term_constr_id", [tapp]) in - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_SMTEncoding_Util.mkApp - ("PreType", [xx]) in - [uu___14] in - ("Term_constr_id", uu___13) in - FStar_SMTEncoding_Util.mkApp uu___12 in - (uu___10, uu___11) in - FStar_SMTEncoding_Util.mkEq uu___9 in - (xx_has_type, uu___8) in - FStar_SMTEncoding_Util.mkImp uu___7 in - ([[xx_has_type]], uu___5, uu___6) in - FStar_SMTEncoding_Term.mkForall rng uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Compiler_Util.digest_of_string tapp_hash in - Prims.strcat "_pretyping_" uu___7 in - Prims.strcat module_name uu___6 in - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.mk_unique - uu___5 in - (uu___3, (FStar_Pervasives_Native.Some "pretyping"), - uu___4) in - FStar_SMTEncoding_Util.mkAssume uu___2) + let uu___7 = + FStar_Compiler_Util.digest_of_string tapp_hash in + Prims.strcat "_pretyping_" uu___7 in + Prims.strcat module_name uu___6 in + FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.mk_unique + uu___5 in + (uu___3, (FStar_Pervasives_Native.Some "pretyping"), + uu___4) in + FStar_SMTEncoding_Util.mkAssume uu___2) let (primitive_type_axioms : FStar_TypeChecker_Env.env -> FStar_Ident.lident -> @@ -2109,8 +2120,9 @@ let (encode_free_var : FStar_Syntax_Syntax.range_of_fv fv in pretype_axiom - uu___15 env2 - vapp vars1 in + false uu___15 + env2 vapp + vars1 in [uu___14] in uu___12 :: uu___13 else [] in @@ -4427,8 +4439,10 @@ let (encode_sig_inductive : let uu___12 = let uu___13 = FStar_Ident.range_of_lid t in - pretype_axiom uu___13 env2 tapp - vars in + pretype_axiom + (Prims.op_Negation + is_injective_on_params) + uu___13 env2 tapp vars in [uu___12] in FStar_SMTEncoding_Term.mk_decls_trivial uu___11 in diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst index 7ce6a13c8b2..b2f58d850f7 100644 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ b/src/smtencoding/FStar.SMTEncoding.Encode.fst @@ -168,15 +168,19 @@ let prims = {mk=mk; is=is} -let pretype_axiom rng env tapp vars = +let pretype_axiom term_constr_eq rng env tapp vars = let xxsym, xx = fresh_fvar env.current_module_name "x" Term_sort in let ffsym, ff = fresh_fvar env.current_module_name "f" Fuel_sort in let xx_has_type = mk_HasTypeFuel ff xx tapp in let tapp_hash = Term.hash_of_term tapp in let module_name = env.current_module_name in Util.mkAssume(mkForall rng ([[xx_has_type]], mk_fv (xxsym, Term_sort)::mk_fv (ffsym, Fuel_sort)::vars, - mkImp(xx_has_type, mkEq(mkApp ("Term_constr_id", [tapp]), - mkApp ("Term_constr_id", [mkApp("PreType", [xx])])))), + mkImp(xx_has_type, + (if term_constr_eq + then mkEq(mkApp ("Term_constr_id", [tapp]), + mkApp ("Term_constr_id", [mkApp("PreType", [xx])])) + else mkEq(tapp, + mkApp("PreType", [xx]))))), Some "pretyping", (varops.mk_unique (module_name ^ "_pretyping_" ^ (BU.digest_of_string tapp_hash)))) @@ -534,7 +538,7 @@ let encode_free_var uninterpreted env fv tt t_norm quals :decls_t * env_t = let freshness = if quals |> List.contains New then [Term.fresh_constructor (S.range_of_fv fv) (vname, vars |> List.map fv_sort, Term_sort, varops.next_id()); - pretype_axiom (S.range_of_fv fv) env vapp vars] + pretype_axiom false (S.range_of_fv fv) env vapp vars] else [] in let g = decls1@decls2@decls3@(freshness@typingAx::mk_disc_proj_axioms guard encoded_res_t vapp vars |> mk_decls_trivial) in @@ -1211,7 +1215,7 @@ let encode_sig_inductive (is_injective_on_params:bool) (env:env_t) (se:sigelt) let aux = kindingAx @(inversion_axioms env tapp vars) - @([pretype_axiom (Ident.range_of_lid t) env tapp vars] |> mk_decls_trivial) + @([pretype_axiom (not is_injective_on_params) (Ident.range_of_lid t) env tapp vars] |> mk_decls_trivial) in (decls |> mk_decls_trivial)@binder_decls@aux, env From 9979879cc7a78adfe620ddcf6f075637038b0300 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Wed, 24 Apr 2024 21:33:29 -0700 Subject: [PATCH 32/42] Revert "temporary admits" This reverts commit 600963d0d191cbfcab87a62d36dd24e2a0770a49. --- ulib/LowStar.Monotonic.Buffer.fst | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/ulib/LowStar.Monotonic.Buffer.fst b/ulib/LowStar.Monotonic.Buffer.fst index 97d428f670f..9e270442c43 100644 --- a/ulib/LowStar.Monotonic.Buffer.fst +++ b/ulib/LowStar.Monotonic.Buffer.fst @@ -233,7 +233,7 @@ let live_same_addresses_equal_types_and_preorders' = Heap.lemma_distinct_addrs_distinct_preorders (); Heap.lemma_distinct_addrs_distinct_mm (); let s1 : Seq.seq a1 = as_seq h b1 in - assume (Seq.seq a1 == Seq.seq a2); + assert (Seq.seq a1 == Seq.seq a2); let s1' : Seq.seq a2 = coerce_eq _ s1 in assert (s1 === s1'); lemma_equal_instances_implies_equal_types a1 a2 s1 s1' @@ -1141,7 +1141,7 @@ let modifies_loc_buffer_from_to_intro' #a #rrel #rel b from to l h h' = // prove that the types, rrels, rels are equal Heap.lemma_distinct_addrs_distinct_preorders (); Heap.lemma_distinct_addrs_distinct_mm (); - assume (Seq.seq t' == Seq.seq a); + assert (Seq.seq t' == Seq.seq a); let _s0 : Seq.seq a = as_seq h b in let _s1 : Seq.seq t' = coerce_eq _ _s0 in lemma_equal_instances_implies_equal_types a t' _s0 _s1; @@ -1332,7 +1332,6 @@ let g_upd_seq_as_seq #a #_ #_ b s h = // prove modifies_1_preserves_ubuffers Heap.lemma_distinct_addrs_distinct_preorders (); Heap.lemma_distinct_addrs_distinct_mm (); - admit(); s_lemma_equal_instances_implies_equal_types (); modifies_1_modifies b h h' end @@ -1343,7 +1342,6 @@ let g_upd_modifies_strong #_ #_ #_ b i v h = Heap.lemma_distinct_addrs_distinct_preorders (); Heap.lemma_distinct_addrs_distinct_mm (); s_lemma_equal_instances_implies_equal_types (); - admit(); modifies_1_from_to_modifies b (U32.uint_to_t i) (U32.uint_to_t (i + 1)) h h' #pop-options From 988584448f52ec959cf9f832882a29e23fced6c8 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Fri, 26 Apr 2024 14:58:07 -0700 Subject: [PATCH 33/42] refactor to provide an environment to eq_tm and NBETerm.eq_t --- .../generated/FStar_SMTEncoding_Encode.ml | 14 +- .../fstar-lib/generated/FStar_Syntax_Util.ml | 542 ++----- .../generated/FStar_Tactics_Hooks.ml | 7 +- .../generated/FStar_TypeChecker_Cfg.ml | 18 +- .../generated/FStar_TypeChecker_Common.ml | 887 ----------- .../generated/FStar_TypeChecker_Core.ml | 10 +- .../generated/FStar_TypeChecker_DMFF.ml | 2 +- .../FStar_TypeChecker_DeferredImplicits.ml | 13 +- .../generated/FStar_TypeChecker_NBE.ml | 19 +- .../generated/FStar_TypeChecker_NBETerm.ml | 217 +-- .../generated/FStar_TypeChecker_Normalize.ml | 34 +- .../FStar_TypeChecker_Normalize_Unfolding.ml | 3 +- .../generated/FStar_TypeChecker_Primops.ml | 13 +- .../generated/FStar_TypeChecker_Primops_Eq.ml | 365 ++--- .../generated/FStar_TypeChecker_Rel.ml | 252 ++-- .../generated/FStar_TypeChecker_TcEffect.ml | 49 +- .../generated/FStar_TypeChecker_TcTerm.ml | 21 +- .../FStar_TypeChecker_TermEqAndSimplify.ml | 1303 +++++++++++++++++ .../generated/FStar_TypeChecker_Util.ml | 15 +- .../fstar-tests/generated/FStar_Tests_Util.ml | 5 +- src/smtencoding/FStar.SMTEncoding.Encode.fst | 7 +- src/syntax/FStar.Syntax.Util.fst | 643 ++++---- src/tactics/FStar.Tactics.Hooks.fst | 3 +- src/tests/FStar.Tests.Util.fst | 2 +- src/typechecker/FStar.TypeChecker.Cfg.fst | 5 +- src/typechecker/FStar.TypeChecker.Cfg.fsti | 2 +- src/typechecker/FStar.TypeChecker.Common.fst | 264 ---- src/typechecker/FStar.TypeChecker.Common.fsti | 1 - src/typechecker/FStar.TypeChecker.Core.fst | 4 +- src/typechecker/FStar.TypeChecker.DMFF.fst | 3 +- .../FStar.TypeChecker.DeferredImplicits.fst | 5 +- src/typechecker/FStar.TypeChecker.NBE.fst | 11 +- src/typechecker/FStar.TypeChecker.NBETerm.fst | 68 +- .../FStar.TypeChecker.NBETerm.fsti | 4 +- .../FStar.TypeChecker.Normalize.Unfolding.fst | 4 +- .../FStar.TypeChecker.Normalize.fst | 6 +- .../FStar.TypeChecker.Primops.Base.fsti | 2 +- .../FStar.TypeChecker.Primops.Eq.fst | 68 +- .../FStar.TypeChecker.Primops.Eq.fsti | 6 +- src/typechecker/FStar.TypeChecker.Primops.fst | 7 +- .../FStar.TypeChecker.Primops.fsti | 3 +- src/typechecker/FStar.TypeChecker.Rel.fst | 31 +- .../FStar.TypeChecker.TcEffect.fst | 21 +- src/typechecker/FStar.TypeChecker.TcTerm.fst | 9 +- .../FStar.TypeChecker.TermEqAndSimplify.fst | 531 +++++++ .../FStar.TypeChecker.TermEqAndSimplify.fsti | 16 + src/typechecker/FStar.TypeChecker.Util.fst | 5 +- 47 files changed, 3047 insertions(+), 2473 deletions(-) create mode 100644 ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml create mode 100644 src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst create mode 100644 src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fsti diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index d6c777432c3..bd30c5cf7e8 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -5170,17 +5170,18 @@ let (encode_datacon : -> let uu___37 = - FStar_Syntax_Util.eq_tm + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env1.FStar_SMTEncoding_Env.tcenv head1 head' in (match uu___37 with | - FStar_Syntax_Util.Equal + FStar_TypeChecker_TermEqAndSimplify.Equal -> FStar_Pervasives_Native.None | - FStar_Syntax_Util.NotEqual + FStar_TypeChecker_TermEqAndSimplify.NotEqual -> binder_and_codomain_type t' @@ -5913,17 +5914,18 @@ let (encode_datacon : -> let uu___33 = - FStar_Syntax_Util.eq_tm + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env1.FStar_SMTEncoding_Env.tcenv head1 head' in (match uu___33 with | - FStar_Syntax_Util.Equal + FStar_TypeChecker_TermEqAndSimplify.Equal -> FStar_Pervasives_Native.None | - FStar_Syntax_Util.NotEqual + FStar_TypeChecker_TermEqAndSimplify.NotEqual -> binder_and_codomain_type t' diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Util.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Util.ml index 7ddadaffc7d..20334fc76d1 100644 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Util.ml +++ b/ocaml/fstar-lib/generated/FStar_Syntax_Util.ml @@ -382,6 +382,14 @@ let (eq_univs : = fun u1 -> fun u2 -> let uu___ = compare_univs u1 u2 in uu___ = Prims.int_zero +let (eq_univs_list : + FStar_Syntax_Syntax.universes -> + FStar_Syntax_Syntax.universes -> Prims.bool) + = + fun us -> + fun vs -> + ((FStar_Compiler_List.length us) = (FStar_Compiler_List.length vs)) && + (FStar_Compiler_List.forall2 eq_univs us vs) let (ml_comp : FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.comp) @@ -929,418 +937,6 @@ let (canon_app : match uu___ with | (hd, args) -> FStar_Syntax_Syntax.mk_Tm_app hd args t.FStar_Syntax_Syntax.pos -type eq_result = - | Equal - | NotEqual - | Unknown -let (uu___is_Equal : eq_result -> Prims.bool) = - fun projectee -> match projectee with | Equal -> true | uu___ -> false -let (uu___is_NotEqual : eq_result -> Prims.bool) = - fun projectee -> match projectee with | NotEqual -> true | uu___ -> false -let (uu___is_Unknown : eq_result -> Prims.bool) = - fun projectee -> match projectee with | Unknown -> true | uu___ -> false -let (injectives : Prims.string Prims.list) = - ["FStar.Int8.int_to_t"; - "FStar.Int16.int_to_t"; - "FStar.Int32.int_to_t"; - "FStar.Int64.int_to_t"; - "FStar.Int128.int_to_t"; - "FStar.UInt8.uint_to_t"; - "FStar.UInt16.uint_to_t"; - "FStar.UInt32.uint_to_t"; - "FStar.UInt64.uint_to_t"; - "FStar.UInt128.uint_to_t"; - "FStar.SizeT.uint_to_t"; - "FStar.Int8.__int_to_t"; - "FStar.Int16.__int_to_t"; - "FStar.Int32.__int_to_t"; - "FStar.Int64.__int_to_t"; - "FStar.Int128.__int_to_t"; - "FStar.UInt8.__uint_to_t"; - "FStar.UInt16.__uint_to_t"; - "FStar.UInt32.__uint_to_t"; - "FStar.UInt64.__uint_to_t"; - "FStar.UInt128.__uint_to_t"; - "FStar.SizeT.__uint_to_t"] -let (eq_inj : eq_result -> eq_result -> eq_result) = - fun r -> - fun s -> - match (r, s) with - | (Equal, Equal) -> Equal - | (NotEqual, uu___) -> NotEqual - | (uu___, NotEqual) -> NotEqual - | (uu___, uu___1) -> Unknown -let (equal_if : Prims.bool -> eq_result) = - fun uu___ -> if uu___ then Equal else Unknown -let (equal_iff : Prims.bool -> eq_result) = - fun uu___ -> if uu___ then Equal else NotEqual -let (eq_and : eq_result -> (unit -> eq_result) -> eq_result) = - fun r -> - fun s -> - let uu___ = (r = Equal) && (let uu___1 = s () in uu___1 = Equal) in - if uu___ then Equal else Unknown -let rec (eq_tm : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> eq_result) = - fun t1 -> - fun t2 -> - let t11 = canon_app t1 in - let t21 = canon_app t2 in - let equal_data f1 args1 f2 args2 = - let uu___ = FStar_Syntax_Syntax.fv_eq f1 f2 in - if uu___ - then - let uu___1 = FStar_Compiler_List.zip args1 args2 in - FStar_Compiler_List.fold_left - (fun acc -> - fun uu___2 -> - match uu___2 with - | ((a1, q1), (a2, q2)) -> - let uu___3 = eq_tm a1 a2 in eq_inj acc uu___3) Equal - uu___1 - else NotEqual in - let qual_is_inj uu___ = - match uu___ with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Data_ctor) -> - true - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Record_ctor - uu___1) -> true - | uu___1 -> false in - let heads_and_args_in_case_both_data = - let uu___ = let uu___1 = unmeta t11 in head_and_args uu___1 in - match uu___ with - | (head1, args1) -> - let uu___1 = let uu___2 = unmeta t21 in head_and_args uu___2 in - (match uu___1 with - | (head2, args2) -> - let uu___2 = - let uu___3 = - let uu___4 = un_uinst head1 in - uu___4.FStar_Syntax_Syntax.n in - let uu___4 = - let uu___5 = un_uinst head2 in - uu___5.FStar_Syntax_Syntax.n in - (uu___3, uu___4) in - (match uu___2 with - | (FStar_Syntax_Syntax.Tm_fvar f, - FStar_Syntax_Syntax.Tm_fvar g) when - (qual_is_inj f.FStar_Syntax_Syntax.fv_qual) && - (qual_is_inj g.FStar_Syntax_Syntax.fv_qual) - -> FStar_Pervasives_Native.Some (f, args1, g, args2) - | uu___3 -> FStar_Pervasives_Native.None)) in - let t12 = unmeta t11 in - let t22 = unmeta t21 in - match ((t12.FStar_Syntax_Syntax.n), (t22.FStar_Syntax_Syntax.n)) with - | (FStar_Syntax_Syntax.Tm_bvar bv1, FStar_Syntax_Syntax.Tm_bvar bv2) -> - equal_if - (bv1.FStar_Syntax_Syntax.index = bv2.FStar_Syntax_Syntax.index) - | (FStar_Syntax_Syntax.Tm_lazy uu___, uu___1) -> - let uu___2 = unlazy t12 in eq_tm uu___2 t22 - | (uu___, FStar_Syntax_Syntax.Tm_lazy uu___1) -> - let uu___2 = unlazy t22 in eq_tm t12 uu___2 - | (FStar_Syntax_Syntax.Tm_name a, FStar_Syntax_Syntax.Tm_name b) -> - let uu___ = FStar_Syntax_Syntax.bv_eq a b in equal_if uu___ - | uu___ when - FStar_Compiler_Util.is_some heads_and_args_in_case_both_data -> - let uu___1 = - FStar_Compiler_Util.must heads_and_args_in_case_both_data in - (match uu___1 with - | (f, args1, g, args2) -> equal_data f args1 g args2) - | (FStar_Syntax_Syntax.Tm_fvar f, FStar_Syntax_Syntax.Tm_fvar g) -> - let uu___ = FStar_Syntax_Syntax.fv_eq f g in equal_if uu___ - | (FStar_Syntax_Syntax.Tm_uinst (f, us), FStar_Syntax_Syntax.Tm_uinst - (g, vs)) -> - let uu___ = eq_tm f g in - eq_and uu___ - (fun uu___1 -> - let uu___2 = eq_univs_list us vs in equal_if uu___2) - | (FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_range uu___), - FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_range uu___1)) -> - Unknown - | (FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_real r1), - FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_real r2)) -> - equal_if (r1 = r2) - | (FStar_Syntax_Syntax.Tm_constant c, FStar_Syntax_Syntax.Tm_constant - d) -> let uu___ = FStar_Const.eq_const c d in equal_iff uu___ - | (FStar_Syntax_Syntax.Tm_uvar (u1, ([], uu___)), - FStar_Syntax_Syntax.Tm_uvar (u2, ([], uu___1))) -> - let uu___2 = - FStar_Syntax_Unionfind.equiv u1.FStar_Syntax_Syntax.ctx_uvar_head - u2.FStar_Syntax_Syntax.ctx_uvar_head in - equal_if uu___2 - | (FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = h1; FStar_Syntax_Syntax.args = args1;_}, - FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = h2; FStar_Syntax_Syntax.args = args2;_}) - -> - let uu___ = - let uu___1 = - let uu___2 = un_uinst h1 in uu___2.FStar_Syntax_Syntax.n in - let uu___2 = - let uu___3 = un_uinst h2 in uu___3.FStar_Syntax_Syntax.n in - (uu___1, uu___2) in - (match uu___ with - | (FStar_Syntax_Syntax.Tm_fvar f1, FStar_Syntax_Syntax.Tm_fvar f2) - when - (FStar_Syntax_Syntax.fv_eq f1 f2) && - (let uu___1 = - let uu___2 = FStar_Syntax_Syntax.lid_of_fv f1 in - FStar_Ident.string_of_lid uu___2 in - FStar_Compiler_List.mem uu___1 injectives) - -> equal_data f1 args1 f2 args2 - | uu___1 -> - let uu___2 = eq_tm h1 h2 in - eq_and uu___2 (fun uu___3 -> eq_args args1 args2)) - | (FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t13; - FStar_Syntax_Syntax.ret_opt = uu___; - FStar_Syntax_Syntax.brs = bs1; - FStar_Syntax_Syntax.rc_opt1 = uu___1;_}, - FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t23; - FStar_Syntax_Syntax.ret_opt = uu___2; - FStar_Syntax_Syntax.brs = bs2; - FStar_Syntax_Syntax.rc_opt1 = uu___3;_}) - -> - if - (FStar_Compiler_List.length bs1) = - (FStar_Compiler_List.length bs2) - then - let uu___4 = FStar_Compiler_List.zip bs1 bs2 in - let uu___5 = eq_tm t13 t23 in - FStar_Compiler_List.fold_right - (fun uu___6 -> - fun a -> - match uu___6 with - | (b1, b2) -> - eq_and a (fun uu___7 -> branch_matches b1 b2)) uu___4 - uu___5 - else Unknown - | (FStar_Syntax_Syntax.Tm_type u, FStar_Syntax_Syntax.Tm_type v) -> - let uu___ = eq_univs u v in equal_if uu___ - | (FStar_Syntax_Syntax.Tm_quoted (t13, q1), - FStar_Syntax_Syntax.Tm_quoted (t23, q2)) -> Unknown - | (FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = t13; FStar_Syntax_Syntax.phi = phi1;_}, - FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = t23; FStar_Syntax_Syntax.phi = phi2;_}) -> - let uu___ = - eq_tm t13.FStar_Syntax_Syntax.sort t23.FStar_Syntax_Syntax.sort in - eq_and uu___ (fun uu___1 -> eq_tm phi1 phi2) - | (FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs1; FStar_Syntax_Syntax.body = body1; - FStar_Syntax_Syntax.rc_opt = uu___;_}, - FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs2; FStar_Syntax_Syntax.body = body2; - FStar_Syntax_Syntax.rc_opt = uu___1;_}) - when - (FStar_Compiler_List.length bs1) = (FStar_Compiler_List.length bs2) - -> - let uu___2 = - FStar_Compiler_List.fold_left2 - (fun r -> - fun b1 -> - fun b2 -> - eq_and r - (fun uu___3 -> - eq_tm - (b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - (b2.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort)) - Equal bs1 bs2 in - eq_and uu___2 (fun uu___3 -> eq_tm body1 body2) - | (FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs1; FStar_Syntax_Syntax.comp = c1;_}, - FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs2; FStar_Syntax_Syntax.comp = c2;_}) - when - (FStar_Compiler_List.length bs1) = (FStar_Compiler_List.length bs2) - -> - let uu___ = - FStar_Compiler_List.fold_left2 - (fun r -> - fun b1 -> - fun b2 -> - eq_and r - (fun uu___1 -> - eq_tm - (b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - (b2.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort)) - Equal bs1 bs2 in - eq_and uu___ (fun uu___1 -> eq_comp c1 c2) - | uu___ -> Unknown -and (eq_antiquotations : - FStar_Syntax_Syntax.term Prims.list -> - FStar_Syntax_Syntax.term Prims.list -> eq_result) - = - fun a1 -> - fun a2 -> - match (a1, a2) with - | ([], []) -> Equal - | ([], uu___) -> NotEqual - | (uu___, []) -> NotEqual - | (t1::a11, t2::a21) -> - let uu___ = eq_tm t1 t2 in - (match uu___ with - | NotEqual -> NotEqual - | Unknown -> - let uu___1 = eq_antiquotations a11 a21 in - (match uu___1 with | NotEqual -> NotEqual | uu___2 -> Unknown) - | Equal -> eq_antiquotations a11 a21) -and (branch_matches : - (FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t * - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax) -> - (FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t * - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax) -> eq_result) - = - fun b1 -> - fun b2 -> - let related_by f o1 o2 = - match (o1, o2) with - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> - true - | (FStar_Pervasives_Native.Some x, FStar_Pervasives_Native.Some y) -> - f x y - | (uu___, uu___1) -> false in - let uu___ = b1 in - match uu___ with - | (p1, w1, t1) -> - let uu___1 = b2 in - (match uu___1 with - | (p2, w2, t2) -> - let uu___2 = FStar_Syntax_Syntax.eq_pat p1 p2 in - if uu___2 - then - let uu___3 = - (let uu___4 = eq_tm t1 t2 in uu___4 = Equal) && - (related_by - (fun t11 -> - fun t21 -> - let uu___4 = eq_tm t11 t21 in uu___4 = Equal) w1 - w2) in - (if uu___3 then Equal else Unknown) - else Unknown) -and (eq_args : - FStar_Syntax_Syntax.args -> FStar_Syntax_Syntax.args -> eq_result) = - fun a1 -> - fun a2 -> - match (a1, a2) with - | ([], []) -> Equal - | ((a, uu___)::a11, (b, uu___1)::b1) -> - let uu___2 = eq_tm a b in - (match uu___2 with | Equal -> eq_args a11 b1 | uu___3 -> Unknown) - | uu___ -> Unknown -and (eq_univs_list : - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.universes -> Prims.bool) - = - fun us -> - fun vs -> - ((FStar_Compiler_List.length us) = (FStar_Compiler_List.length vs)) && - (FStar_Compiler_List.forall2 eq_univs us vs) -and (eq_comp : - FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp -> eq_result) = - fun c1 -> - fun c2 -> - match ((c1.FStar_Syntax_Syntax.n), (c2.FStar_Syntax_Syntax.n)) with - | (FStar_Syntax_Syntax.Total t1, FStar_Syntax_Syntax.Total t2) -> - eq_tm t1 t2 - | (FStar_Syntax_Syntax.GTotal t1, FStar_Syntax_Syntax.GTotal t2) -> - eq_tm t1 t2 - | (FStar_Syntax_Syntax.Comp ct1, FStar_Syntax_Syntax.Comp ct2) -> - let uu___ = - let uu___1 = - eq_univs_list ct1.FStar_Syntax_Syntax.comp_univs - ct2.FStar_Syntax_Syntax.comp_univs in - equal_if uu___1 in - eq_and uu___ - (fun uu___1 -> - let uu___2 = - let uu___3 = - FStar_Ident.lid_equals ct1.FStar_Syntax_Syntax.effect_name - ct2.FStar_Syntax_Syntax.effect_name in - equal_if uu___3 in - eq_and uu___2 - (fun uu___3 -> - let uu___4 = - eq_tm ct1.FStar_Syntax_Syntax.result_typ - ct2.FStar_Syntax_Syntax.result_typ in - eq_and uu___4 - (fun uu___5 -> - eq_args ct1.FStar_Syntax_Syntax.effect_args - ct2.FStar_Syntax_Syntax.effect_args))) - | uu___ -> NotEqual -let (eq_quoteinfo : - FStar_Syntax_Syntax.quoteinfo -> FStar_Syntax_Syntax.quoteinfo -> eq_result) - = - fun q1 -> - fun q2 -> - if q1.FStar_Syntax_Syntax.qkind <> q2.FStar_Syntax_Syntax.qkind - then NotEqual - else - eq_antiquotations - (FStar_Pervasives_Native.snd q1.FStar_Syntax_Syntax.antiquotations) - (FStar_Pervasives_Native.snd q2.FStar_Syntax_Syntax.antiquotations) -let (eq_bqual : - FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> - eq_result) - = - fun a1 -> - fun a2 -> - match (a1, a2) with - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> Equal - | (FStar_Pervasives_Native.None, uu___) -> NotEqual - | (uu___, FStar_Pervasives_Native.None) -> NotEqual - | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit b1), - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit b2)) when - b1 = b2 -> Equal - | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t1), - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t2)) -> - eq_tm t1 t2 - | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Equality), - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Equality)) -> - Equal - | uu___ -> NotEqual -let (eq_aqual : - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> - eq_result) - = - fun a1 -> - fun a2 -> - match (a1, a2) with - | (FStar_Pervasives_Native.Some a11, FStar_Pervasives_Native.Some a21) - -> - if - (a11.FStar_Syntax_Syntax.aqual_implicit = - a21.FStar_Syntax_Syntax.aqual_implicit) - && - ((FStar_Compiler_List.length - a11.FStar_Syntax_Syntax.aqual_attributes) - = - (FStar_Compiler_List.length - a21.FStar_Syntax_Syntax.aqual_attributes)) - then - FStar_Compiler_List.fold_left2 - (fun out -> - fun t1 -> - fun t2 -> - match out with - | NotEqual -> out - | Unknown -> - let uu___ = eq_tm t1 t2 in - (match uu___ with - | NotEqual -> NotEqual - | uu___1 -> Unknown) - | Equal -> eq_tm t1 t2) Equal - a11.FStar_Syntax_Syntax.aqual_attributes - a21.FStar_Syntax_Syntax.aqual_attributes - else NotEqual - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> Equal - | uu___ -> NotEqual let rec (unrefine : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = fun t -> let t1 = FStar_Syntax_Subst.compress t in @@ -2339,12 +1935,6 @@ let (type_with_u : FStar_Syntax_Syntax.universe -> FStar_Syntax_Syntax.typ) = fun u -> FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_type u) FStar_Compiler_Range_Type.dummyRange -let (attr_eq : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun a -> - fun a' -> - let uu___ = eq_tm a a' in - match uu___ with | Equal -> true | uu___1 -> false let (attr_substitute : FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) = let uu___ = @@ -3658,7 +3248,7 @@ let rec (term_eq_dbg : u2.FStar_Syntax_Syntax.ctx_uvar_head) | (FStar_Syntax_Syntax.Tm_quoted (qt1, qi1), FStar_Syntax_Syntax.Tm_quoted (qt2, qi2)) -> - (let uu___1 = let uu___2 = eq_quoteinfo qi1 qi2 in uu___2 = Equal in + (let uu___1 = quote_info_eq_dbg dbg qi1 qi2 in check1 "tm_quoted qi" uu___1) && (let uu___1 = term_eq_dbg dbg qt1 qt2 in check1 "tm_quoted payload" uu___1) @@ -3729,7 +3319,7 @@ and (arg_eq_dbg : let uu___ = term_eq_dbg dbg t1 t2 in check dbg "arg tm" uu___) (fun q1 -> fun q2 -> - let uu___ = let uu___1 = eq_aqual q1 q2 in uu___1 = Equal in + let uu___ = aqual_eq_dbg dbg q1 q2 in check dbg "arg qual" uu___) a1 a2 and (binder_eq_dbg : Prims.bool -> @@ -3744,10 +3334,8 @@ and (binder_eq_dbg : (b2.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in check dbg "binder_sort" uu___) && (let uu___ = - let uu___1 = - eq_bqual b1.FStar_Syntax_Syntax.binder_qual - b2.FStar_Syntax_Syntax.binder_qual in - uu___1 = Equal in + bqual_eq_dbg dbg b1.FStar_Syntax_Syntax.binder_qual + b2.FStar_Syntax_Syntax.binder_qual in check dbg "binder qual" uu___)) && (let uu___ = @@ -3823,6 +3411,108 @@ and (letbinding_eq_dbg : term_eq_dbg dbg lb1.FStar_Syntax_Syntax.lbdef lb2.FStar_Syntax_Syntax.lbdef in check dbg "lb def" uu___) +and (quote_info_eq_dbg : + Prims.bool -> + FStar_Syntax_Syntax.quoteinfo -> + FStar_Syntax_Syntax.quoteinfo -> Prims.bool) + = + fun dbg -> + fun q1 -> + fun q2 -> + if q1.FStar_Syntax_Syntax.qkind <> q2.FStar_Syntax_Syntax.qkind + then false + else + antiquotations_eq_dbg dbg + (FStar_Pervasives_Native.snd + q1.FStar_Syntax_Syntax.antiquotations) + (FStar_Pervasives_Native.snd + q2.FStar_Syntax_Syntax.antiquotations) +and (antiquotations_eq_dbg : + Prims.bool -> + FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax Prims.list -> + FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax Prims.list -> + Prims.bool) + = + fun dbg -> + fun a1 -> + fun a2 -> + match (a1, a2) with + | ([], []) -> true + | ([], uu___) -> false + | (uu___, []) -> false + | (t1::a11, t2::a21) -> + let uu___ = + let uu___1 = term_eq_dbg dbg t1 t2 in Prims.op_Negation uu___1 in + if uu___ then false else antiquotations_eq_dbg dbg a11 a21 +and (bqual_eq_dbg : + Prims.bool -> + FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + Prims.bool) + = + fun dbg -> + fun a1 -> + fun a2 -> + match (a1, a2) with + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> + true + | (FStar_Pervasives_Native.None, uu___) -> false + | (uu___, FStar_Pervasives_Native.None) -> false + | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit b1), + FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit b2)) + when b1 = b2 -> true + | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t1), + FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t2)) -> + term_eq_dbg dbg t1 t2 + | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Equality), + FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Equality)) -> + true + | uu___ -> false +and (aqual_eq_dbg : + Prims.bool -> + FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> + FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> + Prims.bool) + = + fun dbg -> + fun a1 -> + fun a2 -> + match (a1, a2) with + | (FStar_Pervasives_Native.Some a11, FStar_Pervasives_Native.Some + a21) -> + if + (a11.FStar_Syntax_Syntax.aqual_implicit = + a21.FStar_Syntax_Syntax.aqual_implicit) + && + ((FStar_Compiler_List.length + a11.FStar_Syntax_Syntax.aqual_attributes) + = + (FStar_Compiler_List.length + a21.FStar_Syntax_Syntax.aqual_attributes)) + then + FStar_Compiler_List.fold_left2 + (fun out -> + fun t1 -> + fun t2 -> + if Prims.op_Negation out + then false + else term_eq_dbg dbg t1 t2) true + a11.FStar_Syntax_Syntax.aqual_attributes + a21.FStar_Syntax_Syntax.aqual_attributes + else false + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> + true + | uu___ -> false +let (eq_aqual : + FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> + FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> + Prims.bool) + = fun a1 -> fun a2 -> aqual_eq_dbg false a1 a2 +let (eq_bqual : + FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + Prims.bool) + = fun b1 -> fun b2 -> bqual_eq_dbg false b1 b2 let (term_eq : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> Prims.bool) = fun t1 -> @@ -4912,9 +4602,7 @@ let (is_binder_unused : FStar_Syntax_Syntax.binder -> Prims.bool) = let (deduplicate_terms : FStar_Syntax_Syntax.term Prims.list -> FStar_Syntax_Syntax.term Prims.list) = - fun l -> - FStar_Compiler_List.deduplicate - (fun x -> fun y -> let uu___ = eq_tm x y in uu___ = Equal) l + fun l -> FStar_Compiler_List.deduplicate (fun x -> fun y -> term_eq x y) l let (eq_binding : FStar_Syntax_Syntax.binding -> FStar_Syntax_Syntax.binding -> Prims.bool) = fun b1 -> diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Hooks.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Hooks.ml index 13327a01148..85ce3f884e7 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Hooks.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_Hooks.ml @@ -1261,9 +1261,10 @@ let rec (traverse_for_spinoff : FStar_Parser_Const.squash_lid)) && (let uu___8 = - FStar_Syntax_Util.eq_tm t2 - FStar_Syntax_Util.t_true in - uu___8 = FStar_Syntax_Util.Equal) + FStar_TypeChecker_TermEqAndSimplify.eq_tm + e t2 FStar_Syntax_Util.t_true in + uu___8 = + FStar_TypeChecker_TermEqAndSimplify.Equal) -> (if debug then diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Cfg.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Cfg.ml index caf64d7bfe2..d7ade7dd769 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Cfg.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Cfg.ml @@ -2190,9 +2190,17 @@ let (prim_from_list : let (built_in_primitive_steps : FStar_TypeChecker_Primops_Base.primitive_step FStar_Compiler_Util.psmap) = prim_from_list FStar_TypeChecker_Primops.built_in_primitive_steps_list +let (env_dependent_ops : FStar_TypeChecker_Env.env_t -> prim_step_set) = + fun env -> + let uu___ = FStar_TypeChecker_Primops.env_dependent_ops env in + prim_from_list uu___ let (equality_ops : - FStar_TypeChecker_Primops_Base.primitive_step FStar_Compiler_Util.psmap) = - prim_from_list FStar_TypeChecker_Primops.equality_ops_list + FStar_TypeChecker_Env.env_t -> + FStar_TypeChecker_Primops_Base.primitive_step FStar_Compiler_Util.psmap) + = + fun env -> + let uu___ = FStar_TypeChecker_Primops.equality_ops_list env in + prim_from_list uu___ let (showable_cfg : cfg FStar_Class_Show.showable) = { FStar_Class_Show.show = @@ -2414,7 +2422,11 @@ let (config' : let d1 = match d with | [] -> [FStar_TypeChecker_Env.NoDelta] | uu___ -> d in let steps = let uu___ = to_fsteps s in add_nbe uu___ in - let psteps1 = let uu___ = cached_steps () in add_steps uu___ psteps in + let psteps1 = + let uu___ = + let uu___1 = cached_steps () in + let uu___2 = env_dependent_ops e in merge_steps uu___1 uu___2 in + add_steps uu___ psteps in let dbg_flag = FStar_Compiler_List.contains FStar_TypeChecker_Env.NormDebug s in let uu___ = diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Common.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Common.ml index 456504c264b..10fe85caf67 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Common.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Common.ml @@ -914,893 +914,6 @@ let (lcomp_of_comp_guard : FStar_Syntax_Syntax.comp -> guard_t -> lcomp) = (fun uu___1 -> (c0, g)) let (lcomp_of_comp : FStar_Syntax_Syntax.comp -> lcomp) = fun c0 -> lcomp_of_comp_guard c0 trivial_guard -let (simplify : - Prims.bool -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun debug -> - fun tm -> - let w t = - { - FStar_Syntax_Syntax.n = (t.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = (tm.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = (t.FStar_Syntax_Syntax.hash_code) - } in - let simp_t t = - let uu___ = - let uu___1 = FStar_Syntax_Util.unmeta t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.true_lid -> - FStar_Pervasives_Native.Some true - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.false_lid -> - FStar_Pervasives_Native.Some false - | uu___1 -> FStar_Pervasives_Native.None in - let rec args_are_binders args bs = - match (args, bs) with - | ((t, uu___)::args1, b::bs1) -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_name bv' -> - (FStar_Syntax_Syntax.bv_eq b.FStar_Syntax_Syntax.binder_bv - bv') - && (args_are_binders args1 bs1) - | uu___2 -> false) - | ([], []) -> true - | (uu___, uu___1) -> false in - let is_applied bs t = - if debug - then - (let uu___1 = FStar_Syntax_Print.term_to_string t in - let uu___2 = FStar_Syntax_Print.tag_of_term t in - FStar_Compiler_Util.print2 "WPE> is_applied %s -- %s\n" uu___1 - uu___2) - else (); - (let uu___1 = FStar_Syntax_Util.head_and_args_full t in - match uu___1 with - | (hd, args) -> - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress hd in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_name bv when args_are_binders args bs - -> - (if debug - then - (let uu___4 = FStar_Syntax_Print.term_to_string t in - let uu___5 = FStar_Syntax_Print.bv_to_string bv in - let uu___6 = FStar_Syntax_Print.term_to_string hd in - FStar_Compiler_Util.print3 - "WPE> got it\n>>>>top = %s\n>>>>b = %s\n>>>>hd = %s\n" - uu___4 uu___5 uu___6) - else (); - FStar_Pervasives_Native.Some bv) - | uu___3 -> FStar_Pervasives_Native.None)) in - let is_applied_maybe_squashed bs t = - if debug - then - (let uu___1 = FStar_Syntax_Print.term_to_string t in - let uu___2 = FStar_Syntax_Print.tag_of_term t in - FStar_Compiler_Util.print2 - "WPE> is_applied_maybe_squashed %s -- %s\n" uu___1 uu___2) - else (); - (let uu___1 = FStar_Syntax_Util.is_squash t in - match uu___1 with - | FStar_Pervasives_Native.Some (uu___2, t') -> is_applied bs t' - | uu___2 -> - let uu___3 = FStar_Syntax_Util.is_auto_squash t in - (match uu___3 with - | FStar_Pervasives_Native.Some (uu___4, t') -> is_applied bs t' - | uu___4 -> is_applied bs t)) in - let is_const_match phi = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress phi in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = uu___1; - FStar_Syntax_Syntax.ret_opt = uu___2; - FStar_Syntax_Syntax.brs = br::brs; - FStar_Syntax_Syntax.rc_opt1 = uu___3;_} - -> - let uu___4 = br in - (match uu___4 with - | (uu___5, uu___6, e) -> - let r = - let uu___7 = simp_t e in - match uu___7 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some b -> - let uu___8 = - FStar_Compiler_List.for_all - (fun uu___9 -> - match uu___9 with - | (uu___10, uu___11, e') -> - let uu___12 = simp_t e' in - uu___12 = (FStar_Pervasives_Native.Some b)) - brs in - if uu___8 - then FStar_Pervasives_Native.Some b - else FStar_Pervasives_Native.None in - r) - | uu___1 -> FStar_Pervasives_Native.None in - let maybe_auto_squash t = - let uu___ = FStar_Syntax_Util.is_sub_singleton t in - if uu___ - then t - else FStar_Syntax_Util.mk_auto_squash FStar_Syntax_Syntax.U_zero t in - let squashed_head_un_auto_squash_args t = - let maybe_un_auto_squash_arg uu___ = - match uu___ with - | (t1, q) -> - let uu___1 = FStar_Syntax_Util.is_auto_squash t1 in - (match uu___1 with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.U_zero, t2) -> (t2, q) - | uu___2 -> (t1, q)) in - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (head, args) -> - let args1 = FStar_Compiler_List.map maybe_un_auto_squash_arg args in - FStar_Syntax_Syntax.mk_Tm_app head args1 - t.FStar_Syntax_Syntax.pos in - let rec clearly_inhabited ty = - let uu___ = - let uu___1 = FStar_Syntax_Util.unmeta ty in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_uinst (t, uu___1) -> clearly_inhabited t - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = uu___1; - FStar_Syntax_Syntax.comp = c;_} - -> clearly_inhabited (FStar_Syntax_Util.comp_result c) - | FStar_Syntax_Syntax.Tm_fvar fv -> - let l = FStar_Syntax_Syntax.lid_of_fv fv in - (((FStar_Ident.lid_equals l FStar_Parser_Const.int_lid) || - (FStar_Ident.lid_equals l FStar_Parser_Const.bool_lid)) - || (FStar_Ident.lid_equals l FStar_Parser_Const.string_lid)) - || (FStar_Ident.lid_equals l FStar_Parser_Const.exn_lid) - | uu___1 -> false in - let simplify1 arg = - let uu___ = simp_t (FStar_Pervasives_Native.fst arg) in (uu___, arg) in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress tm in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_uinst - ({ FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}, - uu___4); - FStar_Syntax_Syntax.pos = uu___5; - FStar_Syntax_Syntax.vars = uu___6; - FStar_Syntax_Syntax.hash_code = uu___7;_}; - FStar_Syntax_Syntax.args = args;_} - -> - let uu___8 = - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.and_lid in - if uu___8 - then - let uu___9 = FStar_Compiler_List.map simplify1 args in - (match uu___9 with - | (FStar_Pervasives_Native.Some (true), uu___10)::(uu___11, - (arg, - uu___12))::[] - -> maybe_auto_squash arg - | (uu___10, (arg, uu___11))::(FStar_Pervasives_Native.Some - (true), uu___12)::[] - -> maybe_auto_squash arg - | (FStar_Pervasives_Native.Some (false), uu___10)::uu___11::[] - -> w FStar_Syntax_Util.t_false - | uu___10::(FStar_Pervasives_Native.Some (false), uu___11)::[] - -> w FStar_Syntax_Util.t_false - | uu___10 -> squashed_head_un_auto_squash_args tm) - else - (let uu___10 = - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.or_lid in - if uu___10 - then - let uu___11 = FStar_Compiler_List.map simplify1 args in - match uu___11 with - | (FStar_Pervasives_Native.Some (true), uu___12)::uu___13::[] - -> w FStar_Syntax_Util.t_true - | uu___12::(FStar_Pervasives_Native.Some (true), uu___13)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (false), uu___12)::(uu___13, - (arg, - uu___14))::[] - -> maybe_auto_squash arg - | (uu___12, (arg, uu___13))::(FStar_Pervasives_Native.Some - (false), uu___14)::[] - -> maybe_auto_squash arg - | uu___12 -> squashed_head_un_auto_squash_args tm - else - (let uu___12 = - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.imp_lid in - if uu___12 - then - let uu___13 = FStar_Compiler_List.map simplify1 args in - match uu___13 with - | uu___14::(FStar_Pervasives_Native.Some (true), uu___15)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (false), uu___14)::uu___15::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (true), uu___14)::(uu___15, - (arg, - uu___16))::[] - -> maybe_auto_squash arg - | (uu___14, (p, uu___15))::(uu___16, (q, uu___17))::[] -> - let uu___18 = FStar_Syntax_Util.term_eq p q in - (if uu___18 - then w FStar_Syntax_Util.t_true - else squashed_head_un_auto_squash_args tm) - | uu___14 -> squashed_head_un_auto_squash_args tm - else - (let uu___14 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.iff_lid in - if uu___14 - then - let uu___15 = FStar_Compiler_List.map simplify1 args in - match uu___15 with - | (FStar_Pervasives_Native.Some (true), uu___16):: - (FStar_Pervasives_Native.Some (true), uu___17)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (false), uu___16):: - (FStar_Pervasives_Native.Some (false), uu___17)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (true), uu___16):: - (FStar_Pervasives_Native.Some (false), uu___17)::[] - -> w FStar_Syntax_Util.t_false - | (FStar_Pervasives_Native.Some (false), uu___16):: - (FStar_Pervasives_Native.Some (true), uu___17)::[] - -> w FStar_Syntax_Util.t_false - | (uu___16, (arg, uu___17))::(FStar_Pervasives_Native.Some - (true), uu___18)::[] - -> maybe_auto_squash arg - | (FStar_Pervasives_Native.Some (true), uu___16):: - (uu___17, (arg, uu___18))::[] -> - maybe_auto_squash arg - | (uu___16, (arg, uu___17))::(FStar_Pervasives_Native.Some - (false), uu___18)::[] - -> - let uu___19 = FStar_Syntax_Util.mk_neg arg in - maybe_auto_squash uu___19 - | (FStar_Pervasives_Native.Some (false), uu___16):: - (uu___17, (arg, uu___18))::[] -> - let uu___19 = FStar_Syntax_Util.mk_neg arg in - maybe_auto_squash uu___19 - | (uu___16, (p, uu___17))::(uu___18, (q, uu___19))::[] - -> - let uu___20 = FStar_Syntax_Util.term_eq p q in - (if uu___20 - then w FStar_Syntax_Util.t_true - else squashed_head_un_auto_squash_args tm) - | uu___16 -> squashed_head_un_auto_squash_args tm - else - (let uu___16 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.not_lid in - if uu___16 - then - let uu___17 = FStar_Compiler_List.map simplify1 args in - match uu___17 with - | (FStar_Pervasives_Native.Some (true), uu___18)::[] - -> w FStar_Syntax_Util.t_false - | (FStar_Pervasives_Native.Some (false), uu___18)::[] - -> w FStar_Syntax_Util.t_true - | uu___18 -> squashed_head_un_auto_squash_args tm - else - (let uu___18 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.forall_lid in - if uu___18 - then - match args with - | (t, uu___19)::[] -> - let uu___20 = - let uu___21 = FStar_Syntax_Subst.compress t in - uu___21.FStar_Syntax_Syntax.n in - (match uu___20 with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = uu___21::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___22;_} - -> - let uu___23 = simp_t body in - (match uu___23 with - | FStar_Pervasives_Native.Some (true) -> - w FStar_Syntax_Util.t_true - | uu___24 -> tm) - | uu___21 -> tm) - | (ty, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = - uu___19;_})::(t, uu___20)::[] - -> - let uu___21 = - let uu___22 = FStar_Syntax_Subst.compress t in - uu___22.FStar_Syntax_Syntax.n in - (match uu___21 with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = uu___22::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___23;_} - -> - let uu___24 = simp_t body in - (match uu___24 with - | FStar_Pervasives_Native.Some (true) -> - w FStar_Syntax_Util.t_true - | FStar_Pervasives_Native.Some (false) - when clearly_inhabited ty -> - w FStar_Syntax_Util.t_false - | uu___25 -> tm) - | uu___22 -> tm) - | uu___19 -> tm - else - (let uu___20 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.exists_lid in - if uu___20 - then - match args with - | (t, uu___21)::[] -> - let uu___22 = - let uu___23 = - FStar_Syntax_Subst.compress t in - uu___23.FStar_Syntax_Syntax.n in - (match uu___22 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = uu___23::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___24;_} - -> - let uu___25 = simp_t body in - (match uu___25 with - | FStar_Pervasives_Native.Some - (false) -> - w FStar_Syntax_Util.t_false - | uu___26 -> tm) - | uu___23 -> tm) - | (ty, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = - uu___21;_})::(t, uu___22)::[] - -> - let uu___23 = - let uu___24 = - FStar_Syntax_Subst.compress t in - uu___24.FStar_Syntax_Syntax.n in - (match uu___23 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = uu___24::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___25;_} - -> - let uu___26 = simp_t body in - (match uu___26 with - | FStar_Pervasives_Native.Some - (false) -> - w FStar_Syntax_Util.t_false - | FStar_Pervasives_Native.Some (true) - when clearly_inhabited ty -> - w FStar_Syntax_Util.t_true - | uu___27 -> tm) - | uu___24 -> tm) - | uu___21 -> tm - else - (let uu___22 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.b2t_lid in - if uu___22 - then - match args with - | ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_bool (true)); - FStar_Syntax_Syntax.pos = uu___23; - FStar_Syntax_Syntax.vars = uu___24; - FStar_Syntax_Syntax.hash_code = uu___25;_}, - uu___26)::[] -> - w FStar_Syntax_Util.t_true - | ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_bool (false)); - FStar_Syntax_Syntax.pos = uu___23; - FStar_Syntax_Syntax.vars = uu___24; - FStar_Syntax_Syntax.hash_code = uu___25;_}, - uu___26)::[] -> - w FStar_Syntax_Util.t_false - | uu___23 -> tm - else - (let uu___24 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.haseq_lid in - if uu___24 - then - let t_has_eq_for_sure t = - let haseq_lids = - [FStar_Parser_Const.int_lid; - FStar_Parser_Const.bool_lid; - FStar_Parser_Const.unit_lid; - FStar_Parser_Const.string_lid] in - let uu___25 = - let uu___26 = - FStar_Syntax_Subst.compress t in - uu___26.FStar_Syntax_Syntax.n in - match uu___25 with - | FStar_Syntax_Syntax.Tm_fvar fv1 when - FStar_Compiler_List.existsb - (fun l -> - FStar_Syntax_Syntax.fv_eq_lid - fv1 l) haseq_lids - -> true - | uu___26 -> false in - (if - (FStar_Compiler_List.length args) = - Prims.int_one - then - let t = - let uu___25 = - FStar_Compiler_List.hd args in - FStar_Pervasives_Native.fst uu___25 in - let uu___25 = t_has_eq_for_sure t in - (if uu___25 - then w FStar_Syntax_Util.t_true - else - (let uu___27 = - let uu___28 = - FStar_Syntax_Subst.compress t in - uu___28.FStar_Syntax_Syntax.n in - match uu___27 with - | FStar_Syntax_Syntax.Tm_refine - uu___28 -> - let t1 = - FStar_Syntax_Util.unrefine t in - let uu___29 = - t_has_eq_for_sure t1 in - if uu___29 - then - w FStar_Syntax_Util.t_true - else - (let haseq_tm = - let uu___31 = - let uu___32 = - FStar_Syntax_Subst.compress - tm in - uu___32.FStar_Syntax_Syntax.n in - match uu___31 with - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd - = hd; - FStar_Syntax_Syntax.args - = uu___32;_} - -> hd - | uu___32 -> - FStar_Compiler_Effect.failwith - "Impossible! We have already checked that this is a Tm_app" in - let uu___31 = - let uu___32 = - FStar_Syntax_Syntax.as_arg - t1 in - [uu___32] in - FStar_Syntax_Util.mk_app - haseq_tm uu___31) - | uu___28 -> tm)) - else tm) - else - (let uu___26 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.eq2_lid in - if uu___26 - then - match args with - | (_typ, uu___27)::(a1, uu___28):: - (a2, uu___29)::[] -> - let uu___30 = - FStar_Syntax_Util.eq_tm a1 a2 in - (match uu___30 with - | FStar_Syntax_Util.Equal -> - w FStar_Syntax_Util.t_true - | FStar_Syntax_Util.NotEqual -> - w FStar_Syntax_Util.t_false - | uu___31 -> tm) - | uu___27 -> tm - else - (let uu___28 = - FStar_Syntax_Util.is_auto_squash tm in - match uu___28 with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.U_zero, t) - when - FStar_Syntax_Util.is_sub_singleton - t - -> t - | uu___29 -> tm)))))))))) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}; - FStar_Syntax_Syntax.args = args;_} - -> - let uu___4 = - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.and_lid in - if uu___4 - then - let uu___5 = FStar_Compiler_List.map simplify1 args in - (match uu___5 with - | (FStar_Pervasives_Native.Some (true), uu___6)::(uu___7, - (arg, uu___8))::[] - -> maybe_auto_squash arg - | (uu___6, (arg, uu___7))::(FStar_Pervasives_Native.Some (true), - uu___8)::[] - -> maybe_auto_squash arg - | (FStar_Pervasives_Native.Some (false), uu___6)::uu___7::[] -> - w FStar_Syntax_Util.t_false - | uu___6::(FStar_Pervasives_Native.Some (false), uu___7)::[] -> - w FStar_Syntax_Util.t_false - | uu___6 -> squashed_head_un_auto_squash_args tm) - else - (let uu___6 = - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.or_lid in - if uu___6 - then - let uu___7 = FStar_Compiler_List.map simplify1 args in - match uu___7 with - | (FStar_Pervasives_Native.Some (true), uu___8)::uu___9::[] -> - w FStar_Syntax_Util.t_true - | uu___8::(FStar_Pervasives_Native.Some (true), uu___9)::[] -> - w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (false), uu___8)::(uu___9, - (arg, - uu___10))::[] - -> maybe_auto_squash arg - | (uu___8, (arg, uu___9))::(FStar_Pervasives_Native.Some - (false), uu___10)::[] - -> maybe_auto_squash arg - | uu___8 -> squashed_head_un_auto_squash_args tm - else - (let uu___8 = - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.imp_lid in - if uu___8 - then - let uu___9 = FStar_Compiler_List.map simplify1 args in - match uu___9 with - | uu___10::(FStar_Pervasives_Native.Some (true), uu___11)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (false), uu___10)::uu___11::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (true), uu___10)::(uu___11, - (arg, - uu___12))::[] - -> maybe_auto_squash arg - | (uu___10, (p, uu___11))::(uu___12, (q, uu___13))::[] -> - let uu___14 = FStar_Syntax_Util.term_eq p q in - (if uu___14 - then w FStar_Syntax_Util.t_true - else squashed_head_un_auto_squash_args tm) - | uu___10 -> squashed_head_un_auto_squash_args tm - else - (let uu___10 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.iff_lid in - if uu___10 - then - let uu___11 = FStar_Compiler_List.map simplify1 args in - match uu___11 with - | (FStar_Pervasives_Native.Some (true), uu___12):: - (FStar_Pervasives_Native.Some (true), uu___13)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (false), uu___12):: - (FStar_Pervasives_Native.Some (false), uu___13)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (true), uu___12):: - (FStar_Pervasives_Native.Some (false), uu___13)::[] - -> w FStar_Syntax_Util.t_false - | (FStar_Pervasives_Native.Some (false), uu___12):: - (FStar_Pervasives_Native.Some (true), uu___13)::[] - -> w FStar_Syntax_Util.t_false - | (uu___12, (arg, uu___13))::(FStar_Pervasives_Native.Some - (true), uu___14)::[] - -> maybe_auto_squash arg - | (FStar_Pervasives_Native.Some (true), uu___12):: - (uu___13, (arg, uu___14))::[] -> - maybe_auto_squash arg - | (uu___12, (arg, uu___13))::(FStar_Pervasives_Native.Some - (false), uu___14)::[] - -> - let uu___15 = FStar_Syntax_Util.mk_neg arg in - maybe_auto_squash uu___15 - | (FStar_Pervasives_Native.Some (false), uu___12):: - (uu___13, (arg, uu___14))::[] -> - let uu___15 = FStar_Syntax_Util.mk_neg arg in - maybe_auto_squash uu___15 - | (uu___12, (p, uu___13))::(uu___14, (q, uu___15))::[] - -> - let uu___16 = FStar_Syntax_Util.term_eq p q in - (if uu___16 - then w FStar_Syntax_Util.t_true - else squashed_head_un_auto_squash_args tm) - | uu___12 -> squashed_head_un_auto_squash_args tm - else - (let uu___12 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.not_lid in - if uu___12 - then - let uu___13 = FStar_Compiler_List.map simplify1 args in - match uu___13 with - | (FStar_Pervasives_Native.Some (true), uu___14)::[] - -> w FStar_Syntax_Util.t_false - | (FStar_Pervasives_Native.Some (false), uu___14)::[] - -> w FStar_Syntax_Util.t_true - | uu___14 -> squashed_head_un_auto_squash_args tm - else - (let uu___14 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.forall_lid in - if uu___14 - then - match args with - | (t, uu___15)::[] -> - let uu___16 = - let uu___17 = FStar_Syntax_Subst.compress t in - uu___17.FStar_Syntax_Syntax.n in - (match uu___16 with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = uu___17::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___18;_} - -> - let uu___19 = simp_t body in - (match uu___19 with - | FStar_Pervasives_Native.Some (true) -> - w FStar_Syntax_Util.t_true - | uu___20 -> tm) - | uu___17 -> tm) - | (ty, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = - uu___15;_})::(t, uu___16)::[] - -> - let uu___17 = - let uu___18 = FStar_Syntax_Subst.compress t in - uu___18.FStar_Syntax_Syntax.n in - (match uu___17 with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = uu___18::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___19;_} - -> - let uu___20 = simp_t body in - (match uu___20 with - | FStar_Pervasives_Native.Some (true) -> - w FStar_Syntax_Util.t_true - | FStar_Pervasives_Native.Some (false) - when clearly_inhabited ty -> - w FStar_Syntax_Util.t_false - | uu___21 -> tm) - | uu___18 -> tm) - | uu___15 -> tm - else - (let uu___16 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.exists_lid in - if uu___16 - then - match args with - | (t, uu___17)::[] -> - let uu___18 = - let uu___19 = - FStar_Syntax_Subst.compress t in - uu___19.FStar_Syntax_Syntax.n in - (match uu___18 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = uu___19::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___20;_} - -> - let uu___21 = simp_t body in - (match uu___21 with - | FStar_Pervasives_Native.Some - (false) -> - w FStar_Syntax_Util.t_false - | uu___22 -> tm) - | uu___19 -> tm) - | (ty, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = - uu___17;_})::(t, uu___18)::[] - -> - let uu___19 = - let uu___20 = - FStar_Syntax_Subst.compress t in - uu___20.FStar_Syntax_Syntax.n in - (match uu___19 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = uu___20::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___21;_} - -> - let uu___22 = simp_t body in - (match uu___22 with - | FStar_Pervasives_Native.Some - (false) -> - w FStar_Syntax_Util.t_false - | FStar_Pervasives_Native.Some (true) - when clearly_inhabited ty -> - w FStar_Syntax_Util.t_true - | uu___23 -> tm) - | uu___20 -> tm) - | uu___17 -> tm - else - (let uu___18 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.b2t_lid in - if uu___18 - then - match args with - | ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_bool (true)); - FStar_Syntax_Syntax.pos = uu___19; - FStar_Syntax_Syntax.vars = uu___20; - FStar_Syntax_Syntax.hash_code = uu___21;_}, - uu___22)::[] -> - w FStar_Syntax_Util.t_true - | ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_bool (false)); - FStar_Syntax_Syntax.pos = uu___19; - FStar_Syntax_Syntax.vars = uu___20; - FStar_Syntax_Syntax.hash_code = uu___21;_}, - uu___22)::[] -> - w FStar_Syntax_Util.t_false - | uu___19 -> tm - else - (let uu___20 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.haseq_lid in - if uu___20 - then - let t_has_eq_for_sure t = - let haseq_lids = - [FStar_Parser_Const.int_lid; - FStar_Parser_Const.bool_lid; - FStar_Parser_Const.unit_lid; - FStar_Parser_Const.string_lid] in - let uu___21 = - let uu___22 = - FStar_Syntax_Subst.compress t in - uu___22.FStar_Syntax_Syntax.n in - match uu___21 with - | FStar_Syntax_Syntax.Tm_fvar fv1 when - FStar_Compiler_List.existsb - (fun l -> - FStar_Syntax_Syntax.fv_eq_lid - fv1 l) haseq_lids - -> true - | uu___22 -> false in - (if - (FStar_Compiler_List.length args) = - Prims.int_one - then - let t = - let uu___21 = - FStar_Compiler_List.hd args in - FStar_Pervasives_Native.fst uu___21 in - let uu___21 = t_has_eq_for_sure t in - (if uu___21 - then w FStar_Syntax_Util.t_true - else - (let uu___23 = - let uu___24 = - FStar_Syntax_Subst.compress t in - uu___24.FStar_Syntax_Syntax.n in - match uu___23 with - | FStar_Syntax_Syntax.Tm_refine - uu___24 -> - let t1 = - FStar_Syntax_Util.unrefine t in - let uu___25 = - t_has_eq_for_sure t1 in - if uu___25 - then - w FStar_Syntax_Util.t_true - else - (let haseq_tm = - let uu___27 = - let uu___28 = - FStar_Syntax_Subst.compress - tm in - uu___28.FStar_Syntax_Syntax.n in - match uu___27 with - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd - = hd; - FStar_Syntax_Syntax.args - = uu___28;_} - -> hd - | uu___28 -> - FStar_Compiler_Effect.failwith - "Impossible! We have already checked that this is a Tm_app" in - let uu___27 = - let uu___28 = - FStar_Syntax_Syntax.as_arg - t1 in - [uu___28] in - FStar_Syntax_Util.mk_app - haseq_tm uu___27) - | uu___24 -> tm)) - else tm) - else - (let uu___22 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.eq2_lid in - if uu___22 - then - match args with - | (_typ, uu___23)::(a1, uu___24):: - (a2, uu___25)::[] -> - let uu___26 = - FStar_Syntax_Util.eq_tm a1 a2 in - (match uu___26 with - | FStar_Syntax_Util.Equal -> - w FStar_Syntax_Util.t_true - | FStar_Syntax_Util.NotEqual -> - w FStar_Syntax_Util.t_false - | uu___27 -> tm) - | uu___23 -> tm - else - (let uu___24 = - FStar_Syntax_Util.is_auto_squash tm in - match uu___24 with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.U_zero, t) - when - FStar_Syntax_Util.is_sub_singleton - t - -> t - | uu___25 -> tm)))))))))) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = bv; FStar_Syntax_Syntax.phi = t;_} -> - let uu___1 = simp_t t in - (match uu___1 with - | FStar_Pervasives_Native.Some (true) -> - bv.FStar_Syntax_Syntax.sort - | FStar_Pervasives_Native.Some (false) -> tm - | FStar_Pervasives_Native.None -> tm) - | FStar_Syntax_Syntax.Tm_match uu___1 -> - let uu___2 = is_const_match tm in - (match uu___2 with - | FStar_Pervasives_Native.Some (true) -> - w FStar_Syntax_Util.t_true - | FStar_Pervasives_Native.Some (false) -> - w FStar_Syntax_Util.t_false - | FStar_Pervasives_Native.None -> tm) - | uu___1 -> tm let (check_positivity_qual : Prims.bool -> FStar_Syntax_Syntax.positivity_qualifier FStar_Pervasives_Native.option diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Core.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Core.ml index a33bc00b5aa..9ef0b8f3ed1 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Core.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Core.ml @@ -3604,8 +3604,9 @@ and (check_relation_comp : match uu___ with | (FStar_Pervasives_Native.None, uu___1) -> let uu___2 = - let uu___3 = FStar_Syntax_Util.eq_comp c0 c1 in - uu___3 = FStar_Syntax_Util.Equal in + let uu___3 = + FStar_TypeChecker_TermEqAndSimplify.eq_comp g.tcenv c0 c1 in + uu___3 = FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___2 then (fun uu___3 -> Success ((), FStar_Pervasives_Native.None)) else @@ -3667,8 +3668,9 @@ and (check_relation_comp : fail uu___10)))) | (uu___1, FStar_Pervasives_Native.None) -> let uu___2 = - let uu___3 = FStar_Syntax_Util.eq_comp c0 c1 in - uu___3 = FStar_Syntax_Util.Equal in + let uu___3 = + FStar_TypeChecker_TermEqAndSimplify.eq_comp g.tcenv c0 c1 in + uu___3 = FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___2 then (fun uu___3 -> Success ((), FStar_Pervasives_Native.None)) else diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_DMFF.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_DMFF.ml index 26392457f1f..b69d166c782 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_DMFF.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_DMFF.ml @@ -3674,7 +3674,7 @@ and (trans_F_ : ((let uu___10 = let uu___11 = FStar_Syntax_Util.eq_aqual q q' in - uu___11 <> FStar_Syntax_Util.Equal in + Prims.op_Negation uu___11 in if uu___10 then let uu___11 = diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_DeferredImplicits.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_DeferredImplicits.ml index 7b0d9d3fa16..e00320e9cef 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_DeferredImplicits.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_DeferredImplicits.ml @@ -54,7 +54,7 @@ let (uu___is_Imp : goal_type -> Prims.bool) = let (__proj__Imp__item___0 : goal_type -> FStar_Syntax_Syntax.ctx_uvar) = fun projectee -> match projectee with | Imp _0 -> _0 let (find_user_tac_for_uvar : - FStar_TypeChecker_Env.env -> + FStar_TypeChecker_Env.env_t -> FStar_Syntax_Syntax.ctx_uvar -> FStar_Syntax_Syntax.sigelt FStar_Pervasives_Native.option) = @@ -120,7 +120,8 @@ let (find_user_tac_for_uvar : let candidates = FStar_Compiler_List.filter (fun hook -> - FStar_Compiler_Util.for_some (FStar_Syntax_Util.attr_eq a) + FStar_Compiler_Util.for_some + (FStar_TypeChecker_TermEqAndSimplify.eq_tm_bool env a) hook.FStar_Syntax_Syntax.sigattrs) hooks in let candidates1 = FStar_Compiler_Util.remove_dups @@ -156,7 +157,9 @@ let (find_user_tac_for_uvar : when (FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.override_resolve_implicits_handler_lid) - && (FStar_Syntax_Util.attr_eq a a') + && + (FStar_TypeChecker_TermEqAndSimplify.eq_tm_bool + env a a') -> let uu___5 = attr_list_elements overrides in (match uu___5 with @@ -174,7 +177,9 @@ let (find_user_tac_for_uvar : (a', uu___2)::(overrides, uu___3)::[]) when (FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.override_resolve_implicits_handler_lid) - && (FStar_Syntax_Util.attr_eq a a') + && + (FStar_TypeChecker_TermEqAndSimplify.eq_tm_bool + env a a') -> let uu___4 = attr_list_elements overrides in (match uu___4 with diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_NBE.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_NBE.ml index 809a89458e4..770d24d7301 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_NBE.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_NBE.ml @@ -2333,7 +2333,8 @@ and (translate_monadic : let maybe_range_arg = let uu___2 = FStar_Compiler_Util.for_some - (FStar_Syntax_Util.attr_eq + (FStar_TypeChecker_TermEqAndSimplify.eq_tm_bool + (cfg.core_cfg).FStar_TypeChecker_Cfg.tcenv FStar_Syntax_Util.dm4f_bind_range_attr) ed.FStar_Syntax_Syntax.eff_attrs in if uu___2 @@ -2889,9 +2890,9 @@ and (readback : if ((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.simplify then - FStar_TypeChecker_Common.simplify + FStar_TypeChecker_TermEqAndSimplify.simplify ((cfg.core_cfg).FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.wpe - refinement + (cfg.core_cfg).FStar_TypeChecker_Cfg.tcenv refinement else refinement in with_range uu___2) | FStar_TypeChecker_NBETerm.Reflect t -> @@ -2958,9 +2959,9 @@ and (readback : if ((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.simplify then - FStar_TypeChecker_Common.simplify + FStar_TypeChecker_TermEqAndSimplify.simplify ((cfg.core_cfg).FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.wpe - app + (cfg.core_cfg).FStar_TypeChecker_Cfg.tcenv app else app in with_range uu___1 | FStar_TypeChecker_NBETerm.Accu @@ -2977,9 +2978,9 @@ and (readback : if ((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.simplify then - FStar_TypeChecker_Common.simplify + FStar_TypeChecker_TermEqAndSimplify.simplify ((cfg.core_cfg).FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.wpe - app + (cfg.core_cfg).FStar_TypeChecker_Cfg.tcenv app else app in with_range uu___1 | FStar_TypeChecker_NBETerm.Accu @@ -3005,9 +3006,9 @@ and (readback : if ((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.simplify then - FStar_TypeChecker_Common.simplify + FStar_TypeChecker_TermEqAndSimplify.simplify ((cfg.core_cfg).FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.wpe - app + (cfg.core_cfg).FStar_TypeChecker_Cfg.tcenv app else app in with_range uu___1 | FStar_TypeChecker_NBETerm.Accu diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml index 1ab8f46c7b0..8ce4cccdcc6 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml @@ -418,124 +418,153 @@ let (mkAccuMatch : = fun s -> fun ret -> fun bs -> fun rc -> mk_t (Accu ((Match (s, ret, bs, rc)), [])) -let (equal_if : Prims.bool -> FStar_Syntax_Util.eq_result) = +let (equal_if : Prims.bool -> FStar_TypeChecker_TermEqAndSimplify.eq_result) + = fun uu___ -> - if uu___ then FStar_Syntax_Util.Equal else FStar_Syntax_Util.Unknown -let (equal_iff : Prims.bool -> FStar_Syntax_Util.eq_result) = + if uu___ + then FStar_TypeChecker_TermEqAndSimplify.Equal + else FStar_TypeChecker_TermEqAndSimplify.Unknown +let (equal_iff : Prims.bool -> FStar_TypeChecker_TermEqAndSimplify.eq_result) + = fun uu___ -> - if uu___ then FStar_Syntax_Util.Equal else FStar_Syntax_Util.NotEqual + if uu___ + then FStar_TypeChecker_TermEqAndSimplify.Equal + else FStar_TypeChecker_TermEqAndSimplify.NotEqual let (eq_inj : - FStar_Syntax_Util.eq_result -> - FStar_Syntax_Util.eq_result -> FStar_Syntax_Util.eq_result) + FStar_TypeChecker_TermEqAndSimplify.eq_result -> + FStar_TypeChecker_TermEqAndSimplify.eq_result -> + FStar_TypeChecker_TermEqAndSimplify.eq_result) = fun r1 -> fun r2 -> match (r1, r2) with - | (FStar_Syntax_Util.Equal, FStar_Syntax_Util.Equal) -> - FStar_Syntax_Util.Equal - | (FStar_Syntax_Util.NotEqual, uu___) -> FStar_Syntax_Util.NotEqual - | (uu___, FStar_Syntax_Util.NotEqual) -> FStar_Syntax_Util.NotEqual - | (FStar_Syntax_Util.Unknown, uu___) -> FStar_Syntax_Util.Unknown - | (uu___, FStar_Syntax_Util.Unknown) -> FStar_Syntax_Util.Unknown + | (FStar_TypeChecker_TermEqAndSimplify.Equal, + FStar_TypeChecker_TermEqAndSimplify.Equal) -> + FStar_TypeChecker_TermEqAndSimplify.Equal + | (FStar_TypeChecker_TermEqAndSimplify.NotEqual, uu___) -> + FStar_TypeChecker_TermEqAndSimplify.NotEqual + | (uu___, FStar_TypeChecker_TermEqAndSimplify.NotEqual) -> + FStar_TypeChecker_TermEqAndSimplify.NotEqual + | (FStar_TypeChecker_TermEqAndSimplify.Unknown, uu___) -> + FStar_TypeChecker_TermEqAndSimplify.Unknown + | (uu___, FStar_TypeChecker_TermEqAndSimplify.Unknown) -> + FStar_TypeChecker_TermEqAndSimplify.Unknown let (eq_and : - FStar_Syntax_Util.eq_result -> - (unit -> FStar_Syntax_Util.eq_result) -> FStar_Syntax_Util.eq_result) + FStar_TypeChecker_TermEqAndSimplify.eq_result -> + (unit -> FStar_TypeChecker_TermEqAndSimplify.eq_result) -> + FStar_TypeChecker_TermEqAndSimplify.eq_result) = fun f -> fun g -> match f with - | FStar_Syntax_Util.Equal -> g () - | uu___ -> FStar_Syntax_Util.Unknown -let (eq_constant : constant -> constant -> FStar_Syntax_Util.eq_result) = + | FStar_TypeChecker_TermEqAndSimplify.Equal -> g () + | uu___ -> FStar_TypeChecker_TermEqAndSimplify.Unknown +let (eq_constant : + constant -> constant -> FStar_TypeChecker_TermEqAndSimplify.eq_result) = fun c1 -> fun c2 -> match (c1, c2) with - | (Unit, Unit) -> FStar_Syntax_Util.Equal + | (Unit, Unit) -> FStar_TypeChecker_TermEqAndSimplify.Equal | (Bool b1, Bool b2) -> equal_iff (b1 = b2) | (Int i1, Int i2) -> equal_iff (i1 = i2) | (String (s1, uu___), String (s2, uu___1)) -> equal_iff (s1 = s2) | (Char c11, Char c21) -> equal_iff (c11 = c21) - | (Range r1, Range r2) -> FStar_Syntax_Util.Unknown - | (uu___, uu___1) -> FStar_Syntax_Util.NotEqual -let rec (eq_t : t -> t -> FStar_Syntax_Util.eq_result) = - fun t1 -> - fun t2 -> - match ((t1.nbe_t), (t2.nbe_t)) with - | (Lam uu___, Lam uu___1) -> FStar_Syntax_Util.Unknown - | (Accu (a1, as1), Accu (a2, as2)) -> - let uu___ = eq_atom a1 a2 in - eq_and uu___ (fun uu___1 -> eq_args as1 as2) - | (Construct (v1, us1, args1), Construct (v2, us2, args2)) -> - let uu___ = FStar_Syntax_Syntax.fv_eq v1 v2 in - if uu___ - then - (if - (FStar_Compiler_List.length args1) <> - (FStar_Compiler_List.length args2) - then - FStar_Compiler_Effect.failwith - "eq_t, different number of args on Construct" - else (); - (let uu___2 = FStar_Compiler_List.zip args1 args2 in - FStar_Compiler_List.fold_left - (fun acc -> - fun uu___3 -> - match uu___3 with - | ((a1, uu___4), (a2, uu___5)) -> - let uu___6 = eq_t a1 a2 in eq_inj acc uu___6) - FStar_Syntax_Util.Equal uu___2)) - else FStar_Syntax_Util.NotEqual - | (FV (v1, us1, args1), FV (v2, us2, args2)) -> - let uu___ = FStar_Syntax_Syntax.fv_eq v1 v2 in - if uu___ - then - let uu___1 = - let uu___2 = FStar_Syntax_Util.eq_univs_list us1 us2 in - equal_iff uu___2 in - eq_and uu___1 (fun uu___2 -> eq_args args1 args2) - else FStar_Syntax_Util.Unknown - | (Constant c1, Constant c2) -> eq_constant c1 c2 - | (Type_t u1, Type_t u2) -> - let uu___ = FStar_Syntax_Util.eq_univs u1 u2 in equal_iff uu___ - | (Univ u1, Univ u2) -> - let uu___ = FStar_Syntax_Util.eq_univs u1 u2 in equal_iff uu___ - | (Refinement (r1, t11), Refinement (r2, t21)) -> - let x = - FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None - FStar_Syntax_Syntax.t_unit in - let uu___ = - let uu___1 = - let uu___2 = t11 () in FStar_Pervasives_Native.fst uu___2 in - let uu___2 = - let uu___3 = t21 () in FStar_Pervasives_Native.fst uu___3 in - eq_t uu___1 uu___2 in - eq_and uu___ - (fun uu___1 -> - let uu___2 = let uu___3 = mkAccuVar x in r1 uu___3 in - let uu___3 = let uu___4 = mkAccuVar x in r2 uu___4 in - eq_t uu___2 uu___3) - | (Unknown, Unknown) -> FStar_Syntax_Util.Equal - | (uu___, uu___1) -> FStar_Syntax_Util.Unknown -and (eq_atom : atom -> atom -> FStar_Syntax_Util.eq_result) = + | (Range r1, Range r2) -> FStar_TypeChecker_TermEqAndSimplify.Unknown + | (uu___, uu___1) -> FStar_TypeChecker_TermEqAndSimplify.NotEqual +let rec (eq_t : + FStar_TypeChecker_Env.env_t -> + t -> t -> FStar_TypeChecker_TermEqAndSimplify.eq_result) + = + fun env -> + fun t1 -> + fun t2 -> + match ((t1.nbe_t), (t2.nbe_t)) with + | (Lam uu___, Lam uu___1) -> + FStar_TypeChecker_TermEqAndSimplify.Unknown + | (Accu (a1, as1), Accu (a2, as2)) -> + let uu___ = eq_atom a1 a2 in + eq_and uu___ (fun uu___1 -> eq_args env as1 as2) + | (Construct (v1, us1, args1), Construct (v2, us2, args2)) -> + let uu___ = FStar_Syntax_Syntax.fv_eq v1 v2 in + if uu___ + then + (if + (FStar_Compiler_List.length args1) <> + (FStar_Compiler_List.length args2) + then + FStar_Compiler_Effect.failwith + "eq_t, different number of args on Construct" + else (); + (let uu___2 = FStar_Compiler_List.zip args1 args2 in + FStar_Compiler_List.fold_left + (fun acc -> + fun uu___3 -> + match uu___3 with + | ((a1, uu___4), (a2, uu___5)) -> + let uu___6 = eq_t env a1 a2 in eq_inj acc uu___6) + FStar_TypeChecker_TermEqAndSimplify.Equal uu___2)) + else FStar_TypeChecker_TermEqAndSimplify.NotEqual + | (FV (v1, us1, args1), FV (v2, us2, args2)) -> + let uu___ = FStar_Syntax_Syntax.fv_eq v1 v2 in + if uu___ + then + let uu___1 = + let uu___2 = FStar_Syntax_Util.eq_univs_list us1 us2 in + equal_iff uu___2 in + eq_and uu___1 (fun uu___2 -> eq_args env args1 args2) + else FStar_TypeChecker_TermEqAndSimplify.Unknown + | (Constant c1, Constant c2) -> eq_constant c1 c2 + | (Type_t u1, Type_t u2) -> + let uu___ = FStar_Syntax_Util.eq_univs u1 u2 in equal_iff uu___ + | (Univ u1, Univ u2) -> + let uu___ = FStar_Syntax_Util.eq_univs u1 u2 in equal_iff uu___ + | (Refinement (r1, t11), Refinement (r2, t21)) -> + let x = + FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None + FStar_Syntax_Syntax.t_unit in + let uu___ = + let uu___1 = + let uu___2 = t11 () in FStar_Pervasives_Native.fst uu___2 in + let uu___2 = + let uu___3 = t21 () in FStar_Pervasives_Native.fst uu___3 in + eq_t env uu___1 uu___2 in + eq_and uu___ + (fun uu___1 -> + let uu___2 = let uu___3 = mkAccuVar x in r1 uu___3 in + let uu___3 = let uu___4 = mkAccuVar x in r2 uu___4 in + eq_t env uu___2 uu___3) + | (Unknown, Unknown) -> FStar_TypeChecker_TermEqAndSimplify.Equal + | (uu___, uu___1) -> FStar_TypeChecker_TermEqAndSimplify.Unknown +and (eq_atom : atom -> atom -> FStar_TypeChecker_TermEqAndSimplify.eq_result) + = fun a1 -> fun a2 -> match (a1, a2) with | (Var bv1, Var bv2) -> let uu___ = FStar_Syntax_Syntax.bv_eq bv1 bv2 in equal_if uu___ - | (uu___, uu___1) -> FStar_Syntax_Util.Unknown -and (eq_arg : arg -> arg -> FStar_Syntax_Util.eq_result) = - fun a1 -> - fun a2 -> - eq_t (FStar_Pervasives_Native.fst a1) (FStar_Pervasives_Native.fst a2) -and (eq_args : args -> args -> FStar_Syntax_Util.eq_result) = - fun as1 -> - fun as2 -> - match (as1, as2) with - | ([], []) -> FStar_Syntax_Util.Equal - | (x::xs, y::ys) -> - let uu___ = eq_arg x y in - eq_and uu___ (fun uu___1 -> eq_args xs ys) - | (uu___, uu___1) -> FStar_Syntax_Util.Unknown + | (uu___, uu___1) -> FStar_TypeChecker_TermEqAndSimplify.Unknown +and (eq_arg : + FStar_TypeChecker_Env.env_t -> + arg -> arg -> FStar_TypeChecker_TermEqAndSimplify.eq_result) + = + fun env -> + fun a1 -> + fun a2 -> + eq_t env (FStar_Pervasives_Native.fst a1) + (FStar_Pervasives_Native.fst a2) +and (eq_args : + FStar_TypeChecker_Env.env_t -> + args -> args -> FStar_TypeChecker_TermEqAndSimplify.eq_result) + = + fun env -> + fun as1 -> + fun as2 -> + match (as1, as2) with + | ([], []) -> FStar_TypeChecker_TermEqAndSimplify.Equal + | (x::xs, y::ys) -> + let uu___ = eq_arg env x y in + eq_and uu___ (fun uu___1 -> eq_args env xs ys) + | (uu___, uu___1) -> FStar_TypeChecker_TermEqAndSimplify.Unknown let (constant_to_string : constant -> Prims.string) = fun c -> match c with diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize.ml index 04bc95afc05..fbe5fb64f0a 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize.ml @@ -1582,7 +1582,10 @@ let (reduce_equality : fun norm_cb -> fun cfg -> fun tm -> - reduce_primops norm_cb + let uu___ = + let uu___1 = + FStar_TypeChecker_Cfg.equality_ops + cfg.FStar_TypeChecker_Cfg.tcenv in { FStar_TypeChecker_Cfg.steps = { @@ -1652,8 +1655,7 @@ let (reduce_equality : FStar_TypeChecker_Cfg.debug = (cfg.FStar_TypeChecker_Cfg.debug); FStar_TypeChecker_Cfg.delta_level = (cfg.FStar_TypeChecker_Cfg.delta_level); - FStar_TypeChecker_Cfg.primitive_steps = - FStar_TypeChecker_Cfg.equality_ops; + FStar_TypeChecker_Cfg.primitive_steps = uu___1; FStar_TypeChecker_Cfg.strong = (cfg.FStar_TypeChecker_Cfg.strong); FStar_TypeChecker_Cfg.memoize_lazy = (cfg.FStar_TypeChecker_Cfg.memoize_lazy); @@ -1663,7 +1665,8 @@ let (reduce_equality : (cfg.FStar_TypeChecker_Cfg.reifying); FStar_TypeChecker_Cfg.compat_memo_ignore_cfg = (cfg.FStar_TypeChecker_Cfg.compat_memo_ignore_cfg) - } tm + } in + reduce_primops norm_cb uu___ tm type norm_request_t = | Norm_request_none | Norm_request_ready @@ -4972,7 +4975,8 @@ and (do_reify_monadic : (let maybe_range_arg = let uu___12 = FStar_Compiler_Util.for_some - (FStar_Syntax_Util.attr_eq + (FStar_TypeChecker_TermEqAndSimplify.eq_tm_bool + cfg.FStar_TypeChecker_Cfg.tcenv FStar_Syntax_Util.dm4f_bind_range_attr) ed.FStar_Syntax_Syntax.eff_attrs in if uu___12 @@ -6420,10 +6424,12 @@ and (maybe_simplify_aux : -> (t, false) | uu___32 -> let uu___33 = - norm_cb cfg in - reduce_equality - uu___33 cfg - env1 tm1)))))))))) + let uu___34 = + norm_cb cfg in + reduce_equality + uu___34 cfg + env1 in + uu___33 tm1)))))))))) | FStar_Syntax_Syntax.Tm_app { FStar_Syntax_Syntax.hd = @@ -6965,10 +6971,12 @@ and (maybe_simplify_aux : -> (t, false) | uu___28 -> let uu___29 = - norm_cb cfg in - reduce_equality - uu___29 cfg - env1 tm1)))))))))) + let uu___30 = + norm_cb cfg in + reduce_equality + uu___30 cfg + env1 in + uu___29 tm1)))))))))) | FStar_Syntax_Syntax.Tm_refine { FStar_Syntax_Syntax.b = bv; FStar_Syntax_Syntax.phi = t;_} diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize_Unfolding.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize_Unfolding.ml index 76069b83a47..b18144f3b1b 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize_Unfolding.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize_Unfolding.ml @@ -694,7 +694,8 @@ let (should_unfold : (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_tac && (FStar_Compiler_Util.for_some - (FStar_Syntax_Util.attr_eq + (FStar_TypeChecker_TermEqAndSimplify.eq_tm_bool + cfg.FStar_TypeChecker_Cfg.tcenv FStar_Syntax_Util.tac_opaque_attr) attrs) -> (FStar_TypeChecker_Cfg.log_unfolding cfg diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops.ml index cc07f707b7a..6bc474617d9 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops.ml @@ -1146,9 +1146,12 @@ let (built_in_primitive_steps_list : FStar_TypeChecker_Primops_Docs.ops (FStar_Compiler_List.op_At FStar_TypeChecker_Primops_MachineInts.ops - (FStar_Compiler_List.op_At - FStar_TypeChecker_Primops_Eq.dec_eq_ops - FStar_TypeChecker_Primops_Errors_Msg.ops)))))))) + FStar_TypeChecker_Primops_Errors_Msg.ops))))))) let (equality_ops_list : - FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - FStar_TypeChecker_Primops_Eq.prop_eq_ops \ No newline at end of file + FStar_TypeChecker_Env.env_t -> + FStar_TypeChecker_Primops_Base.primitive_step Prims.list) + = fun env -> FStar_TypeChecker_Primops_Eq.prop_eq_ops env +let (env_dependent_ops : + FStar_TypeChecker_Env.env_t -> + FStar_TypeChecker_Primops_Base.primitive_step Prims.list) + = fun env -> FStar_TypeChecker_Primops_Eq.dec_eq_ops env \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Eq.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Eq.ml index 833b8d1e78e..257be3a2c80 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Eq.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Eq.ml @@ -1,38 +1,46 @@ open Prims let (s_eq : - FStar_Syntax_Embeddings.abstract_term -> + FStar_TypeChecker_Env.env_t -> FStar_Syntax_Embeddings.abstract_term -> FStar_Syntax_Embeddings.abstract_term -> - Prims.bool FStar_Pervasives_Native.option) + FStar_Syntax_Embeddings.abstract_term -> + Prims.bool FStar_Pervasives_Native.option) = - fun _typ -> - fun x -> - fun y -> - let uu___ = - FStar_Syntax_Util.eq_tm - (FStar_Syntax_Embeddings.__proj__Abstract__item__t x) - (FStar_Syntax_Embeddings.__proj__Abstract__item__t y) in - match uu___ with - | FStar_Syntax_Util.Equal -> FStar_Pervasives_Native.Some true - | FStar_Syntax_Util.NotEqual -> FStar_Pervasives_Native.Some false - | uu___1 -> FStar_Pervasives_Native.None + fun env -> + fun _typ -> + fun x -> + fun y -> + let uu___ = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env + (FStar_Syntax_Embeddings.__proj__Abstract__item__t x) + (FStar_Syntax_Embeddings.__proj__Abstract__item__t y) in + match uu___ with + | FStar_TypeChecker_TermEqAndSimplify.Equal -> + FStar_Pervasives_Native.Some true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> + FStar_Pervasives_Native.Some false + | uu___1 -> FStar_Pervasives_Native.None let (nbe_eq : - FStar_TypeChecker_NBETerm.abstract_nbe_term -> + FStar_TypeChecker_Env.env_t -> FStar_TypeChecker_NBETerm.abstract_nbe_term -> FStar_TypeChecker_NBETerm.abstract_nbe_term -> - Prims.bool FStar_Pervasives_Native.option) + FStar_TypeChecker_NBETerm.abstract_nbe_term -> + Prims.bool FStar_Pervasives_Native.option) = - fun _typ -> - fun x -> - fun y -> - let uu___ = - FStar_TypeChecker_NBETerm.eq_t - (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t x) - (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t y) in - match uu___ with - | FStar_Syntax_Util.Equal -> FStar_Pervasives_Native.Some true - | FStar_Syntax_Util.NotEqual -> FStar_Pervasives_Native.Some false - | uu___1 -> FStar_Pervasives_Native.None + fun env -> + fun _typ -> + fun x -> + fun y -> + let uu___ = + FStar_TypeChecker_NBETerm.eq_t env + (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t x) + (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t y) in + match uu___ with + | FStar_TypeChecker_TermEqAndSimplify.Equal -> + FStar_Pervasives_Native.Some true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> + FStar_Pervasives_Native.Some false + | uu___1 -> FStar_Pervasives_Native.None let push3 : 'uuuuu 'uuuuu1 'uuuuu2 'uuuuu3 'uuuuu4 . ('uuuuu -> 'uuuuu1) -> @@ -55,142 +63,76 @@ let negopt3 : (Obj.magic (FStar_Class_Monad.fmap FStar_Class_Monad.monad_option () () (fun uu___1 -> (Obj.magic Prims.op_Negation) uu___1))) uu___1) -let (dec_eq_ops : FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - let uu___ = - FStar_TypeChecker_Primops_Base.mk3' Prims.int_zero - FStar_Parser_Const.op_Eq FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_bool FStar_TypeChecker_NBETerm.e_bool s_eq - nbe_eq in - let uu___1 = - let uu___2 = +let (dec_eq_ops : + FStar_TypeChecker_Env.env_t -> + FStar_TypeChecker_Primops_Base.primitive_step Prims.list) + = + fun env -> + let uu___ = FStar_TypeChecker_Primops_Base.mk3' Prims.int_zero - FStar_Parser_Const.op_notEq FStar_Syntax_Embeddings.e_abstract_term + FStar_Parser_Const.op_Eq FStar_Syntax_Embeddings.e_abstract_term FStar_TypeChecker_NBETerm.e_abstract_nbe_term FStar_Syntax_Embeddings.e_abstract_term FStar_TypeChecker_NBETerm.e_abstract_nbe_term FStar_Syntax_Embeddings.e_abstract_term FStar_TypeChecker_NBETerm.e_abstract_nbe_term FStar_Syntax_Embeddings.e_bool FStar_TypeChecker_NBETerm.e_bool - ((negopt3 ()) s_eq) ((negopt3 ()) nbe_eq) in - [uu___2] in - uu___ :: uu___1 + (s_eq env) (nbe_eq env) in + let uu___1 = + let uu___2 = + FStar_TypeChecker_Primops_Base.mk3' Prims.int_zero + FStar_Parser_Const.op_notEq FStar_Syntax_Embeddings.e_abstract_term + FStar_TypeChecker_NBETerm.e_abstract_nbe_term + FStar_Syntax_Embeddings.e_abstract_term + FStar_TypeChecker_NBETerm.e_abstract_nbe_term + FStar_Syntax_Embeddings.e_abstract_term + FStar_TypeChecker_NBETerm.e_abstract_nbe_term + FStar_Syntax_Embeddings.e_bool FStar_TypeChecker_NBETerm.e_bool + ((negopt3 ()) (s_eq env)) ((negopt3 ()) (nbe_eq env)) in + [uu___2] in + uu___ :: uu___1 let (s_eq2 : - FStar_Syntax_Embeddings.abstract_term -> - FStar_Syntax_Embeddings.abstract_term -> - FStar_Syntax_Embeddings.abstract_term -> - FStar_Syntax_Embeddings.abstract_term FStar_Pervasives_Native.option) - = - fun _typ -> - fun x -> - fun y -> - let uu___ = - FStar_Syntax_Util.eq_tm - (FStar_Syntax_Embeddings.__proj__Abstract__item__t x) - (FStar_Syntax_Embeddings.__proj__Abstract__item__t y) in - match uu___ with - | FStar_Syntax_Util.Equal -> - FStar_Pervasives_Native.Some - (FStar_Syntax_Embeddings.Abstract FStar_Syntax_Util.t_true) - | FStar_Syntax_Util.NotEqual -> - FStar_Pervasives_Native.Some - (FStar_Syntax_Embeddings.Abstract FStar_Syntax_Util.t_false) - | uu___1 -> FStar_Pervasives_Native.None -let (nbe_eq2 : - FStar_TypeChecker_NBETerm.abstract_nbe_term -> - FStar_TypeChecker_NBETerm.abstract_nbe_term -> - FStar_TypeChecker_NBETerm.abstract_nbe_term -> - FStar_TypeChecker_NBETerm.abstract_nbe_term - FStar_Pervasives_Native.option) - = - fun _typ -> - fun x -> - fun y -> - let uu___ = - FStar_TypeChecker_NBETerm.eq_t - (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t x) - (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t y) in - match uu___ with - | FStar_Syntax_Util.Equal -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.true_lid - FStar_Pervasives_Native.None in - FStar_TypeChecker_NBETerm.mkFV uu___3 [] [] in - FStar_TypeChecker_NBETerm.AbstractNBE uu___2 in - FStar_Pervasives_Native.Some uu___1 - | FStar_Syntax_Util.NotEqual -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.false_lid - FStar_Pervasives_Native.None in - FStar_TypeChecker_NBETerm.mkFV uu___3 [] [] in - FStar_TypeChecker_NBETerm.AbstractNBE uu___2 in - FStar_Pervasives_Native.Some uu___1 - | FStar_Syntax_Util.Unknown -> FStar_Pervasives_Native.None -let (s_eq3 : - FStar_Syntax_Embeddings.abstract_term -> + FStar_TypeChecker_Env.env_t -> FStar_Syntax_Embeddings.abstract_term -> FStar_Syntax_Embeddings.abstract_term -> FStar_Syntax_Embeddings.abstract_term -> FStar_Syntax_Embeddings.abstract_term FStar_Pervasives_Native.option) = - fun typ1 -> - fun typ2 -> + fun env -> + fun _typ -> fun x -> fun y -> let uu___ = - let uu___1 = - FStar_Syntax_Util.eq_tm - (FStar_Syntax_Embeddings.__proj__Abstract__item__t typ1) - (FStar_Syntax_Embeddings.__proj__Abstract__item__t typ2) in - let uu___2 = - FStar_Syntax_Util.eq_tm - (FStar_Syntax_Embeddings.__proj__Abstract__item__t x) - (FStar_Syntax_Embeddings.__proj__Abstract__item__t y) in - (uu___1, uu___2) in + FStar_TypeChecker_TermEqAndSimplify.eq_tm env + (FStar_Syntax_Embeddings.__proj__Abstract__item__t x) + (FStar_Syntax_Embeddings.__proj__Abstract__item__t y) in match uu___ with - | (FStar_Syntax_Util.Equal, FStar_Syntax_Util.Equal) -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> FStar_Pervasives_Native.Some (FStar_Syntax_Embeddings.Abstract FStar_Syntax_Util.t_true) - | (FStar_Syntax_Util.NotEqual, uu___1) -> - FStar_Pervasives_Native.Some - (FStar_Syntax_Embeddings.Abstract FStar_Syntax_Util.t_false) - | (uu___1, FStar_Syntax_Util.NotEqual) -> + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> FStar_Pervasives_Native.Some (FStar_Syntax_Embeddings.Abstract FStar_Syntax_Util.t_false) | uu___1 -> FStar_Pervasives_Native.None -let (nbe_eq3 : - FStar_TypeChecker_NBETerm.abstract_nbe_term -> +let (nbe_eq2 : + FStar_TypeChecker_Env.env_t -> FStar_TypeChecker_NBETerm.abstract_nbe_term -> FStar_TypeChecker_NBETerm.abstract_nbe_term -> FStar_TypeChecker_NBETerm.abstract_nbe_term -> FStar_TypeChecker_NBETerm.abstract_nbe_term FStar_Pervasives_Native.option) = - fun typ1 -> - fun typ2 -> + fun env -> + fun _typ -> fun x -> fun y -> let uu___ = - let uu___1 = - FStar_TypeChecker_NBETerm.eq_t - (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t typ1) - (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t typ2) in - let uu___2 = - FStar_TypeChecker_NBETerm.eq_t - (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t x) - (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t y) in - (uu___1, uu___2) in + FStar_TypeChecker_NBETerm.eq_t env + (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t x) + (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t y) in match uu___ with - | (FStar_Syntax_Util.Equal, FStar_Syntax_Util.Equal) -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> let uu___1 = let uu___2 = let uu___3 = @@ -199,51 +141,142 @@ let (nbe_eq3 : FStar_TypeChecker_NBETerm.mkFV uu___3 [] [] in FStar_TypeChecker_NBETerm.AbstractNBE uu___2 in FStar_Pervasives_Native.Some uu___1 - | (FStar_Syntax_Util.NotEqual, uu___1) -> - let uu___2 = - let uu___3 = - let uu___4 = + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> + let uu___1 = + let uu___2 = + let uu___3 = FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.false_lid FStar_Pervasives_Native.None in - FStar_TypeChecker_NBETerm.mkFV uu___4 [] [] in - FStar_TypeChecker_NBETerm.AbstractNBE uu___3 in - FStar_Pervasives_Native.Some uu___2 - | (uu___1, FStar_Syntax_Util.NotEqual) -> + FStar_TypeChecker_NBETerm.mkFV uu___3 [] [] in + FStar_TypeChecker_NBETerm.AbstractNBE uu___2 in + FStar_Pervasives_Native.Some uu___1 + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> + FStar_Pervasives_Native.None +let (s_eq3 : + FStar_TypeChecker_Env.env_t -> + FStar_Syntax_Embeddings.abstract_term -> + FStar_Syntax_Embeddings.abstract_term -> + FStar_Syntax_Embeddings.abstract_term -> + FStar_Syntax_Embeddings.abstract_term -> + FStar_Syntax_Embeddings.abstract_term + FStar_Pervasives_Native.option) + = + fun env -> + fun typ1 -> + fun typ2 -> + fun x -> + fun y -> + let uu___ = + let uu___1 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env + (FStar_Syntax_Embeddings.__proj__Abstract__item__t typ1) + (FStar_Syntax_Embeddings.__proj__Abstract__item__t typ2) in let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Syntax.lid_as_fv - FStar_Parser_Const.false_lid - FStar_Pervasives_Native.None in - FStar_TypeChecker_NBETerm.mkFV uu___4 [] [] in - FStar_TypeChecker_NBETerm.AbstractNBE uu___3 in - FStar_Pervasives_Native.Some uu___2 - | uu___1 -> FStar_Pervasives_Native.None -let (prop_eq_ops : FStar_TypeChecker_Primops_Base.primitive_step Prims.list) + FStar_TypeChecker_TermEqAndSimplify.eq_tm env + (FStar_Syntax_Embeddings.__proj__Abstract__item__t x) + (FStar_Syntax_Embeddings.__proj__Abstract__item__t y) in + (uu___1, uu___2) in + match uu___ with + | (FStar_TypeChecker_TermEqAndSimplify.Equal, + FStar_TypeChecker_TermEqAndSimplify.Equal) -> + FStar_Pervasives_Native.Some + (FStar_Syntax_Embeddings.Abstract FStar_Syntax_Util.t_true) + | (FStar_TypeChecker_TermEqAndSimplify.NotEqual, uu___1) -> + FStar_Pervasives_Native.Some + (FStar_Syntax_Embeddings.Abstract FStar_Syntax_Util.t_false) + | (uu___1, FStar_TypeChecker_TermEqAndSimplify.NotEqual) -> + FStar_Pervasives_Native.Some + (FStar_Syntax_Embeddings.Abstract FStar_Syntax_Util.t_false) + | uu___1 -> FStar_Pervasives_Native.None +let (nbe_eq3 : + FStar_TypeChecker_Env.env_t -> + FStar_TypeChecker_NBETerm.abstract_nbe_term -> + FStar_TypeChecker_NBETerm.abstract_nbe_term -> + FStar_TypeChecker_NBETerm.abstract_nbe_term -> + FStar_TypeChecker_NBETerm.abstract_nbe_term -> + FStar_TypeChecker_NBETerm.abstract_nbe_term + FStar_Pervasives_Native.option) = - let uu___ = - FStar_TypeChecker_Primops_Base.mk3' Prims.int_one - FStar_Parser_Const.eq2_lid FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term s_eq2 nbe_eq2 in - let uu___1 = - let uu___2 = - FStar_TypeChecker_Primops_Base.mk4' (Prims.of_int (2)) - FStar_Parser_Const.eq3_lid FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_abstract_term + fun env -> + fun typ1 -> + fun typ2 -> + fun x -> + fun y -> + let uu___ = + let uu___1 = + FStar_TypeChecker_NBETerm.eq_t env + (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t + typ1) + (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t + typ2) in + let uu___2 = + FStar_TypeChecker_NBETerm.eq_t env + (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t x) + (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t y) in + (uu___1, uu___2) in + match uu___ with + | (FStar_TypeChecker_TermEqAndSimplify.Equal, + FStar_TypeChecker_TermEqAndSimplify.Equal) -> + let uu___1 = + let uu___2 = + let uu___3 = + FStar_Syntax_Syntax.lid_as_fv + FStar_Parser_Const.true_lid + FStar_Pervasives_Native.None in + FStar_TypeChecker_NBETerm.mkFV uu___3 [] [] in + FStar_TypeChecker_NBETerm.AbstractNBE uu___2 in + FStar_Pervasives_Native.Some uu___1 + | (FStar_TypeChecker_TermEqAndSimplify.NotEqual, uu___1) -> + let uu___2 = + let uu___3 = + let uu___4 = + FStar_Syntax_Syntax.lid_as_fv + FStar_Parser_Const.false_lid + FStar_Pervasives_Native.None in + FStar_TypeChecker_NBETerm.mkFV uu___4 [] [] in + FStar_TypeChecker_NBETerm.AbstractNBE uu___3 in + FStar_Pervasives_Native.Some uu___2 + | (uu___1, FStar_TypeChecker_TermEqAndSimplify.NotEqual) -> + let uu___2 = + let uu___3 = + let uu___4 = + FStar_Syntax_Syntax.lid_as_fv + FStar_Parser_Const.false_lid + FStar_Pervasives_Native.None in + FStar_TypeChecker_NBETerm.mkFV uu___4 [] [] in + FStar_TypeChecker_NBETerm.AbstractNBE uu___3 in + FStar_Pervasives_Native.Some uu___2 + | uu___1 -> FStar_Pervasives_Native.None +let (prop_eq_ops : + FStar_TypeChecker_Env.env_t -> + FStar_TypeChecker_Primops_Base.primitive_step Prims.list) + = + fun env -> + let uu___ = + FStar_TypeChecker_Primops_Base.mk3' Prims.int_one + FStar_Parser_Const.eq2_lid FStar_Syntax_Embeddings.e_abstract_term FStar_TypeChecker_NBETerm.e_abstract_nbe_term FStar_Syntax_Embeddings.e_abstract_term FStar_TypeChecker_NBETerm.e_abstract_nbe_term FStar_Syntax_Embeddings.e_abstract_term FStar_TypeChecker_NBETerm.e_abstract_nbe_term FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term s_eq3 nbe_eq3 in - [uu___2] in - uu___ :: uu___1 \ No newline at end of file + FStar_TypeChecker_NBETerm.e_abstract_nbe_term (s_eq2 env) + (nbe_eq2 env) in + let uu___1 = + let uu___2 = + FStar_TypeChecker_Primops_Base.mk4' (Prims.of_int (2)) + FStar_Parser_Const.eq3_lid FStar_Syntax_Embeddings.e_abstract_term + FStar_TypeChecker_NBETerm.e_abstract_nbe_term + FStar_Syntax_Embeddings.e_abstract_term + FStar_TypeChecker_NBETerm.e_abstract_nbe_term + FStar_Syntax_Embeddings.e_abstract_term + FStar_TypeChecker_NBETerm.e_abstract_nbe_term + FStar_Syntax_Embeddings.e_abstract_term + FStar_TypeChecker_NBETerm.e_abstract_nbe_term + FStar_Syntax_Embeddings.e_abstract_term + FStar_TypeChecker_NBETerm.e_abstract_nbe_term (s_eq3 env) + (nbe_eq3 env) in + [uu___2] in + uu___ :: uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Rel.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Rel.ml index 075f1913578..f92e7d14be5 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Rel.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Rel.ml @@ -3199,8 +3199,9 @@ let (head_matches_delta : "FStar.TypeChecker.Rel.norm_with_steps.1" steps env t in let uu___4 = - let uu___5 = FStar_Syntax_Util.eq_tm t t' in - uu___5 = FStar_Syntax_Util.Equal in + let uu___5 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t t' in + uu___5 = FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___4 then FStar_Pervasives_Native.None else @@ -3242,8 +3243,9 @@ let (head_matches_delta : match uu___ with | (head, head') -> let uu___1 = - let uu___2 = FStar_Syntax_Util.eq_tm head head' in - uu___2 = FStar_Syntax_Util.Equal in + let uu___2 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env head head' in + uu___2 = FStar_TypeChecker_TermEqAndSimplify.Equal in Prims.op_Negation uu___1 in let rec aux retry n_delta t11 t21 = let r = head_matches env t11 t21 in @@ -6524,8 +6526,7 @@ and (solve_binders : match (a1, a2) with | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit b1), FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Implicit b2)) -> - FStar_Syntax_Util.Equal + (FStar_Syntax_Syntax.Implicit b2)) -> true | uu___1 -> FStar_Syntax_Util.eq_bqual a1 a2 in let compat_positivity_qualifiers p1 p2 = match p_rel orig with @@ -6552,10 +6553,9 @@ and (solve_binders : (let formula = p_guard rhs_prob in ((FStar_Pervasives.Inl ([rhs_prob], formula)), wl2)))) | (x::xs1, y::ys1) when - (let uu___1 = - eq_bqual x.FStar_Syntax_Syntax.binder_qual - y.FStar_Syntax_Syntax.binder_qual in - uu___1 = FStar_Syntax_Util.Equal) && + (eq_bqual x.FStar_Syntax_Syntax.binder_qual + y.FStar_Syntax_Syntax.binder_qual) + && (compat_positivity_qualifiers x.FStar_Syntax_Syntax.binder_positivity y.FStar_Syntax_Syntax.binder_positivity) @@ -6823,8 +6823,10 @@ and (solve_t_flex_rigid_eq : (fun x -> fun y -> let uu___7 = - FStar_Syntax_Util.eq_tm x y in - uu___7 = FStar_Syntax_Util.Equal) + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env x y in + uu___7 = + FStar_TypeChecker_TermEqAndSimplify.Equal) b.FStar_Syntax_Syntax.binder_attrs a.FStar_Syntax_Syntax.aqual_attributes) | uu___6 -> false in @@ -7527,10 +7529,10 @@ and (solve_t_flex_rigid_eq : let uu___17 = FStar_Syntax_Util.ctx_uvar_typ ctx_uv in - FStar_Syntax_Util.eq_tm - t_head uu___17 in + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env t_head uu___17 in uu___16 = - FStar_Syntax_Util.Equal in + FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___15 then solve_sub_probs_if_head_types_equal @@ -8196,8 +8198,10 @@ and (solve_t' : tprob -> worklist -> solution) = else (let uu___5 = (nargs = Prims.int_zero) || - (let uu___6 = FStar_Syntax_Util.eq_args args1 args2 in - uu___6 = FStar_Syntax_Util.Equal) in + (let uu___6 = + FStar_TypeChecker_TermEqAndSimplify.eq_args env + args1 args2 in + uu___6 = FStar_TypeChecker_TermEqAndSimplify.Equal) in if uu___5 then (if need_unif1 @@ -8399,19 +8403,21 @@ and (solve_t' : tprob -> worklist -> solution) = -> let uu___16 = let uu___17 = - FStar_Syntax_Util.eq_tm + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env1 head1' head1 in let uu___18 = - FStar_Syntax_Util.eq_tm + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env1 head2' head2 in (uu___17, uu___18) in (match uu___16 with - | (FStar_Syntax_Util.Equal, - FStar_Syntax_Util.Equal) + | (FStar_TypeChecker_TermEqAndSimplify.Equal, + FStar_TypeChecker_TermEqAndSimplify.Equal) -> ((let uu___18 = @@ -10656,11 +10662,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -10668,7 +10676,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -10677,8 +10684,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -10792,11 +10801,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -10804,7 +10815,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -10813,8 +10823,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -10928,11 +10940,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -10940,7 +10954,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -10949,8 +10962,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -11064,11 +11079,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -11076,7 +11093,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -11085,8 +11101,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -11200,11 +11218,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -11212,7 +11232,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -11221,8 +11240,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -11336,11 +11357,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -11348,7 +11371,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -11357,8 +11379,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -11472,11 +11496,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -11484,7 +11510,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -11493,8 +11518,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -11608,11 +11635,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -11620,7 +11649,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -11629,8 +11657,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -11744,11 +11774,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -11756,7 +11788,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -11765,8 +11796,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -11880,11 +11913,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -11892,7 +11927,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -11901,8 +11935,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -12016,11 +12052,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -12028,7 +12066,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -12037,8 +12074,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -12152,11 +12191,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -12164,7 +12205,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -12173,8 +12213,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcEffect.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcEffect.ml index 226e42cdf27..279718c6c74 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcEffect.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcEffect.ml @@ -692,11 +692,12 @@ let (bind_combinator_kind : = let uu___14 = - FStar_Syntax_Util.eq_tm + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env g_sig_b_arrow_t (g_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in uu___14 = - FStar_Syntax_Util.Equal in + FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___13 then @@ -706,11 +707,12 @@ let (bind_combinator_kind : = let uu___16 = - FStar_Syntax_Util.eq_tm + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env g_sig_b_sort (g_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in uu___16 = - FStar_Syntax_Util.Equal in + FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___15 then @@ -963,11 +965,12 @@ let (bind_combinator_kind : = let uu___15 = - FStar_Syntax_Util.eq_tm + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env (f_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort expected_f_b_sort in uu___15 = - FStar_Syntax_Util.Equal in + FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___14 then @@ -1190,11 +1193,12 @@ let (bind_combinator_kind : = let uu___16 = - FStar_Syntax_Util.eq_tm + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env (g_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort expected_g_b_sort in uu___16 = - FStar_Syntax_Util.Equal in + FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___15 then @@ -1923,11 +1927,12 @@ let (subcomp_combinator_kind : uu___8 uu___9 in let uu___8 = let uu___9 = - FStar_Syntax_Util.eq_tm + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env (f_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort expected_f_b_sort in uu___9 = - FStar_Syntax_Util.Equal in + FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___8 then FStar_Pervasives_Native.Some @@ -2052,12 +2057,13 @@ let (subcomp_combinator_kind : uu___9 in let uu___8 = let uu___9 = - FStar_Syntax_Util.eq_tm + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env (FStar_Syntax_Util.comp_result k_c) expected_t in uu___9 = - FStar_Syntax_Util.Equal in + FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___8 then FStar_Pervasives_Native.Some @@ -2668,11 +2674,12 @@ let (ite_combinator_kind : FStar_Compiler_Range_Type.dummyRange in let uu___10 = let uu___11 = - FStar_Syntax_Util.eq_tm + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env (f_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort expected_f_b_sort in uu___11 = - FStar_Syntax_Util.Equal in + FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___10 then FStar_Pervasives_Native.Some @@ -2731,11 +2738,12 @@ let (ite_combinator_kind : FStar_Compiler_Range_Type.dummyRange in let uu___10 = let uu___11 = - FStar_Syntax_Util.eq_tm + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env (g_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort expected_g_b_sort in uu___11 = - FStar_Syntax_Util.Equal in + FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___10 then FStar_Pervasives_Native.Some @@ -3465,10 +3473,12 @@ let (lift_combinator_kind : uu___8 in let uu___7 = let uu___8 = - FStar_Syntax_Util.eq_tm + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env (f_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort expected_f_b_sort in - uu___8 = FStar_Syntax_Util.Equal in + uu___8 = + FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___7 then FStar_Pervasives_Native.Some () else FStar_Pervasives_Native.None in @@ -7530,7 +7540,8 @@ let (tc_non_layered_eff_decl : = let uu___21 = FStar_Compiler_Util.for_some - (FStar_Syntax_Util.attr_eq + (FStar_TypeChecker_TermEqAndSimplify.eq_tm_bool + env FStar_Syntax_Util.dm4f_bind_range_attr) ed2.FStar_Syntax_Syntax.eff_attrs in if uu___21 diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcTerm.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcTerm.ml index aeadfe2bf63..cc3b5c5ecc1 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcTerm.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcTerm.ml @@ -1341,8 +1341,10 @@ let (guard_letrecs : FStar_Syntax_Util.unrefine uu___ in let rec warn t11 t21 = let uu___ = - let uu___1 = FStar_Syntax_Util.eq_tm t11 t21 in - uu___1 = FStar_Syntax_Util.Equal in + let uu___1 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env2 t11 + t21 in + uu___1 = FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___ then false else @@ -1531,8 +1533,10 @@ let (guard_letrecs : uu___1 :: uu___2 in FStar_Syntax_Syntax.mk_Tm_app rel uu___ r in let uu___ = - let uu___1 = FStar_Syntax_Util.eq_tm rel rel_prev in - uu___1 = FStar_Syntax_Util.Equal in + let uu___1 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env2 rel + rel_prev in + uu___1 = FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___ then rel_guard else @@ -5996,7 +6000,7 @@ and (tc_abs_check_binders : let uu___2 = (Prims.op_Negation (special imp imp')) && (let uu___3 = FStar_Syntax_Util.eq_bqual imp imp' in - uu___3 <> FStar_Syntax_Util.Equal) in + Prims.op_Negation uu___3) in if uu___2 then let uu___3 = @@ -6128,9 +6132,10 @@ and (tc_abs_check_binders : FStar_Compiler_List.existsb (fun attr -> let uu___5 = - FStar_Syntax_Util.eq_tm attr - attr' in - uu___5 = FStar_Syntax_Util.Equal) + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env1 attr attr' in + uu___5 = + FStar_TypeChecker_TermEqAndSimplify.Equal) attrs1 in Prims.op_Negation uu___4) attrs'1 in FStar_Compiler_List.op_At attrs1 diff in diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml new file mode 100644 index 00000000000..cd2b0c70cef --- /dev/null +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml @@ -0,0 +1,1303 @@ +open Prims +type eq_result = + | Equal + | NotEqual + | Unknown +let (uu___is_Equal : eq_result -> Prims.bool) = + fun projectee -> match projectee with | Equal -> true | uu___ -> false +let (uu___is_NotEqual : eq_result -> Prims.bool) = + fun projectee -> match projectee with | NotEqual -> true | uu___ -> false +let (uu___is_Unknown : eq_result -> Prims.bool) = + fun projectee -> match projectee with | Unknown -> true | uu___ -> false +let (injectives : Prims.string Prims.list) = + ["FStar.Int8.int_to_t"; + "FStar.Int16.int_to_t"; + "FStar.Int32.int_to_t"; + "FStar.Int64.int_to_t"; + "FStar.Int128.int_to_t"; + "FStar.UInt8.uint_to_t"; + "FStar.UInt16.uint_to_t"; + "FStar.UInt32.uint_to_t"; + "FStar.UInt64.uint_to_t"; + "FStar.UInt128.uint_to_t"; + "FStar.SizeT.uint_to_t"; + "FStar.Int8.__int_to_t"; + "FStar.Int16.__int_to_t"; + "FStar.Int32.__int_to_t"; + "FStar.Int64.__int_to_t"; + "FStar.Int128.__int_to_t"; + "FStar.UInt8.__uint_to_t"; + "FStar.UInt16.__uint_to_t"; + "FStar.UInt32.__uint_to_t"; + "FStar.UInt64.__uint_to_t"; + "FStar.UInt128.__uint_to_t"; + "FStar.SizeT.__uint_to_t"] +let (eq_inj : eq_result -> eq_result -> eq_result) = + fun r -> + fun s -> + match (r, s) with + | (Equal, Equal) -> Equal + | (NotEqual, uu___) -> NotEqual + | (uu___, NotEqual) -> NotEqual + | (uu___, uu___1) -> Unknown +let (equal_if : Prims.bool -> eq_result) = + fun uu___ -> if uu___ then Equal else Unknown +let (equal_iff : Prims.bool -> eq_result) = + fun uu___ -> if uu___ then Equal else NotEqual +let (eq_and : eq_result -> (unit -> eq_result) -> eq_result) = + fun r -> + fun s -> + let uu___ = (r = Equal) && (let uu___1 = s () in uu___1 = Equal) in + if uu___ then Equal else Unknown +let rec (eq_tm : + FStar_TypeChecker_Env.env_t -> + FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> eq_result) + = + fun env -> + fun t1 -> + fun t2 -> + let eq_tm1 = eq_tm env in + let t11 = FStar_Syntax_Util.canon_app t1 in + let t21 = FStar_Syntax_Util.canon_app t2 in + let equal_data f1 args1 f2 args2 = + let uu___ = FStar_Syntax_Syntax.fv_eq f1 f2 in + if uu___ + then + let uu___1 = FStar_Compiler_List.zip args1 args2 in + FStar_Compiler_List.fold_left + (fun acc -> + fun uu___2 -> + match uu___2 with + | ((a1, q1), (a2, q2)) -> + let uu___3 = eq_tm1 a1 a2 in eq_inj acc uu___3) Equal + uu___1 + else NotEqual in + let qual_is_inj uu___ = + match uu___ with + | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Data_ctor) -> + true + | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Record_ctor + uu___1) -> true + | uu___1 -> false in + let heads_and_args_in_case_both_data = + let uu___ = + let uu___1 = FStar_Syntax_Util.unmeta t11 in + FStar_Syntax_Util.head_and_args uu___1 in + match uu___ with + | (head1, args1) -> + let uu___1 = + let uu___2 = FStar_Syntax_Util.unmeta t21 in + FStar_Syntax_Util.head_and_args uu___2 in + (match uu___1 with + | (head2, args2) -> + let uu___2 = + let uu___3 = + let uu___4 = FStar_Syntax_Util.un_uinst head1 in + uu___4.FStar_Syntax_Syntax.n in + let uu___4 = + let uu___5 = FStar_Syntax_Util.un_uinst head2 in + uu___5.FStar_Syntax_Syntax.n in + (uu___3, uu___4) in + (match uu___2 with + | (FStar_Syntax_Syntax.Tm_fvar f, + FStar_Syntax_Syntax.Tm_fvar g) when + (qual_is_inj f.FStar_Syntax_Syntax.fv_qual) && + (qual_is_inj g.FStar_Syntax_Syntax.fv_qual) + -> FStar_Pervasives_Native.Some (f, args1, g, args2) + | uu___3 -> FStar_Pervasives_Native.None)) in + let t12 = FStar_Syntax_Util.unmeta t11 in + let t22 = FStar_Syntax_Util.unmeta t21 in + match ((t12.FStar_Syntax_Syntax.n), (t22.FStar_Syntax_Syntax.n)) with + | (FStar_Syntax_Syntax.Tm_bvar bv1, FStar_Syntax_Syntax.Tm_bvar bv2) + -> + equal_if + (bv1.FStar_Syntax_Syntax.index = bv2.FStar_Syntax_Syntax.index) + | (FStar_Syntax_Syntax.Tm_lazy uu___, uu___1) -> + let uu___2 = FStar_Syntax_Util.unlazy t12 in eq_tm1 uu___2 t22 + | (uu___, FStar_Syntax_Syntax.Tm_lazy uu___1) -> + let uu___2 = FStar_Syntax_Util.unlazy t22 in eq_tm1 t12 uu___2 + | (FStar_Syntax_Syntax.Tm_name a, FStar_Syntax_Syntax.Tm_name b) -> + let uu___ = FStar_Syntax_Syntax.bv_eq a b in equal_if uu___ + | uu___ when + FStar_Pervasives_Native.uu___is_Some + heads_and_args_in_case_both_data + -> + let uu___1 = + FStar_Compiler_Util.must heads_and_args_in_case_both_data in + (match uu___1 with + | (f, args1, g, args2) -> equal_data f args1 g args2) + | (FStar_Syntax_Syntax.Tm_fvar f, FStar_Syntax_Syntax.Tm_fvar g) -> + let uu___ = FStar_Syntax_Syntax.fv_eq f g in equal_if uu___ + | (FStar_Syntax_Syntax.Tm_uinst (f, us), FStar_Syntax_Syntax.Tm_uinst + (g, vs)) -> + let uu___ = eq_tm1 f g in + eq_and uu___ + (fun uu___1 -> + let uu___2 = FStar_Syntax_Util.eq_univs_list us vs in + equal_if uu___2) + | (FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_range uu___), + FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_range uu___1)) + -> Unknown + | (FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_real r1), + FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_real r2)) -> + equal_if (r1 = r2) + | (FStar_Syntax_Syntax.Tm_constant c, FStar_Syntax_Syntax.Tm_constant + d) -> let uu___ = FStar_Const.eq_const c d in equal_iff uu___ + | (FStar_Syntax_Syntax.Tm_uvar (u1, ([], uu___)), + FStar_Syntax_Syntax.Tm_uvar (u2, ([], uu___1))) -> + let uu___2 = + FStar_Syntax_Unionfind.equiv + u1.FStar_Syntax_Syntax.ctx_uvar_head + u2.FStar_Syntax_Syntax.ctx_uvar_head in + equal_if uu___2 + | (FStar_Syntax_Syntax.Tm_app + { FStar_Syntax_Syntax.hd = h1; FStar_Syntax_Syntax.args = args1;_}, + FStar_Syntax_Syntax.Tm_app + { FStar_Syntax_Syntax.hd = h2; FStar_Syntax_Syntax.args = args2;_}) + -> + let uu___ = + let uu___1 = + let uu___2 = FStar_Syntax_Util.un_uinst h1 in + uu___2.FStar_Syntax_Syntax.n in + let uu___2 = + let uu___3 = FStar_Syntax_Util.un_uinst h2 in + uu___3.FStar_Syntax_Syntax.n in + (uu___1, uu___2) in + (match uu___ with + | (FStar_Syntax_Syntax.Tm_fvar f1, FStar_Syntax_Syntax.Tm_fvar + f2) when + (FStar_Syntax_Syntax.fv_eq f1 f2) && + (let uu___1 = + let uu___2 = FStar_Syntax_Syntax.lid_of_fv f1 in + FStar_Ident.string_of_lid uu___2 in + FStar_Compiler_List.mem uu___1 injectives) + -> equal_data f1 args1 f2 args2 + | uu___1 -> + let uu___2 = eq_tm1 h1 h2 in + eq_and uu___2 (fun uu___3 -> eq_args env args1 args2)) + | (FStar_Syntax_Syntax.Tm_match + { FStar_Syntax_Syntax.scrutinee = t13; + FStar_Syntax_Syntax.ret_opt = uu___; + FStar_Syntax_Syntax.brs = bs1; + FStar_Syntax_Syntax.rc_opt1 = uu___1;_}, + FStar_Syntax_Syntax.Tm_match + { FStar_Syntax_Syntax.scrutinee = t23; + FStar_Syntax_Syntax.ret_opt = uu___2; + FStar_Syntax_Syntax.brs = bs2; + FStar_Syntax_Syntax.rc_opt1 = uu___3;_}) + -> + if + (FStar_Compiler_List.length bs1) = + (FStar_Compiler_List.length bs2) + then + let uu___4 = FStar_Compiler_List.zip bs1 bs2 in + let uu___5 = eq_tm1 t13 t23 in + FStar_Compiler_List.fold_right + (fun uu___6 -> + fun a -> + match uu___6 with + | (b1, b2) -> + eq_and a (fun uu___7 -> branch_matches env b1 b2)) + uu___4 uu___5 + else Unknown + | (FStar_Syntax_Syntax.Tm_type u, FStar_Syntax_Syntax.Tm_type v) -> + let uu___ = FStar_Syntax_Util.eq_univs u v in equal_if uu___ + | (FStar_Syntax_Syntax.Tm_quoted (t13, q1), + FStar_Syntax_Syntax.Tm_quoted (t23, q2)) -> Unknown + | (FStar_Syntax_Syntax.Tm_refine + { FStar_Syntax_Syntax.b = t13; FStar_Syntax_Syntax.phi = phi1;_}, + FStar_Syntax_Syntax.Tm_refine + { FStar_Syntax_Syntax.b = t23; FStar_Syntax_Syntax.phi = phi2;_}) + -> + let uu___ = + eq_tm1 t13.FStar_Syntax_Syntax.sort + t23.FStar_Syntax_Syntax.sort in + eq_and uu___ (fun uu___1 -> eq_tm1 phi1 phi2) + | (FStar_Syntax_Syntax.Tm_abs + { FStar_Syntax_Syntax.bs = bs1; FStar_Syntax_Syntax.body = body1; + FStar_Syntax_Syntax.rc_opt = uu___;_}, + FStar_Syntax_Syntax.Tm_abs + { FStar_Syntax_Syntax.bs = bs2; FStar_Syntax_Syntax.body = body2; + FStar_Syntax_Syntax.rc_opt = uu___1;_}) + when + (FStar_Compiler_List.length bs1) = + (FStar_Compiler_List.length bs2) + -> + let uu___2 = + FStar_Compiler_List.fold_left2 + (fun r -> + fun b1 -> + fun b2 -> + eq_and r + (fun uu___3 -> + eq_tm1 + (b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort + (b2.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort)) + Equal bs1 bs2 in + eq_and uu___2 (fun uu___3 -> eq_tm1 body1 body2) + | (FStar_Syntax_Syntax.Tm_arrow + { FStar_Syntax_Syntax.bs1 = bs1; FStar_Syntax_Syntax.comp = c1;_}, + FStar_Syntax_Syntax.Tm_arrow + { FStar_Syntax_Syntax.bs1 = bs2; FStar_Syntax_Syntax.comp = c2;_}) + when + (FStar_Compiler_List.length bs1) = + (FStar_Compiler_List.length bs2) + -> + let uu___ = + FStar_Compiler_List.fold_left2 + (fun r -> + fun b1 -> + fun b2 -> + eq_and r + (fun uu___1 -> + eq_tm1 + (b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort + (b2.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort)) + Equal bs1 bs2 in + eq_and uu___ (fun uu___1 -> eq_comp env c1 c2) + | uu___ -> Unknown +and (eq_antiquotations : + FStar_TypeChecker_Env.env_t -> + FStar_Syntax_Syntax.term Prims.list -> + FStar_Syntax_Syntax.term Prims.list -> eq_result) + = + fun env -> + fun a1 -> + fun a2 -> + match (a1, a2) with + | ([], []) -> Equal + | ([], uu___) -> NotEqual + | (uu___, []) -> NotEqual + | (t1::a11, t2::a21) -> + let uu___ = eq_tm env t1 t2 in + (match uu___ with + | NotEqual -> NotEqual + | Unknown -> + let uu___1 = eq_antiquotations env a11 a21 in + (match uu___1 with + | NotEqual -> NotEqual + | uu___2 -> Unknown) + | Equal -> eq_antiquotations env a11 a21) +and (branch_matches : + FStar_TypeChecker_Env.env_t -> + (FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t * + FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax + FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term' + FStar_Syntax_Syntax.syntax) -> + (FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t * + FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax + FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term' + FStar_Syntax_Syntax.syntax) -> eq_result) + = + fun env -> + fun b1 -> + fun b2 -> + let related_by f o1 o2 = + match (o1, o2) with + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> + true + | (FStar_Pervasives_Native.Some x, FStar_Pervasives_Native.Some y) + -> f x y + | (uu___, uu___1) -> false in + let uu___ = b1 in + match uu___ with + | (p1, w1, t1) -> + let uu___1 = b2 in + (match uu___1 with + | (p2, w2, t2) -> + let uu___2 = FStar_Syntax_Syntax.eq_pat p1 p2 in + if uu___2 + then + let uu___3 = + (let uu___4 = eq_tm env t1 t2 in uu___4 = Equal) && + (related_by + (fun t11 -> + fun t21 -> + let uu___4 = eq_tm env t11 t21 in + uu___4 = Equal) w1 w2) in + (if uu___3 then Equal else Unknown) + else Unknown) +and (eq_args : + FStar_TypeChecker_Env.env_t -> + FStar_Syntax_Syntax.args -> FStar_Syntax_Syntax.args -> eq_result) + = + fun env -> + fun a1 -> + fun a2 -> + match (a1, a2) with + | ([], []) -> Equal + | ((a, uu___)::a11, (b, uu___1)::b1) -> + let uu___2 = eq_tm env a b in + (match uu___2 with + | Equal -> eq_args env a11 b1 + | uu___3 -> Unknown) + | uu___ -> Unknown +and (eq_comp : + FStar_TypeChecker_Env.env_t -> + FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp -> eq_result) + = + fun env -> + fun c1 -> + fun c2 -> + match ((c1.FStar_Syntax_Syntax.n), (c2.FStar_Syntax_Syntax.n)) with + | (FStar_Syntax_Syntax.Total t1, FStar_Syntax_Syntax.Total t2) -> + eq_tm env t1 t2 + | (FStar_Syntax_Syntax.GTotal t1, FStar_Syntax_Syntax.GTotal t2) -> + eq_tm env t1 t2 + | (FStar_Syntax_Syntax.Comp ct1, FStar_Syntax_Syntax.Comp ct2) -> + let uu___ = + let uu___1 = + FStar_Syntax_Util.eq_univs_list + ct1.FStar_Syntax_Syntax.comp_univs + ct2.FStar_Syntax_Syntax.comp_univs in + equal_if uu___1 in + eq_and uu___ + (fun uu___1 -> + let uu___2 = + let uu___3 = + FStar_Ident.lid_equals + ct1.FStar_Syntax_Syntax.effect_name + ct2.FStar_Syntax_Syntax.effect_name in + equal_if uu___3 in + eq_and uu___2 + (fun uu___3 -> + let uu___4 = + eq_tm env ct1.FStar_Syntax_Syntax.result_typ + ct2.FStar_Syntax_Syntax.result_typ in + eq_and uu___4 + (fun uu___5 -> + eq_args env ct1.FStar_Syntax_Syntax.effect_args + ct2.FStar_Syntax_Syntax.effect_args))) + | uu___ -> NotEqual +let (eq_tm_bool : + FStar_TypeChecker_Env.env_t -> + FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> Prims.bool) + = fun e -> fun t1 -> fun t2 -> let uu___ = eq_tm e t1 t2 in uu___ = Equal +let (simplify : + Prims.bool -> + FStar_TypeChecker_Env.env_t -> + FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) + = + fun debug -> + fun env -> + fun tm -> + let w t = + { + FStar_Syntax_Syntax.n = (t.FStar_Syntax_Syntax.n); + FStar_Syntax_Syntax.pos = (tm.FStar_Syntax_Syntax.pos); + FStar_Syntax_Syntax.vars = (t.FStar_Syntax_Syntax.vars); + FStar_Syntax_Syntax.hash_code = (t.FStar_Syntax_Syntax.hash_code) + } in + let simp_t t = + let uu___ = + let uu___1 = FStar_Syntax_Util.unmeta t in + uu___1.FStar_Syntax_Syntax.n in + match uu___ with + | FStar_Syntax_Syntax.Tm_fvar fv when + FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.true_lid -> + FStar_Pervasives_Native.Some true + | FStar_Syntax_Syntax.Tm_fvar fv when + FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.false_lid + -> FStar_Pervasives_Native.Some false + | uu___1 -> FStar_Pervasives_Native.None in + let rec args_are_binders args bs = + match (args, bs) with + | ((t, uu___)::args1, b::bs1) -> + let uu___1 = + let uu___2 = FStar_Syntax_Subst.compress t in + uu___2.FStar_Syntax_Syntax.n in + (match uu___1 with + | FStar_Syntax_Syntax.Tm_name bv' -> + (FStar_Syntax_Syntax.bv_eq b.FStar_Syntax_Syntax.binder_bv + bv') + && (args_are_binders args1 bs1) + | uu___2 -> false) + | ([], []) -> true + | (uu___, uu___1) -> false in + let is_applied bs t = + if debug + then + (let uu___1 = FStar_Syntax_Print.term_to_string t in + let uu___2 = FStar_Syntax_Print.tag_of_term t in + FStar_Compiler_Util.print2 "WPE> is_applied %s -- %s\n" uu___1 + uu___2) + else (); + (let uu___1 = FStar_Syntax_Util.head_and_args_full t in + match uu___1 with + | (hd, args) -> + let uu___2 = + let uu___3 = FStar_Syntax_Subst.compress hd in + uu___3.FStar_Syntax_Syntax.n in + (match uu___2 with + | FStar_Syntax_Syntax.Tm_name bv when + args_are_binders args bs -> + (if debug + then + (let uu___4 = FStar_Syntax_Print.term_to_string t in + let uu___5 = FStar_Syntax_Print.bv_to_string bv in + let uu___6 = FStar_Syntax_Print.term_to_string hd in + FStar_Compiler_Util.print3 + "WPE> got it\n>>>>top = %s\n>>>>b = %s\n>>>>hd = %s\n" + uu___4 uu___5 uu___6) + else (); + FStar_Pervasives_Native.Some bv) + | uu___3 -> FStar_Pervasives_Native.None)) in + let is_applied_maybe_squashed bs t = + if debug + then + (let uu___1 = FStar_Syntax_Print.term_to_string t in + let uu___2 = FStar_Syntax_Print.tag_of_term t in + FStar_Compiler_Util.print2 + "WPE> is_applied_maybe_squashed %s -- %s\n" uu___1 uu___2) + else (); + (let uu___1 = FStar_Syntax_Util.is_squash t in + match uu___1 with + | FStar_Pervasives_Native.Some (uu___2, t') -> is_applied bs t' + | uu___2 -> + let uu___3 = FStar_Syntax_Util.is_auto_squash t in + (match uu___3 with + | FStar_Pervasives_Native.Some (uu___4, t') -> + is_applied bs t' + | uu___4 -> is_applied bs t)) in + let is_const_match phi = + let uu___ = + let uu___1 = FStar_Syntax_Subst.compress phi in + uu___1.FStar_Syntax_Syntax.n in + match uu___ with + | FStar_Syntax_Syntax.Tm_match + { FStar_Syntax_Syntax.scrutinee = uu___1; + FStar_Syntax_Syntax.ret_opt = uu___2; + FStar_Syntax_Syntax.brs = br::brs; + FStar_Syntax_Syntax.rc_opt1 = uu___3;_} + -> + let uu___4 = br in + (match uu___4 with + | (uu___5, uu___6, e) -> + let r = + let uu___7 = simp_t e in + match uu___7 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some b -> + let uu___8 = + FStar_Compiler_List.for_all + (fun uu___9 -> + match uu___9 with + | (uu___10, uu___11, e') -> + let uu___12 = simp_t e' in + uu___12 = + (FStar_Pervasives_Native.Some b)) brs in + if uu___8 + then FStar_Pervasives_Native.Some b + else FStar_Pervasives_Native.None in + r) + | uu___1 -> FStar_Pervasives_Native.None in + let maybe_auto_squash t = + let uu___ = FStar_Syntax_Util.is_sub_singleton t in + if uu___ + then t + else FStar_Syntax_Util.mk_auto_squash FStar_Syntax_Syntax.U_zero t in + let squashed_head_un_auto_squash_args t = + let maybe_un_auto_squash_arg uu___ = + match uu___ with + | (t1, q) -> + let uu___1 = FStar_Syntax_Util.is_auto_squash t1 in + (match uu___1 with + | FStar_Pervasives_Native.Some + (FStar_Syntax_Syntax.U_zero, t2) -> (t2, q) + | uu___2 -> (t1, q)) in + let uu___ = FStar_Syntax_Util.head_and_args t in + match uu___ with + | (head, args) -> + let args1 = + FStar_Compiler_List.map maybe_un_auto_squash_arg args in + FStar_Syntax_Syntax.mk_Tm_app head args1 + t.FStar_Syntax_Syntax.pos in + let rec clearly_inhabited ty = + let uu___ = + let uu___1 = FStar_Syntax_Util.unmeta ty in + uu___1.FStar_Syntax_Syntax.n in + match uu___ with + | FStar_Syntax_Syntax.Tm_uinst (t, uu___1) -> clearly_inhabited t + | FStar_Syntax_Syntax.Tm_arrow + { FStar_Syntax_Syntax.bs1 = uu___1; + FStar_Syntax_Syntax.comp = c;_} + -> clearly_inhabited (FStar_Syntax_Util.comp_result c) + | FStar_Syntax_Syntax.Tm_fvar fv -> + let l = FStar_Syntax_Syntax.lid_of_fv fv in + (((FStar_Ident.lid_equals l FStar_Parser_Const.int_lid) || + (FStar_Ident.lid_equals l FStar_Parser_Const.bool_lid)) + || (FStar_Ident.lid_equals l FStar_Parser_Const.string_lid)) + || (FStar_Ident.lid_equals l FStar_Parser_Const.exn_lid) + | uu___1 -> false in + let simplify1 arg = + let uu___ = simp_t (FStar_Pervasives_Native.fst arg) in + (uu___, arg) in + let uu___ = + let uu___1 = FStar_Syntax_Subst.compress tm in + uu___1.FStar_Syntax_Syntax.n in + match uu___ with + | FStar_Syntax_Syntax.Tm_app + { + FStar_Syntax_Syntax.hd = + { + FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_uinst + ({ + FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; + FStar_Syntax_Syntax.pos = uu___1; + FStar_Syntax_Syntax.vars = uu___2; + FStar_Syntax_Syntax.hash_code = uu___3;_}, + uu___4); + FStar_Syntax_Syntax.pos = uu___5; + FStar_Syntax_Syntax.vars = uu___6; + FStar_Syntax_Syntax.hash_code = uu___7;_}; + FStar_Syntax_Syntax.args = args;_} + -> + let uu___8 = + FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.and_lid in + if uu___8 + then + let uu___9 = FStar_Compiler_List.map simplify1 args in + (match uu___9 with + | (FStar_Pervasives_Native.Some (true), uu___10)::(uu___11, + (arg, + uu___12))::[] + -> maybe_auto_squash arg + | (uu___10, (arg, uu___11))::(FStar_Pervasives_Native.Some + (true), uu___12)::[] + -> maybe_auto_squash arg + | (FStar_Pervasives_Native.Some (false), uu___10)::uu___11::[] + -> w FStar_Syntax_Util.t_false + | uu___10::(FStar_Pervasives_Native.Some (false), uu___11)::[] + -> w FStar_Syntax_Util.t_false + | uu___10 -> squashed_head_un_auto_squash_args tm) + else + (let uu___10 = + FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.or_lid in + if uu___10 + then + let uu___11 = FStar_Compiler_List.map simplify1 args in + match uu___11 with + | (FStar_Pervasives_Native.Some (true), uu___12)::uu___13::[] + -> w FStar_Syntax_Util.t_true + | uu___12::(FStar_Pervasives_Native.Some (true), uu___13)::[] + -> w FStar_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (false), uu___12)::(uu___13, + (arg, + uu___14))::[] + -> maybe_auto_squash arg + | (uu___12, (arg, uu___13))::(FStar_Pervasives_Native.Some + (false), uu___14)::[] + -> maybe_auto_squash arg + | uu___12 -> squashed_head_un_auto_squash_args tm + else + (let uu___12 = + FStar_Syntax_Syntax.fv_eq_lid fv + FStar_Parser_Const.imp_lid in + if uu___12 + then + let uu___13 = FStar_Compiler_List.map simplify1 args in + match uu___13 with + | uu___14::(FStar_Pervasives_Native.Some (true), uu___15)::[] + -> w FStar_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (false), uu___14)::uu___15::[] + -> w FStar_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (true), uu___14):: + (uu___15, (arg, uu___16))::[] -> + maybe_auto_squash arg + | (uu___14, (p, uu___15))::(uu___16, (q, uu___17))::[] -> + let uu___18 = FStar_Syntax_Util.term_eq p q in + (if uu___18 + then w FStar_Syntax_Util.t_true + else squashed_head_un_auto_squash_args tm) + | uu___14 -> squashed_head_un_auto_squash_args tm + else + (let uu___14 = + FStar_Syntax_Syntax.fv_eq_lid fv + FStar_Parser_Const.iff_lid in + if uu___14 + then + let uu___15 = FStar_Compiler_List.map simplify1 args in + match uu___15 with + | (FStar_Pervasives_Native.Some (true), uu___16):: + (FStar_Pervasives_Native.Some (true), uu___17)::[] + -> w FStar_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (false), uu___16):: + (FStar_Pervasives_Native.Some (false), uu___17)::[] + -> w FStar_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (true), uu___16):: + (FStar_Pervasives_Native.Some (false), uu___17)::[] + -> w FStar_Syntax_Util.t_false + | (FStar_Pervasives_Native.Some (false), uu___16):: + (FStar_Pervasives_Native.Some (true), uu___17)::[] + -> w FStar_Syntax_Util.t_false + | (uu___16, (arg, uu___17))::(FStar_Pervasives_Native.Some + (true), uu___18)::[] + -> maybe_auto_squash arg + | (FStar_Pervasives_Native.Some (true), uu___16):: + (uu___17, (arg, uu___18))::[] -> + maybe_auto_squash arg + | (uu___16, (arg, uu___17))::(FStar_Pervasives_Native.Some + (false), uu___18)::[] + -> + let uu___19 = FStar_Syntax_Util.mk_neg arg in + maybe_auto_squash uu___19 + | (FStar_Pervasives_Native.Some (false), uu___16):: + (uu___17, (arg, uu___18))::[] -> + let uu___19 = FStar_Syntax_Util.mk_neg arg in + maybe_auto_squash uu___19 + | (uu___16, (p, uu___17))::(uu___18, (q, uu___19))::[] + -> + let uu___20 = FStar_Syntax_Util.term_eq p q in + (if uu___20 + then w FStar_Syntax_Util.t_true + else squashed_head_un_auto_squash_args tm) + | uu___16 -> squashed_head_un_auto_squash_args tm + else + (let uu___16 = + FStar_Syntax_Syntax.fv_eq_lid fv + FStar_Parser_Const.not_lid in + if uu___16 + then + let uu___17 = + FStar_Compiler_List.map simplify1 args in + match uu___17 with + | (FStar_Pervasives_Native.Some (true), uu___18)::[] + -> w FStar_Syntax_Util.t_false + | (FStar_Pervasives_Native.Some (false), uu___18)::[] + -> w FStar_Syntax_Util.t_true + | uu___18 -> squashed_head_un_auto_squash_args tm + else + (let uu___18 = + FStar_Syntax_Syntax.fv_eq_lid fv + FStar_Parser_Const.forall_lid in + if uu___18 + then + match args with + | (t, uu___19)::[] -> + let uu___20 = + let uu___21 = + FStar_Syntax_Subst.compress t in + uu___21.FStar_Syntax_Syntax.n in + (match uu___20 with + | FStar_Syntax_Syntax.Tm_abs + { FStar_Syntax_Syntax.bs = uu___21::[]; + FStar_Syntax_Syntax.body = body; + FStar_Syntax_Syntax.rc_opt = uu___22;_} + -> + let uu___23 = simp_t body in + (match uu___23 with + | FStar_Pervasives_Native.Some (true) + -> w FStar_Syntax_Util.t_true + | uu___24 -> tm) + | uu___21 -> tm) + | (ty, FStar_Pervasives_Native.Some + { FStar_Syntax_Syntax.aqual_implicit = true; + FStar_Syntax_Syntax.aqual_attributes = + uu___19;_})::(t, uu___20)::[] + -> + let uu___21 = + let uu___22 = + FStar_Syntax_Subst.compress t in + uu___22.FStar_Syntax_Syntax.n in + (match uu___21 with + | FStar_Syntax_Syntax.Tm_abs + { FStar_Syntax_Syntax.bs = uu___22::[]; + FStar_Syntax_Syntax.body = body; + FStar_Syntax_Syntax.rc_opt = uu___23;_} + -> + let uu___24 = simp_t body in + (match uu___24 with + | FStar_Pervasives_Native.Some (true) + -> w FStar_Syntax_Util.t_true + | FStar_Pervasives_Native.Some (false) + when clearly_inhabited ty -> + w FStar_Syntax_Util.t_false + | uu___25 -> tm) + | uu___22 -> tm) + | uu___19 -> tm + else + (let uu___20 = + FStar_Syntax_Syntax.fv_eq_lid fv + FStar_Parser_Const.exists_lid in + if uu___20 + then + match args with + | (t, uu___21)::[] -> + let uu___22 = + let uu___23 = + FStar_Syntax_Subst.compress t in + uu___23.FStar_Syntax_Syntax.n in + (match uu___22 with + | FStar_Syntax_Syntax.Tm_abs + { + FStar_Syntax_Syntax.bs = + uu___23::[]; + FStar_Syntax_Syntax.body = body; + FStar_Syntax_Syntax.rc_opt = + uu___24;_} + -> + let uu___25 = simp_t body in + (match uu___25 with + | FStar_Pervasives_Native.Some + (false) -> + w FStar_Syntax_Util.t_false + | uu___26 -> tm) + | uu___23 -> tm) + | (ty, FStar_Pervasives_Native.Some + { + FStar_Syntax_Syntax.aqual_implicit = + true; + FStar_Syntax_Syntax.aqual_attributes = + uu___21;_})::(t, uu___22)::[] + -> + let uu___23 = + let uu___24 = + FStar_Syntax_Subst.compress t in + uu___24.FStar_Syntax_Syntax.n in + (match uu___23 with + | FStar_Syntax_Syntax.Tm_abs + { + FStar_Syntax_Syntax.bs = + uu___24::[]; + FStar_Syntax_Syntax.body = body; + FStar_Syntax_Syntax.rc_opt = + uu___25;_} + -> + let uu___26 = simp_t body in + (match uu___26 with + | FStar_Pervasives_Native.Some + (false) -> + w FStar_Syntax_Util.t_false + | FStar_Pervasives_Native.Some + (true) when + clearly_inhabited ty -> + w FStar_Syntax_Util.t_true + | uu___27 -> tm) + | uu___24 -> tm) + | uu___21 -> tm + else + (let uu___22 = + FStar_Syntax_Syntax.fv_eq_lid fv + FStar_Parser_Const.b2t_lid in + if uu___22 + then + match args with + | ({ + FStar_Syntax_Syntax.n = + FStar_Syntax_Syntax.Tm_constant + (FStar_Const.Const_bool (true)); + FStar_Syntax_Syntax.pos = uu___23; + FStar_Syntax_Syntax.vars = uu___24; + FStar_Syntax_Syntax.hash_code = + uu___25;_}, + uu___26)::[] -> + w FStar_Syntax_Util.t_true + | ({ + FStar_Syntax_Syntax.n = + FStar_Syntax_Syntax.Tm_constant + (FStar_Const.Const_bool (false)); + FStar_Syntax_Syntax.pos = uu___23; + FStar_Syntax_Syntax.vars = uu___24; + FStar_Syntax_Syntax.hash_code = + uu___25;_}, + uu___26)::[] -> + w FStar_Syntax_Util.t_false + | uu___23 -> tm + else + (let uu___24 = + FStar_Syntax_Syntax.fv_eq_lid fv + FStar_Parser_Const.haseq_lid in + if uu___24 + then + let t_has_eq_for_sure t = + let haseq_lids = + [FStar_Parser_Const.int_lid; + FStar_Parser_Const.bool_lid; + FStar_Parser_Const.unit_lid; + FStar_Parser_Const.string_lid] in + let uu___25 = + let uu___26 = + FStar_Syntax_Subst.compress t in + uu___26.FStar_Syntax_Syntax.n in + match uu___25 with + | FStar_Syntax_Syntax.Tm_fvar fv1 + when + FStar_Compiler_List.existsb + (fun l -> + FStar_Syntax_Syntax.fv_eq_lid + fv1 l) haseq_lids + -> true + | uu___26 -> false in + (if + (FStar_Compiler_List.length args) = + Prims.int_one + then + let t = + let uu___25 = + FStar_Compiler_List.hd args in + FStar_Pervasives_Native.fst + uu___25 in + let uu___25 = t_has_eq_for_sure t in + (if uu___25 + then w FStar_Syntax_Util.t_true + else + (let uu___27 = + let uu___28 = + FStar_Syntax_Subst.compress + t in + uu___28.FStar_Syntax_Syntax.n in + match uu___27 with + | FStar_Syntax_Syntax.Tm_refine + uu___28 -> + let t1 = + FStar_Syntax_Util.unrefine + t in + let uu___29 = + t_has_eq_for_sure t1 in + if uu___29 + then + w FStar_Syntax_Util.t_true + else + (let haseq_tm = + let uu___31 = + let uu___32 = + FStar_Syntax_Subst.compress + tm in + uu___32.FStar_Syntax_Syntax.n in + match uu___31 with + | FStar_Syntax_Syntax.Tm_app + { + FStar_Syntax_Syntax.hd + = hd; + FStar_Syntax_Syntax.args + = uu___32;_} + -> hd + | uu___32 -> + FStar_Compiler_Effect.failwith + "Impossible! We have already checked that this is a Tm_app" in + let uu___31 = + let uu___32 = + FStar_Syntax_Syntax.as_arg + t1 in + [uu___32] in + FStar_Syntax_Util.mk_app + haseq_tm uu___31) + | uu___28 -> tm)) + else tm) + else + (let uu___26 = + FStar_Syntax_Syntax.fv_eq_lid fv + FStar_Parser_Const.eq2_lid in + if uu___26 + then + match args with + | (_typ, uu___27)::(a1, uu___28):: + (a2, uu___29)::[] -> + let uu___30 = eq_tm env a1 a2 in + (match uu___30 with + | Equal -> + w FStar_Syntax_Util.t_true + | NotEqual -> + w FStar_Syntax_Util.t_false + | uu___31 -> tm) + | uu___27 -> tm + else + (let uu___28 = + FStar_Syntax_Util.is_auto_squash + tm in + match uu___28 with + | FStar_Pervasives_Native.Some + (FStar_Syntax_Syntax.U_zero, t) + when + FStar_Syntax_Util.is_sub_singleton + t + -> t + | uu___29 -> tm)))))))))) + | FStar_Syntax_Syntax.Tm_app + { + FStar_Syntax_Syntax.hd = + { FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; + FStar_Syntax_Syntax.pos = uu___1; + FStar_Syntax_Syntax.vars = uu___2; + FStar_Syntax_Syntax.hash_code = uu___3;_}; + FStar_Syntax_Syntax.args = args;_} + -> + let uu___4 = + FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.and_lid in + if uu___4 + then + let uu___5 = FStar_Compiler_List.map simplify1 args in + (match uu___5 with + | (FStar_Pervasives_Native.Some (true), uu___6)::(uu___7, + (arg, + uu___8))::[] + -> maybe_auto_squash arg + | (uu___6, (arg, uu___7))::(FStar_Pervasives_Native.Some + (true), uu___8)::[] + -> maybe_auto_squash arg + | (FStar_Pervasives_Native.Some (false), uu___6)::uu___7::[] + -> w FStar_Syntax_Util.t_false + | uu___6::(FStar_Pervasives_Native.Some (false), uu___7)::[] + -> w FStar_Syntax_Util.t_false + | uu___6 -> squashed_head_un_auto_squash_args tm) + else + (let uu___6 = + FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.or_lid in + if uu___6 + then + let uu___7 = FStar_Compiler_List.map simplify1 args in + match uu___7 with + | (FStar_Pervasives_Native.Some (true), uu___8)::uu___9::[] + -> w FStar_Syntax_Util.t_true + | uu___8::(FStar_Pervasives_Native.Some (true), uu___9)::[] + -> w FStar_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (false), uu___8)::(uu___9, + (arg, + uu___10))::[] + -> maybe_auto_squash arg + | (uu___8, (arg, uu___9))::(FStar_Pervasives_Native.Some + (false), uu___10)::[] + -> maybe_auto_squash arg + | uu___8 -> squashed_head_un_auto_squash_args tm + else + (let uu___8 = + FStar_Syntax_Syntax.fv_eq_lid fv + FStar_Parser_Const.imp_lid in + if uu___8 + then + let uu___9 = FStar_Compiler_List.map simplify1 args in + match uu___9 with + | uu___10::(FStar_Pervasives_Native.Some (true), uu___11)::[] + -> w FStar_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (false), uu___10)::uu___11::[] + -> w FStar_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (true), uu___10):: + (uu___11, (arg, uu___12))::[] -> + maybe_auto_squash arg + | (uu___10, (p, uu___11))::(uu___12, (q, uu___13))::[] -> + let uu___14 = FStar_Syntax_Util.term_eq p q in + (if uu___14 + then w FStar_Syntax_Util.t_true + else squashed_head_un_auto_squash_args tm) + | uu___10 -> squashed_head_un_auto_squash_args tm + else + (let uu___10 = + FStar_Syntax_Syntax.fv_eq_lid fv + FStar_Parser_Const.iff_lid in + if uu___10 + then + let uu___11 = FStar_Compiler_List.map simplify1 args in + match uu___11 with + | (FStar_Pervasives_Native.Some (true), uu___12):: + (FStar_Pervasives_Native.Some (true), uu___13)::[] + -> w FStar_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (false), uu___12):: + (FStar_Pervasives_Native.Some (false), uu___13)::[] + -> w FStar_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (true), uu___12):: + (FStar_Pervasives_Native.Some (false), uu___13)::[] + -> w FStar_Syntax_Util.t_false + | (FStar_Pervasives_Native.Some (false), uu___12):: + (FStar_Pervasives_Native.Some (true), uu___13)::[] + -> w FStar_Syntax_Util.t_false + | (uu___12, (arg, uu___13))::(FStar_Pervasives_Native.Some + (true), uu___14)::[] + -> maybe_auto_squash arg + | (FStar_Pervasives_Native.Some (true), uu___12):: + (uu___13, (arg, uu___14))::[] -> + maybe_auto_squash arg + | (uu___12, (arg, uu___13))::(FStar_Pervasives_Native.Some + (false), uu___14)::[] + -> + let uu___15 = FStar_Syntax_Util.mk_neg arg in + maybe_auto_squash uu___15 + | (FStar_Pervasives_Native.Some (false), uu___12):: + (uu___13, (arg, uu___14))::[] -> + let uu___15 = FStar_Syntax_Util.mk_neg arg in + maybe_auto_squash uu___15 + | (uu___12, (p, uu___13))::(uu___14, (q, uu___15))::[] + -> + let uu___16 = FStar_Syntax_Util.term_eq p q in + (if uu___16 + then w FStar_Syntax_Util.t_true + else squashed_head_un_auto_squash_args tm) + | uu___12 -> squashed_head_un_auto_squash_args tm + else + (let uu___12 = + FStar_Syntax_Syntax.fv_eq_lid fv + FStar_Parser_Const.not_lid in + if uu___12 + then + let uu___13 = + FStar_Compiler_List.map simplify1 args in + match uu___13 with + | (FStar_Pervasives_Native.Some (true), uu___14)::[] + -> w FStar_Syntax_Util.t_false + | (FStar_Pervasives_Native.Some (false), uu___14)::[] + -> w FStar_Syntax_Util.t_true + | uu___14 -> squashed_head_un_auto_squash_args tm + else + (let uu___14 = + FStar_Syntax_Syntax.fv_eq_lid fv + FStar_Parser_Const.forall_lid in + if uu___14 + then + match args with + | (t, uu___15)::[] -> + let uu___16 = + let uu___17 = + FStar_Syntax_Subst.compress t in + uu___17.FStar_Syntax_Syntax.n in + (match uu___16 with + | FStar_Syntax_Syntax.Tm_abs + { FStar_Syntax_Syntax.bs = uu___17::[]; + FStar_Syntax_Syntax.body = body; + FStar_Syntax_Syntax.rc_opt = uu___18;_} + -> + let uu___19 = simp_t body in + (match uu___19 with + | FStar_Pervasives_Native.Some (true) + -> w FStar_Syntax_Util.t_true + | uu___20 -> tm) + | uu___17 -> tm) + | (ty, FStar_Pervasives_Native.Some + { FStar_Syntax_Syntax.aqual_implicit = true; + FStar_Syntax_Syntax.aqual_attributes = + uu___15;_})::(t, uu___16)::[] + -> + let uu___17 = + let uu___18 = + FStar_Syntax_Subst.compress t in + uu___18.FStar_Syntax_Syntax.n in + (match uu___17 with + | FStar_Syntax_Syntax.Tm_abs + { FStar_Syntax_Syntax.bs = uu___18::[]; + FStar_Syntax_Syntax.body = body; + FStar_Syntax_Syntax.rc_opt = uu___19;_} + -> + let uu___20 = simp_t body in + (match uu___20 with + | FStar_Pervasives_Native.Some (true) + -> w FStar_Syntax_Util.t_true + | FStar_Pervasives_Native.Some (false) + when clearly_inhabited ty -> + w FStar_Syntax_Util.t_false + | uu___21 -> tm) + | uu___18 -> tm) + | uu___15 -> tm + else + (let uu___16 = + FStar_Syntax_Syntax.fv_eq_lid fv + FStar_Parser_Const.exists_lid in + if uu___16 + then + match args with + | (t, uu___17)::[] -> + let uu___18 = + let uu___19 = + FStar_Syntax_Subst.compress t in + uu___19.FStar_Syntax_Syntax.n in + (match uu___18 with + | FStar_Syntax_Syntax.Tm_abs + { + FStar_Syntax_Syntax.bs = + uu___19::[]; + FStar_Syntax_Syntax.body = body; + FStar_Syntax_Syntax.rc_opt = + uu___20;_} + -> + let uu___21 = simp_t body in + (match uu___21 with + | FStar_Pervasives_Native.Some + (false) -> + w FStar_Syntax_Util.t_false + | uu___22 -> tm) + | uu___19 -> tm) + | (ty, FStar_Pervasives_Native.Some + { + FStar_Syntax_Syntax.aqual_implicit = + true; + FStar_Syntax_Syntax.aqual_attributes = + uu___17;_})::(t, uu___18)::[] + -> + let uu___19 = + let uu___20 = + FStar_Syntax_Subst.compress t in + uu___20.FStar_Syntax_Syntax.n in + (match uu___19 with + | FStar_Syntax_Syntax.Tm_abs + { + FStar_Syntax_Syntax.bs = + uu___20::[]; + FStar_Syntax_Syntax.body = body; + FStar_Syntax_Syntax.rc_opt = + uu___21;_} + -> + let uu___22 = simp_t body in + (match uu___22 with + | FStar_Pervasives_Native.Some + (false) -> + w FStar_Syntax_Util.t_false + | FStar_Pervasives_Native.Some + (true) when + clearly_inhabited ty -> + w FStar_Syntax_Util.t_true + | uu___23 -> tm) + | uu___20 -> tm) + | uu___17 -> tm + else + (let uu___18 = + FStar_Syntax_Syntax.fv_eq_lid fv + FStar_Parser_Const.b2t_lid in + if uu___18 + then + match args with + | ({ + FStar_Syntax_Syntax.n = + FStar_Syntax_Syntax.Tm_constant + (FStar_Const.Const_bool (true)); + FStar_Syntax_Syntax.pos = uu___19; + FStar_Syntax_Syntax.vars = uu___20; + FStar_Syntax_Syntax.hash_code = + uu___21;_}, + uu___22)::[] -> + w FStar_Syntax_Util.t_true + | ({ + FStar_Syntax_Syntax.n = + FStar_Syntax_Syntax.Tm_constant + (FStar_Const.Const_bool (false)); + FStar_Syntax_Syntax.pos = uu___19; + FStar_Syntax_Syntax.vars = uu___20; + FStar_Syntax_Syntax.hash_code = + uu___21;_}, + uu___22)::[] -> + w FStar_Syntax_Util.t_false + | uu___19 -> tm + else + (let uu___20 = + FStar_Syntax_Syntax.fv_eq_lid fv + FStar_Parser_Const.haseq_lid in + if uu___20 + then + let t_has_eq_for_sure t = + let haseq_lids = + [FStar_Parser_Const.int_lid; + FStar_Parser_Const.bool_lid; + FStar_Parser_Const.unit_lid; + FStar_Parser_Const.string_lid] in + let uu___21 = + let uu___22 = + FStar_Syntax_Subst.compress t in + uu___22.FStar_Syntax_Syntax.n in + match uu___21 with + | FStar_Syntax_Syntax.Tm_fvar fv1 + when + FStar_Compiler_List.existsb + (fun l -> + FStar_Syntax_Syntax.fv_eq_lid + fv1 l) haseq_lids + -> true + | uu___22 -> false in + (if + (FStar_Compiler_List.length args) = + Prims.int_one + then + let t = + let uu___21 = + FStar_Compiler_List.hd args in + FStar_Pervasives_Native.fst + uu___21 in + let uu___21 = t_has_eq_for_sure t in + (if uu___21 + then w FStar_Syntax_Util.t_true + else + (let uu___23 = + let uu___24 = + FStar_Syntax_Subst.compress + t in + uu___24.FStar_Syntax_Syntax.n in + match uu___23 with + | FStar_Syntax_Syntax.Tm_refine + uu___24 -> + let t1 = + FStar_Syntax_Util.unrefine + t in + let uu___25 = + t_has_eq_for_sure t1 in + if uu___25 + then + w FStar_Syntax_Util.t_true + else + (let haseq_tm = + let uu___27 = + let uu___28 = + FStar_Syntax_Subst.compress + tm in + uu___28.FStar_Syntax_Syntax.n in + match uu___27 with + | FStar_Syntax_Syntax.Tm_app + { + FStar_Syntax_Syntax.hd + = hd; + FStar_Syntax_Syntax.args + = uu___28;_} + -> hd + | uu___28 -> + FStar_Compiler_Effect.failwith + "Impossible! We have already checked that this is a Tm_app" in + let uu___27 = + let uu___28 = + FStar_Syntax_Syntax.as_arg + t1 in + [uu___28] in + FStar_Syntax_Util.mk_app + haseq_tm uu___27) + | uu___24 -> tm)) + else tm) + else + (let uu___22 = + FStar_Syntax_Syntax.fv_eq_lid fv + FStar_Parser_Const.eq2_lid in + if uu___22 + then + match args with + | (_typ, uu___23)::(a1, uu___24):: + (a2, uu___25)::[] -> + let uu___26 = eq_tm env a1 a2 in + (match uu___26 with + | Equal -> + w FStar_Syntax_Util.t_true + | NotEqual -> + w FStar_Syntax_Util.t_false + | uu___27 -> tm) + | uu___23 -> tm + else + (let uu___24 = + FStar_Syntax_Util.is_auto_squash + tm in + match uu___24 with + | FStar_Pervasives_Native.Some + (FStar_Syntax_Syntax.U_zero, t) + when + FStar_Syntax_Util.is_sub_singleton + t + -> t + | uu___25 -> tm)))))))))) + | FStar_Syntax_Syntax.Tm_refine + { FStar_Syntax_Syntax.b = bv; FStar_Syntax_Syntax.phi = t;_} -> + let uu___1 = simp_t t in + (match uu___1 with + | FStar_Pervasives_Native.Some (true) -> + bv.FStar_Syntax_Syntax.sort + | FStar_Pervasives_Native.Some (false) -> tm + | FStar_Pervasives_Native.None -> tm) + | FStar_Syntax_Syntax.Tm_match uu___1 -> + let uu___2 = is_const_match tm in + (match uu___2 with + | FStar_Pervasives_Native.Some (true) -> + w FStar_Syntax_Util.t_true + | FStar_Pervasives_Native.Some (false) -> + w FStar_Syntax_Util.t_false + | FStar_Pervasives_Native.None -> tm) + | uu___1 -> tm \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Util.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Util.ml index 3c638a5388f..58d65c13a78 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Util.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Util.ml @@ -5908,8 +5908,11 @@ let (weaken_result_typ : let set_result_typ c1 = FStar_Syntax_Util.set_result_typ c1 t in let uu___4 = - let uu___5 = FStar_Syntax_Util.eq_tm t res_t in - uu___5 = FStar_Syntax_Util.Equal in + let uu___5 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env + t res_t in + uu___5 = + FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___4 then ((let uu___6 = @@ -6507,11 +6510,9 @@ let (maybe_instantiate : FStar_Syntax_Syntax.binder_positivity = uu___5; FStar_Syntax_Syntax.binder_attrs = uu___6;_} -> (FStar_Compiler_Option.isNone imp) || - (let uu___7 = - FStar_Syntax_Util.eq_bqual imp - (FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.Equality) in - uu___7 = FStar_Syntax_Util.Equal)) formals in + (FStar_Syntax_Util.eq_bqual imp + (FStar_Pervasives_Native.Some + FStar_Syntax_Syntax.Equality))) formals in match uu___2 with | FStar_Pervasives_Native.None -> FStar_Compiler_List.length formals diff --git a/ocaml/fstar-tests/generated/FStar_Tests_Util.ml b/ocaml/fstar-tests/generated/FStar_Tests_Util.ml index 2c8c8f06c83..9dc829fbdca 100644 --- a/ocaml/fstar-tests/generated/FStar_Tests_Util.ml +++ b/ocaml/fstar-tests/generated/FStar_Tests_Util.ml @@ -69,9 +69,8 @@ let rec (term_eq' : fun uu___1 -> match (uu___, uu___1) with | ((a, imp), (b, imp')) -> - (term_eq' a b) && - (let uu___2 = FStar_Syntax_Util.eq_aqual imp imp' in - uu___2 = FStar_Syntax_Util.Equal)) xs ys) in + (term_eq' a b) && (FStar_Syntax_Util.eq_aqual imp imp')) + xs ys) in let comp_eq c d = match ((c.FStar_Syntax_Syntax.n), (d.FStar_Syntax_Syntax.n)) with | (FStar_Syntax_Syntax.Total t, FStar_Syntax_Syntax.Total s) -> diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst index b2f58d850f7..d0b6baf3355 100644 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ b/src/smtencoding/FStar.SMTEncoding.Encode.fst @@ -42,6 +42,7 @@ module SS = FStar.Syntax.Subst module TcUtil = FStar.TypeChecker.Util module UF = FStar.Syntax.Unionfind module U = FStar.Syntax.Util +module TEQ = FStar.TypeChecker.TermEqAndSimplify let norm_before_encoding env t = let steps = [Env.Eager_unfolding; @@ -1408,9 +1409,9 @@ let encode_datacon (is_injective_on_tparams:bool) (env:env_t) (se:sigelt) let head, _ = U.head_and_args t in let t' = norm t in let head', _ = U.head_and_args t' in - match U.eq_tm head head' with - | U.Equal -> None //no progress after whnf - | U.NotEqual -> binder_and_codomain_type t' + match TEQ.eq_tm env.tcenv head head' with + | TEQ.Equal -> None //no progress after whnf + | TEQ.NotEqual -> binder_and_codomain_type t' | _ -> //Did we actually make progress? Be conservative to avoid an infinite loop match (SS.compress head).n with diff --git a/src/syntax/FStar.Syntax.Util.fst b/src/syntax/FStar.Syntax.Util.fst index 3f608f402cf..3b19e04cbe8 100644 --- a/src/syntax/FStar.Syntax.Util.fst +++ b/src/syntax/FStar.Syntax.Util.fst @@ -222,6 +222,10 @@ let rec compare_univs (u1:universe) (u2:universe) : int = let eq_univs u1 u2 = compare_univs u1 u2 = 0 +let eq_univs_list (us:universes) (vs:universes) : bool = + List.length us = List.length vs + && List.forall2 eq_univs us vs + (********************************************************************************) (*********************** Utilities for computation types ************************) (********************************************************************************) @@ -496,313 +500,272 @@ let canon_app t = let hd, args = head_and_args_full (unascribe t) in mk_Tm_app hd args t.pos -(* ---------------------------------------------------------------------- *) -(* Syntactic equality of terms *) -(* ---------------------------------------------------------------------- *) -type eq_result = - | Equal - | NotEqual - | Unknown - -// Functions that we specially treat as injective, to make normalization -// (particularly of decidable equality) better. We should make sure they -// are actually proved to be injective. -let injectives = - ["FStar.Int8.int_to_t"; - "FStar.Int16.int_to_t"; - "FStar.Int32.int_to_t"; - "FStar.Int64.int_to_t"; - "FStar.Int128.int_to_t"; - "FStar.UInt8.uint_to_t"; - "FStar.UInt16.uint_to_t"; - "FStar.UInt32.uint_to_t"; - "FStar.UInt64.uint_to_t"; - "FStar.UInt128.uint_to_t"; - "FStar.SizeT.uint_to_t"; - "FStar.Int8.__int_to_t"; - "FStar.Int16.__int_to_t"; - "FStar.Int32.__int_to_t"; - "FStar.Int64.__int_to_t"; - "FStar.Int128.__int_to_t"; - "FStar.UInt8.__uint_to_t"; - "FStar.UInt16.__uint_to_t"; - "FStar.UInt32.__uint_to_t"; - "FStar.UInt64.__uint_to_t"; - "FStar.UInt128.__uint_to_t"; - "FStar.SizeT.__uint_to_t"; - ] - -// Compose two eq_result injectively, as in a pair -let eq_inj r s = - match r, s with - | Equal, Equal -> Equal - | NotEqual, _ - | _, NotEqual -> NotEqual - | _, _ -> Unknown - -// Promote a bool to eq_result, conservatively. -let equal_if = function - | true -> Equal - | _ -> Unknown - -// Promote a bool to an eq_result, taking a false to bet NotEqual. -// This is only useful for fully decidable equalities. -// Use with care, see note about Const_real below and #2806. -let equal_iff = function - | true -> Equal - | _ -> NotEqual - -// Compose two equality results, NOT assuming a NotEqual implies anything. -// This is useful, e.g., for checking the equality of applications. Consider -// f x ~ g y -// if f=g and x=y then we know these two expressions are equal, but cannot say -// anything when either result is NotEqual or Unknown, hence this returns Unknown -// in most cases. -// The second comparison is thunked for efficiency. -let eq_and r s = - if r = Equal && s () = Equal - then Equal - else Unknown - -(* Precondition: terms are well-typed in a common environment, or this can return false positives *) -let rec eq_tm (t1:term) (t2:term) : eq_result = - let t1 = canon_app t1 in - let t2 = canon_app t2 in - let equal_data (f1:fv) (args1:Syntax.args) (f2:fv) (args2:Syntax.args) = - // we got constructors! we know they are injective and disjoint, so we can do some - // good analysis on them - if fv_eq f1 f2 - then ( - assert (List.length args1 = List.length args2); - List.fold_left (fun acc ((a1, q1), (a2, q2)) -> - //if q1 <> q2 - //then failwith (U.format1 "Arguments of %s mismatch on implicit qualifier\n" - // (Ident.string_of_lid f1.fv_name.v)); - //NS: 05/06/2018 ...this does not always hold - // it's been succeeding because the assert is disabled in the non-debug builds - //assert (q1 = q2); - eq_inj acc (eq_tm a1 a2)) Equal <| List.zip args1 args2 - ) else NotEqual - in - let qual_is_inj = function - | Some Data_ctor - | Some (Record_ctor _) -> true - | _ -> false - in - let heads_and_args_in_case_both_data :option (fv * args * fv * args) = - let head1, args1 = t1 |> unmeta |> head_and_args in - let head2, args2 = t2 |> unmeta |> head_and_args in - match (un_uinst head1).n, (un_uinst head2).n with - | Tm_fvar f, Tm_fvar g when qual_is_inj f.fv_qual && - qual_is_inj g.fv_qual -> Some (f, args1, g, args2) - | _ -> None - in - let t1 = unmeta t1 in - let t2 = unmeta t2 in - match t1.n, t2.n with - // We sometimes compare open terms, as we get alpha-equivalence - // for free. - | Tm_bvar bv1, Tm_bvar bv2 -> - equal_if (bv1.index = bv2.index) - - | Tm_lazy _, _ -> eq_tm (unlazy t1) t2 - | _, Tm_lazy _ -> eq_tm t1 (unlazy t2) - - | Tm_name a, Tm_name b -> - equal_if (bv_eq a b) - - | _ when heads_and_args_in_case_both_data |> is_some -> //matches only when both are data constructors - heads_and_args_in_case_both_data |> must |> (fun (f, args1, g, args2) -> - equal_data f args1 g args2 - ) +// (* ---------------------------------------------------------------------- *) +// (* Syntactic equality of terms *) +// (* ---------------------------------------------------------------------- *) +// type eq_result = +// | Equal +// | NotEqual +// | Unknown + +// // Functions that we specially treat as injective, to make normalization +// // (particularly of decidable equality) better. We should make sure they +// // are actually proved to be injective. +// let injectives = +// ["FStar.Int8.int_to_t"; +// "FStar.Int16.int_to_t"; +// "FStar.Int32.int_to_t"; +// "FStar.Int64.int_to_t"; +// "FStar.Int128.int_to_t"; +// "FStar.UInt8.uint_to_t"; +// "FStar.UInt16.uint_to_t"; +// "FStar.UInt32.uint_to_t"; +// "FStar.UInt64.uint_to_t"; +// "FStar.UInt128.uint_to_t"; +// "FStar.SizeT.uint_to_t"; +// "FStar.Int8.__int_to_t"; +// "FStar.Int16.__int_to_t"; +// "FStar.Int32.__int_to_t"; +// "FStar.Int64.__int_to_t"; +// "FStar.Int128.__int_to_t"; +// "FStar.UInt8.__uint_to_t"; +// "FStar.UInt16.__uint_to_t"; +// "FStar.UInt32.__uint_to_t"; +// "FStar.UInt64.__uint_to_t"; +// "FStar.UInt128.__uint_to_t"; +// "FStar.SizeT.__uint_to_t"; +// ] + +// // Compose two eq_result injectively, as in a pair +// let eq_inj r s = +// match r, s with +// | Equal, Equal -> Equal +// | NotEqual, _ +// | _, NotEqual -> NotEqual +// | _, _ -> Unknown + +// // Promote a bool to eq_result, conservatively. +// let equal_if = function +// | true -> Equal +// | _ -> Unknown + +// // Promote a bool to an eq_result, taking a false to bet NotEqual. +// // This is only useful for fully decidable equalities. +// // Use with care, see note about Const_real below and #2806. +// let equal_iff = function +// | true -> Equal +// | _ -> NotEqual + +// // Compose two equality results, NOT assuming a NotEqual implies anything. +// // This is useful, e.g., for checking the equality of applications. Consider +// // f x ~ g y +// // if f=g and x=y then we know these two expressions are equal, but cannot say +// // anything when either result is NotEqual or Unknown, hence this returns Unknown +// // in most cases. +// // The second comparison is thunked for efficiency. +// let eq_and r s = +// if r = Equal && s () = Equal +// then Equal +// else Unknown + +// (* Precondition: terms are well-typed in a common environment, or this can return false positives *) +// let rec eq_tm (t1:term) (t2:term) : eq_result = +// let t1 = canon_app t1 in +// let t2 = canon_app t2 in +// let equal_data (f1:fv) (args1:Syntax.args) (f2:fv) (args2:Syntax.args) = +// // we got constructors! we know they are injective and disjoint, so we can do some +// // good analysis on them +// if fv_eq f1 f2 +// then ( +// assert (List.length args1 = List.length args2); +// List.fold_left (fun acc ((a1, q1), (a2, q2)) -> +// //if q1 <> q2 +// //then failwith (U.format1 "Arguments of %s mismatch on implicit qualifier\n" +// // (Ident.string_of_lid f1.fv_name.v)); +// //NS: 05/06/2018 ...this does not always hold +// // it's been succeeding because the assert is disabled in the non-debug builds +// //assert (q1 = q2); +// eq_inj acc (eq_tm a1 a2)) Equal <| List.zip args1 args2 +// ) else NotEqual +// in +// let qual_is_inj = function +// | Some Data_ctor +// | Some (Record_ctor _) -> true +// | _ -> false +// in +// let heads_and_args_in_case_both_data :option (fv * args * fv * args) = +// let head1, args1 = t1 |> unmeta |> head_and_args in +// let head2, args2 = t2 |> unmeta |> head_and_args in +// match (un_uinst head1).n, (un_uinst head2).n with +// | Tm_fvar f, Tm_fvar g when qual_is_inj f.fv_qual && +// qual_is_inj g.fv_qual -> Some (f, args1, g, args2) +// | _ -> None +// in +// let t1 = unmeta t1 in +// let t2 = unmeta t2 in +// match t1.n, t2.n with +// // We sometimes compare open terms, as we get alpha-equivalence +// // for free. +// | Tm_bvar bv1, Tm_bvar bv2 -> +// equal_if (bv1.index = bv2.index) + +// | Tm_lazy _, _ -> eq_tm (unlazy t1) t2 +// | _, Tm_lazy _ -> eq_tm t1 (unlazy t2) + +// | Tm_name a, Tm_name b -> +// equal_if (bv_eq a b) + +// | _ when heads_and_args_in_case_both_data |> is_some -> //matches only when both are data constructors +// heads_and_args_in_case_both_data |> must |> (fun (f, args1, g, args2) -> +// equal_data f args1 g args2 +// ) + +// | Tm_fvar f, Tm_fvar g -> equal_if (fv_eq f g) + +// | Tm_uinst(f, us), Tm_uinst(g, vs) -> +// // If the fvars and universe instantiations match, then Equal, +// // otherwise Unknown. +// eq_and (eq_tm f g) (fun () -> equal_if (eq_univs_list us vs)) + +// | Tm_constant (Const_range _), Tm_constant (Const_range _) -> +// // Ranges should be opaque, even to the normalizer. c.f. #1312 +// Unknown + +// | Tm_constant (Const_real r1), Tm_constant (Const_real r2) -> +// // We cannot decide equality of reals. Use a conservative approach here. +// // If the strings match, they are equal, otherwise we don't know. If this +// // goes via the eq_iff case below, it will falsely claim that "1.0R" and +// // "01.R" are different, since eq_const does not canonizalize the string +// // representations. +// equal_if (r1 = r2) + +// | Tm_constant c, Tm_constant d -> +// // NOTE: this relies on the fact that eq_const *correctly decides* +// // semantic equality of constants. This needs some care. For instance, +// // since integers are represented by a string, eq_const needs to take care +// // of ignoring leading zeroes, and match 0 with -0. An exception to this +// // are real number literals (handled above). See #2806. +// // +// // Currently (24/Jan/23) this seems to be correctly implemented, but +// // updates should be done with care. +// equal_iff (eq_const c d) + +// | Tm_uvar (u1, ([], _)), Tm_uvar (u2, ([], _)) -> +// equal_if (Unionfind.equiv u1.ctx_uvar_head u2.ctx_uvar_head) + +// | Tm_app {hd=h1; args=args1}, Tm_app {hd=h2; args=args2} -> +// begin match (un_uinst h1).n, (un_uinst h2).n with +// | Tm_fvar f1, Tm_fvar f2 when fv_eq f1 f2 && List.mem (string_of_lid (lid_of_fv f1)) injectives -> +// equal_data f1 args1 f2 args2 + +// | _ -> // can only assert they're equal if they syntactically match, nothing else +// eq_and (eq_tm h1 h2) (fun () -> eq_args args1 args2) +// end + +// | Tm_match {scrutinee=t1; brs=bs1}, Tm_match {scrutinee=t2; brs=bs2} -> //AR: note: no return annotations +// if List.length bs1 = List.length bs2 +// then List.fold_right (fun (b1, b2) a -> eq_and a (fun () -> branch_matches b1 b2)) +// (List.zip bs1 bs2) +// (eq_tm t1 t2) +// else Unknown + +// | Tm_type u, Tm_type v -> +// equal_if (eq_univs u v) + +// | Tm_quoted (t1, q1), Tm_quoted (t2, q2) -> +// // NOTE: we do NOT ever provide a meaningful result for quoted terms. Even +// // if term_eq (the syntactic equality) returns true, that does not mean we +// // can present the equality to userspace since term_eq ignores the names +// // of binders, but the view exposes them. Hence, we simply always return +// // Unknown. We do not seem to rely anywhere on simplifying equalities of +// // quoted literals. See also #2806. +// Unknown + +// | Tm_refine {b=t1; phi=phi1}, Tm_refine {b=t2; phi=phi2} -> +// eq_and (eq_tm t1.sort t2.sort) (fun () -> eq_tm phi1 phi2) + +// (* +// * AR: ignoring residual comp here, that's an ascription added by the typechecker +// * do we care if that's different? +// *) +// | Tm_abs {bs=bs1; body=body1}, Tm_abs {bs=bs2; body=body2} +// when List.length bs1 = List.length bs2 -> + +// eq_and (List.fold_left2 (fun r b1 b2 -> eq_and r (fun () -> eq_tm b1.binder_bv.sort b2.binder_bv.sort)) +// Equal bs1 bs2) +// (fun () -> eq_tm body1 body2) + +// | Tm_arrow {bs=bs1; comp=c1}, Tm_arrow {bs=bs2; comp=c2} +// when List.length bs1 = List.length bs2 -> +// eq_and (List.fold_left2 (fun r b1 b2 -> eq_and r (fun () -> eq_tm b1.binder_bv.sort b2.binder_bv.sort)) +// Equal bs1 bs2) +// (fun () -> eq_comp c1 c2) + +// | _ -> Unknown + +// and eq_antiquotations a1 a2 = +// // Basically this; +// // List.fold_left2 (fun acc t1 t2 -> eq_inj acc (eq_tm t1 t2)) Equal a1 a2 +// // but lazy and handling lists of different size +// match a1, a2 with +// | [], [] -> Equal +// | [], _ +// | _, [] -> NotEqual +// | t1::a1, t2::a2 -> +// match eq_tm t1 t2 with +// | NotEqual -> NotEqual +// | Unknown -> +// (match eq_antiquotations a1 a2 with +// | NotEqual -> NotEqual +// | _ -> Unknown) +// | Equal -> eq_antiquotations a1 a2 + +// and branch_matches b1 b2 = +// let related_by f o1 o2 = +// match o1, o2 with +// | None, None -> true +// | Some x, Some y -> f x y +// | _, _ -> false +// in +// let (p1, w1, t1) = b1 in +// let (p2, w2, t2) = b2 in +// if eq_pat p1 p2 +// then begin +// // We check the `when` branches too, even if unsupported for now +// if eq_tm t1 t2 = Equal && related_by (fun t1 t2 -> eq_tm t1 t2 = Equal) w1 w2 +// then Equal +// else Unknown +// end +// else Unknown + +// and eq_args (a1:args) (a2:args) : eq_result = +// match a1, a2 with +// | [], [] -> Equal +// | (a, _)::a1, (b, _)::b1 -> +// (match eq_tm a b with +// | Equal -> eq_args a1 b1 +// | _ -> Unknown) +// | _ -> Unknown + +// and eq_univs_list (us:universes) (vs:universes) : bool = +// List.length us = List.length vs +// && List.forall2 eq_univs us vs + +// and eq_comp (c1 c2:comp) : eq_result = +// match c1.n, c2.n with +// | Total t1, Total t2 +// | GTotal t1, GTotal t2 -> +// eq_tm t1 t2 +// | Comp ct1, Comp ct2 -> +// eq_and (equal_if (eq_univs_list ct1.comp_univs ct2.comp_univs)) +// (fun _ -> +// eq_and (equal_if (Ident.lid_equals ct1.effect_name ct2.effect_name)) +// (fun _ -> +// eq_and (eq_tm ct1.result_typ ct2.result_typ) +// (fun _ -> eq_args ct1.effect_args ct2.effect_args))) +// //ignoring cflags +// | _ -> NotEqual - | Tm_fvar f, Tm_fvar g -> equal_if (fv_eq f g) - - | Tm_uinst(f, us), Tm_uinst(g, vs) -> - // If the fvars and universe instantiations match, then Equal, - // otherwise Unknown. - eq_and (eq_tm f g) (fun () -> equal_if (eq_univs_list us vs)) - - | Tm_constant (Const_range _), Tm_constant (Const_range _) -> - // Ranges should be opaque, even to the normalizer. c.f. #1312 - Unknown - - | Tm_constant (Const_real r1), Tm_constant (Const_real r2) -> - // We cannot decide equality of reals. Use a conservative approach here. - // If the strings match, they are equal, otherwise we don't know. If this - // goes via the eq_iff case below, it will falsely claim that "1.0R" and - // "01.R" are different, since eq_const does not canonizalize the string - // representations. - equal_if (r1 = r2) - - | Tm_constant c, Tm_constant d -> - // NOTE: this relies on the fact that eq_const *correctly decides* - // semantic equality of constants. This needs some care. For instance, - // since integers are represented by a string, eq_const needs to take care - // of ignoring leading zeroes, and match 0 with -0. An exception to this - // are real number literals (handled above). See #2806. - // - // Currently (24/Jan/23) this seems to be correctly implemented, but - // updates should be done with care. - equal_iff (eq_const c d) - - | Tm_uvar (u1, ([], _)), Tm_uvar (u2, ([], _)) -> - equal_if (Unionfind.equiv u1.ctx_uvar_head u2.ctx_uvar_head) - - | Tm_app {hd=h1; args=args1}, Tm_app {hd=h2; args=args2} -> - begin match (un_uinst h1).n, (un_uinst h2).n with - | Tm_fvar f1, Tm_fvar f2 when fv_eq f1 f2 && List.mem (string_of_lid (lid_of_fv f1)) injectives -> - equal_data f1 args1 f2 args2 - - | _ -> // can only assert they're equal if they syntactically match, nothing else - eq_and (eq_tm h1 h2) (fun () -> eq_args args1 args2) - end - - | Tm_match {scrutinee=t1; brs=bs1}, Tm_match {scrutinee=t2; brs=bs2} -> //AR: note: no return annotations - if List.length bs1 = List.length bs2 - then List.fold_right (fun (b1, b2) a -> eq_and a (fun () -> branch_matches b1 b2)) - (List.zip bs1 bs2) - (eq_tm t1 t2) - else Unknown - - | Tm_type u, Tm_type v -> - equal_if (eq_univs u v) - - | Tm_quoted (t1, q1), Tm_quoted (t2, q2) -> - // NOTE: we do NOT ever provide a meaningful result for quoted terms. Even - // if term_eq (the syntactic equality) returns true, that does not mean we - // can present the equality to userspace since term_eq ignores the names - // of binders, but the view exposes them. Hence, we simply always return - // Unknown. We do not seem to rely anywhere on simplifying equalities of - // quoted literals. See also #2806. - Unknown - - | Tm_refine {b=t1; phi=phi1}, Tm_refine {b=t2; phi=phi2} -> - eq_and (eq_tm t1.sort t2.sort) (fun () -> eq_tm phi1 phi2) - - (* - * AR: ignoring residual comp here, that's an ascription added by the typechecker - * do we care if that's different? - *) - | Tm_abs {bs=bs1; body=body1}, Tm_abs {bs=bs2; body=body2} - when List.length bs1 = List.length bs2 -> - - eq_and (List.fold_left2 (fun r b1 b2 -> eq_and r (fun () -> eq_tm b1.binder_bv.sort b2.binder_bv.sort)) - Equal bs1 bs2) - (fun () -> eq_tm body1 body2) - - | Tm_arrow {bs=bs1; comp=c1}, Tm_arrow {bs=bs2; comp=c2} - when List.length bs1 = List.length bs2 -> - eq_and (List.fold_left2 (fun r b1 b2 -> eq_and r (fun () -> eq_tm b1.binder_bv.sort b2.binder_bv.sort)) - Equal bs1 bs2) - (fun () -> eq_comp c1 c2) - - | _ -> Unknown - -and eq_antiquotations a1 a2 = - // Basically this; - // List.fold_left2 (fun acc t1 t2 -> eq_inj acc (eq_tm t1 t2)) Equal a1 a2 - // but lazy and handling lists of different size - match a1, a2 with - | [], [] -> Equal - | [], _ - | _, [] -> NotEqual - | t1::a1, t2::a2 -> - match eq_tm t1 t2 with - | NotEqual -> NotEqual - | Unknown -> - (match eq_antiquotations a1 a2 with - | NotEqual -> NotEqual - | _ -> Unknown) - | Equal -> eq_antiquotations a1 a2 - -and branch_matches b1 b2 = - let related_by f o1 o2 = - match o1, o2 with - | None, None -> true - | Some x, Some y -> f x y - | _, _ -> false - in - let (p1, w1, t1) = b1 in - let (p2, w2, t2) = b2 in - if eq_pat p1 p2 - then begin - // We check the `when` branches too, even if unsupported for now - if eq_tm t1 t2 = Equal && related_by (fun t1 t2 -> eq_tm t1 t2 = Equal) w1 w2 - then Equal - else Unknown - end - else Unknown - -and eq_args (a1:args) (a2:args) : eq_result = - match a1, a2 with - | [], [] -> Equal - | (a, _)::a1, (b, _)::b1 -> - (match eq_tm a b with - | Equal -> eq_args a1 b1 - | _ -> Unknown) - | _ -> Unknown - -and eq_univs_list (us:universes) (vs:universes) : bool = - List.length us = List.length vs - && List.forall2 eq_univs us vs - -and eq_comp (c1 c2:comp) : eq_result = - match c1.n, c2.n with - | Total t1, Total t2 - | GTotal t1, GTotal t2 -> - eq_tm t1 t2 - | Comp ct1, Comp ct2 -> - eq_and (equal_if (eq_univs_list ct1.comp_univs ct2.comp_univs)) - (fun _ -> - eq_and (equal_if (Ident.lid_equals ct1.effect_name ct2.effect_name)) - (fun _ -> - eq_and (eq_tm ct1.result_typ ct2.result_typ) - (fun _ -> eq_args ct1.effect_args ct2.effect_args))) - //ignoring cflags - | _ -> NotEqual - -(* Only used in term_eq *) -let eq_quoteinfo q1 q2 = - if q1.qkind <> q2.qkind - then NotEqual - else eq_antiquotations (snd q1.antiquotations) (snd q2.antiquotations) - -(* Only used in term_eq *) -let eq_bqual a1 a2 = - match a1, a2 with - | None, None -> Equal - | None, _ - | _, None -> NotEqual - | Some (Implicit b1), Some (Implicit b2) when b1=b2 -> Equal - | Some (Meta t1), Some (Meta t2) -> eq_tm t1 t2 - | Some Equality, Some Equality -> Equal - | _ -> NotEqual - -(* Only used in term_eq *) -let eq_aqual a1 a2 = - match a1, a2 with - | Some a1, Some a2 -> - if a1.aqual_implicit = a2.aqual_implicit - && List.length a1.aqual_attributes = List.length a2.aqual_attributes - then List.fold_left2 - (fun out t1 t2 -> - match out with - | NotEqual -> out - | Unknown -> - (match eq_tm t1 t2 with - | NotEqual -> NotEqual - | _ -> Unknown) - | Equal -> - eq_tm t1 t2) - Equal - a1.aqual_attributes - a2.aqual_attributes - else NotEqual - | None, None -> - Equal - | _ -> - NotEqual let rec unrefine t = @@ -1264,11 +1227,11 @@ let type_u () : typ * universe = let type_with_u (u:universe) : typ = mk (Tm_type u) dummyRange -// works on anything, really -let attr_eq a a' = - match eq_tm a a' with - | Equal -> true - | _ -> false +// // works on anything, really +// let attr_eq a a' = +// match eq_tm a a' with +// | Equal -> true +// | _ -> false let attr_substitute = mk (Tm_fvar (lid_as_fv PC.attr_substitute_lid None)) Range.dummyRange @@ -1716,7 +1679,7 @@ let rec term_eq_dbg (dbg : bool) t1 t2 = check "uvar" (u1.ctx_uvar_head = u2.ctx_uvar_head) | Tm_quoted (qt1, qi1), Tm_quoted (qt2, qi2) -> - (check "tm_quoted qi" (eq_quoteinfo qi1 qi2 = Equal)) && + (check "tm_quoted qi" (quote_info_eq_dbg dbg qi1 qi2)) && (check "tm_quoted payload" (term_eq_dbg dbg qt1 qt2)) | Tm_meta {tm=t1; meta=m1}, Tm_meta {tm=t2; meta=m2} -> @@ -1766,11 +1729,11 @@ let rec term_eq_dbg (dbg : bool) t1 t2 = and arg_eq_dbg (dbg : bool) a1 a2 = eqprod (fun t1 t2 -> check dbg "arg tm" (term_eq_dbg dbg t1 t2)) - (fun q1 q2 -> check dbg "arg qual" (eq_aqual q1 q2 = Equal)) + (fun q1 q2 -> check dbg "arg qual" (aqual_eq_dbg dbg q1 q2)) a1 a2 and binder_eq_dbg (dbg : bool) b1 b2 = (check dbg "binder_sort" (term_eq_dbg dbg b1.binder_bv.sort b2.binder_bv.sort)) && - (check dbg "binder qual" (eq_bqual b1.binder_qual b2.binder_qual = Equal)) && //AR: not checking attributes, should we? + (check dbg "binder qual" (bqual_eq_dbg dbg b1.binder_qual b2.binder_qual)) && //AR: not checking attributes, should we? (check dbg "binder attrs" (eqlist (term_eq_dbg dbg) b1.binder_attrs b2.binder_attrs)) and comp_eq_dbg (dbg : bool) c1 c2 = @@ -1798,6 +1761,56 @@ and letbinding_eq_dbg (dbg : bool) (lb1 : letbinding) lb2 = (check dbg "lb def" (term_eq_dbg dbg lb1.lbdef lb2.lbdef)) // Ignoring eff and attrs.. +and quote_info_eq_dbg (dbg:bool) q1 q2 = + if q1.qkind <> q2.qkind + then false + else antiquotations_eq_dbg dbg (snd q1.antiquotations) (snd q2.antiquotations) + +and antiquotations_eq_dbg (dbg:bool) a1 a2 = + // Basically this; + // List.fold_left2 (fun acc t1 t2 -> eq_inj acc (eq_tm t1 t2)) Equal a1 a2 + // but lazy and handling lists of different size + match a1, a2 with + | [], [] -> true + | [], _ + | _, [] -> false + | t1::a1, t2::a2 -> + if not <| term_eq_dbg dbg t1 t2 + then false + else antiquotations_eq_dbg dbg a1 a2 + +and bqual_eq_dbg dbg a1 a2 = + match a1, a2 with + | None, None -> true + | None, _ + | _, None -> false + | Some (Implicit b1), Some (Implicit b2) when b1=b2 -> true + | Some (Meta t1), Some (Meta t2) -> term_eq_dbg dbg t1 t2 + | Some Equality, Some Equality -> true + | _ -> false + +and aqual_eq_dbg dbg a1 a2 = + match a1, a2 with + | Some a1, Some a2 -> + if a1.aqual_implicit = a2.aqual_implicit + && List.length a1.aqual_attributes = List.length a2.aqual_attributes + then List.fold_left2 + (fun out t1 t2 -> + if not out + then false + else term_eq_dbg dbg t1 t2) + true + a1.aqual_attributes + a2.aqual_attributes + else false + | None, None -> + true + | _ -> + false + +let eq_aqual a1 a2 = aqual_eq_dbg false a1 a2 +let eq_bqual b1 b2 = bqual_eq_dbg false b1 b2 + let term_eq t1 t2 = let r = term_eq_dbg !debug_term_eq t1 t2 in debug_term_eq := false; @@ -2389,7 +2402,7 @@ let is_binder_unused (b:binder) = b.binder_positivity = Some BinderUnused let deduplicate_terms (l:list term) = - FStar.Compiler.List.deduplicate (fun x y -> eq_tm x y = Equal) l + FStar.Compiler.List.deduplicate (fun x y -> term_eq x y) l let eq_binding b1 b2 = match b1, b2 with diff --git a/src/tactics/FStar.Tactics.Hooks.fst b/src/tactics/FStar.Tactics.Hooks.fst index c11516170fa..ae36d646c5e 100644 --- a/src/tactics/FStar.Tactics.Hooks.fst +++ b/src/tactics/FStar.Tactics.Hooks.fst @@ -44,6 +44,7 @@ module Env = FStar.TypeChecker.Env module TcUtil = FStar.TypeChecker.Util module TcRel = FStar.TypeChecker.Rel module TcTerm = FStar.TypeChecker.TcTerm +module TEQ = FStar.TypeChecker.TermEqAndSimplify (* We only use the _abstract_ embeddings from this module, hence there is no v1/v2 distinction. *) @@ -576,7 +577,7 @@ let rec traverse_for_spinoff | Tm_fvar fv, [(t, _)] when simplified && S.fv_eq_lid fv PC.squash_lid && - U.eq_tm t U.t_true = U.Equal -> + TEQ.eq_tm e t U.t_true = TEQ.Equal -> //simplify squash True to True //important for simplifying queries to Trivial if debug then BU.print_string "Simplified squash True to True"; diff --git a/src/tests/FStar.Tests.Util.fst b/src/tests/FStar.Tests.Util.fst index 94afeb89a9a..7961ba068bb 100644 --- a/src/tests/FStar.Tests.Util.fst +++ b/src/tests/FStar.Tests.Util.fst @@ -55,7 +55,7 @@ let rec term_eq' t1 t2 = && List.forall2 (fun (x:binder) (y:binder) -> term_eq' x.binder_bv.sort y.binder_bv.sort) xs ys in let args_eq xs ys = List.length xs = List.length ys - && List.forall2 (fun (a, imp) (b, imp') -> term_eq' a b && U.eq_aqual imp imp'=U.Equal) xs ys in + && List.forall2 (fun (a, imp) (b, imp') -> term_eq' a b && U.eq_aqual imp imp') xs ys in let comp_eq (c:S.comp) (d:S.comp) = match c.n, d.n with | S.Total t, S.Total s -> term_eq' t s diff --git a/src/typechecker/FStar.TypeChecker.Cfg.fst b/src/typechecker/FStar.TypeChecker.Cfg.fst index 5cb7254d97d..39430271921 100644 --- a/src/typechecker/FStar.TypeChecker.Cfg.fst +++ b/src/typechecker/FStar.TypeChecker.Cfg.fst @@ -251,7 +251,8 @@ let prim_from_list (l : list primitive_step) : prim_step_set = (* Turn the lists into psmap sets, for efficiency of lookup *) let built_in_primitive_steps = prim_from_list built_in_primitive_steps_list -let equality_ops = prim_from_list equality_ops_list +let env_dependent_ops env = prim_from_list (env_dependent_ops env) +let equality_ops env = prim_from_list (equality_ops_list env) instance showable_cfg : showable cfg = { show = (fun cfg -> @@ -373,7 +374,7 @@ let config' psteps s e = | [] -> [Env.NoDelta] | _ -> d in let steps = to_fsteps s |> add_nbe in - let psteps = add_steps (cached_steps ()) psteps in + let psteps = add_steps (merge_steps (cached_steps ()) (env_dependent_ops e))psteps in let dbg_flag = List.contains NormDebug s in {tcenv = e; debug = if dbg_flag || Options.debug_any () then diff --git a/src/typechecker/FStar.TypeChecker.Cfg.fsti b/src/typechecker/FStar.TypeChecker.Cfg.fsti index d5683f2f060..7843a7808eb 100644 --- a/src/typechecker/FStar.TypeChecker.Cfg.fsti +++ b/src/typechecker/FStar.TypeChecker.Cfg.fsti @@ -137,7 +137,7 @@ val find_prim_step: cfg -> fv -> option primitive_step // val try_unembed_simple: EMB.embedding 'a -> term -> option 'a val built_in_primitive_steps : BU.psmap primitive_step -val equality_ops : BU.psmap primitive_step +val equality_ops (env:Env.env_t): BU.psmap primitive_step val register_plugin: primitive_step -> unit val register_extra_step: primitive_step -> unit diff --git a/src/typechecker/FStar.TypeChecker.Common.fst b/src/typechecker/FStar.TypeChecker.Common.fst index 1a25708ce24..9f844bed437 100644 --- a/src/typechecker/FStar.TypeChecker.Common.fst +++ b/src/typechecker/FStar.TypeChecker.Common.fst @@ -350,270 +350,6 @@ let lcomp_of_comp_guard c0 g = let lcomp_of_comp c0 = lcomp_of_comp_guard c0 trivial_guard -//////////////////////////////////////////////////////////////////////////////// -// Core logical simplification of terms -//////////////////////////////////////////////////////////////////////////////// -module SS = FStar.Syntax.Subst -open FStar.Syntax.Util -open FStar.Const -let simplify (debug:bool) (tm:term) : term = - let w t = {t with pos=tm.pos} in - let simp_t t = - // catch annotated subformulae too - match (U.unmeta t).n with - | Tm_fvar fv when S.fv_eq_lid fv PC.true_lid -> Some true - | Tm_fvar fv when S.fv_eq_lid fv PC.false_lid -> Some false - | _ -> None - in - let rec args_are_binders args bs = - match args, bs with - | (t, _)::args, b::bs -> - begin match (SS.compress t).n with - | Tm_name bv' -> S.bv_eq b.binder_bv bv' && args_are_binders args bs - | _ -> false - end - | [], [] -> true - | _, _ -> false - in - let is_applied (bs:binders) (t : term) : option bv = - if debug then - BU.print2 "WPE> is_applied %s -- %s\n" (Print.term_to_string t) (Print.tag_of_term t); - let hd, args = U.head_and_args_full t in - match (SS.compress hd).n with - | Tm_name bv when args_are_binders args bs -> - if debug then - BU.print3 "WPE> got it\n>>>>top = %s\n>>>>b = %s\n>>>>hd = %s\n" - (Print.term_to_string t) - (Print.bv_to_string bv) - (Print.term_to_string hd); - Some bv - | _ -> None - in - let is_applied_maybe_squashed (bs : binders) (t : term) : option bv = - if debug then - BU.print2 "WPE> is_applied_maybe_squashed %s -- %s\n" (Print.term_to_string t) (Print.tag_of_term t); - match is_squash t with - - | Some (_, t') -> is_applied bs t' - | _ -> begin match is_auto_squash t with - | Some (_, t') -> is_applied bs t' - | _ -> is_applied bs t - end - in - let is_const_match (phi : term) : option bool = - match (SS.compress phi).n with - (* Trying to be efficient, but just checking if they all agree *) - (* Note, if we wanted to do this for any term instead of just True/False - * we need to open the terms *) - | Tm_match {brs=br::brs} -> - let (_, _, e) = br in - let r = begin match simp_t e with - | None -> None - | Some b -> if List.for_all (fun (_, _, e') -> simp_t e' = Some b) brs - then Some b - else None - end - in - r - | _ -> None - in - let maybe_auto_squash t = - if U.is_sub_singleton t - then t - else U.mk_auto_squash U_zero t - in - let squashed_head_un_auto_squash_args t = - //The head of t is already a squashed operator, e.g. /\ etc. - //no point also squashing its arguments if they're already in U_zero - let maybe_un_auto_squash_arg (t,q) = - match U.is_auto_squash t with - | Some (U_zero, t) -> - //if we're squashing from U_zero to U_zero - // then just remove it - t, q - | _ -> - t,q - in - let head, args = U.head_and_args t in - let args = List.map maybe_un_auto_squash_arg args in - S.mk_Tm_app head args t.pos - in - let rec clearly_inhabited (ty : typ) : bool = - match (U.unmeta ty).n with - | Tm_uinst (t, _) -> clearly_inhabited t - | Tm_arrow {comp=c} -> clearly_inhabited (U.comp_result c) - | Tm_fvar fv -> - let l = S.lid_of_fv fv in - (Ident.lid_equals l PC.int_lid) - || (Ident.lid_equals l PC.bool_lid) - || (Ident.lid_equals l PC.string_lid) - || (Ident.lid_equals l PC.exn_lid) - | _ -> false - in - let simplify arg = (simp_t (fst arg), arg) in - match (SS.compress tm).n with - | Tm_app {hd={n=Tm_uinst({n=Tm_fvar fv}, _)}; args} - | Tm_app {hd={n=Tm_fvar fv}; args} -> - if S.fv_eq_lid fv PC.and_lid - then match args |> List.map simplify with - | [(Some true, _); (_, (arg, _))] - | [(_, (arg, _)); (Some true, _)] -> maybe_auto_squash arg - | [(Some false, _); _] - | [_; (Some false, _)] -> w U.t_false - | _ -> squashed_head_un_auto_squash_args tm - else if S.fv_eq_lid fv PC.or_lid - then match args |> List.map simplify with - | [(Some true, _); _] - | [_; (Some true, _)] -> w U.t_true - | [(Some false, _); (_, (arg, _))] - | [(_, (arg, _)); (Some false, _)] -> maybe_auto_squash arg - | _ -> squashed_head_un_auto_squash_args tm - else if S.fv_eq_lid fv PC.imp_lid - then match args |> List.map simplify with - | [_; (Some true, _)] - | [(Some false, _); _] -> w U.t_true - | [(Some true, _); (_, (arg, _))] -> maybe_auto_squash arg - | [(_, (p, _)); (_, (q, _))] -> - if U.term_eq p q - then w U.t_true - else squashed_head_un_auto_squash_args tm - | _ -> squashed_head_un_auto_squash_args tm - else if S.fv_eq_lid fv PC.iff_lid - then match args |> List.map simplify with - | [(Some true, _) ; (Some true, _)] - | [(Some false, _) ; (Some false, _)] -> w U.t_true - | [(Some true, _) ; (Some false, _)] - | [(Some false, _) ; (Some true, _)] -> w U.t_false - | [(_, (arg, _)) ; (Some true, _)] - | [(Some true, _) ; (_, (arg, _))] -> maybe_auto_squash arg - | [(_, (arg, _)) ; (Some false, _)] - | [(Some false, _) ; (_, (arg, _))] -> maybe_auto_squash (U.mk_neg arg) - | [(_, (p, _)); (_, (q, _))] -> - if U.term_eq p q - then w U.t_true - else squashed_head_un_auto_squash_args tm - | _ -> squashed_head_un_auto_squash_args tm - else if S.fv_eq_lid fv PC.not_lid - then match args |> List.map simplify with - | [(Some true, _)] -> w U.t_false - | [(Some false, _)] -> w U.t_true - | _ -> squashed_head_un_auto_squash_args tm - else if S.fv_eq_lid fv PC.forall_lid - then match args with - (* Simplify ∀x. True to True *) - | [(t, _)] -> - begin match (SS.compress t).n with - | Tm_abs {bs=[_]; body} -> - (match simp_t body with - | Some true -> w U.t_true - | _ -> tm) - | _ -> tm - end - (* Simplify ∀x. True to True, and ∀x. False to False, if the domain is not empty *) - | [(ty, Some ({ aqual_implicit = true })); (t, _)] -> - begin match (SS.compress t).n with - | Tm_abs {bs=[_]; body} -> - (match simp_t body with - | Some true -> w U.t_true - | Some false when clearly_inhabited ty -> w U.t_false - | _ -> tm) - | _ -> tm - end - | _ -> tm - else if S.fv_eq_lid fv PC.exists_lid - then match args with - (* Simplify ∃x. False to False *) - | [(t, _)] -> - begin match (SS.compress t).n with - | Tm_abs {bs=[_]; body} -> - (match simp_t body with - | Some false -> w U.t_false - | _ -> tm) - | _ -> tm - end - (* Simplify ∃x. False to False and ∃x. True to True, if the domain is not empty *) - | [(ty, Some ({ aqual_implicit = true })); (t, _)] -> - begin match (SS.compress t).n with - | Tm_abs {bs=[_]; body} -> - (match simp_t body with - | Some false -> w U.t_false - | Some true when clearly_inhabited ty -> w U.t_true - | _ -> tm) - | _ -> tm - end - | _ -> tm - else if S.fv_eq_lid fv PC.b2t_lid - then match args with - | [{n=Tm_constant (Const_bool true)}, _] -> w U.t_true - | [{n=Tm_constant (Const_bool false)}, _] -> w U.t_false - | _ -> tm //its arg is a bool, can't unsquash - else if S.fv_eq_lid fv PC.haseq_lid - then begin - (* - * AR: We try to mimic the hasEq related axioms in Prims - * and the axiom related to refinements - * For other types, such as lists, whose hasEq is derived by the typechecker, - * we leave them as is - *) - let t_has_eq_for_sure (t:S.term) :bool = - //Axioms from prims - let haseq_lids = [PC.int_lid; PC.bool_lid; PC.unit_lid; PC.string_lid] in - match (SS.compress t).n with - | Tm_fvar fv when haseq_lids |> List.existsb (fun l -> S.fv_eq_lid fv l) -> true - | _ -> false - in - if List.length args = 1 then - let t = args |> List.hd |> fst in - if t |> t_has_eq_for_sure then w U.t_true - else - match (SS.compress t).n with - | Tm_refine _ -> - let t = U.unrefine t in - if t |> t_has_eq_for_sure then w U.t_true - else - //get the hasEq term itself - let haseq_tm = - match (SS.compress tm).n with - | Tm_app {hd} -> hd - | _ -> failwith "Impossible! We have already checked that this is a Tm_app" - in - //and apply it to the unrefined type - mk_app (haseq_tm) [t |> as_arg] - | _ -> tm - else tm - end - else if S.fv_eq_lid fv PC.eq2_lid - then match args with - | [(_typ, _); (a1, _); (a2, _)] -> //eq2 - (match U.eq_tm a1 a2 with - | U.Equal -> w U.t_true - | U.NotEqual -> w U.t_false - | _ -> tm) - | _ -> tm - else - begin - match U.is_auto_squash tm with - | Some (U_zero, t) - when U.is_sub_singleton t -> - //remove redundant auto_squashes - t - | _ -> - tm - end - | Tm_refine {b=bv; phi=t} -> - begin match simp_t t with - | Some true -> bv.sort - | Some false -> tm - | None -> tm - end - | Tm_match _ -> - begin match is_const_match tm with - | Some true -> w U.t_true - | Some false -> w U.t_false - | None -> tm - end - | _ -> tm - let check_positivity_qual subtyping p0 p1 = if p0 = p1 then true else if subtyping diff --git a/src/typechecker/FStar.TypeChecker.Common.fsti b/src/typechecker/FStar.TypeChecker.Common.fsti index 8e91e651af0..aed6201f9d3 100644 --- a/src/typechecker/FStar.TypeChecker.Common.fsti +++ b/src/typechecker/FStar.TypeChecker.Common.fsti @@ -204,7 +204,6 @@ val residual_comp_of_lcomp : lcomp -> residual_comp val lcomp_of_comp_guard : comp -> guard_t -> lcomp //lcomp_of_comp_guard with trivial guard val lcomp_of_comp : comp -> lcomp -val simplify : debug:bool -> term -> term val check_positivity_qual (subtyping:bool) (p0 p1:option positivity_qualifier) : bool diff --git a/src/typechecker/FStar.TypeChecker.Core.fst b/src/typechecker/FStar.TypeChecker.Core.fst index c353707ad82..43b8280e479 100644 --- a/src/typechecker/FStar.TypeChecker.Core.fst +++ b/src/typechecker/FStar.TypeChecker.Core.fst @@ -16,6 +16,8 @@ module BU = FStar.Compiler.Util module TcUtil = FStar.TypeChecker.Util module Hash = FStar.Syntax.Hash module Subst = FStar.Syntax.Subst +module TEQ = FStar.TypeChecker.TermEqAndSimplify + open FStar.Class.Show open FStar.Class.Setlike @@ -1143,7 +1145,7 @@ and check_relation_comp (g:env) rel (c0 c1:comp) match destruct_comp c0, destruct_comp c1 with | None, _ | _, None -> - if U.eq_comp c0 c1 = U.Equal + if TEQ.eq_comp g.tcenv c0 c1 = TEQ.Equal then return () else ( let ct_eq res0 args0 res1 args1 = diff --git a/src/typechecker/FStar.TypeChecker.DMFF.fst b/src/typechecker/FStar.TypeChecker.DMFF.fst index 666f63a077a..5165430ac86 100644 --- a/src/typechecker/FStar.TypeChecker.DMFF.fst +++ b/src/typechecker/FStar.TypeChecker.DMFF.fst @@ -40,6 +40,7 @@ module TcTerm = FStar.TypeChecker.TcTerm module BU = FStar.Compiler.Util //basic util module U = FStar.Syntax.Util module PC = FStar.Parser.Const +module TEQ = FStar.TypeChecker.TermEqAndSimplify open FStar.Class.Setlike @@ -1298,7 +1299,7 @@ and trans_F_ (env: env_) (c: typ) (wp: term): term = failwith "mismatch"; mk (Tm_app {hd=head; args=List.map2 (fun (arg, q) (wp_arg, q') -> let print_implicit q = if S.is_aqual_implicit q then "implicit" else "explicit" in - if eq_aqual q q' <> Equal + if not (eq_aqual q q') then Errors.log_issue head.pos (Errors.Warning_IncoherentImplicitQualifier, diff --git a/src/typechecker/FStar.TypeChecker.DeferredImplicits.fst b/src/typechecker/FStar.TypeChecker.DeferredImplicits.fst index e3f04680c3b..35418a38c98 100644 --- a/src/typechecker/FStar.TypeChecker.DeferredImplicits.fst +++ b/src/typechecker/FStar.TypeChecker.DeferredImplicits.fst @@ -35,6 +35,7 @@ module BU = FStar.Compiler.Util module S = FStar.Syntax.Syntax module U = FStar.Syntax.Util module SS = FStar.Syntax.Subst +module TEQ = FStar.TypeChecker.TermEqAndSimplify open FStar.Class.Setlike @@ -115,7 +116,7 @@ let find_user_tac_for_uvar env (u:ctx_uvar) : option sigelt = (* candidates: hooks that also have the attribute [a] *) let candidates = hooks |> List.filter - (fun hook -> hook.sigattrs |> BU.for_some (U.attr_eq a)) + (fun hook -> hook.sigattrs |> BU.for_some (TEQ.eq_tm_bool env a)) in (* The environment sometimes returns duplicates in the candidate list; filter out dups *) let candidates = @@ -146,7 +147,7 @@ let find_user_tac_for_uvar env (u:ctx_uvar) : option sigelt = | Tm_fvar fv, [_; (a', _); (overrides, _)] //type argument may be missing, since it is just an attr | Tm_fvar fv, [(a', _); (overrides, _)] when fv_eq_lid fv FStar.Parser.Const.override_resolve_implicits_handler_lid - && U.attr_eq a a' -> + && TEQ.eq_tm_bool env a a' -> //other has an attribute [@@override_resolve_implicits_handler a overrides] begin match attr_list_elements overrides with diff --git a/src/typechecker/FStar.TypeChecker.NBE.fst b/src/typechecker/FStar.TypeChecker.NBE.fst index 2056e1d8061..8bcb2bc9cb6 100644 --- a/src/typechecker/FStar.TypeChecker.NBE.fst +++ b/src/typechecker/FStar.TypeChecker.NBE.fst @@ -45,6 +45,7 @@ module NU = FStar.TypeChecker.Normalize.Unfolding module FC = FStar.Const module EMB = FStar.Syntax.Embeddings module PC = FStar.Parser.Const +module TEQ = FStar.TypeChecker.TermEqAndSimplify open FStar.Class.Show @@ -1070,7 +1071,7 @@ and translate_monadic (m, ty) cfg bs e : t = S.mk (Tm_abs {bs=[S.mk_binder (BU.left lb.lbname)]; body; rc_opt=Some body_rc}) body.pos in let maybe_range_arg = - if BU.for_some (U.attr_eq U.dm4f_bind_range_attr) ed.eff_attrs + if BU.for_some (TEQ.eq_tm_bool cfg.core_cfg.tcenv U.dm4f_bind_range_attr) ed.eff_attrs then [translate cfg [] (PO.embed_simple lb.lbpos lb.lbpos), None; translate cfg [] (PO.embed_simple body.pos body.pos), None] else [] @@ -1289,7 +1290,7 @@ and readback (cfg:config) (x:t) : term = let refinement = U.refine x body in with_range ( if cfg.core_cfg.steps.simplify - then Common.simplify cfg.core_cfg.debug.wpe refinement + then TEQ.simplify cfg.core_cfg.debug.wpe cfg.core_cfg.tcenv refinement else refinement ) @@ -1326,7 +1327,7 @@ and readback (cfg:config) (x:t) : term = let app = U.mk_app (S.mk_Tm_uinst fv (List.rev us)) args in with_range ( if cfg.core_cfg.steps.simplify - then Common.simplify cfg.core_cfg.debug.wpe app + then TEQ.simplify cfg.core_cfg.debug.wpe cfg.core_cfg.tcenv app else app ) @@ -1338,7 +1339,7 @@ and readback (cfg:config) (x:t) : term = let app = U.mk_app (S.bv_to_name bv) args in with_range ( if cfg.core_cfg.steps.simplify - then Common.simplify cfg.core_cfg.debug.wpe app + then TEQ.simplify cfg.core_cfg.debug.wpe cfg.core_cfg.tcenv app else app ) @@ -1380,7 +1381,7 @@ and readback (cfg:config) (x:t) : term = let app = U.mk_app head args in with_range ( if cfg.core_cfg.steps.simplify - then Common.simplify cfg.core_cfg.debug.wpe app + then TEQ.simplify cfg.core_cfg.debug.wpe cfg.core_cfg.tcenv app else app ) diff --git a/src/typechecker/FStar.TypeChecker.NBETerm.fst b/src/typechecker/FStar.TypeChecker.NBETerm.fst index db10421a0b9..451f0879ac8 100644 --- a/src/typechecker/FStar.TypeChecker.NBETerm.fst +++ b/src/typechecker/FStar.TypeChecker.NBETerm.fst @@ -31,6 +31,8 @@ module P = FStar.Syntax.Print module BU = FStar.Compiler.Util module C = FStar.Const module SE = FStar.Syntax.Embeddings +module TEQ = FStar.TypeChecker.TermEqAndSimplify + open FStar.VConfig open FStar.Class.Show @@ -82,74 +84,74 @@ let mkAccuMatch (s:t) (ret:(unit -> option match_returns_ascription)) (bs:(unit // Term equality let equal_if = function - | true -> U.Equal - | _ -> U.Unknown + | true -> TEQ.Equal + | _ -> TEQ.Unknown let equal_iff = function - | true -> U.Equal - | _ -> U.NotEqual + | true -> TEQ.Equal + | _ -> TEQ.NotEqual let eq_inj r1 r2 = match r1, r2 with - | U.Equal, U.Equal -> U.Equal - | U.NotEqual, _ - | _, U.NotEqual -> U.NotEqual - | U.Unknown, _ - | _, U.Unknown -> U.Unknown + | TEQ.Equal, TEQ.Equal -> TEQ.Equal + | TEQ.NotEqual, _ + | _, TEQ.NotEqual -> TEQ.NotEqual + | TEQ.Unknown, _ + | _, TEQ.Unknown -> TEQ.Unknown let eq_and f g = match f with - | U.Equal -> g() - | _ -> U.Unknown + | TEQ.Equal -> g() + | _ -> TEQ.Unknown let eq_constant (c1 : constant) (c2 : constant) = match c1, c2 with -| Unit, Unit -> U.Equal +| Unit, Unit -> TEQ.Equal | Bool b1, Bool b2 -> equal_iff (b1 = b2) | Int i1, Int i2 -> equal_iff (i1 = i2) | String (s1, _), String (s2, _) -> equal_iff (s1 = s2) | Char c1, Char c2 -> equal_iff (c1 = c2) -| Range r1, Range r2 -> U.Unknown (* Seems that ranges are opaque *) -| _, _ -> U.NotEqual +| Range r1, Range r2 -> TEQ.Unknown (* Seems that ranges are opaque *) +| _, _ -> TEQ.NotEqual -let rec eq_t (t1 : t) (t2 : t) : U.eq_result = +let rec eq_t env (t1 : t) (t2 : t) : TEQ.eq_result = match t1.nbe_t, t2.nbe_t with - | Lam _, Lam _ -> U.Unknown - | Accu(a1, as1), Accu(a2, as2) -> eq_and (eq_atom a1 a2) (fun () -> eq_args as1 as2) + | Lam _, Lam _ -> TEQ.Unknown + | Accu(a1, as1), Accu(a2, as2) -> eq_and (eq_atom a1 a2) (fun () -> eq_args env as1 as2) | Construct(v1, us1, args1), Construct(v2, us2, args2) -> if S.fv_eq v1 v2 then begin if List.length args1 <> List.length args2 then failwith "eq_t, different number of args on Construct"; List.fold_left (fun acc ((a1, _), (a2, _)) -> - eq_inj acc (eq_t a1 a2)) U.Equal <| List.zip args1 args2 - end else U.NotEqual + eq_inj acc (eq_t env a1 a2)) TEQ.Equal <| List.zip args1 args2 + end else TEQ.NotEqual | FV(v1, us1, args1), FV(v2, us2, args2) -> if S.fv_eq v1 v2 then - eq_and (equal_iff (U.eq_univs_list us1 us2)) (fun () -> eq_args args1 args2) - else U.Unknown + eq_and (equal_iff (U.eq_univs_list us1 us2)) (fun () -> eq_args env args1 args2) + else TEQ.Unknown | Constant c1, Constant c2 -> eq_constant c1 c2 | Type_t u1, Type_t u2 | Univ u1, Univ u2 -> equal_iff (U.eq_univs u1 u2) | Refinement(r1, t1), Refinement(r2, t2) -> let x = S.new_bv None S.t_unit in (* bogus type *) - eq_and (eq_t (fst (t1 ())) (fst (t2 ()))) (fun () -> eq_t (r1 (mkAccuVar x)) (r2 (mkAccuVar x))) - | Unknown, Unknown -> U.Equal - | _, _ -> U.Unknown (* XXX following eq_tm *) + eq_and (eq_t env (fst (t1 ())) (fst (t2 ()))) (fun () -> eq_t env (r1 (mkAccuVar x)) (r2 (mkAccuVar x))) + | Unknown, Unknown -> TEQ.Equal + | _, _ -> TEQ.Unknown (* XXX following eq_tm *) -and eq_atom (a1 : atom) (a2 : atom) : U.eq_result = +and eq_atom (a1 : atom) (a2 : atom) : TEQ.eq_result = match a1, a2 with | Var bv1, Var bv2 -> equal_if (bv_eq bv1 bv2) (* ZP : TODO if or iff?? *) - | _, _ -> U.Unknown (* XXX Cannot compare suspended matches (?) *) - -and eq_arg (a1 : arg) (a2 : arg) = eq_t (fst a1) (fst a2) -and eq_args (as1 : args) (as2 : args) : U.eq_result = -match as1, as2 with -| [], [] -> U.Equal -| x :: xs, y :: ys -> eq_and (eq_arg x y) (fun () -> eq_args xs ys) -| _, _ -> U.Unknown (* ZP: following tm_eq, but why not U.NotEqual? *) + | _, _ -> TEQ.Unknown (* XXX Cannot compare suspended matches (?) *) + +and eq_arg env (a1 : arg) (a2 : arg) = eq_t env (fst a1) (fst a2) +and eq_args env (as1 : args) (as2 : args) : TEQ.eq_result = + match as1, as2 with + | [], [] -> TEQ.Equal + | x :: xs, y :: ys -> eq_and (eq_arg env x y) (fun () -> eq_args env xs ys) + | _, _ -> TEQ.Unknown (* ZP: following tm_eq, but why not TEQ.NotEqual? *) // Printing functions diff --git a/src/typechecker/FStar.TypeChecker.NBETerm.fsti b/src/typechecker/FStar.TypeChecker.NBETerm.fsti index 180ea8ebd23..0dbe63e90fa 100644 --- a/src/typechecker/FStar.TypeChecker.NBETerm.fsti +++ b/src/typechecker/FStar.TypeChecker.NBETerm.fsti @@ -29,7 +29,7 @@ open FStar.Char module S = FStar.Syntax.Syntax module U = FStar.Syntax.Util module Z = FStar.BigInt - +module TEQ = FStar.TypeChecker.TermEqAndSimplify open FStar.Class.Show val interleave_hack : int @@ -238,7 +238,7 @@ class embedding (a:Type0) = { e_typ : unit -> emb_typ; } -val eq_t : t -> t -> U.eq_result +val eq_t : Env.env_t -> t -> t -> TEQ.eq_result // Printing functions diff --git a/src/typechecker/FStar.TypeChecker.Normalize.Unfolding.fst b/src/typechecker/FStar.TypeChecker.Normalize.Unfolding.fst index 08c273bfbe0..ff4aa39686d 100644 --- a/src/typechecker/FStar.TypeChecker.Normalize.Unfolding.fst +++ b/src/typechecker/FStar.TypeChecker.Normalize.Unfolding.fst @@ -15,6 +15,8 @@ module PC = FStar.Parser.Const module Print = FStar.Syntax.Print module S = FStar.Syntax.Syntax module U = FStar.Syntax.Util +module TEQ = FStar.TypeChecker.TermEqAndSimplify + open FStar.Class.Show (* Max number of warnings to print in a single run. @@ -142,7 +144,7 @@ let should_unfold cfg should_reify fv qninfo : should_unfold_res = meets_some_criterion // UnfoldTac means never unfold FVs marked [@"tac_opaque"] - | _, _, _, _, _, _ when cfg.steps.unfold_tac && BU.for_some (U.attr_eq U.tac_opaque_attr) attrs -> + | _, _, _, _, _, _ when cfg.steps.unfold_tac && BU.for_some (TEQ.eq_tm_bool cfg.tcenv U.tac_opaque_attr) attrs -> log_unfolding cfg (fun () -> BU.print_string " >> tac_opaque, not unfolding\n"); no diff --git a/src/typechecker/FStar.TypeChecker.Normalize.fst b/src/typechecker/FStar.TypeChecker.Normalize.fst index 9986861e353..44d3c5d5070 100644 --- a/src/typechecker/FStar.TypeChecker.Normalize.fst +++ b/src/typechecker/FStar.TypeChecker.Normalize.fst @@ -48,7 +48,7 @@ module I = FStar.Ident module EMB = FStar.Syntax.Embeddings module Z = FStar.BigInt module TcComm = FStar.TypeChecker.Common - +module TEQ = FStar.TypeChecker.TermEqAndSimplify module PO = FStar.TypeChecker.Primops open FStar.TypeChecker.Normalize.Unfolding @@ -749,7 +749,7 @@ let reduce_primops norm_cb cfg env tm : term & bool = let reduce_equality norm_cb cfg tm = reduce_primops norm_cb ({cfg with steps = { default_steps with primops = true }; - primitive_steps=equality_ops}) tm + primitive_steps=equality_ops cfg.tcenv}) tm (********************************************************************************************************************) (* Main normalization function of the abstract machine *) @@ -1977,7 +1977,7 @@ and do_reify_monadic fallback cfg env stack (top : term) (m : monad_name) (t : t (S.as_arg lb.lbtyp)::(S.as_arg t)::(unit_args@range_args@[S.as_arg f_arg; S.as_arg body]) else let maybe_range_arg = - if BU.for_some (U.attr_eq U.dm4f_bind_range_attr) ed.eff_attrs + if BU.for_some (TEQ.eq_tm_bool cfg.tcenv U.dm4f_bind_range_attr) ed.eff_attrs then [as_arg (PO.embed_simple lb.lbpos lb.lbpos); as_arg (PO.embed_simple body.pos body.pos)] else [] diff --git a/src/typechecker/FStar.TypeChecker.Primops.Base.fsti b/src/typechecker/FStar.TypeChecker.Primops.Base.fsti index f8cc19d07dc..edac4fb7e8d 100644 --- a/src/typechecker/FStar.TypeChecker.Primops.Base.fsti +++ b/src/typechecker/FStar.TypeChecker.Primops.Base.fsti @@ -6,7 +6,7 @@ open FStar.Compiler open FStar.Compiler.Effect open FStar.Compiler.List open FStar.Syntax.Syntax - +module Env = FStar.TypeChecker.Env module EMB = FStar.Syntax.Embeddings module NBE = FStar.TypeChecker.NBETerm diff --git a/src/typechecker/FStar.TypeChecker.Primops.Eq.fst b/src/typechecker/FStar.TypeChecker.Primops.Eq.fst index cc3c0a2ac41..ce471a23881 100644 --- a/src/typechecker/FStar.TypeChecker.Primops.Eq.fst +++ b/src/typechecker/FStar.TypeChecker.Primops.Eq.fst @@ -14,63 +14,65 @@ module S = FStar.Syntax.Syntax module U = FStar.Syntax.Util module EMB = FStar.Syntax.Embeddings module NBE = FStar.TypeChecker.NBETerm +module TEQ = FStar.TypeChecker.TermEqAndSimplify +module Env = FStar.TypeChecker.Env open FStar.TypeChecker.Primops.Base -let s_eq (_typ x y : EMB.abstract_term) : option bool = - match U.eq_tm x.t y.t with - | U.Equal -> Some true - | U.NotEqual -> Some false +let s_eq (env:Env.env_t) (_typ x y : EMB.abstract_term) : option bool = + match TEQ.eq_tm env x.t y.t with + | TEQ.Equal -> Some true + | TEQ.NotEqual -> Some false | _ -> None -let nbe_eq (_typ x y : NBETerm.abstract_nbe_term) : option bool = - match NBETerm.eq_t x.t y.t with - | U.Equal -> Some true - | U.NotEqual -> Some false +let nbe_eq env (_typ x y : NBETerm.abstract_nbe_term) : option bool = + match NBETerm.eq_t env x.t y.t with + | TEQ.Equal -> Some true + | TEQ.NotEqual -> Some false | _ -> None let push3 f g x y z = f (g x y z) let negopt3 = push3 (fmap #option not) -let dec_eq_ops : list primitive_step = [ - mk3' 0 PC.op_Eq s_eq nbe_eq; - mk3' 0 PC.op_notEq (negopt3 s_eq) (negopt3 nbe_eq); +let dec_eq_ops env : list primitive_step = [ + mk3' 0 PC.op_Eq (s_eq env) (nbe_eq env); + mk3' 0 PC.op_notEq (negopt3 (s_eq env)) (negopt3 (nbe_eq env)); ] (* Propositional equality follows. We use the abstract newtypes to easily embed exactly the term we want. *) -let s_eq2 (_typ x y : EMB.abstract_term) : option EMB.abstract_term = - match U.eq_tm x.t y.t with - | U.Equal -> Some (EMB.Abstract U.t_true) - | U.NotEqual -> Some (EMB.Abstract U.t_false) +let s_eq2 env (_typ x y : EMB.abstract_term) : option EMB.abstract_term = + match TEQ.eq_tm env x.t y.t with + | TEQ.Equal -> Some (EMB.Abstract U.t_true) + | TEQ.NotEqual -> Some (EMB.Abstract U.t_false) | _ -> None -let nbe_eq2 (_typ x y : NBE.abstract_nbe_term) : option NBE.abstract_nbe_term = +let nbe_eq2 env (_typ x y : NBE.abstract_nbe_term) : option NBE.abstract_nbe_term = let open FStar.TypeChecker.NBETerm in - match NBETerm.eq_t x.t y.t with - | U.Equal -> Some (AbstractNBE (mkFV (S.lid_as_fv PC.true_lid None) [] [])) - | U.NotEqual -> Some (AbstractNBE (mkFV (S.lid_as_fv PC.false_lid None) [] [])) - | U.Unknown -> None + match NBETerm.eq_t env x.t y.t with + | TEQ.Equal -> Some (AbstractNBE (mkFV (S.lid_as_fv PC.true_lid None) [] [])) + | TEQ.NotEqual -> Some (AbstractNBE (mkFV (S.lid_as_fv PC.false_lid None) [] [])) + | TEQ.Unknown -> None -let s_eq3 (typ1 typ2 x y : EMB.abstract_term) : option EMB.abstract_term = - match U.eq_tm typ1.t typ2.t, U.eq_tm x.t y.t with - | U.Equal, U.Equal -> Some (EMB.Abstract U.t_true) - | U.NotEqual, _ - | _, U.NotEqual -> +let s_eq3 env (typ1 typ2 x y : EMB.abstract_term) : option EMB.abstract_term = + match TEQ.eq_tm env typ1.t typ2.t, TEQ.eq_tm env x.t y.t with + | TEQ.Equal, TEQ.Equal -> Some (EMB.Abstract U.t_true) + | TEQ.NotEqual, _ + | _, TEQ.NotEqual -> Some (EMB.Abstract U.t_false) | _ -> None -let nbe_eq3 (typ1 typ2 x y : NBE.abstract_nbe_term) : option NBE.abstract_nbe_term = +let nbe_eq3 env (typ1 typ2 x y : NBE.abstract_nbe_term) : option NBE.abstract_nbe_term = let open FStar.TypeChecker.NBETerm in - match eq_t typ1.t typ2.t, eq_t x.t y.t with - | U.Equal, U.Equal -> Some (AbstractNBE (mkFV (S.lid_as_fv PC.true_lid None) [] [])) - | U.NotEqual, _ - | _, U.NotEqual -> + match eq_t env typ1.t typ2.t, eq_t env x.t y.t with + | TEQ.Equal, TEQ.Equal -> Some (AbstractNBE (mkFV (S.lid_as_fv PC.true_lid None) [] [])) + | TEQ.NotEqual, _ + | _, TEQ.NotEqual -> Some (AbstractNBE (mkFV (S.lid_as_fv PC.false_lid None) [] [])) | _ -> None -let prop_eq_ops : list primitive_step = [ - mk3' 1 PC.eq2_lid s_eq2 nbe_eq2; - mk4' 2 PC.eq3_lid s_eq3 nbe_eq3; +let prop_eq_ops env : list primitive_step = [ + mk3' 1 PC.eq2_lid (s_eq2 env) (nbe_eq2 env); + mk4' 2 PC.eq3_lid (s_eq3 env) (nbe_eq3 env); ] diff --git a/src/typechecker/FStar.TypeChecker.Primops.Eq.fsti b/src/typechecker/FStar.TypeChecker.Primops.Eq.fsti index 7dd929e8ac8..c884d7c6a02 100644 --- a/src/typechecker/FStar.TypeChecker.Primops.Eq.fsti +++ b/src/typechecker/FStar.TypeChecker.Primops.Eq.fsti @@ -1,7 +1,7 @@ module FStar.TypeChecker.Primops.Eq - +module Env = FStar.TypeChecker.Env open FStar.TypeChecker.Primops.Base -val dec_eq_ops : list primitive_step +val dec_eq_ops (_:Env.env_t) : list primitive_step -val prop_eq_ops : list primitive_step \ No newline at end of file +val prop_eq_ops (_:Env.env_t) : list primitive_step \ No newline at end of file diff --git a/src/typechecker/FStar.TypeChecker.Primops.fst b/src/typechecker/FStar.TypeChecker.Primops.fst index e19e2e18fe7..ce52eb5fc71 100644 --- a/src/typechecker/FStar.TypeChecker.Primops.fst +++ b/src/typechecker/FStar.TypeChecker.Primops.fst @@ -400,8 +400,9 @@ let built_in_primitive_steps_list : list primitive_step = @ Primops.Erased.ops @ Primops.Docs.ops @ Primops.MachineInts.ops - @ Primops.Eq.dec_eq_ops @ Primops.Errors.Msg.ops -let equality_ops_list : list primitive_step = - Primops.Eq.prop_eq_ops +let equality_ops_list env : list primitive_step = + Primops.Eq.prop_eq_ops env + +let env_dependent_ops (env:Env.env_t) = Primops.Eq.dec_eq_ops env \ No newline at end of file diff --git a/src/typechecker/FStar.TypeChecker.Primops.fsti b/src/typechecker/FStar.TypeChecker.Primops.fsti index 455dc428ba7..39cca74551f 100644 --- a/src/typechecker/FStar.TypeChecker.Primops.fsti +++ b/src/typechecker/FStar.TypeChecker.Primops.fsti @@ -6,4 +6,5 @@ include FStar.TypeChecker.Primops.Base with their implementations. *) val built_in_primitive_steps_list : list primitive_step -val equality_ops_list : list primitive_step +val equality_ops_list (env:Env.env_t) : list primitive_step +val env_dependent_ops (env:Env.env_t) : list primitive_step \ No newline at end of file diff --git a/src/typechecker/FStar.TypeChecker.Rel.fst b/src/typechecker/FStar.TypeChecker.Rel.fst index a95b34d944d..ccddd804b32 100644 --- a/src/typechecker/FStar.TypeChecker.Rel.fst +++ b/src/typechecker/FStar.TypeChecker.Rel.fst @@ -50,6 +50,7 @@ module UF = FStar.Syntax.Unionfind module PC = FStar.Parser.Const module FC = FStar.Const module TcComm = FStar.TypeChecker.Common +module TEQ = FStar.TypeChecker.TermEqAndSimplify instance showable_implicit_checking_status : showable implicit_checking_status = { show = (function @@ -1367,7 +1368,7 @@ let head_matches_delta env smt_ok t1 t2 : (match_result & option (typ&typ)) = //should we always disable Zeta here? in let t' = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.1" steps env t in - if U.eq_tm t t' = U.Equal //if we didn't inline anything + if TEQ.eq_tm env t t' = TEQ.Equal //if we didn't inline anything then None else let _ = if Env.debug env <| Options.Other "RelDelta" then BU.print2 "Inlined %s to %s\n" @@ -1390,7 +1391,7 @@ let head_matches_delta env smt_ok t1 t2 : (match_result & option (typ&typ)) = *) let made_progress t t' = let head, head' = U.head_and_args t |> fst, U.head_and_args t' |> fst in - not (U.eq_tm head head' = U.Equal) in + not (TEQ.eq_tm env head head' = TEQ.Equal) in let rec aux retry n_delta t1 t2 = let r = head_matches env t1 t2 in @@ -2687,7 +2688,7 @@ and solve_binders (bs1:binders) (bs2:binders) (orig:prob) (wl:worklist) let eq_bqual a1 a2 = match a1, a2 with | Some (Implicit b1), Some (Implicit b2) -> - U.Equal //we don't care about comparing the dot qualifier in this context + true //we don't care about comparing the dot qualifier in this context | _ -> U.eq_bqual a1 a2 in @@ -2723,7 +2724,7 @@ and solve_binders (bs1:binders) (bs2:binders) (orig:prob) (wl:worklist) Inl ([rhs_prob], formula), wl | x::xs, y::ys - when (eq_bqual x.binder_qual y.binder_qual = U.Equal && + when (eq_bqual x.binder_qual y.binder_qual && compat_positivity_qualifiers x.binder_positivity y.binder_positivity) -> let hd1, imp = x.binder_bv, x.binder_qual in let hd2, imp' = y.binder_bv, y.binder_qual in @@ -2858,7 +2859,7 @@ and solve_t_flex_rigid_eq (orig:prob) (wl:worklist) (lhs:flex_t) (rhs:term) | None, None -> true | Some (Implicit _), Some a -> a.aqual_implicit && - U.eqlist (fun x y -> U.eq_tm x y = U.Equal) + U.eqlist (fun x y -> TEQ.eq_tm env x y = TEQ.Equal) b.binder_attrs a.aqual_attributes | _ -> false @@ -3175,7 +3176,7 @@ and solve_t_flex_rigid_eq (orig:prob) (wl:worklist) (lhs:flex_t) (rhs:term) UF.rollback tx; inapplicable "Subprobs failed: " (Some lstring) in - if U.eq_tm t_head (U.ctx_uvar_typ ctx_uv) = U.Equal + if TEQ.eq_tm env t_head (U.ctx_uvar_typ ctx_uv) = TEQ.Equal then // // eq_tm doesn't unify, so uvars_head computed remains consistent @@ -3443,7 +3444,7 @@ and solve_t' (problem:tprob) (wl:worklist) : solution = (show head1) (show args1) (show head2) (show args2))) orig else - if nargs=0 || U.eq_args args1 args2=U.Equal //special case: for easily proving things like nat <: nat, or greater_than i <: greater_than i etc. + if nargs=0 || TEQ.eq_args env args1 args2=TEQ.Equal //special case: for easily proving things like nat <: nat, or greater_than i <: greater_than i etc. then if need_unif then solve_t ({problem with lhs=head1; rhs=head2}) wl else solve_head_then wl (fun ok wl -> @@ -3515,8 +3516,8 @@ and solve_t' (problem:tprob) (wl:worklist) : solution = let head1', _ = U.head_and_args t1' in let head2', _ = U.head_and_args t2' in begin - match U.eq_tm head1' head1, U.eq_tm head2' head2 with - | U.Equal, U.Equal -> //unfolding didn't make progress + match TEQ.eq_tm env head1' head1, TEQ.eq_tm env head2' head2 with + | TEQ.Equal, TEQ.Equal -> //unfolding didn't make progress if debug wl <| Options.Other "Rel" then BU.print4 "Unfolding didn't make progress ... got %s ~> %s;\nand %s ~> %s\n" @@ -4240,21 +4241,21 @@ and solve_t' (problem:tprob) (wl:worklist) : solution = let equal t1 t2 : bool = (* Try comparing the terms as they are. If we get Equal or NotEqual, we are done. If we get an Unknown, attempt some normalization. *) - let r = U.eq_tm t1 t2 in + let env = p_env wl orig in + let r = TEQ.eq_tm env t1 t2 in match r with - | U.Equal -> true - | U.NotEqual -> false - | U.Unknown -> + | TEQ.Equal -> true + | TEQ.NotEqual -> false + | TEQ.Unknown -> let steps = [ Env.UnfoldUntil delta_constant; Env.Primops; Env.Beta; Env.Eager_unfolding; Env.Iota ] in - let env = p_env wl orig in let t1 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps env t1 in let t2 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t2 in - U.eq_tm t1 t2 = U.Equal + TEQ.eq_tm env t1 t2 = TEQ.Equal in if (Env.is_interpreted wl.tcenv head1 || Env.is_interpreted wl.tcenv head2) //we have something like (+ x1 x2) =?= (- y1 y2) && problem.relation = EQ diff --git a/src/typechecker/FStar.TypeChecker.TcEffect.fst b/src/typechecker/FStar.TypeChecker.TcEffect.fst index 39299526b31..b9b0ddfd03b 100644 --- a/src/typechecker/FStar.TypeChecker.TcEffect.fst +++ b/src/typechecker/FStar.TypeChecker.TcEffect.fst @@ -38,6 +38,7 @@ module Env = FStar.TypeChecker.Env module N = FStar.TypeChecker.Normalize module TcUtil = FStar.TypeChecker.Util module Gen = FStar.TypeChecker.Generalize +module TEQ = FStar.TypeChecker.TermEqAndSimplify module BU = FStar.Compiler.Util open FStar.Class.Show @@ -254,9 +255,9 @@ let bind_combinator_kind (env:env) U.arrow [S.mk_binder x_bv] (mk_Total g_sig_b_sort) in let g_b_kind = - if U.eq_tm g_sig_b_arrow_t g_b.binder_bv.sort = U.Equal + if TEQ.eq_tm env g_sig_b_arrow_t g_b.binder_bv.sort = TEQ.Equal then Substitutive_binder - else if U.eq_tm g_sig_b_sort g_b.binder_bv.sort = U.Equal + else if TEQ.eq_tm env g_sig_b_sort g_b.binder_bv.sort = TEQ.Equal then BindCont_no_abstraction_binder else Ad_hoc_binder in let ss = ss@[NT (g_sig_b.binder_bv, g_b.binder_bv |> S.bv_to_name)] in @@ -301,7 +302,7 @@ let bind_combinator_kind (env:env) result_typ = a_b.binder_bv |> S.bv_to_name; effect_args = repr_app_bs |> List.map (fun b -> b.binder_bv |> S.bv_to_name |> S.as_arg); flags = []})) in - if U.eq_tm f_b.binder_bv.sort expected_f_b_sort = U.Equal + if TEQ.eq_tm env f_b.binder_bv.sort expected_f_b_sort = TEQ.Equal then Some () else None in @@ -335,7 +336,7 @@ let bind_combinator_kind (env:env) effect_args = repr_args; flags = []})) in U.arrow [x_bv |> S.mk_binder] (mk_Total thunk_t) in - if U.eq_tm g_b.binder_bv.sort expected_g_b_sort = U.Equal + if TEQ.eq_tm env g_b.binder_bv.sort expected_g_b_sort = TEQ.Equal then Some () else None in @@ -579,7 +580,7 @@ let subcomp_combinator_kind (env:env) result_typ = a_b.binder_bv |> S.bv_to_name; effect_args = (eff_params_bs@f_bs) |> List.map (fun b -> b.binder_bv |> S.bv_to_name |> S.as_arg); flags = []})) in - if U.eq_tm f_b.binder_bv.sort expected_f_b_sort = U.Equal + if TEQ.eq_tm env f_b.binder_bv.sort expected_f_b_sort = TEQ.Equal then Some () else None in @@ -600,7 +601,7 @@ let subcomp_combinator_kind (env:env) result_typ = a_b.binder_bv |> S.bv_to_name; effect_args = (eff_params_bs@f_or_g_bs) |> List.map (fun b -> b.binder_bv |> S.bv_to_name |> S.as_arg); flags = []})) in - if U.eq_tm (U.comp_result k_c) expected_t = U.Equal + if TEQ.eq_tm env (U.comp_result k_c) expected_t = TEQ.Equal then Some () else None in @@ -810,7 +811,7 @@ let ite_combinator_kind (env:env) ((a_b.binder_bv |> S.bv_to_name |> S.as_arg):: (List.map (fun {binder_bv=b} -> b |> S.bv_to_name |> S.as_arg) (eff_params_bs@f_bs))) Range.dummyRange in - if U.eq_tm f_b.binder_bv.sort expected_f_b_sort = U.Equal + if TEQ.eq_tm env f_b.binder_bv.sort expected_f_b_sort = TEQ.Equal then Some () else None in @@ -821,7 +822,7 @@ let ite_combinator_kind (env:env) ((a_b.binder_bv |> S.bv_to_name |> S.as_arg):: (List.map (fun {binder_bv=b} -> b |> S.bv_to_name |> S.as_arg) (eff_params_bs@f_or_g_bs))) Range.dummyRange in - if U.eq_tm g_b.binder_bv.sort expected_g_b_sort = U.Equal + if TEQ.eq_tm env g_b.binder_bv.sort expected_g_b_sort = TEQ.Equal then Some () else None in @@ -1078,7 +1079,7 @@ let lift_combinator_kind (env:env) result_typ = a_b.binder_bv |> S.bv_to_name; effect_args = f_bs |> List.map (fun b -> b.binder_bv |> S.bv_to_name |> S.as_arg); flags = []})) in - if U.eq_tm f_b.binder_bv.sort expected_f_b_sort = U.Equal + if TEQ.eq_tm env f_b.binder_bv.sort expected_f_b_sort = TEQ.Equal then Some () else None in @@ -2221,7 +2222,7 @@ Errors.with_ctx (BU.format1 "While checking effect definition `%s`" (string_of_l mk_repr b wp in let maybe_range_arg = - if BU.for_some (U.attr_eq U.dm4f_bind_range_attr) ed.eff_attrs + if BU.for_some (TEQ.eq_tm_bool env U.dm4f_bind_range_attr) ed.eff_attrs then [S.null_binder S.t_range; S.null_binder S.t_range] else [] in diff --git a/src/typechecker/FStar.TypeChecker.TcTerm.fst b/src/typechecker/FStar.TypeChecker.TcTerm.fst index 53f9584497e..9f59ce15063 100644 --- a/src/typechecker/FStar.TypeChecker.TcTerm.fst +++ b/src/typechecker/FStar.TypeChecker.TcTerm.fst @@ -49,6 +49,7 @@ module U = FStar.Syntax.Util module PP = FStar.Syntax.Print module UF = FStar.Syntax.Unionfind module Const = FStar.Parser.Const +module TEQ = FStar.TypeChecker.TermEqAndSimplify (* Some local utilities *) let instantiate_both env = {env with Env.instantiate_imp=true} @@ -555,7 +556,7 @@ let guard_letrecs env actuals expected_c : list (lbname*typ*univ_names) = let t1 = env.typeof_well_typed_tot_or_gtot_term env e1 false |> fst |> U.unrefine in let t2 = env.typeof_well_typed_tot_or_gtot_term env e2 false |> fst |> U.unrefine in let rec warn t1 t2 = - if U.eq_tm t1 t2 = Equal + if TEQ.eq_tm env t1 t2 = TEQ.Equal then false else match (SS.compress t1).n, (SS.compress t2).n with | Tm_uinst (t1, _), Tm_uinst (t2, _) -> warn t1 t2 @@ -619,7 +620,7 @@ let guard_letrecs env actuals expected_c : list (lbname*typ*univ_names) = * just prove that (rel e e_prev) *) let rel_guard = mk_Tm_app rel [as_arg e; as_arg e_prev] r in - if U.eq_tm rel rel_prev = U.Equal + if TEQ.eq_tm env rel rel_prev = TEQ.Equal then rel_guard else ( (* if the relation is dependent on parameters in scope, @@ -2153,7 +2154,7 @@ and tc_abs_check_binders env bs bs_expected use_eq | Some (Implicit _), Some (Meta _) -> true | _ -> false in - if not (special imp imp') && U.eq_bqual imp imp' <> U.Equal + if not (special imp imp') && not (U.eq_bqual imp imp') then raise_error (Errors.Fatal_InconsistentImplicitArgumentAnnotation, BU.format1 "Inconsistent implicit argument annotation on argument %s" (Print.bv_to_string hd)) (S.range_of_bv hd) @@ -2214,7 +2215,7 @@ and tc_abs_check_binders env bs bs_expected use_eq let hd = {hd with sort=t} in let combine_attrs (attrs:list S.attribute) (attrs':list S.attribute) : list S.attribute = let diff = List.filter (fun attr' -> - not (List.existsb (fun attr -> U.eq_tm attr attr' = U.Equal) attrs) + not (List.existsb (fun attr -> TEQ.eq_tm env attr attr' = TEQ.Equal) attrs) ) attrs' in attrs@diff in diff --git a/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst b/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst new file mode 100644 index 00000000000..c92b131b4a7 --- /dev/null +++ b/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst @@ -0,0 +1,531 @@ +module FStar.TypeChecker.TermEqAndSimplify +open FStar.Pervasives +open FStar.Compiler.Effect +open FStar.Compiler +open FStar.Compiler.Util +open FStar.Syntax +open FStar.Const +open FStar.Ident +open FStar.TypeChecker.Env +open FStar.Syntax.Syntax +open FStar.Syntax.Util +module SS = FStar.Syntax.Subst +module U = FStar.Syntax.Util +module PC = FStar.Parser.Const +module S = FStar.Syntax.Syntax +module BU = FStar.Compiler.Util + +// Functions that we specially treat as injective, to make normalization +// (particularly of decidable equality) better. We should make sure they +// are actually proved to be injective. +let injectives = + ["FStar.Int8.int_to_t"; + "FStar.Int16.int_to_t"; + "FStar.Int32.int_to_t"; + "FStar.Int64.int_to_t"; + "FStar.Int128.int_to_t"; + "FStar.UInt8.uint_to_t"; + "FStar.UInt16.uint_to_t"; + "FStar.UInt32.uint_to_t"; + "FStar.UInt64.uint_to_t"; + "FStar.UInt128.uint_to_t"; + "FStar.SizeT.uint_to_t"; + "FStar.Int8.__int_to_t"; + "FStar.Int16.__int_to_t"; + "FStar.Int32.__int_to_t"; + "FStar.Int64.__int_to_t"; + "FStar.Int128.__int_to_t"; + "FStar.UInt8.__uint_to_t"; + "FStar.UInt16.__uint_to_t"; + "FStar.UInt32.__uint_to_t"; + "FStar.UInt64.__uint_to_t"; + "FStar.UInt128.__uint_to_t"; + "FStar.SizeT.__uint_to_t"; + ] + +// Compose two eq_result injectively, as in a pair +let eq_inj r s = + match r, s with + | Equal, Equal -> Equal + | NotEqual, _ + | _, NotEqual -> NotEqual + | _, _ -> Unknown + +// Promote a bool to eq_result, conservatively. +let equal_if = function + | true -> Equal + | _ -> Unknown + +// Promote a bool to an eq_result, taking a false to bet NotEqual. +// This is only useful for fully decidable equalities. +// Use with care, see note about Const_real below and #2806. +let equal_iff = function + | true -> Equal + | _ -> NotEqual + +// Compose two equality results, NOT assuming a NotEqual implies anything. +// This is useful, e.g., for checking the equality of applications. Consider +// f x ~ g y +// if f=g and x=y then we know these two expressions are equal, but cannot say +// anything when either result is NotEqual or Unknown, hence this returns Unknown +// in most cases. +// The second comparison is thunked for efficiency. +let eq_and r s = + if r = Equal && s () = Equal + then Equal + else Unknown + +(* Precondition: terms are well-typed in a common environment, or this can return false positives *) +let rec eq_tm (env:env_t) (t1:term) (t2:term) : eq_result = + let eq_tm = eq_tm env in + let t1 = canon_app t1 in + let t2 = canon_app t2 in + let equal_data (f1:fv) (args1:Syntax.args) (f2:fv) (args2:Syntax.args) = + // we got constructors! we know they are injective and disjoint, so we can do some + // good analysis on them + if fv_eq f1 f2 + then ( + assert (List.length args1 = List.length args2); + List.fold_left (fun acc ((a1, q1), (a2, q2)) -> + //if q1 <> q2 + //then failwith (U.format1 "Arguments of %s mismatch on implicit qualifier\n" + // (Ident.string_of_lid f1.fv_name.v)); + //NS: 05/06/2018 ...this does not always hold + // it's been succeeding because the assert is disabled in the non-debug builds + //assert (q1 = q2); + eq_inj acc (eq_tm a1 a2)) Equal <| List.zip args1 args2 + ) else NotEqual + in + let qual_is_inj = function + | Some Data_ctor + | Some (Record_ctor _) -> true + | _ -> false + in + let heads_and_args_in_case_both_data :option (fv * args * fv * args) = + let head1, args1 = t1 |> unmeta |> head_and_args in + let head2, args2 = t2 |> unmeta |> head_and_args in + match (un_uinst head1).n, (un_uinst head2).n with + | Tm_fvar f, Tm_fvar g when qual_is_inj f.fv_qual && + qual_is_inj g.fv_qual -> Some (f, args1, g, args2) + | _ -> None + in + let t1 = unmeta t1 in + let t2 = unmeta t2 in + match t1.n, t2.n with + // We sometimes compare open terms, as we get alpha-equivalence + // for free. + | Tm_bvar bv1, Tm_bvar bv2 -> + equal_if (bv1.index = bv2.index) + + | Tm_lazy _, _ -> eq_tm (unlazy t1) t2 + | _, Tm_lazy _ -> eq_tm t1 (unlazy t2) + + | Tm_name a, Tm_name b -> + equal_if (bv_eq a b) + + | _ when heads_and_args_in_case_both_data |> Some? -> //matches only when both are data constructors + heads_and_args_in_case_both_data |> must |> (fun (f, args1, g, args2) -> + equal_data f args1 g args2 + ) + + | Tm_fvar f, Tm_fvar g -> equal_if (fv_eq f g) + + | Tm_uinst(f, us), Tm_uinst(g, vs) -> + // If the fvars and universe instantiations match, then Equal, + // otherwise Unknown. + eq_and (eq_tm f g) (fun () -> equal_if (eq_univs_list us vs)) + + | Tm_constant (Const_range _), Tm_constant (Const_range _) -> + // Ranges should be opaque, even to the normalizer. c.f. #1312 + Unknown + + | Tm_constant (Const_real r1), Tm_constant (Const_real r2) -> + // We cannot decide equality of reals. Use a conservative approach here. + // If the strings match, they are equal, otherwise we don't know. If this + // goes via the eq_iff case below, it will falsely claim that "1.0R" and + // "01.R" are different, since eq_const does not canonizalize the string + // representations. + equal_if (r1 = r2) + + | Tm_constant c, Tm_constant d -> + // NOTE: this relies on the fact that eq_const *correctly decides* + // semantic equality of constants. This needs some care. For instance, + // since integers are represented by a string, eq_const needs to take care + // of ignoring leading zeroes, and match 0 with -0. An exception to this + // are real number literals (handled above). See #2806. + // + // Currently (24/Jan/23) this seems to be correctly implemented, but + // updates should be done with care. + equal_iff (eq_const c d) + + | Tm_uvar (u1, ([], _)), Tm_uvar (u2, ([], _)) -> + equal_if (Unionfind.equiv u1.ctx_uvar_head u2.ctx_uvar_head) + + | Tm_app {hd=h1; args=args1}, Tm_app {hd=h2; args=args2} -> + begin match (un_uinst h1).n, (un_uinst h2).n with + | Tm_fvar f1, Tm_fvar f2 when fv_eq f1 f2 && List.mem (string_of_lid (lid_of_fv f1)) injectives -> + equal_data f1 args1 f2 args2 + + | _ -> // can only assert they're equal if they syntactically match, nothing else + eq_and (eq_tm h1 h2) (fun () -> eq_args env args1 args2) + end + + | Tm_match {scrutinee=t1; brs=bs1}, Tm_match {scrutinee=t2; brs=bs2} -> //AR: note: no return annotations + if List.length bs1 = List.length bs2 + then List.fold_right (fun (b1, b2) a -> eq_and a (fun () -> branch_matches env b1 b2)) + (List.zip bs1 bs2) + (eq_tm t1 t2) + else Unknown + + | Tm_type u, Tm_type v -> + equal_if (eq_univs u v) + + | Tm_quoted (t1, q1), Tm_quoted (t2, q2) -> + // NOTE: we do NOT ever provide a meaningful result for quoted terms. Even + // if term_eq (the syntactic equality) returns true, that does not mean we + // can present the equality to userspace since term_eq ignores the names + // of binders, but the view exposes them. Hence, we simply always return + // Unknown. We do not seem to rely anywhere on simplifying equalities of + // quoted literals. See also #2806. + Unknown + + | Tm_refine {b=t1; phi=phi1}, Tm_refine {b=t2; phi=phi2} -> + eq_and (eq_tm t1.sort t2.sort) (fun () -> eq_tm phi1 phi2) + + (* + * AR: ignoring residual comp here, that's an ascription added by the typechecker + * do we care if that's different? + *) + | Tm_abs {bs=bs1; body=body1}, Tm_abs {bs=bs2; body=body2} + when List.length bs1 = List.length bs2 -> + + eq_and (List.fold_left2 (fun r b1 b2 -> eq_and r (fun () -> eq_tm b1.binder_bv.sort b2.binder_bv.sort)) + Equal bs1 bs2) + (fun () -> eq_tm body1 body2) + + | Tm_arrow {bs=bs1; comp=c1}, Tm_arrow {bs=bs2; comp=c2} + when List.length bs1 = List.length bs2 -> + eq_and (List.fold_left2 (fun r b1 b2 -> eq_and r (fun () -> eq_tm b1.binder_bv.sort b2.binder_bv.sort)) + Equal bs1 bs2) + (fun () -> eq_comp env c1 c2) + + | _ -> Unknown + +and eq_antiquotations (env:env_t) a1 a2 = + // Basically this; + // List.fold_left2 (fun acc t1 t2 -> eq_inj acc (eq_tm t1 t2)) Equal a1 a2 + // but lazy and handling lists of different size + match a1, a2 with + | [], [] -> Equal + | [], _ + | _, [] -> NotEqual + | t1::a1, t2::a2 -> + match eq_tm env t1 t2 with + | NotEqual -> NotEqual + | Unknown -> + (match eq_antiquotations env a1 a2 with + | NotEqual -> NotEqual + | _ -> Unknown) + | Equal -> eq_antiquotations env a1 a2 + +and branch_matches env b1 b2 = + let related_by f o1 o2 = + match o1, o2 with + | None, None -> true + | Some x, Some y -> f x y + | _, _ -> false + in + let (p1, w1, t1) = b1 in + let (p2, w2, t2) = b2 in + if eq_pat p1 p2 + then begin + // We check the `when` branches too, even if unsupported for now + if eq_tm env t1 t2 = Equal && related_by (fun t1 t2 -> eq_tm env t1 t2 = Equal) w1 w2 + then Equal + else Unknown + end + else Unknown + +and eq_args env (a1:args) (a2:args) : eq_result = + match a1, a2 with + | [], [] -> Equal + | (a, _)::a1, (b, _)::b1 -> + (match eq_tm env a b with + | Equal -> eq_args env a1 b1 + | _ -> Unknown) + | _ -> Unknown + +and eq_comp env (c1 c2:comp) : eq_result = + match c1.n, c2.n with + | Total t1, Total t2 + | GTotal t1, GTotal t2 -> + eq_tm env t1 t2 + | Comp ct1, Comp ct2 -> + eq_and (equal_if (eq_univs_list ct1.comp_univs ct2.comp_univs)) + (fun _ -> + eq_and (equal_if (Ident.lid_equals ct1.effect_name ct2.effect_name)) + (fun _ -> + eq_and (eq_tm env ct1.result_typ ct2.result_typ) + (fun _ -> eq_args env ct1.effect_args ct2.effect_args))) + //ignoring cflags + | _ -> NotEqual + +let eq_tm_bool e t1 t2 = eq_tm e t1 t2 = Equal + +let simplify (debug:bool) (env:env_t) (tm:term) : term = + let w t = {t with pos=tm.pos} in + let simp_t t = + // catch annotated subformulae too + match (U.unmeta t).n with + | Tm_fvar fv when S.fv_eq_lid fv PC.true_lid -> Some true + | Tm_fvar fv when S.fv_eq_lid fv PC.false_lid -> Some false + | _ -> None + in + let rec args_are_binders args bs = + match args, bs with + | (t, _)::args, b::bs -> + begin match (SS.compress t).n with + | Tm_name bv' -> S.bv_eq b.binder_bv bv' && args_are_binders args bs + | _ -> false + end + | [], [] -> true + | _, _ -> false + in + let is_applied (bs:binders) (t : term) : option bv = + if debug then + BU.print2 "WPE> is_applied %s -- %s\n" (Print.term_to_string t) (Print.tag_of_term t); + let hd, args = U.head_and_args_full t in + match (SS.compress hd).n with + | Tm_name bv when args_are_binders args bs -> + if debug then + BU.print3 "WPE> got it\n>>>>top = %s\n>>>>b = %s\n>>>>hd = %s\n" + (Print.term_to_string t) + (Print.bv_to_string bv) + (Print.term_to_string hd); + Some bv + | _ -> None + in + let is_applied_maybe_squashed (bs : binders) (t : term) : option bv = + if debug then + BU.print2 "WPE> is_applied_maybe_squashed %s -- %s\n" (Print.term_to_string t) (Print.tag_of_term t); + match is_squash t with + + | Some (_, t') -> is_applied bs t' + | _ -> begin match is_auto_squash t with + | Some (_, t') -> is_applied bs t' + | _ -> is_applied bs t + end + in + let is_const_match (phi : term) : option bool = + match (SS.compress phi).n with + (* Trying to be efficient, but just checking if they all agree *) + (* Note, if we wanted to do this for any term instead of just True/False + * we need to open the terms *) + | Tm_match {brs=br::brs} -> + let (_, _, e) = br in + let r = begin match simp_t e with + | None -> None + | Some b -> if List.for_all (fun (_, _, e') -> simp_t e' = Some b) brs + then Some b + else None + end + in + r + | _ -> None + in + let maybe_auto_squash t = + if U.is_sub_singleton t + then t + else U.mk_auto_squash U_zero t + in + let squashed_head_un_auto_squash_args t = + //The head of t is already a squashed operator, e.g. /\ etc. + //no point also squashing its arguments if they're already in U_zero + let maybe_un_auto_squash_arg (t,q) = + match U.is_auto_squash t with + | Some (U_zero, t) -> + //if we're squashing from U_zero to U_zero + // then just remove it + t, q + | _ -> + t,q + in + let head, args = U.head_and_args t in + let args = List.map maybe_un_auto_squash_arg args in + S.mk_Tm_app head args t.pos + in + let rec clearly_inhabited (ty : typ) : bool = + match (U.unmeta ty).n with + | Tm_uinst (t, _) -> clearly_inhabited t + | Tm_arrow {comp=c} -> clearly_inhabited (U.comp_result c) + | Tm_fvar fv -> + let l = S.lid_of_fv fv in + (Ident.lid_equals l PC.int_lid) + || (Ident.lid_equals l PC.bool_lid) + || (Ident.lid_equals l PC.string_lid) + || (Ident.lid_equals l PC.exn_lid) + | _ -> false + in + let simplify arg = (simp_t (fst arg), arg) in + match (SS.compress tm).n with + | Tm_app {hd={n=Tm_uinst({n=Tm_fvar fv}, _)}; args} + | Tm_app {hd={n=Tm_fvar fv}; args} -> + if S.fv_eq_lid fv PC.and_lid + then match args |> List.map simplify with + | [(Some true, _); (_, (arg, _))] + | [(_, (arg, _)); (Some true, _)] -> maybe_auto_squash arg + | [(Some false, _); _] + | [_; (Some false, _)] -> w U.t_false + | _ -> squashed_head_un_auto_squash_args tm + else if S.fv_eq_lid fv PC.or_lid + then match args |> List.map simplify with + | [(Some true, _); _] + | [_; (Some true, _)] -> w U.t_true + | [(Some false, _); (_, (arg, _))] + | [(_, (arg, _)); (Some false, _)] -> maybe_auto_squash arg + | _ -> squashed_head_un_auto_squash_args tm + else if S.fv_eq_lid fv PC.imp_lid + then match args |> List.map simplify with + | [_; (Some true, _)] + | [(Some false, _); _] -> w U.t_true + | [(Some true, _); (_, (arg, _))] -> maybe_auto_squash arg + | [(_, (p, _)); (_, (q, _))] -> + if U.term_eq p q + then w U.t_true + else squashed_head_un_auto_squash_args tm + | _ -> squashed_head_un_auto_squash_args tm + else if S.fv_eq_lid fv PC.iff_lid + then match args |> List.map simplify with + | [(Some true, _) ; (Some true, _)] + | [(Some false, _) ; (Some false, _)] -> w U.t_true + | [(Some true, _) ; (Some false, _)] + | [(Some false, _) ; (Some true, _)] -> w U.t_false + | [(_, (arg, _)) ; (Some true, _)] + | [(Some true, _) ; (_, (arg, _))] -> maybe_auto_squash arg + | [(_, (arg, _)) ; (Some false, _)] + | [(Some false, _) ; (_, (arg, _))] -> maybe_auto_squash (U.mk_neg arg) + | [(_, (p, _)); (_, (q, _))] -> + if U.term_eq p q + then w U.t_true + else squashed_head_un_auto_squash_args tm + | _ -> squashed_head_un_auto_squash_args tm + else if S.fv_eq_lid fv PC.not_lid + then match args |> List.map simplify with + | [(Some true, _)] -> w U.t_false + | [(Some false, _)] -> w U.t_true + | _ -> squashed_head_un_auto_squash_args tm + else if S.fv_eq_lid fv PC.forall_lid + then match args with + (* Simplify ∀x. True to True *) + | [(t, _)] -> + begin match (SS.compress t).n with + | Tm_abs {bs=[_]; body} -> + (match simp_t body with + | Some true -> w U.t_true + | _ -> tm) + | _ -> tm + end + (* Simplify ∀x. True to True, and ∀x. False to False, if the domain is not empty *) + | [(ty, Some ({ aqual_implicit = true })); (t, _)] -> + begin match (SS.compress t).n with + | Tm_abs {bs=[_]; body} -> + (match simp_t body with + | Some true -> w U.t_true + | Some false when clearly_inhabited ty -> w U.t_false + | _ -> tm) + | _ -> tm + end + | _ -> tm + else if S.fv_eq_lid fv PC.exists_lid + then match args with + (* Simplify ∃x. False to False *) + | [(t, _)] -> + begin match (SS.compress t).n with + | Tm_abs {bs=[_]; body} -> + (match simp_t body with + | Some false -> w U.t_false + | _ -> tm) + | _ -> tm + end + (* Simplify ∃x. False to False and ∃x. True to True, if the domain is not empty *) + | [(ty, Some ({ aqual_implicit = true })); (t, _)] -> + begin match (SS.compress t).n with + | Tm_abs {bs=[_]; body} -> + (match simp_t body with + | Some false -> w U.t_false + | Some true when clearly_inhabited ty -> w U.t_true + | _ -> tm) + | _ -> tm + end + | _ -> tm + else if S.fv_eq_lid fv PC.b2t_lid + then match args with + | [{n=Tm_constant (Const_bool true)}, _] -> w U.t_true + | [{n=Tm_constant (Const_bool false)}, _] -> w U.t_false + | _ -> tm //its arg is a bool, can't unsquash + else if S.fv_eq_lid fv PC.haseq_lid + then begin + (* + * AR: We try to mimic the hasEq related axioms in Prims + * and the axiom related to refinements + * For other types, such as lists, whose hasEq is derived by the typechecker, + * we leave them as is + *) + let t_has_eq_for_sure (t:S.term) :bool = + //Axioms from prims + let haseq_lids = [PC.int_lid; PC.bool_lid; PC.unit_lid; PC.string_lid] in + match (SS.compress t).n with + | Tm_fvar fv when haseq_lids |> List.existsb (fun l -> S.fv_eq_lid fv l) -> true + | _ -> false + in + if List.length args = 1 then + let t = args |> List.hd |> fst in + if t |> t_has_eq_for_sure then w U.t_true + else + match (SS.compress t).n with + | Tm_refine _ -> + let t = U.unrefine t in + if t |> t_has_eq_for_sure then w U.t_true + else + //get the hasEq term itself + let haseq_tm = + match (SS.compress tm).n with + | Tm_app {hd} -> hd + | _ -> failwith "Impossible! We have already checked that this is a Tm_app" + in + //and apply it to the unrefined type + mk_app (haseq_tm) [t |> as_arg] + | _ -> tm + else tm + end + else if S.fv_eq_lid fv PC.eq2_lid + then match args with + | [(_typ, _); (a1, _); (a2, _)] -> //eq2 + (match eq_tm env a1 a2 with + | Equal -> w U.t_true + | NotEqual -> w U.t_false + | _ -> tm) + | _ -> tm + else + begin + match U.is_auto_squash tm with + | Some (U_zero, t) + when U.is_sub_singleton t -> + //remove redundant auto_squashes + t + | _ -> + tm + end + | Tm_refine {b=bv; phi=t} -> + begin match simp_t t with + | Some true -> bv.sort + | Some false -> tm + | None -> tm + end + | Tm_match _ -> + begin match is_const_match tm with + | Some true -> w U.t_true + | Some false -> w U.t_false + | None -> tm + end + | _ -> tm diff --git a/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fsti b/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fsti new file mode 100644 index 00000000000..ba368f6f6de --- /dev/null +++ b/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fsti @@ -0,0 +1,16 @@ +module FStar.TypeChecker.TermEqAndSimplify +open FStar.Pervasives +open FStar.Compiler.Effect +open FStar.TypeChecker.Env +open FStar.Syntax.Syntax + +type eq_result = + | Equal + | NotEqual + | Unknown + +val eq_tm (_:env_t) (t1 t2:term) : eq_result +val eq_args (_:env_t) (t1 t2:args) : eq_result +val eq_comp (_:env_t) (t1 t2:comp) : eq_result +val eq_tm_bool (e:env_t) (t1 t2:term) : bool +val simplify (debug:bool) (_:env_t) (_:term) : term diff --git a/src/typechecker/FStar.TypeChecker.Util.fst b/src/typechecker/FStar.TypeChecker.Util.fst index 29cc86c24f8..ffce4b77467 100644 --- a/src/typechecker/FStar.TypeChecker.Util.fst +++ b/src/typechecker/FStar.TypeChecker.Util.fst @@ -46,6 +46,7 @@ module TcComm = FStar.TypeChecker.Common module P = FStar.Syntax.Print module C = FStar.Parser.Const module UF = FStar.Syntax.Unionfind +module TEQ = FStar.TypeChecker.TermEqAndSimplify open FStar.Class.Setlike @@ -2654,7 +2655,7 @@ let weaken_result_typ env (e:term) (lc:lcomp) (t:typ) (use_eq:bool) : term * lco let set_result_typ (c:comp) :comp = Util.set_result_typ c t in - if Util.eq_tm t res_t = Util.Equal then begin //if the two types res_t and t are same, then just set the result type + if TEQ.eq_tm env t res_t = TEQ.Equal then begin //if the two types res_t and t are same, then just set the result type if Env.debug env <| Options.Extreme then BU.print2 "weaken_result_type::strengthen_trivial: res_t:%s is same as t:%s\n" (Print.term_to_string res_t) (Print.term_to_string t); @@ -2848,7 +2849,7 @@ let maybe_instantiate (env:Env.env) e t = let number_of_implicits t = let formals = unfolded_arrow_formals env t in let n_implicits = - match formals |> BU.prefix_until (fun ({binder_qual=imp}) -> Option.isNone imp || U.eq_bqual imp (Some Equality) = U.Equal) with + match formals |> BU.prefix_until (fun ({binder_qual=imp}) -> Option.isNone imp || U.eq_bqual imp (Some Equality)) with | None -> List.length formals | Some (implicits, _first_explicit, _rest) -> List.length implicits in n_implicits From a3ca82c2c3fd0f4ec31841e166b428e5469f4551 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Fri, 26 Apr 2024 15:45:45 -0700 Subject: [PATCH 34/42] revise equality of data constructors to return unknown if the type parameters are not equal --- .../generated/FStar_TypeChecker_Env.ml | 26 +++++++ .../generated/FStar_TypeChecker_NBETerm.ml | 51 +++++++++++--- .../FStar_TypeChecker_TermEqAndSimplify.ml | 70 +++++++++++++++---- src/typechecker/FStar.TypeChecker.Env.fst | 5 ++ src/typechecker/FStar.TypeChecker.Env.fsti | 1 + src/typechecker/FStar.TypeChecker.NBETerm.fst | 22 +++++- .../FStar.TypeChecker.TermEqAndSimplify.fst | 62 +++++++++++----- 7 files changed, 199 insertions(+), 38 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Env.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Env.ml index 0f575764d77..c724c1fbd98 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Env.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Env.ml @@ -3590,6 +3590,32 @@ let (typ_of_datacon : env -> FStar_Ident.lident -> FStar_Ident.lident) = let uu___3 = FStar_Syntax_Print.lid_to_string lid in FStar_Compiler_Util.format1 "Not a datacon: %s" uu___3 in FStar_Compiler_Effect.failwith uu___2 +let (num_datacon_ty_params : + env -> FStar_Ident.lident -> Prims.int FStar_Pervasives_Native.option) = + fun env1 -> + fun lid -> + let uu___ = lookup_qname env1 lid in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_datacon + { FStar_Syntax_Syntax.lid1 = uu___1; + FStar_Syntax_Syntax.us1 = uu___2; + FStar_Syntax_Syntax.t1 = uu___3; + FStar_Syntax_Syntax.ty_lid = uu___4; + FStar_Syntax_Syntax.num_ty_params = num_ty_params; + FStar_Syntax_Syntax.mutuals1 = uu___5;_}; + FStar_Syntax_Syntax.sigrng = uu___6; + FStar_Syntax_Syntax.sigquals = uu___7; + FStar_Syntax_Syntax.sigmeta = uu___8; + FStar_Syntax_Syntax.sigattrs = uu___9; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___10; + FStar_Syntax_Syntax.sigopts = uu___11;_}, + uu___12), + uu___13) + -> FStar_Pervasives_Native.Some num_ty_params + | uu___1 -> FStar_Pervasives_Native.None let (lookup_definition_qninfo_aux : Prims.bool -> delta_level Prims.list -> diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml index 8ce4cccdcc6..c168df346fd 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml @@ -495,14 +495,49 @@ let rec (eq_t : FStar_Compiler_Effect.failwith "eq_t, different number of args on Construct" else (); - (let uu___2 = FStar_Compiler_List.zip args1 args2 in - FStar_Compiler_List.fold_left - (fun acc -> - fun uu___3 -> - match uu___3 with - | ((a1, uu___4), (a2, uu___5)) -> - let uu___6 = eq_t env a1 a2 in eq_inj acc uu___6) - FStar_TypeChecker_TermEqAndSimplify.Equal uu___2)) + (let uu___2 = + let uu___3 = FStar_Syntax_Syntax.lid_of_fv v1 in + FStar_TypeChecker_Env.num_datacon_ty_params env uu___3 in + match uu___2 with + | FStar_Pervasives_Native.None -> + FStar_TypeChecker_TermEqAndSimplify.Unknown + | FStar_Pervasives_Native.Some n -> + if n <= (FStar_Compiler_List.length args1) + then + let eq_args1 as1 as2 = + FStar_Compiler_List.fold_left2 + (fun acc -> + fun uu___3 -> + fun uu___4 -> + match (uu___3, uu___4) with + | ((a1, uu___5), (a2, uu___6)) -> + let uu___7 = eq_t env a1 a2 in + eq_inj acc uu___7) + FStar_TypeChecker_TermEqAndSimplify.Equal as1 as2 in + let uu___3 = FStar_Compiler_List.splitAt n args1 in + (match uu___3 with + | (parms1, args11) -> + let uu___4 = FStar_Compiler_List.splitAt n args2 in + (match uu___4 with + | (parms2, args21) -> + let uu___5 = + let uu___6 = eq_args1 args11 args21 in + uu___6 = + FStar_TypeChecker_TermEqAndSimplify.Equal in + if uu___5 + then + let uu___6 = + let uu___7 = eq_args1 parms1 parms2 in + uu___7 = + FStar_TypeChecker_TermEqAndSimplify.Equal in + (if uu___6 + then + FStar_TypeChecker_TermEqAndSimplify.Equal + else + FStar_TypeChecker_TermEqAndSimplify.Unknown) + else + FStar_TypeChecker_TermEqAndSimplify.NotEqual)) + else FStar_TypeChecker_TermEqAndSimplify.Unknown)) else FStar_TypeChecker_TermEqAndSimplify.NotEqual | (FV (v1, us1, args1), FV (v2, us2, args2)) -> let uu___ = FStar_Syntax_Syntax.fv_eq v1 v2 in diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml index cd2b0c70cef..64154508e6c 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml @@ -59,18 +59,33 @@ let rec (eq_tm : let eq_tm1 = eq_tm env in let t11 = FStar_Syntax_Util.canon_app t1 in let t21 = FStar_Syntax_Util.canon_app t2 in - let equal_data f1 args1 f2 args2 = + let equal_data f1 parms1 args1 f2 parms2 args2 = let uu___ = FStar_Syntax_Syntax.fv_eq f1 f2 in if uu___ then - let uu___1 = FStar_Compiler_List.zip args1 args2 in - FStar_Compiler_List.fold_left - (fun acc -> - fun uu___2 -> - match uu___2 with - | ((a1, q1), (a2, q2)) -> - let uu___3 = eq_tm1 a1 a2 in eq_inj acc uu___3) Equal - uu___1 + (if + ((FStar_Compiler_List.length parms1) = + (FStar_Compiler_List.length parms2)) + && + ((FStar_Compiler_List.length args1) = + (FStar_Compiler_List.length args2)) + then + let eq_arg_list as1 as2 = + FStar_Compiler_List.fold_left2 + (fun acc -> + fun uu___1 -> + fun uu___2 -> + match (uu___1, uu___2) with + | ((a1, q1), (a2, q2)) -> + let uu___3 = eq_tm1 a1 a2 in eq_inj acc uu___3) + Equal as1 as2 in + let args_eq = eq_arg_list args1 args2 in + (if args_eq = Equal + then + let parms_eq = eq_arg_list parms1 parms2 in + (if parms_eq = Equal then Equal else Unknown) + else args_eq) + else Unknown) else NotEqual in let qual_is_inj uu___ = match uu___ with @@ -103,7 +118,37 @@ let rec (eq_tm : FStar_Syntax_Syntax.Tm_fvar g) when (qual_is_inj f.FStar_Syntax_Syntax.fv_qual) && (qual_is_inj g.FStar_Syntax_Syntax.fv_qual) - -> FStar_Pervasives_Native.Some (f, args1, g, args2) + -> + let uu___3 = + let uu___4 = + let uu___5 = FStar_Syntax_Syntax.lid_of_fv f in + FStar_TypeChecker_Env.num_datacon_ty_params env + uu___5 in + let uu___5 = + let uu___6 = FStar_Syntax_Syntax.lid_of_fv g in + FStar_TypeChecker_Env.num_datacon_ty_params env + uu___6 in + (uu___4, uu___5) in + (match uu___3 with + | (FStar_Pervasives_Native.Some n1, + FStar_Pervasives_Native.Some n2) -> + if + (n1 <= (FStar_Compiler_List.length args1)) && + (n2 <= (FStar_Compiler_List.length args2)) + then + let uu___4 = + FStar_Compiler_List.splitAt n1 args1 in + (match uu___4 with + | (parms1, args11) -> + let uu___5 = + FStar_Compiler_List.splitAt n2 args2 in + (match uu___5 with + | (parms2, args21) -> + FStar_Pervasives_Native.Some + (f, parms1, args11, g, parms2, + args21))) + else FStar_Pervasives_Native.None + | uu___4 -> FStar_Pervasives_Native.None) | uu___3 -> FStar_Pervasives_Native.None)) in let t12 = FStar_Syntax_Util.unmeta t11 in let t22 = FStar_Syntax_Util.unmeta t21 in @@ -125,7 +170,8 @@ let rec (eq_tm : let uu___1 = FStar_Compiler_Util.must heads_and_args_in_case_both_data in (match uu___1 with - | (f, args1, g, args2) -> equal_data f args1 g args2) + | (f, parms1, args1, g, parms2, args2) -> + equal_data f parms1 args1 g parms2 args2) | (FStar_Syntax_Syntax.Tm_fvar f, FStar_Syntax_Syntax.Tm_fvar g) -> let uu___ = FStar_Syntax_Syntax.fv_eq f g in equal_if uu___ | (FStar_Syntax_Syntax.Tm_uinst (f, us), FStar_Syntax_Syntax.Tm_uinst @@ -171,7 +217,7 @@ let rec (eq_tm : let uu___2 = FStar_Syntax_Syntax.lid_of_fv f1 in FStar_Ident.string_of_lid uu___2 in FStar_Compiler_List.mem uu___1 injectives) - -> equal_data f1 args1 f2 args2 + -> equal_data f1 [] args1 f2 [] args2 | uu___1 -> let uu___2 = eq_tm1 h1 h2 in eq_and uu___2 (fun uu___3 -> eq_args env args1 args2)) diff --git a/src/typechecker/FStar.TypeChecker.Env.fst b/src/typechecker/FStar.TypeChecker.Env.fst index c59d0cc38e8..6ce5c890c6c 100644 --- a/src/typechecker/FStar.TypeChecker.Env.fst +++ b/src/typechecker/FStar.TypeChecker.Env.fst @@ -745,6 +745,11 @@ let typ_of_datacon env lid = | Some (Inr ({ sigel = Sig_datacon {ty_lid=l} }, _), _) -> l | _ -> failwith (BU.format1 "Not a datacon: %s" (Print.lid_to_string lid)) +let num_datacon_ty_params env lid = + match lookup_qname env lid with + | Some (Inr ({ sigel = Sig_datacon {num_ty_params} }, _), _) -> Some num_ty_params + | _ -> None + let lookup_definition_qninfo_aux rec_ok delta_levels lid (qninfo : qninfo) = let visible quals = delta_levels |> BU.for_some (fun dl -> quals |> BU.for_some (visible_at dl)) diff --git a/src/typechecker/FStar.TypeChecker.Env.fsti b/src/typechecker/FStar.TypeChecker.Env.fsti index f6d29b1ac6c..f3d76452836 100644 --- a/src/typechecker/FStar.TypeChecker.Env.fsti +++ b/src/typechecker/FStar.TypeChecker.Env.fsti @@ -344,6 +344,7 @@ val is_irreducible : env -> lident -> bool val is_type_constructor : env -> lident -> bool val num_inductive_ty_params: env -> lident -> option int val num_inductive_uniform_ty_params: env -> lident -> option int +val num_datacon_ty_params : env -> lident -> option int val delta_depth_of_qninfo : fv -> qninfo -> option delta_depth val delta_depth_of_fv : env -> fv -> delta_depth diff --git a/src/typechecker/FStar.TypeChecker.NBETerm.fst b/src/typechecker/FStar.TypeChecker.NBETerm.fst index 451f0879ac8..37fbb5a94a0 100644 --- a/src/typechecker/FStar.TypeChecker.NBETerm.fst +++ b/src/typechecker/FStar.TypeChecker.NBETerm.fst @@ -123,8 +123,26 @@ let rec eq_t env (t1 : t) (t2 : t) : TEQ.eq_result = if S.fv_eq v1 v2 then begin if List.length args1 <> List.length args2 then failwith "eq_t, different number of args on Construct"; - List.fold_left (fun acc ((a1, _), (a2, _)) -> - eq_inj acc (eq_t env a1 a2)) TEQ.Equal <| List.zip args1 args2 + match Env.num_datacon_ty_params env (lid_of_fv v1) with + | None -> TEQ.Unknown + | Some n -> + if n <= List.length args1 + then ( + let eq_args as1 as2 = + List.fold_left2 + (fun acc (a1, _) (a2, _) -> eq_inj acc (eq_t env a1 a2)) + TEQ.Equal + as1 as2 + in + let parms1, args1 = List.splitAt n args1 in + let parms2, args2 = List.splitAt n args2 in + if eq_args args1 args2 = TEQ.Equal + then if eq_args parms1 parms2 = TEQ.Equal + then TEQ.Equal + else TEQ.Unknown + else TEQ.NotEqual + ) + else TEQ.Unknown end else TEQ.NotEqual | FV(v1, us1, args1), FV(v2, us2, args2) -> diff --git a/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst b/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst index c92b131b4a7..4b2af53498d 100644 --- a/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst +++ b/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst @@ -80,20 +80,37 @@ let rec eq_tm (env:env_t) (t1:term) (t2:term) : eq_result = let eq_tm = eq_tm env in let t1 = canon_app t1 in let t2 = canon_app t2 in - let equal_data (f1:fv) (args1:Syntax.args) (f2:fv) (args2:Syntax.args) = + let equal_data (f1:fv) (parms1 args1:Syntax.args) (f2:fv) (parms2 args2:Syntax.args) = // we got constructors! we know they are injective and disjoint, so we can do some // good analysis on them if fv_eq f1 f2 then ( - assert (List.length args1 = List.length args2); - List.fold_left (fun acc ((a1, q1), (a2, q2)) -> - //if q1 <> q2 - //then failwith (U.format1 "Arguments of %s mismatch on implicit qualifier\n" - // (Ident.string_of_lid f1.fv_name.v)); - //NS: 05/06/2018 ...this does not always hold - // it's been succeeding because the assert is disabled in the non-debug builds - //assert (q1 = q2); - eq_inj acc (eq_tm a1 a2)) Equal <| List.zip args1 args2 + if List.length parms1 = List.length parms2 + && List.length args1 = List.length args2 + then ( + let eq_arg_list as1 as2 = + List.fold_left2 + (fun acc (a1, q1) (a2, q2) -> + //if q1 <> q2 + //then failwith (U.format1 "Arguments of %s mismatch on implicit qualifier\n" + // (Ident.string_of_lid f1.fv_name.v)); + //NS: 05/06/2018 ...this does not always hold + // it's been succeeding because the assert is disabled in the non-debug builds + //assert (q1 = q2); + eq_inj acc (eq_tm a1 a2)) + Equal + as1 + as2 + in + let args_eq = eq_arg_list args1 args2 in + if args_eq = Equal + then let parms_eq = eq_arg_list parms1 parms2 in + if parms_eq = Equal + then Equal + else Unknown + else args_eq + ) + else Unknown ) else NotEqual in let qual_is_inj = function @@ -101,12 +118,25 @@ let rec eq_tm (env:env_t) (t1:term) (t2:term) : eq_result = | Some (Record_ctor _) -> true | _ -> false in - let heads_and_args_in_case_both_data :option (fv * args * fv * args) = + let heads_and_args_in_case_both_data :option (fv * args * args * fv * args * args) = let head1, args1 = t1 |> unmeta |> head_and_args in let head2, args2 = t2 |> unmeta |> head_and_args in match (un_uinst head1).n, (un_uinst head2).n with - | Tm_fvar f, Tm_fvar g when qual_is_inj f.fv_qual && - qual_is_inj g.fv_qual -> Some (f, args1, g, args2) + | Tm_fvar f, Tm_fvar g + when qual_is_inj f.fv_qual && + qual_is_inj g.fv_qual -> ( + match Env.num_datacon_ty_params env (lid_of_fv f), Env.num_datacon_ty_params env (lid_of_fv g) with + | Some n1, Some n2 -> + if n1 <= List.length args1 + && n2 <= List.length args2 + then ( + let parms1, args1 = List.splitAt n1 args1 in + let parms2, args2 = List.splitAt n2 args2 in + Some (f, parms1, args1, g, parms2, args2) + ) + else None + | _ -> None + ) | _ -> None in let t1 = unmeta t1 in @@ -124,8 +154,8 @@ let rec eq_tm (env:env_t) (t1:term) (t2:term) : eq_result = equal_if (bv_eq a b) | _ when heads_and_args_in_case_both_data |> Some? -> //matches only when both are data constructors - heads_and_args_in_case_both_data |> must |> (fun (f, args1, g, args2) -> - equal_data f args1 g args2 + heads_and_args_in_case_both_data |> must |> (fun (f, parms1, args1, g, parms2, args2) -> + equal_data f parms1 args1 g parms2 args2 ) | Tm_fvar f, Tm_fvar g -> equal_if (fv_eq f g) @@ -164,7 +194,7 @@ let rec eq_tm (env:env_t) (t1:term) (t2:term) : eq_result = | Tm_app {hd=h1; args=args1}, Tm_app {hd=h2; args=args2} -> begin match (un_uinst h1).n, (un_uinst h2).n with | Tm_fvar f1, Tm_fvar f2 when fv_eq f1 f2 && List.mem (string_of_lid (lid_of_fv f1)) injectives -> - equal_data f1 args1 f2 args2 + equal_data f1 [] args1 f2 [] args2 | _ -> // can only assert they're equal if they syntactically match, nothing else eq_and (eq_tm h1 h2) (fun () -> eq_args env args1 args2) From 03d1b17e6720d2bc54315f93f7e7cd0865a2c614 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Fri, 26 Apr 2024 17:20:16 -0700 Subject: [PATCH 35/42] adding an injective_type_params field to Sig_inductive and Sig_datacon --- .../fstar-lib/generated/FStar_CheckedFiles.ml | 2 +- .../generated/FStar_Extraction_ML_Modul.ml | 119 +- .../generated/FStar_Extraction_ML_RegEmb.ml | 305 +-- .../generated/FStar_Reflection_V1_Builtins.ml | 86 +- .../generated/FStar_Reflection_V2_Builtins.ml | 49 +- .../generated/FStar_SMTEncoding_Encode.ml | 1992 +++++++---------- .../fstar-lib/generated/FStar_Syntax_DsEnv.ml | 202 +- .../generated/FStar_Syntax_MutRecTy.ml | 16 +- .../fstar-lib/generated/FStar_Syntax_Print.ml | 56 +- .../generated/FStar_Syntax_Resugar.ml | 136 +- .../generated/FStar_Syntax_Syntax.ml | 59 +- .../fstar-lib/generated/FStar_Syntax_Util.ml | 6 +- .../generated/FStar_Syntax_VisitM.ml | 15 +- .../generated/FStar_Tactics_V1_Basic.ml | 348 +-- .../generated/FStar_Tactics_V2_Basic.ml | 356 +-- .../generated/FStar_ToSyntax_ToSyntax.ml | 259 ++- .../generated/FStar_TypeChecker_Cfg.ml | 4 +- .../generated/FStar_TypeChecker_Env.ml | 246 +- .../generated/FStar_TypeChecker_NBETerm.ml | 3 +- .../generated/FStar_TypeChecker_Normalize.ml | 17 +- .../generated/FStar_TypeChecker_Positivity.ml | 47 +- .../generated/FStar_TypeChecker_Tc.ml | 18 +- .../FStar_TypeChecker_TcInductive.ml | 1083 ++++++--- .../FStar_TypeChecker_TermEqAndSimplify.ml | 8 +- .../generated/FStar_TypeChecker_Util.ml | 34 +- src/fstar/FStar.CheckedFiles.fst | 2 +- .../FStar.Reflection.V1.Builtins.fst | 7 +- .../FStar.Reflection.V2.Builtins.fst | 7 +- src/smtencoding/FStar.SMTEncoding.Encode.fst | 121 +- src/syntax/FStar.Syntax.MutRecTy.fst | 14 +- src/syntax/FStar.Syntax.Syntax.fsti | 2 + src/syntax/FStar.Syntax.VisitM.fst | 8 +- src/tosyntax/FStar.ToSyntax.ToSyntax.fst | 20 +- src/typechecker/FStar.TypeChecker.Cfg.fst | 2 +- src/typechecker/FStar.TypeChecker.Env.fst | 5 +- src/typechecker/FStar.TypeChecker.Env.fsti | 2 +- src/typechecker/FStar.TypeChecker.NBETerm.fst | 2 +- .../FStar.TypeChecker.Normalize.fst | 11 +- .../FStar.TypeChecker.Positivity.fst | 5 +- .../FStar.TypeChecker.TcInductive.fst | 118 +- .../FStar.TypeChecker.TermEqAndSimplify.fst | 3 +- tests/bug-reports/BugBoxInjectivity.fst | 49 + ulib/prims.fst | 2 +- 43 files changed, 3119 insertions(+), 2727 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_CheckedFiles.ml b/ocaml/fstar-lib/generated/FStar_CheckedFiles.ml index 729e546791b..8303424e119 100644 --- a/ocaml/fstar-lib/generated/FStar_CheckedFiles.ml +++ b/ocaml/fstar-lib/generated/FStar_CheckedFiles.ml @@ -1,5 +1,5 @@ open Prims -let (cache_version_number : Prims.int) = (Prims.of_int (66)) +let (cache_version_number : Prims.int) = (Prims.of_int (67)) type tc_result = { checked_module: FStar_Syntax_Syntax.modul ; diff --git a/ocaml/fstar-lib/generated/FStar_Extraction_ML_Modul.ml b/ocaml/fstar-lib/generated/FStar_Extraction_ML_Modul.ml index 58dcb7cf5c0..fd0d46c0cfa 100644 --- a/ocaml/fstar-lib/generated/FStar_Extraction_ML_Modul.ml +++ b/ocaml/fstar-lib/generated/FStar_Extraction_ML_Modul.ml @@ -450,13 +450,14 @@ let (bundle_as_inductive_families : FStar_Syntax_Syntax.num_uniform_params = uu___1; FStar_Syntax_Syntax.t = t; FStar_Syntax_Syntax.mutuals = uu___2; - FStar_Syntax_Syntax.ds = datas;_} + FStar_Syntax_Syntax.ds = datas; + FStar_Syntax_Syntax.injective_type_params = uu___3;_} -> - let uu___3 = FStar_Syntax_Subst.open_univ_vars us t in - (match uu___3 with + let uu___4 = FStar_Syntax_Subst.open_univ_vars us t in + (match uu___4 with | (_us, t1) -> - let uu___4 = FStar_Syntax_Subst.open_term bs t1 in - (match uu___4 with + let uu___5 = FStar_Syntax_Subst.open_term bs t1 in + (match uu___5 with | (bs1, t2) -> let datas1 = FStar_Compiler_List.collect @@ -471,93 +472,95 @@ let (bundle_as_inductive_families : FStar_Syntax_Syntax.num_ty_params = nparams; FStar_Syntax_Syntax.mutuals1 = - uu___5;_} + uu___6; + FStar_Syntax_Syntax.injective_type_params1 + = uu___7;_} when FStar_Ident.lid_equals l l' -> - let uu___6 = + let uu___8 = FStar_Syntax_Subst.open_univ_vars us1 t3 in - (match uu___6 with + (match uu___8 with | (_us1, t4) -> - let uu___7 = + let uu___9 = FStar_Syntax_Util.arrow_formals t4 in - (match uu___7 with + (match uu___9 with | (bs', body) -> - let uu___8 = + let uu___10 = FStar_Compiler_Util.first_N (FStar_Compiler_List.length bs1) bs' in - (match uu___8 with + (match uu___10 with | (bs_params, rest) -> let subst = FStar_Compiler_List.map2 - (fun uu___9 -> - fun uu___10 + (fun uu___11 -> + fun uu___12 -> match - (uu___9, - uu___10) + (uu___11, + uu___12) with | ({ FStar_Syntax_Syntax.binder_bv = b'; FStar_Syntax_Syntax.binder_qual - = uu___11; + = uu___13; FStar_Syntax_Syntax.binder_positivity - = uu___12; + = uu___14; FStar_Syntax_Syntax.binder_attrs - = uu___13;_}, + = uu___15;_}, { FStar_Syntax_Syntax.binder_bv = b; FStar_Syntax_Syntax.binder_qual - = uu___14; + = uu___16; FStar_Syntax_Syntax.binder_positivity - = uu___15; + = uu___17; FStar_Syntax_Syntax.binder_attrs - = uu___16;_}) + = uu___18;_}) -> - let uu___17 + let uu___19 = - let uu___18 + let uu___20 = FStar_Syntax_Syntax.bv_to_name b in (b', - uu___18) in + uu___20) in FStar_Syntax_Syntax.NT - uu___17) + uu___19) bs_params bs1 in let t5 = - let uu___9 = - let uu___10 = + let uu___11 = + let uu___12 = FStar_Syntax_Syntax.mk_Total body in FStar_Syntax_Util.arrow - rest uu___10 in + rest uu___12 in FStar_Syntax_Subst.subst - subst uu___9 in + subst uu___11 in [{ dname = d; dtyp = t5 }]))) - | uu___5 -> []) ses in + | uu___6 -> []) ses in let metadata = - let uu___5 = + let uu___6 = extract_metadata se.FStar_Syntax_Syntax.sigattrs in - let uu___6 = + let uu___7 = FStar_Compiler_List.choose flag_of_qual quals in - FStar_Compiler_List.op_At uu___5 uu___6 in + FStar_Compiler_List.op_At uu___6 uu___7 in let fv = FStar_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None in - let uu___5 = + let uu___6 = FStar_Extraction_ML_UEnv.extend_type_name env1 fv in - (match uu___5 with - | (uu___6, env2) -> + (match uu___6 with + | (uu___7, env2) -> (env2, [{ ifv = fv; @@ -1029,17 +1032,18 @@ let (extract_bundle_iface : FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___1; FStar_Syntax_Syntax.num_ty_params = uu___2; - FStar_Syntax_Syntax.mutuals1 = uu___3;_}; - FStar_Syntax_Syntax.sigrng = uu___4; - FStar_Syntax_Syntax.sigquals = uu___5; - FStar_Syntax_Syntax.sigmeta = uu___6; - FStar_Syntax_Syntax.sigattrs = uu___7; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___8; - FStar_Syntax_Syntax.sigopts = uu___9;_}::[]; - FStar_Syntax_Syntax.lids = uu___10;_}, + FStar_Syntax_Syntax.mutuals1 = uu___3; + FStar_Syntax_Syntax.injective_type_params1 = uu___4;_}; + FStar_Syntax_Syntax.sigrng = uu___5; + FStar_Syntax_Syntax.sigquals = uu___6; + FStar_Syntax_Syntax.sigmeta = uu___7; + FStar_Syntax_Syntax.sigattrs = uu___8; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; + FStar_Syntax_Syntax.sigopts = uu___10;_}::[]; + FStar_Syntax_Syntax.lids = uu___11;_}, (FStar_Syntax_Syntax.ExceptionConstructor)::[]) -> - let uu___11 = extract_ctor env [] env { dname = l; dtyp = t } in - (match uu___11 with + let uu___12 = extract_ctor env [] env { dname = l; dtyp = t } in + (match uu___12 with | (env1, ctor) -> (env1, (iface_of_bindings [ctor]))) | (FStar_Syntax_Syntax.Sig_bundle { FStar_Syntax_Syntax.ses = ses; FStar_Syntax_Syntax.lids = uu___;_}, @@ -2070,17 +2074,18 @@ let (extract_bundle : FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___1; FStar_Syntax_Syntax.num_ty_params = uu___2; - FStar_Syntax_Syntax.mutuals1 = uu___3;_}; - FStar_Syntax_Syntax.sigrng = uu___4; - FStar_Syntax_Syntax.sigquals = uu___5; - FStar_Syntax_Syntax.sigmeta = uu___6; - FStar_Syntax_Syntax.sigattrs = uu___7; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___8; - FStar_Syntax_Syntax.sigopts = uu___9;_}::[]; - FStar_Syntax_Syntax.lids = uu___10;_}, + FStar_Syntax_Syntax.mutuals1 = uu___3; + FStar_Syntax_Syntax.injective_type_params1 = uu___4;_}; + FStar_Syntax_Syntax.sigrng = uu___5; + FStar_Syntax_Syntax.sigquals = uu___6; + FStar_Syntax_Syntax.sigmeta = uu___7; + FStar_Syntax_Syntax.sigattrs = uu___8; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; + FStar_Syntax_Syntax.sigopts = uu___10;_}::[]; + FStar_Syntax_Syntax.lids = uu___11;_}, (FStar_Syntax_Syntax.ExceptionConstructor)::[]) -> - let uu___11 = extract_ctor env [] env { dname = l; dtyp = t } in - (match uu___11 with + let uu___12 = extract_ctor env [] env { dname = l; dtyp = t } in + (match uu___12 with | (env1, ctor) -> (env1, [FStar_Extraction_ML_Syntax.mk_mlmodule1_with_attrs diff --git a/ocaml/fstar-lib/generated/FStar_Extraction_ML_RegEmb.ml b/ocaml/fstar-lib/generated/FStar_Extraction_ML_RegEmb.ml index aac544dad71..acc7688f8a3 100644 --- a/ocaml/fstar-lib/generated/FStar_Extraction_ML_RegEmb.ml +++ b/ocaml/fstar-lib/generated/FStar_Extraction_ML_RegEmb.ml @@ -1688,72 +1688,73 @@ let (mk_unembed : FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = ty_lid; FStar_Syntax_Syntax.num_ty_params = num_ty_params; - FStar_Syntax_Syntax.mutuals1 = uu___1;_} + FStar_Syntax_Syntax.mutuals1 = uu___1; + FStar_Syntax_Syntax.injective_type_params1 = uu___2;_} -> let fv = fresh "fv" in - let uu___2 = FStar_Syntax_Util.arrow_formals t in - (match uu___2 with + let uu___3 = FStar_Syntax_Util.arrow_formals t in + (match uu___3 with | (bs, c) -> let vs = FStar_Compiler_List.map (fun b -> - let uu___3 = - let uu___4 = + let uu___4 = + let uu___5 = FStar_Ident.string_of_id (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.ppname in - fresh uu___4 in - (uu___3, + fresh uu___5 in + (uu___4, ((b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort))) bs in let pat_s = - let uu___3 = - let uu___4 = FStar_Ident.string_of_lid lid in - FStar_Extraction_ML_Syntax.MLC_String uu___4 in - FStar_Extraction_ML_Syntax.MLP_Const uu___3 in + let uu___4 = + let uu___5 = FStar_Ident.string_of_lid lid in + FStar_Extraction_ML_Syntax.MLC_String uu___5 in + FStar_Extraction_ML_Syntax.MLP_Const uu___4 in let pat_args = - let uu___3 = + let uu___4 = FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | (v, uu___5) -> + (fun uu___5 -> + match uu___5 with + | (v, uu___6) -> FStar_Extraction_ML_Syntax.MLP_Var v) vs in - pats_to_list_pat uu___3 in + pats_to_list_pat uu___4 in let pat_both = FStar_Extraction_ML_Syntax.MLP_Tuple [pat_s; pat_args] in let ret = match record_fields with | FStar_Pervasives_Native.Some fields -> - let uu___3 = + let uu___4 = FStar_Compiler_List.map2 - (fun uu___4 -> + (fun uu___5 -> fun fld -> - match uu___4 with - | (v, uu___5) -> + match uu___5 with + | (v, uu___6) -> ((FStar_Pervasives_Native.snd fld), (mk (FStar_Extraction_ML_Syntax.MLE_Var v)))) vs fields in - ml_record lid uu___3 + ml_record lid uu___4 | FStar_Pervasives_Native.None -> - let uu___3 = + let uu___4 = FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | (v, uu___5) -> + (fun uu___5 -> + match uu___5 with + | (v, uu___6) -> mk (FStar_Extraction_ML_Syntax.MLE_Var v)) vs in - ml_ctor lid uu___3 in + ml_ctor lid uu___4 in let ret1 = mk (FStar_Extraction_ML_Syntax.MLE_App (ml_some, [ret])) in let body = FStar_Compiler_List.fold_right - (fun uu___3 -> + (fun uu___4 -> fun body1 -> - match uu___3 with + match uu___4 with | (v, ty) -> let body2 = mk @@ -1761,41 +1762,41 @@ let (mk_unembed : ([mk_binder v FStar_Extraction_ML_Syntax.MLTY_Top], body1)) in - let uu___4 = - let uu___5 = - let uu___6 = ml_name bind_opt_lid in - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - ml_name unembed_lid in + let uu___5 = + let uu___6 = + let uu___7 = ml_name bind_opt_lid in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = let uu___12 = - let uu___13 = + ml_name unembed_lid in + let uu___13 = + let uu___14 = embedding_for tcenv mutuals SyntaxTerm [] ty in - [uu___13; + [uu___14; mk (FStar_Extraction_ML_Syntax.MLE_Var v)] in - (uu___11, uu___12) in + (uu___12, uu___13) in FStar_Extraction_ML_Syntax.MLE_App - uu___10 in - mk uu___9 in - [uu___8; body2] in - (uu___6, uu___7) in + uu___11 in + mk uu___10 in + [uu___9; body2] in + (uu___7, uu___8) in FStar_Extraction_ML_Syntax.MLE_App - uu___5 in - mk uu___4) vs ret1 in + uu___6 in + mk uu___5) vs ret1 in let br = (pat_both, FStar_Pervasives_Native.None, body) in - let uu___3 = - let uu___4 = + let uu___4 = + let uu___5 = FStar_Compiler_Effect.op_Bang e_branches in - br :: uu___4 in + br :: uu___5 in FStar_Compiler_Effect.op_Colon_Equals e_branches - uu___3) + uu___4) | uu___1 -> FStar_Compiler_Effect.failwith "impossible, filter above") ctors; @@ -1838,28 +1839,29 @@ let (mk_embed : FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = ty_lid; FStar_Syntax_Syntax.num_ty_params = num_ty_params; - FStar_Syntax_Syntax.mutuals1 = uu___1;_} + FStar_Syntax_Syntax.mutuals1 = uu___1; + FStar_Syntax_Syntax.injective_type_params1 = uu___2;_} -> let fv = fresh "fv" in - let uu___2 = FStar_Syntax_Util.arrow_formals t in - (match uu___2 with + let uu___3 = FStar_Syntax_Util.arrow_formals t in + (match uu___3 with | (bs, c) -> let vs = FStar_Compiler_List.map (fun b -> - let uu___3 = - let uu___4 = + let uu___4 = + let uu___5 = FStar_Ident.string_of_id (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.ppname in - fresh uu___4 in - (uu___3, + fresh uu___5 in + (uu___4, ((b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort))) bs in let pat = match record_fields with | FStar_Pervasives_Native.Some fields -> - let uu___3 = - let uu___4 = + let uu___4 = + let uu___5 = FStar_Compiler_List.map2 (fun v -> fun fld -> @@ -1867,48 +1869,48 @@ let (mk_embed : (FStar_Extraction_ML_Syntax.MLP_Var (FStar_Pervasives_Native.fst v)))) vs fields in - ([], uu___4) in - FStar_Extraction_ML_Syntax.MLP_Record uu___3 + ([], uu___5) in + FStar_Extraction_ML_Syntax.MLP_Record uu___4 | FStar_Pervasives_Native.None -> - let uu___3 = - let uu___4 = - let uu___5 = FStar_Ident.path_of_lid lid in - splitlast uu___5 in + let uu___4 = let uu___5 = + let uu___6 = FStar_Ident.path_of_lid lid in + splitlast uu___6 in + let uu___6 = FStar_Compiler_List.map (fun v -> FStar_Extraction_ML_Syntax.MLP_Var (FStar_Pervasives_Native.fst v)) vs in - (uu___4, uu___5) in - FStar_Extraction_ML_Syntax.MLP_CTor uu___3 in + (uu___5, uu___6) in + FStar_Extraction_ML_Syntax.MLP_CTor uu___4 in let fvar = ml_name s_tdataconstr_lid in let lid_of_str = ml_name lid_of_str_lid in let head = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = FStar_Ident.string_of_lid lid in FStar_Extraction_ML_Syntax.MLC_String - uu___13 in + uu___14 in FStar_Extraction_ML_Syntax.MLE_Const - uu___12 in - mk uu___11 in - [uu___10] in - (lid_of_str, uu___9) in - FStar_Extraction_ML_Syntax.MLE_App uu___8 in - mk uu___7 in - [uu___6] in - (fvar, uu___5) in - FStar_Extraction_ML_Syntax.MLE_App uu___4 in - mk uu___3 in + uu___13 in + mk uu___12 in + [uu___11] in + (lid_of_str, uu___10) in + FStar_Extraction_ML_Syntax.MLE_App uu___9 in + mk uu___8 in + [uu___7] in + (fvar, uu___6) in + FStar_Extraction_ML_Syntax.MLE_App uu___5 in + mk uu___4 in let mk_mk_app t1 ts = let ts1 = FStar_Compiler_List.map @@ -1916,44 +1918,44 @@ let (mk_embed : mk (FStar_Extraction_ML_Syntax.MLE_Tuple [t2; ml_none])) ts in - let uu___3 = - let uu___4 = - let uu___5 = ml_name mk_app_lid in - let uu___6 = - let uu___7 = - let uu___8 = as_ml_list ts1 in [uu___8] in - t1 :: uu___7 in - (uu___5, uu___6) in - FStar_Extraction_ML_Syntax.MLE_App uu___4 in - mk uu___3 in + let uu___4 = + let uu___5 = + let uu___6 = ml_name mk_app_lid in + let uu___7 = + let uu___8 = + let uu___9 = as_ml_list ts1 in [uu___9] in + t1 :: uu___8 in + (uu___6, uu___7) in + FStar_Extraction_ML_Syntax.MLE_App uu___5 in + mk uu___4 in let args = FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with + (fun uu___4 -> + match uu___4 with | (v, ty) -> let vt = mk (FStar_Extraction_ML_Syntax.MLE_Var v) in - let uu___4 = - let uu___5 = - let uu___6 = ml_name embed_lid in - let uu___7 = - let uu___8 = + let uu___5 = + let uu___6 = + let uu___7 = ml_name embed_lid in + let uu___8 = + let uu___9 = embedding_for tcenv mutuals SyntaxTerm [] ty in - [uu___8; vt] in - (uu___6, uu___7) in + [uu___9; vt] in + (uu___7, uu___8) in FStar_Extraction_ML_Syntax.MLE_App - uu___5 in - mk uu___4) vs in + uu___6 in + mk uu___5) vs in let ret = mk_mk_app head args in let br = (pat, FStar_Pervasives_Native.None, ret) in - let uu___3 = - let uu___4 = + let uu___4 = + let uu___5 = FStar_Compiler_Effect.op_Bang e_branches in - br :: uu___4 in + br :: uu___5 in FStar_Compiler_Effect.op_Colon_Equals e_branches - uu___3) + uu___4) | uu___1 -> FStar_Compiler_Effect.failwith "impossible, filter above") ctors; @@ -2051,7 +2053,8 @@ let (__do_handle_plugin : FStar_Syntax_Syntax.num_uniform_params = uu___3; FStar_Syntax_Syntax.t = uu___4; FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6;_} + FStar_Syntax_Syntax.ds = uu___6; + FStar_Syntax_Syntax.injective_type_params = uu___7;_} -> lid) mutual_sigelts in let proc_one typ_sigelt = let uu___1 = typ_sigelt.FStar_Syntax_Syntax.sigel in @@ -2063,7 +2066,8 @@ let (__do_handle_plugin : FStar_Syntax_Syntax.num_uniform_params = uu___3; FStar_Syntax_Syntax.t = uu___4; FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6;_} + FStar_Syntax_Syntax.ds = uu___6; + FStar_Syntax_Syntax.injective_type_params = uu___7;_} -> (if (FStar_Compiler_List.length ps) > Prims.int_zero then @@ -2072,48 +2076,50 @@ let (__do_handle_plugin : else (); (let ns = FStar_Ident.ns_of_lid tlid in let name = - let uu___8 = - let uu___9 = FStar_Ident.ids_of_lid tlid in - FStar_Compiler_List.last uu___9 in - FStar_Ident.string_of_id uu___8 in + let uu___9 = + let uu___10 = FStar_Ident.ids_of_lid tlid in + FStar_Compiler_List.last uu___10 in + FStar_Ident.string_of_id uu___9 in let ctors = FStar_Compiler_List.filter (fun se1 -> match se1.FStar_Syntax_Syntax.sigel with | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___8; - FStar_Syntax_Syntax.us1 = uu___9; - FStar_Syntax_Syntax.t1 = uu___10; + { FStar_Syntax_Syntax.lid1 = uu___9; + FStar_Syntax_Syntax.us1 = uu___10; + FStar_Syntax_Syntax.t1 = uu___11; FStar_Syntax_Syntax.ty_lid = ty_lid; - FStar_Syntax_Syntax.num_ty_params = uu___11; - FStar_Syntax_Syntax.mutuals1 = uu___12;_} + FStar_Syntax_Syntax.num_ty_params = uu___12; + FStar_Syntax_Syntax.mutuals1 = uu___13; + FStar_Syntax_Syntax.injective_type_params1 = + uu___14;_} -> FStar_Ident.lid_equals ty_lid tlid - | uu___8 -> false) ses in + | uu___9 -> false) ses in let ml_name1 = - let uu___8 = - let uu___9 = - let uu___10 = FStar_Ident.string_of_lid tlid in - FStar_Extraction_ML_Syntax.MLC_String uu___10 in - FStar_Extraction_ML_Syntax.MLE_Const uu___9 in - mk uu___8 in + let uu___9 = + let uu___10 = + let uu___11 = FStar_Ident.string_of_lid tlid in + FStar_Extraction_ML_Syntax.MLC_String uu___11 in + FStar_Extraction_ML_Syntax.MLE_Const uu___10 in + mk uu___9 in let record_fields = - let uu___8 = + let uu___9 = FStar_Compiler_List.find - (fun uu___9 -> - match uu___9 with - | FStar_Syntax_Syntax.RecordType uu___10 -> true - | uu___10 -> false) + (fun uu___10 -> + match uu___10 with + | FStar_Syntax_Syntax.RecordType uu___11 -> true + | uu___11 -> false) typ_sigelt.FStar_Syntax_Syntax.sigquals in - match uu___8 with + match uu___9 with | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.RecordType (uu___9, b)) -> - let uu___10 = + (FStar_Syntax_Syntax.RecordType (uu___10, b)) -> + let uu___11 = FStar_Compiler_List.map (fun f -> FStar_Extraction_ML_UEnv.lookup_record_field_name g (tlid, f)) b in - FStar_Pervasives_Native.Some uu___10 - | uu___9 -> FStar_Pervasives_Native.None in + FStar_Pervasives_Native.Some uu___11 + | uu___10 -> FStar_Pervasives_Native.None in let tcenv = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in let ml_unembed = mk_unembed tcenv mutual_lids record_fields ctors in @@ -2144,19 +2150,19 @@ let (__do_handle_plugin : FStar_Extraction_ML_Syntax.mllb_meta = []; FStar_Extraction_ML_Syntax.print_typ = false } in - (let uu___9 = - let uu___10 = - let uu___11 = + (let uu___10 = + let uu___11 = + let uu___12 = FStar_Ident.mk_ident ((Prims.strcat "e_" name), FStar_Compiler_Range_Type.dummyRange) in - FStar_Ident.lid_of_ns_and_id ns uu___11 in + FStar_Ident.lid_of_ns_and_id ns uu___12 in { arity = Prims.int_zero; - syn_emb = uu___10; + syn_emb = uu___11; nbe_emb = FStar_Pervasives_Native.None } in - register_embedding tlid uu___9); + register_embedding tlid uu___10); [lb])) in let lbs = FStar_Compiler_List.concatMap proc_one mutual_sigelts in let unthunking = @@ -2171,7 +2177,8 @@ let (__do_handle_plugin : FStar_Syntax_Syntax.num_uniform_params = uu___3; FStar_Syntax_Syntax.t = uu___4; FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6;_} + FStar_Syntax_Syntax.ds = uu___6; + FStar_Syntax_Syntax.injective_type_params = uu___7;_} -> tlid1 in let name = let uu___1 = diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V1_Builtins.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V1_Builtins.ml index 8679a07295b..1d431cf3cd4 100644 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V1_Builtins.ml +++ b/ocaml/fstar-lib/generated/FStar_Reflection_V1_Builtins.ml @@ -882,22 +882,23 @@ let (inspect_sigelt : FStar_Syntax_Syntax.params = param_bs; FStar_Syntax_Syntax.num_uniform_params = uu___; FStar_Syntax_Syntax.t = ty; FStar_Syntax_Syntax.mutuals = uu___1; - FStar_Syntax_Syntax.ds = c_lids;_} + FStar_Syntax_Syntax.ds = c_lids; + FStar_Syntax_Syntax.injective_type_params = uu___2;_} -> let nm = FStar_Ident.path_of_lid lid in - let uu___2 = FStar_Syntax_Subst.univ_var_opening us in - (match uu___2 with + let uu___3 = FStar_Syntax_Subst.univ_var_opening us in + (match uu___3 with | (s, us1) -> let param_bs1 = FStar_Syntax_Subst.subst_binders s param_bs in let ty1 = FStar_Syntax_Subst.subst s ty in - let uu___3 = FStar_Syntax_Subst.open_term param_bs1 ty1 in - (match uu___3 with + let uu___4 = FStar_Syntax_Subst.open_term param_bs1 ty1 in + (match uu___4 with | (param_bs2, ty2) -> let inspect_ctor c_lid = - let uu___4 = - let uu___5 = get_env () in - FStar_TypeChecker_Env.lookup_sigelt uu___5 c_lid in - match uu___4 with + let uu___5 = + let uu___6 = get_env () in + FStar_TypeChecker_Env.lookup_sigelt uu___6 c_lid in + match uu___5 with | FStar_Pervasives_Native.Some { FStar_Syntax_Syntax.sigel = @@ -905,22 +906,24 @@ let (inspect_sigelt : { FStar_Syntax_Syntax.lid1 = lid1; FStar_Syntax_Syntax.us1 = us2; FStar_Syntax_Syntax.t1 = cty; - FStar_Syntax_Syntax.ty_lid = uu___5; + FStar_Syntax_Syntax.ty_lid = uu___6; FStar_Syntax_Syntax.num_ty_params = nparam; - FStar_Syntax_Syntax.mutuals1 = uu___6;_}; - FStar_Syntax_Syntax.sigrng = uu___7; - FStar_Syntax_Syntax.sigquals = uu___8; - FStar_Syntax_Syntax.sigmeta = uu___9; - FStar_Syntax_Syntax.sigattrs = uu___10; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___11; - FStar_Syntax_Syntax.sigopts = uu___12;_} + FStar_Syntax_Syntax.mutuals1 = uu___7; + FStar_Syntax_Syntax.injective_type_params1 = + uu___8;_}; + FStar_Syntax_Syntax.sigrng = uu___9; + FStar_Syntax_Syntax.sigquals = uu___10; + FStar_Syntax_Syntax.sigmeta = uu___11; + FStar_Syntax_Syntax.sigattrs = uu___12; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___13; + FStar_Syntax_Syntax.sigopts = uu___14;_} -> let cty1 = FStar_Syntax_Subst.subst s cty in - let uu___13 = - let uu___14 = get_env () in - FStar_TypeChecker_Normalize.get_n_binders uu___14 + let uu___15 = + let uu___16 = get_env () in + FStar_TypeChecker_Normalize.get_n_binders uu___16 nparam cty1 in - (match uu___13 with + (match uu___15 with | (param_ctor_bs, c) -> (if (FStar_Compiler_List.length param_ctor_bs) <> @@ -929,11 +932,11 @@ let (inspect_sigelt : FStar_Compiler_Effect.failwith "impossible: inspect_sigelt: could not obtain sufficient ctor param binders" else (); - (let uu___16 = - let uu___17 = + (let uu___18 = + let uu___19 = FStar_Syntax_Util.is_total_comp c in - Prims.op_Negation uu___17 in - if uu___16 + Prims.op_Negation uu___19 in + if uu___18 then FStar_Compiler_Effect.failwith "impossible: inspect_sigelt: removed parameters and got an effectful comp" @@ -943,26 +946,26 @@ let (inspect_sigelt : FStar_Compiler_List.map2 (fun b1 -> fun b2 -> - let uu___16 = - let uu___17 = + let uu___18 = + let uu___19 = FStar_Syntax_Syntax.bv_to_name b2.FStar_Syntax_Syntax.binder_bv in ((b1.FStar_Syntax_Syntax.binder_bv), - uu___17) in - FStar_Syntax_Syntax.NT uu___16) + uu___19) in + FStar_Syntax_Syntax.NT uu___18) param_ctor_bs param_bs2 in let cty3 = FStar_Syntax_Subst.subst s' cty2 in let cty4 = FStar_Syntax_Util.remove_inacc cty3 in - let uu___16 = FStar_Ident.path_of_lid lid1 in - (uu___16, cty4)))) - | uu___5 -> + let uu___18 = FStar_Ident.path_of_lid lid1 in + (uu___18, cty4)))) + | uu___6 -> FStar_Compiler_Effect.failwith "impossible: inspect_sigelt: did not find ctor" in - let uu___4 = - let uu___5 = FStar_Compiler_List.map inspect_ident us1 in - let uu___6 = FStar_Compiler_List.map inspect_ctor c_lids in - (nm, uu___5, param_bs2, ty2, uu___6) in - FStar_Reflection_V1_Data.Sg_Inductive uu___4)) + let uu___5 = + let uu___6 = FStar_Compiler_List.map inspect_ident us1 in + let uu___7 = FStar_Compiler_List.map inspect_ctor c_lids in + (nm, uu___6, param_bs2, ty2, uu___7) in + FStar_Reflection_V1_Data.Sg_Inductive uu___5)) | FStar_Syntax_Syntax.Sig_declare_typ { FStar_Syntax_Syntax.lid2 = lid; FStar_Syntax_Syntax.us2 = us; FStar_Syntax_Syntax.t2 = ty;_} @@ -1037,6 +1040,7 @@ let (pack_sigelt : (check_lid ind_lid; (let s = FStar_Syntax_Subst.univ_var_closing us_names1 in let nparam = FStar_Compiler_List.length param_bs in + let injective_type_params = false in let pack_ctor c = let uu___1 = c in match uu___1 with @@ -1056,7 +1060,9 @@ let (pack_sigelt : FStar_Syntax_Syntax.t1 = ty3; FStar_Syntax_Syntax.ty_lid = ind_lid; FStar_Syntax_Syntax.num_ty_params = nparam; - FStar_Syntax_Syntax.mutuals1 = [] + FStar_Syntax_Syntax.mutuals1 = []; + FStar_Syntax_Syntax.injective_type_params1 = + injective_type_params }) in let ctor_ses = FStar_Compiler_List.map pack_ctor ctors in let c_lids = @@ -1079,7 +1085,9 @@ let (pack_sigelt : FStar_Pervasives_Native.None; FStar_Syntax_Syntax.t = ty2; FStar_Syntax_Syntax.mutuals = []; - FStar_Syntax_Syntax.ds = c_lids + FStar_Syntax_Syntax.ds = c_lids; + FStar_Syntax_Syntax.injective_type_params = + injective_type_params }) in let se = FStar_Syntax_Syntax.mk_sigelt diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Builtins.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Builtins.ml index 3c6ea77ae05..245ff6c1fe4 100644 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Builtins.ml +++ b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Builtins.ml @@ -834,37 +834,39 @@ let (inspect_sigelt : FStar_Syntax_Syntax.params = param_bs; FStar_Syntax_Syntax.num_uniform_params = uu___; FStar_Syntax_Syntax.t = ty; FStar_Syntax_Syntax.mutuals = uu___1; - FStar_Syntax_Syntax.ds = c_lids;_} + FStar_Syntax_Syntax.ds = c_lids; + FStar_Syntax_Syntax.injective_type_params = uu___2;_} -> let nm = FStar_Ident.path_of_lid lid in let inspect_ctor c_lid = - let uu___2 = - let uu___3 = get_env () in - FStar_TypeChecker_Env.lookup_sigelt uu___3 c_lid in - match uu___2 with + let uu___3 = + let uu___4 = get_env () in + FStar_TypeChecker_Env.lookup_sigelt uu___4 c_lid in + match uu___3 with | FStar_Pervasives_Native.Some { FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_datacon { FStar_Syntax_Syntax.lid1 = lid1; FStar_Syntax_Syntax.us1 = us1; FStar_Syntax_Syntax.t1 = cty; - FStar_Syntax_Syntax.ty_lid = uu___3; + FStar_Syntax_Syntax.ty_lid = uu___4; FStar_Syntax_Syntax.num_ty_params = nparam; - FStar_Syntax_Syntax.mutuals1 = uu___4;_}; - FStar_Syntax_Syntax.sigrng = uu___5; - FStar_Syntax_Syntax.sigquals = uu___6; - FStar_Syntax_Syntax.sigmeta = uu___7; - FStar_Syntax_Syntax.sigattrs = uu___8; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; - FStar_Syntax_Syntax.sigopts = uu___10;_} - -> let uu___11 = FStar_Ident.path_of_lid lid1 in (uu___11, cty) - | uu___3 -> + FStar_Syntax_Syntax.mutuals1 = uu___5; + FStar_Syntax_Syntax.injective_type_params1 = uu___6;_}; + FStar_Syntax_Syntax.sigrng = uu___7; + FStar_Syntax_Syntax.sigquals = uu___8; + FStar_Syntax_Syntax.sigmeta = uu___9; + FStar_Syntax_Syntax.sigattrs = uu___10; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___11; + FStar_Syntax_Syntax.sigopts = uu___12;_} + -> let uu___13 = FStar_Ident.path_of_lid lid1 in (uu___13, cty) + | uu___4 -> FStar_Compiler_Effect.failwith "impossible: inspect_sigelt: did not find ctor" in - let uu___2 = - let uu___3 = FStar_Compiler_List.map inspect_ctor c_lids in - (nm, us, param_bs, ty, uu___3) in - FStar_Reflection_V2_Data.Sg_Inductive uu___2 + let uu___3 = + let uu___4 = FStar_Compiler_List.map inspect_ctor c_lids in + (nm, us, param_bs, ty, uu___4) in + FStar_Reflection_V2_Data.Sg_Inductive uu___3 | FStar_Syntax_Syntax.Sig_declare_typ { FStar_Syntax_Syntax.lid2 = lid; FStar_Syntax_Syntax.us2 = us; FStar_Syntax_Syntax.t2 = ty;_} @@ -924,6 +926,7 @@ let (pack_sigelt : FStar_Ident.lid_of_path nm FStar_Compiler_Range_Type.dummyRange in (check_lid ind_lid; (let nparam = FStar_Compiler_List.length param_bs in + let injective_type_params = false in let pack_ctor c = let uu___1 = c in match uu___1 with @@ -939,7 +942,9 @@ let (pack_sigelt : FStar_Syntax_Syntax.t1 = ty1; FStar_Syntax_Syntax.ty_lid = ind_lid; FStar_Syntax_Syntax.num_ty_params = nparam; - FStar_Syntax_Syntax.mutuals1 = [] + FStar_Syntax_Syntax.mutuals1 = []; + FStar_Syntax_Syntax.injective_type_params1 = + injective_type_params }) in let ctor_ses = FStar_Compiler_List.map pack_ctor ctors in let c_lids = @@ -958,7 +963,9 @@ let (pack_sigelt : FStar_Pervasives_Native.None; FStar_Syntax_Syntax.t = ty; FStar_Syntax_Syntax.mutuals = []; - FStar_Syntax_Syntax.ds = c_lids + FStar_Syntax_Syntax.ds = c_lids; + FStar_Syntax_Syntax.injective_type_params = + injective_type_params }) in let se = FStar_Syntax_Syntax.mk_sigelt diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml index bd30c5cf7e8..ffebb10d50e 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -3782,8 +3782,11 @@ let (encode_top_level_let : (Prims.strcat "let rec unencodeable: Skipping: " msg) in let uu___2 = FStar_SMTEncoding_Term.mk_decls_trivial [decl] in (uu___2, env)) -let (is_sig_inductive_injective_on_params : - FStar_SMTEncoding_Env.env_t -> FStar_Syntax_Syntax.sigelt -> Prims.bool) = +let (encode_sig_inductive : + FStar_SMTEncoding_Env.env_t -> + FStar_Syntax_Syntax.sigelt -> + (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.env_t)) + = fun env -> fun se -> let uu___ = se.FStar_Syntax_Syntax.sigel in @@ -3794,888 +3797,656 @@ let (is_sig_inductive_injective_on_params : FStar_Syntax_Syntax.params = tps; FStar_Syntax_Syntax.num_uniform_params = uu___1; FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = uu___2; - FStar_Syntax_Syntax.ds = uu___3;_} + FStar_Syntax_Syntax.ds = datas; + FStar_Syntax_Syntax.injective_type_params = injective_type_params;_} -> let t_lid = t in let tcenv = env.FStar_SMTEncoding_Env.tcenv in - let uu___4 = FStar_Syntax_Subst.univ_var_opening universe_names in - (match uu___4 with - | (usubst, uvs) -> - let uu___5 = - let uu___6 = FStar_TypeChecker_Env.push_univ_vars tcenv uvs in - let uu___7 = FStar_Syntax_Subst.subst_binders usubst tps in - let uu___8 = - let uu___9 = - FStar_Syntax_Subst.shift_subst - (FStar_Compiler_List.length tps) usubst in - FStar_Syntax_Subst.subst uu___9 k in - (uu___6, uu___7, uu___8) in - (match uu___5 with - | (tcenv1, tps1, k1) -> - let uu___6 = FStar_Syntax_Subst.open_term tps1 k1 in - (match uu___6 with - | (tps2, k2) -> - let uu___7 = FStar_Syntax_Util.arrow_formals k2 in - (match uu___7 with - | (uu___8, k3) -> - let uu___9 = - FStar_TypeChecker_TcTerm.tc_binders tcenv1 - tps2 in - (match uu___9 with - | (tps3, env_tps, uu___10, us) -> - let u_k = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.fvar t - FStar_Pervasives_Native.None in - let uu___13 = - let uu___14 = - FStar_Syntax_Util.args_of_binders - tps3 in - FStar_Pervasives_Native.snd uu___14 in - let uu___14 = - FStar_Ident.range_of_lid t in - FStar_Syntax_Syntax.mk_Tm_app uu___12 - uu___13 uu___14 in - FStar_TypeChecker_TcTerm.level_of_type - env_tps uu___11 k3 in - let rec universe_leq u v = - match (u, v) with - | (FStar_Syntax_Syntax.U_zero, uu___11) - -> true - | (FStar_Syntax_Syntax.U_succ u0, - FStar_Syntax_Syntax.U_succ v0) -> - universe_leq u0 v0 - | (FStar_Syntax_Syntax.U_name u0, - FStar_Syntax_Syntax.U_name v0) -> - FStar_Ident.ident_equals u0 v0 - | (FStar_Syntax_Syntax.U_name uu___11, - FStar_Syntax_Syntax.U_succ v0) -> - universe_leq u v0 - | (FStar_Syntax_Syntax.U_max us1, - uu___11) -> - FStar_Compiler_Util.for_all - (fun u1 -> universe_leq u1 v) us1 - | (uu___11, FStar_Syntax_Syntax.U_max - vs) -> - FStar_Compiler_Util.for_some - (universe_leq u) vs - | (FStar_Syntax_Syntax.U_unknown, - uu___11) -> - let uu___12 = - let uu___13 = - FStar_Ident.string_of_lid t in - let uu___14 = - FStar_Syntax_Print.univ_to_string - u in - let uu___15 = - FStar_Syntax_Print.univ_to_string - v in - FStar_Compiler_Util.format3 - "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" - uu___13 uu___14 uu___15 in - FStar_Compiler_Effect.failwith - uu___12 - | (uu___11, - FStar_Syntax_Syntax.U_unknown) -> - let uu___12 = - let uu___13 = - FStar_Ident.string_of_lid t in - let uu___14 = - FStar_Syntax_Print.univ_to_string - u in - let uu___15 = - FStar_Syntax_Print.univ_to_string - v in - FStar_Compiler_Util.format3 - "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" - uu___13 uu___14 uu___15 in - FStar_Compiler_Effect.failwith - uu___12 - | (FStar_Syntax_Syntax.U_unif uu___11, - uu___12) -> - let uu___13 = - let uu___14 = - FStar_Ident.string_of_lid t in - let uu___15 = - FStar_Syntax_Print.univ_to_string - u in - let uu___16 = - FStar_Syntax_Print.univ_to_string - v in - FStar_Compiler_Util.format3 - "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" - uu___14 uu___15 uu___16 in - FStar_Compiler_Effect.failwith - uu___13 - | (uu___11, FStar_Syntax_Syntax.U_unif - uu___12) -> - let uu___13 = - let uu___14 = - FStar_Ident.string_of_lid t in - let uu___15 = - FStar_Syntax_Print.univ_to_string - u in - let uu___16 = - FStar_Syntax_Print.univ_to_string - v in - FStar_Compiler_Util.format3 - "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" - uu___14 uu___15 uu___16 in - FStar_Compiler_Effect.failwith - uu___13 - | uu___11 -> false in - let u_leq_u_k u = - let u1 = - FStar_TypeChecker_Normalize.normalize_universe - env_tps u in - universe_leq u1 u_k in - let tp_ok tp u_tp = - let t_tp = - (tp.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let uu___11 = u_leq_u_k u_tp in - if uu___11 - then true - else - (let t_tp1 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Unrefine; - FStar_TypeChecker_Env.Unascribe; - FStar_TypeChecker_Env.Unmeta; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Beta] - env_tps t_tp in - let uu___13 = - FStar_Syntax_Util.arrow_formals - t_tp1 in - match uu___13 with - | (formals, t1) -> - let uu___14 = - FStar_TypeChecker_TcTerm.tc_binders - env_tps formals in - (match uu___14 with - | (uu___15, uu___16, uu___17, - u_formals) -> - let inj = - FStar_Compiler_Util.for_all - (fun u_formal -> - u_leq_u_k u_formal) - u_formals in - if inj - then - let uu___18 = - let uu___19 = - FStar_Syntax_Subst.compress - t1 in - uu___19.FStar_Syntax_Syntax.n in - (match uu___18 with - | FStar_Syntax_Syntax.Tm_type - u -> u_leq_u_k u - | uu___19 -> false) - else false)) in - let is_injective_on_params = - FStar_Compiler_List.forall2 tp_ok tps3 - us in - ((let uu___12 = - FStar_TypeChecker_Env.debug - env.FStar_SMTEncoding_Env.tcenv - (FStar_Options.Other "SMTEncoding") in - if uu___12 - then - let uu___13 = - FStar_Ident.string_of_lid t in - FStar_Compiler_Util.print2 - "%s injectivity for %s\n" - (if is_injective_on_params - then "YES" - else "NO") uu___13 - else ()); - is_injective_on_params)))))) -let (encode_sig_inductive : - Prims.bool -> - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.sigelt -> - (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.env_t)) - = - fun is_injective_on_params -> - fun env -> - fun se -> - let uu___ = se.FStar_Syntax_Syntax.sigel in - match uu___ with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = t; - FStar_Syntax_Syntax.us = universe_names; - FStar_Syntax_Syntax.params = tps; - FStar_Syntax_Syntax.num_uniform_params = uu___1; - FStar_Syntax_Syntax.t = k; - FStar_Syntax_Syntax.mutuals = uu___2; - FStar_Syntax_Syntax.ds = datas;_} - -> - let t_lid = t in - let tcenv = env.FStar_SMTEncoding_Env.tcenv in - let quals = se.FStar_Syntax_Syntax.sigquals in - let is_logical = - FStar_Compiler_Util.for_some - (fun uu___3 -> - match uu___3 with - | FStar_Syntax_Syntax.Logic -> true - | FStar_Syntax_Syntax.Assumption -> true - | uu___4 -> false) quals in - let constructor_or_logic_type_decl c = - if is_logical - then - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_List.map - (fun f -> f.FStar_SMTEncoding_Term.field_sort) - c.FStar_SMTEncoding_Term.constr_fields in - ((c.FStar_SMTEncoding_Term.constr_name), uu___5, - FStar_SMTEncoding_Term.Term_sort, - FStar_Pervasives_Native.None) in - FStar_SMTEncoding_Term.DeclFun uu___4 in - [uu___3] - else - (let uu___4 = FStar_Ident.range_of_lid t in - FStar_SMTEncoding_Term.constructor_to_decl uu___4 c) in - let inversion_axioms env1 tapp vars = + let quals = se.FStar_Syntax_Syntax.sigquals in + let is_logical = + FStar_Compiler_Util.for_some + (fun uu___3 -> + match uu___3 with + | FStar_Syntax_Syntax.Logic -> true + | FStar_Syntax_Syntax.Assumption -> true + | uu___4 -> false) quals in + let constructor_or_logic_type_decl c = + if is_logical + then let uu___3 = - FStar_Compiler_Util.for_some - (fun l -> - let uu___4 = - FStar_TypeChecker_Env.try_lookup_lid - env1.FStar_SMTEncoding_Env.tcenv l in - FStar_Compiler_Option.isNone uu___4) datas in - if uu___3 - then [] - else - (let uu___5 = - FStar_SMTEncoding_Env.fresh_fvar - env1.FStar_SMTEncoding_Env.current_module_name "x" - FStar_SMTEncoding_Term.Term_sort in - match uu___5 with - | (xxsym, xx) -> - let uu___6 = - FStar_Compiler_List.fold_left - (fun uu___7 -> - fun l -> - match uu___7 with - | (out, decls) -> - let is_l = - FStar_SMTEncoding_Env.mk_data_tester env1 - l xx in - let uu___8 = - let uu___9 = - is_injective_on_params || - (let uu___10 = - FStar_Options.ext_getv - "compat:injectivity" in - uu___10 <> "") in - if uu___9 - then - let uu___10 = - FStar_TypeChecker_Env.lookup_datacon - env1.FStar_SMTEncoding_Env.tcenv l in - match uu___10 with - | (uu___11, data_t) -> - let uu___12 = - FStar_Syntax_Util.arrow_formals - data_t in - (match uu___12 with - | (args, res) -> - let indices = - let uu___13 = - FStar_Syntax_Util.head_and_args_full - res in - FStar_Pervasives_Native.snd - uu___13 in - let env2 = - FStar_Compiler_List.fold_left - (fun env3 -> - fun uu___13 -> - match uu___13 with - | { - FStar_Syntax_Syntax.binder_bv - = x; - FStar_Syntax_Syntax.binder_qual - = uu___14; - FStar_Syntax_Syntax.binder_positivity - = uu___15; - FStar_Syntax_Syntax.binder_attrs - = uu___16;_} - -> - let uu___17 = - let uu___18 = - let uu___19 = - FStar_SMTEncoding_Env.mk_term_projector_name - l x in - (uu___19, - [xx]) in - FStar_SMTEncoding_Util.mkApp - uu___18 in - FStar_SMTEncoding_Env.push_term_var - env3 x uu___17) - env1 args in + let uu___4 = + let uu___5 = + FStar_Compiler_List.map + (fun f -> f.FStar_SMTEncoding_Term.field_sort) + c.FStar_SMTEncoding_Term.constr_fields in + ((c.FStar_SMTEncoding_Term.constr_name), uu___5, + FStar_SMTEncoding_Term.Term_sort, + FStar_Pervasives_Native.None) in + FStar_SMTEncoding_Term.DeclFun uu___4 in + [uu___3] + else + (let uu___4 = FStar_Ident.range_of_lid t in + FStar_SMTEncoding_Term.constructor_to_decl uu___4 c) in + let inversion_axioms env1 tapp vars = + let uu___3 = + FStar_Compiler_Util.for_some + (fun l -> + let uu___4 = + FStar_TypeChecker_Env.try_lookup_lid + env1.FStar_SMTEncoding_Env.tcenv l in + FStar_Compiler_Option.isNone uu___4) datas in + if uu___3 + then [] + else + (let uu___5 = + FStar_SMTEncoding_Env.fresh_fvar + env1.FStar_SMTEncoding_Env.current_module_name "x" + FStar_SMTEncoding_Term.Term_sort in + match uu___5 with + | (xxsym, xx) -> + let uu___6 = + FStar_Compiler_List.fold_left + (fun uu___7 -> + fun l -> + match uu___7 with + | (out, decls) -> + let is_l = + FStar_SMTEncoding_Env.mk_data_tester env1 l + xx in + let uu___8 = + let uu___9 = + injective_type_params || + (let uu___10 = + FStar_Options.ext_getv + "compat:injectivity" in + uu___10 <> "") in + if uu___9 + then + let uu___10 = + FStar_TypeChecker_Env.lookup_datacon + env1.FStar_SMTEncoding_Env.tcenv l in + match uu___10 with + | (uu___11, data_t) -> + let uu___12 = + FStar_Syntax_Util.arrow_formals + data_t in + (match uu___12 with + | (args, res) -> + let indices = let uu___13 = - FStar_SMTEncoding_EncodeTerm.encode_args - indices env2 in - (match uu___13 with - | (indices1, decls') -> - (if - (FStar_Compiler_List.length - indices1) - <> - (FStar_Compiler_List.length - vars) - then - FStar_Compiler_Effect.failwith - "Impossible" - else (); - (let eqs = - FStar_Compiler_List.map2 - (fun v -> - fun a -> - let uu___15 = - let uu___16 - = - FStar_SMTEncoding_Util.mkFreeV - v in - (uu___16, a) in - FStar_SMTEncoding_Util.mkEq - uu___15) - vars indices1 in - let uu___15 = - let uu___16 = + FStar_Syntax_Util.head_and_args_full + res in + FStar_Pervasives_Native.snd + uu___13 in + let env2 = + FStar_Compiler_List.fold_left + (fun env3 -> + fun uu___13 -> + match uu___13 with + | { + FStar_Syntax_Syntax.binder_bv + = x; + FStar_Syntax_Syntax.binder_qual + = uu___14; + FStar_Syntax_Syntax.binder_positivity + = uu___15; + FStar_Syntax_Syntax.binder_attrs + = uu___16;_} + -> let uu___17 = - FStar_SMTEncoding_Util.mk_and_l - eqs in - (is_l, uu___17) in - FStar_SMTEncoding_Util.mkAnd - uu___16 in - (uu___15, decls'))))) - else (is_l, []) in - (match uu___8 with - | (inversion_case, decls') -> - let uu___9 = - FStar_SMTEncoding_Util.mkOr - (out, inversion_case) in - (uu___9, - (FStar_Compiler_List.op_At decls - decls')))) - (FStar_SMTEncoding_Util.mkFalse, []) datas in - (match uu___6 with - | (data_ax, decls) -> - let uu___7 = - FStar_SMTEncoding_Env.fresh_fvar - env1.FStar_SMTEncoding_Env.current_module_name - "f" FStar_SMTEncoding_Term.Fuel_sort in - (match uu___7 with - | (ffsym, ff) -> - let fuel_guarded_inversion = - let xx_has_type_sfuel = - if - (FStar_Compiler_List.length datas) > - Prims.int_one - then - let uu___8 = - FStar_SMTEncoding_Util.mkApp - ("SFuel", [ff]) in - FStar_SMTEncoding_Term.mk_HasTypeFuel - uu___8 xx tapp - else - FStar_SMTEncoding_Term.mk_HasTypeFuel ff - xx tapp in - let uu___8 = - let uu___9 = - let uu___10 = FStar_Ident.range_of_lid t in - let uu___11 = - let uu___12 = - let uu___13 = - FStar_SMTEncoding_Term.mk_fv - (ffsym, - FStar_SMTEncoding_Term.Fuel_sort) in - let uu___14 = - let uu___15 = - FStar_SMTEncoding_Term.mk_fv - (xxsym, - FStar_SMTEncoding_Term.Term_sort) in - uu___15 :: vars in - FStar_SMTEncoding_Env.add_fuel - uu___13 uu___14 in - let uu___13 = - FStar_SMTEncoding_Util.mkImp - (xx_has_type_sfuel, data_ax) in - ([[xx_has_type_sfuel]], uu___12, - uu___13) in - FStar_SMTEncoding_Term.mkForall uu___10 - uu___11 in - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Ident.string_of_lid t in - Prims.strcat "fuel_guarded_inversion_" - uu___12 in - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.mk_unique - uu___11 in - (uu___9, - (FStar_Pervasives_Native.Some - "inversion axiom"), uu___10) in - FStar_SMTEncoding_Util.mkAssume uu___8 in - let uu___8 = - FStar_SMTEncoding_Term.mk_decls_trivial - [fuel_guarded_inversion] in - FStar_Compiler_List.op_At decls uu___8))) in - let uu___3 = - let k1 = - match tps with - | [] -> k - | uu___4 -> - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.mk_Total k in - { - FStar_Syntax_Syntax.bs1 = tps; - FStar_Syntax_Syntax.comp = uu___7 - } in - FStar_Syntax_Syntax.Tm_arrow uu___6 in - FStar_Syntax_Syntax.mk uu___5 k.FStar_Syntax_Syntax.pos in - let k2 = norm_before_encoding env k1 in - FStar_Syntax_Util.arrow_formals k2 in - (match uu___3 with - | (formals, res) -> - let uu___4 = - FStar_SMTEncoding_EncodeTerm.encode_binders - FStar_Pervasives_Native.None formals env in - (match uu___4 with - | (vars, guards, env', binder_decls, uu___5) -> - let arity = FStar_Compiler_List.length vars in - let uu___6 = - FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid - env t arity in - (match uu___6 with - | (tname, ttok, env1) -> - let ttok_tm = - FStar_SMTEncoding_Util.mkApp (ttok, []) in - let guard = FStar_SMTEncoding_Util.mk_and_l guards in - let tapp = - let uu___7 = - let uu___8 = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV vars in - (tname, uu___8) in - FStar_SMTEncoding_Util.mkApp uu___7 in - let uu___7 = - let tname_decl = + let uu___18 = + let uu___19 = + FStar_SMTEncoding_Env.mk_term_projector_name + l x in + (uu___19, [xx]) in + FStar_SMTEncoding_Util.mkApp + uu___18 in + FStar_SMTEncoding_Env.push_term_var + env3 x uu___17) + env1 args in + let uu___13 = + FStar_SMTEncoding_EncodeTerm.encode_args + indices env2 in + (match uu___13 with + | (indices1, decls') -> + (if + (FStar_Compiler_List.length + indices1) + <> + (FStar_Compiler_List.length + vars) + then + FStar_Compiler_Effect.failwith + "Impossible" + else (); + (let eqs = + FStar_Compiler_List.map2 + (fun v -> + fun a -> + let uu___15 = + let uu___16 = + FStar_SMTEncoding_Util.mkFreeV + v in + (uu___16, a) in + FStar_SMTEncoding_Util.mkEq + uu___15) vars + indices1 in + let uu___15 = + let uu___16 = + let uu___17 = + FStar_SMTEncoding_Util.mk_and_l + eqs in + (is_l, uu___17) in + FStar_SMTEncoding_Util.mkAnd + uu___16 in + (uu___15, decls'))))) + else (is_l, []) in + (match uu___8 with + | (inversion_case, decls') -> + let uu___9 = + FStar_SMTEncoding_Util.mkOr + (out, inversion_case) in + (uu___9, + (FStar_Compiler_List.op_At decls + decls')))) + (FStar_SMTEncoding_Util.mkFalse, []) datas in + (match uu___6 with + | (data_ax, decls) -> + let uu___7 = + FStar_SMTEncoding_Env.fresh_fvar + env1.FStar_SMTEncoding_Env.current_module_name + "f" FStar_SMTEncoding_Term.Fuel_sort in + (match uu___7 with + | (ffsym, ff) -> + let fuel_guarded_inversion = + let xx_has_type_sfuel = + if + (FStar_Compiler_List.length datas) > + Prims.int_one + then + let uu___8 = + FStar_SMTEncoding_Util.mkApp + ("SFuel", [ff]) in + FStar_SMTEncoding_Term.mk_HasTypeFuel + uu___8 xx tapp + else + FStar_SMTEncoding_Term.mk_HasTypeFuel ff + xx tapp in let uu___8 = let uu___9 = - FStar_Compiler_List.map - (fun fv -> - let uu___10 = - let uu___11 = - FStar_SMTEncoding_Term.fv_name fv in - Prims.strcat tname uu___11 in - let uu___11 = - FStar_SMTEncoding_Term.fv_sort fv in - { - FStar_SMTEncoding_Term.field_name = - uu___10; - FStar_SMTEncoding_Term.field_sort = - uu___11; - FStar_SMTEncoding_Term.field_projectible - = false - }) vars in + let uu___10 = FStar_Ident.range_of_lid t in + let uu___11 = + let uu___12 = + let uu___13 = + FStar_SMTEncoding_Term.mk_fv + (ffsym, + FStar_SMTEncoding_Term.Fuel_sort) in + let uu___14 = + let uu___15 = + FStar_SMTEncoding_Term.mk_fv + (xxsym, + FStar_SMTEncoding_Term.Term_sort) in + uu___15 :: vars in + FStar_SMTEncoding_Env.add_fuel uu___13 + uu___14 in + let uu___13 = + FStar_SMTEncoding_Util.mkImp + (xx_has_type_sfuel, data_ax) in + ([[xx_has_type_sfuel]], uu___12, + uu___13) in + FStar_SMTEncoding_Term.mkForall uu___10 + uu___11 in let uu___10 = let uu___11 = + let uu___12 = + FStar_Ident.string_of_lid t in + Prims.strcat "fuel_guarded_inversion_" + uu___12 in + FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.mk_unique + uu___11 in + (uu___9, + (FStar_Pervasives_Native.Some + "inversion axiom"), uu___10) in + FStar_SMTEncoding_Util.mkAssume uu___8 in + let uu___8 = + FStar_SMTEncoding_Term.mk_decls_trivial + [fuel_guarded_inversion] in + FStar_Compiler_List.op_At decls uu___8))) in + let uu___3 = + let k1 = + match tps with + | [] -> k + | uu___4 -> + let uu___5 = + let uu___6 = + let uu___7 = FStar_Syntax_Syntax.mk_Total k in + { + FStar_Syntax_Syntax.bs1 = tps; + FStar_Syntax_Syntax.comp = uu___7 + } in + FStar_Syntax_Syntax.Tm_arrow uu___6 in + FStar_Syntax_Syntax.mk uu___5 k.FStar_Syntax_Syntax.pos in + let k2 = norm_before_encoding env k1 in + FStar_Syntax_Util.arrow_formals k2 in + (match uu___3 with + | (formals, res) -> + let uu___4 = + FStar_SMTEncoding_EncodeTerm.encode_binders + FStar_Pervasives_Native.None formals env in + (match uu___4 with + | (vars, guards, env', binder_decls, uu___5) -> + let arity = FStar_Compiler_List.length vars in + let uu___6 = + FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid + env t arity in + (match uu___6 with + | (tname, ttok, env1) -> + let ttok_tm = + FStar_SMTEncoding_Util.mkApp (ttok, []) in + let guard = FStar_SMTEncoding_Util.mk_and_l guards in + let tapp = + let uu___7 = + let uu___8 = + FStar_Compiler_List.map + FStar_SMTEncoding_Util.mkFreeV vars in + (tname, uu___8) in + FStar_SMTEncoding_Util.mkApp uu___7 in + let uu___7 = + let tname_decl = + let uu___8 = + let uu___9 = + FStar_Compiler_List.map + (fun fv -> + let uu___10 = + let uu___11 = + FStar_SMTEncoding_Term.fv_name fv in + Prims.strcat tname uu___11 in + let uu___11 = + FStar_SMTEncoding_Term.fv_sort fv in + { + FStar_SMTEncoding_Term.field_name = + uu___10; + FStar_SMTEncoding_Term.field_sort = + uu___11; + FStar_SMTEncoding_Term.field_projectible + = false + }) vars in + let uu___10 = + let uu___11 = + FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id + () in + FStar_Pervasives_Native.Some uu___11 in + { + FStar_SMTEncoding_Term.constr_name = tname; + FStar_SMTEncoding_Term.constr_fields = + uu___9; + FStar_SMTEncoding_Term.constr_sort = + FStar_SMTEncoding_Term.Term_sort; + FStar_SMTEncoding_Term.constr_id = uu___10; + FStar_SMTEncoding_Term.constr_base = false + } in + constructor_or_logic_type_decl uu___8 in + let uu___8 = + match vars with + | [] -> + let uu___9 = + let uu___10 = + let uu___11 = + FStar_SMTEncoding_Util.mkApp + (tname, []) in + FStar_Pervasives_Native.Some uu___11 in + FStar_SMTEncoding_Env.push_free_var env1 t + arity tname uu___10 in + ([], uu___9) + | uu___9 -> + let ttok_decl = + FStar_SMTEncoding_Term.DeclFun + (ttok, [], + FStar_SMTEncoding_Term.Term_sort, + (FStar_Pervasives_Native.Some "token")) in + let ttok_fresh = + let uu___10 = FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id () in - FStar_Pervasives_Native.Some uu___11 in - { - FStar_SMTEncoding_Term.constr_name = tname; - FStar_SMTEncoding_Term.constr_fields = - uu___9; - FStar_SMTEncoding_Term.constr_sort = - FStar_SMTEncoding_Term.Term_sort; - FStar_SMTEncoding_Term.constr_id = uu___10; - FStar_SMTEncoding_Term.constr_base = false - } in - constructor_or_logic_type_decl uu___8 in - let uu___8 = - match vars with - | [] -> - let uu___9 = - let uu___10 = - let uu___11 = - FStar_SMTEncoding_Util.mkApp - (tname, []) in - FStar_Pervasives_Native.Some uu___11 in - FStar_SMTEncoding_Env.push_free_var env1 - t arity tname uu___10 in - ([], uu___9) - | uu___9 -> - let ttok_decl = - FStar_SMTEncoding_Term.DeclFun - (ttok, [], - FStar_SMTEncoding_Term.Term_sort, - (FStar_Pervasives_Native.Some - "token")) in - let ttok_fresh = - let uu___10 = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id - () in - FStar_SMTEncoding_Term.fresh_token - (ttok, - FStar_SMTEncoding_Term.Term_sort) - uu___10 in - let ttok_app = - FStar_SMTEncoding_EncodeTerm.mk_Apply - ttok_tm vars in - let pats = [[ttok_app]; [tapp]] in - let name_tok_corr = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Ident.range_of_lid t in - let uu___13 = - let uu___14 = - FStar_SMTEncoding_Util.mkEq - (ttok_app, tapp) in - (pats, - FStar_Pervasives_Native.None, - vars, uu___14) in - FStar_SMTEncoding_Term.mkForall' - uu___12 uu___13 in - (uu___11, - (FStar_Pervasives_Native.Some - "name-token correspondence"), - (Prims.strcat - "token_correspondence_" ttok)) in - FStar_SMTEncoding_Util.mkAssume uu___10 in - ([ttok_decl; ttok_fresh; name_tok_corr], - env1) in - match uu___8 with - | (tok_decls, env2) -> - ((FStar_Compiler_List.op_At tname_decl - tok_decls), env2) in - (match uu___7 with - | (decls, env2) -> - let kindingAx = - let uu___8 = - FStar_SMTEncoding_EncodeTerm.encode_term_pred - FStar_Pervasives_Native.None res env' - tapp in - match uu___8 with - | (k1, decls1) -> - let karr = - if - (FStar_Compiler_List.length formals) - > Prims.int_zero - then - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_SMTEncoding_Term.mk_PreType - ttok_tm in - FStar_SMTEncoding_Term.mk_tester - "Tm_arrow" uu___12 in - (uu___11, - (FStar_Pervasives_Native.Some - "kinding"), - (Prims.strcat "pre_kinding_" - ttok)) in - FStar_SMTEncoding_Util.mkAssume - uu___10 in - [uu___9] - else [] in - let rng = FStar_Ident.range_of_lid t in - let tot_fun_axioms = + FStar_SMTEncoding_Term.fresh_token + (ttok, FStar_SMTEncoding_Term.Term_sort) + uu___10 in + let ttok_app = + FStar_SMTEncoding_EncodeTerm.mk_Apply + ttok_tm vars in + let pats = [[ttok_app]; [tapp]] in + let name_tok_corr = + let uu___10 = + let uu___11 = + let uu___12 = + FStar_Ident.range_of_lid t in + let uu___13 = + let uu___14 = + FStar_SMTEncoding_Util.mkEq + (ttok_app, tapp) in + (pats, FStar_Pervasives_Native.None, + vars, uu___14) in + FStar_SMTEncoding_Term.mkForall' + uu___12 uu___13 in + (uu___11, + (FStar_Pervasives_Native.Some + "name-token correspondence"), + (Prims.strcat "token_correspondence_" + ttok)) in + FStar_SMTEncoding_Util.mkAssume uu___10 in + ([ttok_decl; ttok_fresh; name_tok_corr], + env1) in + match uu___8 with + | (tok_decls, env2) -> + ((FStar_Compiler_List.op_At tname_decl + tok_decls), env2) in + (match uu___7 with + | (decls, env2) -> + let kindingAx = + let uu___8 = + FStar_SMTEncoding_EncodeTerm.encode_term_pred + FStar_Pervasives_Native.None res env' + tapp in + match uu___8 with + | (k1, decls1) -> + let karr = + if + (FStar_Compiler_List.length formals) + > Prims.int_zero + then let uu___9 = - FStar_Compiler_List.map - (fun uu___10 -> - FStar_SMTEncoding_Util.mkTrue) - vars in - FStar_SMTEncoding_EncodeTerm.isTotFun_axioms - rng ttok_tm vars uu___9 true in + let uu___10 = + let uu___11 = + let uu___12 = + FStar_SMTEncoding_Term.mk_PreType + ttok_tm in + FStar_SMTEncoding_Term.mk_tester + "Tm_arrow" uu___12 in + (uu___11, + (FStar_Pervasives_Native.Some + "kinding"), + (Prims.strcat "pre_kinding_" + ttok)) in + FStar_SMTEncoding_Util.mkAssume + uu___10 in + [uu___9] + else [] in + let rng = FStar_Ident.range_of_lid t in + let tot_fun_axioms = let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - FStar_SMTEncoding_Util.mkImp - (guard, k1) in - ([[tapp]], vars, - uu___18) in - FStar_SMTEncoding_Term.mkForall - rng uu___17 in - (tot_fun_axioms, uu___16) in - FStar_SMTEncoding_Util.mkAnd - uu___15 in - (uu___14, - FStar_Pervasives_Native.None, - (Prims.strcat "kinding_" - ttok)) in - FStar_SMTEncoding_Util.mkAssume - uu___13 in - [uu___12] in - FStar_Compiler_List.op_At karr - uu___11 in - FStar_SMTEncoding_Term.mk_decls_trivial - uu___10 in - FStar_Compiler_List.op_At decls1 uu___9 in - let aux = - let uu___8 = + FStar_Compiler_List.map + (fun uu___10 -> + FStar_SMTEncoding_Util.mkTrue) + vars in + FStar_SMTEncoding_EncodeTerm.isTotFun_axioms + rng ttok_tm vars uu___9 true in let uu___9 = - inversion_axioms env2 tapp vars in - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Ident.range_of_lid t in - pretype_axiom - (Prims.op_Negation - is_injective_on_params) - uu___13 env2 tapp vars in - [uu___12] in + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + FStar_SMTEncoding_Util.mkImp + (guard, k1) in + ([[tapp]], vars, + uu___18) in + FStar_SMTEncoding_Term.mkForall + rng uu___17 in + (tot_fun_axioms, uu___16) in + FStar_SMTEncoding_Util.mkAnd + uu___15 in + (uu___14, + FStar_Pervasives_Native.None, + (Prims.strcat "kinding_" ttok)) in + FStar_SMTEncoding_Util.mkAssume + uu___13 in + [uu___12] in + FStar_Compiler_List.op_At karr + uu___11 in FStar_SMTEncoding_Term.mk_decls_trivial - uu___11 in - FStar_Compiler_List.op_At uu___9 uu___10 in - FStar_Compiler_List.op_At kindingAx uu___8 in + uu___10 in + FStar_Compiler_List.op_At decls1 uu___9 in + let aux = let uu___8 = let uu___9 = + inversion_axioms env2 tapp vars in + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + FStar_Ident.range_of_lid t in + pretype_axiom + (Prims.op_Negation + injective_type_params) uu___13 + env2 tapp vars in + [uu___12] in FStar_SMTEncoding_Term.mk_decls_trivial - decls in - FStar_Compiler_List.op_At uu___9 - (FStar_Compiler_List.op_At binder_decls - aux) in - (uu___8, env2))))) + uu___11 in + FStar_Compiler_List.op_At uu___9 uu___10 in + FStar_Compiler_List.op_At kindingAx uu___8 in + let uu___8 = + let uu___9 = + FStar_SMTEncoding_Term.mk_decls_trivial + decls in + FStar_Compiler_List.op_At uu___9 + (FStar_Compiler_List.op_At binder_decls aux) in + (uu___8, env2))))) let (encode_datacon : - Prims.bool -> - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.sigelt -> - (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.env_t)) + FStar_SMTEncoding_Env.env_t -> + FStar_Syntax_Syntax.sigelt -> + (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.env_t)) = - fun is_injective_on_tparams -> - fun env -> - fun se -> - let uu___ = se.FStar_Syntax_Syntax.sigel in - match uu___ with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = d; FStar_Syntax_Syntax.us1 = uu___1; - FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = uu___2; - FStar_Syntax_Syntax.num_ty_params = n_tps; - FStar_Syntax_Syntax.mutuals1 = mutuals;_} - -> - let quals = se.FStar_Syntax_Syntax.sigquals in - let t1 = norm_before_encoding env t in - let uu___3 = FStar_Syntax_Util.arrow_formals t1 in - (match uu___3 with - | (formals, t_res) -> - let arity = FStar_Compiler_List.length formals in - let uu___4 = - FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid - env d arity in - (match uu___4 with - | (ddconstrsym, ddtok, env1) -> - let ddtok_tm = FStar_SMTEncoding_Util.mkApp (ddtok, []) in - let uu___5 = - FStar_SMTEncoding_Env.fresh_fvar - env1.FStar_SMTEncoding_Env.current_module_name "f" - FStar_SMTEncoding_Term.Fuel_sort in - (match uu___5 with - | (fuel_var, fuel_tm) -> - let s_fuel_tm = - FStar_SMTEncoding_Util.mkApp - ("SFuel", [fuel_tm]) in - let uu___6 = - FStar_SMTEncoding_EncodeTerm.encode_binders - (FStar_Pervasives_Native.Some fuel_tm) formals - env1 in - (match uu___6 with - | (vars, guards, env', binder_decls, names) -> - let is_injective_on_tparams1 = - is_injective_on_tparams || - (let uu___7 = - FStar_Options.ext_getv - "compat:injectivity" in - uu___7 <> "") in - let fields = - FStar_Compiler_List.mapi - (fun n -> - fun x -> - let field_projectible = - (n >= n_tps) || - is_injective_on_tparams1 in - let uu___7 = - FStar_SMTEncoding_Env.mk_term_projector_name - d x in - { - FStar_SMTEncoding_Term.field_name - = uu___7; - FStar_SMTEncoding_Term.field_sort - = - FStar_SMTEncoding_Term.Term_sort; - FStar_SMTEncoding_Term.field_projectible - = field_projectible - }) names in - let datacons = - let uu___7 = FStar_Ident.range_of_lid d in - let uu___8 = - let uu___9 = - let uu___10 = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id - () in - FStar_Pervasives_Native.Some uu___10 in - { - FStar_SMTEncoding_Term.constr_name = - ddconstrsym; - FStar_SMTEncoding_Term.constr_fields = - fields; - FStar_SMTEncoding_Term.constr_sort = - FStar_SMTEncoding_Term.Term_sort; - FStar_SMTEncoding_Term.constr_id = - uu___9; - FStar_SMTEncoding_Term.constr_base = - (Prims.op_Negation - is_injective_on_tparams1) - } in - FStar_SMTEncoding_Term.constructor_to_decl - uu___7 uu___8 in - let app = - FStar_SMTEncoding_EncodeTerm.mk_Apply - ddtok_tm vars in - let guard = - FStar_SMTEncoding_Util.mk_and_l guards in - let xvars = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV vars in - let dapp = - FStar_SMTEncoding_Util.mkApp - (ddconstrsym, xvars) in - let uu___7 = - FStar_SMTEncoding_EncodeTerm.encode_term_pred - FStar_Pervasives_Native.None t1 env1 - ddtok_tm in - (match uu___7 with - | (tok_typing, decls3) -> - let tok_typing1 = - match fields with - | uu___8::uu___9 -> - let ff = - FStar_SMTEncoding_Term.mk_fv - ("ty", - FStar_SMTEncoding_Term.Term_sort) in - let f = - FStar_SMTEncoding_Util.mkFreeV - ff in - let vtok_app_l = - FStar_SMTEncoding_EncodeTerm.mk_Apply - ddtok_tm [ff] in - let vtok_app_r = - let uu___10 = - let uu___11 = - FStar_SMTEncoding_Term.mk_fv - (ddtok, - FStar_SMTEncoding_Term.Term_sort) in - [uu___11] in - FStar_SMTEncoding_EncodeTerm.mk_Apply - f uu___10 in - let uu___10 = - FStar_Ident.range_of_lid d in - let uu___11 = - let uu___12 = - FStar_SMTEncoding_Term.mk_NoHoist - f tok_typing in - ([[vtok_app_l]; [vtok_app_r]], - [ff], uu___12) in - FStar_SMTEncoding_Term.mkForall - uu___10 uu___11 - | uu___8 -> tok_typing in - let uu___8 = - let uu___9 = - FStar_SMTEncoding_EncodeTerm.encode_term - t_res env' in - match uu___9 with - | (t_res_tm, t_res_decls) -> + fun env -> + fun se -> + let uu___ = se.FStar_Syntax_Syntax.sigel in + match uu___ with + | FStar_Syntax_Syntax.Sig_datacon + { FStar_Syntax_Syntax.lid1 = d; FStar_Syntax_Syntax.us1 = uu___1; + FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___2; + FStar_Syntax_Syntax.num_ty_params = n_tps; + FStar_Syntax_Syntax.mutuals1 = mutuals; + FStar_Syntax_Syntax.injective_type_params1 = + injective_type_params;_} + -> + let quals = se.FStar_Syntax_Syntax.sigquals in + let t1 = norm_before_encoding env t in + let uu___3 = FStar_Syntax_Util.arrow_formals t1 in + (match uu___3 with + | (formals, t_res) -> + let arity = FStar_Compiler_List.length formals in + let uu___4 = + FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid env + d arity in + (match uu___4 with + | (ddconstrsym, ddtok, env1) -> + let ddtok_tm = FStar_SMTEncoding_Util.mkApp (ddtok, []) in + let uu___5 = + FStar_SMTEncoding_Env.fresh_fvar + env1.FStar_SMTEncoding_Env.current_module_name "f" + FStar_SMTEncoding_Term.Fuel_sort in + (match uu___5 with + | (fuel_var, fuel_tm) -> + let s_fuel_tm = + FStar_SMTEncoding_Util.mkApp ("SFuel", [fuel_tm]) in + let uu___6 = + FStar_SMTEncoding_EncodeTerm.encode_binders + (FStar_Pervasives_Native.Some fuel_tm) formals + env1 in + (match uu___6 with + | (vars, guards, env', binder_decls, names) -> + let injective_type_params1 = + injective_type_params || + (let uu___7 = + FStar_Options.ext_getv + "compat:injectivity" in + uu___7 <> "") in + let fields = + FStar_Compiler_List.mapi + (fun n -> + fun x -> + let field_projectible = + (n >= n_tps) || + injective_type_params1 in + let uu___7 = + FStar_SMTEncoding_Env.mk_term_projector_name + d x in + { + FStar_SMTEncoding_Term.field_name = + uu___7; + FStar_SMTEncoding_Term.field_sort = + FStar_SMTEncoding_Term.Term_sort; + FStar_SMTEncoding_Term.field_projectible + = field_projectible + }) names in + let datacons = + let uu___7 = FStar_Ident.range_of_lid d in + let uu___8 = + let uu___9 = + let uu___10 = + FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id + () in + FStar_Pervasives_Native.Some uu___10 in + { + FStar_SMTEncoding_Term.constr_name = + ddconstrsym; + FStar_SMTEncoding_Term.constr_fields = + fields; + FStar_SMTEncoding_Term.constr_sort = + FStar_SMTEncoding_Term.Term_sort; + FStar_SMTEncoding_Term.constr_id = uu___9; + FStar_SMTEncoding_Term.constr_base = + (Prims.op_Negation + injective_type_params1) + } in + FStar_SMTEncoding_Term.constructor_to_decl + uu___7 uu___8 in + let app = + FStar_SMTEncoding_EncodeTerm.mk_Apply + ddtok_tm vars in + let guard = + FStar_SMTEncoding_Util.mk_and_l guards in + let xvars = + FStar_Compiler_List.map + FStar_SMTEncoding_Util.mkFreeV vars in + let dapp = + FStar_SMTEncoding_Util.mkApp + (ddconstrsym, xvars) in + let uu___7 = + FStar_SMTEncoding_EncodeTerm.encode_term_pred + FStar_Pervasives_Native.None t1 env1 + ddtok_tm in + (match uu___7 with + | (tok_typing, decls3) -> + let tok_typing1 = + match fields with + | uu___8::uu___9 -> + let ff = + FStar_SMTEncoding_Term.mk_fv + ("ty", + FStar_SMTEncoding_Term.Term_sort) in + let f = + FStar_SMTEncoding_Util.mkFreeV ff in + let vtok_app_l = + FStar_SMTEncoding_EncodeTerm.mk_Apply + ddtok_tm [ff] in + let vtok_app_r = let uu___10 = - FStar_SMTEncoding_Term.mk_HasTypeWithFuel - (FStar_Pervasives_Native.Some - fuel_tm) dapp t_res_tm in - (uu___10, t_res_tm, t_res_decls) in - (match uu___8 with - | (ty_pred', t_res_tm, decls_pred) -> - let proxy_fresh = - match formals with - | [] -> [] - | uu___9 -> - let uu___10 = - let uu___11 = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id - () in - FStar_SMTEncoding_Term.fresh_token - (ddtok, - FStar_SMTEncoding_Term.Term_sort) - uu___11 in - [uu___10] in - let encode_elim uu___9 = - let uu___10 = - FStar_Syntax_Util.head_and_args - t_res in - match uu___10 with - | (head, args) -> + let uu___11 = + FStar_SMTEncoding_Term.mk_fv + (ddtok, + FStar_SMTEncoding_Term.Term_sort) in + [uu___11] in + FStar_SMTEncoding_EncodeTerm.mk_Apply + f uu___10 in + let uu___10 = + FStar_Ident.range_of_lid d in + let uu___11 = + let uu___12 = + FStar_SMTEncoding_Term.mk_NoHoist + f tok_typing in + ([[vtok_app_l]; [vtok_app_r]], + [ff], uu___12) in + FStar_SMTEncoding_Term.mkForall + uu___10 uu___11 + | uu___8 -> tok_typing in + let uu___8 = + let uu___9 = + FStar_SMTEncoding_EncodeTerm.encode_term + t_res env' in + match uu___9 with + | (t_res_tm, t_res_decls) -> + let uu___10 = + FStar_SMTEncoding_Term.mk_HasTypeWithFuel + (FStar_Pervasives_Native.Some + fuel_tm) dapp t_res_tm in + (uu___10, t_res_tm, t_res_decls) in + (match uu___8 with + | (ty_pred', t_res_tm, decls_pred) -> + let proxy_fresh = + match formals with + | [] -> [] + | uu___9 -> + let uu___10 = let uu___11 = - let uu___12 = - FStar_Syntax_Subst.compress - head in - uu___12.FStar_Syntax_Syntax.n in - (match uu___11 with - | FStar_Syntax_Syntax.Tm_uinst - ({ - FStar_Syntax_Syntax.n - = - FStar_Syntax_Syntax.Tm_fvar - fv; - FStar_Syntax_Syntax.pos - = uu___12; - FStar_Syntax_Syntax.vars - = uu___13; - FStar_Syntax_Syntax.hash_code - = uu___14;_}, - uu___15) - -> - let encoded_head_fvb = - FStar_SMTEncoding_Env.lookup_free_var_name - env' - fv.FStar_Syntax_Syntax.fv_name in - let uu___16 = - FStar_SMTEncoding_EncodeTerm.encode_args - args env' in - (match uu___16 with - | (encoded_args, - arg_decls) -> - let uu___17 = - let uu___18 = - FStar_Compiler_List.zip - args - encoded_args in - FStar_Compiler_List.fold_left - (fun uu___19 -> - fun uu___20 - -> - match - (uu___19, + FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id + () in + FStar_SMTEncoding_Term.fresh_token + (ddtok, + FStar_SMTEncoding_Term.Term_sort) + uu___11 in + [uu___10] in + let encode_elim uu___9 = + let uu___10 = + FStar_Syntax_Util.head_and_args + t_res in + match uu___10 with + | (head, args) -> + let uu___11 = + let uu___12 = + FStar_Syntax_Subst.compress + head in + uu___12.FStar_Syntax_Syntax.n in + (match uu___11 with + | FStar_Syntax_Syntax.Tm_uinst + ({ + FStar_Syntax_Syntax.n = + FStar_Syntax_Syntax.Tm_fvar + fv; + FStar_Syntax_Syntax.pos + = uu___12; + FStar_Syntax_Syntax.vars + = uu___13; + FStar_Syntax_Syntax.hash_code + = uu___14;_}, + uu___15) + -> + let encoded_head_fvb = + FStar_SMTEncoding_Env.lookup_free_var_name + env' + fv.FStar_Syntax_Syntax.fv_name in + let uu___16 = + FStar_SMTEncoding_EncodeTerm.encode_args + args env' in + (match uu___16 with + | (encoded_args, + arg_decls) -> + let uu___17 = + let uu___18 = + FStar_Compiler_List.zip + args + encoded_args in + FStar_Compiler_List.fold_left + (fun uu___19 -> + fun uu___20 -> + match + (uu___19, uu___20) - with - | - ((env2, + with + | ((env2, arg_vars, eqns_or_guards, i), @@ -4717,36 +4488,34 @@ let (encode_datacon : eqns, (i + Prims.int_one)))) - (env', [], [], - Prims.int_zero) - uu___18 in - (match uu___17 with - | (uu___18, - arg_vars, - elim_eqns_or_guards, - uu___19) -> - let arg_vars1 - = - FStar_Compiler_List.rev - arg_vars in - let uu___20 = - FStar_Compiler_List.splitAt - n_tps - arg_vars1 in - (match uu___20 - with - | (arg_params, - uu___21) - -> - let uu___22 + (env', [], [], + Prims.int_zero) + uu___18 in + (match uu___17 with + | (uu___18, + arg_vars, + elim_eqns_or_guards, + uu___19) -> + let arg_vars1 = + FStar_Compiler_List.rev + arg_vars in + let uu___20 = + FStar_Compiler_List.splitAt + n_tps + arg_vars1 in + (match uu___20 + with + | (arg_params, + uu___21) -> + let uu___22 = FStar_Compiler_List.splitAt n_tps vars in - (match uu___22 - with - | - (data_arg_params, + (match uu___22 + with + | + (data_arg_params, uu___23) -> let elim_eqns_and_guards @@ -5393,33 +5162,31 @@ let (encode_datacon : [typing_inversion; subterm_ordering] codomain_ordering))))))) - | FStar_Syntax_Syntax.Tm_fvar - fv -> - let encoded_head_fvb = - FStar_SMTEncoding_Env.lookup_free_var_name - env' - fv.FStar_Syntax_Syntax.fv_name in - let uu___12 = - FStar_SMTEncoding_EncodeTerm.encode_args - args env' in - (match uu___12 with - | (encoded_args, - arg_decls) -> - let uu___13 = - let uu___14 = - FStar_Compiler_List.zip - args - encoded_args in - FStar_Compiler_List.fold_left - (fun uu___15 -> - fun uu___16 - -> - match - (uu___15, + | FStar_Syntax_Syntax.Tm_fvar + fv -> + let encoded_head_fvb = + FStar_SMTEncoding_Env.lookup_free_var_name + env' + fv.FStar_Syntax_Syntax.fv_name in + let uu___12 = + FStar_SMTEncoding_EncodeTerm.encode_args + args env' in + (match uu___12 with + | (encoded_args, + arg_decls) -> + let uu___13 = + let uu___14 = + FStar_Compiler_List.zip + args + encoded_args in + FStar_Compiler_List.fold_left + (fun uu___15 -> + fun uu___16 -> + match + (uu___15, uu___16) - with - | - ((env2, + with + | ((env2, arg_vars, eqns_or_guards, i), @@ -5461,36 +5228,34 @@ let (encode_datacon : eqns, (i + Prims.int_one)))) - (env', [], [], - Prims.int_zero) - uu___14 in - (match uu___13 with - | (uu___14, - arg_vars, - elim_eqns_or_guards, - uu___15) -> - let arg_vars1 - = - FStar_Compiler_List.rev - arg_vars in - let uu___16 = - FStar_Compiler_List.splitAt - n_tps - arg_vars1 in - (match uu___16 - with - | (arg_params, - uu___17) - -> - let uu___18 + (env', [], [], + Prims.int_zero) + uu___14 in + (match uu___13 with + | (uu___14, + arg_vars, + elim_eqns_or_guards, + uu___15) -> + let arg_vars1 = + FStar_Compiler_List.rev + arg_vars in + let uu___16 = + FStar_Compiler_List.splitAt + n_tps + arg_vars1 in + (match uu___16 + with + | (arg_params, + uu___17) -> + let uu___18 = FStar_Compiler_List.splitAt n_tps vars in - (match uu___18 - with - | - (data_arg_params, + (match uu___18 + with + | + (data_arg_params, uu___19) -> let elim_eqns_and_guards @@ -6137,62 +5902,59 @@ let (encode_datacon : [typing_inversion; subterm_ordering] codomain_ordering))))))) - | uu___12 -> - ((let uu___14 = - let uu___15 = - let uu___16 = - FStar_Syntax_Print.lid_to_string - d in - let uu___17 = - FStar_Syntax_Print.term_to_string - head in - FStar_Compiler_Util.format2 - "Constructor %s builds an unexpected type %s\n" - uu___16 uu___17 in - (FStar_Errors_Codes.Warning_ConstructorBuildsUnexpectedType, - uu___15) in - FStar_Errors.log_issue - se.FStar_Syntax_Syntax.sigrng - uu___14); - ([], []))) in - let uu___9 = encode_elim () in - (match uu___9 with - | (decls2, elim) -> - let data_cons_typing_intro_decl - = - let uu___10 = - match t_res_tm.FStar_SMTEncoding_Term.tm - with - | FStar_SMTEncoding_Term.App - (op, args) -> - let uu___11 = - FStar_Compiler_List.splitAt - n_tps args in - (match uu___11 with - | (targs, iargs) -> - let uu___12 = - let uu___13 = - FStar_Compiler_List.map - (fun - uu___14 - -> - FStar_SMTEncoding_Env.fresh_fvar + | uu___12 -> + ((let uu___14 = + let uu___15 = + let uu___16 = + FStar_Syntax_Print.lid_to_string + d in + let uu___17 = + FStar_Syntax_Print.term_to_string + head in + FStar_Compiler_Util.format2 + "Constructor %s builds an unexpected type %s\n" + uu___16 uu___17 in + (FStar_Errors_Codes.Warning_ConstructorBuildsUnexpectedType, + uu___15) in + FStar_Errors.log_issue + se.FStar_Syntax_Syntax.sigrng + uu___14); + ([], []))) in + let uu___9 = encode_elim () in + (match uu___9 with + | (decls2, elim) -> + let data_cons_typing_intro_decl + = + let uu___10 = + match t_res_tm.FStar_SMTEncoding_Term.tm + with + | FStar_SMTEncoding_Term.App + (op, args) -> + let uu___11 = + FStar_Compiler_List.splitAt + n_tps args in + (match uu___11 with + | (targs, iargs) -> + let uu___12 = + let uu___13 = + FStar_Compiler_List.map + (fun uu___14 + -> + FStar_SMTEncoding_Env.fresh_fvar env1.FStar_SMTEncoding_Env.current_module_name "i" FStar_SMTEncoding_Term.Term_sort) - iargs in - FStar_Compiler_List.split - uu___13 in - (match uu___12 - with - | (fresh_ivars, - fresh_iargs) - -> - let additional_guards + iargs in + FStar_Compiler_List.split + uu___13 in + (match uu___12 with + | (fresh_ivars, + fresh_iargs) -> + let additional_guards + = + let uu___13 = - let uu___13 - = - FStar_Compiler_List.map2 + FStar_Compiler_List.map2 (fun a -> fun fresh_a @@ -6202,15 +5964,14 @@ let (encode_datacon : fresh_a)) iargs fresh_iargs in - FStar_SMTEncoding_Util.mk_and_l - uu___13 in - let uu___13 - = - FStar_SMTEncoding_Term.mk_HasTypeWithFuel - (FStar_Pervasives_Native.Some + FStar_SMTEncoding_Util.mk_and_l + uu___13 in + let uu___13 = + FStar_SMTEncoding_Term.mk_HasTypeWithFuel + (FStar_Pervasives_Native.Some fuel_tm) - dapp - { + dapp + { FStar_SMTEncoding_Term.tm = (FStar_SMTEncoding_Term.App @@ -6224,115 +5985,109 @@ let (encode_datacon : FStar_SMTEncoding_Term.rng = (t_res_tm.FStar_SMTEncoding_Term.rng) - } in - let uu___14 + } in + let uu___14 = + let uu___15 = - let uu___15 - = - FStar_Compiler_List.map + FStar_Compiler_List.map (fun s -> FStar_SMTEncoding_Term.mk_fv (s, FStar_SMTEncoding_Term.Term_sort)) fresh_ivars in - FStar_Compiler_List.op_At - vars - uu___15 in - let uu___15 - = - FStar_SMTEncoding_Util.mkAnd - (guard, + FStar_Compiler_List.op_At + vars + uu___15 in + let uu___15 = + FStar_SMTEncoding_Util.mkAnd + (guard, additional_guards) in - (uu___13, - uu___14, - uu___15))) - | uu___11 -> - (ty_pred', vars, - guard) in - match uu___10 with - | (ty_pred'1, vars1, guard1) - -> - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Ident.range_of_lid - d in - let uu___14 = - let uu___15 = - let uu___16 = - FStar_SMTEncoding_Term.mk_fv - (fuel_var, - FStar_SMTEncoding_Term.Fuel_sort) in - FStar_SMTEncoding_Env.add_fuel - uu___16 vars1 in - let uu___16 = - FStar_SMTEncoding_Util.mkImp - (guard1, - ty_pred'1) in - ([[ty_pred'1]], - uu___15, - uu___16) in - FStar_SMTEncoding_Term.mkForall - uu___13 uu___14 in - (uu___12, - (FStar_Pervasives_Native.Some - "data constructor typing intro"), - (Prims.strcat - "data_typing_intro_" - ddtok)) in - FStar_SMTEncoding_Util.mkAssume - uu___11 in - let g = - let uu___10 = + (uu___13, + uu___14, + uu___15))) + | uu___11 -> + (ty_pred', vars, guard) in + match uu___10 with + | (ty_pred'1, vars1, guard1) + -> let uu___11 = let uu___12 = let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 + FStar_Ident.range_of_lid + d in + let uu___14 = + let uu___15 = + let uu___16 = + FStar_SMTEncoding_Term.mk_fv + (fuel_var, + FStar_SMTEncoding_Term.Fuel_sort) in + FStar_SMTEncoding_Env.add_fuel + uu___16 vars1 in + let uu___16 = + FStar_SMTEncoding_Util.mkImp + (guard1, + ty_pred'1) in + ([[ty_pred'1]], + uu___15, uu___16) in + FStar_SMTEncoding_Term.mkForall + uu___13 uu___14 in + (uu___12, + (FStar_Pervasives_Native.Some + "data constructor typing intro"), + (Prims.strcat + "data_typing_intro_" + ddtok)) in + FStar_SMTEncoding_Util.mkAssume + uu___11 in + let g = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + let uu___19 = - let uu___19 - = - let uu___20 + let uu___20 = FStar_Syntax_Print.lid_to_string d in - FStar_Compiler_Util.format1 + FStar_Compiler_Util.format1 "data constructor proxy: %s" uu___20 in - FStar_Pervasives_Native.Some - uu___19 in - (ddtok, [], - FStar_SMTEncoding_Term.Term_sort, - uu___18) in - FStar_SMTEncoding_Term.DeclFun - uu___17 in - [uu___16] in - FStar_Compiler_List.op_At - uu___15 - proxy_fresh in - FStar_SMTEncoding_Term.mk_decls_trivial - uu___14 in - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - FStar_SMTEncoding_Util.mkAssume - (tok_typing1, - (FStar_Pervasives_Native.Some + FStar_Pervasives_Native.Some + uu___19 in + (ddtok, [], + FStar_SMTEncoding_Term.Term_sort, + uu___18) in + FStar_SMTEncoding_Term.DeclFun + uu___17 in + [uu___16] in + FStar_Compiler_List.op_At + uu___15 + proxy_fresh in + FStar_SMTEncoding_Term.mk_decls_trivial + uu___14 in + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + FStar_SMTEncoding_Util.mkAssume + (tok_typing1, + (FStar_Pervasives_Native.Some "typing for data constructor proxy"), - (Prims.strcat + (Prims.strcat "typing_tok_" ddtok)) in - let uu___19 = - let uu___20 + let uu___19 = + let uu___20 = + let uu___21 = - let uu___21 - = - let uu___22 + let uu___22 = let uu___23 = @@ -6351,39 +6106,39 @@ let (encode_datacon : FStar_SMTEncoding_Term.mkForall uu___23 uu___24 in - (uu___22, + (uu___22, (FStar_Pervasives_Native.Some "equality for proxy"), (Prims.strcat "equality_tok_" ddtok)) in - FStar_SMTEncoding_Util.mkAssume - uu___21 in - [uu___20; - data_cons_typing_intro_decl] in - uu___18 :: - uu___19 in - FStar_Compiler_List.op_At - uu___17 elim in - FStar_SMTEncoding_Term.mk_decls_trivial - uu___16 in - FStar_Compiler_List.op_At - decls_pred uu___15 in + FStar_SMTEncoding_Util.mkAssume + uu___21 in + [uu___20; + data_cons_typing_intro_decl] in + uu___18 :: + uu___19 in + FStar_Compiler_List.op_At + uu___17 elim in + FStar_SMTEncoding_Term.mk_decls_trivial + uu___16 in FStar_Compiler_List.op_At - uu___13 uu___14 in + decls_pred uu___15 in FStar_Compiler_List.op_At - decls3 uu___12 in + uu___13 uu___14 in FStar_Compiler_List.op_At - decls2 uu___11 in - FStar_Compiler_List.op_At - binder_decls uu___10 in - let uu___10 = - let uu___11 = - FStar_SMTEncoding_Term.mk_decls_trivial - datacons in + decls3 uu___12 in FStar_Compiler_List.op_At - uu___11 g in - (uu___10, env1)))))))) + decls2 uu___11 in + FStar_Compiler_List.op_At + binder_decls uu___10 in + let uu___10 = + let uu___11 = + FStar_SMTEncoding_Term.mk_decls_trivial + datacons in + FStar_Compiler_List.op_At + uu___11 g in + (uu___10, env1)))))))) let rec (encode_sigelt : FStar_SMTEncoding_Env.env_t -> FStar_Syntax_Syntax.sigelt -> @@ -7013,16 +6768,6 @@ and (encode_sigelt' : { FStar_Syntax_Syntax.ses = ses; FStar_Syntax_Syntax.lids = uu___1;_} -> - let tycon = - FStar_Compiler_List.tryFind - (fun se1 -> - FStar_Syntax_Syntax.uu___is_Sig_inductive_typ - se1.FStar_Syntax_Syntax.sigel) ses in - let is_injective_on_params = - match tycon with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some se1 -> - is_sig_inductive_injective_on_params env se1 in let uu___2 = FStar_Compiler_List.fold_left (fun uu___3 -> @@ -7032,10 +6777,9 @@ and (encode_sigelt' : let uu___4 = match se1.FStar_Syntax_Syntax.sigel with | FStar_Syntax_Syntax.Sig_inductive_typ uu___5 -> - encode_sig_inductive is_injective_on_params - env1 se1 + encode_sig_inductive env1 se1 | FStar_Syntax_Syntax.Sig_datacon uu___5 -> - encode_datacon is_injective_on_params env1 se1 + encode_datacon env1 se1 | uu___5 -> encode_sigelt env1 se1 in (match uu___4 with | (g', env2) -> diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_DsEnv.ml b/ocaml/fstar-lib/generated/FStar_Syntax_DsEnv.ml index 06ff38992f3..22c03ce5d67 100644 --- a/ocaml/fstar-lib/generated/FStar_Syntax_DsEnv.ml +++ b/ocaml/fstar-lib/generated/FStar_Syntax_DsEnv.ml @@ -1179,16 +1179,17 @@ let (fv_qual_of_se : { FStar_Syntax_Syntax.lid1 = uu___; FStar_Syntax_Syntax.us1 = uu___1; FStar_Syntax_Syntax.t1 = uu___2; FStar_Syntax_Syntax.ty_lid = l; FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4;_} + FStar_Syntax_Syntax.mutuals1 = uu___4; + FStar_Syntax_Syntax.injective_type_params1 = uu___5;_} -> let qopt = FStar_Compiler_Util.find_map se.FStar_Syntax_Syntax.sigquals - (fun uu___5 -> - match uu___5 with - | FStar_Syntax_Syntax.RecordConstructor (uu___6, fs) -> + (fun uu___6 -> + match uu___6 with + | FStar_Syntax_Syntax.RecordConstructor (uu___7, fs) -> FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Record_ctor (l, fs)) - | uu___6 -> FStar_Pervasives_Native.None) in + | uu___7 -> FStar_Pervasives_Native.None) in (match qopt with | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor @@ -1949,14 +1950,15 @@ let (find_all_datacons : FStar_Syntax_Syntax.num_uniform_params = uu___4; FStar_Syntax_Syntax.t = uu___5; FStar_Syntax_Syntax.mutuals = datas; - FStar_Syntax_Syntax.ds = uu___6;_}; - FStar_Syntax_Syntax.sigrng = uu___7; - FStar_Syntax_Syntax.sigquals = uu___8; - FStar_Syntax_Syntax.sigmeta = uu___9; - FStar_Syntax_Syntax.sigattrs = uu___10; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___11; - FStar_Syntax_Syntax.sigopts = uu___12;_}, - uu___13) -> FStar_Pervasives_Native.Some datas + FStar_Syntax_Syntax.ds = uu___6; + FStar_Syntax_Syntax.injective_type_params = uu___7;_}; + FStar_Syntax_Syntax.sigrng = uu___8; + FStar_Syntax_Syntax.sigquals = uu___9; + FStar_Syntax_Syntax.sigmeta = uu___10; + FStar_Syntax_Syntax.sigattrs = uu___11; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___12; + FStar_Syntax_Syntax.sigopts = uu___13;_}, + uu___14) -> FStar_Pervasives_Native.Some datas | uu___1 -> FStar_Pervasives_Native.None in resolve_in_open_namespaces' env1 lid (fun uu___ -> FStar_Pervasives_Native.None) @@ -2066,13 +2068,15 @@ let (extract_record : FStar_Syntax_Syntax.t1 = uu___3; FStar_Syntax_Syntax.ty_lid = uu___4; FStar_Syntax_Syntax.num_ty_params = uu___5; - FStar_Syntax_Syntax.mutuals1 = uu___6;_}; - FStar_Syntax_Syntax.sigrng = uu___7; - FStar_Syntax_Syntax.sigquals = uu___8; - FStar_Syntax_Syntax.sigmeta = uu___9; - FStar_Syntax_Syntax.sigattrs = uu___10; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___11; - FStar_Syntax_Syntax.sigopts = uu___12;_} -> + FStar_Syntax_Syntax.mutuals1 = uu___6; + FStar_Syntax_Syntax.injective_type_params1 = + uu___7;_}; + FStar_Syntax_Syntax.sigrng = uu___8; + FStar_Syntax_Syntax.sigquals = uu___9; + FStar_Syntax_Syntax.sigmeta = uu___10; + FStar_Syntax_Syntax.sigattrs = uu___11; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___12; + FStar_Syntax_Syntax.sigopts = uu___13;_} -> FStar_Ident.lid_equals dc lid | uu___2 -> false) sigs in FStar_Compiler_List.iter @@ -2087,51 +2091,54 @@ let (extract_record : FStar_Syntax_Syntax.num_uniform_params = uu___2; FStar_Syntax_Syntax.t = uu___3; FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = dc::[];_}; - FStar_Syntax_Syntax.sigrng = uu___5; + FStar_Syntax_Syntax.ds = dc::[]; + FStar_Syntax_Syntax.injective_type_params = uu___5;_}; + FStar_Syntax_Syntax.sigrng = uu___6; FStar_Syntax_Syntax.sigquals = typename_quals; - FStar_Syntax_Syntax.sigmeta = uu___6; - FStar_Syntax_Syntax.sigattrs = uu___7; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___8; - FStar_Syntax_Syntax.sigopts = uu___9;_} -> - let uu___10 = - let uu___11 = find_dc dc in - FStar_Compiler_Util.must uu___11 in - (match uu___10 with + FStar_Syntax_Syntax.sigmeta = uu___7; + FStar_Syntax_Syntax.sigattrs = uu___8; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; + FStar_Syntax_Syntax.sigopts = uu___10;_} -> + let uu___11 = + let uu___12 = find_dc dc in + FStar_Compiler_Util.must uu___12 in + (match uu___11 with | { FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_datacon { FStar_Syntax_Syntax.lid1 = constrname; - FStar_Syntax_Syntax.us1 = uu___11; + FStar_Syntax_Syntax.us1 = uu___12; FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = uu___12; + FStar_Syntax_Syntax.ty_lid = uu___13; FStar_Syntax_Syntax.num_ty_params = n; - FStar_Syntax_Syntax.mutuals1 = uu___13;_}; - FStar_Syntax_Syntax.sigrng = uu___14; - FStar_Syntax_Syntax.sigquals = uu___15; - FStar_Syntax_Syntax.sigmeta = uu___16; - FStar_Syntax_Syntax.sigattrs = uu___17; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___18; - FStar_Syntax_Syntax.sigopts = uu___19;_} -> - let uu___20 = FStar_Syntax_Util.arrow_formals t in - (match uu___20 with - | (all_formals, uu___21) -> - let uu___22 = + FStar_Syntax_Syntax.mutuals1 = uu___14; + FStar_Syntax_Syntax.injective_type_params1 = + uu___15;_}; + FStar_Syntax_Syntax.sigrng = uu___16; + FStar_Syntax_Syntax.sigquals = uu___17; + FStar_Syntax_Syntax.sigmeta = uu___18; + FStar_Syntax_Syntax.sigattrs = uu___19; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___20; + FStar_Syntax_Syntax.sigopts = uu___21;_} -> + let uu___22 = FStar_Syntax_Util.arrow_formals t in + (match uu___22 with + | (all_formals, uu___23) -> + let uu___24 = FStar_Compiler_Util.first_N n all_formals in - (match uu___22 with + (match uu___24 with | (_params, formals) -> let is_rec = is_record typename_quals in let formals' = FStar_Compiler_List.collect (fun f -> - let uu___23 = + let uu___25 = (FStar_Syntax_Syntax.is_null_bv f.FStar_Syntax_Syntax.binder_bv) || (is_rec && (FStar_Syntax_Syntax.is_bqual_implicit f.FStar_Syntax_Syntax.binder_qual)) in - if uu___23 then [] else [f]) + if uu___25 then [] else [f]) formals in let fields' = FStar_Compiler_List.map @@ -2141,11 +2148,11 @@ let (extract_record : formals' in let fields = fields' in let record = - let uu___23 = + let uu___25 = FStar_Ident.ident_of_lid constrname in { typename; - constrname = uu___23; + constrname = uu___25; parms; fields; is_private = @@ -2154,41 +2161,41 @@ let (extract_record : typename_quals); is_record = is_rec } in - ((let uu___24 = - let uu___25 = + ((let uu___26 = + let uu___27 = FStar_Compiler_Effect.op_Bang new_globs in - (Record_or_dc record) :: uu___25 in + (Record_or_dc record) :: uu___27 in FStar_Compiler_Effect.op_Colon_Equals - new_globs uu___24); + new_globs uu___26); (match () with | () -> - ((let add_field uu___25 = - match uu___25 with - | (id, uu___26) -> + ((let add_field uu___27 = + match uu___27 with + | (id, uu___28) -> let modul = - let uu___27 = - let uu___28 = + let uu___29 = + let uu___30 = FStar_Ident.ns_of_lid constrname in FStar_Ident.lid_of_ids - uu___28 in + uu___30 in FStar_Ident.string_of_lid - uu___27 in - let uu___27 = + uu___29 in + let uu___29 = get_exported_id_set e modul in - (match uu___27 with + (match uu___29 with | FStar_Pervasives_Native.Some my_ex -> let my_exported_ids = my_ex Exported_id_field in - ((let uu___29 = - let uu___30 = + ((let uu___31 = + let uu___32 = FStar_Ident.string_of_id id in - let uu___31 = + let uu___33 = FStar_Compiler_Effect.op_Bang my_exported_ids in Obj.magic @@ -2197,27 +2204,27 @@ let (extract_record : (Obj.magic (FStar_Compiler_RBSet.setlike_rbset FStar_Class_Ord.ord_string)) - uu___30 + uu___32 (Obj.magic - uu___31)) in + uu___33)) in FStar_Compiler_Effect.op_Colon_Equals my_exported_ids - uu___29); + uu___31); (match () with | () -> let projname = - let uu___29 = - let uu___30 + let uu___31 = + let uu___32 = FStar_Syntax_Util.mk_field_projector_name_from_ident constrname id in FStar_Ident.ident_of_lid - uu___30 in + uu___32 in FStar_Ident.string_of_id - uu___29 in - let uu___30 = - let uu___31 = + uu___31 in + let uu___32 = + let uu___33 = FStar_Compiler_Effect.op_Bang my_exported_ids in Obj.magic @@ -2230,10 +2237,10 @@ let (extract_record : projname ( Obj.magic - uu___31)) in + uu___33)) in FStar_Compiler_Effect.op_Colon_Equals my_exported_ids - uu___30)) + uu___32)) | FStar_Pervasives_Native.None -> ()) in FStar_Compiler_List.iter @@ -2241,7 +2248,7 @@ let (extract_record : (match () with | () -> insert_record_cache record)))))) - | uu___11 -> ()) + | uu___12 -> ()) | uu___2 -> ()) sigs | uu___ -> () let (try_lookup_record_or_dc_by_field_name : @@ -2947,11 +2954,13 @@ let (finish : env -> FStar_Syntax_Syntax.modul -> env) = FStar_Syntax_Syntax.t1 = uu___3; FStar_Syntax_Syntax.ty_lid = uu___4; FStar_Syntax_Syntax.num_ty_params = uu___5; - FStar_Syntax_Syntax.mutuals1 = uu___6;_} + FStar_Syntax_Syntax.mutuals1 = uu___6; + FStar_Syntax_Syntax.injective_type_params1 = + uu___7;_} -> - let uu___7 = FStar_Ident.string_of_lid lid in + let uu___8 = FStar_Ident.string_of_lid lid in FStar_Compiler_Util.smap_remove (sigmap env1) - uu___7 + uu___8 | FStar_Syntax_Syntax.Sig_inductive_typ { FStar_Syntax_Syntax.lid = lid; FStar_Syntax_Syntax.us = univ_names; @@ -2959,36 +2968,39 @@ let (finish : env -> FStar_Syntax_Syntax.modul -> env) = FStar_Syntax_Syntax.num_uniform_params = uu___2; FStar_Syntax_Syntax.t = typ; FStar_Syntax_Syntax.mutuals = uu___3; - FStar_Syntax_Syntax.ds = uu___4;_} + FStar_Syntax_Syntax.ds = uu___4; + FStar_Syntax_Syntax.injective_type_params = + uu___5;_} -> - ((let uu___6 = FStar_Ident.string_of_lid lid in + ((let uu___7 = FStar_Ident.string_of_lid lid in FStar_Compiler_Util.smap_remove (sigmap env1) - uu___6); + uu___7); if Prims.op_Negation (FStar_Compiler_List.contains FStar_Syntax_Syntax.Private quals) then (let sigel = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = FStar_Syntax_Syntax.mk_Total typ in { FStar_Syntax_Syntax.bs1 = binders; - FStar_Syntax_Syntax.comp = uu___10 + FStar_Syntax_Syntax.comp = uu___11 } in - FStar_Syntax_Syntax.Tm_arrow uu___9 in - let uu___9 = FStar_Ident.range_of_lid lid in - FStar_Syntax_Syntax.mk uu___8 uu___9 in + FStar_Syntax_Syntax.Tm_arrow uu___10 in + let uu___10 = + FStar_Ident.range_of_lid lid in + FStar_Syntax_Syntax.mk uu___9 uu___10 in { FStar_Syntax_Syntax.lid2 = lid; FStar_Syntax_Syntax.us2 = univ_names; - FStar_Syntax_Syntax.t2 = uu___7 + FStar_Syntax_Syntax.t2 = uu___8 } in - FStar_Syntax_Syntax.Sig_declare_typ uu___6 in + FStar_Syntax_Syntax.Sig_declare_typ uu___7 in let se2 = { FStar_Syntax_Syntax.sigel = sigel; @@ -3005,9 +3017,9 @@ let (finish : env -> FStar_Syntax_Syntax.modul -> env) = FStar_Syntax_Syntax.sigopts = (se1.FStar_Syntax_Syntax.sigopts) } in - let uu___6 = FStar_Ident.string_of_lid lid in + let uu___7 = FStar_Ident.string_of_lid lid in FStar_Compiler_Util.smap_add (sigmap env1) - uu___6 (se2, false)) + uu___7 (se2, false)) else ()) | uu___2 -> ()) ses else () diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_MutRecTy.ml b/ocaml/fstar-lib/generated/FStar_Syntax_MutRecTy.ml index 4d998fe1010..5523021bbb0 100644 --- a/ocaml/fstar-lib/generated/FStar_Syntax_MutRecTy.ml +++ b/ocaml/fstar-lib/generated/FStar_Syntax_MutRecTy.ml @@ -353,7 +353,9 @@ let (disentangle_abbrevs_from_bundle : FStar_Syntax_Syntax.num_uniform_params = num_uniform; FStar_Syntax_Syntax.t = ty; FStar_Syntax_Syntax.mutuals = mut; - FStar_Syntax_Syntax.ds = dc;_} + FStar_Syntax_Syntax.ds = dc; + FStar_Syntax_Syntax.injective_type_params = + injective_type_params;_} -> let bnd' = FStar_Syntax_InstFV.inst_binders unfold_fv bnd in @@ -370,7 +372,9 @@ let (disentangle_abbrevs_from_bundle : num_uniform; FStar_Syntax_Syntax.t = ty'; FStar_Syntax_Syntax.mutuals = mut'; - FStar_Syntax_Syntax.ds = dc + FStar_Syntax_Syntax.ds = dc; + FStar_Syntax_Syntax.injective_type_params = + injective_type_params }); FStar_Syntax_Syntax.sigrng = (x.FStar_Syntax_Syntax.sigrng); @@ -391,7 +395,9 @@ let (disentangle_abbrevs_from_bundle : FStar_Syntax_Syntax.t1 = ty; FStar_Syntax_Syntax.ty_lid = res; FStar_Syntax_Syntax.num_ty_params = npars; - FStar_Syntax_Syntax.mutuals1 = mut;_} + FStar_Syntax_Syntax.mutuals1 = mut; + FStar_Syntax_Syntax.injective_type_params1 = + injective_type_params;_} -> let ty' = FStar_Syntax_InstFV.inst unfold_fv ty in let mut' = filter_out_type_abbrevs mut in @@ -404,7 +410,9 @@ let (disentangle_abbrevs_from_bundle : FStar_Syntax_Syntax.t1 = ty'; FStar_Syntax_Syntax.ty_lid = res; FStar_Syntax_Syntax.num_ty_params = npars; - FStar_Syntax_Syntax.mutuals1 = mut' + FStar_Syntax_Syntax.mutuals1 = mut'; + FStar_Syntax_Syntax.injective_type_params1 = + injective_type_params }); FStar_Syntax_Syntax.sigrng = (x.FStar_Syntax_Syntax.sigrng); diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Print.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Print.ml index 930a25fe49b..c24e8bb91ef 100644 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Print.ml +++ b/ocaml/fstar-lib/generated/FStar_Syntax_Print.ml @@ -1450,41 +1450,43 @@ let rec (sigelt_to_string : FStar_Syntax_Syntax.sigelt -> Prims.string) = FStar_Syntax_Syntax.num_uniform_params = uu___2; FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = uu___3; - FStar_Syntax_Syntax.ds = uu___4;_} + FStar_Syntax_Syntax.ds = uu___4; + FStar_Syntax_Syntax.injective_type_params = uu___5;_} -> let quals_str = quals_to_string' x.FStar_Syntax_Syntax.sigquals in let binders_str = binders_to_string " " tps in let term_str = term_to_string k in - let uu___5 = FStar_Options.print_universes () in - if uu___5 + let uu___6 = FStar_Options.print_universes () in + if uu___6 then - let uu___6 = FStar_Ident.string_of_lid lid in - let uu___7 = univ_names_to_string univs in + let uu___7 = FStar_Ident.string_of_lid lid in + let uu___8 = univ_names_to_string univs in FStar_Compiler_Util.format5 "%stype %s<%s> %s : %s" quals_str - uu___6 uu___7 binders_str term_str + uu___7 uu___8 binders_str term_str else - (let uu___7 = FStar_Ident.string_of_lid lid in + (let uu___8 = FStar_Ident.string_of_lid lid in FStar_Compiler_Util.format4 "%stype %s %s : %s" quals_str - uu___7 binders_str term_str) + uu___8 binders_str term_str) | FStar_Syntax_Syntax.Sig_datacon { FStar_Syntax_Syntax.lid1 = lid; FStar_Syntax_Syntax.us1 = univs; FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___2; FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4;_} + FStar_Syntax_Syntax.mutuals1 = uu___4; + FStar_Syntax_Syntax.injective_type_params1 = uu___5;_} -> - let uu___5 = FStar_Options.print_universes () in - if uu___5 + let uu___6 = FStar_Options.print_universes () in + if uu___6 then - let uu___6 = univ_names_to_string univs in - let uu___7 = FStar_Ident.string_of_lid lid in - let uu___8 = term_to_string t in - FStar_Compiler_Util.format3 "datacon<%s> %s : %s" uu___6 - uu___7 uu___8 + let uu___7 = univ_names_to_string univs in + let uu___8 = FStar_Ident.string_of_lid lid in + let uu___9 = term_to_string t in + FStar_Compiler_Util.format3 "datacon<%s> %s : %s" uu___7 + uu___8 uu___9 else - (let uu___7 = FStar_Ident.string_of_lid lid in - let uu___8 = term_to_string t in - FStar_Compiler_Util.format2 "datacon %s : %s" uu___7 uu___8) + (let uu___8 = FStar_Ident.string_of_lid lid in + let uu___9 = term_to_string t in + FStar_Compiler_Util.format2 "datacon %s : %s" uu___8 uu___9) | FStar_Syntax_Syntax.Sig_declare_typ { FStar_Syntax_Syntax.lid2 = lid; FStar_Syntax_Syntax.us2 = univs; FStar_Syntax_Syntax.t2 = t;_} @@ -1726,20 +1728,22 @@ let rec (sigelt_to_string_short : FStar_Syntax_Syntax.sigelt -> Prims.string) FStar_Syntax_Syntax.num_uniform_params = uu___2; FStar_Syntax_Syntax.t = uu___3; FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5;_} + FStar_Syntax_Syntax.ds = uu___5; + FStar_Syntax_Syntax.injective_type_params = uu___6;_} -> - let uu___6 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.format1 "type %s" uu___6 + let uu___7 = FStar_Ident.string_of_lid lid in + FStar_Compiler_Util.format1 "type %s" uu___7 | FStar_Syntax_Syntax.Sig_datacon { FStar_Syntax_Syntax.lid1 = lid; FStar_Syntax_Syntax.us1 = uu___; FStar_Syntax_Syntax.t1 = uu___1; FStar_Syntax_Syntax.ty_lid = t_lid; FStar_Syntax_Syntax.num_ty_params = uu___2; - FStar_Syntax_Syntax.mutuals1 = uu___3;_} + FStar_Syntax_Syntax.mutuals1 = uu___3; + FStar_Syntax_Syntax.injective_type_params1 = uu___4;_} -> - let uu___4 = FStar_Ident.string_of_lid lid in - let uu___5 = FStar_Ident.string_of_lid t_lid in - FStar_Compiler_Util.format2 "datacon %s for type %s" uu___4 uu___5 + let uu___5 = FStar_Ident.string_of_lid lid in + let uu___6 = FStar_Ident.string_of_lid t_lid in + FStar_Compiler_Util.format2 "datacon %s for type %s" uu___5 uu___6 | FStar_Syntax_Syntax.Sig_assume { FStar_Syntax_Syntax.lid3 = lid; FStar_Syntax_Syntax.us3 = uu___; FStar_Syntax_Syntax.phi1 = uu___1;_} diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Resugar.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Resugar.ml index d9ea812baef..805022a39c1 100644 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Resugar.ml +++ b/ocaml/fstar-lib/generated/FStar_Syntax_Resugar.ml @@ -2379,96 +2379,100 @@ let (resugar_typ : FStar_Syntax_Syntax.num_uniform_params = uu___; FStar_Syntax_Syntax.t = t; FStar_Syntax_Syntax.mutuals = uu___1; - FStar_Syntax_Syntax.ds = datacons;_} + FStar_Syntax_Syntax.ds = datacons; + FStar_Syntax_Syntax.injective_type_params = uu___2;_} -> - let uu___2 = + let uu___3 = FStar_Compiler_List.partition (fun se1 -> match se1.FStar_Syntax_Syntax.sigel with | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___3; - FStar_Syntax_Syntax.us1 = uu___4; - FStar_Syntax_Syntax.t1 = uu___5; + { FStar_Syntax_Syntax.lid1 = uu___4; + FStar_Syntax_Syntax.us1 = uu___5; + FStar_Syntax_Syntax.t1 = uu___6; FStar_Syntax_Syntax.ty_lid = inductive_lid; - FStar_Syntax_Syntax.num_ty_params = uu___6; - FStar_Syntax_Syntax.mutuals1 = uu___7;_} + FStar_Syntax_Syntax.num_ty_params = uu___7; + FStar_Syntax_Syntax.mutuals1 = uu___8; + FStar_Syntax_Syntax.injective_type_params1 = uu___9;_} -> FStar_Ident.lid_equals inductive_lid tylid - | uu___3 -> FStar_Compiler_Effect.failwith "unexpected") + | uu___4 -> FStar_Compiler_Effect.failwith "unexpected") datacon_ses in - (match uu___2 with + (match uu___3 with | (current_datacons, other_datacons) -> let bs1 = - let uu___3 = FStar_Options.print_implicits () in - if uu___3 then bs else filter_imp_bs bs in + let uu___4 = FStar_Options.print_implicits () in + if uu___4 then bs else filter_imp_bs bs in let bs2 = (map_opt ()) (fun b -> resugar_binder' env b t.FStar_Syntax_Syntax.pos) bs1 in let tyc = - let uu___3 = + let uu___4 = FStar_Compiler_Util.for_some - (fun uu___4 -> - match uu___4 with - | FStar_Syntax_Syntax.RecordType uu___5 -> true - | uu___5 -> false) se.FStar_Syntax_Syntax.sigquals in - if uu___3 + (fun uu___5 -> + match uu___5 with + | FStar_Syntax_Syntax.RecordType uu___6 -> true + | uu___6 -> false) se.FStar_Syntax_Syntax.sigquals in + if uu___4 then let resugar_datacon_as_fields fields se1 = match se1.FStar_Syntax_Syntax.sigel with | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___4; + { FStar_Syntax_Syntax.lid1 = uu___5; FStar_Syntax_Syntax.us1 = univs; FStar_Syntax_Syntax.t1 = term; - FStar_Syntax_Syntax.ty_lid = uu___5; + FStar_Syntax_Syntax.ty_lid = uu___6; FStar_Syntax_Syntax.num_ty_params = num; - FStar_Syntax_Syntax.mutuals1 = uu___6;_} + FStar_Syntax_Syntax.mutuals1 = uu___7; + FStar_Syntax_Syntax.injective_type_params1 = + uu___8;_} -> - let uu___7 = - let uu___8 = FStar_Syntax_Subst.compress term in - uu___8.FStar_Syntax_Syntax.n in - (match uu___7 with + let uu___9 = + let uu___10 = FStar_Syntax_Subst.compress term in + uu___10.FStar_Syntax_Syntax.n in + (match uu___9 with | FStar_Syntax_Syntax.Tm_arrow { FStar_Syntax_Syntax.bs1 = bs3; - FStar_Syntax_Syntax.comp = uu___8;_} + FStar_Syntax_Syntax.comp = uu___10;_} -> let mfields = FStar_Compiler_List.collect (fun b -> - let uu___9 = + let uu___11 = resugar_bqual env b.FStar_Syntax_Syntax.binder_qual in - match uu___9 with + match uu___11 with | FStar_Pervasives_Native.None -> [] | FStar_Pervasives_Native.Some q -> - let uu___10 = - let uu___11 = + let uu___12 = + let uu___13 = bv_as_unique_ident b.FStar_Syntax_Syntax.binder_bv in - let uu___12 = + let uu___14 = FStar_Compiler_List.map (resugar_term' env) b.FStar_Syntax_Syntax.binder_attrs in - let uu___13 = + let uu___15 = resugar_term' env (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - (uu___11, q, uu___12, uu___13) in - [uu___10]) bs3 in + (uu___13, q, uu___14, uu___15) in + [uu___12]) bs3 in FStar_Compiler_List.op_At mfields fields - | uu___8 -> + | uu___10 -> FStar_Compiler_Effect.failwith "unexpected") - | uu___4 -> + | uu___5 -> FStar_Compiler_Effect.failwith "unexpected" in let fields = FStar_Compiler_List.fold_left resugar_datacon_as_fields [] current_datacons in - let uu___4 = - let uu___5 = FStar_Ident.ident_of_lid tylid in - let uu___6 = + let uu___5 = + let uu___6 = FStar_Ident.ident_of_lid tylid in + let uu___7 = FStar_Compiler_List.map (resugar_term' env) se.FStar_Syntax_Syntax.sigattrs in - (uu___5, bs2, FStar_Pervasives_Native.None, uu___6, + (uu___6, bs2, FStar_Pervasives_Native.None, uu___7, fields) in - FStar_Parser_AST.TyconRecord uu___4 + FStar_Parser_AST.TyconRecord uu___5 else (let resugar_datacon constructors se1 = match se1.FStar_Syntax_Syntax.sigel with @@ -2476,32 +2480,34 @@ let (resugar_typ : { FStar_Syntax_Syntax.lid1 = l; FStar_Syntax_Syntax.us1 = univs; FStar_Syntax_Syntax.t1 = term; - FStar_Syntax_Syntax.ty_lid = uu___5; + FStar_Syntax_Syntax.ty_lid = uu___6; FStar_Syntax_Syntax.num_ty_params = num; - FStar_Syntax_Syntax.mutuals1 = uu___6;_} + FStar_Syntax_Syntax.mutuals1 = uu___7; + FStar_Syntax_Syntax.injective_type_params1 = + uu___8;_} -> let c = - let uu___7 = FStar_Ident.ident_of_lid l in - let uu___8 = - let uu___9 = - let uu___10 = resugar_term' env term in - FStar_Parser_AST.VpArbitrary uu___10 in - FStar_Pervasives_Native.Some uu___9 in - let uu___9 = + let uu___9 = FStar_Ident.ident_of_lid l in + let uu___10 = + let uu___11 = + let uu___12 = resugar_term' env term in + FStar_Parser_AST.VpArbitrary uu___12 in + FStar_Pervasives_Native.Some uu___11 in + let uu___11 = FStar_Compiler_List.map (resugar_term' env) se1.FStar_Syntax_Syntax.sigattrs in - (uu___7, uu___8, uu___9) in + (uu___9, uu___10, uu___11) in c :: constructors - | uu___5 -> + | uu___6 -> FStar_Compiler_Effect.failwith "unexpected" in let constructors = FStar_Compiler_List.fold_left resugar_datacon [] current_datacons in - let uu___5 = - let uu___6 = FStar_Ident.ident_of_lid tylid in - (uu___6, bs2, FStar_Pervasives_Native.None, + let uu___6 = + let uu___7 = FStar_Ident.ident_of_lid tylid in + (uu___7, bs2, FStar_Pervasives_Native.None, constructors) in - FStar_Parser_AST.TyconVariant uu___5) in + FStar_Parser_AST.TyconVariant uu___6) in (other_datacons, tyc)) | uu___ -> FStar_Compiler_Effect.failwith @@ -2819,16 +2825,18 @@ let (resugar_sigelt' : FStar_Syntax_Syntax.t1 = uu___4; FStar_Syntax_Syntax.ty_lid = uu___5; FStar_Syntax_Syntax.num_ty_params = uu___6; - FStar_Syntax_Syntax.mutuals1 = uu___7;_} + FStar_Syntax_Syntax.mutuals1 = uu___7; + FStar_Syntax_Syntax.injective_type_params1 = + uu___8;_} -> - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = FStar_Ident.ident_of_lid l in - (uu___11, FStar_Pervasives_Native.None) in - FStar_Parser_AST.Exception uu___10 in - decl'_to_decl se1 uu___9 in - FStar_Pervasives_Native.Some uu___8 + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = FStar_Ident.ident_of_lid l in + (uu___12, FStar_Pervasives_Native.None) in + FStar_Parser_AST.Exception uu___11 in + decl'_to_decl se1 uu___10 in + FStar_Pervasives_Native.Some uu___9 | uu___3 -> FStar_Compiler_Effect.failwith "wrong format for resguar to Exception") diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Syntax.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Syntax.ml index 35276ce22c0..2eb354d8cae 100644 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Syntax.ml +++ b/ocaml/fstar-lib/generated/FStar_Syntax_Syntax.ml @@ -1772,7 +1772,8 @@ type sigelt'__Sig_inductive_typ__payload = num_uniform_params: Prims.int FStar_Pervasives_Native.option ; t: typ ; mutuals: FStar_Ident.lident Prims.list ; - ds: FStar_Ident.lident Prims.list } + ds: FStar_Ident.lident Prims.list ; + injective_type_params: Prims.bool } and sigelt'__Sig_bundle__payload = { ses: sigelt Prims.list ; @@ -1784,7 +1785,8 @@ and sigelt'__Sig_datacon__payload = t1: typ ; ty_lid: FStar_Ident.lident ; num_ty_params: Prims.int ; - mutuals1: FStar_Ident.lident Prims.list } + mutuals1: FStar_Ident.lident Prims.list ; + injective_type_params1: Prims.bool } and sigelt'__Sig_declare_typ__payload = { lid2: FStar_Ident.lident ; @@ -1862,17 +1864,20 @@ let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__lid : sigelt'__Sig_inductive_typ__payload -> FStar_Ident.lident) = fun projectee -> match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds;_} -> lid + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> lid let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__us : sigelt'__Sig_inductive_typ__payload -> univ_names) = fun projectee -> match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds;_} -> us + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> us let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__params : sigelt'__Sig_inductive_typ__payload -> binders) = fun projectee -> match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds;_} -> params + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> params let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__num_uniform_params : sigelt'__Sig_inductive_typ__payload -> @@ -1880,23 +1885,32 @@ let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__num_uniform_params = fun projectee -> match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds;_} -> - num_uniform_params + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> num_uniform_params let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__t : sigelt'__Sig_inductive_typ__payload -> typ) = fun projectee -> match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds;_} -> t + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> t let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__mutuals : sigelt'__Sig_inductive_typ__payload -> FStar_Ident.lident Prims.list) = fun projectee -> match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds;_} -> mutuals + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> mutuals let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__ds : sigelt'__Sig_inductive_typ__payload -> FStar_Ident.lident Prims.list) = fun projectee -> match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds;_} -> ds + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> ds +let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__injective_type_params + : sigelt'__Sig_inductive_typ__payload -> Prims.bool) = + fun projectee -> + match projectee with + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> injective_type_params let (__proj__Mksigelt'__Sig_bundle__payload__item__ses : sigelt'__Sig_bundle__payload -> sigelt Prims.list) = fun projectee -> match projectee with | { ses; lids;_} -> ses @@ -1908,37 +1922,50 @@ let (__proj__Mksigelt'__Sig_datacon__payload__item__lid : fun projectee -> match projectee with | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; - mutuals1 = mutuals;_} -> lid + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> lid let (__proj__Mksigelt'__Sig_datacon__payload__item__us : sigelt'__Sig_datacon__payload -> univ_names) = fun projectee -> match projectee with | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; - mutuals1 = mutuals;_} -> us + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> us let (__proj__Mksigelt'__Sig_datacon__payload__item__t : sigelt'__Sig_datacon__payload -> typ) = fun projectee -> match projectee with | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; - mutuals1 = mutuals;_} -> t + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> t let (__proj__Mksigelt'__Sig_datacon__payload__item__ty_lid : sigelt'__Sig_datacon__payload -> FStar_Ident.lident) = fun projectee -> match projectee with | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; - mutuals1 = mutuals;_} -> ty_lid + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> ty_lid let (__proj__Mksigelt'__Sig_datacon__payload__item__num_ty_params : sigelt'__Sig_datacon__payload -> Prims.int) = fun projectee -> match projectee with | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; - mutuals1 = mutuals;_} -> num_ty_params + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> num_ty_params let (__proj__Mksigelt'__Sig_datacon__payload__item__mutuals : sigelt'__Sig_datacon__payload -> FStar_Ident.lident Prims.list) = fun projectee -> match projectee with | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; - mutuals1 = mutuals;_} -> mutuals + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> mutuals +let (__proj__Mksigelt'__Sig_datacon__payload__item__injective_type_params : + sigelt'__Sig_datacon__payload -> Prims.bool) = + fun projectee -> + match projectee with + | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> injective_type_params let (__proj__Mksigelt'__Sig_declare_typ__payload__item__lid : sigelt'__Sig_declare_typ__payload -> FStar_Ident.lident) = fun projectee -> diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Util.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Util.ml index 20334fc76d1..9c14f74f34c 100644 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Util.ml +++ b/ocaml/fstar-lib/generated/FStar_Syntax_Util.ml @@ -1065,7 +1065,8 @@ let (lids_of_sigelt : FStar_Syntax_Syntax.num_uniform_params = uu___2; FStar_Syntax_Syntax.t = uu___3; FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5;_} + FStar_Syntax_Syntax.ds = uu___5; + FStar_Syntax_Syntax.injective_type_params = uu___6;_} -> [lid] | FStar_Syntax_Syntax.Sig_effect_abbrev { FStar_Syntax_Syntax.lid4 = lid; FStar_Syntax_Syntax.us4 = uu___; @@ -1078,7 +1079,8 @@ let (lids_of_sigelt : FStar_Syntax_Syntax.t1 = uu___1; FStar_Syntax_Syntax.ty_lid = uu___2; FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4;_} + FStar_Syntax_Syntax.mutuals1 = uu___4; + FStar_Syntax_Syntax.injective_type_params1 = uu___5;_} -> [lid] | FStar_Syntax_Syntax.Sig_declare_typ { FStar_Syntax_Syntax.lid2 = lid; FStar_Syntax_Syntax.us2 = uu___; diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_VisitM.ml b/ocaml/fstar-lib/generated/FStar_Syntax_VisitM.ml index a51590443a2..b9e76115bd4 100644 --- a/ocaml/fstar-lib/generated/FStar_Syntax_VisitM.ml +++ b/ocaml/fstar-lib/generated/FStar_Syntax_VisitM.ml @@ -1652,7 +1652,8 @@ let rec on_sub_sigelt' : 'm . 'm lvm -> FStar_Syntax_Syntax.sigelt' -> 'm = FStar_Syntax_Syntax.params = params; FStar_Syntax_Syntax.num_uniform_params = num_uniform_params; FStar_Syntax_Syntax.t = t; FStar_Syntax_Syntax.mutuals = mutuals; - FStar_Syntax_Syntax.ds = ds;_} + FStar_Syntax_Syntax.ds = ds; + FStar_Syntax_Syntax.injective_type_params = injective_type_params;_} -> let uu___ = FStar_Class_Monad.mapM (_lvm_monad d) () () @@ -1683,7 +1684,9 @@ let rec on_sub_sigelt' : 'm . 'm lvm -> FStar_Syntax_Syntax.sigelt' -> 'm = FStar_Syntax_Syntax.t = t1; FStar_Syntax_Syntax.mutuals = mutuals; - FStar_Syntax_Syntax.ds = ds + FStar_Syntax_Syntax.ds = ds; + FStar_Syntax_Syntax.injective_type_params + = injective_type_params })))) uu___2))) uu___1) | FStar_Syntax_Syntax.Sig_bundle { FStar_Syntax_Syntax.ses = ses; FStar_Syntax_Syntax.lids = lids;_} @@ -1708,7 +1711,9 @@ let rec on_sub_sigelt' : 'm . 'm lvm -> FStar_Syntax_Syntax.sigelt' -> 'm = { FStar_Syntax_Syntax.lid1 = lid; FStar_Syntax_Syntax.us1 = us; FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = ty_lid; FStar_Syntax_Syntax.num_ty_params = num_ty_params; - FStar_Syntax_Syntax.mutuals1 = mutuals;_} + FStar_Syntax_Syntax.mutuals1 = mutuals; + FStar_Syntax_Syntax.injective_type_params1 = + injective_type_params;_} -> let uu___ = f_term d t in FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ @@ -1726,7 +1731,9 @@ let rec on_sub_sigelt' : 'm . 'm lvm -> FStar_Syntax_Syntax.sigelt' -> 'm = FStar_Syntax_Syntax.ty_lid = ty_lid; FStar_Syntax_Syntax.num_ty_params = num_ty_params; - FStar_Syntax_Syntax.mutuals1 = mutuals + FStar_Syntax_Syntax.mutuals1 = mutuals; + FStar_Syntax_Syntax.injective_type_params1 = + injective_type_params })))) uu___1) | FStar_Syntax_Syntax.Sig_declare_typ { FStar_Syntax_Syntax.lid2 = lid; FStar_Syntax_Syntax.us2 = us; diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_V1_Basic.ml b/ocaml/fstar-lib/generated/FStar_Tactics_V1_Basic.ml index b0786a86398..515138046e4 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_V1_Basic.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_V1_Basic.ml @@ -7423,7 +7423,9 @@ let (t_destruct : FStar_Syntax_Syntax.mutuals = mut; FStar_Syntax_Syntax.ds - = c_lids;_} + = c_lids; + FStar_Syntax_Syntax.injective_type_params + = uu___11;_} -> Obj.repr (let erasable @@ -7431,36 +7433,36 @@ let (t_destruct : FStar_Syntax_Util.has_attribute se.FStar_Syntax_Syntax.sigattrs FStar_Parser_Const.erasable_attr in - let uu___11 - = let uu___12 = + let uu___13 + = erasable && - (let uu___13 + (let uu___14 = is_irrelevant g in Prims.op_Negation - uu___13) in + uu___14) in failwhen - uu___12 + uu___13 "cannot destruct erasable type to solve proof-relevant goal" in FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___11 - (fun uu___12 + (fun + uu___13 -> (fun - uu___12 + uu___13 -> - let uu___12 + let uu___13 = Obj.magic - uu___12 in - let uu___13 + uu___13 in + let uu___14 = failwhen ((FStar_Compiler_List.length @@ -7472,34 +7474,34 @@ let (t_destruct : (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___13 - (fun uu___14 + (fun + uu___15 -> (fun - uu___14 + uu___15 -> - let uu___14 + let uu___15 = Obj.magic - uu___14 in - let uu___15 + uu___15 in + let uu___16 = FStar_Syntax_Subst.open_term t_ps t_ty in - match uu___15 + match uu___16 with | (t_ps1, t_ty1) -> - let uu___16 + let uu___17 = Obj.magic (FStar_Class_Monad.mapM FStar_Tactics_Monad.monad_tac () () (fun - uu___17 + uu___18 -> (fun c_lid -> @@ -7507,16 +7509,16 @@ let (t_destruct : = Obj.magic c_lid in - let uu___17 - = let uu___18 = + let uu___19 + = FStar_Tactics_Types.goal_env g in FStar_TypeChecker_Env.lookup_sigelt - uu___18 + uu___19 c_lid in - match uu___17 + match uu___18 with | FStar_Pervasives_Native.None @@ -7537,17 +7539,19 @@ let (t_destruct : FStar_Syntax_Syntax.Sig_datacon { FStar_Syntax_Syntax.lid1 - = uu___18; + = uu___19; FStar_Syntax_Syntax.us1 = c_us; FStar_Syntax_Syntax.t1 = c_ty; FStar_Syntax_Syntax.ty_lid - = uu___19; + = uu___20; FStar_Syntax_Syntax.num_ty_params = nparam; FStar_Syntax_Syntax.mutuals1 - = mut1;_} + = mut1; + FStar_Syntax_Syntax.injective_type_params1 + = uu___21;_} -> Obj.repr (let fv1 @@ -7556,7 +7560,7 @@ let (t_destruct : c_lid (FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor) in - let uu___20 + let uu___22 = failwhen ((FStar_Compiler_List.length @@ -7567,17 +7571,17 @@ let (t_destruct : FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___20 + uu___22 (fun - uu___21 + uu___23 -> (fun - uu___21 + uu___23 -> - let uu___21 + let uu___23 = Obj.magic - uu___21 in + uu___23 in let s = FStar_TypeChecker_Env.mk_univ_subst c_us a_us in @@ -7585,26 +7589,26 @@ let (t_destruct : = FStar_Syntax_Subst.subst s c_ty in - let uu___22 + let uu___24 = FStar_TypeChecker_Env.inst_tscheme (c_us, c_ty1) in - match uu___22 + match uu___24 with | (c_us1, c_ty2) -> - let uu___23 + let uu___25 = FStar_Syntax_Util.arrow_formals_comp c_ty2 in - (match uu___23 + (match uu___25 with | (bs, comp) -> - let uu___24 + let uu___26 = let rename_bv bv = @@ -7613,26 +7617,26 @@ let (t_destruct : bv.FStar_Syntax_Syntax.ppname in let ppname1 = - let uu___25 + let uu___27 = - let uu___26 + let uu___28 = - let uu___27 + let uu___29 = FStar_Class_Show.show FStar_Ident.showable_ident ppname in Prims.strcat "a" - uu___27 in - let uu___27 + uu___29 in + let uu___29 = FStar_Ident.range_of_id ppname in - (uu___26, - uu___27) in + (uu___28, + uu___29) in FStar_Ident.mk_ident - uu___25 in + uu___27 in FStar_Syntax_Syntax.freshen_bv { FStar_Syntax_Syntax.ppname @@ -7647,13 +7651,13 @@ let (t_destruct : let bs' = FStar_Compiler_List.map (fun b -> - let uu___25 + let uu___27 = rename_bv b.FStar_Syntax_Syntax.binder_bv in { FStar_Syntax_Syntax.binder_bv - = uu___25; + = uu___27; FStar_Syntax_Syntax.binder_qual = (b.FStar_Syntax_Syntax.binder_qual); @@ -7668,100 +7672,100 @@ let (t_destruct : = FStar_Compiler_List.map2 (fun - uu___25 + uu___27 -> fun - uu___26 + uu___28 -> match - (uu___25, - uu___26) + (uu___27, + uu___28) with | ({ FStar_Syntax_Syntax.binder_bv = bv; FStar_Syntax_Syntax.binder_qual - = uu___27; + = uu___29; FStar_Syntax_Syntax.binder_positivity - = uu___28; + = uu___30; FStar_Syntax_Syntax.binder_attrs - = uu___29;_}, + = uu___31;_}, { FStar_Syntax_Syntax.binder_bv = bv'; FStar_Syntax_Syntax.binder_qual - = uu___30; + = uu___32; FStar_Syntax_Syntax.binder_positivity - = uu___31; + = uu___33; FStar_Syntax_Syntax.binder_attrs - = uu___32;_}) + = uu___34;_}) -> - let uu___33 + let uu___35 = - let uu___34 + let uu___36 = FStar_Syntax_Syntax.bv_to_name bv' in (bv, - uu___34) in + uu___36) in FStar_Syntax_Syntax.NT - uu___33) + uu___35) bs bs' in - let uu___25 + let uu___27 = FStar_Syntax_Subst.subst_binders subst bs' in - let uu___26 + let uu___28 = FStar_Syntax_Subst.subst_comp subst comp in - (uu___25, - uu___26) in - (match uu___24 + (uu___27, + uu___28) in + (match uu___26 with | (bs1, comp1) -> - let uu___25 + let uu___27 = FStar_Compiler_List.splitAt nparam bs1 in - (match uu___25 + (match uu___27 with | (d_ps, bs2) -> - let uu___26 + let uu___28 = - let uu___27 + let uu___29 = - let uu___28 + let uu___30 = FStar_Syntax_Util.is_total_comp comp1 in Prims.op_Negation - uu___28 in + uu___30 in failwhen - uu___27 + uu___29 "not total?" in Obj.magic (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___26 + uu___28 (fun - uu___27 + uu___29 -> (fun - uu___27 + uu___29 -> - let uu___27 + let uu___29 = Obj.magic - uu___27 in + uu___29 in let mk_pat p = { @@ -7772,28 +7776,28 @@ let (t_destruct : (s_tm1.FStar_Syntax_Syntax.pos) } in let is_imp - uu___28 = - match uu___28 + uu___30 = + match uu___30 with | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit - uu___29) + uu___31) -> true | - uu___29 + uu___31 -> false in - let uu___28 + let uu___30 = FStar_Compiler_List.splitAt nparam args in - match uu___28 + match uu___30 with | (a_ps, a_is) -> - let uu___29 + let uu___31 = failwhen ((FStar_Compiler_List.length @@ -7805,17 +7809,17 @@ let (t_destruct : (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___29 + uu___31 (fun - uu___30 + uu___32 -> (fun - uu___30 + uu___32 -> - let uu___30 + let uu___32 = Obj.magic - uu___30 in + uu___32 in let d_ps_a_ps = FStar_Compiler_List.zip @@ -7824,22 +7828,22 @@ let (t_destruct : = FStar_Compiler_List.map (fun - uu___31 + uu___33 -> - match uu___31 + match uu___33 with | ({ FStar_Syntax_Syntax.binder_bv = bv; FStar_Syntax_Syntax.binder_qual - = uu___32; + = uu___34; FStar_Syntax_Syntax.binder_positivity - = uu___33; + = uu___35; FStar_Syntax_Syntax.binder_attrs - = uu___34;_}, + = uu___36;_}, (t, - uu___35)) + uu___37)) -> FStar_Syntax_Syntax.NT (bv, t)) @@ -7851,22 +7855,22 @@ let (t_destruct : = FStar_Compiler_List.map (fun - uu___31 + uu___33 -> - match uu___31 + match uu___33 with | ({ FStar_Syntax_Syntax.binder_bv = bv; FStar_Syntax_Syntax.binder_qual - = uu___32; + = uu___34; FStar_Syntax_Syntax.binder_positivity - = uu___33; + = uu___35; FStar_Syntax_Syntax.binder_attrs - = uu___34;_}, + = uu___36;_}, (t, - uu___35)) + uu___37)) -> ((mk_pat (FStar_Syntax_Syntax.Pat_dot_term @@ -7878,9 +7882,9 @@ let (t_destruct : = FStar_Compiler_List.map (fun - uu___31 + uu___33 -> - match uu___31 + match uu___33 with | { @@ -7889,9 +7893,9 @@ let (t_destruct : FStar_Syntax_Syntax.binder_qual = bq; FStar_Syntax_Syntax.binder_positivity - = uu___32; + = uu___34; FStar_Syntax_Syntax.binder_attrs - = uu___33;_} + = uu___35;_} -> ((mk_pat (FStar_Syntax_Syntax.Pat_var @@ -7921,7 +7925,7 @@ let (t_destruct : env1.FStar_TypeChecker_Env.universe_of env1 s_ty1 in - let uu___31 + let uu___33 = FStar_TypeChecker_TcTerm.tc_pat { @@ -8082,23 +8086,23 @@ let (t_destruct : (env1.FStar_TypeChecker_Env.core_check) } s_ty1 pat in - match uu___31 + match uu___33 with | - (uu___32, - uu___33, - uu___34, + (uu___34, uu___35, - pat_t, uu___36, + uu___37, + pat_t, + uu___38, _guard_pat, _erasable) -> let eq_b = - let uu___37 + let uu___39 = - let uu___38 + let uu___40 = FStar_Syntax_Util.mk_eq2 equ s_ty1 @@ -8106,38 +8110,38 @@ let (t_destruct : pat_t in FStar_Syntax_Util.mk_squash FStar_Syntax_Syntax.U_zero - uu___38 in + uu___40 in FStar_Syntax_Syntax.gen_bv "breq" FStar_Pervasives_Native.None - uu___37 in + uu___39 in let cod1 = - let uu___37 + let uu___39 = - let uu___38 + let uu___40 = FStar_Syntax_Syntax.mk_binder eq_b in - [uu___38] in - let uu___38 + [uu___40] in + let uu___40 = FStar_Syntax_Syntax.mk_Total cod in FStar_Syntax_Util.arrow - uu___37 - uu___38 in + uu___39 + uu___40 in let nty = - let uu___37 + let uu___39 = FStar_Syntax_Syntax.mk_Total cod1 in FStar_Syntax_Util.arrow bs3 - uu___37 in - let uu___37 + uu___39 in + let uu___39 = - let uu___38 + let uu___40 = goal_typedness_deps g in @@ -8145,7 +8149,7 @@ let (t_destruct : "destruct branch" env1 nty FStar_Pervasives_Native.None - uu___38 + uu___40 (rangeof g) in Obj.magic @@ -8153,18 +8157,18 @@ let (t_destruct : FStar_Tactics_Monad.monad_tac () () (Obj.magic - uu___37) + uu___39) (fun - uu___38 + uu___40 -> (fun - uu___38 + uu___40 -> - let uu___38 + let uu___40 = Obj.magic - uu___38 in - match uu___38 + uu___40 in + match uu___40 with | (uvt, uv) @@ -8180,48 +8184,48 @@ let (t_destruct : uvt bs3 in let brt1 = - let uu___39 + let uu___41 = - let uu___40 + let uu___42 = FStar_Syntax_Syntax.as_arg FStar_Syntax_Util.exp_unit in - [uu___40] in + [uu___42] in FStar_Syntax_Util.mk_app brt - uu___39 in + uu___41 in let br = FStar_Syntax_Subst.close_branch (pat, FStar_Pervasives_Native.None, brt1) in - let uu___39 + let uu___41 = - let uu___40 + let uu___42 = - let uu___41 + let uu___43 = FStar_BigInt.of_int_fs (FStar_Compiler_List.length bs3) in (fv1, - uu___41) in + uu___43) in (g', br, - uu___40) in + uu___42) in Obj.magic (ret - uu___39)) - uu___38))) - uu___30))) - uu___27)))))) - uu___21)) + uu___41)) + uu___40))) + uu___32))) + uu___29)))))) + uu___23)) | - uu___18 + uu___19 -> Obj.repr (FStar_Tactics_Monad.fail "impossible: not a ctor")))) - uu___17) + uu___18) (Obj.magic c_lids)) in Obj.magic @@ -8229,9 +8233,9 @@ let (t_destruct : FStar_Tactics_Monad.monad_tac () () (Obj.magic - uu___16) + uu___17) (fun - uu___17 + uu___18 -> (fun goal_brs @@ -8240,11 +8244,11 @@ let (t_destruct : = Obj.magic goal_brs in - let uu___17 + let uu___18 = FStar_Compiler_List.unzip3 goal_brs in - match uu___17 + match uu___18 with | (goals, @@ -8266,7 +8270,7 @@ let (t_destruct : FStar_Pervasives_Native.None }) s_tm1.FStar_Syntax_Syntax.pos in - let uu___18 + let uu___19 = solve' g w in @@ -8274,21 +8278,21 @@ let (t_destruct : (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___18 - (fun uu___19 + (fun + uu___20 -> (fun - uu___19 + uu___20 -> - let uu___19 + let uu___20 = Obj.magic - uu___19 in + uu___20 in mark_goal_implicit_already_checked g; ( - let uu___21 + let uu___22 = FStar_Tactics_Monad.add_goals goals in @@ -8296,25 +8300,25 @@ let (t_destruct : (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___21 - (fun uu___22 + (fun + uu___23 -> (fun - uu___22 + uu___23 -> - let uu___22 + let uu___23 = Obj.magic - uu___22 in + uu___23 in Obj.magic (ret infos)) - uu___22)))) - uu___19))) - uu___17))) - uu___14))) - uu___12)) + uu___23)))) + uu___20))) + uu___18))) + uu___15))) + uu___13)) | uu___9 -> Obj.repr diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_V2_Basic.ml b/ocaml/fstar-lib/generated/FStar_Tactics_V2_Basic.ml index a40fec710a7..cfafee0fbf9 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_V2_Basic.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_V2_Basic.ml @@ -8077,7 +8077,9 @@ let (t_destruct : FStar_Syntax_Syntax.mutuals = mut; FStar_Syntax_Syntax.ds - = c_lids;_} + = c_lids; + FStar_Syntax_Syntax.injective_type_params + = uu___11;_} -> Obj.repr (let erasable @@ -8085,36 +8087,36 @@ let (t_destruct : FStar_Syntax_Util.has_attribute se.FStar_Syntax_Syntax.sigattrs FStar_Parser_Const.erasable_attr in - let uu___11 - = let uu___12 = + let uu___13 + = erasable && - (let uu___13 + (let uu___14 = FStar_Tactics_Monad.is_irrelevant g in Prims.op_Negation - uu___13) in + uu___14) in failwhen - uu___12 + uu___13 "cannot destruct erasable type to solve proof-relevant goal" in FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___11 - (fun uu___12 + (fun + uu___13 -> (fun - uu___12 + uu___13 -> - let uu___12 + let uu___13 = Obj.magic - uu___12 in - let uu___13 + uu___13 in + let uu___14 = failwhen ((FStar_Compiler_List.length @@ -8126,34 +8128,34 @@ let (t_destruct : (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___13 - (fun uu___14 + (fun + uu___15 -> (fun - uu___14 + uu___15 -> - let uu___14 + let uu___15 = Obj.magic - uu___14 in - let uu___15 + uu___15 in + let uu___16 = FStar_Syntax_Subst.open_term t_ps t_ty in - match uu___15 + match uu___16 with | (t_ps1, t_ty1) -> - let uu___16 + let uu___17 = Obj.magic (FStar_Class_Monad.mapM FStar_Tactics_Monad.monad_tac () () (fun - uu___17 + uu___18 -> (fun c_lid -> @@ -8161,16 +8163,16 @@ let (t_destruct : = Obj.magic c_lid in - let uu___17 - = let uu___18 = + let uu___19 + = FStar_Tactics_Types.goal_env g in FStar_TypeChecker_Env.lookup_sigelt - uu___18 + uu___19 c_lid in - match uu___17 + match uu___18 with | FStar_Pervasives_Native.None @@ -8191,33 +8193,35 @@ let (t_destruct : FStar_Syntax_Syntax.Sig_datacon { FStar_Syntax_Syntax.lid1 - = uu___18; + = uu___19; FStar_Syntax_Syntax.us1 = c_us; FStar_Syntax_Syntax.t1 = c_ty; FStar_Syntax_Syntax.ty_lid - = uu___19; + = uu___20; FStar_Syntax_Syntax.num_ty_params = nparam; FStar_Syntax_Syntax.mutuals1 - = mut1;_} + = mut1; + FStar_Syntax_Syntax.injective_type_params1 + = uu___21;_} -> Obj.repr (let qual = let fallback - uu___20 = + uu___22 = FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor in let qninfo = - let uu___20 + let uu___22 = FStar_Tactics_Types.goal_env g in FStar_TypeChecker_Env.lookup_qname - uu___20 + uu___22 c_lid in match qninfo with @@ -8230,7 +8234,7 @@ let (t_destruct : FStar_Syntax_DsEnv.fv_qual_of_se se2 | - uu___20 + uu___22 -> fallback () in @@ -8238,7 +8242,7 @@ let (t_destruct : FStar_Syntax_Syntax.lid_as_fv c_lid qual in - let uu___20 + let uu___22 = failwhen ((FStar_Compiler_List.length @@ -8249,17 +8253,17 @@ let (t_destruct : FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___20 + uu___22 (fun - uu___21 + uu___23 -> (fun - uu___21 + uu___23 -> - let uu___21 + let uu___23 = Obj.magic - uu___21 in + uu___23 in let s = FStar_TypeChecker_Env.mk_univ_subst c_us a_us in @@ -8267,26 +8271,26 @@ let (t_destruct : = FStar_Syntax_Subst.subst s c_ty in - let uu___22 + let uu___24 = FStar_TypeChecker_Env.inst_tscheme (c_us, c_ty1) in - match uu___22 + match uu___24 with | (c_us1, c_ty2) -> - let uu___23 + let uu___25 = FStar_Syntax_Util.arrow_formals_comp c_ty2 in - (match uu___23 + (match uu___25 with | (bs, comp) -> - let uu___24 + let uu___26 = let rename_bv bv = @@ -8295,26 +8299,26 @@ let (t_destruct : bv.FStar_Syntax_Syntax.ppname in let ppname1 = - let uu___25 + let uu___27 = - let uu___26 + let uu___28 = - let uu___27 + let uu___29 = FStar_Class_Show.show FStar_Ident.showable_ident ppname in Prims.strcat "a" - uu___27 in - let uu___27 + uu___29 in + let uu___29 = FStar_Ident.range_of_id ppname in - (uu___26, - uu___27) in + (uu___28, + uu___29) in FStar_Ident.mk_ident - uu___25 in + uu___27 in FStar_Syntax_Syntax.freshen_bv { FStar_Syntax_Syntax.ppname @@ -8329,13 +8333,13 @@ let (t_destruct : let bs' = FStar_Compiler_List.map (fun b -> - let uu___25 + let uu___27 = rename_bv b.FStar_Syntax_Syntax.binder_bv in { FStar_Syntax_Syntax.binder_bv - = uu___25; + = uu___27; FStar_Syntax_Syntax.binder_qual = (b.FStar_Syntax_Syntax.binder_qual); @@ -8350,100 +8354,100 @@ let (t_destruct : = FStar_Compiler_List.map2 (fun - uu___25 + uu___27 -> fun - uu___26 + uu___28 -> match - (uu___25, - uu___26) + (uu___27, + uu___28) with | ({ FStar_Syntax_Syntax.binder_bv = bv; FStar_Syntax_Syntax.binder_qual - = uu___27; + = uu___29; FStar_Syntax_Syntax.binder_positivity - = uu___28; + = uu___30; FStar_Syntax_Syntax.binder_attrs - = uu___29;_}, + = uu___31;_}, { FStar_Syntax_Syntax.binder_bv = bv'; FStar_Syntax_Syntax.binder_qual - = uu___30; + = uu___32; FStar_Syntax_Syntax.binder_positivity - = uu___31; + = uu___33; FStar_Syntax_Syntax.binder_attrs - = uu___32;_}) + = uu___34;_}) -> - let uu___33 + let uu___35 = - let uu___34 + let uu___36 = FStar_Syntax_Syntax.bv_to_name bv' in (bv, - uu___34) in + uu___36) in FStar_Syntax_Syntax.NT - uu___33) + uu___35) bs bs' in - let uu___25 + let uu___27 = FStar_Syntax_Subst.subst_binders subst bs' in - let uu___26 + let uu___28 = FStar_Syntax_Subst.subst_comp subst comp in - (uu___25, - uu___26) in - (match uu___24 + (uu___27, + uu___28) in + (match uu___26 with | (bs1, comp1) -> - let uu___25 + let uu___27 = FStar_Compiler_List.splitAt nparam bs1 in - (match uu___25 + (match uu___27 with | (d_ps, bs2) -> - let uu___26 + let uu___28 = - let uu___27 + let uu___29 = - let uu___28 + let uu___30 = FStar_Syntax_Util.is_total_comp comp1 in Prims.op_Negation - uu___28 in + uu___30 in failwhen - uu___27 + uu___29 "not total?" in Obj.magic (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___26 + uu___28 (fun - uu___27 + uu___29 -> (fun - uu___27 + uu___29 -> - let uu___27 + let uu___29 = Obj.magic - uu___27 in + uu___29 in let mk_pat p = { @@ -8454,28 +8458,28 @@ let (t_destruct : (s_tm1.FStar_Syntax_Syntax.pos) } in let is_imp - uu___28 = - match uu___28 + uu___30 = + match uu___30 with | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit - uu___29) + uu___31) -> true | - uu___29 + uu___31 -> false in - let uu___28 + let uu___30 = FStar_Compiler_List.splitAt nparam args in - match uu___28 + match uu___30 with | (a_ps, a_is) -> - let uu___29 + let uu___31 = failwhen ((FStar_Compiler_List.length @@ -8487,17 +8491,17 @@ let (t_destruct : (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___29 + uu___31 (fun - uu___30 + uu___32 -> (fun - uu___30 + uu___32 -> - let uu___30 + let uu___32 = Obj.magic - uu___30 in + uu___32 in let d_ps_a_ps = FStar_Compiler_List.zip @@ -8506,22 +8510,22 @@ let (t_destruct : = FStar_Compiler_List.map (fun - uu___31 + uu___33 -> - match uu___31 + match uu___33 with | ({ FStar_Syntax_Syntax.binder_bv = bv; FStar_Syntax_Syntax.binder_qual - = uu___32; + = uu___34; FStar_Syntax_Syntax.binder_positivity - = uu___33; + = uu___35; FStar_Syntax_Syntax.binder_attrs - = uu___34;_}, + = uu___36;_}, (t, - uu___35)) + uu___37)) -> FStar_Syntax_Syntax.NT (bv, t)) @@ -8533,22 +8537,22 @@ let (t_destruct : = FStar_Compiler_List.map (fun - uu___31 + uu___33 -> - match uu___31 + match uu___33 with | ({ FStar_Syntax_Syntax.binder_bv = bv; FStar_Syntax_Syntax.binder_qual - = uu___32; + = uu___34; FStar_Syntax_Syntax.binder_positivity - = uu___33; + = uu___35; FStar_Syntax_Syntax.binder_attrs - = uu___34;_}, + = uu___36;_}, (t, - uu___35)) + uu___37)) -> ((mk_pat (FStar_Syntax_Syntax.Pat_dot_term @@ -8560,9 +8564,9 @@ let (t_destruct : = FStar_Compiler_List.map (fun - uu___31 + uu___33 -> - match uu___31 + match uu___33 with | { @@ -8571,9 +8575,9 @@ let (t_destruct : FStar_Syntax_Syntax.binder_qual = bq; FStar_Syntax_Syntax.binder_positivity - = uu___32; + = uu___34; FStar_Syntax_Syntax.binder_attrs - = uu___33;_} + = uu___35;_} -> ((mk_pat (FStar_Syntax_Syntax.Pat_var @@ -8603,7 +8607,7 @@ let (t_destruct : env1.FStar_TypeChecker_Env.universe_of env1 s_ty1 in - let uu___31 + let uu___33 = FStar_TypeChecker_TcTerm.tc_pat { @@ -8764,23 +8768,23 @@ let (t_destruct : (env1.FStar_TypeChecker_Env.core_check) } s_ty1 pat in - match uu___31 + match uu___33 with | - (uu___32, - uu___33, - uu___34, + (uu___34, uu___35, - pat_t, uu___36, + uu___37, + pat_t, + uu___38, _guard_pat, _erasable) -> let eq_b = - let uu___37 + let uu___39 = - let uu___38 + let uu___40 = FStar_Syntax_Util.mk_eq2 equ s_ty1 @@ -8788,38 +8792,38 @@ let (t_destruct : pat_t in FStar_Syntax_Util.mk_squash FStar_Syntax_Syntax.U_zero - uu___38 in + uu___40 in FStar_Syntax_Syntax.gen_bv "breq" FStar_Pervasives_Native.None - uu___37 in + uu___39 in let cod1 = - let uu___37 + let uu___39 = - let uu___38 + let uu___40 = FStar_Syntax_Syntax.mk_binder eq_b in - [uu___38] in - let uu___38 + [uu___40] in + let uu___40 = FStar_Syntax_Syntax.mk_Total cod in FStar_Syntax_Util.arrow - uu___37 - uu___38 in + uu___39 + uu___40 in let nty = - let uu___37 + let uu___39 = FStar_Syntax_Syntax.mk_Total cod1 in FStar_Syntax_Util.arrow bs3 - uu___37 in - let uu___37 + uu___39 in + let uu___39 = - let uu___38 + let uu___40 = FStar_Tactics_Monad.goal_typedness_deps g in @@ -8827,7 +8831,7 @@ let (t_destruct : "destruct branch" env1 nty FStar_Pervasives_Native.None - uu___38 + uu___40 (rangeof g) in Obj.magic @@ -8835,18 +8839,18 @@ let (t_destruct : FStar_Tactics_Monad.monad_tac () () (Obj.magic - uu___37) + uu___39) (fun - uu___38 + uu___40 -> (fun - uu___38 + uu___40 -> - let uu___38 + let uu___40 = Obj.magic - uu___38 in - match uu___38 + uu___40 in + match uu___40 with | (uvt, uv) @@ -8862,51 +8866,51 @@ let (t_destruct : uvt bs3 in let brt1 = - let uu___39 + let uu___41 = - let uu___40 + let uu___42 = FStar_Syntax_Syntax.as_arg FStar_Syntax_Util.exp_unit in - [uu___40] in + [uu___42] in FStar_Syntax_Util.mk_app brt - uu___39 in + uu___41 in let br = FStar_Syntax_Subst.close_branch (pat, FStar_Pervasives_Native.None, brt1) in - let uu___39 + let uu___41 = - let uu___40 + let uu___42 = - let uu___41 + let uu___43 = FStar_BigInt.of_int_fs (FStar_Compiler_List.length bs3) in (fv1, - uu___41) in + uu___43) in (g', br, - uu___40) in + uu___42) in Obj.magic (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () (Obj.magic - uu___39))) - uu___38))) - uu___30))) - uu___27)))))) - uu___21)) + uu___41))) + uu___40))) + uu___32))) + uu___29)))))) + uu___23)) | - uu___18 + uu___19 -> Obj.repr (FStar_Tactics_Monad.fail "impossible: not a ctor")))) - uu___17) + uu___18) (Obj.magic c_lids)) in Obj.magic @@ -8914,9 +8918,9 @@ let (t_destruct : FStar_Tactics_Monad.monad_tac () () (Obj.magic - uu___16) + uu___17) (fun - uu___17 + uu___18 -> (fun goal_brs @@ -8925,11 +8929,11 @@ let (t_destruct : = Obj.magic goal_brs in - let uu___17 + let uu___18 = FStar_Compiler_List.unzip3 goal_brs in - match uu___17 + match uu___18 with | (goals, @@ -8951,7 +8955,7 @@ let (t_destruct : FStar_Pervasives_Native.None }) s_tm1.FStar_Syntax_Syntax.pos in - let uu___18 + let uu___19 = solve' g w in @@ -8959,21 +8963,21 @@ let (t_destruct : (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___18 - (fun uu___19 + (fun + uu___20 -> (fun - uu___19 + uu___20 -> - let uu___19 + let uu___20 = Obj.magic - uu___19 in + uu___20 in FStar_Tactics_Monad.mark_goal_implicit_already_checked g; ( - let uu___21 + let uu___22 = FStar_Tactics_Monad.add_goals goals in @@ -8981,28 +8985,28 @@ let (t_destruct : (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___21 - (fun uu___22 + (fun + uu___23 -> (fun - uu___22 + uu___23 -> - let uu___22 + let uu___23 = Obj.magic - uu___22 in + uu___23 in Obj.magic (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () (Obj.magic infos))) - uu___22)))) - uu___19))) - uu___17))) - uu___14))) - uu___12)) + uu___23)))) + uu___20))) + uu___18))) + uu___15))) + uu___13)) | uu___9 -> Obj.repr diff --git a/ocaml/fstar-lib/generated/FStar_ToSyntax_ToSyntax.ml b/ocaml/fstar-lib/generated/FStar_ToSyntax_ToSyntax.ml index 710914b9822..bc18fe7f8bf 100644 --- a/ocaml/fstar-lib/generated/FStar_ToSyntax_ToSyntax.ml +++ b/ocaml/fstar-lib/generated/FStar_ToSyntax_ToSyntax.ml @@ -1170,30 +1170,33 @@ let rec (generalize_annotated_univs : FStar_Syntax_Syntax.num_uniform_params = num_uniform; FStar_Syntax_Syntax.t = t; FStar_Syntax_Syntax.mutuals = lids1; - FStar_Syntax_Syntax.ds = lids2;_} + FStar_Syntax_Syntax.ds = lids2; + FStar_Syntax_Syntax.injective_type_params = uu___5;_} -> - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Subst.subst_binders usubst bs in + let uu___6 = + let uu___7 = let uu___8 = - let uu___9 = + FStar_Syntax_Subst.subst_binders usubst bs in + let uu___9 = + let uu___10 = FStar_Syntax_Subst.shift_subst (FStar_Compiler_List.length bs) usubst in - FStar_Syntax_Subst.subst uu___9 t in + FStar_Syntax_Subst.subst uu___10 t in { FStar_Syntax_Syntax.lid = lid; FStar_Syntax_Syntax.us = unames; - FStar_Syntax_Syntax.params = uu___7; + FStar_Syntax_Syntax.params = uu___8; FStar_Syntax_Syntax.num_uniform_params = num_uniform; - FStar_Syntax_Syntax.t = uu___8; + FStar_Syntax_Syntax.t = uu___9; FStar_Syntax_Syntax.mutuals = lids1; - FStar_Syntax_Syntax.ds = lids2 + FStar_Syntax_Syntax.ds = lids2; + FStar_Syntax_Syntax.injective_type_params = + false } in - FStar_Syntax_Syntax.Sig_inductive_typ uu___6 in + FStar_Syntax_Syntax.Sig_inductive_typ uu___7 in { - FStar_Syntax_Syntax.sigel = uu___5; + FStar_Syntax_Syntax.sigel = uu___6; FStar_Syntax_Syntax.sigrng = (se.FStar_Syntax_Syntax.sigrng); FStar_Syntax_Syntax.sigquals = @@ -1213,22 +1216,25 @@ let rec (generalize_annotated_univs : FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = tlid; FStar_Syntax_Syntax.num_ty_params = n; - FStar_Syntax_Syntax.mutuals1 = lids1;_} + FStar_Syntax_Syntax.mutuals1 = lids1; + FStar_Syntax_Syntax.injective_type_params1 = uu___5;_} -> - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Subst.subst usubst t in + let uu___6 = + let uu___7 = + let uu___8 = FStar_Syntax_Subst.subst usubst t in { FStar_Syntax_Syntax.lid1 = lid; FStar_Syntax_Syntax.us1 = unames; - FStar_Syntax_Syntax.t1 = uu___7; + FStar_Syntax_Syntax.t1 = uu___8; FStar_Syntax_Syntax.ty_lid = tlid; FStar_Syntax_Syntax.num_ty_params = n; - FStar_Syntax_Syntax.mutuals1 = lids1 + FStar_Syntax_Syntax.mutuals1 = lids1; + FStar_Syntax_Syntax.injective_type_params1 = + false } in - FStar_Syntax_Syntax.Sig_datacon uu___6 in + FStar_Syntax_Syntax.Sig_datacon uu___7 in { - FStar_Syntax_Syntax.sigel = uu___5; + FStar_Syntax_Syntax.sigel = uu___6; FStar_Syntax_Syntax.sigrng = (se.FStar_Syntax_Syntax.sigrng); FStar_Syntax_Syntax.sigquals = @@ -6660,32 +6666,33 @@ let (mk_data_projector_names : FStar_Syntax_Syntax.us1 = uu___; FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___1; FStar_Syntax_Syntax.num_ty_params = n; - FStar_Syntax_Syntax.mutuals1 = uu___2;_} + FStar_Syntax_Syntax.mutuals1 = uu___2; + FStar_Syntax_Syntax.injective_type_params1 = uu___3;_} -> - let uu___3 = FStar_Syntax_Util.arrow_formals t in - (match uu___3 with - | (formals, uu___4) -> + let uu___4 = FStar_Syntax_Util.arrow_formals t in + (match uu___4 with + | (formals, uu___5) -> (match formals with | [] -> [] - | uu___5 -> - let filter_records uu___6 = - match uu___6 with + | uu___6 -> + let filter_records uu___7 = + match uu___7 with | FStar_Syntax_Syntax.RecordConstructor - (uu___7, fns) -> + (uu___8, fns) -> FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Record_ctor (lid, fns)) - | uu___7 -> FStar_Pervasives_Native.None in + | uu___8 -> FStar_Pervasives_Native.None in let fv_qual = - let uu___6 = + let uu___7 = FStar_Compiler_Util.find_map se.FStar_Syntax_Syntax.sigquals filter_records in - match uu___6 with + match uu___7 with | FStar_Pervasives_Native.None -> FStar_Syntax_Syntax.Data_ctor | FStar_Pervasives_Native.Some q -> q in - let uu___6 = FStar_Compiler_Util.first_N n formals in - (match uu___6 with - | (uu___7, rest) -> + let uu___7 = FStar_Compiler_Util.first_N n formals in + (match uu___7 with + | (uu___8, rest) -> mk_indexed_projector_names iquals fv_qual se.FStar_Syntax_Syntax.sigattrs env lid rest))) | uu___ -> []) @@ -7072,7 +7079,9 @@ let rec (desugar_tycon : FStar_Pervasives_Native.None; FStar_Syntax_Syntax.t = k1; FStar_Syntax_Syntax.mutuals = mutuals; - FStar_Syntax_Syntax.ds = [] + FStar_Syntax_Syntax.ds = []; + FStar_Syntax_Syntax.injective_type_params = + false }); FStar_Syntax_Syntax.sigrng = uu___2; FStar_Syntax_Syntax.sigquals = quals1; @@ -7138,7 +7147,9 @@ let rec (desugar_tycon : FStar_Syntax_Syntax.num_uniform_params = uu___5; FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = []; - FStar_Syntax_Syntax.ds = [];_} + FStar_Syntax_Syntax.ds = []; + FStar_Syntax_Syntax.injective_type_params = + uu___6;_} -> let quals1 = se.FStar_Syntax_Syntax.sigquals in let quals2 = @@ -7147,22 +7158,22 @@ let rec (desugar_tycon : FStar_Syntax_Syntax.Assumption quals1 then quals1 else - ((let uu___8 = - let uu___9 = FStar_Options.ml_ish () in - Prims.op_Negation uu___9 in - if uu___8 + ((let uu___9 = + let uu___10 = FStar_Options.ml_ish () in + Prims.op_Negation uu___10 in + if uu___9 then - let uu___9 = - let uu___10 = - let uu___11 = + let uu___10 = + let uu___11 = + let uu___12 = FStar_Syntax_Print.lid_to_string l in FStar_Compiler_Util.format1 "Adding an implicit 'assume new' qualifier on %s" - uu___11 in + uu___12 in (FStar_Errors_Codes.Warning_AddImplicitAssumeNewQualifier, - uu___10) in + uu___11) in FStar_Errors.log_issue - se.FStar_Syntax_Syntax.sigrng uu___9 + se.FStar_Syntax_Syntax.sigrng uu___10 else ()); FStar_Syntax_Syntax.Assumption :: @@ -7172,17 +7183,17 @@ let rec (desugar_tycon : let t = match typars with | [] -> k - | uu___6 -> - let uu___7 = - let uu___8 = - let uu___9 = + | uu___7 -> + let uu___8 = + let uu___9 = + let uu___10 = FStar_Syntax_Syntax.mk_Total k in { FStar_Syntax_Syntax.bs1 = typars; - FStar_Syntax_Syntax.comp = uu___9 + FStar_Syntax_Syntax.comp = uu___10 } in - FStar_Syntax_Syntax.Tm_arrow uu___8 in - FStar_Syntax_Syntax.mk uu___7 + FStar_Syntax_Syntax.Tm_arrow uu___9 in + FStar_Syntax_Syntax.mk uu___8 se.FStar_Syntax_Syntax.sigrng in { FStar_Syntax_Syntax.sigel = @@ -7421,37 +7432,39 @@ let rec (desugar_tycon : = uu___4; FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6;_}; - FStar_Syntax_Syntax.sigrng = uu___7; - FStar_Syntax_Syntax.sigquals = uu___8; - FStar_Syntax_Syntax.sigmeta = uu___9; - FStar_Syntax_Syntax.sigattrs = uu___10; + FStar_Syntax_Syntax.ds = uu___6; + FStar_Syntax_Syntax.injective_type_params + = uu___7;_}; + FStar_Syntax_Syntax.sigrng = uu___8; + FStar_Syntax_Syntax.sigquals = uu___9; + FStar_Syntax_Syntax.sigmeta = uu___10; + FStar_Syntax_Syntax.sigattrs = uu___11; FStar_Syntax_Syntax.sigopens_and_abbrevs = - uu___11; - FStar_Syntax_Syntax.sigopts = uu___12;_}, + uu___12; + FStar_Syntax_Syntax.sigopts = uu___13;_}, binders, t, quals1) -> let t1 = - let uu___13 = + let uu___14 = typars_of_binders env1 binders in - match uu___13 with + match uu___14 with | (env2, tpars1) -> - let uu___14 = push_tparams env2 tpars1 in - (match uu___14 with + let uu___15 = push_tparams env2 tpars1 in + (match uu___15 with | (env_tps, tpars2) -> let t2 = desugar_typ env_tps t in let tpars3 = FStar_Syntax_Subst.close_binders tpars2 in FStar_Syntax_Subst.close tpars3 t2) in - let uu___13 = - let uu___14 = - let uu___15 = FStar_Ident.range_of_lid id in + let uu___14 = + let uu___15 = + let uu___16 = FStar_Ident.range_of_lid id in mk_typ_abbrev env1 d id uvs tpars (FStar_Pervasives_Native.Some k) t1 - [id] quals1 uu___15 in - ([], uu___14) in - [uu___13] + [id] quals1 uu___16 in + ([], uu___15) in + [uu___14] | FStar_Pervasives.Inl ({ FStar_Syntax_Syntax.sigel = @@ -7463,7 +7476,9 @@ let rec (desugar_tycon : = num_uniform; FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = mutuals1; - FStar_Syntax_Syntax.ds = uu___4;_}; + FStar_Syntax_Syntax.ds = uu___4; + FStar_Syntax_Syntax.injective_type_params + = injective_type_params;_}; FStar_Syntax_Syntax.sigrng = uu___5; FStar_Syntax_Syntax.sigquals = tname_quals; FStar_Syntax_Syntax.sigmeta = uu___6; @@ -7613,7 +7628,10 @@ let rec (desugar_tycon : FStar_Syntax_Syntax.num_ty_params = ntps; FStar_Syntax_Syntax.mutuals1 - = mutuals1 + = mutuals1; + FStar_Syntax_Syntax.injective_type_params1 + = + injective_type_params } in FStar_Syntax_Syntax.Sig_datacon uu___17 in @@ -7715,7 +7733,10 @@ let rec (desugar_tycon : FStar_Syntax_Syntax.mutuals = mutuals1; FStar_Syntax_Syntax.ds - = constrNames + = constrNames; + FStar_Syntax_Syntax.injective_type_params + = + injective_type_params }); FStar_Syntax_Syntax.sigrng = uu___15; @@ -7784,16 +7805,18 @@ let rec (desugar_tycon : = uu___6; FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = uu___7; - FStar_Syntax_Syntax.ds = constrs;_} + FStar_Syntax_Syntax.ds = constrs; + FStar_Syntax_Syntax.injective_type_params + = uu___8;_} -> let quals1 = se.FStar_Syntax_Syntax.sigquals in - let uu___8 = + let uu___9 = FStar_Compiler_List.filter (fun data_lid -> let data_quals = let data_se = - let uu___9 = + let uu___10 = FStar_Compiler_List.find (fun se1 -> match se1.FStar_Syntax_Syntax.sigel @@ -7803,35 +7826,37 @@ let rec (desugar_tycon : FStar_Syntax_Syntax.lid1 = name; FStar_Syntax_Syntax.us1 - = uu___10; - FStar_Syntax_Syntax.t1 = uu___11; - FStar_Syntax_Syntax.ty_lid + FStar_Syntax_Syntax.t1 = uu___12; - FStar_Syntax_Syntax.num_ty_params + FStar_Syntax_Syntax.ty_lid = uu___13; + FStar_Syntax_Syntax.num_ty_params + = uu___14; FStar_Syntax_Syntax.mutuals1 - = uu___14;_} + = uu___15; + FStar_Syntax_Syntax.injective_type_params1 + = uu___16;_} -> FStar_Ident.lid_equals name data_lid - | uu___10 -> false) + | uu___11 -> false) sigelts in FStar_Compiler_Util.must - uu___9 in + uu___10 in data_se.FStar_Syntax_Syntax.sigquals in - let uu___9 = + let uu___10 = FStar_Compiler_List.existsb - (fun uu___10 -> - match uu___10 with + (fun uu___11 -> + match uu___11 with | FStar_Syntax_Syntax.RecordConstructor - uu___11 -> true - | uu___11 -> false) + uu___12 -> true + | uu___12 -> false) data_quals in - Prims.op_Negation uu___9) + Prims.op_Negation uu___10) constrs in mk_data_discriminators quals1 env3 - uu___8 + uu___9 se.FStar_Syntax_Syntax.sigattrs | uu___5 -> []) sigelts in let ops = @@ -9275,12 +9300,14 @@ and (desugar_decl_core : FStar_Syntax_Syntax.num_ty_params = uu___6; FStar_Syntax_Syntax.mutuals1 = - uu___7;_} + uu___7; + FStar_Syntax_Syntax.injective_type_params1 + = uu___8;_} -> - let uu___8 = + let uu___9 = FStar_Syntax_Util.arrow_formals t in - (match uu___8 with - | (formals1, uu___9) -> + (match uu___9 with + | (formals1, uu___10) -> FStar_Pervasives_Native.Some formals1) | uu___3 -> FStar_Pervasives_Native.None) @@ -9300,7 +9327,8 @@ and (desugar_decl_core : FStar_Syntax_Syntax.num_uniform_params = uu___4; FStar_Syntax_Syntax.t = ty; FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6;_} + FStar_Syntax_Syntax.ds = uu___6; + FStar_Syntax_Syntax.injective_type_params = uu___7;_} -> let formals1 = match formals with @@ -9311,44 +9339,44 @@ and (desugar_decl_core : let i = FStar_Ident.ident_of_lid meth in FStar_Compiler_Util.for_some (fun formal -> - let uu___7 = + let uu___8 = FStar_Ident.ident_equals i (formal.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.ppname in - if uu___7 + if uu___8 then FStar_Compiler_Util.for_some (fun attr -> - let uu___8 = - let uu___9 = + let uu___9 = + let uu___10 = FStar_Syntax_Subst.compress attr in - uu___9.FStar_Syntax_Syntax.n in - match uu___8 with + uu___10.FStar_Syntax_Syntax.n in + match uu___9 with | FStar_Syntax_Syntax.Tm_fvar fv -> FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.no_method_lid - | uu___9 -> false) + | uu___10 -> false) formal.FStar_Syntax_Syntax.binder_attrs else false) formals1 in let meths1 = FStar_Compiler_List.filter (fun x -> - let uu___7 = has_no_method_attr x in - Prims.op_Negation uu___7) meths in + let uu___8 = has_no_method_attr x in + Prims.op_Negation uu___8) meths in let is_typed = false in - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = mkclass lid in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = mkclass lid in { FStar_Syntax_Syntax.is_typed = is_typed; FStar_Syntax_Syntax.lids2 = meths1; - FStar_Syntax_Syntax.tac = uu___10 + FStar_Syntax_Syntax.tac = uu___11 } in - FStar_Syntax_Syntax.Sig_splice uu___9 in - let uu___9 = + FStar_Syntax_Syntax.Sig_splice uu___10 in + let uu___10 = FStar_Syntax_DsEnv.opens_and_abbrevs env1 in { - FStar_Syntax_Syntax.sigel = uu___8; + FStar_Syntax_Syntax.sigel = uu___9; FStar_Syntax_Syntax.sigrng = (d.FStar_Parser_AST.drange); FStar_Syntax_Syntax.sigquals = []; @@ -9356,11 +9384,11 @@ and (desugar_decl_core : FStar_Syntax_Syntax.default_sigmeta; FStar_Syntax_Syntax.sigattrs = []; FStar_Syntax_Syntax.sigopens_and_abbrevs = - uu___9; + uu___10; FStar_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None } in - [uu___7] + [uu___8] | uu___2 -> [] in let uu___2 = if typeclass @@ -9865,7 +9893,8 @@ and (desugar_decl_core : FStar_Parser_Const.exn_lid; FStar_Syntax_Syntax.num_ty_params = Prims.int_zero; FStar_Syntax_Syntax.mutuals1 = - [FStar_Parser_Const.exn_lid] + [FStar_Parser_Const.exn_lid]; + FStar_Syntax_Syntax.injective_type_params1 = false }); FStar_Syntax_Syntax.sigrng = (d.FStar_Parser_AST.drange); FStar_Syntax_Syntax.sigquals = qual; diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Cfg.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Cfg.ml index d7ade7dd769..0ec4b48ca35 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Cfg.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Cfg.ml @@ -2424,8 +2424,8 @@ let (config' : let steps = let uu___ = to_fsteps s in add_nbe uu___ in let psteps1 = let uu___ = - let uu___1 = cached_steps () in - let uu___2 = env_dependent_ops e in merge_steps uu___1 uu___2 in + let uu___1 = env_dependent_ops e in + let uu___2 = cached_steps () in merge_steps uu___1 uu___2 in add_steps uu___ psteps in let dbg_flag = FStar_Compiler_List.contains FStar_TypeChecker_Env.NormDebug s in diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Env.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Env.ml index c724c1fbd98..b106e67b263 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Env.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Env.ml @@ -3141,18 +3141,19 @@ let (try_lookup_lid_aux : FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___2; FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4;_}; - FStar_Syntax_Syntax.sigrng = uu___5; - FStar_Syntax_Syntax.sigquals = uu___6; - FStar_Syntax_Syntax.sigmeta = uu___7; - FStar_Syntax_Syntax.sigattrs = uu___8; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; - FStar_Syntax_Syntax.sigopts = uu___10;_}, + FStar_Syntax_Syntax.mutuals1 = uu___4; + FStar_Syntax_Syntax.injective_type_params1 = uu___5;_}; + FStar_Syntax_Syntax.sigrng = uu___6; + FStar_Syntax_Syntax.sigquals = uu___7; + FStar_Syntax_Syntax.sigmeta = uu___8; + FStar_Syntax_Syntax.sigattrs = uu___9; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___10; + FStar_Syntax_Syntax.sigopts = uu___11;_}, FStar_Pervasives_Native.None) -> - let uu___11 = - let uu___12 = inst_tscheme1 (uvs, t) in (uu___12, rng) in - FStar_Pervasives_Native.Some uu___11 + let uu___12 = + let uu___13 = inst_tscheme1 (uvs, t) in (uu___13, rng) in + FStar_Pervasives_Native.Some uu___12 | FStar_Pervasives.Inr ({ FStar_Syntax_Syntax.sigel = @@ -3196,32 +3197,33 @@ let (try_lookup_lid_aux : FStar_Syntax_Syntax.num_uniform_params = uu___1; FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = uu___2; - FStar_Syntax_Syntax.ds = uu___3;_}; - FStar_Syntax_Syntax.sigrng = uu___4; - FStar_Syntax_Syntax.sigquals = uu___5; - FStar_Syntax_Syntax.sigmeta = uu___6; - FStar_Syntax_Syntax.sigattrs = uu___7; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___8; - FStar_Syntax_Syntax.sigopts = uu___9;_}, + FStar_Syntax_Syntax.ds = uu___3; + FStar_Syntax_Syntax.injective_type_params = uu___4;_}; + FStar_Syntax_Syntax.sigrng = uu___5; + FStar_Syntax_Syntax.sigquals = uu___6; + FStar_Syntax_Syntax.sigmeta = uu___7; + FStar_Syntax_Syntax.sigattrs = uu___8; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; + FStar_Syntax_Syntax.sigopts = uu___10;_}, FStar_Pervasives_Native.None) -> (match tps with | [] -> - let uu___10 = - let uu___11 = inst_tscheme1 (uvs, k) in - (uu___11, rng) in - FStar_Pervasives_Native.Some uu___10 - | uu___10 -> let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = FStar_Syntax_Syntax.mk_Total k in - FStar_Syntax_Util.flat_arrow tps uu___15 in - (uvs, uu___14) in - inst_tscheme1 uu___13 in + let uu___12 = inst_tscheme1 (uvs, k) in (uu___12, rng) in - FStar_Pervasives_Native.Some uu___11) + FStar_Pervasives_Native.Some uu___11 + | uu___11 -> + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = FStar_Syntax_Syntax.mk_Total k in + FStar_Syntax_Util.flat_arrow tps uu___16 in + (uvs, uu___15) in + inst_tscheme1 uu___14 in + (uu___13, rng) in + FStar_Pervasives_Native.Some uu___12) | FStar_Pervasives.Inr ({ FStar_Syntax_Syntax.sigel = @@ -3232,32 +3234,33 @@ let (try_lookup_lid_aux : FStar_Syntax_Syntax.num_uniform_params = uu___1; FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = uu___2; - FStar_Syntax_Syntax.ds = uu___3;_}; - FStar_Syntax_Syntax.sigrng = uu___4; - FStar_Syntax_Syntax.sigquals = uu___5; - FStar_Syntax_Syntax.sigmeta = uu___6; - FStar_Syntax_Syntax.sigattrs = uu___7; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___8; - FStar_Syntax_Syntax.sigopts = uu___9;_}, + FStar_Syntax_Syntax.ds = uu___3; + FStar_Syntax_Syntax.injective_type_params = uu___4;_}; + FStar_Syntax_Syntax.sigrng = uu___5; + FStar_Syntax_Syntax.sigquals = uu___6; + FStar_Syntax_Syntax.sigmeta = uu___7; + FStar_Syntax_Syntax.sigattrs = uu___8; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; + FStar_Syntax_Syntax.sigopts = uu___10;_}, FStar_Pervasives_Native.Some us) -> (match tps with | [] -> - let uu___10 = - let uu___11 = inst_tscheme_with (uvs, k) us in - (uu___11, rng) in - FStar_Pervasives_Native.Some uu___10 - | uu___10 -> let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = FStar_Syntax_Syntax.mk_Total k in - FStar_Syntax_Util.flat_arrow tps uu___15 in - (uvs, uu___14) in - inst_tscheme_with uu___13 us in + let uu___12 = inst_tscheme_with (uvs, k) us in (uu___12, rng) in - FStar_Pervasives_Native.Some uu___11) + FStar_Pervasives_Native.Some uu___11 + | uu___11 -> + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = FStar_Syntax_Syntax.mk_Total k in + FStar_Syntax_Util.flat_arrow tps uu___16 in + (uvs, uu___15) in + inst_tscheme_with uu___14 us in + (uu___13, rng) in + FStar_Pervasives_Native.Some uu___12) | FStar_Pervasives.Inr se -> let uu___1 = match se with @@ -3481,18 +3484,19 @@ let (lookup_datacon : FStar_Syntax_Syntax.us1 = uvs; FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___2; FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4;_}; - FStar_Syntax_Syntax.sigrng = uu___5; - FStar_Syntax_Syntax.sigquals = uu___6; - FStar_Syntax_Syntax.sigmeta = uu___7; - FStar_Syntax_Syntax.sigattrs = uu___8; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; - FStar_Syntax_Syntax.sigopts = uu___10;_}, + FStar_Syntax_Syntax.mutuals1 = uu___4; + FStar_Syntax_Syntax.injective_type_params1 = uu___5;_}; + FStar_Syntax_Syntax.sigrng = uu___6; + FStar_Syntax_Syntax.sigquals = uu___7; + FStar_Syntax_Syntax.sigmeta = uu___8; + FStar_Syntax_Syntax.sigattrs = uu___9; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___10; + FStar_Syntax_Syntax.sigopts = uu___11;_}, FStar_Pervasives_Native.None), - uu___11) + uu___12) -> - let uu___12 = FStar_Ident.range_of_lid lid in - inst_tscheme_with_range uu___12 (uvs, t) + let uu___13 = FStar_Ident.range_of_lid lid in + inst_tscheme_with_range uu___13 (uvs, t) | uu___1 -> let uu___2 = name_not_found lid in let uu___3 = FStar_Ident.range_of_lid lid in @@ -3516,18 +3520,19 @@ let (lookup_and_inst_datacon : FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___2; FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4;_}; - FStar_Syntax_Syntax.sigrng = uu___5; - FStar_Syntax_Syntax.sigquals = uu___6; - FStar_Syntax_Syntax.sigmeta = uu___7; - FStar_Syntax_Syntax.sigattrs = uu___8; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; - FStar_Syntax_Syntax.sigopts = uu___10;_}, + FStar_Syntax_Syntax.mutuals1 = uu___4; + FStar_Syntax_Syntax.injective_type_params1 = uu___5;_}; + FStar_Syntax_Syntax.sigrng = uu___6; + FStar_Syntax_Syntax.sigquals = uu___7; + FStar_Syntax_Syntax.sigmeta = uu___8; + FStar_Syntax_Syntax.sigattrs = uu___9; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___10; + FStar_Syntax_Syntax.sigopts = uu___11;_}, FStar_Pervasives_Native.None), - uu___11) + uu___12) -> - let uu___12 = inst_tscheme_with (uvs, t) us in - FStar_Pervasives_Native.snd uu___12 + let uu___13 = inst_tscheme_with (uvs, t) us in + FStar_Pervasives_Native.snd uu___13 | uu___1 -> let uu___2 = name_not_found lid in let uu___3 = FStar_Ident.range_of_lid lid in @@ -3550,15 +3555,16 @@ let (datacons_of_typ : FStar_Syntax_Syntax.num_uniform_params = uu___4; FStar_Syntax_Syntax.t = uu___5; FStar_Syntax_Syntax.mutuals = uu___6; - FStar_Syntax_Syntax.ds = dcs;_}; - FStar_Syntax_Syntax.sigrng = uu___7; - FStar_Syntax_Syntax.sigquals = uu___8; - FStar_Syntax_Syntax.sigmeta = uu___9; - FStar_Syntax_Syntax.sigattrs = uu___10; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___11; - FStar_Syntax_Syntax.sigopts = uu___12;_}, - uu___13), - uu___14) + FStar_Syntax_Syntax.ds = dcs; + FStar_Syntax_Syntax.injective_type_params = uu___7;_}; + FStar_Syntax_Syntax.sigrng = uu___8; + FStar_Syntax_Syntax.sigquals = uu___9; + FStar_Syntax_Syntax.sigmeta = uu___10; + FStar_Syntax_Syntax.sigattrs = uu___11; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___12; + FStar_Syntax_Syntax.sigopts = uu___13;_}, + uu___14), + uu___15) -> (true, dcs) | uu___1 -> (false, []) let (typ_of_datacon : env -> FStar_Ident.lident -> FStar_Ident.lident) = @@ -3575,22 +3581,23 @@ let (typ_of_datacon : env -> FStar_Ident.lident -> FStar_Ident.lident) = FStar_Syntax_Syntax.t1 = uu___3; FStar_Syntax_Syntax.ty_lid = l; FStar_Syntax_Syntax.num_ty_params = uu___4; - FStar_Syntax_Syntax.mutuals1 = uu___5;_}; - FStar_Syntax_Syntax.sigrng = uu___6; - FStar_Syntax_Syntax.sigquals = uu___7; - FStar_Syntax_Syntax.sigmeta = uu___8; - FStar_Syntax_Syntax.sigattrs = uu___9; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___10; - FStar_Syntax_Syntax.sigopts = uu___11;_}, - uu___12), - uu___13) + FStar_Syntax_Syntax.mutuals1 = uu___5; + FStar_Syntax_Syntax.injective_type_params1 = uu___6;_}; + FStar_Syntax_Syntax.sigrng = uu___7; + FStar_Syntax_Syntax.sigquals = uu___8; + FStar_Syntax_Syntax.sigmeta = uu___9; + FStar_Syntax_Syntax.sigattrs = uu___10; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___11; + FStar_Syntax_Syntax.sigopts = uu___12;_}, + uu___13), + uu___14) -> l | uu___1 -> let uu___2 = let uu___3 = FStar_Syntax_Print.lid_to_string lid in FStar_Compiler_Util.format1 "Not a datacon: %s" uu___3 in FStar_Compiler_Effect.failwith uu___2 -let (num_datacon_ty_params : +let (num_datacon_non_injective_ty_params : env -> FStar_Ident.lident -> Prims.int FStar_Pervasives_Native.option) = fun env1 -> fun lid -> @@ -3605,7 +3612,9 @@ let (num_datacon_ty_params : FStar_Syntax_Syntax.t1 = uu___3; FStar_Syntax_Syntax.ty_lid = uu___4; FStar_Syntax_Syntax.num_ty_params = num_ty_params; - FStar_Syntax_Syntax.mutuals1 = uu___5;_}; + FStar_Syntax_Syntax.mutuals1 = uu___5; + FStar_Syntax_Syntax.injective_type_params1 = + injective_type_params;_}; FStar_Syntax_Syntax.sigrng = uu___6; FStar_Syntax_Syntax.sigquals = uu___7; FStar_Syntax_Syntax.sigmeta = uu___8; @@ -3614,7 +3623,10 @@ let (num_datacon_ty_params : FStar_Syntax_Syntax.sigopts = uu___11;_}, uu___12), uu___13) - -> FStar_Pervasives_Native.Some num_ty_params + -> + if injective_type_params + then FStar_Pervasives_Native.Some Prims.int_zero + else FStar_Pervasives_Native.Some num_ty_params | uu___1 -> FStar_Pervasives_Native.None let (lookup_definition_qninfo_aux : Prims.bool -> @@ -4431,15 +4443,16 @@ let (num_inductive_ty_params : FStar_Syntax_Syntax.num_uniform_params = uu___3; FStar_Syntax_Syntax.t = uu___4; FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6;_}; - FStar_Syntax_Syntax.sigrng = uu___7; - FStar_Syntax_Syntax.sigquals = uu___8; - FStar_Syntax_Syntax.sigmeta = uu___9; - FStar_Syntax_Syntax.sigattrs = uu___10; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___11; - FStar_Syntax_Syntax.sigopts = uu___12;_}, - uu___13), - uu___14) + FStar_Syntax_Syntax.ds = uu___6; + FStar_Syntax_Syntax.injective_type_params = uu___7;_}; + FStar_Syntax_Syntax.sigrng = uu___8; + FStar_Syntax_Syntax.sigquals = uu___9; + FStar_Syntax_Syntax.sigmeta = uu___10; + FStar_Syntax_Syntax.sigattrs = uu___11; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___12; + FStar_Syntax_Syntax.sigopts = uu___13;_}, + uu___14), + uu___15) -> FStar_Pervasives_Native.Some (FStar_Compiler_List.length tps) | uu___1 -> FStar_Pervasives_Native.None let (num_inductive_uniform_ty_params : @@ -4459,27 +4472,28 @@ let (num_inductive_uniform_ty_params : FStar_Syntax_Syntax.num_uniform_params = num_uniform; FStar_Syntax_Syntax.t = uu___4; FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6;_}; - FStar_Syntax_Syntax.sigrng = uu___7; - FStar_Syntax_Syntax.sigquals = uu___8; - FStar_Syntax_Syntax.sigmeta = uu___9; - FStar_Syntax_Syntax.sigattrs = uu___10; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___11; - FStar_Syntax_Syntax.sigopts = uu___12;_}, - uu___13), - uu___14) + FStar_Syntax_Syntax.ds = uu___6; + FStar_Syntax_Syntax.injective_type_params = uu___7;_}; + FStar_Syntax_Syntax.sigrng = uu___8; + FStar_Syntax_Syntax.sigquals = uu___9; + FStar_Syntax_Syntax.sigmeta = uu___10; + FStar_Syntax_Syntax.sigattrs = uu___11; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___12; + FStar_Syntax_Syntax.sigopts = uu___13;_}, + uu___14), + uu___15) -> (match num_uniform with | FStar_Pervasives_Native.None -> - let uu___15 = - let uu___16 = - let uu___17 = FStar_Ident.string_of_lid lid in + let uu___16 = + let uu___17 = + let uu___18 = FStar_Ident.string_of_lid lid in FStar_Compiler_Util.format1 "Internal error: Inductive %s is not decorated with its uniform type parameters" - uu___17 in - (FStar_Errors_Codes.Fatal_UnexpectedInductivetype, uu___16) in - let uu___16 = FStar_Ident.range_of_lid lid in - FStar_Errors.raise_error uu___15 uu___16 + uu___18 in + (FStar_Errors_Codes.Fatal_UnexpectedInductivetype, uu___17) in + let uu___17 = FStar_Ident.range_of_lid lid in + FStar_Errors.raise_error uu___16 uu___17 | FStar_Pervasives_Native.Some n -> FStar_Pervasives_Native.Some n) | uu___1 -> FStar_Pervasives_Native.None let (effect_decl_opt : diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml index c168df346fd..14b4af2363b 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml @@ -497,7 +497,8 @@ let rec (eq_t : else (); (let uu___2 = let uu___3 = FStar_Syntax_Syntax.lid_of_fv v1 in - FStar_TypeChecker_Env.num_datacon_ty_params env uu___3 in + FStar_TypeChecker_Env.num_datacon_non_injective_ty_params + env uu___3 in match uu___2 with | FStar_Pervasives_Native.None -> FStar_TypeChecker_TermEqAndSimplify.Unknown diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize.ml index fbe5fb64f0a..e5e47469320 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize.ml @@ -9005,7 +9005,8 @@ let rec (elim_uvars : FStar_Syntax_Syntax.params = binders; FStar_Syntax_Syntax.num_uniform_params = num_uniform; FStar_Syntax_Syntax.t = typ; FStar_Syntax_Syntax.mutuals = lids; - FStar_Syntax_Syntax.ds = lids';_} + FStar_Syntax_Syntax.ds = lids'; + FStar_Syntax_Syntax.injective_type_params = injective_type_params;_} -> let uu___ = elim_uvars_aux_t env1 univ_names binders typ in (match uu___ with @@ -9020,7 +9021,9 @@ let rec (elim_uvars : FStar_Syntax_Syntax.num_uniform_params = num_uniform; FStar_Syntax_Syntax.t = typ1; FStar_Syntax_Syntax.mutuals = lids; - FStar_Syntax_Syntax.ds = lids' + FStar_Syntax_Syntax.ds = lids'; + FStar_Syntax_Syntax.injective_type_params = + injective_type_params }); FStar_Syntax_Syntax.sigrng = (s1.FStar_Syntax_Syntax.sigrng); FStar_Syntax_Syntax.sigquals = @@ -9062,7 +9065,9 @@ let rec (elim_uvars : FStar_Syntax_Syntax.t1 = typ; FStar_Syntax_Syntax.ty_lid = lident; FStar_Syntax_Syntax.num_ty_params = i; - FStar_Syntax_Syntax.mutuals1 = lids;_} + FStar_Syntax_Syntax.mutuals1 = lids; + FStar_Syntax_Syntax.injective_type_params1 = + injective_type_params;_} -> let uu___ = elim_uvars_aux_t env1 univ_names [] typ in (match uu___ with @@ -9076,7 +9081,9 @@ let rec (elim_uvars : FStar_Syntax_Syntax.t1 = typ1; FStar_Syntax_Syntax.ty_lid = lident; FStar_Syntax_Syntax.num_ty_params = i; - FStar_Syntax_Syntax.mutuals1 = lids + FStar_Syntax_Syntax.mutuals1 = lids; + FStar_Syntax_Syntax.injective_type_params1 = + injective_type_params }); FStar_Syntax_Syntax.sigrng = (s1.FStar_Syntax_Syntax.sigrng); FStar_Syntax_Syntax.sigquals = @@ -9641,7 +9648,7 @@ let (get_n_binders : FStar_Syntax_Syntax.term -> (FStar_Syntax_Syntax.binder Prims.list * FStar_Syntax_Syntax.comp)) = fun env1 -> fun n -> fun t -> get_n_binders' env1 [] n t -let (uu___3792 : unit) = +let (uu___3794 : unit) = FStar_Compiler_Effect.op_Colon_Equals __get_n_binders get_n_binders' let (maybe_unfold_head_fv : FStar_TypeChecker_Env.env -> diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Positivity.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Positivity.ml index 797fe186c64..718a32b7f7d 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Positivity.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Positivity.ml @@ -138,10 +138,11 @@ let (open_sig_inductive_typ : FStar_Syntax_Syntax.num_uniform_params = uu___; FStar_Syntax_Syntax.t = uu___1; FStar_Syntax_Syntax.mutuals = uu___2; - FStar_Syntax_Syntax.ds = uu___3;_} + FStar_Syntax_Syntax.ds = uu___3; + FStar_Syntax_Syntax.injective_type_params = uu___4;_} -> - let uu___4 = FStar_Syntax_Subst.univ_var_opening ty_us in - (match uu___4 with + let uu___5 = FStar_Syntax_Subst.univ_var_opening ty_us in + (match uu___5 with | (ty_usubst, ty_us1) -> let env1 = FStar_TypeChecker_Env.push_univ_vars env ty_us1 in let ty_params1 = @@ -372,7 +373,9 @@ let (mark_uniform_type_parameters : FStar_Syntax_Syntax.num_uniform_params = uu___1; FStar_Syntax_Syntax.t = t; FStar_Syntax_Syntax.mutuals = mutuals; - FStar_Syntax_Syntax.ds = data_lids;_} + FStar_Syntax_Syntax.ds = data_lids; + FStar_Syntax_Syntax.injective_type_params = + injective_type_params;_} -> let uu___2 = open_sig_inductive_typ env tc in (match uu___2 with @@ -390,31 +393,33 @@ let (mark_uniform_type_parameters : FStar_Syntax_Syntax.t1 = dt; FStar_Syntax_Syntax.ty_lid = tc_lid'; FStar_Syntax_Syntax.num_ty_params = uu___5; - FStar_Syntax_Syntax.mutuals1 = uu___6;_} + FStar_Syntax_Syntax.mutuals1 = uu___6; + FStar_Syntax_Syntax.injective_type_params1 + = uu___7;_} -> - let uu___7 = + let uu___8 = FStar_Ident.lid_equals tc_lid1 tc_lid' in - if uu___7 + if uu___8 then let dt1 = - let uu___8 = - let uu___9 = + let uu___9 = + let uu___10 = FStar_Compiler_List.map - (fun uu___10 -> + (fun uu___11 -> FStar_Syntax_Syntax.U_name - uu___10) us1 in + uu___11) us1 in FStar_TypeChecker_Env.mk_univ_subst - d_us uu___9 in - FStar_Syntax_Subst.subst uu___8 dt in - let uu___8 = - let uu___9 = - let uu___10 = + d_us uu___10 in + FStar_Syntax_Subst.subst uu___9 dt in + let uu___9 = + let uu___10 = + let uu___11 = apply_constr_arrow d_lid dt1 ty_param_args in FStar_Syntax_Util.arrow_formals - uu___10 in - FStar_Pervasives_Native.fst uu___9 in - FStar_Pervasives_Native.Some uu___8 + uu___11 in + FStar_Pervasives_Native.fst uu___10 in + FStar_Pervasives_Native.Some uu___9 else FStar_Pervasives_Native.None | uu___5 -> FStar_Pervasives_Native.None) datas in let ty_param_bvs = @@ -473,7 +478,9 @@ let (mark_uniform_type_parameters : max_uniform_prefix); FStar_Syntax_Syntax.t = t; FStar_Syntax_Syntax.mutuals = mutuals; - FStar_Syntax_Syntax.ds = data_lids + FStar_Syntax_Syntax.ds = data_lids; + FStar_Syntax_Syntax.injective_type_params = + injective_type_params } in { FStar_Syntax_Syntax.sigel = sigel; diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Tc.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Tc.ml index b0c708e79e5..bf80ad732b3 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Tc.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Tc.ml @@ -10,13 +10,15 @@ let (sigelt_typ : FStar_Syntax_Syntax.params = uu___2; FStar_Syntax_Syntax.num_uniform_params = uu___3; FStar_Syntax_Syntax.t = t; FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5;_} + FStar_Syntax_Syntax.ds = uu___5; + FStar_Syntax_Syntax.injective_type_params = uu___6;_} -> FStar_Pervasives_Native.Some t | FStar_Syntax_Syntax.Sig_datacon { FStar_Syntax_Syntax.lid1 = uu___; FStar_Syntax_Syntax.us1 = uu___1; FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___2; FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4;_} + FStar_Syntax_Syntax.mutuals1 = uu___4; + FStar_Syntax_Syntax.injective_type_params1 = uu___5;_} -> FStar_Pervasives_Native.Some t | FStar_Syntax_Syntax.Sig_declare_typ { FStar_Syntax_Syntax.lid2 = uu___; FStar_Syntax_Syntax.us2 = uu___1; @@ -435,7 +437,9 @@ let (tc_inductive' : uu___9; FStar_Syntax_Syntax.t = uu___10; FStar_Syntax_Syntax.mutuals = uu___11; - FStar_Syntax_Syntax.ds = uu___12;_} + FStar_Syntax_Syntax.ds = uu___12; + FStar_Syntax_Syntax.injective_type_params + = uu___13;_} -> (lid, (ty.FStar_Syntax_Syntax.sigrng)) | uu___7 -> FStar_Compiler_Effect.failwith @@ -464,7 +468,9 @@ let (tc_inductive' : FStar_Syntax_Syntax.t1 = uu___8; FStar_Syntax_Syntax.ty_lid = ty_lid; FStar_Syntax_Syntax.num_ty_params = uu___9; - FStar_Syntax_Syntax.mutuals1 = uu___10;_} + FStar_Syntax_Syntax.mutuals1 = uu___10; + FStar_Syntax_Syntax.injective_type_params1 + = uu___11;_} -> (data_lid, ty_lid) | uu___7 -> FStar_Compiler_Effect.failwith "Impossible" in @@ -506,7 +512,9 @@ let (tc_inductive' : uu___6; FStar_Syntax_Syntax.t = uu___7; FStar_Syntax_Syntax.mutuals = uu___8; - FStar_Syntax_Syntax.ds = uu___9;_} + FStar_Syntax_Syntax.ds = uu___9; + FStar_Syntax_Syntax.injective_type_params = + uu___10;_} -> lid1 | uu___4 -> FStar_Compiler_Effect.failwith "Impossible" in diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcInductive.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcInductive.ml index 676e915c74f..ce84b3f0f05 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcInductive.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcInductive.ml @@ -5,6 +5,270 @@ let (unfold_whnf : = FStar_TypeChecker_Normalize.unfold_whnf' [FStar_TypeChecker_Env.AllowUnboundUniverses] +let (check_sig_inductive_injectivity_on_params : + FStar_TypeChecker_Env.env_t -> + FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.sigelt) + = + fun tcenv -> + fun se -> + let uu___ = se.FStar_Syntax_Syntax.sigel in + match uu___ with + | FStar_Syntax_Syntax.Sig_inductive_typ dd -> + let uu___1 = dd in + (match uu___1 with + | { FStar_Syntax_Syntax.lid = t; + FStar_Syntax_Syntax.us = universe_names; + FStar_Syntax_Syntax.params = tps; + FStar_Syntax_Syntax.num_uniform_params = uu___2; + FStar_Syntax_Syntax.t = k; + FStar_Syntax_Syntax.mutuals = uu___3; + FStar_Syntax_Syntax.ds = uu___4; + FStar_Syntax_Syntax.injective_type_params = uu___5;_} -> + let t_lid = t in + let uu___6 = + FStar_Syntax_Subst.univ_var_opening universe_names in + (match uu___6 with + | (usubst, uvs) -> + let uu___7 = + let uu___8 = + FStar_TypeChecker_Env.push_univ_vars tcenv uvs in + let uu___9 = + FStar_Syntax_Subst.subst_binders usubst tps in + let uu___10 = + let uu___11 = + FStar_Syntax_Subst.shift_subst + (FStar_Compiler_List.length tps) usubst in + FStar_Syntax_Subst.subst uu___11 k in + (uu___8, uu___9, uu___10) in + (match uu___7 with + | (tcenv1, tps1, k1) -> + let uu___8 = FStar_Syntax_Subst.open_term tps1 k1 in + (match uu___8 with + | (tps2, k2) -> + let uu___9 = FStar_Syntax_Util.arrow_formals k2 in + (match uu___9 with + | (uu___10, k3) -> + let uu___11 = + FStar_TypeChecker_TcTerm.tc_binders + tcenv1 tps2 in + (match uu___11 with + | (tps3, env_tps, uu___12, us) -> + let u_k = + let uu___13 = + let uu___14 = + FStar_Syntax_Syntax.fvar t + FStar_Pervasives_Native.None in + let uu___15 = + let uu___16 = + FStar_Syntax_Util.args_of_binders + tps3 in + FStar_Pervasives_Native.snd + uu___16 in + let uu___16 = + FStar_Ident.range_of_lid t in + FStar_Syntax_Syntax.mk_Tm_app + uu___14 uu___15 uu___16 in + FStar_TypeChecker_TcTerm.level_of_type + env_tps uu___13 k3 in + let rec universe_leq u v = + match (u, v) with + | (FStar_Syntax_Syntax.U_zero, + uu___13) -> true + | (FStar_Syntax_Syntax.U_succ u0, + FStar_Syntax_Syntax.U_succ v0) + -> universe_leq u0 v0 + | (FStar_Syntax_Syntax.U_name u0, + FStar_Syntax_Syntax.U_name v0) + -> + FStar_Ident.ident_equals u0 v0 + | (FStar_Syntax_Syntax.U_name + uu___13, + FStar_Syntax_Syntax.U_succ v0) + -> universe_leq u v0 + | (FStar_Syntax_Syntax.U_max us1, + uu___13) -> + FStar_Compiler_Util.for_all + (fun u1 -> universe_leq u1 v) + us1 + | (uu___13, + FStar_Syntax_Syntax.U_max vs) -> + FStar_Compiler_Util.for_some + (universe_leq u) vs + | (FStar_Syntax_Syntax.U_unknown, + uu___13) -> + let uu___14 = + let uu___15 = + FStar_Ident.string_of_lid t in + let uu___16 = + FStar_Syntax_Print.univ_to_string + u in + let uu___17 = + FStar_Syntax_Print.univ_to_string + v in + FStar_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___15 uu___16 uu___17 in + FStar_Compiler_Effect.failwith + uu___14 + | (uu___13, + FStar_Syntax_Syntax.U_unknown) + -> + let uu___14 = + let uu___15 = + FStar_Ident.string_of_lid t in + let uu___16 = + FStar_Syntax_Print.univ_to_string + u in + let uu___17 = + FStar_Syntax_Print.univ_to_string + v in + FStar_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___15 uu___16 uu___17 in + FStar_Compiler_Effect.failwith + uu___14 + | (FStar_Syntax_Syntax.U_unif + uu___13, uu___14) -> + let uu___15 = + let uu___16 = + FStar_Ident.string_of_lid t in + let uu___17 = + FStar_Syntax_Print.univ_to_string + u in + let uu___18 = + FStar_Syntax_Print.univ_to_string + v in + FStar_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___16 uu___17 uu___18 in + FStar_Compiler_Effect.failwith + uu___15 + | (uu___13, + FStar_Syntax_Syntax.U_unif + uu___14) -> + let uu___15 = + let uu___16 = + FStar_Ident.string_of_lid t in + let uu___17 = + FStar_Syntax_Print.univ_to_string + u in + let uu___18 = + FStar_Syntax_Print.univ_to_string + v in + FStar_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___16 uu___17 uu___18 in + FStar_Compiler_Effect.failwith + uu___15 + | uu___13 -> false in + let u_leq_u_k u = + let u1 = + FStar_TypeChecker_Normalize.normalize_universe + env_tps u in + universe_leq u1 u_k in + let tp_ok tp u_tp = + let t_tp = + (tp.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in + let uu___13 = u_leq_u_k u_tp in + if uu___13 + then true + else + (let t_tp1 = + FStar_TypeChecker_Normalize.normalize + [FStar_TypeChecker_Env.Unrefine; + FStar_TypeChecker_Env.Unascribe; + FStar_TypeChecker_Env.Unmeta; + FStar_TypeChecker_Env.Primops; + FStar_TypeChecker_Env.HNF; + FStar_TypeChecker_Env.UnfoldUntil + FStar_Syntax_Syntax.delta_constant; + FStar_TypeChecker_Env.Beta] + env_tps t_tp in + let uu___15 = + FStar_Syntax_Util.arrow_formals + t_tp1 in + match uu___15 with + | (formals, t1) -> + let uu___16 = + FStar_TypeChecker_TcTerm.tc_binders + env_tps formals in + (match uu___16 with + | (uu___17, uu___18, + uu___19, u_formals) -> + let inj = + FStar_Compiler_Util.for_all + (fun u_formal -> + u_leq_u_k + u_formal) + u_formals in + if inj + then + let uu___20 = + let uu___21 = + FStar_Syntax_Subst.compress + t1 in + uu___21.FStar_Syntax_Syntax.n in + (match uu___20 with + | FStar_Syntax_Syntax.Tm_type + u -> u_leq_u_k u + | uu___21 -> false) + else false)) in + let injective_type_params = + FStar_Compiler_List.forall2 tp_ok + tps3 us in + ((let uu___14 = + FStar_TypeChecker_Env.debug + tcenv1 + (FStar_Options.Other + "TcInductive") in + if uu___14 + then + let uu___15 = + FStar_Ident.string_of_lid t in + FStar_Compiler_Util.print2 + "%s injectivity for %s\n" + (if injective_type_params + then "YES" + else "NO") uu___15 + else ()); + { + FStar_Syntax_Syntax.sigel = + (FStar_Syntax_Syntax.Sig_inductive_typ + { + FStar_Syntax_Syntax.lid = + (dd.FStar_Syntax_Syntax.lid); + FStar_Syntax_Syntax.us = + (dd.FStar_Syntax_Syntax.us); + FStar_Syntax_Syntax.params + = + (dd.FStar_Syntax_Syntax.params); + FStar_Syntax_Syntax.num_uniform_params + = + (dd.FStar_Syntax_Syntax.num_uniform_params); + FStar_Syntax_Syntax.t = + (dd.FStar_Syntax_Syntax.t); + FStar_Syntax_Syntax.mutuals + = + (dd.FStar_Syntax_Syntax.mutuals); + FStar_Syntax_Syntax.ds = + (dd.FStar_Syntax_Syntax.ds); + FStar_Syntax_Syntax.injective_type_params + = injective_type_params + }); + FStar_Syntax_Syntax.sigrng = + (se.FStar_Syntax_Syntax.sigrng); + FStar_Syntax_Syntax.sigquals = + (se.FStar_Syntax_Syntax.sigquals); + FStar_Syntax_Syntax.sigmeta = + (se.FStar_Syntax_Syntax.sigmeta); + FStar_Syntax_Syntax.sigattrs = + (se.FStar_Syntax_Syntax.sigattrs); + FStar_Syntax_Syntax.sigopens_and_abbrevs + = + (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); + FStar_Syntax_Syntax.sigopts = + (se.FStar_Syntax_Syntax.sigopts) + }))))))) let (tc_tycon : FStar_TypeChecker_Env.env_t -> FStar_Syntax_Syntax.sigelt -> @@ -19,36 +283,37 @@ let (tc_tycon : FStar_Syntax_Syntax.params = tps; FStar_Syntax_Syntax.num_uniform_params = n_uniform; FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = mutuals; - FStar_Syntax_Syntax.ds = data;_} + FStar_Syntax_Syntax.ds = data; + FStar_Syntax_Syntax.injective_type_params = uu___;_} -> let env0 = env in - let uu___ = FStar_Syntax_Subst.univ_var_opening uvs in - (match uu___ with + let uu___1 = FStar_Syntax_Subst.univ_var_opening uvs in + (match uu___1 with | (usubst, uvs1) -> - let uu___1 = - let uu___2 = FStar_TypeChecker_Env.push_univ_vars env uvs1 in - let uu___3 = FStar_Syntax_Subst.subst_binders usubst tps in - let uu___4 = - let uu___5 = + let uu___2 = + let uu___3 = FStar_TypeChecker_Env.push_univ_vars env uvs1 in + let uu___4 = FStar_Syntax_Subst.subst_binders usubst tps in + let uu___5 = + let uu___6 = FStar_Syntax_Subst.shift_subst (FStar_Compiler_List.length tps) usubst in - FStar_Syntax_Subst.subst uu___5 k in - (uu___2, uu___3, uu___4) in - (match uu___1 with + FStar_Syntax_Subst.subst uu___6 k in + (uu___3, uu___4, uu___5) in + (match uu___2 with | (env1, tps1, k1) -> - let uu___2 = FStar_Syntax_Subst.open_term tps1 k1 in - (match uu___2 with + let uu___3 = FStar_Syntax_Subst.open_term tps1 k1 in + (match uu___3 with | (tps2, k2) -> - let uu___3 = + let uu___4 = FStar_TypeChecker_TcTerm.tc_binders env1 tps2 in - (match uu___3 with + (match uu___4 with | (tps3, env_tps, guard_params, us) -> - let uu___4 = - let uu___5 = + let uu___5 = + let uu___6 = FStar_TypeChecker_TcTerm.tc_tot_or_gtot_term env_tps k2 in - match uu___5 with - | (k3, uu___6, g) -> + match uu___6 with + | (k3, uu___7, g) -> let k4 = FStar_TypeChecker_Normalize.normalize [FStar_TypeChecker_Env.Exclude @@ -60,23 +325,23 @@ let (tc_tycon : FStar_TypeChecker_Env.Exclude FStar_TypeChecker_Env.Beta] env_tps k3 in - let uu___7 = - FStar_Syntax_Util.arrow_formals k4 in let uu___8 = - let uu___9 = + FStar_Syntax_Util.arrow_formals k4 in + let uu___9 = + let uu___10 = FStar_TypeChecker_Env.conj_guard guard_params g in FStar_TypeChecker_Rel.discharge_guard - env_tps uu___9 in - (uu___7, uu___8) in - (match uu___4 with + env_tps uu___10 in + (uu___8, uu___9) in + (match uu___5 with | ((indices, t), guard) -> let k3 = - let uu___5 = + let uu___6 = FStar_Syntax_Syntax.mk_Total t in - FStar_Syntax_Util.arrow indices uu___5 in - let uu___5 = FStar_Syntax_Util.type_u () in - (match uu___5 with + FStar_Syntax_Util.arrow indices uu___6 in + let uu___6 = FStar_Syntax_Util.type_u () in + (match uu___6 with | (t_type, u) -> let valid_type = (((FStar_Syntax_Util.is_eqtype_no_unrefine @@ -96,21 +361,21 @@ let (tc_tycon : env1 t t_type) in (if Prims.op_Negation valid_type then - (let uu___7 = - let uu___8 = - let uu___9 = + (let uu___8 = + let uu___9 = + let uu___10 = FStar_Syntax_Print.term_to_string t in - let uu___10 = + let uu___11 = FStar_Ident.string_of_lid tc in FStar_Compiler_Util.format2 "Type annotation %s for inductive %s is not Type or eqtype, or it is eqtype but contains noeq/unopteq qualifiers" - uu___9 uu___10 in + uu___10 uu___11 in (FStar_Errors_Codes.Error_InductiveAnnotNotAType, - uu___8) in + uu___9) in FStar_Errors.raise_error_text - uu___7 + uu___8 s.FStar_Syntax_Syntax.sigrng) else (); (let usubst1 = @@ -120,22 +385,22 @@ let (tc_tycon : FStar_TypeChecker_Util.close_guard_implicits env1 false tps3 guard in let t_tc = - let uu___7 = - let uu___8 = + let uu___8 = + let uu___9 = FStar_Syntax_Subst.subst_binders usubst1 tps3 in - let uu___9 = - let uu___10 = + let uu___10 = + let uu___11 = FStar_Syntax_Subst.shift_subst (FStar_Compiler_List.length tps3) usubst1 in FStar_Syntax_Subst.subst_binders - uu___10 indices in + uu___11 indices in FStar_Compiler_List.op_At - uu___8 uu___9 in - let uu___8 = - let uu___9 = - let uu___10 = + uu___9 uu___10 in + let uu___9 = + let uu___10 = + let uu___11 = FStar_Syntax_Subst.shift_subst ((FStar_Compiler_List.length tps3) @@ -143,46 +408,46 @@ let (tc_tycon : (FStar_Compiler_List.length indices)) usubst1 in FStar_Syntax_Subst.subst - uu___10 t in + uu___11 t in FStar_Syntax_Syntax.mk_Total - uu___9 in - FStar_Syntax_Util.arrow uu___7 - uu___8 in + uu___10 in + FStar_Syntax_Util.arrow uu___8 + uu___9 in let tps4 = FStar_Syntax_Subst.close_binders tps3 in let k4 = FStar_Syntax_Subst.close tps4 k3 in - let uu___7 = - let uu___8 = + let uu___8 = + let uu___9 = FStar_Syntax_Subst.subst_binders usubst1 tps4 in - let uu___9 = - let uu___10 = + let uu___10 = + let uu___11 = FStar_Syntax_Subst.shift_subst (FStar_Compiler_List.length tps4) usubst1 in FStar_Syntax_Subst.subst - uu___10 k4 in - (uu___8, uu___9) in - match uu___7 with + uu___11 k4 in + (uu___9, uu___10) in + match uu___8 with | (tps5, k5) -> let fv_tc = FStar_Syntax_Syntax.lid_as_fv tc FStar_Pervasives_Native.None in - let uu___8 = + let uu___9 = FStar_Syntax_Subst.open_univ_vars uvs1 t_tc in - (match uu___8 with + (match uu___9 with | (uvs2, t_tc1) -> - let uu___9 = + let uu___10 = FStar_TypeChecker_Env.push_let_binding env0 (FStar_Pervasives.Inr fv_tc) (uvs2, t_tc1) in - (uu___9, + (uu___10, { FStar_Syntax_Syntax.sigel = @@ -201,7 +466,9 @@ let (tc_tycon : FStar_Syntax_Syntax.mutuals = mutuals; FStar_Syntax_Syntax.ds - = data + = data; + FStar_Syntax_Syntax.injective_type_params + = false }); FStar_Syntax_Syntax.sigrng = @@ -245,47 +512,50 @@ let (tc_data : FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = tc_lid; FStar_Syntax_Syntax.num_ty_params = ntps; - FStar_Syntax_Syntax.mutuals1 = mutual_tcs;_} + FStar_Syntax_Syntax.mutuals1 = mutual_tcs; + FStar_Syntax_Syntax.injective_type_params1 = uu___;_} -> - let uu___ = FStar_Syntax_Subst.univ_var_opening _uvs in - (match uu___ with + let uu___1 = FStar_Syntax_Subst.univ_var_opening _uvs in + (match uu___1 with | (usubst, _uvs1) -> - let uu___1 = - let uu___2 = + let uu___2 = + let uu___3 = FStar_TypeChecker_Env.push_univ_vars env _uvs1 in - let uu___3 = FStar_Syntax_Subst.subst usubst t in - (uu___2, uu___3) in - (match uu___1 with + let uu___4 = FStar_Syntax_Subst.subst usubst t in + (uu___3, uu___4) in + (match uu___2 with | (env1, t1) -> - let uu___2 = + let uu___3 = let tps_u_opt = FStar_Compiler_Util.find_map tcs - (fun uu___3 -> - match uu___3 with + (fun uu___4 -> + match uu___4 with | (se1, u_tc) -> - let uu___4 = - let uu___5 = - let uu___6 = + let uu___5 = + let uu___6 = + let uu___7 = FStar_Syntax_Util.lid_of_sigelt se1 in - FStar_Compiler_Util.must uu___6 in - FStar_Ident.lid_equals tc_lid uu___5 in - if uu___4 + FStar_Compiler_Util.must uu___7 in + FStar_Ident.lid_equals tc_lid uu___6 in + if uu___5 then (match se1.FStar_Syntax_Syntax.sigel with | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = uu___5; - FStar_Syntax_Syntax.us = uu___6; + { FStar_Syntax_Syntax.lid = uu___6; + FStar_Syntax_Syntax.us = uu___7; FStar_Syntax_Syntax.params = tps; FStar_Syntax_Syntax.num_uniform_params - = uu___7; - FStar_Syntax_Syntax.t = uu___8; + = uu___8; + FStar_Syntax_Syntax.t = uu___9; FStar_Syntax_Syntax.mutuals = - uu___9; - FStar_Syntax_Syntax.ds = uu___10;_} + uu___10; + FStar_Syntax_Syntax.ds = uu___11; + FStar_Syntax_Syntax.injective_type_params + = uu___12;_} -> let tps1 = - let uu___11 = + let uu___13 = FStar_Syntax_Subst.subst_binders usubst tps in FStar_Compiler_List.map @@ -304,37 +574,37 @@ let (tc_data : FStar_Syntax_Syntax.binder_attrs = (x.FStar_Syntax_Syntax.binder_attrs) - }) uu___11 in + }) uu___13 in let tps2 = FStar_Syntax_Subst.open_binders tps1 in - let uu___11 = - let uu___12 = + let uu___13 = + let uu___14 = FStar_TypeChecker_Env.push_binders env1 tps2 in - (uu___12, tps2, u_tc) in + (uu___14, tps2, u_tc) in FStar_Pervasives_Native.Some - uu___11 - | uu___5 -> + uu___13 + | uu___6 -> FStar_Compiler_Effect.failwith "Impossible") else FStar_Pervasives_Native.None) in match tps_u_opt with | FStar_Pervasives_Native.Some x -> x | FStar_Pervasives_Native.None -> - let uu___3 = + let uu___4 = FStar_Ident.lid_equals tc_lid FStar_Parser_Const.exn_lid in - if uu___3 + if uu___4 then (env1, [], FStar_Syntax_Syntax.U_zero) else FStar_Errors.raise_error (FStar_Errors_Codes.Fatal_UnexpectedDataConstructor, "Unexpected data constructor") se.FStar_Syntax_Syntax.sigrng in - (match uu___2 with + (match uu___3 with | (env2, tps, u_tc) -> - let uu___3 = + let uu___4 = let t2 = FStar_TypeChecker_Normalize.normalize (FStar_Compiler_List.op_At @@ -342,18 +612,18 @@ let (tc_data : [FStar_TypeChecker_Env.AllowUnboundUniverses]) env2 t1 in let t3 = FStar_Syntax_Util.canon_arrow t2 in - let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress t3 in - uu___5.FStar_Syntax_Syntax.n in - match uu___4 with + let uu___5 = + let uu___6 = FStar_Syntax_Subst.compress t3 in + uu___6.FStar_Syntax_Syntax.n in + match uu___5 with | FStar_Syntax_Syntax.Tm_arrow { FStar_Syntax_Syntax.bs1 = bs; FStar_Syntax_Syntax.comp = res;_} -> - let uu___5 = + let uu___6 = FStar_Compiler_Util.first_N ntps bs in - (match uu___5 with - | (uu___6, bs') -> + (match uu___6 with + | (uu___7, bs') -> let t4 = FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_arrow @@ -364,71 +634,71 @@ let (tc_data : let subst = FStar_Compiler_List.mapi (fun i -> - fun uu___7 -> - match uu___7 with + fun uu___8 -> + match uu___8 with | { FStar_Syntax_Syntax.binder_bv = x; FStar_Syntax_Syntax.binder_qual - = uu___8; - FStar_Syntax_Syntax.binder_positivity = uu___9; + FStar_Syntax_Syntax.binder_positivity + = uu___10; FStar_Syntax_Syntax.binder_attrs - = uu___10;_} + = uu___11;_} -> FStar_Syntax_Syntax.DB ((ntps - (Prims.int_one + i)), x)) tps in - let uu___7 = - let uu___8 = + let uu___8 = + let uu___9 = FStar_Syntax_Subst.subst subst t4 in FStar_Syntax_Util.arrow_formals_comp - uu___8 in - (match uu___7 with + uu___9 in + (match uu___8 with | (bs1, c1) -> - let uu___8 = + let uu___9 = (FStar_Options.ml_ish ()) || (FStar_Syntax_Util.is_total_comp c1) in - if uu___8 + if uu___9 then (bs1, (FStar_Syntax_Util.comp_result c1)) else - (let uu___10 = + (let uu___11 = FStar_Ident.range_of_lid (FStar_Syntax_Util.comp_effect_name c1) in FStar_Errors.raise_error (FStar_Errors_Codes.Fatal_UnexpectedConstructorType, "Constructors cannot have effects") - uu___10))) - | uu___5 -> ([], t3) in - (match uu___3 with + uu___11))) + | uu___6 -> ([], t3) in + (match uu___4 with | (arguments, result) -> - ((let uu___5 = + ((let uu___6 = FStar_TypeChecker_Env.debug env2 FStar_Options.Low in - if uu___5 + if uu___6 then - let uu___6 = - FStar_Syntax_Print.lid_to_string c in let uu___7 = + FStar_Syntax_Print.lid_to_string c in + let uu___8 = FStar_Syntax_Print.binders_to_string "->" arguments in - let uu___8 = + let uu___9 = FStar_Syntax_Print.term_to_string result in FStar_Compiler_Util.print3 "Checking datacon %s : %s -> %s \n" - uu___6 uu___7 uu___8 + uu___7 uu___8 uu___9 else ()); - (let uu___5 = + (let uu___6 = FStar_TypeChecker_TcTerm.tc_tparams env2 arguments in - match uu___5 with + match uu___6 with | (arguments1, env', us) -> let type_u_tc = FStar_Syntax_Syntax.mk @@ -437,23 +707,23 @@ let (tc_data : let env'1 = FStar_TypeChecker_Env.set_expected_typ env' type_u_tc in - let uu___6 = + let uu___7 = FStar_TypeChecker_TcTerm.tc_trivial_guard env'1 result in - (match uu___6 with + (match uu___7 with | (result1, res_lcomp) -> - let uu___7 = + let uu___8 = FStar_Syntax_Util.head_and_args_full result1 in - (match uu___7 with + (match uu___8 with | (head, args) -> let g_uvs = - let uu___8 = - let uu___9 = + let uu___9 = + let uu___10 = FStar_Syntax_Subst.compress head in - uu___9.FStar_Syntax_Syntax.n in - match uu___8 with + uu___10.FStar_Syntax_Syntax.n in + match uu___9 with | FStar_Syntax_Syntax.Tm_uinst ({ FStar_Syntax_Syntax.n @@ -461,11 +731,11 @@ let (tc_data : FStar_Syntax_Syntax.Tm_fvar fv; FStar_Syntax_Syntax.pos - = uu___9; - FStar_Syntax_Syntax.vars = uu___10; + FStar_Syntax_Syntax.vars + = uu___11; FStar_Syntax_Syntax.hash_code - = uu___11;_}, + = uu___12;_}, tuvs) when FStar_Syntax_Syntax.fv_eq_lid @@ -482,15 +752,15 @@ let (tc_data : (fun g -> fun u1 -> fun u2 -> - let uu___12 + let uu___13 = - let uu___13 + let uu___14 = FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_type u1) FStar_Compiler_Range_Type.dummyRange in - let uu___14 + let uu___15 = FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_type @@ -499,10 +769,10 @@ let (tc_data : FStar_Compiler_Range_Type.dummyRange in FStar_TypeChecker_Rel.teq env'1 - uu___13 - uu___14 in + uu___14 + uu___15 in FStar_TypeChecker_Env.conj_guard - g uu___12) + g uu___13) FStar_TypeChecker_Env.trivial_guard tuvs _uvs1 else @@ -516,138 +786,138 @@ let (tc_data : fv tc_lid -> FStar_TypeChecker_Env.trivial_guard - | uu___9 -> - let uu___10 = - let uu___11 = - let uu___12 = + | uu___10 -> + let uu___11 = + let uu___12 = + let uu___13 = FStar_Syntax_Print.lid_to_string tc_lid in - let uu___13 = + let uu___14 = FStar_Syntax_Print.term_to_string head in FStar_Compiler_Util.format2 "Expected a constructor of type %s; got %s" - uu___12 uu___13 in + uu___13 uu___14 in (FStar_Errors_Codes.Fatal_UnexpectedConstructorType, - uu___11) in + uu___12) in FStar_Errors.raise_error - uu___10 + uu___11 se.FStar_Syntax_Syntax.sigrng in let g = FStar_Compiler_List.fold_left2 (fun g1 -> - fun uu___8 -> + fun uu___9 -> fun u_x -> - match uu___8 with + match uu___9 with | { FStar_Syntax_Syntax.binder_bv = x; FStar_Syntax_Syntax.binder_qual - = uu___9; - FStar_Syntax_Syntax.binder_positivity = uu___10; + FStar_Syntax_Syntax.binder_positivity + = uu___11; FStar_Syntax_Syntax.binder_attrs - = uu___11;_} + = uu___12;_} -> - let uu___12 = + let uu___13 = FStar_TypeChecker_Rel.universe_inequality u_x u_tc in FStar_TypeChecker_Env.conj_guard - g1 uu___12) + g1 uu___13) g_uvs arguments1 us in (FStar_Errors.stop_if_err (); (let p_args = - let uu___9 = + let uu___10 = FStar_Compiler_Util.first_N (FStar_Compiler_List.length tps) args in FStar_Pervasives_Native.fst - uu___9 in + uu___10 in FStar_Compiler_List.iter2 - (fun uu___10 -> - fun uu___11 -> - match (uu___10, - uu___11) + (fun uu___11 -> + fun uu___12 -> + match (uu___11, + uu___12) with | ({ FStar_Syntax_Syntax.binder_bv = bv; FStar_Syntax_Syntax.binder_qual - = uu___12; - FStar_Syntax_Syntax.binder_positivity = uu___13; + FStar_Syntax_Syntax.binder_positivity + = uu___14; FStar_Syntax_Syntax.binder_attrs - = uu___14;_}, - (t2, uu___15)) -> - let uu___16 = - let uu___17 = + = uu___15;_}, + (t2, uu___16)) -> + let uu___17 = + let uu___18 = FStar_Syntax_Subst.compress t2 in - uu___17.FStar_Syntax_Syntax.n in - (match uu___16 + uu___18.FStar_Syntax_Syntax.n in + (match uu___17 with | FStar_Syntax_Syntax.Tm_name bv' when FStar_Syntax_Syntax.bv_eq bv bv' -> () - | uu___17 -> - let uu___18 - = - let uu___19 + | uu___18 -> + let uu___19 = let uu___20 = + let uu___21 + = FStar_Syntax_Print.bv_to_string bv in - let uu___21 + let uu___22 = FStar_Syntax_Print.term_to_string t2 in FStar_Compiler_Util.format2 "This parameter is not constant: expected %s, got %s" - uu___20 - uu___21 in + uu___21 + uu___22 in (FStar_Errors_Codes.Error_BadInductiveParam, - uu___19) in + uu___20) in FStar_Errors.raise_error - uu___18 + uu___19 t2.FStar_Syntax_Syntax.pos)) tps p_args; (let ty = - let uu___10 = + let uu___11 = unfold_whnf env2 res_lcomp.FStar_TypeChecker_Common.res_typ in FStar_Syntax_Util.unrefine - uu___10 in - (let uu___11 = - let uu___12 = + uu___11 in + (let uu___12 = + let uu___13 = FStar_Syntax_Subst.compress ty in - uu___12.FStar_Syntax_Syntax.n in - match uu___11 with + uu___13.FStar_Syntax_Syntax.n in + match uu___12 with | FStar_Syntax_Syntax.Tm_type - uu___12 -> () - | uu___12 -> - let uu___13 = - let uu___14 = - let uu___15 = + uu___13 -> () + | uu___13 -> + let uu___14 = + let uu___15 = + let uu___16 = FStar_Syntax_Print.term_to_string result1 in - let uu___16 = + let uu___17 = FStar_Syntax_Print.term_to_string ty in FStar_Compiler_Util.format2 "The type of %s is %s, but since this is the result type of a constructor its type should be Type" - uu___15 uu___16 in + uu___16 uu___17 in (FStar_Errors_Codes.Fatal_WrongResultTypeAfterConstrutor, - uu___14) in + uu___15) in FStar_Errors.raise_error - uu___13 + uu___14 se.FStar_Syntax_Syntax.sigrng); (let t2 = - let uu___11 = - let uu___12 = + let uu___12 = + let uu___13 = FStar_Compiler_List.map (fun b -> { @@ -667,12 +937,12 @@ let (tc_data : (b.FStar_Syntax_Syntax.binder_attrs) }) tps in FStar_Compiler_List.op_At - uu___12 arguments1 in - let uu___12 = + uu___13 arguments1 in + let uu___13 = FStar_Syntax_Syntax.mk_Total result1 in FStar_Syntax_Util.arrow - uu___11 uu___12 in + uu___12 uu___13 in let t3 = FStar_Syntax_Subst.close_univ_vars _uvs1 t2 in @@ -692,7 +962,9 @@ let (tc_data : FStar_Syntax_Syntax.num_ty_params = ntps; FStar_Syntax_Syntax.mutuals1 - = mutual_tcs + = mutual_tcs; + FStar_Syntax_Syntax.injective_type_params1 + = false }); FStar_Syntax_Syntax.sigrng = @@ -737,12 +1009,13 @@ let (generalize_and_inst_within : FStar_Syntax_Syntax.num_uniform_params = uu___4; FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6;_} + FStar_Syntax_Syntax.ds = uu___6; + FStar_Syntax_Syntax.injective_type_params = uu___7;_} -> - let uu___7 = - let uu___8 = FStar_Syntax_Syntax.mk_Total k in - FStar_Syntax_Util.arrow tps uu___8 in - FStar_Syntax_Syntax.null_binder uu___7 + let uu___8 = + let uu___9 = FStar_Syntax_Syntax.mk_Total k in + FStar_Syntax_Util.arrow tps uu___9 in + FStar_Syntax_Syntax.null_binder uu___8 | uu___2 -> FStar_Compiler_Effect.failwith "Impossible")) tcs in let binders' = @@ -755,7 +1028,8 @@ let (generalize_and_inst_within : FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___2; FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4;_} + FStar_Syntax_Syntax.mutuals1 = uu___4; + FStar_Syntax_Syntax.injective_type_params1 = uu___5;_} -> FStar_Syntax_Syntax.null_binder t | uu___ -> FStar_Compiler_Effect.failwith "Impossible") datas in let t = @@ -828,19 +1102,21 @@ let (generalize_and_inst_within : FStar_Syntax_Syntax.mutuals = mutuals; FStar_Syntax_Syntax.ds = - datas1;_} + datas1; + FStar_Syntax_Syntax.injective_type_params + = uu___15;_} -> let ty = FStar_Syntax_Subst.close_univ_vars uvs1 x.FStar_Syntax_Syntax.sort in - let uu___15 = - let uu___16 = - let uu___17 = + let uu___16 = + let uu___17 = + let uu___18 = FStar_Syntax_Subst.compress ty in - uu___17.FStar_Syntax_Syntax.n in - match uu___16 with + uu___18.FStar_Syntax_Syntax.n in + match uu___17 with | FStar_Syntax_Syntax.Tm_arrow { FStar_Syntax_Syntax.bs1 @@ -848,18 +1124,18 @@ let (generalize_and_inst_within : FStar_Syntax_Syntax.comp = c;_} -> - let uu___17 = + let uu___18 = FStar_Compiler_Util.first_N (FStar_Compiler_List.length tps) binders1 in - (match uu___17 with + (match uu___18 with | (tps1, rest) -> let t3 = match rest with | [] -> FStar_Syntax_Util.comp_result c - | uu___18 -> + | uu___19 -> FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_arrow { @@ -870,8 +1146,8 @@ let (generalize_and_inst_within : }) (x.FStar_Syntax_Syntax.sort).FStar_Syntax_Syntax.pos in (tps1, t3)) - | uu___17 -> ([], ty) in - (match uu___15 with + | uu___18 -> ([], ty) in + (match uu___16 with | (tps1, t3) -> { FStar_Syntax_Syntax.sigel @@ -891,7 +1167,9 @@ let (generalize_and_inst_within : FStar_Syntax_Syntax.mutuals = mutuals; FStar_Syntax_Syntax.ds - = datas1 + = datas1; + FStar_Syntax_Syntax.injective_type_params + = false }); FStar_Syntax_Syntax.sigrng = @@ -945,19 +1223,21 @@ let (generalize_and_inst_within : FStar_Syntax_Syntax.mutuals = uu___13; FStar_Syntax_Syntax.ds = - uu___14;_}; + uu___14; + FStar_Syntax_Syntax.injective_type_params + = uu___15;_}; FStar_Syntax_Syntax.sigrng = - uu___15; - FStar_Syntax_Syntax.sigquals = uu___16; - FStar_Syntax_Syntax.sigmeta = + FStar_Syntax_Syntax.sigquals = uu___17; - FStar_Syntax_Syntax.sigattrs = + FStar_Syntax_Syntax.sigmeta = uu___18; + FStar_Syntax_Syntax.sigattrs = + uu___19; FStar_Syntax_Syntax.sigopens_and_abbrevs - = uu___19; + = uu___20; FStar_Syntax_Syntax.sigopts = - uu___20;_} + uu___21;_} -> (tc, uvs_universes) | uu___9 -> FStar_Compiler_Effect.failwith @@ -991,15 +1271,17 @@ let (generalize_and_inst_within : FStar_Syntax_Syntax.num_ty_params = ntps; FStar_Syntax_Syntax.mutuals1 - = mutuals;_} + = mutuals; + FStar_Syntax_Syntax.injective_type_params1 + = uu___14;_} -> let ty = - let uu___14 = + let uu___15 = FStar_Syntax_InstFV.instantiate tc_insts t3.FStar_Syntax_Syntax.sort in FStar_Syntax_Subst.close_univ_vars - uvs1 uu___14 in + uvs1 uu___15 in { FStar_Syntax_Syntax.sigel = @@ -1016,7 +1298,9 @@ let (generalize_and_inst_within : FStar_Syntax_Syntax.num_ty_params = ntps; FStar_Syntax_Syntax.mutuals1 - = mutuals + = mutuals; + FStar_Syntax_Syntax.injective_type_params1 + = false }); FStar_Syntax_Syntax.sigrng = @@ -1049,7 +1333,8 @@ let (datacon_typ : FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.term) = { FStar_Syntax_Syntax.lid1 = uu___; FStar_Syntax_Syntax.us1 = uu___1; FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___2; FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4;_} + FStar_Syntax_Syntax.mutuals1 = uu___4; + FStar_Syntax_Syntax.injective_type_params1 = uu___5;_} -> t | uu___ -> FStar_Compiler_Effect.failwith "Impossible!" let (haseq_suffix : Prims.string) = "__uu___haseq" @@ -1102,7 +1387,8 @@ let (get_optimized_haseq_axiom : FStar_Syntax_Syntax.num_uniform_params = uu___2; FStar_Syntax_Syntax.t = t; FStar_Syntax_Syntax.mutuals = uu___3; - FStar_Syntax_Syntax.ds = uu___4;_} + FStar_Syntax_Syntax.ds = uu___4; + FStar_Syntax_Syntax.injective_type_params = uu___5;_} -> (lid, bs, t) | uu___1 -> FStar_Compiler_Effect.failwith "Impossible!" in match uu___ with @@ -1359,7 +1645,8 @@ let (optimized_haseq_ty : FStar_Syntax_Syntax.num_uniform_params = uu___2; FStar_Syntax_Syntax.t = uu___3; FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5;_} + FStar_Syntax_Syntax.ds = uu___5; + FStar_Syntax_Syntax.injective_type_params = uu___6;_} -> lid1 | uu___ -> FStar_Compiler_Effect.failwith "Impossible!" in let uu___ = acc in @@ -1387,7 +1674,9 @@ let (optimized_haseq_ty : FStar_Syntax_Syntax.ty_lid = t_lid; FStar_Syntax_Syntax.num_ty_params = uu___9; - FStar_Syntax_Syntax.mutuals1 = uu___10;_} + FStar_Syntax_Syntax.mutuals1 = uu___10; + FStar_Syntax_Syntax.injective_type_params1 + = uu___11;_} -> t_lid = lid | uu___6 -> FStar_Compiler_Effect.failwith @@ -1425,7 +1714,8 @@ let (optimized_haseq_scheme : FStar_Syntax_Syntax.num_uniform_params = uu___3; FStar_Syntax_Syntax.t = t; FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5;_} + FStar_Syntax_Syntax.ds = uu___5; + FStar_Syntax_Syntax.injective_type_params = uu___6;_} -> (us, t) | uu___1 -> FStar_Compiler_Effect.failwith "Impossible!" in match uu___ with @@ -1652,7 +1942,8 @@ let (unoptimized_haseq_ty : FStar_Syntax_Syntax.num_uniform_params = uu___2; FStar_Syntax_Syntax.t = t; FStar_Syntax_Syntax.mutuals = uu___3; - FStar_Syntax_Syntax.ds = d_lids;_} + FStar_Syntax_Syntax.ds = d_lids; + FStar_Syntax_Syntax.injective_type_params = uu___4;_} -> (lid, bs, t, d_lids) | uu___1 -> FStar_Compiler_Effect.failwith "Impossible!" in match uu___ with @@ -1715,7 +2006,9 @@ let (unoptimized_haseq_ty : FStar_Syntax_Syntax.ty_lid = t_lid; FStar_Syntax_Syntax.num_ty_params = uu___5; - FStar_Syntax_Syntax.mutuals1 = uu___6;_} + FStar_Syntax_Syntax.mutuals1 = uu___6; + FStar_Syntax_Syntax.injective_type_params1 + = uu___7;_} -> t_lid = lid | uu___2 -> FStar_Compiler_Effect.failwith "Impossible") @@ -1820,7 +2113,8 @@ let (unoptimized_haseq_scheme : FStar_Syntax_Syntax.num_uniform_params = uu___2; FStar_Syntax_Syntax.t = uu___3; FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5;_} + FStar_Syntax_Syntax.ds = uu___5; + FStar_Syntax_Syntax.injective_type_params = uu___6;_} -> lid | uu___ -> FStar_Compiler_Effect.failwith "Impossible!") tcs in let uu___ = @@ -1832,7 +2126,8 @@ let (unoptimized_haseq_scheme : FStar_Syntax_Syntax.num_uniform_params = uu___2; FStar_Syntax_Syntax.t = uu___3; FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5;_} + FStar_Syntax_Syntax.ds = uu___5; + FStar_Syntax_Syntax.injective_type_params = uu___6;_} -> (lid, us) | uu___1 -> FStar_Compiler_Effect.failwith "Impossible!" in match uu___ with @@ -1933,7 +2228,9 @@ let (check_inductive_well_typedness : FStar_Syntax_Syntax.num_uniform_params = uu___6; FStar_Syntax_Syntax.t = uu___7; FStar_Syntax_Syntax.mutuals = uu___8; - FStar_Syntax_Syntax.ds = uu___9;_} + FStar_Syntax_Syntax.ds = uu___9; + FStar_Syntax_Syntax.injective_type_params = + uu___10;_} -> uvs | uu___4 -> FStar_Compiler_Effect.failwith @@ -2045,49 +2342,51 @@ let (check_inductive_well_typedness : = num_uniform; FStar_Syntax_Syntax.t = typ; FStar_Syntax_Syntax.mutuals = ts; - FStar_Syntax_Syntax.ds = ds;_} + FStar_Syntax_Syntax.ds = ds; + FStar_Syntax_Syntax.injective_type_params + = uu___5;_} -> let fail expected inferred = - let uu___5 = - let uu___6 = - let uu___7 = + let uu___6 = + let uu___7 = + let uu___8 = FStar_Syntax_Print.tscheme_to_string expected in - let uu___8 = + let uu___9 = FStar_Syntax_Print.tscheme_to_string inferred in FStar_Compiler_Util.format2 "Expected an inductive with type %s; got %s" - uu___7 uu___8 in + uu___8 uu___9 in (FStar_Errors_Codes.Fatal_UnexpectedInductivetype, - uu___6) in - FStar_Errors.raise_error uu___5 + uu___7) in + FStar_Errors.raise_error uu___6 se.FStar_Syntax_Syntax.sigrng in let copy_binder_attrs_from_val binders1 expected = let expected_attrs = - let uu___5 = - let uu___6 = + let uu___6 = + let uu___7 = FStar_TypeChecker_Normalize.get_n_binders env1 (FStar_Compiler_List.length binders1) expected in FStar_Pervasives_Native.fst - uu___6 in + uu___7 in FStar_Compiler_List.map - (fun uu___6 -> - match uu___6 with + (fun uu___7 -> + match uu___7 with | { FStar_Syntax_Syntax.binder_bv - = uu___7; - FStar_Syntax_Syntax.binder_qual = uu___8; + FStar_Syntax_Syntax.binder_qual + = uu___9; FStar_Syntax_Syntax.binder_positivity = pqual; FStar_Syntax_Syntax.binder_attrs = attrs;_} -> (attrs, pqual)) - uu___5 in + uu___6 in if (FStar_Compiler_List.length expected_attrs) @@ -2095,44 +2394,44 @@ let (check_inductive_well_typedness : (FStar_Compiler_List.length binders1) then - let uu___5 = - let uu___6 = - let uu___7 = + let uu___6 = + let uu___7 = + let uu___8 = FStar_Compiler_Util.string_of_int (FStar_Compiler_List.length binders1) in - let uu___8 = + let uu___9 = FStar_Syntax_Print.term_to_string expected in FStar_Compiler_Util.format2 "Could not get %s type parameters from val type %s" - uu___7 uu___8 in + uu___8 uu___9 in (FStar_Errors_Codes.Fatal_UnexpectedInductivetype, - uu___6) in - FStar_Errors.raise_error uu___5 + uu___7) in + FStar_Errors.raise_error uu___6 se.FStar_Syntax_Syntax.sigrng else FStar_Compiler_List.map2 - (fun uu___6 -> + (fun uu___7 -> fun b -> - match uu___6 with + match uu___7 with | (ex_attrs, pqual) -> - ((let uu___8 = - let uu___9 = + ((let uu___9 = + let uu___10 = FStar_TypeChecker_Common.check_positivity_qual true pqual b.FStar_Syntax_Syntax.binder_positivity in Prims.op_Negation - uu___9 in - if uu___8 + uu___10 in + if uu___9 then - let uu___9 = + let uu___10 = FStar_Syntax_Syntax.range_of_bv b.FStar_Syntax_Syntax.binder_bv in FStar_Errors.raise_error (FStar_Errors_Codes.Fatal_UnexpectedInductivetype, "Incompatible positivity annotation") - uu___9 + uu___10 else ()); { FStar_Syntax_Syntax.binder_bv @@ -2155,32 +2454,32 @@ let (check_inductive_well_typedness : let body = match binders1 with | [] -> typ - | uu___5 -> - let uu___6 = - let uu___7 = - let uu___8 = + | uu___6 -> + let uu___7 = + let uu___8 = + let uu___9 = FStar_Syntax_Syntax.mk_Total typ in { FStar_Syntax_Syntax.bs1 = binders1; FStar_Syntax_Syntax.comp - = uu___8 + = uu___9 } in FStar_Syntax_Syntax.Tm_arrow - uu___7 in + uu___8 in FStar_Syntax_Syntax.mk - uu___6 + uu___7 se.FStar_Syntax_Syntax.sigrng in (univs1, body) in - let uu___5 = + let uu___6 = FStar_TypeChecker_Env.try_lookup_val_decl env0 l in - (match uu___5 with + (match uu___6 with | FStar_Pervasives_Native.None -> se | FStar_Pervasives_Native.Some - (expected_typ, uu___6) -> + (expected_typ, uu___7) -> if (FStar_Compiler_List.length univs1) @@ -2189,32 +2488,32 @@ let (check_inductive_well_typedness : (FStar_Pervasives_Native.fst expected_typ)) then - let uu___7 = + let uu___8 = FStar_Syntax_Subst.open_univ_vars univs1 (FStar_Pervasives_Native.snd expected_typ) in - (match uu___7 with - | (uu___8, expected) -> + (match uu___8 with + | (uu___9, expected) -> let binders1 = copy_binder_attrs_from_val binders expected in let inferred_typ = inferred_typ_with_binders binders1 in - let uu___9 = + let uu___10 = FStar_Syntax_Subst.open_univ_vars univs1 (FStar_Pervasives_Native.snd inferred_typ) in - (match uu___9 with - | (uu___10, inferred) + (match uu___10 with + | (uu___11, inferred) -> - let uu___11 = + let uu___12 = FStar_TypeChecker_Rel.teq_nosmt_force env0 inferred expected in - if uu___11 + if uu___12 then { FStar_Syntax_Syntax.sigel @@ -2236,7 +2535,9 @@ let (check_inductive_well_typedness : FStar_Syntax_Syntax.mutuals = ts; FStar_Syntax_Syntax.ds - = ds + = ds; + FStar_Syntax_Syntax.injective_type_params + = false }); FStar_Syntax_Syntax.sigrng = @@ -2261,11 +2562,94 @@ let (check_inductive_well_typedness : fail expected_typ inferred_typ)) else - (let uu___8 = + (let uu___9 = inferred_typ_with_binders binders in - fail expected_typ uu___8)) + fail expected_typ uu___9)) | uu___5 -> se) tcs1 in + let tcs3 = + FStar_Compiler_List.map + (check_sig_inductive_injectivity_on_params + env1) tcs2 in + let is_injective l = + let uu___5 = + FStar_Compiler_List.tryPick + (fun se -> + let uu___6 = + se.FStar_Syntax_Syntax.sigel in + match uu___6 with + | FStar_Syntax_Syntax.Sig_inductive_typ + { FStar_Syntax_Syntax.lid = lid; + FStar_Syntax_Syntax.us = uu___7; + FStar_Syntax_Syntax.params = + uu___8; + FStar_Syntax_Syntax.num_uniform_params + = uu___9; + FStar_Syntax_Syntax.t = uu___10; + FStar_Syntax_Syntax.mutuals = + uu___11; + FStar_Syntax_Syntax.ds = uu___12; + FStar_Syntax_Syntax.injective_type_params + = injective_type_params;_} + -> + let uu___13 = + FStar_Ident.lid_equals l lid in + if uu___13 + then + FStar_Pervasives_Native.Some + injective_type_params + else FStar_Pervasives_Native.None) + tcs3 in + match uu___5 with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some i -> i in + let datas3 = + FStar_Compiler_List.map + (fun se -> + let uu___5 = + se.FStar_Syntax_Syntax.sigel in + match uu___5 with + | FStar_Syntax_Syntax.Sig_datacon dd -> + let uu___6 = + let uu___7 = + let uu___8 = + is_injective + dd.FStar_Syntax_Syntax.ty_lid in + { + FStar_Syntax_Syntax.lid1 = + (dd.FStar_Syntax_Syntax.lid1); + FStar_Syntax_Syntax.us1 = + (dd.FStar_Syntax_Syntax.us1); + FStar_Syntax_Syntax.t1 = + (dd.FStar_Syntax_Syntax.t1); + FStar_Syntax_Syntax.ty_lid = + (dd.FStar_Syntax_Syntax.ty_lid); + FStar_Syntax_Syntax.num_ty_params + = + (dd.FStar_Syntax_Syntax.num_ty_params); + FStar_Syntax_Syntax.mutuals1 = + (dd.FStar_Syntax_Syntax.mutuals1); + FStar_Syntax_Syntax.injective_type_params1 + = uu___8 + } in + FStar_Syntax_Syntax.Sig_datacon + uu___7 in + { + FStar_Syntax_Syntax.sigel = uu___6; + FStar_Syntax_Syntax.sigrng = + (se.FStar_Syntax_Syntax.sigrng); + FStar_Syntax_Syntax.sigquals = + (se.FStar_Syntax_Syntax.sigquals); + FStar_Syntax_Syntax.sigmeta = + (se.FStar_Syntax_Syntax.sigmeta); + FStar_Syntax_Syntax.sigattrs = + (se.FStar_Syntax_Syntax.sigattrs); + FStar_Syntax_Syntax.sigopens_and_abbrevs + = + (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); + FStar_Syntax_Syntax.sigopts = + (se.FStar_Syntax_Syntax.sigopts) + }) datas2 in let sig_bndle = let uu___5 = FStar_TypeChecker_Env.get_range env0 in @@ -2278,8 +2662,8 @@ let (check_inductive_well_typedness : (FStar_Syntax_Syntax.Sig_bundle { FStar_Syntax_Syntax.ses = - (FStar_Compiler_List.op_At tcs2 - datas2); + (FStar_Compiler_List.op_At tcs3 + datas3); FStar_Syntax_Syntax.lids = lids }); FStar_Syntax_Syntax.sigrng = uu___5; @@ -2292,7 +2676,7 @@ let (check_inductive_well_typedness : FStar_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None } in - (sig_bndle, tcs2, datas2))))) + (sig_bndle, tcs3, datas3))))) let (early_prims_inductives : Prims.string Prims.list) = ["empty"; "trivial"; "equals"; "pair"; "sum"] let (mk_discriminator_and_indexed_projectors : @@ -3161,142 +3545,145 @@ let (mk_data_operations : FStar_Syntax_Syntax.us1 = uvs; FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = typ_lid; FStar_Syntax_Syntax.num_ty_params = n_typars; - FStar_Syntax_Syntax.mutuals1 = uu___;_} + FStar_Syntax_Syntax.mutuals1 = uu___; + FStar_Syntax_Syntax.injective_type_params1 = uu___1;_} -> - let uu___1 = FStar_Syntax_Subst.univ_var_opening uvs in - (match uu___1 with + let uu___2 = FStar_Syntax_Subst.univ_var_opening uvs in + (match uu___2 with | (univ_opening, uvs1) -> let t1 = FStar_Syntax_Subst.subst univ_opening t in - let uu___2 = FStar_Syntax_Util.arrow_formals t1 in - (match uu___2 with - | (formals, uu___3) -> - let uu___4 = + let uu___3 = FStar_Syntax_Util.arrow_formals t1 in + (match uu___3 with + | (formals, uu___4) -> + let uu___5 = let tps_opt = FStar_Compiler_Util.find_map tcs (fun se1 -> - let uu___5 = - let uu___6 = - let uu___7 = + let uu___6 = + let uu___7 = + let uu___8 = FStar_Syntax_Util.lid_of_sigelt se1 in - FStar_Compiler_Util.must uu___7 in - FStar_Ident.lid_equals typ_lid uu___6 in - if uu___5 + FStar_Compiler_Util.must uu___8 in + FStar_Ident.lid_equals typ_lid uu___7 in + if uu___6 then match se1.FStar_Syntax_Syntax.sigel with | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = uu___6; + { FStar_Syntax_Syntax.lid = uu___7; FStar_Syntax_Syntax.us = uvs'; FStar_Syntax_Syntax.params = tps; FStar_Syntax_Syntax.num_uniform_params - = uu___7; + = uu___8; FStar_Syntax_Syntax.t = typ0; FStar_Syntax_Syntax.mutuals = - uu___8; - FStar_Syntax_Syntax.ds = constrs;_} + uu___9; + FStar_Syntax_Syntax.ds = constrs; + FStar_Syntax_Syntax.injective_type_params + = uu___10;_} -> FStar_Pervasives_Native.Some (tps, typ0, ((FStar_Compiler_List.length constrs) > Prims.int_one)) - | uu___6 -> + | uu___7 -> FStar_Compiler_Effect.failwith "Impossible" else FStar_Pervasives_Native.None) in match tps_opt with | FStar_Pervasives_Native.Some x -> x | FStar_Pervasives_Native.None -> - let uu___5 = + let uu___6 = FStar_Ident.lid_equals typ_lid FStar_Parser_Const.exn_lid in - if uu___5 + if uu___6 then ([], FStar_Syntax_Util.ktype0, true) else FStar_Errors.raise_error (FStar_Errors_Codes.Fatal_UnexpectedDataConstructor, "Unexpected data constructor") se.FStar_Syntax_Syntax.sigrng in - (match uu___4 with + (match uu___5 with | (inductive_tps, typ0, should_refine) -> let inductive_tps1 = FStar_Syntax_Subst.subst_binders univ_opening inductive_tps in let typ01 = - let uu___5 = + let uu___6 = FStar_Syntax_Subst.shift_subst (FStar_Compiler_List.length inductive_tps1) univ_opening in - FStar_Syntax_Subst.subst uu___5 typ0 in - let uu___5 = + FStar_Syntax_Subst.subst uu___6 typ0 in + let uu___6 = FStar_Syntax_Util.arrow_formals typ01 in - (match uu___5 with - | (indices, uu___6) -> + (match uu___6 with + | (indices, uu___7) -> let refine_domain = - let uu___7 = + let uu___8 = FStar_Compiler_Util.for_some - (fun uu___8 -> - match uu___8 with + (fun uu___9 -> + match uu___9 with | FStar_Syntax_Syntax.RecordConstructor - uu___9 -> true - | uu___9 -> false) + uu___10 -> true + | uu___10 -> false) se.FStar_Syntax_Syntax.sigquals in - if uu___7 then false else should_refine in + if uu___8 then false else should_refine in let fv_qual = - let filter_records uu___7 = - match uu___7 with + let filter_records uu___8 = + match uu___8 with | FStar_Syntax_Syntax.RecordConstructor - (uu___8, fns) -> + (uu___9, fns) -> FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Record_ctor (typ_lid, fns)) - | uu___8 -> + | uu___9 -> FStar_Pervasives_Native.None in - let uu___7 = + let uu___8 = FStar_Compiler_Util.find_map se.FStar_Syntax_Syntax.sigquals filter_records in - match uu___7 with + match uu___8 with | FStar_Pervasives_Native.None -> FStar_Syntax_Syntax.Data_ctor | FStar_Pervasives_Native.Some q -> q in let fields = - let uu___7 = + let uu___8 = FStar_Compiler_Util.first_N n_typars formals in - match uu___7 with + match uu___8 with | (imp_tps, fields1) -> let rename = FStar_Compiler_List.map2 - (fun uu___8 -> - fun uu___9 -> - match (uu___8, uu___9) + (fun uu___9 -> + fun uu___10 -> + match (uu___9, uu___10) with | ({ FStar_Syntax_Syntax.binder_bv = x; FStar_Syntax_Syntax.binder_qual - = uu___10; - FStar_Syntax_Syntax.binder_positivity = uu___11; + FStar_Syntax_Syntax.binder_positivity + = uu___12; FStar_Syntax_Syntax.binder_attrs - = uu___12;_}, + = uu___13;_}, { FStar_Syntax_Syntax.binder_bv = x'; FStar_Syntax_Syntax.binder_qual - = uu___13; - FStar_Syntax_Syntax.binder_positivity = uu___14; + FStar_Syntax_Syntax.binder_positivity + = uu___15; FStar_Syntax_Syntax.binder_attrs - = uu___15;_}) + = uu___16;_}) -> - let uu___16 = - let uu___17 = + let uu___17 = + let uu___18 = FStar_Syntax_Syntax.bv_to_name x' in - (x, uu___17) in + (x, uu___18) in FStar_Syntax_Syntax.NT - uu___16) imp_tps + uu___17) imp_tps inductive_tps1 in FStar_Syntax_Subst.subst_binders rename fields1 in diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml index 64154508e6c..b63e05a5320 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml @@ -122,12 +122,12 @@ let rec (eq_tm : let uu___3 = let uu___4 = let uu___5 = FStar_Syntax_Syntax.lid_of_fv f in - FStar_TypeChecker_Env.num_datacon_ty_params env - uu___5 in + FStar_TypeChecker_Env.num_datacon_non_injective_ty_params + env uu___5 in let uu___5 = let uu___6 = FStar_Syntax_Syntax.lid_of_fv g in - FStar_TypeChecker_Env.num_datacon_ty_params env - uu___6 in + FStar_TypeChecker_Env.num_datacon_non_injective_ty_params + env uu___6 in (uu___4, uu___5) in (match uu___3 with | (FStar_Pervasives_Native.Some n1, diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Util.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Util.ml index 58d65c13a78..b7ec7eb929b 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Util.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Util.ml @@ -8251,24 +8251,26 @@ let (try_lookup_record_type : FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___5; FStar_Syntax_Syntax.num_ty_params = nparms; - FStar_Syntax_Syntax.mutuals1 = uu___6;_}; - FStar_Syntax_Syntax.sigrng = uu___7; - FStar_Syntax_Syntax.sigquals = uu___8; - FStar_Syntax_Syntax.sigmeta = uu___9; - FStar_Syntax_Syntax.sigattrs = uu___10; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___11; - FStar_Syntax_Syntax.sigopts = uu___12;_} + FStar_Syntax_Syntax.mutuals1 = uu___6; + FStar_Syntax_Syntax.injective_type_params1 = + uu___7;_}; + FStar_Syntax_Syntax.sigrng = uu___8; + FStar_Syntax_Syntax.sigquals = uu___9; + FStar_Syntax_Syntax.sigmeta = uu___10; + FStar_Syntax_Syntax.sigattrs = uu___11; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___12; + FStar_Syntax_Syntax.sigopts = uu___13;_} -> - let uu___13 = FStar_Syntax_Util.arrow_formals t in - (match uu___13 with + let uu___14 = FStar_Syntax_Util.arrow_formals t in + (match uu___14 with | (formals, c) -> if nparms < (FStar_Compiler_List.length formals) then - let uu___14 = + let uu___15 = FStar_Compiler_List.splitAt nparms formals in - (match uu___14 with - | (uu___15, fields) -> + (match uu___15 with + | (uu___16, fields) -> let fields1 = FStar_Compiler_List.filter (fun b -> @@ -8276,8 +8278,8 @@ let (try_lookup_record_type : with | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit - uu___16) -> false - | uu___16 -> true) fields in + uu___17) -> false + | uu___17 -> true) fields in let fields2 = FStar_Compiler_List.map (fun b -> @@ -8288,13 +8290,13 @@ let (try_lookup_record_type : FStar_TypeChecker_Env.is_record env typename in let r = - let uu___16 = + let uu___17 = FStar_Ident.ident_of_lid dc in { FStar_Syntax_DsEnv.typename = typename; FStar_Syntax_DsEnv.constrname = - uu___16; + uu___17; FStar_Syntax_DsEnv.parms = []; FStar_Syntax_DsEnv.fields = fields2; FStar_Syntax_DsEnv.is_private = diff --git a/src/fstar/FStar.CheckedFiles.fst b/src/fstar/FStar.CheckedFiles.fst index f629b8e123d..b02e98a2d23 100644 --- a/src/fstar/FStar.CheckedFiles.fst +++ b/src/fstar/FStar.CheckedFiles.fst @@ -34,7 +34,7 @@ module Dep = FStar.Parser.Dep * detect when loading the cache that the version number is same * It needs to be kept in sync with prims.fst *) -let cache_version_number = 66 +let cache_version_number = 67 (* * Abbreviation for what we store in the checked files (stages as described below) diff --git a/src/reflection/FStar.Reflection.V1.Builtins.fst b/src/reflection/FStar.Reflection.V1.Builtins.fst index ce917c84858..4652661bf5b 100644 --- a/src/reflection/FStar.Reflection.V1.Builtins.fst +++ b/src/reflection/FStar.Reflection.V1.Builtins.fst @@ -639,12 +639,14 @@ let pack_sigelt (sv:sigelt_view) : sigelt = check_lid ind_lid; let s = SS.univ_var_closing us_names in let nparam = List.length param_bs in + //We can't tust the value of injective_type_params; set it to false here and let the typechecker recompute + let injective_type_params = false in let pack_ctor (c:ctor) : sigelt = let (nm, ty) = c in let lid = Ident.lid_of_path nm Range.dummyRange in let ty = U.arrow param_bs (S.mk_Total ty) in let ty = SS.subst s ty in (* close univs *) - mk_sigelt <| Sig_datacon {lid; us=us_names; t=ty; ty_lid=ind_lid; num_ty_params=nparam; mutuals=[]} + mk_sigelt <| Sig_datacon {lid; us=us_names; t=ty; ty_lid=ind_lid; num_ty_params=nparam; mutuals=[]; injective_type_params } in let ctor_ses : list sigelt = List.map pack_ctor ctors in @@ -665,7 +667,8 @@ let pack_sigelt (sv:sigelt_view) : sigelt = num_uniform_params=None; t=ty; mutuals=[]; - ds=c_lids} + ds=c_lids; + injective_type_params } in let se = mk_sigelt <| Sig_bundle {ses=ind_se::ctor_ses; lids=ind_lid::c_lids} in { se with sigquals = Noeq::se.sigquals } diff --git a/src/reflection/FStar.Reflection.V2.Builtins.fst b/src/reflection/FStar.Reflection.V2.Builtins.fst index 8cfa8dc0b72..484a5925f37 100644 --- a/src/reflection/FStar.Reflection.V2.Builtins.fst +++ b/src/reflection/FStar.Reflection.V2.Builtins.fst @@ -603,10 +603,12 @@ let pack_sigelt (sv:sigelt_view) : sigelt = let ind_lid = Ident.lid_of_path nm Range.dummyRange in check_lid ind_lid; let nparam = List.length param_bs in + //We can't tust the value of injective_type_params; set it to false here and let the typechecker recompute + let injective_type_params = false in let pack_ctor (c:ctor) : sigelt = let (nm, ty) = c in let lid = Ident.lid_of_path nm Range.dummyRange in - mk_sigelt <| Sig_datacon {lid; us=us_names; t=ty; ty_lid=ind_lid; num_ty_params=nparam; mutuals=[]} + mk_sigelt <| Sig_datacon {lid; us=us_names; t=ty; ty_lid=ind_lid; num_ty_params=nparam; mutuals=[]; injective_type_params } in let ctor_ses : list sigelt = List.map pack_ctor ctors in @@ -621,7 +623,8 @@ let pack_sigelt (sv:sigelt_view) : sigelt = num_uniform_params=None; t=ty; mutuals=[]; - ds=c_lids} + ds=c_lids; + injective_type_params } in let se = mk_sigelt <| Sig_bundle {ses=ind_se::ctor_ses; lids=ind_lid::c_lids} in { se with sigquals = Noeq::se.sigquals } diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst index d0b6baf3355..a5d31e432a3 100644 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ b/src/smtencoding/FStar.SMTEncoding.Encode.fst @@ -1005,95 +1005,11 @@ let encode_top_level_let : let decl = Caption ("let rec unencodeable: Skipping: " ^msg) in [decl] |> mk_decls_trivial, env - -let is_sig_inductive_injective_on_params (env:env_t) (se:sigelt) - : bool - = let Sig_inductive_typ { lid=t; us=universe_names; params=tps; t=k } = se.sigel in - let t_lid = t in - let tcenv = env.tcenv in - let usubst, uvs = SS.univ_var_opening universe_names in - let tcenv, tps, k = - Env.push_univ_vars tcenv uvs, - SS.subst_binders usubst tps, - SS.subst (SS.shift_subst (List.length tps) usubst) k - in - let tps, k = SS.open_term tps k in - let _, k = U.arrow_formals k in //don't care about indices here - let tps, env_tps, _, us = TcTerm.tc_binders tcenv tps in - let u_k = - TcTerm.level_of_type - env_tps - (S.mk_Tm_app - (S.fvar t None) - (snd (U.args_of_binders tps)) - (Ident.range_of_lid t)) - k - in - //BU.print2 "Universe of tycon: %s : %s\n" (Ident.string_of_lid t) (Print.univ_to_string u_k); - let rec universe_leq u v = - match u, v with - | U_zero, _ -> true - | U_succ u0, U_succ v0 -> universe_leq u0 v0 - | U_name u0, U_name v0 -> Ident.ident_equals u0 v0 - | U_name _, U_succ v0 -> universe_leq u v0 - | U_max us, _ -> us |> BU.for_all (fun u -> universe_leq u v) - | _, U_max vs -> vs |> BU.for_some (universe_leq u) - | U_unknown, _ - | _, U_unknown - | U_unif _, _ - | _, U_unif _ -> failwith (BU.format3 "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" - (Ident.string_of_lid t) - (Print.univ_to_string u) - (Print.univ_to_string v)) - | _ -> false - in - let u_leq_u_k u = - let u = N.normalize_universe env_tps u in - universe_leq u u_k - in - let tp_ok (tp:S.binder) (u_tp:universe) = - let t_tp = tp.binder_bv.sort in - if u_leq_u_k u_tp - then true - else ( - let t_tp = - N.normalize - [Unrefine; Unascribe; Unmeta; - Primops; HNF; UnfoldUntil delta_constant; Beta] - env_tps t_tp - in - let formals, t = U.arrow_formals t_tp in - let _, _, _, u_formals = TcTerm.tc_binders env_tps formals in - let inj = BU.for_all (fun u_formal -> u_leq_u_k u_formal) u_formals in - if inj - then ( - match (SS.compress t).n with - | Tm_type u -> - (* retain injectivity for parameters that are type functions - from small universes (i.e., all formals are smaller than the constructed type) - to a universe <= the universe of the constructed type. - See BugBoxInjectivity.fst *) - u_leq_u_k u - | _ -> - false - ) - else ( - false - ) - - ) - in - let is_injective_on_params = List.forall2 tp_ok tps us in - if Env.debug env.tcenv <| Options.Other "SMTEncoding" - then BU.print2 "%s injectivity for %s\n" - (if is_injective_on_params then "YES" else "NO") - (Ident.string_of_lid t); - is_injective_on_params - - -let encode_sig_inductive (is_injective_on_params:bool) (env:env_t) (se:sigelt) +let encode_sig_inductive (env:env_t) (se:sigelt) : decls_t * env_t -= let Sig_inductive_typ { lid=t; us=universe_names; params=tps; t=k; ds=datas} = se.sigel in += let Sig_inductive_typ + { lid=t; us=universe_names; params=tps; + t=k; ds=datas; injective_type_params } = se.sigel in let t_lid = t in let tcenv = env.tcenv in let quals = se.sigquals in @@ -1113,7 +1029,7 @@ let encode_sig_inductive (is_injective_on_params:bool) (env:env_t) (se:sigelt) (fun (out, decls) l -> let is_l = mk_data_tester env l xx in let inversion_case, decls' = - if is_injective_on_params + if injective_type_params || Options.ext_getv "compat:injectivity" <> "" then ( let _, data_t = Env.lookup_datacon env.tcenv l in @@ -1216,13 +1132,13 @@ let encode_sig_inductive (is_injective_on_params:bool) (env:env_t) (se:sigelt) let aux = kindingAx @(inversion_axioms env tapp vars) - @([pretype_axiom (not is_injective_on_params) (Ident.range_of_lid t) env tapp vars] |> mk_decls_trivial) + @([pretype_axiom (not injective_type_params) (Ident.range_of_lid t) env tapp vars] |> mk_decls_trivial) in (decls |> mk_decls_trivial)@binder_decls@aux, env -let encode_datacon (is_injective_on_tparams:bool) (env:env_t) (se:sigelt) +let encode_datacon (env:env_t) (se:sigelt) : decls_t * env_t -= let Sig_datacon {lid=d; t; num_ty_params=n_tps; mutuals} = se.sigel in += let Sig_datacon {lid=d; t; num_ty_params=n_tps; mutuals; injective_type_params } = se.sigel in let quals = se.sigquals in let t = norm_before_encoding env t in let formals, t_res = U.arrow_formals t in @@ -1232,8 +1148,8 @@ let encode_datacon (is_injective_on_tparams:bool) (env:env_t) (se:sigelt) let fuel_var, fuel_tm = fresh_fvar env.current_module_name "f" Fuel_sort in let s_fuel_tm = mkApp("SFuel", [fuel_tm]) in let vars, guards, env', binder_decls, names = encode_binders (Some fuel_tm) formals env in - let is_injective_on_tparams = - is_injective_on_tparams || Options.ext_getv "compat:injectivity" <> "" + let injective_type_params = + injective_type_params || Options.ext_getv "compat:injectivity" <> "" in let fields = names |> @@ -1241,7 +1157,7 @@ let encode_datacon (is_injective_on_tparams:bool) (env:env_t) (se:sigelt) (fun n x -> let field_projectible = n >= n_tps || //either this field is not a type parameter - is_injective_on_tparams //or we are allowed to be injective on parameters + injective_type_params //or we are allowed to be injective on parameters in { field_name=mk_term_projector_name d x; field_sort=Term_sort; @@ -1252,7 +1168,7 @@ let encode_datacon (is_injective_on_tparams:bool) (env:env_t) (se:sigelt) constr_fields=fields; constr_sort=Term_sort; constr_id=Some (varops.next_id()); - constr_base=not is_injective_on_tparams + constr_base=not injective_type_params } |> Term.constructor_to_decl (Ident.range_of_lid d) in let app = mk_Apply ddtok_tm vars in let guard = mk_and_l guards in @@ -1761,15 +1677,6 @@ and encode_sigelt' (env:env_t) (se:sigelt) : (decls_t * env_t) = encode_top_level_let env (is_rec, bindings) se.sigquals | Sig_bundle {ses} -> - let tycon = List.tryFind (fun se -> Sig_inductive_typ? se.sigel) ses in - let is_injective_on_params = - match tycon with - | None -> - //Exceptions appear as Sig_bundle without an inductive type - false - | Some se -> - is_sig_inductive_injective_on_params env se - in let g, env = ses |> List.fold_left @@ -1777,9 +1684,9 @@ and encode_sigelt' (env:env_t) (se:sigelt) : (decls_t * env_t) = let g', env = match se.sigel with | Sig_inductive_typ _ -> - encode_sig_inductive is_injective_on_params env se + encode_sig_inductive env se | Sig_datacon _ -> - encode_datacon is_injective_on_params env se + encode_datacon env se | _ -> encode_sigelt env se in diff --git a/src/syntax/FStar.Syntax.MutRecTy.fst b/src/syntax/FStar.Syntax.MutRecTy.fst index ce8e61f5432..34e9c74ea70 100644 --- a/src/syntax/FStar.Syntax.MutRecTy.fst +++ b/src/syntax/FStar.Syntax.MutRecTy.fst @@ -193,7 +193,9 @@ let disentangle_abbrevs_from_bundle let unfold_in_sig (x: sigelt) = match x.sigel with | Sig_inductive_typ {lid; us=univs; params=bnd; - num_uniform_params=num_uniform; t=ty; mutuals=mut; ds=dc} -> + num_uniform_params=num_uniform; + t=ty; mutuals=mut; ds=dc; + injective_type_params } -> let bnd' = inst_binders unfold_fv bnd in let ty' = inst unfold_fv ty in let mut' = filter_out_type_abbrevs mut in @@ -203,9 +205,12 @@ let disentangle_abbrevs_from_bundle num_uniform_params=num_uniform; t=ty'; mutuals=mut'; - ds=dc} }] + ds=dc; + injective_type_params } }] - | Sig_datacon {lid; us=univs; t=ty; ty_lid=res; num_ty_params=npars; mutuals=mut} -> + | Sig_datacon {lid; us=univs; t=ty; ty_lid=res; + num_ty_params=npars; mutuals=mut; + injective_type_params } -> let ty' = inst unfold_fv ty in let mut' = filter_out_type_abbrevs mut in [{ x with sigel = Sig_datacon {lid; @@ -213,7 +218,8 @@ let disentangle_abbrevs_from_bundle t=ty'; ty_lid=res; num_ty_params=npars; - mutuals=mut'} }] + mutuals=mut'; + injective_type_params } }] | Sig_let _ -> [] diff --git a/src/syntax/FStar.Syntax.Syntax.fsti b/src/syntax/FStar.Syntax.Syntax.fsti index 0368a976caa..c9e8962fce2 100644 --- a/src/syntax/FStar.Syntax.Syntax.fsti +++ b/src/syntax/FStar.Syntax.Syntax.fsti @@ -656,6 +656,7 @@ type sigelt' = t:typ; //t mutuals:list lident; //mutually defined types ds:list lident; //data constructors for this type + injective_type_params:bool //is this type injective in its type parameters? } (* a datatype definition is a Sig_bundle of all mutually defined `Sig_inductive_typ`s and `Sig_datacon`s. perhaps it would be nicer to let this have a 2-level structure, e.g. list list sigelt, @@ -673,6 +674,7 @@ type sigelt' = ty_lid:lident; //the inductive type of the value this constructs num_ty_params:int; //and the number of parameters of the inductive mutuals:list lident; //mutually defined types + injective_type_params:bool //is this type injective in its type parameters? } | Sig_declare_typ { lid:lident; diff --git a/src/syntax/FStar.Syntax.VisitM.fst b/src/syntax/FStar.Syntax.VisitM.fst index 8af505aba0a..e55a731b2a9 100644 --- a/src/syntax/FStar.Syntax.VisitM.fst +++ b/src/syntax/FStar.Syntax.VisitM.fst @@ -377,18 +377,18 @@ let on_sub_action #m {|d : lvm m |} (a : action) : m action = let rec on_sub_sigelt' #m {|d : lvm m |} (se : sigelt') : m sigelt' = match se with - | Sig_inductive_typ {lid; us; params; num_uniform_params; t; mutuals; ds} -> + | Sig_inductive_typ {lid; us; params; num_uniform_params; t; mutuals; ds; injective_type_params } -> let! params = params |> mapM f_binder in let! t = t |> f_term in - return <| Sig_inductive_typ {lid; us; params; num_uniform_params; t; mutuals; ds} + return <| Sig_inductive_typ {lid; us; params; num_uniform_params; t; mutuals; ds; injective_type_params } | Sig_bundle {ses; lids} -> let! ses = ses |> mapM on_sub_sigelt in return <| Sig_bundle {ses; lids} - | Sig_datacon {lid; us; t; ty_lid; num_ty_params; mutuals} -> + | Sig_datacon {lid; us; t; ty_lid; num_ty_params; mutuals; injective_type_params } -> let! t = t |> f_term in - return <| Sig_datacon {lid; us; t; ty_lid; num_ty_params; mutuals} + return <| Sig_datacon {lid; us; t; ty_lid; num_ty_params; mutuals; injective_type_params } | Sig_declare_typ {lid; us; t} -> let! t = t |> f_term in diff --git a/src/tosyntax/FStar.ToSyntax.ToSyntax.fst b/src/tosyntax/FStar.ToSyntax.ToSyntax.fst index a2809bf79d9..c0f10927ecd 100644 --- a/src/tosyntax/FStar.ToSyntax.ToSyntax.fst +++ b/src/tosyntax/FStar.ToSyntax.ToSyntax.fst @@ -627,14 +627,16 @@ let rec generalize_annotated_univs (s:sigelt) :sigelt = num_uniform_params=num_uniform; t=Subst.subst (Subst.shift_subst (List.length bs) usubst) t; mutuals=lids1; - ds=lids2} } + ds=lids2; + injective_type_params=false} } | Sig_datacon {lid;t;ty_lid=tlid;num_ty_params=n;mutuals=lids} -> { se with sigel = Sig_datacon {lid; us=unames; t=Subst.subst usubst t; ty_lid=tlid; num_ty_params=n; - mutuals=lids} } + mutuals=lids; + injective_type_params=false} } | _ -> failwith "Impossible: collect_annotated_universes: Sig_bundle should not have a non data/type sigelt" ); lids} } | Sig_declare_typ {lid; t} -> @@ -3007,7 +3009,8 @@ let rec desugar_tycon env (d: AST.decl) (d_attrs:list S.term) quals tcs : (env_t num_uniform_params=None; t=k; mutuals; - ds=[]}; + ds=[]; + injective_type_params=false}; sigquals = quals; sigrng = range_of_id id; sigmeta = default_sigmeta; @@ -3148,7 +3151,8 @@ let rec desugar_tycon env (d: AST.decl) (d_attrs:list S.term) quals tcs : (env_t params=tpars; num_uniform_params=num_uniform; t=k; - mutuals}; sigquals = tname_quals }, + mutuals; + injective_type_params}; sigquals = tname_quals }, constrs, tconstr, quals) -> let mk_tot t = let tot = mk_term (Name C.effect_Tot_lid) t.range t.level in @@ -3177,7 +3181,8 @@ let rec desugar_tycon env (d: AST.decl) (d_attrs:list S.term) quals tcs : (env_t t=U.arrow data_tpars (mk_Total (t |> U.name_function_binders)); ty_lid=tname; num_ty_params=ntps; - mutuals}; + mutuals; + injective_type_params}; sigquals = quals; sigrng = range_of_lid name; sigmeta = default_sigmeta ; @@ -3199,7 +3204,8 @@ let rec desugar_tycon env (d: AST.decl) (d_attrs:list S.term) quals tcs : (env_t num_uniform_params=num_uniform; t=k; mutuals; - ds=constrNames}; + ds=constrNames; + injective_type_params}; sigquals = tname_quals; sigrng = range_of_lid tname; sigmeta = default_sigmeta ; @@ -4084,7 +4090,7 @@ and desugar_decl_core env (d_attrs:list S.term) (d:decl) : (env_t * sigelts) = let l = qualify env id in let qual = [ExceptionConstructor] in let top_attrs = d_attrs in - let se = { sigel = Sig_datacon {lid=l;us=[];t;ty_lid=C.exn_lid;num_ty_params=0;mutuals=[C.exn_lid]}; + let se = { sigel = Sig_datacon {lid=l;us=[];t;ty_lid=C.exn_lid;num_ty_params=0;mutuals=[C.exn_lid];injective_type_params=false}; sigquals = qual; sigrng = d.drange; sigmeta = default_sigmeta ; diff --git a/src/typechecker/FStar.TypeChecker.Cfg.fst b/src/typechecker/FStar.TypeChecker.Cfg.fst index 39430271921..d7434cce192 100644 --- a/src/typechecker/FStar.TypeChecker.Cfg.fst +++ b/src/typechecker/FStar.TypeChecker.Cfg.fst @@ -374,7 +374,7 @@ let config' psteps s e = | [] -> [Env.NoDelta] | _ -> d in let steps = to_fsteps s |> add_nbe in - let psteps = add_steps (merge_steps (cached_steps ()) (env_dependent_ops e))psteps in + let psteps = add_steps (merge_steps (env_dependent_ops e) (cached_steps ())) psteps in let dbg_flag = List.contains NormDebug s in {tcenv = e; debug = if dbg_flag || Options.debug_any () then diff --git a/src/typechecker/FStar.TypeChecker.Env.fst b/src/typechecker/FStar.TypeChecker.Env.fst index 6ce5c890c6c..a8517d75a5b 100644 --- a/src/typechecker/FStar.TypeChecker.Env.fst +++ b/src/typechecker/FStar.TypeChecker.Env.fst @@ -745,9 +745,10 @@ let typ_of_datacon env lid = | Some (Inr ({ sigel = Sig_datacon {ty_lid=l} }, _), _) -> l | _ -> failwith (BU.format1 "Not a datacon: %s" (Print.lid_to_string lid)) -let num_datacon_ty_params env lid = +let num_datacon_non_injective_ty_params env lid = match lookup_qname env lid with - | Some (Inr ({ sigel = Sig_datacon {num_ty_params} }, _), _) -> Some num_ty_params + | Some (Inr ({ sigel = Sig_datacon {num_ty_params; injective_type_params} }, _), _) -> + if injective_type_params then Some 0 else Some num_ty_params | _ -> None let lookup_definition_qninfo_aux rec_ok delta_levels lid (qninfo : qninfo) = diff --git a/src/typechecker/FStar.TypeChecker.Env.fsti b/src/typechecker/FStar.TypeChecker.Env.fsti index f3d76452836..fbf71f6c396 100644 --- a/src/typechecker/FStar.TypeChecker.Env.fsti +++ b/src/typechecker/FStar.TypeChecker.Env.fsti @@ -344,7 +344,7 @@ val is_irreducible : env -> lident -> bool val is_type_constructor : env -> lident -> bool val num_inductive_ty_params: env -> lident -> option int val num_inductive_uniform_ty_params: env -> lident -> option int -val num_datacon_ty_params : env -> lident -> option int +val num_datacon_non_injective_ty_params : env -> lident -> option int val delta_depth_of_qninfo : fv -> qninfo -> option delta_depth val delta_depth_of_fv : env -> fv -> delta_depth diff --git a/src/typechecker/FStar.TypeChecker.NBETerm.fst b/src/typechecker/FStar.TypeChecker.NBETerm.fst index 37fbb5a94a0..8a0d40ea096 100644 --- a/src/typechecker/FStar.TypeChecker.NBETerm.fst +++ b/src/typechecker/FStar.TypeChecker.NBETerm.fst @@ -123,7 +123,7 @@ let rec eq_t env (t1 : t) (t2 : t) : TEQ.eq_result = if S.fv_eq v1 v2 then begin if List.length args1 <> List.length args2 then failwith "eq_t, different number of args on Construct"; - match Env.num_datacon_ty_params env (lid_of_fv v1) with + match Env.num_datacon_non_injective_ty_params env (lid_of_fv v1) with | None -> TEQ.Unknown | Some n -> if n <= List.length args1 diff --git a/src/typechecker/FStar.TypeChecker.Normalize.fst b/src/typechecker/FStar.TypeChecker.Normalize.fst index 44d3c5d5070..6e5385f78e8 100644 --- a/src/typechecker/FStar.TypeChecker.Normalize.fst +++ b/src/typechecker/FStar.TypeChecker.Normalize.fst @@ -3290,7 +3290,8 @@ let rec elim_uvars (env:Env.env) (s:sigelt) = num_uniform_params=num_uniform; t=typ; mutuals=lids; - ds=lids'} -> + ds=lids'; + injective_type_params} -> let univ_names, binders, typ = elim_uvars_aux_t env univ_names binders typ in {s with sigel = Sig_inductive_typ {lid; us=univ_names; @@ -3298,19 +3299,21 @@ let rec elim_uvars (env:Env.env) (s:sigelt) = num_uniform_params=num_uniform; t=typ; mutuals=lids; - ds=lids'}} + ds=lids'; + injective_type_params}} | Sig_bundle {ses=sigs; lids} -> {s with sigel = Sig_bundle {ses=List.map (elim_uvars env) sigs; lids}} - | Sig_datacon {lid; us=univ_names; t=typ; ty_lid=lident; num_ty_params=i; mutuals=lids} -> + | Sig_datacon {lid; us=univ_names; t=typ; ty_lid=lident; num_ty_params=i; mutuals=lids; injective_type_params} -> let univ_names, _, typ = elim_uvars_aux_t env univ_names [] typ in {s with sigel = Sig_datacon {lid; us=univ_names; t=typ; ty_lid=lident; num_ty_params=i; - mutuals=lids}} + mutuals=lids; + injective_type_params}} | Sig_declare_typ {lid; us=univ_names; t=typ} -> let univ_names, _, typ = elim_uvars_aux_t env univ_names [] typ in diff --git a/src/typechecker/FStar.TypeChecker.Positivity.fst b/src/typechecker/FStar.TypeChecker.Positivity.fst index 5db4276ffee..9bc9817e720 100644 --- a/src/typechecker/FStar.TypeChecker.Positivity.fst +++ b/src/typechecker/FStar.TypeChecker.Positivity.fst @@ -366,7 +366,7 @@ let mark_uniform_type_parameters (env:env_t) (sig:sigelt) : sigelt = let mark_tycon_parameters tc datas = - let Sig_inductive_typ {lid=tc_lid; us; params=ty_param_binders; t; mutuals; ds=data_lids} = tc.sigel in + let Sig_inductive_typ {lid=tc_lid; us; params=ty_param_binders; t; mutuals; ds=data_lids; injective_type_params } = tc.sigel in let env, (tc_lid, us, ty_params) = open_sig_inductive_typ env tc in let _, ty_param_args = U.args_of_binders ty_params in let datacon_fields : list (list binder) = @@ -418,7 +418,8 @@ let mark_uniform_type_parameters (env:env_t) num_uniform_params=Some max_uniform_prefix; t; mutuals; - ds=data_lids} in + ds=data_lids; + injective_type_params} in { tc with sigel } in match sig.sigel with diff --git a/src/typechecker/FStar.TypeChecker.TcInductive.fst b/src/typechecker/FStar.TypeChecker.TcInductive.fst index f4c6c9baffe..7c5aa867cd0 100644 --- a/src/typechecker/FStar.TypeChecker.TcInductive.fst +++ b/src/typechecker/FStar.TypeChecker.TcInductive.fst @@ -46,6 +46,90 @@ module C = FStar.Parser.Const let unfold_whnf = N.unfold_whnf' [Env.AllowUnboundUniverses] +let check_sig_inductive_injectivity_on_params (tcenv:env_t) (se:sigelt) + : sigelt + = let Sig_inductive_typ dd = se.sigel in + let { lid=t; us=universe_names; params=tps; t=k } = dd in + let t_lid = t in + let usubst, uvs = SS.univ_var_opening universe_names in + let tcenv, tps, k = + Env.push_univ_vars tcenv uvs, + SS.subst_binders usubst tps, + SS.subst (SS.shift_subst (List.length tps) usubst) k + in + let tps, k = SS.open_term tps k in + let _, k = U.arrow_formals k in //don't care about indices here + let tps, env_tps, _, us = TcTerm.tc_binders tcenv tps in + let u_k = + TcTerm.level_of_type + env_tps + (S.mk_Tm_app + (S.fvar t None) + (snd (U.args_of_binders tps)) + (Ident.range_of_lid t)) + k + in + //BU.print2 "Universe of tycon: %s : %s\n" (Ident.string_of_lid t) (Print.univ_to_string u_k); + let rec universe_leq u v = + match u, v with + | U_zero, _ -> true + | U_succ u0, U_succ v0 -> universe_leq u0 v0 + | U_name u0, U_name v0 -> Ident.ident_equals u0 v0 + | U_name _, U_succ v0 -> universe_leq u v0 + | U_max us, _ -> us |> BU.for_all (fun u -> universe_leq u v) + | _, U_max vs -> vs |> BU.for_some (universe_leq u) + | U_unknown, _ + | _, U_unknown + | U_unif _, _ + | _, U_unif _ -> failwith (BU.format3 "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + (Ident.string_of_lid t) + (Print.univ_to_string u) + (Print.univ_to_string v)) + | _ -> false + in + let u_leq_u_k u = + let u = N.normalize_universe env_tps u in + universe_leq u u_k + in + let tp_ok (tp:S.binder) (u_tp:universe) = + let t_tp = tp.binder_bv.sort in + if u_leq_u_k u_tp + then true + else ( + let t_tp = + N.normalize + [Unrefine; Unascribe; Unmeta; + Primops; HNF; UnfoldUntil delta_constant; Beta] + env_tps t_tp + in + let formals, t = U.arrow_formals t_tp in + let _, _, _, u_formals = TcTerm.tc_binders env_tps formals in + let inj = BU.for_all (fun u_formal -> u_leq_u_k u_formal) u_formals in + if inj + then ( + match (SS.compress t).n with + | Tm_type u -> + (* retain injectivity for parameters that are type functions + from small universes (i.e., all formals are smaller than the constructed type) + to a universe <= the universe of the constructed type. + See BugBoxInjectivity.fst *) + u_leq_u_k u + | _ -> + false + ) + else ( + false + ) + + ) + in + let injective_type_params = List.forall2 tp_ok tps us in + if Env.debug tcenv <| Options.Other "TcInductive" + then BU.print2 "%s injectivity for %s\n" + (if injective_type_params then "YES" else "NO") + (Ident.string_of_lid t); + { se with sigel = Sig_inductive_typ { dd with injective_type_params } } + let tc_tycon (env:env_t) (* environment that contains all mutually defined type constructors *) (s:sigelt) (* a Sig_inductive_type (aka tc) that needs to be type-checked *) : env_t (* environment extended with a refined type for the type-constructor *) @@ -104,7 +188,8 @@ let tc_tycon (env:env_t) (* environment that contains all mutually defined t num_uniform_params=n_uniform; t=k; mutuals; - ds=data} }, + ds=data; + injective_type_params=false} }, u, guard @@ -235,7 +320,8 @@ let tc_data (env:env_t) (tcs : list (sigelt * universe)) t; ty_lid=tc_lid; num_ty_params=ntps; - mutuals=mutual_tcs} }, + mutuals=mutual_tcs; + injective_type_params=false} }, g | _ -> failwith "impossible" @@ -290,7 +376,8 @@ let generalize_and_inst_within (env:env_t) (tcs:list (sigelt * universe)) (datas num_uniform_params=num_uniform; t; mutuals; - ds=datas} } + ds=datas; + injective_type_params=false} } | _ -> failwith "Impossible") tc_types tcs in @@ -310,7 +397,8 @@ let generalize_and_inst_within (env:env_t) (tcs:list (sigelt * universe)) (datas t=ty; ty_lid=tc; num_ty_params=ntps; - mutuals} } + mutuals; + injective_type_params=false} } | _ -> failwith "Impossible") data_types datas in @@ -857,13 +945,33 @@ let check_inductive_well_typedness (env:env_t) (ses:list sigelt) (quals:list qua num_uniform_params=num_uniform; t=typ; mutuals=ts; - ds}} + ds; + injective_type_params=false}} end else fail expected_typ inferred_typ else fail expected_typ (inferred_typ_with_binders binders) end | _ -> se) in + let tcs = tcs |> List.map (check_sig_inductive_injectivity_on_params env) in + let is_injective l = + match + List.tryPick + (fun se -> + let Sig_inductive_typ {lid=lid; injective_type_params} = se.sigel in + if lid_equals l lid then Some injective_type_params else None) + tcs + with + | None -> false + | Some i -> i + in + let datas = + datas |> + List.map + (fun se -> + let Sig_datacon dd = se.sigel in + { se with sigel=Sig_datacon { dd with injective_type_params=is_injective dd.ty_lid }}) + in let sig_bndle = { sigel = Sig_bundle {ses=tcs@datas; lids}; sigquals = quals; sigrng = Env.get_range env0; diff --git a/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst b/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst index 4b2af53498d..e7d5ae2cc4f 100644 --- a/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst +++ b/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst @@ -125,7 +125,8 @@ let rec eq_tm (env:env_t) (t1:term) (t2:term) : eq_result = | Tm_fvar f, Tm_fvar g when qual_is_inj f.fv_qual && qual_is_inj g.fv_qual -> ( - match Env.num_datacon_ty_params env (lid_of_fv f), Env.num_datacon_ty_params env (lid_of_fv g) with + match Env.num_datacon_non_injective_ty_params env (lid_of_fv f), + Env.num_datacon_non_injective_ty_params env (lid_of_fv g) with | Some n1, Some n2 -> if n1 <= List.length args1 && n2 <= List.length args2 diff --git a/tests/bug-reports/BugBoxInjectivity.fst b/tests/bug-reports/BugBoxInjectivity.fst index 506ab6f0633..11639740730 100644 --- a/tests/bug-reports/BugBoxInjectivity.fst +++ b/tests/bug-reports/BugBoxInjectivity.fst @@ -78,3 +78,52 @@ let bad (h0:ceq true true) (h1:ceq false false) : Lemma (true == false) = let Refl = h0 in let Refl = h1 in () + +//Another test case, to make sure that the normalizer doesn't enforce injectivity of +//type parameter arguments of a data constructor + +module T = FStar.Tactics +type idx : Type u#2 = | A1 | A2 + +noeq +type test3 (a:idx) : Type u#1 = + | Mk3 : test3 a + +let case0 (x0 : test3 A1) (x1 : test3 A2) : Lemma False = + assume (test3 A1 == test3 A2); + assume (~ (Mk3 #A1 == coerce_eq () (Mk3 #A2))) + +[@@expect_failure] +let case1 (x0 : test3 A1) (x1 : test3 A2) : Lemma False = + assume (test3 A1 == test3 A2); + assert (~ (Mk3 #A1 == coerce_eq () (Mk3 #A2))) + by (T.norm [delta;primops]; + T.trefl ()) + +[@@expect_failure] +let case2 (x0 : test3 A1) (x1 : test3 A2) : Lemma False = + assume (test3 A1 == test3 A2); + assert (~ (Mk3 #A1 == coerce_eq () (Mk3 #A2))) + by (T.norm [delta;primops;nbe]; + T.trefl ()) + + +[@@expect_failure] +let case4 (x0 : test3 A1) (x1 : test3 A2) : Lemma (test3 A1 == test3 A2 ==> Mk3 #A1 == coerce_eq () (Mk3 #A2)) = + assume (test3 A1 == test3 A2); + assert (Mk3 #A1 == coerce_eq () (Mk3 #A2)) + by (T.norm [delta;primops]; + T.trivial()) //this can't be proven by the normalizer alone + +[@@expect_failure] +let case5 (x0 : test3 A1) (x1 : test3 A2) : Lemma (test3 A1 == test3 A2 ==> Mk3 #A1 == coerce_eq () (Mk3 #A2)) = + assume (test3 A1 == test3 A2); + assert (Mk3 #A1 == coerce_eq () (Mk3 #A2)) + by (T.norm [delta;primops;nbe]; + T.trivial()) //this can't be proven by the normalizer alone; nor by nbe + +let case6 (x0 : test3 A1) (x1 : test3 A2) : Lemma (test3 A1 == test3 A2 ==> Mk3 #A1 == coerce_eq () (Mk3 #A2)) = + assume (test3 A1 == test3 A2); + assert (Mk3 #A1 == coerce_eq () (Mk3 #A2)) + by (T.norm [delta;primops]; + T.smt()) //but it can by SMT, since the parameters are irrelevant diff --git a/ulib/prims.fst b/ulib/prims.fst index 395ff6206c5..18130765343 100644 --- a/ulib/prims.fst +++ b/ulib/prims.fst @@ -708,4 +708,4 @@ val string_of_int: int -> Tot string (** THIS IS MEANT TO BE KEPT IN SYNC WITH FStar.CheckedFiles.fs Incrementing this forces all .checked files to be invalidated *) irreducible -let __cache_version_number__ = 66 +let __cache_version_number__ = 67 From 42bba1e4e2d0037ec53d7d48543eda4740465502 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Fri, 26 Apr 2024 18:05:48 -0700 Subject: [PATCH 36/42] compute injective_type_params flag in phase2 only --- .../FStar_TypeChecker_TcInductive.ml | 534 +++++++++--------- .../FStar.TypeChecker.TcInductive.fst | 5 +- 2 files changed, 279 insertions(+), 260 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcInductive.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcInductive.ml index ce84b3f0f05..7a9d938610d 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcInductive.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcInductive.ml @@ -11,264 +11,282 @@ let (check_sig_inductive_injectivity_on_params : = fun tcenv -> fun se -> - let uu___ = se.FStar_Syntax_Syntax.sigel in - match uu___ with - | FStar_Syntax_Syntax.Sig_inductive_typ dd -> - let uu___1 = dd in - (match uu___1 with - | { FStar_Syntax_Syntax.lid = t; - FStar_Syntax_Syntax.us = universe_names; - FStar_Syntax_Syntax.params = tps; - FStar_Syntax_Syntax.num_uniform_params = uu___2; - FStar_Syntax_Syntax.t = k; - FStar_Syntax_Syntax.mutuals = uu___3; - FStar_Syntax_Syntax.ds = uu___4; - FStar_Syntax_Syntax.injective_type_params = uu___5;_} -> - let t_lid = t in - let uu___6 = - FStar_Syntax_Subst.univ_var_opening universe_names in - (match uu___6 with - | (usubst, uvs) -> - let uu___7 = - let uu___8 = - FStar_TypeChecker_Env.push_univ_vars tcenv uvs in - let uu___9 = - FStar_Syntax_Subst.subst_binders usubst tps in - let uu___10 = - let uu___11 = - FStar_Syntax_Subst.shift_subst - (FStar_Compiler_List.length tps) usubst in - FStar_Syntax_Subst.subst uu___11 k in - (uu___8, uu___9, uu___10) in - (match uu___7 with - | (tcenv1, tps1, k1) -> - let uu___8 = FStar_Syntax_Subst.open_term tps1 k1 in - (match uu___8 with - | (tps2, k2) -> - let uu___9 = FStar_Syntax_Util.arrow_formals k2 in - (match uu___9 with - | (uu___10, k3) -> - let uu___11 = - FStar_TypeChecker_TcTerm.tc_binders - tcenv1 tps2 in - (match uu___11 with - | (tps3, env_tps, uu___12, us) -> - let u_k = - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.fvar t - FStar_Pervasives_Native.None in - let uu___15 = - let uu___16 = - FStar_Syntax_Util.args_of_binders - tps3 in - FStar_Pervasives_Native.snd - uu___16 in - let uu___16 = - FStar_Ident.range_of_lid t in - FStar_Syntax_Syntax.mk_Tm_app - uu___14 uu___15 uu___16 in - FStar_TypeChecker_TcTerm.level_of_type - env_tps uu___13 k3 in - let rec universe_leq u v = - match (u, v) with - | (FStar_Syntax_Syntax.U_zero, - uu___13) -> true - | (FStar_Syntax_Syntax.U_succ u0, - FStar_Syntax_Syntax.U_succ v0) - -> universe_leq u0 v0 - | (FStar_Syntax_Syntax.U_name u0, - FStar_Syntax_Syntax.U_name v0) - -> - FStar_Ident.ident_equals u0 v0 - | (FStar_Syntax_Syntax.U_name - uu___13, - FStar_Syntax_Syntax.U_succ v0) - -> universe_leq u v0 - | (FStar_Syntax_Syntax.U_max us1, - uu___13) -> - FStar_Compiler_Util.for_all - (fun u1 -> universe_leq u1 v) - us1 - | (uu___13, - FStar_Syntax_Syntax.U_max vs) -> - FStar_Compiler_Util.for_some - (universe_leq u) vs - | (FStar_Syntax_Syntax.U_unknown, - uu___13) -> - let uu___14 = - let uu___15 = - FStar_Ident.string_of_lid t in - let uu___16 = - FStar_Syntax_Print.univ_to_string - u in - let uu___17 = - FStar_Syntax_Print.univ_to_string - v in - FStar_Compiler_Util.format3 - "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" - uu___15 uu___16 uu___17 in - FStar_Compiler_Effect.failwith - uu___14 - | (uu___13, - FStar_Syntax_Syntax.U_unknown) - -> - let uu___14 = - let uu___15 = - FStar_Ident.string_of_lid t in - let uu___16 = - FStar_Syntax_Print.univ_to_string - u in - let uu___17 = - FStar_Syntax_Print.univ_to_string - v in - FStar_Compiler_Util.format3 - "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" - uu___15 uu___16 uu___17 in - FStar_Compiler_Effect.failwith - uu___14 - | (FStar_Syntax_Syntax.U_unif - uu___13, uu___14) -> - let uu___15 = - let uu___16 = - FStar_Ident.string_of_lid t in - let uu___17 = - FStar_Syntax_Print.univ_to_string - u in - let uu___18 = - FStar_Syntax_Print.univ_to_string - v in - FStar_Compiler_Util.format3 - "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" - uu___16 uu___17 uu___18 in - FStar_Compiler_Effect.failwith - uu___15 - | (uu___13, - FStar_Syntax_Syntax.U_unif - uu___14) -> - let uu___15 = - let uu___16 = - FStar_Ident.string_of_lid t in - let uu___17 = - FStar_Syntax_Print.univ_to_string - u in - let uu___18 = - FStar_Syntax_Print.univ_to_string - v in - FStar_Compiler_Util.format3 - "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" - uu___16 uu___17 uu___18 in - FStar_Compiler_Effect.failwith - uu___15 - | uu___13 -> false in - let u_leq_u_k u = - let u1 = - FStar_TypeChecker_Normalize.normalize_universe - env_tps u in - universe_leq u1 u_k in - let tp_ok tp u_tp = - let t_tp = - (tp.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let uu___13 = u_leq_u_k u_tp in - if uu___13 - then true - else - (let t_tp1 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Unrefine; - FStar_TypeChecker_Env.Unascribe; - FStar_TypeChecker_Env.Unmeta; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Beta] - env_tps t_tp in - let uu___15 = - FStar_Syntax_Util.arrow_formals - t_tp1 in - match uu___15 with - | (formals, t1) -> + if tcenv.FStar_TypeChecker_Env.phase1 + then se + else + (let uu___1 = se.FStar_Syntax_Syntax.sigel in + match uu___1 with + | FStar_Syntax_Syntax.Sig_inductive_typ dd -> + let uu___2 = dd in + (match uu___2 with + | { FStar_Syntax_Syntax.lid = t; + FStar_Syntax_Syntax.us = universe_names; + FStar_Syntax_Syntax.params = tps; + FStar_Syntax_Syntax.num_uniform_params = uu___3; + FStar_Syntax_Syntax.t = k; + FStar_Syntax_Syntax.mutuals = uu___4; + FStar_Syntax_Syntax.ds = uu___5; + FStar_Syntax_Syntax.injective_type_params = uu___6;_} -> + let t_lid = t in + let uu___7 = + FStar_Syntax_Subst.univ_var_opening universe_names in + (match uu___7 with + | (usubst, uvs) -> + let uu___8 = + let uu___9 = + FStar_TypeChecker_Env.push_univ_vars tcenv uvs in + let uu___10 = + FStar_Syntax_Subst.subst_binders usubst tps in + let uu___11 = + let uu___12 = + FStar_Syntax_Subst.shift_subst + (FStar_Compiler_List.length tps) usubst in + FStar_Syntax_Subst.subst uu___12 k in + (uu___9, uu___10, uu___11) in + (match uu___8 with + | (tcenv1, tps1, k1) -> + let uu___9 = FStar_Syntax_Subst.open_term tps1 k1 in + (match uu___9 with + | (tps2, k2) -> + let uu___10 = + FStar_Syntax_Util.arrow_formals k2 in + (match uu___10 with + | (uu___11, k3) -> + let uu___12 = + FStar_TypeChecker_TcTerm.tc_binders + tcenv1 tps2 in + (match uu___12 with + | (tps3, env_tps, uu___13, us) -> + let u_k = + let uu___14 = + let uu___15 = + FStar_Syntax_Syntax.fvar t + FStar_Pervasives_Native.None in + let uu___16 = + let uu___17 = + FStar_Syntax_Util.args_of_binders + tps3 in + FStar_Pervasives_Native.snd + uu___17 in + let uu___17 = + FStar_Ident.range_of_lid t in + FStar_Syntax_Syntax.mk_Tm_app + uu___15 uu___16 uu___17 in + FStar_TypeChecker_TcTerm.level_of_type + env_tps uu___14 k3 in + let rec universe_leq u v = + match (u, v) with + | (FStar_Syntax_Syntax.U_zero, + uu___14) -> true + | (FStar_Syntax_Syntax.U_succ + u0, + FStar_Syntax_Syntax.U_succ + v0) -> universe_leq u0 v0 + | (FStar_Syntax_Syntax.U_name + u0, + FStar_Syntax_Syntax.U_name + v0) -> + FStar_Ident.ident_equals u0 + v0 + | (FStar_Syntax_Syntax.U_name + uu___14, + FStar_Syntax_Syntax.U_succ + v0) -> universe_leq u v0 + | (FStar_Syntax_Syntax.U_max + us1, uu___14) -> + FStar_Compiler_Util.for_all + (fun u1 -> + universe_leq u1 v) us1 + | (uu___14, + FStar_Syntax_Syntax.U_max vs) + -> + FStar_Compiler_Util.for_some + (universe_leq u) vs + | (FStar_Syntax_Syntax.U_unknown, + uu___14) -> + let uu___15 = + let uu___16 = + FStar_Ident.string_of_lid + t in + let uu___17 = + FStar_Syntax_Print.univ_to_string + u in + let uu___18 = + FStar_Syntax_Print.univ_to_string + v in + FStar_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___16 uu___17 uu___18 in + FStar_Compiler_Effect.failwith + uu___15 + | (uu___14, + FStar_Syntax_Syntax.U_unknown) + -> + let uu___15 = + let uu___16 = + FStar_Ident.string_of_lid + t in + let uu___17 = + FStar_Syntax_Print.univ_to_string + u in + let uu___18 = + FStar_Syntax_Print.univ_to_string + v in + FStar_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___16 uu___17 uu___18 in + FStar_Compiler_Effect.failwith + uu___15 + | (FStar_Syntax_Syntax.U_unif + uu___14, uu___15) -> let uu___16 = - FStar_TypeChecker_TcTerm.tc_binders - env_tps formals in - (match uu___16 with - | (uu___17, uu___18, - uu___19, u_formals) -> - let inj = - FStar_Compiler_Util.for_all - (fun u_formal -> - u_leq_u_k - u_formal) - u_formals in - if inj - then - let uu___20 = - let uu___21 = - FStar_Syntax_Subst.compress - t1 in - uu___21.FStar_Syntax_Syntax.n in - (match uu___20 with - | FStar_Syntax_Syntax.Tm_type - u -> u_leq_u_k u - | uu___21 -> false) - else false)) in - let injective_type_params = - FStar_Compiler_List.forall2 tp_ok - tps3 us in - ((let uu___14 = - FStar_TypeChecker_Env.debug - tcenv1 - (FStar_Options.Other - "TcInductive") in - if uu___14 - then - let uu___15 = - FStar_Ident.string_of_lid t in - FStar_Compiler_Util.print2 - "%s injectivity for %s\n" - (if injective_type_params - then "YES" - else "NO") uu___15 - else ()); - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_inductive_typ - { - FStar_Syntax_Syntax.lid = - (dd.FStar_Syntax_Syntax.lid); - FStar_Syntax_Syntax.us = - (dd.FStar_Syntax_Syntax.us); - FStar_Syntax_Syntax.params - = - (dd.FStar_Syntax_Syntax.params); - FStar_Syntax_Syntax.num_uniform_params - = - (dd.FStar_Syntax_Syntax.num_uniform_params); - FStar_Syntax_Syntax.t = - (dd.FStar_Syntax_Syntax.t); - FStar_Syntax_Syntax.mutuals - = - (dd.FStar_Syntax_Syntax.mutuals); - FStar_Syntax_Syntax.ds = - (dd.FStar_Syntax_Syntax.ds); - FStar_Syntax_Syntax.injective_type_params - = injective_type_params - }); - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - }))))))) + let uu___17 = + FStar_Ident.string_of_lid + t in + let uu___18 = + FStar_Syntax_Print.univ_to_string + u in + let uu___19 = + FStar_Syntax_Print.univ_to_string + v in + FStar_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___17 uu___18 uu___19 in + FStar_Compiler_Effect.failwith + uu___16 + | (uu___14, + FStar_Syntax_Syntax.U_unif + uu___15) -> + let uu___16 = + let uu___17 = + FStar_Ident.string_of_lid + t in + let uu___18 = + FStar_Syntax_Print.univ_to_string + u in + let uu___19 = + FStar_Syntax_Print.univ_to_string + v in + FStar_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___17 uu___18 uu___19 in + FStar_Compiler_Effect.failwith + uu___16 + | uu___14 -> false in + let u_leq_u_k u = + let u1 = + FStar_TypeChecker_Normalize.normalize_universe + env_tps u in + universe_leq u1 u_k in + let tp_ok tp u_tp = + let t_tp = + (tp.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in + let uu___14 = u_leq_u_k u_tp in + if uu___14 + then true + else + (let t_tp1 = + FStar_TypeChecker_Normalize.normalize + [FStar_TypeChecker_Env.Unrefine; + FStar_TypeChecker_Env.Unascribe; + FStar_TypeChecker_Env.Unmeta; + FStar_TypeChecker_Env.Primops; + FStar_TypeChecker_Env.HNF; + FStar_TypeChecker_Env.UnfoldUntil + FStar_Syntax_Syntax.delta_constant; + FStar_TypeChecker_Env.Beta] + env_tps t_tp in + let uu___16 = + FStar_Syntax_Util.arrow_formals + t_tp1 in + match uu___16 with + | (formals, t1) -> + let uu___17 = + FStar_TypeChecker_TcTerm.tc_binders + env_tps formals in + (match uu___17 with + | (uu___18, uu___19, + uu___20, u_formals) + -> + let inj = + FStar_Compiler_Util.for_all + (fun u_formal -> + u_leq_u_k + u_formal) + u_formals in + if inj + then + let uu___21 = + let uu___22 = + FStar_Syntax_Subst.compress + t1 in + uu___22.FStar_Syntax_Syntax.n in + (match uu___21 + with + | FStar_Syntax_Syntax.Tm_type + u -> + u_leq_u_k u + | uu___22 -> + false) + else false)) in + let injective_type_params = + FStar_Compiler_List.forall2 + tp_ok tps3 us in + ((let uu___15 = + FStar_TypeChecker_Env.debug + tcenv1 + (FStar_Options.Other + "TcInductive") in + if uu___15 + then + let uu___16 = + FStar_Ident.string_of_lid t in + FStar_Compiler_Util.print2 + "%s injectivity for %s\n" + (if injective_type_params + then "YES" + else "NO") uu___16 + else ()); + { + FStar_Syntax_Syntax.sigel = + (FStar_Syntax_Syntax.Sig_inductive_typ + { + FStar_Syntax_Syntax.lid + = + (dd.FStar_Syntax_Syntax.lid); + FStar_Syntax_Syntax.us = + (dd.FStar_Syntax_Syntax.us); + FStar_Syntax_Syntax.params + = + (dd.FStar_Syntax_Syntax.params); + FStar_Syntax_Syntax.num_uniform_params + = + (dd.FStar_Syntax_Syntax.num_uniform_params); + FStar_Syntax_Syntax.t = + (dd.FStar_Syntax_Syntax.t); + FStar_Syntax_Syntax.mutuals + = + (dd.FStar_Syntax_Syntax.mutuals); + FStar_Syntax_Syntax.ds = + (dd.FStar_Syntax_Syntax.ds); + FStar_Syntax_Syntax.injective_type_params + = + injective_type_params + }); + FStar_Syntax_Syntax.sigrng = + (se.FStar_Syntax_Syntax.sigrng); + FStar_Syntax_Syntax.sigquals = + (se.FStar_Syntax_Syntax.sigquals); + FStar_Syntax_Syntax.sigmeta = + (se.FStar_Syntax_Syntax.sigmeta); + FStar_Syntax_Syntax.sigattrs = + (se.FStar_Syntax_Syntax.sigattrs); + FStar_Syntax_Syntax.sigopens_and_abbrevs + = + (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); + FStar_Syntax_Syntax.sigopts = + (se.FStar_Syntax_Syntax.sigopts) + })))))))) let (tc_tycon : FStar_TypeChecker_Env.env_t -> FStar_Syntax_Syntax.sigelt -> @@ -2570,7 +2588,7 @@ let (check_inductive_well_typedness : let tcs3 = FStar_Compiler_List.map (check_sig_inductive_injectivity_on_params - env1) tcs2 in + env0) tcs2 in let is_injective l = let uu___5 = FStar_Compiler_List.tryPick diff --git a/src/typechecker/FStar.TypeChecker.TcInductive.fst b/src/typechecker/FStar.TypeChecker.TcInductive.fst index 7c5aa867cd0..c88d3fad391 100644 --- a/src/typechecker/FStar.TypeChecker.TcInductive.fst +++ b/src/typechecker/FStar.TypeChecker.TcInductive.fst @@ -48,7 +48,8 @@ let unfold_whnf = N.unfold_whnf' [Env.AllowUnboundUniverses] let check_sig_inductive_injectivity_on_params (tcenv:env_t) (se:sigelt) : sigelt - = let Sig_inductive_typ dd = se.sigel in + = if tcenv.phase1 then se else + let Sig_inductive_typ dd = se.sigel in let { lid=t; us=universe_names; params=tps; t=k } = dd in let t_lid = t in let usubst, uvs = SS.univ_var_opening universe_names in @@ -953,7 +954,7 @@ let check_inductive_well_typedness (env:env_t) (ses:list sigelt) (quals:list qua end | _ -> se) in - let tcs = tcs |> List.map (check_sig_inductive_injectivity_on_params env) in + let tcs = tcs |> List.map (check_sig_inductive_injectivity_on_params env0) in let is_injective l = match List.tryPick From bcbff7cdffae2030d64279d25ff895052a4ab1fb Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Fri, 26 Apr 2024 18:16:33 -0700 Subject: [PATCH 37/42] snap --- .../fstar-lib/generated/FStar_Syntax_DsEnv.ml | 202 +-- .../generated/FStar_Syntax_Resugar.ml | 136 +- .../generated/FStar_Syntax_Syntax.ml | 59 +- .../fstar-lib/generated/FStar_Syntax_Util.ml | 548 ++------ .../generated/FStar_Tactics_Hooks.ml | 7 +- .../generated/FStar_ToSyntax_ToSyntax.ml | 259 ++-- .../generated/FStar_TypeChecker_Common.ml | 887 ------------- .../generated/FStar_TypeChecker_Core.ml | 10 +- .../generated/FStar_TypeChecker_DMFF.ml | 2 +- .../FStar_TypeChecker_DeferredImplicits.ml | 13 +- .../generated/FStar_TypeChecker_Env.ml | 256 ++-- .../generated/FStar_TypeChecker_Normalize.ml | 51 +- .../generated/FStar_TypeChecker_Rel.ml | 254 ++-- .../FStar_TypeChecker_TcInductive.ml | 1101 +++++++++++------ .../generated/FStar_TypeChecker_TcTerm.ml | 21 +- 15 files changed, 1601 insertions(+), 2205 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_DsEnv.ml b/ocaml/fstar-lib/generated/FStar_Syntax_DsEnv.ml index fde5d3782c3..4ac38fc8917 100644 --- a/ocaml/fstar-lib/generated/FStar_Syntax_DsEnv.ml +++ b/ocaml/fstar-lib/generated/FStar_Syntax_DsEnv.ml @@ -1176,16 +1176,17 @@ let (fv_qual_of_se : { FStar_Syntax_Syntax.lid1 = uu___; FStar_Syntax_Syntax.us1 = uu___1; FStar_Syntax_Syntax.t1 = uu___2; FStar_Syntax_Syntax.ty_lid = l; FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4;_} + FStar_Syntax_Syntax.mutuals1 = uu___4; + FStar_Syntax_Syntax.injective_type_params1 = uu___5;_} -> let qopt = FStar_Compiler_Util.find_map se.FStar_Syntax_Syntax.sigquals - (fun uu___5 -> - match uu___5 with - | FStar_Syntax_Syntax.RecordConstructor (uu___6, fs) -> + (fun uu___6 -> + match uu___6 with + | FStar_Syntax_Syntax.RecordConstructor (uu___7, fs) -> FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Record_ctor (l, fs)) - | uu___6 -> FStar_Pervasives_Native.None) in + | uu___7 -> FStar_Pervasives_Native.None) in (match qopt with | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor @@ -1898,14 +1899,15 @@ let (find_all_datacons : FStar_Syntax_Syntax.num_uniform_params = uu___4; FStar_Syntax_Syntax.t = uu___5; FStar_Syntax_Syntax.mutuals = datas; - FStar_Syntax_Syntax.ds = uu___6;_}; - FStar_Syntax_Syntax.sigrng = uu___7; - FStar_Syntax_Syntax.sigquals = uu___8; - FStar_Syntax_Syntax.sigmeta = uu___9; - FStar_Syntax_Syntax.sigattrs = uu___10; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___11; - FStar_Syntax_Syntax.sigopts = uu___12;_}, - uu___13) -> FStar_Pervasives_Native.Some datas + FStar_Syntax_Syntax.ds = uu___6; + FStar_Syntax_Syntax.injective_type_params = uu___7;_}; + FStar_Syntax_Syntax.sigrng = uu___8; + FStar_Syntax_Syntax.sigquals = uu___9; + FStar_Syntax_Syntax.sigmeta = uu___10; + FStar_Syntax_Syntax.sigattrs = uu___11; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___12; + FStar_Syntax_Syntax.sigopts = uu___13;_}, + uu___14) -> FStar_Pervasives_Native.Some datas | uu___1 -> FStar_Pervasives_Native.None in resolve_in_open_namespaces' env1 lid (fun uu___ -> FStar_Pervasives_Native.None) @@ -2015,13 +2017,15 @@ let (extract_record : FStar_Syntax_Syntax.t1 = uu___3; FStar_Syntax_Syntax.ty_lid = uu___4; FStar_Syntax_Syntax.num_ty_params = uu___5; - FStar_Syntax_Syntax.mutuals1 = uu___6;_}; - FStar_Syntax_Syntax.sigrng = uu___7; - FStar_Syntax_Syntax.sigquals = uu___8; - FStar_Syntax_Syntax.sigmeta = uu___9; - FStar_Syntax_Syntax.sigattrs = uu___10; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___11; - FStar_Syntax_Syntax.sigopts = uu___12;_} -> + FStar_Syntax_Syntax.mutuals1 = uu___6; + FStar_Syntax_Syntax.injective_type_params1 = + uu___7;_}; + FStar_Syntax_Syntax.sigrng = uu___8; + FStar_Syntax_Syntax.sigquals = uu___9; + FStar_Syntax_Syntax.sigmeta = uu___10; + FStar_Syntax_Syntax.sigattrs = uu___11; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___12; + FStar_Syntax_Syntax.sigopts = uu___13;_} -> FStar_Ident.lid_equals dc lid | uu___2 -> false) sigs in FStar_Compiler_List.iter @@ -2036,51 +2040,54 @@ let (extract_record : FStar_Syntax_Syntax.num_uniform_params = uu___2; FStar_Syntax_Syntax.t = uu___3; FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = dc::[];_}; - FStar_Syntax_Syntax.sigrng = uu___5; + FStar_Syntax_Syntax.ds = dc::[]; + FStar_Syntax_Syntax.injective_type_params = uu___5;_}; + FStar_Syntax_Syntax.sigrng = uu___6; FStar_Syntax_Syntax.sigquals = typename_quals; - FStar_Syntax_Syntax.sigmeta = uu___6; - FStar_Syntax_Syntax.sigattrs = uu___7; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___8; - FStar_Syntax_Syntax.sigopts = uu___9;_} -> - let uu___10 = - let uu___11 = find_dc dc in - FStar_Compiler_Util.must uu___11 in - (match uu___10 with + FStar_Syntax_Syntax.sigmeta = uu___7; + FStar_Syntax_Syntax.sigattrs = uu___8; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; + FStar_Syntax_Syntax.sigopts = uu___10;_} -> + let uu___11 = + let uu___12 = find_dc dc in + FStar_Compiler_Util.must uu___12 in + (match uu___11 with | { FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_datacon { FStar_Syntax_Syntax.lid1 = constrname; - FStar_Syntax_Syntax.us1 = uu___11; + FStar_Syntax_Syntax.us1 = uu___12; FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = uu___12; + FStar_Syntax_Syntax.ty_lid = uu___13; FStar_Syntax_Syntax.num_ty_params = n; - FStar_Syntax_Syntax.mutuals1 = uu___13;_}; - FStar_Syntax_Syntax.sigrng = uu___14; - FStar_Syntax_Syntax.sigquals = uu___15; - FStar_Syntax_Syntax.sigmeta = uu___16; - FStar_Syntax_Syntax.sigattrs = uu___17; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___18; - FStar_Syntax_Syntax.sigopts = uu___19;_} -> - let uu___20 = FStar_Syntax_Util.arrow_formals t in - (match uu___20 with - | (all_formals, uu___21) -> - let uu___22 = + FStar_Syntax_Syntax.mutuals1 = uu___14; + FStar_Syntax_Syntax.injective_type_params1 = + uu___15;_}; + FStar_Syntax_Syntax.sigrng = uu___16; + FStar_Syntax_Syntax.sigquals = uu___17; + FStar_Syntax_Syntax.sigmeta = uu___18; + FStar_Syntax_Syntax.sigattrs = uu___19; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___20; + FStar_Syntax_Syntax.sigopts = uu___21;_} -> + let uu___22 = FStar_Syntax_Util.arrow_formals t in + (match uu___22 with + | (all_formals, uu___23) -> + let uu___24 = FStar_Compiler_Util.first_N n all_formals in - (match uu___22 with + (match uu___24 with | (_params, formals) -> let is_rec = is_record typename_quals in let formals' = FStar_Compiler_List.collect (fun f -> - let uu___23 = + let uu___25 = (FStar_Syntax_Syntax.is_null_bv f.FStar_Syntax_Syntax.binder_bv) || (is_rec && (FStar_Syntax_Syntax.is_bqual_implicit f.FStar_Syntax_Syntax.binder_qual)) in - if uu___23 then [] else [f]) + if uu___25 then [] else [f]) formals in let fields' = FStar_Compiler_List.map @@ -2090,11 +2097,11 @@ let (extract_record : formals' in let fields = fields' in let record = - let uu___23 = + let uu___25 = FStar_Ident.ident_of_lid constrname in { typename; - constrname = uu___23; + constrname = uu___25; parms; fields; is_private = @@ -2103,41 +2110,41 @@ let (extract_record : typename_quals); is_record = is_rec } in - ((let uu___24 = - let uu___25 = + ((let uu___26 = + let uu___27 = FStar_Compiler_Effect.op_Bang new_globs in - (Record_or_dc record) :: uu___25 in + (Record_or_dc record) :: uu___27 in FStar_Compiler_Effect.op_Colon_Equals - new_globs uu___24); + new_globs uu___26); (match () with | () -> - ((let add_field uu___25 = - match uu___25 with - | (id, uu___26) -> + ((let add_field uu___27 = + match uu___27 with + | (id, uu___28) -> let modul = - let uu___27 = - let uu___28 = + let uu___29 = + let uu___30 = FStar_Ident.ns_of_lid constrname in FStar_Ident.lid_of_ids - uu___28 in + uu___30 in FStar_Ident.string_of_lid - uu___27 in - let uu___27 = + uu___29 in + let uu___29 = get_exported_id_set e modul in - (match uu___27 with + (match uu___29 with | FStar_Pervasives_Native.Some my_ex -> let my_exported_ids = my_ex Exported_id_field in - ((let uu___29 = - let uu___30 = + ((let uu___31 = + let uu___32 = FStar_Ident.string_of_id id in - let uu___31 = + let uu___33 = FStar_Compiler_Effect.op_Bang my_exported_ids in Obj.magic @@ -2146,27 +2153,27 @@ let (extract_record : (Obj.magic (FStar_Compiler_RBSet.setlike_rbset FStar_Class_Ord.ord_string)) - uu___30 + uu___32 (Obj.magic - uu___31)) in + uu___33)) in FStar_Compiler_Effect.op_Colon_Equals my_exported_ids - uu___29); + uu___31); (match () with | () -> let projname = - let uu___29 = - let uu___30 + let uu___31 = + let uu___32 = FStar_Syntax_Util.mk_field_projector_name_from_ident constrname id in FStar_Ident.ident_of_lid - uu___30 in + uu___32 in FStar_Ident.string_of_id - uu___29 in - let uu___30 = - let uu___31 = + uu___31 in + let uu___32 = + let uu___33 = FStar_Compiler_Effect.op_Bang my_exported_ids in Obj.magic @@ -2179,10 +2186,10 @@ let (extract_record : projname ( Obj.magic - uu___31)) in + uu___33)) in FStar_Compiler_Effect.op_Colon_Equals my_exported_ids - uu___30)) + uu___32)) | FStar_Pervasives_Native.None -> ()) in FStar_Compiler_List.iter @@ -2190,7 +2197,7 @@ let (extract_record : (match () with | () -> insert_record_cache record)))))) - | uu___11 -> ()) + | uu___12 -> ()) | uu___2 -> ()) sigs | uu___ -> () let (try_lookup_record_or_dc_by_field_name : @@ -2891,11 +2898,13 @@ let (finish : env -> FStar_Syntax_Syntax.modul -> env) = FStar_Syntax_Syntax.t1 = uu___3; FStar_Syntax_Syntax.ty_lid = uu___4; FStar_Syntax_Syntax.num_ty_params = uu___5; - FStar_Syntax_Syntax.mutuals1 = uu___6;_} + FStar_Syntax_Syntax.mutuals1 = uu___6; + FStar_Syntax_Syntax.injective_type_params1 = + uu___7;_} -> - let uu___7 = FStar_Ident.string_of_lid lid in + let uu___8 = FStar_Ident.string_of_lid lid in FStar_Compiler_Util.smap_remove (sigmap env1) - uu___7 + uu___8 | FStar_Syntax_Syntax.Sig_inductive_typ { FStar_Syntax_Syntax.lid = lid; FStar_Syntax_Syntax.us = univ_names; @@ -2903,36 +2912,39 @@ let (finish : env -> FStar_Syntax_Syntax.modul -> env) = FStar_Syntax_Syntax.num_uniform_params = uu___2; FStar_Syntax_Syntax.t = typ; FStar_Syntax_Syntax.mutuals = uu___3; - FStar_Syntax_Syntax.ds = uu___4;_} + FStar_Syntax_Syntax.ds = uu___4; + FStar_Syntax_Syntax.injective_type_params = + uu___5;_} -> - ((let uu___6 = FStar_Ident.string_of_lid lid in + ((let uu___7 = FStar_Ident.string_of_lid lid in FStar_Compiler_Util.smap_remove (sigmap env1) - uu___6); + uu___7); if Prims.op_Negation (FStar_Compiler_List.contains FStar_Syntax_Syntax.Private quals) then (let sigel = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = FStar_Syntax_Syntax.mk_Total typ in { FStar_Syntax_Syntax.bs1 = binders; - FStar_Syntax_Syntax.comp = uu___10 + FStar_Syntax_Syntax.comp = uu___11 } in - FStar_Syntax_Syntax.Tm_arrow uu___9 in - let uu___9 = FStar_Ident.range_of_lid lid in - FStar_Syntax_Syntax.mk uu___8 uu___9 in + FStar_Syntax_Syntax.Tm_arrow uu___10 in + let uu___10 = + FStar_Ident.range_of_lid lid in + FStar_Syntax_Syntax.mk uu___9 uu___10 in { FStar_Syntax_Syntax.lid2 = lid; FStar_Syntax_Syntax.us2 = univ_names; - FStar_Syntax_Syntax.t2 = uu___7 + FStar_Syntax_Syntax.t2 = uu___8 } in - FStar_Syntax_Syntax.Sig_declare_typ uu___6 in + FStar_Syntax_Syntax.Sig_declare_typ uu___7 in let se2 = { FStar_Syntax_Syntax.sigel = sigel; @@ -2949,9 +2961,9 @@ let (finish : env -> FStar_Syntax_Syntax.modul -> env) = FStar_Syntax_Syntax.sigopts = (se1.FStar_Syntax_Syntax.sigopts) } in - let uu___6 = FStar_Ident.string_of_lid lid in + let uu___7 = FStar_Ident.string_of_lid lid in FStar_Compiler_Util.smap_add (sigmap env1) - uu___6 (se2, false)) + uu___7 (se2, false)) else ()) | uu___2 -> ()) ses else () diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Resugar.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Resugar.ml index 32baefc20fd..bbc0d8cb37d 100644 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Resugar.ml +++ b/ocaml/fstar-lib/generated/FStar_Syntax_Resugar.ml @@ -2378,96 +2378,100 @@ let (resugar_typ : FStar_Syntax_Syntax.num_uniform_params = uu___; FStar_Syntax_Syntax.t = t; FStar_Syntax_Syntax.mutuals = uu___1; - FStar_Syntax_Syntax.ds = datacons;_} + FStar_Syntax_Syntax.ds = datacons; + FStar_Syntax_Syntax.injective_type_params = uu___2;_} -> - let uu___2 = + let uu___3 = FStar_Compiler_List.partition (fun se1 -> match se1.FStar_Syntax_Syntax.sigel with | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___3; - FStar_Syntax_Syntax.us1 = uu___4; - FStar_Syntax_Syntax.t1 = uu___5; + { FStar_Syntax_Syntax.lid1 = uu___4; + FStar_Syntax_Syntax.us1 = uu___5; + FStar_Syntax_Syntax.t1 = uu___6; FStar_Syntax_Syntax.ty_lid = inductive_lid; - FStar_Syntax_Syntax.num_ty_params = uu___6; - FStar_Syntax_Syntax.mutuals1 = uu___7;_} + FStar_Syntax_Syntax.num_ty_params = uu___7; + FStar_Syntax_Syntax.mutuals1 = uu___8; + FStar_Syntax_Syntax.injective_type_params1 = uu___9;_} -> FStar_Ident.lid_equals inductive_lid tylid - | uu___3 -> FStar_Compiler_Effect.failwith "unexpected") + | uu___4 -> FStar_Compiler_Effect.failwith "unexpected") datacon_ses in - (match uu___2 with + (match uu___3 with | (current_datacons, other_datacons) -> let bs1 = - let uu___3 = FStar_Options.print_implicits () in - if uu___3 then bs else filter_imp_bs bs in + let uu___4 = FStar_Options.print_implicits () in + if uu___4 then bs else filter_imp_bs bs in let bs2 = (map_opt ()) (fun b -> resugar_binder' env b t.FStar_Syntax_Syntax.pos) bs1 in let tyc = - let uu___3 = + let uu___4 = FStar_Compiler_Util.for_some - (fun uu___4 -> - match uu___4 with - | FStar_Syntax_Syntax.RecordType uu___5 -> true - | uu___5 -> false) se.FStar_Syntax_Syntax.sigquals in - if uu___3 + (fun uu___5 -> + match uu___5 with + | FStar_Syntax_Syntax.RecordType uu___6 -> true + | uu___6 -> false) se.FStar_Syntax_Syntax.sigquals in + if uu___4 then let resugar_datacon_as_fields fields se1 = match se1.FStar_Syntax_Syntax.sigel with | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___4; + { FStar_Syntax_Syntax.lid1 = uu___5; FStar_Syntax_Syntax.us1 = univs; FStar_Syntax_Syntax.t1 = term; - FStar_Syntax_Syntax.ty_lid = uu___5; + FStar_Syntax_Syntax.ty_lid = uu___6; FStar_Syntax_Syntax.num_ty_params = num; - FStar_Syntax_Syntax.mutuals1 = uu___6;_} + FStar_Syntax_Syntax.mutuals1 = uu___7; + FStar_Syntax_Syntax.injective_type_params1 = + uu___8;_} -> - let uu___7 = - let uu___8 = FStar_Syntax_Subst.compress term in - uu___8.FStar_Syntax_Syntax.n in - (match uu___7 with + let uu___9 = + let uu___10 = FStar_Syntax_Subst.compress term in + uu___10.FStar_Syntax_Syntax.n in + (match uu___9 with | FStar_Syntax_Syntax.Tm_arrow { FStar_Syntax_Syntax.bs1 = bs3; - FStar_Syntax_Syntax.comp = uu___8;_} + FStar_Syntax_Syntax.comp = uu___10;_} -> let mfields = FStar_Compiler_List.collect (fun b -> - let uu___9 = + let uu___11 = resugar_bqual env b.FStar_Syntax_Syntax.binder_qual in - match uu___9 with + match uu___11 with | FStar_Pervasives_Native.None -> [] | FStar_Pervasives_Native.Some q -> - let uu___10 = - let uu___11 = + let uu___12 = + let uu___13 = bv_as_unique_ident b.FStar_Syntax_Syntax.binder_bv in - let uu___12 = + let uu___14 = FStar_Compiler_List.map (resugar_term' env) b.FStar_Syntax_Syntax.binder_attrs in - let uu___13 = + let uu___15 = resugar_term' env (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - (uu___11, q, uu___12, uu___13) in - [uu___10]) bs3 in + (uu___13, q, uu___14, uu___15) in + [uu___12]) bs3 in FStar_Compiler_List.op_At mfields fields - | uu___8 -> + | uu___10 -> FStar_Compiler_Effect.failwith "unexpected") - | uu___4 -> + | uu___5 -> FStar_Compiler_Effect.failwith "unexpected" in let fields = FStar_Compiler_List.fold_left resugar_datacon_as_fields [] current_datacons in - let uu___4 = - let uu___5 = FStar_Ident.ident_of_lid tylid in - let uu___6 = + let uu___5 = + let uu___6 = FStar_Ident.ident_of_lid tylid in + let uu___7 = FStar_Compiler_List.map (resugar_term' env) se.FStar_Syntax_Syntax.sigattrs in - (uu___5, bs2, FStar_Pervasives_Native.None, uu___6, + (uu___6, bs2, FStar_Pervasives_Native.None, uu___7, fields) in - FStar_Parser_AST.TyconRecord uu___4 + FStar_Parser_AST.TyconRecord uu___5 else (let resugar_datacon constructors se1 = match se1.FStar_Syntax_Syntax.sigel with @@ -2475,32 +2479,34 @@ let (resugar_typ : { FStar_Syntax_Syntax.lid1 = l; FStar_Syntax_Syntax.us1 = univs; FStar_Syntax_Syntax.t1 = term; - FStar_Syntax_Syntax.ty_lid = uu___5; + FStar_Syntax_Syntax.ty_lid = uu___6; FStar_Syntax_Syntax.num_ty_params = num; - FStar_Syntax_Syntax.mutuals1 = uu___6;_} + FStar_Syntax_Syntax.mutuals1 = uu___7; + FStar_Syntax_Syntax.injective_type_params1 = + uu___8;_} -> let c = - let uu___7 = FStar_Ident.ident_of_lid l in - let uu___8 = - let uu___9 = - let uu___10 = resugar_term' env term in - FStar_Parser_AST.VpArbitrary uu___10 in - FStar_Pervasives_Native.Some uu___9 in - let uu___9 = + let uu___9 = FStar_Ident.ident_of_lid l in + let uu___10 = + let uu___11 = + let uu___12 = resugar_term' env term in + FStar_Parser_AST.VpArbitrary uu___12 in + FStar_Pervasives_Native.Some uu___11 in + let uu___11 = FStar_Compiler_List.map (resugar_term' env) se1.FStar_Syntax_Syntax.sigattrs in - (uu___7, uu___8, uu___9) in + (uu___9, uu___10, uu___11) in c :: constructors - | uu___5 -> + | uu___6 -> FStar_Compiler_Effect.failwith "unexpected" in let constructors = FStar_Compiler_List.fold_left resugar_datacon [] current_datacons in - let uu___5 = - let uu___6 = FStar_Ident.ident_of_lid tylid in - (uu___6, bs2, FStar_Pervasives_Native.None, + let uu___6 = + let uu___7 = FStar_Ident.ident_of_lid tylid in + (uu___7, bs2, FStar_Pervasives_Native.None, constructors) in - FStar_Parser_AST.TyconVariant uu___5) in + FStar_Parser_AST.TyconVariant uu___6) in (other_datacons, tyc)) | uu___ -> FStar_Compiler_Effect.failwith @@ -2818,16 +2824,18 @@ let (resugar_sigelt' : FStar_Syntax_Syntax.t1 = uu___4; FStar_Syntax_Syntax.ty_lid = uu___5; FStar_Syntax_Syntax.num_ty_params = uu___6; - FStar_Syntax_Syntax.mutuals1 = uu___7;_} + FStar_Syntax_Syntax.mutuals1 = uu___7; + FStar_Syntax_Syntax.injective_type_params1 = + uu___8;_} -> - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = FStar_Ident.ident_of_lid l in - (uu___11, FStar_Pervasives_Native.None) in - FStar_Parser_AST.Exception uu___10 in - decl'_to_decl se1 uu___9 in - FStar_Pervasives_Native.Some uu___8 + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = FStar_Ident.ident_of_lid l in + (uu___12, FStar_Pervasives_Native.None) in + FStar_Parser_AST.Exception uu___11 in + decl'_to_decl se1 uu___10 in + FStar_Pervasives_Native.Some uu___9 | uu___3 -> FStar_Compiler_Effect.failwith "wrong format for resguar to Exception") diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Syntax.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Syntax.ml index f7b8282b893..f82c7df57d5 100644 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Syntax.ml +++ b/ocaml/fstar-lib/generated/FStar_Syntax_Syntax.ml @@ -1763,7 +1763,8 @@ type sigelt'__Sig_inductive_typ__payload = num_uniform_params: Prims.int FStar_Pervasives_Native.option ; t: typ ; mutuals: FStar_Ident.lident Prims.list ; - ds: FStar_Ident.lident Prims.list } + ds: FStar_Ident.lident Prims.list ; + injective_type_params: Prims.bool } and sigelt'__Sig_bundle__payload = { ses: sigelt Prims.list ; @@ -1775,7 +1776,8 @@ and sigelt'__Sig_datacon__payload = t1: typ ; ty_lid: FStar_Ident.lident ; num_ty_params: Prims.int ; - mutuals1: FStar_Ident.lident Prims.list } + mutuals1: FStar_Ident.lident Prims.list ; + injective_type_params1: Prims.bool } and sigelt'__Sig_declare_typ__payload = { lid2: FStar_Ident.lident ; @@ -1853,17 +1855,20 @@ let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__lid : sigelt'__Sig_inductive_typ__payload -> FStar_Ident.lident) = fun projectee -> match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds;_} -> lid + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> lid let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__us : sigelt'__Sig_inductive_typ__payload -> univ_names) = fun projectee -> match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds;_} -> us + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> us let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__params : sigelt'__Sig_inductive_typ__payload -> binders) = fun projectee -> match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds;_} -> params + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> params let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__num_uniform_params : sigelt'__Sig_inductive_typ__payload -> @@ -1871,23 +1876,32 @@ let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__num_uniform_params = fun projectee -> match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds;_} -> - num_uniform_params + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> num_uniform_params let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__t : sigelt'__Sig_inductive_typ__payload -> typ) = fun projectee -> match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds;_} -> t + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> t let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__mutuals : sigelt'__Sig_inductive_typ__payload -> FStar_Ident.lident Prims.list) = fun projectee -> match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds;_} -> mutuals + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> mutuals let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__ds : sigelt'__Sig_inductive_typ__payload -> FStar_Ident.lident Prims.list) = fun projectee -> match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds;_} -> ds + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> ds +let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__injective_type_params + : sigelt'__Sig_inductive_typ__payload -> Prims.bool) = + fun projectee -> + match projectee with + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> injective_type_params let (__proj__Mksigelt'__Sig_bundle__payload__item__ses : sigelt'__Sig_bundle__payload -> sigelt Prims.list) = fun projectee -> match projectee with | { ses; lids;_} -> ses @@ -1899,37 +1913,50 @@ let (__proj__Mksigelt'__Sig_datacon__payload__item__lid : fun projectee -> match projectee with | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; - mutuals1 = mutuals;_} -> lid + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> lid let (__proj__Mksigelt'__Sig_datacon__payload__item__us : sigelt'__Sig_datacon__payload -> univ_names) = fun projectee -> match projectee with | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; - mutuals1 = mutuals;_} -> us + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> us let (__proj__Mksigelt'__Sig_datacon__payload__item__t : sigelt'__Sig_datacon__payload -> typ) = fun projectee -> match projectee with | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; - mutuals1 = mutuals;_} -> t + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> t let (__proj__Mksigelt'__Sig_datacon__payload__item__ty_lid : sigelt'__Sig_datacon__payload -> FStar_Ident.lident) = fun projectee -> match projectee with | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; - mutuals1 = mutuals;_} -> ty_lid + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> ty_lid let (__proj__Mksigelt'__Sig_datacon__payload__item__num_ty_params : sigelt'__Sig_datacon__payload -> Prims.int) = fun projectee -> match projectee with | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; - mutuals1 = mutuals;_} -> num_ty_params + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> num_ty_params let (__proj__Mksigelt'__Sig_datacon__payload__item__mutuals : sigelt'__Sig_datacon__payload -> FStar_Ident.lident Prims.list) = fun projectee -> match projectee with | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; - mutuals1 = mutuals;_} -> mutuals + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> mutuals +let (__proj__Mksigelt'__Sig_datacon__payload__item__injective_type_params : + sigelt'__Sig_datacon__payload -> Prims.bool) = + fun projectee -> + match projectee with + | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> injective_type_params let (__proj__Mksigelt'__Sig_declare_typ__payload__item__lid : sigelt'__Sig_declare_typ__payload -> FStar_Ident.lident) = fun projectee -> diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Util.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Util.ml index 20d9ecd64ad..f8dd7bd99de 100644 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Util.ml +++ b/ocaml/fstar-lib/generated/FStar_Syntax_Util.ml @@ -382,6 +382,14 @@ let (eq_univs : = fun u1 -> fun u2 -> let uu___ = compare_univs u1 u2 in uu___ = Prims.int_zero +let (eq_univs_list : + FStar_Syntax_Syntax.universes -> + FStar_Syntax_Syntax.universes -> Prims.bool) + = + fun us -> + fun vs -> + ((FStar_Compiler_List.length us) = (FStar_Compiler_List.length vs)) && + (FStar_Compiler_List.forall2 eq_univs us vs) let (ml_comp : FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.comp) @@ -929,418 +937,6 @@ let (canon_app : match uu___ with | (hd, args) -> FStar_Syntax_Syntax.mk_Tm_app hd args t.FStar_Syntax_Syntax.pos -type eq_result = - | Equal - | NotEqual - | Unknown -let (uu___is_Equal : eq_result -> Prims.bool) = - fun projectee -> match projectee with | Equal -> true | uu___ -> false -let (uu___is_NotEqual : eq_result -> Prims.bool) = - fun projectee -> match projectee with | NotEqual -> true | uu___ -> false -let (uu___is_Unknown : eq_result -> Prims.bool) = - fun projectee -> match projectee with | Unknown -> true | uu___ -> false -let (injectives : Prims.string Prims.list) = - ["FStar.Int8.int_to_t"; - "FStar.Int16.int_to_t"; - "FStar.Int32.int_to_t"; - "FStar.Int64.int_to_t"; - "FStar.Int128.int_to_t"; - "FStar.UInt8.uint_to_t"; - "FStar.UInt16.uint_to_t"; - "FStar.UInt32.uint_to_t"; - "FStar.UInt64.uint_to_t"; - "FStar.UInt128.uint_to_t"; - "FStar.SizeT.uint_to_t"; - "FStar.Int8.__int_to_t"; - "FStar.Int16.__int_to_t"; - "FStar.Int32.__int_to_t"; - "FStar.Int64.__int_to_t"; - "FStar.Int128.__int_to_t"; - "FStar.UInt8.__uint_to_t"; - "FStar.UInt16.__uint_to_t"; - "FStar.UInt32.__uint_to_t"; - "FStar.UInt64.__uint_to_t"; - "FStar.UInt128.__uint_to_t"; - "FStar.SizeT.__uint_to_t"] -let (eq_inj : eq_result -> eq_result -> eq_result) = - fun r -> - fun s -> - match (r, s) with - | (Equal, Equal) -> Equal - | (NotEqual, uu___) -> NotEqual - | (uu___, NotEqual) -> NotEqual - | (uu___, uu___1) -> Unknown -let (equal_if : Prims.bool -> eq_result) = - fun uu___ -> if uu___ then Equal else Unknown -let (equal_iff : Prims.bool -> eq_result) = - fun uu___ -> if uu___ then Equal else NotEqual -let (eq_and : eq_result -> (unit -> eq_result) -> eq_result) = - fun r -> - fun s -> - let uu___ = (r = Equal) && (let uu___1 = s () in uu___1 = Equal) in - if uu___ then Equal else Unknown -let rec (eq_tm : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> eq_result) = - fun t1 -> - fun t2 -> - let t11 = canon_app t1 in - let t21 = canon_app t2 in - let equal_data f1 args1 f2 args2 = - let uu___ = FStar_Syntax_Syntax.fv_eq f1 f2 in - if uu___ - then - let uu___1 = FStar_Compiler_List.zip args1 args2 in - FStar_Compiler_List.fold_left - (fun acc -> - fun uu___2 -> - match uu___2 with - | ((a1, q1), (a2, q2)) -> - let uu___3 = eq_tm a1 a2 in eq_inj acc uu___3) Equal - uu___1 - else NotEqual in - let qual_is_inj uu___ = - match uu___ with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Data_ctor) -> - true - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Record_ctor - uu___1) -> true - | uu___1 -> false in - let heads_and_args_in_case_both_data = - let uu___ = let uu___1 = unmeta t11 in head_and_args uu___1 in - match uu___ with - | (head1, args1) -> - let uu___1 = let uu___2 = unmeta t21 in head_and_args uu___2 in - (match uu___1 with - | (head2, args2) -> - let uu___2 = - let uu___3 = - let uu___4 = un_uinst head1 in - uu___4.FStar_Syntax_Syntax.n in - let uu___4 = - let uu___5 = un_uinst head2 in - uu___5.FStar_Syntax_Syntax.n in - (uu___3, uu___4) in - (match uu___2 with - | (FStar_Syntax_Syntax.Tm_fvar f, - FStar_Syntax_Syntax.Tm_fvar g) when - (qual_is_inj f.FStar_Syntax_Syntax.fv_qual) && - (qual_is_inj g.FStar_Syntax_Syntax.fv_qual) - -> FStar_Pervasives_Native.Some (f, args1, g, args2) - | uu___3 -> FStar_Pervasives_Native.None)) in - let t12 = unmeta t11 in - let t22 = unmeta t21 in - match ((t12.FStar_Syntax_Syntax.n), (t22.FStar_Syntax_Syntax.n)) with - | (FStar_Syntax_Syntax.Tm_bvar bv1, FStar_Syntax_Syntax.Tm_bvar bv2) -> - equal_if - (bv1.FStar_Syntax_Syntax.index = bv2.FStar_Syntax_Syntax.index) - | (FStar_Syntax_Syntax.Tm_lazy uu___, uu___1) -> - let uu___2 = unlazy t12 in eq_tm uu___2 t22 - | (uu___, FStar_Syntax_Syntax.Tm_lazy uu___1) -> - let uu___2 = unlazy t22 in eq_tm t12 uu___2 - | (FStar_Syntax_Syntax.Tm_name a, FStar_Syntax_Syntax.Tm_name b) -> - let uu___ = FStar_Syntax_Syntax.bv_eq a b in equal_if uu___ - | uu___ when - FStar_Compiler_Util.is_some heads_and_args_in_case_both_data -> - let uu___1 = - FStar_Compiler_Util.must heads_and_args_in_case_both_data in - (match uu___1 with - | (f, args1, g, args2) -> equal_data f args1 g args2) - | (FStar_Syntax_Syntax.Tm_fvar f, FStar_Syntax_Syntax.Tm_fvar g) -> - let uu___ = FStar_Syntax_Syntax.fv_eq f g in equal_if uu___ - | (FStar_Syntax_Syntax.Tm_uinst (f, us), FStar_Syntax_Syntax.Tm_uinst - (g, vs)) -> - let uu___ = eq_tm f g in - eq_and uu___ - (fun uu___1 -> - let uu___2 = eq_univs_list us vs in equal_if uu___2) - | (FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_range uu___), - FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_range uu___1)) -> - Unknown - | (FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_real r1), - FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_real r2)) -> - equal_if (r1 = r2) - | (FStar_Syntax_Syntax.Tm_constant c, FStar_Syntax_Syntax.Tm_constant - d) -> let uu___ = FStar_Const.eq_const c d in equal_iff uu___ - | (FStar_Syntax_Syntax.Tm_uvar (u1, ([], uu___)), - FStar_Syntax_Syntax.Tm_uvar (u2, ([], uu___1))) -> - let uu___2 = - FStar_Syntax_Unionfind.equiv u1.FStar_Syntax_Syntax.ctx_uvar_head - u2.FStar_Syntax_Syntax.ctx_uvar_head in - equal_if uu___2 - | (FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = h1; FStar_Syntax_Syntax.args = args1;_}, - FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = h2; FStar_Syntax_Syntax.args = args2;_}) - -> - let uu___ = - let uu___1 = - let uu___2 = un_uinst h1 in uu___2.FStar_Syntax_Syntax.n in - let uu___2 = - let uu___3 = un_uinst h2 in uu___3.FStar_Syntax_Syntax.n in - (uu___1, uu___2) in - (match uu___ with - | (FStar_Syntax_Syntax.Tm_fvar f1, FStar_Syntax_Syntax.Tm_fvar f2) - when - (FStar_Syntax_Syntax.fv_eq f1 f2) && - (let uu___1 = - let uu___2 = FStar_Syntax_Syntax.lid_of_fv f1 in - FStar_Ident.string_of_lid uu___2 in - FStar_Compiler_List.mem uu___1 injectives) - -> equal_data f1 args1 f2 args2 - | uu___1 -> - let uu___2 = eq_tm h1 h2 in - eq_and uu___2 (fun uu___3 -> eq_args args1 args2)) - | (FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t13; - FStar_Syntax_Syntax.ret_opt = uu___; - FStar_Syntax_Syntax.brs = bs1; - FStar_Syntax_Syntax.rc_opt1 = uu___1;_}, - FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t23; - FStar_Syntax_Syntax.ret_opt = uu___2; - FStar_Syntax_Syntax.brs = bs2; - FStar_Syntax_Syntax.rc_opt1 = uu___3;_}) - -> - if - (FStar_Compiler_List.length bs1) = - (FStar_Compiler_List.length bs2) - then - let uu___4 = FStar_Compiler_List.zip bs1 bs2 in - let uu___5 = eq_tm t13 t23 in - FStar_Compiler_List.fold_right - (fun uu___6 -> - fun a -> - match uu___6 with - | (b1, b2) -> - eq_and a (fun uu___7 -> branch_matches b1 b2)) uu___4 - uu___5 - else Unknown - | (FStar_Syntax_Syntax.Tm_type u, FStar_Syntax_Syntax.Tm_type v) -> - let uu___ = eq_univs u v in equal_if uu___ - | (FStar_Syntax_Syntax.Tm_quoted (t13, q1), - FStar_Syntax_Syntax.Tm_quoted (t23, q2)) -> Unknown - | (FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = t13; FStar_Syntax_Syntax.phi = phi1;_}, - FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = t23; FStar_Syntax_Syntax.phi = phi2;_}) -> - let uu___ = - eq_tm t13.FStar_Syntax_Syntax.sort t23.FStar_Syntax_Syntax.sort in - eq_and uu___ (fun uu___1 -> eq_tm phi1 phi2) - | (FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs1; FStar_Syntax_Syntax.body = body1; - FStar_Syntax_Syntax.rc_opt = uu___;_}, - FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs2; FStar_Syntax_Syntax.body = body2; - FStar_Syntax_Syntax.rc_opt = uu___1;_}) - when - (FStar_Compiler_List.length bs1) = (FStar_Compiler_List.length bs2) - -> - let uu___2 = - FStar_Compiler_List.fold_left2 - (fun r -> - fun b1 -> - fun b2 -> - eq_and r - (fun uu___3 -> - eq_tm - (b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - (b2.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort)) - Equal bs1 bs2 in - eq_and uu___2 (fun uu___3 -> eq_tm body1 body2) - | (FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs1; FStar_Syntax_Syntax.comp = c1;_}, - FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs2; FStar_Syntax_Syntax.comp = c2;_}) - when - (FStar_Compiler_List.length bs1) = (FStar_Compiler_List.length bs2) - -> - let uu___ = - FStar_Compiler_List.fold_left2 - (fun r -> - fun b1 -> - fun b2 -> - eq_and r - (fun uu___1 -> - eq_tm - (b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - (b2.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort)) - Equal bs1 bs2 in - eq_and uu___ (fun uu___1 -> eq_comp c1 c2) - | uu___ -> Unknown -and (eq_antiquotations : - FStar_Syntax_Syntax.term Prims.list -> - FStar_Syntax_Syntax.term Prims.list -> eq_result) - = - fun a1 -> - fun a2 -> - match (a1, a2) with - | ([], []) -> Equal - | ([], uu___) -> NotEqual - | (uu___, []) -> NotEqual - | (t1::a11, t2::a21) -> - let uu___ = eq_tm t1 t2 in - (match uu___ with - | NotEqual -> NotEqual - | Unknown -> - let uu___1 = eq_antiquotations a11 a21 in - (match uu___1 with | NotEqual -> NotEqual | uu___2 -> Unknown) - | Equal -> eq_antiquotations a11 a21) -and (branch_matches : - (FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t * - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax) -> - (FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t * - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax) -> eq_result) - = - fun b1 -> - fun b2 -> - let related_by f o1 o2 = - match (o1, o2) with - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> - true - | (FStar_Pervasives_Native.Some x, FStar_Pervasives_Native.Some y) -> - f x y - | (uu___, uu___1) -> false in - let uu___ = b1 in - match uu___ with - | (p1, w1, t1) -> - let uu___1 = b2 in - (match uu___1 with - | (p2, w2, t2) -> - let uu___2 = FStar_Syntax_Syntax.eq_pat p1 p2 in - if uu___2 - then - let uu___3 = - (let uu___4 = eq_tm t1 t2 in uu___4 = Equal) && - (related_by - (fun t11 -> - fun t21 -> - let uu___4 = eq_tm t11 t21 in uu___4 = Equal) w1 - w2) in - (if uu___3 then Equal else Unknown) - else Unknown) -and (eq_args : - FStar_Syntax_Syntax.args -> FStar_Syntax_Syntax.args -> eq_result) = - fun a1 -> - fun a2 -> - match (a1, a2) with - | ([], []) -> Equal - | ((a, uu___)::a11, (b, uu___1)::b1) -> - let uu___2 = eq_tm a b in - (match uu___2 with | Equal -> eq_args a11 b1 | uu___3 -> Unknown) - | uu___ -> Unknown -and (eq_univs_list : - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.universes -> Prims.bool) - = - fun us -> - fun vs -> - ((FStar_Compiler_List.length us) = (FStar_Compiler_List.length vs)) && - (FStar_Compiler_List.forall2 eq_univs us vs) -and (eq_comp : - FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp -> eq_result) = - fun c1 -> - fun c2 -> - match ((c1.FStar_Syntax_Syntax.n), (c2.FStar_Syntax_Syntax.n)) with - | (FStar_Syntax_Syntax.Total t1, FStar_Syntax_Syntax.Total t2) -> - eq_tm t1 t2 - | (FStar_Syntax_Syntax.GTotal t1, FStar_Syntax_Syntax.GTotal t2) -> - eq_tm t1 t2 - | (FStar_Syntax_Syntax.Comp ct1, FStar_Syntax_Syntax.Comp ct2) -> - let uu___ = - let uu___1 = - eq_univs_list ct1.FStar_Syntax_Syntax.comp_univs - ct2.FStar_Syntax_Syntax.comp_univs in - equal_if uu___1 in - eq_and uu___ - (fun uu___1 -> - let uu___2 = - let uu___3 = - FStar_Ident.lid_equals ct1.FStar_Syntax_Syntax.effect_name - ct2.FStar_Syntax_Syntax.effect_name in - equal_if uu___3 in - eq_and uu___2 - (fun uu___3 -> - let uu___4 = - eq_tm ct1.FStar_Syntax_Syntax.result_typ - ct2.FStar_Syntax_Syntax.result_typ in - eq_and uu___4 - (fun uu___5 -> - eq_args ct1.FStar_Syntax_Syntax.effect_args - ct2.FStar_Syntax_Syntax.effect_args))) - | uu___ -> NotEqual -let (eq_quoteinfo : - FStar_Syntax_Syntax.quoteinfo -> FStar_Syntax_Syntax.quoteinfo -> eq_result) - = - fun q1 -> - fun q2 -> - if q1.FStar_Syntax_Syntax.qkind <> q2.FStar_Syntax_Syntax.qkind - then NotEqual - else - eq_antiquotations - (FStar_Pervasives_Native.snd q1.FStar_Syntax_Syntax.antiquotations) - (FStar_Pervasives_Native.snd q2.FStar_Syntax_Syntax.antiquotations) -let (eq_bqual : - FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> - eq_result) - = - fun a1 -> - fun a2 -> - match (a1, a2) with - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> Equal - | (FStar_Pervasives_Native.None, uu___) -> NotEqual - | (uu___, FStar_Pervasives_Native.None) -> NotEqual - | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit b1), - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit b2)) when - b1 = b2 -> Equal - | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t1), - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t2)) -> - eq_tm t1 t2 - | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Equality), - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Equality)) -> - Equal - | uu___ -> NotEqual -let (eq_aqual : - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> - eq_result) - = - fun a1 -> - fun a2 -> - match (a1, a2) with - | (FStar_Pervasives_Native.Some a11, FStar_Pervasives_Native.Some a21) - -> - if - (a11.FStar_Syntax_Syntax.aqual_implicit = - a21.FStar_Syntax_Syntax.aqual_implicit) - && - ((FStar_Compiler_List.length - a11.FStar_Syntax_Syntax.aqual_attributes) - = - (FStar_Compiler_List.length - a21.FStar_Syntax_Syntax.aqual_attributes)) - then - FStar_Compiler_List.fold_left2 - (fun out -> - fun t1 -> - fun t2 -> - match out with - | NotEqual -> out - | Unknown -> - let uu___ = eq_tm t1 t2 in - (match uu___ with - | NotEqual -> NotEqual - | uu___1 -> Unknown) - | Equal -> eq_tm t1 t2) Equal - a11.FStar_Syntax_Syntax.aqual_attributes - a21.FStar_Syntax_Syntax.aqual_attributes - else NotEqual - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> Equal - | uu___ -> NotEqual let rec (unrefine : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = fun t -> let t1 = FStar_Syntax_Subst.compress t in @@ -1469,7 +1065,8 @@ let (lids_of_sigelt : FStar_Syntax_Syntax.num_uniform_params = uu___2; FStar_Syntax_Syntax.t = uu___3; FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5;_} + FStar_Syntax_Syntax.ds = uu___5; + FStar_Syntax_Syntax.injective_type_params = uu___6;_} -> [lid] | FStar_Syntax_Syntax.Sig_effect_abbrev { FStar_Syntax_Syntax.lid4 = lid; FStar_Syntax_Syntax.us4 = uu___; @@ -1482,7 +1079,8 @@ let (lids_of_sigelt : FStar_Syntax_Syntax.t1 = uu___1; FStar_Syntax_Syntax.ty_lid = uu___2; FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4;_} + FStar_Syntax_Syntax.mutuals1 = uu___4; + FStar_Syntax_Syntax.injective_type_params1 = uu___5;_} -> [lid] | FStar_Syntax_Syntax.Sig_declare_typ { FStar_Syntax_Syntax.lid2 = lid; FStar_Syntax_Syntax.us2 = uu___; @@ -2339,12 +1937,6 @@ let (type_with_u : FStar_Syntax_Syntax.universe -> FStar_Syntax_Syntax.typ) = fun u -> FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_type u) FStar_Compiler_Range_Type.dummyRange -let (attr_eq : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun a -> - fun a' -> - let uu___ = eq_tm a a' in - match uu___ with | Equal -> true | uu___1 -> false let (attr_substitute : FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) = let uu___ = @@ -3591,7 +3183,7 @@ let rec (term_eq_dbg : u2.FStar_Syntax_Syntax.ctx_uvar_head) | (FStar_Syntax_Syntax.Tm_quoted (qt1, qi1), FStar_Syntax_Syntax.Tm_quoted (qt2, qi2)) -> - (let uu___1 = let uu___2 = eq_quoteinfo qi1 qi2 in uu___2 = Equal in + (let uu___1 = quote_info_eq_dbg dbg qi1 qi2 in check1 "tm_quoted qi" uu___1) && (let uu___1 = term_eq_dbg dbg qt1 qt2 in check1 "tm_quoted payload" uu___1) @@ -3662,7 +3254,7 @@ and (arg_eq_dbg : let uu___ = term_eq_dbg dbg t1 t2 in check dbg "arg tm" uu___) (fun q1 -> fun q2 -> - let uu___ = let uu___1 = eq_aqual q1 q2 in uu___1 = Equal in + let uu___ = aqual_eq_dbg dbg q1 q2 in check dbg "arg qual" uu___) a1 a2 and (binder_eq_dbg : Prims.bool -> @@ -3677,10 +3269,8 @@ and (binder_eq_dbg : (b2.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in check dbg "binder_sort" uu___) && (let uu___ = - let uu___1 = - eq_bqual b1.FStar_Syntax_Syntax.binder_qual - b2.FStar_Syntax_Syntax.binder_qual in - uu___1 = Equal in + bqual_eq_dbg dbg b1.FStar_Syntax_Syntax.binder_qual + b2.FStar_Syntax_Syntax.binder_qual in check dbg "binder qual" uu___)) && (let uu___ = @@ -3756,6 +3346,108 @@ and (letbinding_eq_dbg : term_eq_dbg dbg lb1.FStar_Syntax_Syntax.lbdef lb2.FStar_Syntax_Syntax.lbdef in check dbg "lb def" uu___) +and (quote_info_eq_dbg : + Prims.bool -> + FStar_Syntax_Syntax.quoteinfo -> + FStar_Syntax_Syntax.quoteinfo -> Prims.bool) + = + fun dbg -> + fun q1 -> + fun q2 -> + if q1.FStar_Syntax_Syntax.qkind <> q2.FStar_Syntax_Syntax.qkind + then false + else + antiquotations_eq_dbg dbg + (FStar_Pervasives_Native.snd + q1.FStar_Syntax_Syntax.antiquotations) + (FStar_Pervasives_Native.snd + q2.FStar_Syntax_Syntax.antiquotations) +and (antiquotations_eq_dbg : + Prims.bool -> + FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax Prims.list -> + FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax Prims.list -> + Prims.bool) + = + fun dbg -> + fun a1 -> + fun a2 -> + match (a1, a2) with + | ([], []) -> true + | ([], uu___) -> false + | (uu___, []) -> false + | (t1::a11, t2::a21) -> + let uu___ = + let uu___1 = term_eq_dbg dbg t1 t2 in Prims.op_Negation uu___1 in + if uu___ then false else antiquotations_eq_dbg dbg a11 a21 +and (bqual_eq_dbg : + Prims.bool -> + FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + Prims.bool) + = + fun dbg -> + fun a1 -> + fun a2 -> + match (a1, a2) with + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> + true + | (FStar_Pervasives_Native.None, uu___) -> false + | (uu___, FStar_Pervasives_Native.None) -> false + | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit b1), + FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit b2)) + when b1 = b2 -> true + | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t1), + FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t2)) -> + term_eq_dbg dbg t1 t2 + | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Equality), + FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Equality)) -> + true + | uu___ -> false +and (aqual_eq_dbg : + Prims.bool -> + FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> + FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> + Prims.bool) + = + fun dbg -> + fun a1 -> + fun a2 -> + match (a1, a2) with + | (FStar_Pervasives_Native.Some a11, FStar_Pervasives_Native.Some + a21) -> + if + (a11.FStar_Syntax_Syntax.aqual_implicit = + a21.FStar_Syntax_Syntax.aqual_implicit) + && + ((FStar_Compiler_List.length + a11.FStar_Syntax_Syntax.aqual_attributes) + = + (FStar_Compiler_List.length + a21.FStar_Syntax_Syntax.aqual_attributes)) + then + FStar_Compiler_List.fold_left2 + (fun out -> + fun t1 -> + fun t2 -> + if Prims.op_Negation out + then false + else term_eq_dbg dbg t1 t2) true + a11.FStar_Syntax_Syntax.aqual_attributes + a21.FStar_Syntax_Syntax.aqual_attributes + else false + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> + true + | uu___ -> false +let (eq_aqual : + FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> + FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> + Prims.bool) + = fun a1 -> fun a2 -> aqual_eq_dbg false a1 a2 +let (eq_bqual : + FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + Prims.bool) + = fun b1 -> fun b2 -> bqual_eq_dbg false b1 b2 let (term_eq : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> Prims.bool) = fun t1 -> @@ -4845,9 +4537,7 @@ let (is_binder_unused : FStar_Syntax_Syntax.binder -> Prims.bool) = let (deduplicate_terms : FStar_Syntax_Syntax.term Prims.list -> FStar_Syntax_Syntax.term Prims.list) = - fun l -> - FStar_Compiler_List.deduplicate - (fun x -> fun y -> let uu___ = eq_tm x y in uu___ = Equal) l + fun l -> FStar_Compiler_List.deduplicate (fun x -> fun y -> term_eq x y) l let (eq_binding : FStar_Syntax_Syntax.binding -> FStar_Syntax_Syntax.binding -> Prims.bool) = fun b1 -> diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Hooks.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Hooks.ml index 33dae4e4ca6..898674ac524 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Hooks.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_Hooks.ml @@ -1261,9 +1261,10 @@ let rec (traverse_for_spinoff : FStar_Parser_Const.squash_lid)) && (let uu___8 = - FStar_Syntax_Util.eq_tm t2 - FStar_Syntax_Util.t_true in - uu___8 = FStar_Syntax_Util.Equal) + FStar_TypeChecker_TermEqAndSimplify.eq_tm + e t2 FStar_Syntax_Util.t_true in + uu___8 = + FStar_TypeChecker_TermEqAndSimplify.Equal) -> (if debug then diff --git a/ocaml/fstar-lib/generated/FStar_ToSyntax_ToSyntax.ml b/ocaml/fstar-lib/generated/FStar_ToSyntax_ToSyntax.ml index 959617fa399..372ae31b33b 100644 --- a/ocaml/fstar-lib/generated/FStar_ToSyntax_ToSyntax.ml +++ b/ocaml/fstar-lib/generated/FStar_ToSyntax_ToSyntax.ml @@ -1052,30 +1052,33 @@ let rec (generalize_annotated_univs : FStar_Syntax_Syntax.num_uniform_params = num_uniform; FStar_Syntax_Syntax.t = t; FStar_Syntax_Syntax.mutuals = lids1; - FStar_Syntax_Syntax.ds = lids2;_} + FStar_Syntax_Syntax.ds = lids2; + FStar_Syntax_Syntax.injective_type_params = uu___5;_} -> - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Subst.subst_binders usubst bs in + let uu___6 = + let uu___7 = let uu___8 = - let uu___9 = + FStar_Syntax_Subst.subst_binders usubst bs in + let uu___9 = + let uu___10 = FStar_Syntax_Subst.shift_subst (FStar_Compiler_List.length bs) usubst in - FStar_Syntax_Subst.subst uu___9 t in + FStar_Syntax_Subst.subst uu___10 t in { FStar_Syntax_Syntax.lid = lid; FStar_Syntax_Syntax.us = unames; - FStar_Syntax_Syntax.params = uu___7; + FStar_Syntax_Syntax.params = uu___8; FStar_Syntax_Syntax.num_uniform_params = num_uniform; - FStar_Syntax_Syntax.t = uu___8; + FStar_Syntax_Syntax.t = uu___9; FStar_Syntax_Syntax.mutuals = lids1; - FStar_Syntax_Syntax.ds = lids2 + FStar_Syntax_Syntax.ds = lids2; + FStar_Syntax_Syntax.injective_type_params = + false } in - FStar_Syntax_Syntax.Sig_inductive_typ uu___6 in + FStar_Syntax_Syntax.Sig_inductive_typ uu___7 in { - FStar_Syntax_Syntax.sigel = uu___5; + FStar_Syntax_Syntax.sigel = uu___6; FStar_Syntax_Syntax.sigrng = (se.FStar_Syntax_Syntax.sigrng); FStar_Syntax_Syntax.sigquals = @@ -1095,22 +1098,25 @@ let rec (generalize_annotated_univs : FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = tlid; FStar_Syntax_Syntax.num_ty_params = n; - FStar_Syntax_Syntax.mutuals1 = lids1;_} + FStar_Syntax_Syntax.mutuals1 = lids1; + FStar_Syntax_Syntax.injective_type_params1 = uu___5;_} -> - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Subst.subst usubst t in + let uu___6 = + let uu___7 = + let uu___8 = FStar_Syntax_Subst.subst usubst t in { FStar_Syntax_Syntax.lid1 = lid; FStar_Syntax_Syntax.us1 = unames; - FStar_Syntax_Syntax.t1 = uu___7; + FStar_Syntax_Syntax.t1 = uu___8; FStar_Syntax_Syntax.ty_lid = tlid; FStar_Syntax_Syntax.num_ty_params = n; - FStar_Syntax_Syntax.mutuals1 = lids1 + FStar_Syntax_Syntax.mutuals1 = lids1; + FStar_Syntax_Syntax.injective_type_params1 = + false } in - FStar_Syntax_Syntax.Sig_datacon uu___6 in + FStar_Syntax_Syntax.Sig_datacon uu___7 in { - FStar_Syntax_Syntax.sigel = uu___5; + FStar_Syntax_Syntax.sigel = uu___6; FStar_Syntax_Syntax.sigrng = (se.FStar_Syntax_Syntax.sigrng); FStar_Syntax_Syntax.sigquals = @@ -6497,32 +6503,33 @@ let (mk_data_projector_names : FStar_Syntax_Syntax.us1 = uu___; FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___1; FStar_Syntax_Syntax.num_ty_params = n; - FStar_Syntax_Syntax.mutuals1 = uu___2;_} + FStar_Syntax_Syntax.mutuals1 = uu___2; + FStar_Syntax_Syntax.injective_type_params1 = uu___3;_} -> - let uu___3 = FStar_Syntax_Util.arrow_formals t in - (match uu___3 with - | (formals, uu___4) -> + let uu___4 = FStar_Syntax_Util.arrow_formals t in + (match uu___4 with + | (formals, uu___5) -> (match formals with | [] -> [] - | uu___5 -> - let filter_records uu___6 = - match uu___6 with + | uu___6 -> + let filter_records uu___7 = + match uu___7 with | FStar_Syntax_Syntax.RecordConstructor - (uu___7, fns) -> + (uu___8, fns) -> FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Record_ctor (lid, fns)) - | uu___7 -> FStar_Pervasives_Native.None in + | uu___8 -> FStar_Pervasives_Native.None in let fv_qual = - let uu___6 = + let uu___7 = FStar_Compiler_Util.find_map se.FStar_Syntax_Syntax.sigquals filter_records in - match uu___6 with + match uu___7 with | FStar_Pervasives_Native.None -> FStar_Syntax_Syntax.Data_ctor | FStar_Pervasives_Native.Some q -> q in - let uu___6 = FStar_Compiler_Util.first_N n formals in - (match uu___6 with - | (uu___7, rest) -> + let uu___7 = FStar_Compiler_Util.first_N n formals in + (match uu___7 with + | (uu___8, rest) -> mk_indexed_projector_names iquals fv_qual se.FStar_Syntax_Syntax.sigattrs env lid rest))) | uu___ -> []) @@ -6908,7 +6915,9 @@ let rec (desugar_tycon : FStar_Pervasives_Native.None; FStar_Syntax_Syntax.t = k1; FStar_Syntax_Syntax.mutuals = mutuals; - FStar_Syntax_Syntax.ds = [] + FStar_Syntax_Syntax.ds = []; + FStar_Syntax_Syntax.injective_type_params = + false }); FStar_Syntax_Syntax.sigrng = uu___2; FStar_Syntax_Syntax.sigquals = quals1; @@ -6974,7 +6983,9 @@ let rec (desugar_tycon : FStar_Syntax_Syntax.num_uniform_params = uu___5; FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = []; - FStar_Syntax_Syntax.ds = [];_} + FStar_Syntax_Syntax.ds = []; + FStar_Syntax_Syntax.injective_type_params = + uu___6;_} -> let quals1 = se.FStar_Syntax_Syntax.sigquals in let quals2 = @@ -6983,22 +6994,22 @@ let rec (desugar_tycon : FStar_Syntax_Syntax.Assumption quals1 then quals1 else - ((let uu___8 = - let uu___9 = FStar_Options.ml_ish () in - Prims.op_Negation uu___9 in - if uu___8 + ((let uu___9 = + let uu___10 = FStar_Options.ml_ish () in + Prims.op_Negation uu___10 in + if uu___9 then - let uu___9 = - let uu___10 = - let uu___11 = + let uu___10 = + let uu___11 = + let uu___12 = FStar_Syntax_Print.lid_to_string l in FStar_Compiler_Util.format1 "Adding an implicit 'assume new' qualifier on %s" - uu___11 in + uu___12 in (FStar_Errors_Codes.Warning_AddImplicitAssumeNewQualifier, - uu___10) in + uu___11) in FStar_Errors.log_issue - se.FStar_Syntax_Syntax.sigrng uu___9 + se.FStar_Syntax_Syntax.sigrng uu___10 else ()); FStar_Syntax_Syntax.Assumption :: @@ -7008,17 +7019,17 @@ let rec (desugar_tycon : let t = match typars with | [] -> k - | uu___6 -> - let uu___7 = - let uu___8 = - let uu___9 = + | uu___7 -> + let uu___8 = + let uu___9 = + let uu___10 = FStar_Syntax_Syntax.mk_Total k in { FStar_Syntax_Syntax.bs1 = typars; - FStar_Syntax_Syntax.comp = uu___9 + FStar_Syntax_Syntax.comp = uu___10 } in - FStar_Syntax_Syntax.Tm_arrow uu___8 in - FStar_Syntax_Syntax.mk uu___7 + FStar_Syntax_Syntax.Tm_arrow uu___9 in + FStar_Syntax_Syntax.mk uu___8 se.FStar_Syntax_Syntax.sigrng in { FStar_Syntax_Syntax.sigel = @@ -7257,37 +7268,39 @@ let rec (desugar_tycon : = uu___4; FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6;_}; - FStar_Syntax_Syntax.sigrng = uu___7; - FStar_Syntax_Syntax.sigquals = uu___8; - FStar_Syntax_Syntax.sigmeta = uu___9; - FStar_Syntax_Syntax.sigattrs = uu___10; + FStar_Syntax_Syntax.ds = uu___6; + FStar_Syntax_Syntax.injective_type_params + = uu___7;_}; + FStar_Syntax_Syntax.sigrng = uu___8; + FStar_Syntax_Syntax.sigquals = uu___9; + FStar_Syntax_Syntax.sigmeta = uu___10; + FStar_Syntax_Syntax.sigattrs = uu___11; FStar_Syntax_Syntax.sigopens_and_abbrevs = - uu___11; - FStar_Syntax_Syntax.sigopts = uu___12;_}, + uu___12; + FStar_Syntax_Syntax.sigopts = uu___13;_}, binders, t, quals1) -> let t1 = - let uu___13 = + let uu___14 = typars_of_binders env1 binders in - match uu___13 with + match uu___14 with | (env2, tpars1) -> - let uu___14 = push_tparams env2 tpars1 in - (match uu___14 with + let uu___15 = push_tparams env2 tpars1 in + (match uu___15 with | (env_tps, tpars2) -> let t2 = desugar_typ env_tps t in let tpars3 = FStar_Syntax_Subst.close_binders tpars2 in FStar_Syntax_Subst.close tpars3 t2) in - let uu___13 = - let uu___14 = - let uu___15 = FStar_Ident.range_of_lid id in + let uu___14 = + let uu___15 = + let uu___16 = FStar_Ident.range_of_lid id in mk_typ_abbrev env1 d id uvs tpars (FStar_Pervasives_Native.Some k) t1 - [id] quals1 uu___15 in - ([], uu___14) in - [uu___13] + [id] quals1 uu___16 in + ([], uu___15) in + [uu___14] | FStar_Pervasives.Inl ({ FStar_Syntax_Syntax.sigel = @@ -7299,7 +7312,9 @@ let rec (desugar_tycon : = num_uniform; FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = mutuals1; - FStar_Syntax_Syntax.ds = uu___4;_}; + FStar_Syntax_Syntax.ds = uu___4; + FStar_Syntax_Syntax.injective_type_params + = injective_type_params;_}; FStar_Syntax_Syntax.sigrng = uu___5; FStar_Syntax_Syntax.sigquals = tname_quals; FStar_Syntax_Syntax.sigmeta = uu___6; @@ -7449,7 +7464,10 @@ let rec (desugar_tycon : FStar_Syntax_Syntax.num_ty_params = ntps; FStar_Syntax_Syntax.mutuals1 - = mutuals1 + = mutuals1; + FStar_Syntax_Syntax.injective_type_params1 + = + injective_type_params } in FStar_Syntax_Syntax.Sig_datacon uu___17 in @@ -7551,7 +7569,10 @@ let rec (desugar_tycon : FStar_Syntax_Syntax.mutuals = mutuals1; FStar_Syntax_Syntax.ds - = constrNames + = constrNames; + FStar_Syntax_Syntax.injective_type_params + = + injective_type_params }); FStar_Syntax_Syntax.sigrng = uu___15; @@ -7620,16 +7641,18 @@ let rec (desugar_tycon : = uu___6; FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = uu___7; - FStar_Syntax_Syntax.ds = constrs;_} + FStar_Syntax_Syntax.ds = constrs; + FStar_Syntax_Syntax.injective_type_params + = uu___8;_} -> let quals1 = se.FStar_Syntax_Syntax.sigquals in - let uu___8 = + let uu___9 = FStar_Compiler_List.filter (fun data_lid -> let data_quals = let data_se = - let uu___9 = + let uu___10 = FStar_Compiler_List.find (fun se1 -> match se1.FStar_Syntax_Syntax.sigel @@ -7639,35 +7662,37 @@ let rec (desugar_tycon : FStar_Syntax_Syntax.lid1 = name; FStar_Syntax_Syntax.us1 - = uu___10; - FStar_Syntax_Syntax.t1 = uu___11; - FStar_Syntax_Syntax.ty_lid + FStar_Syntax_Syntax.t1 = uu___12; - FStar_Syntax_Syntax.num_ty_params + FStar_Syntax_Syntax.ty_lid = uu___13; + FStar_Syntax_Syntax.num_ty_params + = uu___14; FStar_Syntax_Syntax.mutuals1 - = uu___14;_} + = uu___15; + FStar_Syntax_Syntax.injective_type_params1 + = uu___16;_} -> FStar_Ident.lid_equals name data_lid - | uu___10 -> false) + | uu___11 -> false) sigelts in FStar_Compiler_Util.must - uu___9 in + uu___10 in data_se.FStar_Syntax_Syntax.sigquals in - let uu___9 = + let uu___10 = FStar_Compiler_List.existsb - (fun uu___10 -> - match uu___10 with + (fun uu___11 -> + match uu___11 with | FStar_Syntax_Syntax.RecordConstructor - uu___11 -> true - | uu___11 -> false) + uu___12 -> true + | uu___12 -> false) data_quals in - Prims.op_Negation uu___9) + Prims.op_Negation uu___10) constrs in mk_data_discriminators quals1 env3 - uu___8 + uu___9 se.FStar_Syntax_Syntax.sigattrs | uu___5 -> []) sigelts in let ops = @@ -9111,12 +9136,14 @@ and (desugar_decl_core : FStar_Syntax_Syntax.num_ty_params = uu___6; FStar_Syntax_Syntax.mutuals1 = - uu___7;_} + uu___7; + FStar_Syntax_Syntax.injective_type_params1 + = uu___8;_} -> - let uu___8 = + let uu___9 = FStar_Syntax_Util.arrow_formals t in - (match uu___8 with - | (formals1, uu___9) -> + (match uu___9 with + | (formals1, uu___10) -> FStar_Pervasives_Native.Some formals1) | uu___3 -> FStar_Pervasives_Native.None) @@ -9136,7 +9163,8 @@ and (desugar_decl_core : FStar_Syntax_Syntax.num_uniform_params = uu___4; FStar_Syntax_Syntax.t = ty; FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6;_} + FStar_Syntax_Syntax.ds = uu___6; + FStar_Syntax_Syntax.injective_type_params = uu___7;_} -> let formals1 = match formals with @@ -9147,44 +9175,44 @@ and (desugar_decl_core : let i = FStar_Ident.ident_of_lid meth in FStar_Compiler_Util.for_some (fun formal -> - let uu___7 = + let uu___8 = FStar_Ident.ident_equals i (formal.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.ppname in - if uu___7 + if uu___8 then FStar_Compiler_Util.for_some (fun attr -> - let uu___8 = - let uu___9 = + let uu___9 = + let uu___10 = FStar_Syntax_Subst.compress attr in - uu___9.FStar_Syntax_Syntax.n in - match uu___8 with + uu___10.FStar_Syntax_Syntax.n in + match uu___9 with | FStar_Syntax_Syntax.Tm_fvar fv -> FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.no_method_lid - | uu___9 -> false) + | uu___10 -> false) formal.FStar_Syntax_Syntax.binder_attrs else false) formals1 in let meths1 = FStar_Compiler_List.filter (fun x -> - let uu___7 = has_no_method_attr x in - Prims.op_Negation uu___7) meths in + let uu___8 = has_no_method_attr x in + Prims.op_Negation uu___8) meths in let is_typed = false in - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = mkclass lid in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = mkclass lid in { FStar_Syntax_Syntax.is_typed = is_typed; FStar_Syntax_Syntax.lids2 = meths1; - FStar_Syntax_Syntax.tac = uu___10 + FStar_Syntax_Syntax.tac = uu___11 } in - FStar_Syntax_Syntax.Sig_splice uu___9 in - let uu___9 = + FStar_Syntax_Syntax.Sig_splice uu___10 in + let uu___10 = FStar_Syntax_DsEnv.opens_and_abbrevs env1 in { - FStar_Syntax_Syntax.sigel = uu___8; + FStar_Syntax_Syntax.sigel = uu___9; FStar_Syntax_Syntax.sigrng = (d.FStar_Parser_AST.drange); FStar_Syntax_Syntax.sigquals = []; @@ -9192,11 +9220,11 @@ and (desugar_decl_core : FStar_Syntax_Syntax.default_sigmeta; FStar_Syntax_Syntax.sigattrs = []; FStar_Syntax_Syntax.sigopens_and_abbrevs = - uu___9; + uu___10; FStar_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None } in - [uu___7] + [uu___8] | uu___2 -> [] in let uu___2 = if typeclass @@ -9699,7 +9727,8 @@ and (desugar_decl_core : FStar_Parser_Const.exn_lid; FStar_Syntax_Syntax.num_ty_params = Prims.int_zero; FStar_Syntax_Syntax.mutuals1 = - [FStar_Parser_Const.exn_lid] + [FStar_Parser_Const.exn_lid]; + FStar_Syntax_Syntax.injective_type_params1 = false }); FStar_Syntax_Syntax.sigrng = (d.FStar_Parser_AST.drange); FStar_Syntax_Syntax.sigquals = qual; diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Common.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Common.ml index 5e803c000c9..3f6c69c7071 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Common.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Common.ml @@ -920,893 +920,6 @@ let (lcomp_of_comp_guard : FStar_Syntax_Syntax.comp -> guard_t -> lcomp) = (fun uu___1 -> (c0, g)) let (lcomp_of_comp : FStar_Syntax_Syntax.comp -> lcomp) = fun c0 -> lcomp_of_comp_guard c0 trivial_guard -let (simplify : - Prims.bool -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun debug -> - fun tm -> - let w t = - { - FStar_Syntax_Syntax.n = (t.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = (tm.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = (t.FStar_Syntax_Syntax.hash_code) - } in - let simp_t t = - let uu___ = - let uu___1 = FStar_Syntax_Util.unmeta t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.true_lid -> - FStar_Pervasives_Native.Some true - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.false_lid -> - FStar_Pervasives_Native.Some false - | uu___1 -> FStar_Pervasives_Native.None in - let rec args_are_binders args bs = - match (args, bs) with - | ((t, uu___)::args1, b::bs1) -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_name bv' -> - (FStar_Syntax_Syntax.bv_eq b.FStar_Syntax_Syntax.binder_bv - bv') - && (args_are_binders args1 bs1) - | uu___2 -> false) - | ([], []) -> true - | (uu___, uu___1) -> false in - let is_applied bs t = - if debug - then - (let uu___1 = FStar_Syntax_Print.term_to_string t in - let uu___2 = FStar_Syntax_Print.tag_of_term t in - FStar_Compiler_Util.print2 "WPE> is_applied %s -- %s\n" uu___1 - uu___2) - else (); - (let uu___1 = FStar_Syntax_Util.head_and_args_full t in - match uu___1 with - | (hd, args) -> - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress hd in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_name bv when args_are_binders args bs - -> - (if debug - then - (let uu___4 = FStar_Syntax_Print.term_to_string t in - let uu___5 = FStar_Syntax_Print.bv_to_string bv in - let uu___6 = FStar_Syntax_Print.term_to_string hd in - FStar_Compiler_Util.print3 - "WPE> got it\n>>>>top = %s\n>>>>b = %s\n>>>>hd = %s\n" - uu___4 uu___5 uu___6) - else (); - FStar_Pervasives_Native.Some bv) - | uu___3 -> FStar_Pervasives_Native.None)) in - let is_applied_maybe_squashed bs t = - if debug - then - (let uu___1 = FStar_Syntax_Print.term_to_string t in - let uu___2 = FStar_Syntax_Print.tag_of_term t in - FStar_Compiler_Util.print2 - "WPE> is_applied_maybe_squashed %s -- %s\n" uu___1 uu___2) - else (); - (let uu___1 = FStar_Syntax_Util.is_squash t in - match uu___1 with - | FStar_Pervasives_Native.Some (uu___2, t') -> is_applied bs t' - | uu___2 -> - let uu___3 = FStar_Syntax_Util.is_auto_squash t in - (match uu___3 with - | FStar_Pervasives_Native.Some (uu___4, t') -> is_applied bs t' - | uu___4 -> is_applied bs t)) in - let is_const_match phi = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress phi in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = uu___1; - FStar_Syntax_Syntax.ret_opt = uu___2; - FStar_Syntax_Syntax.brs = br::brs; - FStar_Syntax_Syntax.rc_opt1 = uu___3;_} - -> - let uu___4 = br in - (match uu___4 with - | (uu___5, uu___6, e) -> - let r = - let uu___7 = simp_t e in - match uu___7 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some b -> - let uu___8 = - FStar_Compiler_List.for_all - (fun uu___9 -> - match uu___9 with - | (uu___10, uu___11, e') -> - let uu___12 = simp_t e' in - uu___12 = (FStar_Pervasives_Native.Some b)) - brs in - if uu___8 - then FStar_Pervasives_Native.Some b - else FStar_Pervasives_Native.None in - r) - | uu___1 -> FStar_Pervasives_Native.None in - let maybe_auto_squash t = - let uu___ = FStar_Syntax_Util.is_sub_singleton t in - if uu___ - then t - else FStar_Syntax_Util.mk_auto_squash FStar_Syntax_Syntax.U_zero t in - let squashed_head_un_auto_squash_args t = - let maybe_un_auto_squash_arg uu___ = - match uu___ with - | (t1, q) -> - let uu___1 = FStar_Syntax_Util.is_auto_squash t1 in - (match uu___1 with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.U_zero, t2) -> (t2, q) - | uu___2 -> (t1, q)) in - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (head, args) -> - let args1 = FStar_Compiler_List.map maybe_un_auto_squash_arg args in - FStar_Syntax_Syntax.mk_Tm_app head args1 - t.FStar_Syntax_Syntax.pos in - let rec clearly_inhabited ty = - let uu___ = - let uu___1 = FStar_Syntax_Util.unmeta ty in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_uinst (t, uu___1) -> clearly_inhabited t - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = uu___1; - FStar_Syntax_Syntax.comp = c;_} - -> clearly_inhabited (FStar_Syntax_Util.comp_result c) - | FStar_Syntax_Syntax.Tm_fvar fv -> - let l = FStar_Syntax_Syntax.lid_of_fv fv in - (((FStar_Ident.lid_equals l FStar_Parser_Const.int_lid) || - (FStar_Ident.lid_equals l FStar_Parser_Const.bool_lid)) - || (FStar_Ident.lid_equals l FStar_Parser_Const.string_lid)) - || (FStar_Ident.lid_equals l FStar_Parser_Const.exn_lid) - | uu___1 -> false in - let simplify1 arg = - let uu___ = simp_t (FStar_Pervasives_Native.fst arg) in (uu___, arg) in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress tm in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_uinst - ({ FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}, - uu___4); - FStar_Syntax_Syntax.pos = uu___5; - FStar_Syntax_Syntax.vars = uu___6; - FStar_Syntax_Syntax.hash_code = uu___7;_}; - FStar_Syntax_Syntax.args = args;_} - -> - let uu___8 = - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.and_lid in - if uu___8 - then - let uu___9 = FStar_Compiler_List.map simplify1 args in - (match uu___9 with - | (FStar_Pervasives_Native.Some (true), uu___10)::(uu___11, - (arg, - uu___12))::[] - -> maybe_auto_squash arg - | (uu___10, (arg, uu___11))::(FStar_Pervasives_Native.Some - (true), uu___12)::[] - -> maybe_auto_squash arg - | (FStar_Pervasives_Native.Some (false), uu___10)::uu___11::[] - -> w FStar_Syntax_Util.t_false - | uu___10::(FStar_Pervasives_Native.Some (false), uu___11)::[] - -> w FStar_Syntax_Util.t_false - | uu___10 -> squashed_head_un_auto_squash_args tm) - else - (let uu___10 = - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.or_lid in - if uu___10 - then - let uu___11 = FStar_Compiler_List.map simplify1 args in - match uu___11 with - | (FStar_Pervasives_Native.Some (true), uu___12)::uu___13::[] - -> w FStar_Syntax_Util.t_true - | uu___12::(FStar_Pervasives_Native.Some (true), uu___13)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (false), uu___12)::(uu___13, - (arg, - uu___14))::[] - -> maybe_auto_squash arg - | (uu___12, (arg, uu___13))::(FStar_Pervasives_Native.Some - (false), uu___14)::[] - -> maybe_auto_squash arg - | uu___12 -> squashed_head_un_auto_squash_args tm - else - (let uu___12 = - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.imp_lid in - if uu___12 - then - let uu___13 = FStar_Compiler_List.map simplify1 args in - match uu___13 with - | uu___14::(FStar_Pervasives_Native.Some (true), uu___15)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (false), uu___14)::uu___15::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (true), uu___14)::(uu___15, - (arg, - uu___16))::[] - -> maybe_auto_squash arg - | (uu___14, (p, uu___15))::(uu___16, (q, uu___17))::[] -> - let uu___18 = FStar_Syntax_Util.term_eq p q in - (if uu___18 - then w FStar_Syntax_Util.t_true - else squashed_head_un_auto_squash_args tm) - | uu___14 -> squashed_head_un_auto_squash_args tm - else - (let uu___14 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.iff_lid in - if uu___14 - then - let uu___15 = FStar_Compiler_List.map simplify1 args in - match uu___15 with - | (FStar_Pervasives_Native.Some (true), uu___16):: - (FStar_Pervasives_Native.Some (true), uu___17)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (false), uu___16):: - (FStar_Pervasives_Native.Some (false), uu___17)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (true), uu___16):: - (FStar_Pervasives_Native.Some (false), uu___17)::[] - -> w FStar_Syntax_Util.t_false - | (FStar_Pervasives_Native.Some (false), uu___16):: - (FStar_Pervasives_Native.Some (true), uu___17)::[] - -> w FStar_Syntax_Util.t_false - | (uu___16, (arg, uu___17))::(FStar_Pervasives_Native.Some - (true), uu___18)::[] - -> maybe_auto_squash arg - | (FStar_Pervasives_Native.Some (true), uu___16):: - (uu___17, (arg, uu___18))::[] -> - maybe_auto_squash arg - | (uu___16, (arg, uu___17))::(FStar_Pervasives_Native.Some - (false), uu___18)::[] - -> - let uu___19 = FStar_Syntax_Util.mk_neg arg in - maybe_auto_squash uu___19 - | (FStar_Pervasives_Native.Some (false), uu___16):: - (uu___17, (arg, uu___18))::[] -> - let uu___19 = FStar_Syntax_Util.mk_neg arg in - maybe_auto_squash uu___19 - | (uu___16, (p, uu___17))::(uu___18, (q, uu___19))::[] - -> - let uu___20 = FStar_Syntax_Util.term_eq p q in - (if uu___20 - then w FStar_Syntax_Util.t_true - else squashed_head_un_auto_squash_args tm) - | uu___16 -> squashed_head_un_auto_squash_args tm - else - (let uu___16 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.not_lid in - if uu___16 - then - let uu___17 = FStar_Compiler_List.map simplify1 args in - match uu___17 with - | (FStar_Pervasives_Native.Some (true), uu___18)::[] - -> w FStar_Syntax_Util.t_false - | (FStar_Pervasives_Native.Some (false), uu___18)::[] - -> w FStar_Syntax_Util.t_true - | uu___18 -> squashed_head_un_auto_squash_args tm - else - (let uu___18 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.forall_lid in - if uu___18 - then - match args with - | (t, uu___19)::[] -> - let uu___20 = - let uu___21 = FStar_Syntax_Subst.compress t in - uu___21.FStar_Syntax_Syntax.n in - (match uu___20 with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = uu___21::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___22;_} - -> - let uu___23 = simp_t body in - (match uu___23 with - | FStar_Pervasives_Native.Some (true) -> - w FStar_Syntax_Util.t_true - | uu___24 -> tm) - | uu___21 -> tm) - | (ty, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = - uu___19;_})::(t, uu___20)::[] - -> - let uu___21 = - let uu___22 = FStar_Syntax_Subst.compress t in - uu___22.FStar_Syntax_Syntax.n in - (match uu___21 with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = uu___22::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___23;_} - -> - let uu___24 = simp_t body in - (match uu___24 with - | FStar_Pervasives_Native.Some (true) -> - w FStar_Syntax_Util.t_true - | FStar_Pervasives_Native.Some (false) - when clearly_inhabited ty -> - w FStar_Syntax_Util.t_false - | uu___25 -> tm) - | uu___22 -> tm) - | uu___19 -> tm - else - (let uu___20 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.exists_lid in - if uu___20 - then - match args with - | (t, uu___21)::[] -> - let uu___22 = - let uu___23 = - FStar_Syntax_Subst.compress t in - uu___23.FStar_Syntax_Syntax.n in - (match uu___22 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = uu___23::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___24;_} - -> - let uu___25 = simp_t body in - (match uu___25 with - | FStar_Pervasives_Native.Some - (false) -> - w FStar_Syntax_Util.t_false - | uu___26 -> tm) - | uu___23 -> tm) - | (ty, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = - uu___21;_})::(t, uu___22)::[] - -> - let uu___23 = - let uu___24 = - FStar_Syntax_Subst.compress t in - uu___24.FStar_Syntax_Syntax.n in - (match uu___23 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = uu___24::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___25;_} - -> - let uu___26 = simp_t body in - (match uu___26 with - | FStar_Pervasives_Native.Some - (false) -> - w FStar_Syntax_Util.t_false - | FStar_Pervasives_Native.Some (true) - when clearly_inhabited ty -> - w FStar_Syntax_Util.t_true - | uu___27 -> tm) - | uu___24 -> tm) - | uu___21 -> tm - else - (let uu___22 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.b2t_lid in - if uu___22 - then - match args with - | ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_bool (true)); - FStar_Syntax_Syntax.pos = uu___23; - FStar_Syntax_Syntax.vars = uu___24; - FStar_Syntax_Syntax.hash_code = uu___25;_}, - uu___26)::[] -> - w FStar_Syntax_Util.t_true - | ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_bool (false)); - FStar_Syntax_Syntax.pos = uu___23; - FStar_Syntax_Syntax.vars = uu___24; - FStar_Syntax_Syntax.hash_code = uu___25;_}, - uu___26)::[] -> - w FStar_Syntax_Util.t_false - | uu___23 -> tm - else - (let uu___24 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.haseq_lid in - if uu___24 - then - let t_has_eq_for_sure t = - let haseq_lids = - [FStar_Parser_Const.int_lid; - FStar_Parser_Const.bool_lid; - FStar_Parser_Const.unit_lid; - FStar_Parser_Const.string_lid] in - let uu___25 = - let uu___26 = - FStar_Syntax_Subst.compress t in - uu___26.FStar_Syntax_Syntax.n in - match uu___25 with - | FStar_Syntax_Syntax.Tm_fvar fv1 when - FStar_Compiler_List.existsb - (fun l -> - FStar_Syntax_Syntax.fv_eq_lid - fv1 l) haseq_lids - -> true - | uu___26 -> false in - (if - (FStar_Compiler_List.length args) = - Prims.int_one - then - let t = - let uu___25 = - FStar_Compiler_List.hd args in - FStar_Pervasives_Native.fst uu___25 in - let uu___25 = t_has_eq_for_sure t in - (if uu___25 - then w FStar_Syntax_Util.t_true - else - (let uu___27 = - let uu___28 = - FStar_Syntax_Subst.compress t in - uu___28.FStar_Syntax_Syntax.n in - match uu___27 with - | FStar_Syntax_Syntax.Tm_refine - uu___28 -> - let t1 = - FStar_Syntax_Util.unrefine t in - let uu___29 = - t_has_eq_for_sure t1 in - if uu___29 - then - w FStar_Syntax_Util.t_true - else - (let haseq_tm = - let uu___31 = - let uu___32 = - FStar_Syntax_Subst.compress - tm in - uu___32.FStar_Syntax_Syntax.n in - match uu___31 with - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd - = hd; - FStar_Syntax_Syntax.args - = uu___32;_} - -> hd - | uu___32 -> - FStar_Compiler_Effect.failwith - "Impossible! We have already checked that this is a Tm_app" in - let uu___31 = - let uu___32 = - FStar_Syntax_Syntax.as_arg - t1 in - [uu___32] in - FStar_Syntax_Util.mk_app - haseq_tm uu___31) - | uu___28 -> tm)) - else tm) - else - (let uu___26 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.eq2_lid in - if uu___26 - then - match args with - | (_typ, uu___27)::(a1, uu___28):: - (a2, uu___29)::[] -> - let uu___30 = - FStar_Syntax_Util.eq_tm a1 a2 in - (match uu___30 with - | FStar_Syntax_Util.Equal -> - w FStar_Syntax_Util.t_true - | FStar_Syntax_Util.NotEqual -> - w FStar_Syntax_Util.t_false - | uu___31 -> tm) - | uu___27 -> tm - else - (let uu___28 = - FStar_Syntax_Util.is_auto_squash tm in - match uu___28 with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.U_zero, t) - when - FStar_Syntax_Util.is_sub_singleton - t - -> t - | uu___29 -> tm)))))))))) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}; - FStar_Syntax_Syntax.args = args;_} - -> - let uu___4 = - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.and_lid in - if uu___4 - then - let uu___5 = FStar_Compiler_List.map simplify1 args in - (match uu___5 with - | (FStar_Pervasives_Native.Some (true), uu___6)::(uu___7, - (arg, uu___8))::[] - -> maybe_auto_squash arg - | (uu___6, (arg, uu___7))::(FStar_Pervasives_Native.Some (true), - uu___8)::[] - -> maybe_auto_squash arg - | (FStar_Pervasives_Native.Some (false), uu___6)::uu___7::[] -> - w FStar_Syntax_Util.t_false - | uu___6::(FStar_Pervasives_Native.Some (false), uu___7)::[] -> - w FStar_Syntax_Util.t_false - | uu___6 -> squashed_head_un_auto_squash_args tm) - else - (let uu___6 = - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.or_lid in - if uu___6 - then - let uu___7 = FStar_Compiler_List.map simplify1 args in - match uu___7 with - | (FStar_Pervasives_Native.Some (true), uu___8)::uu___9::[] -> - w FStar_Syntax_Util.t_true - | uu___8::(FStar_Pervasives_Native.Some (true), uu___9)::[] -> - w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (false), uu___8)::(uu___9, - (arg, - uu___10))::[] - -> maybe_auto_squash arg - | (uu___8, (arg, uu___9))::(FStar_Pervasives_Native.Some - (false), uu___10)::[] - -> maybe_auto_squash arg - | uu___8 -> squashed_head_un_auto_squash_args tm - else - (let uu___8 = - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.imp_lid in - if uu___8 - then - let uu___9 = FStar_Compiler_List.map simplify1 args in - match uu___9 with - | uu___10::(FStar_Pervasives_Native.Some (true), uu___11)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (false), uu___10)::uu___11::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (true), uu___10)::(uu___11, - (arg, - uu___12))::[] - -> maybe_auto_squash arg - | (uu___10, (p, uu___11))::(uu___12, (q, uu___13))::[] -> - let uu___14 = FStar_Syntax_Util.term_eq p q in - (if uu___14 - then w FStar_Syntax_Util.t_true - else squashed_head_un_auto_squash_args tm) - | uu___10 -> squashed_head_un_auto_squash_args tm - else - (let uu___10 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.iff_lid in - if uu___10 - then - let uu___11 = FStar_Compiler_List.map simplify1 args in - match uu___11 with - | (FStar_Pervasives_Native.Some (true), uu___12):: - (FStar_Pervasives_Native.Some (true), uu___13)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (false), uu___12):: - (FStar_Pervasives_Native.Some (false), uu___13)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (true), uu___12):: - (FStar_Pervasives_Native.Some (false), uu___13)::[] - -> w FStar_Syntax_Util.t_false - | (FStar_Pervasives_Native.Some (false), uu___12):: - (FStar_Pervasives_Native.Some (true), uu___13)::[] - -> w FStar_Syntax_Util.t_false - | (uu___12, (arg, uu___13))::(FStar_Pervasives_Native.Some - (true), uu___14)::[] - -> maybe_auto_squash arg - | (FStar_Pervasives_Native.Some (true), uu___12):: - (uu___13, (arg, uu___14))::[] -> - maybe_auto_squash arg - | (uu___12, (arg, uu___13))::(FStar_Pervasives_Native.Some - (false), uu___14)::[] - -> - let uu___15 = FStar_Syntax_Util.mk_neg arg in - maybe_auto_squash uu___15 - | (FStar_Pervasives_Native.Some (false), uu___12):: - (uu___13, (arg, uu___14))::[] -> - let uu___15 = FStar_Syntax_Util.mk_neg arg in - maybe_auto_squash uu___15 - | (uu___12, (p, uu___13))::(uu___14, (q, uu___15))::[] - -> - let uu___16 = FStar_Syntax_Util.term_eq p q in - (if uu___16 - then w FStar_Syntax_Util.t_true - else squashed_head_un_auto_squash_args tm) - | uu___12 -> squashed_head_un_auto_squash_args tm - else - (let uu___12 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.not_lid in - if uu___12 - then - let uu___13 = FStar_Compiler_List.map simplify1 args in - match uu___13 with - | (FStar_Pervasives_Native.Some (true), uu___14)::[] - -> w FStar_Syntax_Util.t_false - | (FStar_Pervasives_Native.Some (false), uu___14)::[] - -> w FStar_Syntax_Util.t_true - | uu___14 -> squashed_head_un_auto_squash_args tm - else - (let uu___14 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.forall_lid in - if uu___14 - then - match args with - | (t, uu___15)::[] -> - let uu___16 = - let uu___17 = FStar_Syntax_Subst.compress t in - uu___17.FStar_Syntax_Syntax.n in - (match uu___16 with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = uu___17::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___18;_} - -> - let uu___19 = simp_t body in - (match uu___19 with - | FStar_Pervasives_Native.Some (true) -> - w FStar_Syntax_Util.t_true - | uu___20 -> tm) - | uu___17 -> tm) - | (ty, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = - uu___15;_})::(t, uu___16)::[] - -> - let uu___17 = - let uu___18 = FStar_Syntax_Subst.compress t in - uu___18.FStar_Syntax_Syntax.n in - (match uu___17 with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = uu___18::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___19;_} - -> - let uu___20 = simp_t body in - (match uu___20 with - | FStar_Pervasives_Native.Some (true) -> - w FStar_Syntax_Util.t_true - | FStar_Pervasives_Native.Some (false) - when clearly_inhabited ty -> - w FStar_Syntax_Util.t_false - | uu___21 -> tm) - | uu___18 -> tm) - | uu___15 -> tm - else - (let uu___16 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.exists_lid in - if uu___16 - then - match args with - | (t, uu___17)::[] -> - let uu___18 = - let uu___19 = - FStar_Syntax_Subst.compress t in - uu___19.FStar_Syntax_Syntax.n in - (match uu___18 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = uu___19::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___20;_} - -> - let uu___21 = simp_t body in - (match uu___21 with - | FStar_Pervasives_Native.Some - (false) -> - w FStar_Syntax_Util.t_false - | uu___22 -> tm) - | uu___19 -> tm) - | (ty, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = - uu___17;_})::(t, uu___18)::[] - -> - let uu___19 = - let uu___20 = - FStar_Syntax_Subst.compress t in - uu___20.FStar_Syntax_Syntax.n in - (match uu___19 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = uu___20::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___21;_} - -> - let uu___22 = simp_t body in - (match uu___22 with - | FStar_Pervasives_Native.Some - (false) -> - w FStar_Syntax_Util.t_false - | FStar_Pervasives_Native.Some (true) - when clearly_inhabited ty -> - w FStar_Syntax_Util.t_true - | uu___23 -> tm) - | uu___20 -> tm) - | uu___17 -> tm - else - (let uu___18 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.b2t_lid in - if uu___18 - then - match args with - | ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_bool (true)); - FStar_Syntax_Syntax.pos = uu___19; - FStar_Syntax_Syntax.vars = uu___20; - FStar_Syntax_Syntax.hash_code = uu___21;_}, - uu___22)::[] -> - w FStar_Syntax_Util.t_true - | ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_bool (false)); - FStar_Syntax_Syntax.pos = uu___19; - FStar_Syntax_Syntax.vars = uu___20; - FStar_Syntax_Syntax.hash_code = uu___21;_}, - uu___22)::[] -> - w FStar_Syntax_Util.t_false - | uu___19 -> tm - else - (let uu___20 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.haseq_lid in - if uu___20 - then - let t_has_eq_for_sure t = - let haseq_lids = - [FStar_Parser_Const.int_lid; - FStar_Parser_Const.bool_lid; - FStar_Parser_Const.unit_lid; - FStar_Parser_Const.string_lid] in - let uu___21 = - let uu___22 = - FStar_Syntax_Subst.compress t in - uu___22.FStar_Syntax_Syntax.n in - match uu___21 with - | FStar_Syntax_Syntax.Tm_fvar fv1 when - FStar_Compiler_List.existsb - (fun l -> - FStar_Syntax_Syntax.fv_eq_lid - fv1 l) haseq_lids - -> true - | uu___22 -> false in - (if - (FStar_Compiler_List.length args) = - Prims.int_one - then - let t = - let uu___21 = - FStar_Compiler_List.hd args in - FStar_Pervasives_Native.fst uu___21 in - let uu___21 = t_has_eq_for_sure t in - (if uu___21 - then w FStar_Syntax_Util.t_true - else - (let uu___23 = - let uu___24 = - FStar_Syntax_Subst.compress t in - uu___24.FStar_Syntax_Syntax.n in - match uu___23 with - | FStar_Syntax_Syntax.Tm_refine - uu___24 -> - let t1 = - FStar_Syntax_Util.unrefine t in - let uu___25 = - t_has_eq_for_sure t1 in - if uu___25 - then - w FStar_Syntax_Util.t_true - else - (let haseq_tm = - let uu___27 = - let uu___28 = - FStar_Syntax_Subst.compress - tm in - uu___28.FStar_Syntax_Syntax.n in - match uu___27 with - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd - = hd; - FStar_Syntax_Syntax.args - = uu___28;_} - -> hd - | uu___28 -> - FStar_Compiler_Effect.failwith - "Impossible! We have already checked that this is a Tm_app" in - let uu___27 = - let uu___28 = - FStar_Syntax_Syntax.as_arg - t1 in - [uu___28] in - FStar_Syntax_Util.mk_app - haseq_tm uu___27) - | uu___24 -> tm)) - else tm) - else - (let uu___22 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.eq2_lid in - if uu___22 - then - match args with - | (_typ, uu___23)::(a1, uu___24):: - (a2, uu___25)::[] -> - let uu___26 = - FStar_Syntax_Util.eq_tm a1 a2 in - (match uu___26 with - | FStar_Syntax_Util.Equal -> - w FStar_Syntax_Util.t_true - | FStar_Syntax_Util.NotEqual -> - w FStar_Syntax_Util.t_false - | uu___27 -> tm) - | uu___23 -> tm - else - (let uu___24 = - FStar_Syntax_Util.is_auto_squash tm in - match uu___24 with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.U_zero, t) - when - FStar_Syntax_Util.is_sub_singleton - t - -> t - | uu___25 -> tm)))))))))) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = bv; FStar_Syntax_Syntax.phi = t;_} -> - let uu___1 = simp_t t in - (match uu___1 with - | FStar_Pervasives_Native.Some (true) -> - bv.FStar_Syntax_Syntax.sort - | FStar_Pervasives_Native.Some (false) -> tm - | FStar_Pervasives_Native.None -> tm) - | FStar_Syntax_Syntax.Tm_match uu___1 -> - let uu___2 = is_const_match tm in - (match uu___2 with - | FStar_Pervasives_Native.Some (true) -> - w FStar_Syntax_Util.t_true - | FStar_Pervasives_Native.Some (false) -> - w FStar_Syntax_Util.t_false - | FStar_Pervasives_Native.None -> tm) - | uu___1 -> tm let (check_positivity_qual : Prims.bool -> FStar_Syntax_Syntax.positivity_qualifier FStar_Pervasives_Native.option diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Core.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Core.ml index ec893d12455..c4b9416044e 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Core.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Core.ml @@ -3579,8 +3579,9 @@ and (check_relation_comp : match uu___ with | (FStar_Pervasives_Native.None, uu___1) -> let uu___2 = - let uu___3 = FStar_Syntax_Util.eq_comp c0 c1 in - uu___3 = FStar_Syntax_Util.Equal in + let uu___3 = + FStar_TypeChecker_TermEqAndSimplify.eq_comp g.tcenv c0 c1 in + uu___3 = FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___2 then (fun uu___3 -> Success ((), FStar_Pervasives_Native.None)) else @@ -3642,8 +3643,9 @@ and (check_relation_comp : fail uu___10)))) | (uu___1, FStar_Pervasives_Native.None) -> let uu___2 = - let uu___3 = FStar_Syntax_Util.eq_comp c0 c1 in - uu___3 = FStar_Syntax_Util.Equal in + let uu___3 = + FStar_TypeChecker_TermEqAndSimplify.eq_comp g.tcenv c0 c1 in + uu___3 = FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___2 then (fun uu___3 -> Success ((), FStar_Pervasives_Native.None)) else diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_DMFF.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_DMFF.ml index 926fa890760..3cb3b06b329 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_DMFF.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_DMFF.ml @@ -3673,7 +3673,7 @@ and (trans_F_ : ((let uu___10 = let uu___11 = FStar_Syntax_Util.eq_aqual q q' in - uu___11 <> FStar_Syntax_Util.Equal in + Prims.op_Negation uu___11 in if uu___10 then let uu___11 = diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_DeferredImplicits.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_DeferredImplicits.ml index bd7a122b030..9f43b534223 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_DeferredImplicits.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_DeferredImplicits.ml @@ -54,7 +54,7 @@ let (uu___is_Imp : goal_type -> Prims.bool) = let (__proj__Imp__item___0 : goal_type -> FStar_Syntax_Syntax.ctx_uvar) = fun projectee -> match projectee with | Imp _0 -> _0 let (find_user_tac_for_uvar : - FStar_TypeChecker_Env.env -> + FStar_TypeChecker_Env.env_t -> FStar_Syntax_Syntax.ctx_uvar -> FStar_Syntax_Syntax.sigelt FStar_Pervasives_Native.option) = @@ -120,7 +120,8 @@ let (find_user_tac_for_uvar : let candidates = FStar_Compiler_List.filter (fun hook -> - FStar_Compiler_Util.for_some (FStar_Syntax_Util.attr_eq a) + FStar_Compiler_Util.for_some + (FStar_TypeChecker_TermEqAndSimplify.eq_tm_bool env a) hook.FStar_Syntax_Syntax.sigattrs) hooks in let candidates1 = FStar_Compiler_Util.remove_dups @@ -156,7 +157,9 @@ let (find_user_tac_for_uvar : when (FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.override_resolve_implicits_handler_lid) - && (FStar_Syntax_Util.attr_eq a a') + && + (FStar_TypeChecker_TermEqAndSimplify.eq_tm_bool + env a a') -> let uu___5 = attr_list_elements overrides in (match uu___5 with @@ -174,7 +177,9 @@ let (find_user_tac_for_uvar : (a', uu___2)::(overrides, uu___3)::[]) when (FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.override_resolve_implicits_handler_lid) - && (FStar_Syntax_Util.attr_eq a a') + && + (FStar_TypeChecker_TermEqAndSimplify.eq_tm_bool + env a a') -> let uu___4 = attr_list_elements overrides in (match uu___4 with diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Env.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Env.ml index c0f4329182e..7958787df72 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Env.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Env.ml @@ -3141,18 +3141,19 @@ let (try_lookup_lid_aux : FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___2; FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4;_}; - FStar_Syntax_Syntax.sigrng = uu___5; - FStar_Syntax_Syntax.sigquals = uu___6; - FStar_Syntax_Syntax.sigmeta = uu___7; - FStar_Syntax_Syntax.sigattrs = uu___8; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; - FStar_Syntax_Syntax.sigopts = uu___10;_}, + FStar_Syntax_Syntax.mutuals1 = uu___4; + FStar_Syntax_Syntax.injective_type_params1 = uu___5;_}; + FStar_Syntax_Syntax.sigrng = uu___6; + FStar_Syntax_Syntax.sigquals = uu___7; + FStar_Syntax_Syntax.sigmeta = uu___8; + FStar_Syntax_Syntax.sigattrs = uu___9; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___10; + FStar_Syntax_Syntax.sigopts = uu___11;_}, FStar_Pervasives_Native.None) -> - let uu___11 = - let uu___12 = inst_tscheme1 (uvs, t) in (uu___12, rng) in - FStar_Pervasives_Native.Some uu___11 + let uu___12 = + let uu___13 = inst_tscheme1 (uvs, t) in (uu___13, rng) in + FStar_Pervasives_Native.Some uu___12 | FStar_Pervasives.Inr ({ FStar_Syntax_Syntax.sigel = @@ -3196,32 +3197,33 @@ let (try_lookup_lid_aux : FStar_Syntax_Syntax.num_uniform_params = uu___1; FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = uu___2; - FStar_Syntax_Syntax.ds = uu___3;_}; - FStar_Syntax_Syntax.sigrng = uu___4; - FStar_Syntax_Syntax.sigquals = uu___5; - FStar_Syntax_Syntax.sigmeta = uu___6; - FStar_Syntax_Syntax.sigattrs = uu___7; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___8; - FStar_Syntax_Syntax.sigopts = uu___9;_}, + FStar_Syntax_Syntax.ds = uu___3; + FStar_Syntax_Syntax.injective_type_params = uu___4;_}; + FStar_Syntax_Syntax.sigrng = uu___5; + FStar_Syntax_Syntax.sigquals = uu___6; + FStar_Syntax_Syntax.sigmeta = uu___7; + FStar_Syntax_Syntax.sigattrs = uu___8; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; + FStar_Syntax_Syntax.sigopts = uu___10;_}, FStar_Pervasives_Native.None) -> (match tps with | [] -> - let uu___10 = - let uu___11 = inst_tscheme1 (uvs, k) in - (uu___11, rng) in - FStar_Pervasives_Native.Some uu___10 - | uu___10 -> let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = FStar_Syntax_Syntax.mk_Total k in - FStar_Syntax_Util.flat_arrow tps uu___15 in - (uvs, uu___14) in - inst_tscheme1 uu___13 in + let uu___12 = inst_tscheme1 (uvs, k) in (uu___12, rng) in - FStar_Pervasives_Native.Some uu___11) + FStar_Pervasives_Native.Some uu___11 + | uu___11 -> + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = FStar_Syntax_Syntax.mk_Total k in + FStar_Syntax_Util.flat_arrow tps uu___16 in + (uvs, uu___15) in + inst_tscheme1 uu___14 in + (uu___13, rng) in + FStar_Pervasives_Native.Some uu___12) | FStar_Pervasives.Inr ({ FStar_Syntax_Syntax.sigel = @@ -3232,32 +3234,33 @@ let (try_lookup_lid_aux : FStar_Syntax_Syntax.num_uniform_params = uu___1; FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = uu___2; - FStar_Syntax_Syntax.ds = uu___3;_}; - FStar_Syntax_Syntax.sigrng = uu___4; - FStar_Syntax_Syntax.sigquals = uu___5; - FStar_Syntax_Syntax.sigmeta = uu___6; - FStar_Syntax_Syntax.sigattrs = uu___7; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___8; - FStar_Syntax_Syntax.sigopts = uu___9;_}, + FStar_Syntax_Syntax.ds = uu___3; + FStar_Syntax_Syntax.injective_type_params = uu___4;_}; + FStar_Syntax_Syntax.sigrng = uu___5; + FStar_Syntax_Syntax.sigquals = uu___6; + FStar_Syntax_Syntax.sigmeta = uu___7; + FStar_Syntax_Syntax.sigattrs = uu___8; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; + FStar_Syntax_Syntax.sigopts = uu___10;_}, FStar_Pervasives_Native.Some us) -> (match tps with | [] -> - let uu___10 = - let uu___11 = inst_tscheme_with (uvs, k) us in - (uu___11, rng) in - FStar_Pervasives_Native.Some uu___10 - | uu___10 -> let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = FStar_Syntax_Syntax.mk_Total k in - FStar_Syntax_Util.flat_arrow tps uu___15 in - (uvs, uu___14) in - inst_tscheme_with uu___13 us in + let uu___12 = inst_tscheme_with (uvs, k) us in (uu___12, rng) in - FStar_Pervasives_Native.Some uu___11) + FStar_Pervasives_Native.Some uu___11 + | uu___11 -> + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = FStar_Syntax_Syntax.mk_Total k in + FStar_Syntax_Util.flat_arrow tps uu___16 in + (uvs, uu___15) in + inst_tscheme_with uu___14 us in + (uu___13, rng) in + FStar_Pervasives_Native.Some uu___12) | FStar_Pervasives.Inr se -> let uu___1 = match se with @@ -3481,18 +3484,19 @@ let (lookup_datacon : FStar_Syntax_Syntax.us1 = uvs; FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___2; FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4;_}; - FStar_Syntax_Syntax.sigrng = uu___5; - FStar_Syntax_Syntax.sigquals = uu___6; - FStar_Syntax_Syntax.sigmeta = uu___7; - FStar_Syntax_Syntax.sigattrs = uu___8; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; - FStar_Syntax_Syntax.sigopts = uu___10;_}, + FStar_Syntax_Syntax.mutuals1 = uu___4; + FStar_Syntax_Syntax.injective_type_params1 = uu___5;_}; + FStar_Syntax_Syntax.sigrng = uu___6; + FStar_Syntax_Syntax.sigquals = uu___7; + FStar_Syntax_Syntax.sigmeta = uu___8; + FStar_Syntax_Syntax.sigattrs = uu___9; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___10; + FStar_Syntax_Syntax.sigopts = uu___11;_}, FStar_Pervasives_Native.None), - uu___11) + uu___12) -> - let uu___12 = FStar_Ident.range_of_lid lid in - inst_tscheme_with_range uu___12 (uvs, t) + let uu___13 = FStar_Ident.range_of_lid lid in + inst_tscheme_with_range uu___13 (uvs, t) | uu___1 -> let uu___2 = name_not_found lid in let uu___3 = FStar_Ident.range_of_lid lid in @@ -3516,18 +3520,19 @@ let (lookup_and_inst_datacon : FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___2; FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4;_}; - FStar_Syntax_Syntax.sigrng = uu___5; - FStar_Syntax_Syntax.sigquals = uu___6; - FStar_Syntax_Syntax.sigmeta = uu___7; - FStar_Syntax_Syntax.sigattrs = uu___8; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; - FStar_Syntax_Syntax.sigopts = uu___10;_}, + FStar_Syntax_Syntax.mutuals1 = uu___4; + FStar_Syntax_Syntax.injective_type_params1 = uu___5;_}; + FStar_Syntax_Syntax.sigrng = uu___6; + FStar_Syntax_Syntax.sigquals = uu___7; + FStar_Syntax_Syntax.sigmeta = uu___8; + FStar_Syntax_Syntax.sigattrs = uu___9; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___10; + FStar_Syntax_Syntax.sigopts = uu___11;_}, FStar_Pervasives_Native.None), - uu___11) + uu___12) -> - let uu___12 = inst_tscheme_with (uvs, t) us in - FStar_Pervasives_Native.snd uu___12 + let uu___13 = inst_tscheme_with (uvs, t) us in + FStar_Pervasives_Native.snd uu___13 | uu___1 -> let uu___2 = name_not_found lid in let uu___3 = FStar_Ident.range_of_lid lid in @@ -3550,7 +3555,34 @@ let (datacons_of_typ : FStar_Syntax_Syntax.num_uniform_params = uu___4; FStar_Syntax_Syntax.t = uu___5; FStar_Syntax_Syntax.mutuals = uu___6; - FStar_Syntax_Syntax.ds = dcs;_}; + FStar_Syntax_Syntax.ds = dcs; + FStar_Syntax_Syntax.injective_type_params = uu___7;_}; + FStar_Syntax_Syntax.sigrng = uu___8; + FStar_Syntax_Syntax.sigquals = uu___9; + FStar_Syntax_Syntax.sigmeta = uu___10; + FStar_Syntax_Syntax.sigattrs = uu___11; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___12; + FStar_Syntax_Syntax.sigopts = uu___13;_}, + uu___14), + uu___15) + -> (true, dcs) + | uu___1 -> (false, []) +let (typ_of_datacon : env -> FStar_Ident.lident -> FStar_Ident.lident) = + fun env1 -> + fun lid -> + let uu___ = lookup_qname env1 lid in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_datacon + { FStar_Syntax_Syntax.lid1 = uu___1; + FStar_Syntax_Syntax.us1 = uu___2; + FStar_Syntax_Syntax.t1 = uu___3; + FStar_Syntax_Syntax.ty_lid = l; + FStar_Syntax_Syntax.num_ty_params = uu___4; + FStar_Syntax_Syntax.mutuals1 = uu___5; + FStar_Syntax_Syntax.injective_type_params1 = uu___6;_}; FStar_Syntax_Syntax.sigrng = uu___7; FStar_Syntax_Syntax.sigquals = uu___8; FStar_Syntax_Syntax.sigmeta = uu___9; @@ -3559,9 +3591,14 @@ let (datacons_of_typ : FStar_Syntax_Syntax.sigopts = uu___12;_}, uu___13), uu___14) - -> (true, dcs) - | uu___1 -> (false, []) -let (typ_of_datacon : env -> FStar_Ident.lident -> FStar_Ident.lident) = + -> l + | uu___1 -> + let uu___2 = + let uu___3 = FStar_Syntax_Print.lid_to_string lid in + FStar_Compiler_Util.format1 "Not a datacon: %s" uu___3 in + FStar_Compiler_Effect.failwith uu___2 +let (num_datacon_non_injective_ty_params : + env -> FStar_Ident.lident -> Prims.int FStar_Pervasives_Native.option) = fun env1 -> fun lid -> let uu___ = lookup_qname env1 lid in @@ -3573,9 +3610,11 @@ let (typ_of_datacon : env -> FStar_Ident.lident -> FStar_Ident.lident) = { FStar_Syntax_Syntax.lid1 = uu___1; FStar_Syntax_Syntax.us1 = uu___2; FStar_Syntax_Syntax.t1 = uu___3; - FStar_Syntax_Syntax.ty_lid = l; - FStar_Syntax_Syntax.num_ty_params = uu___4; - FStar_Syntax_Syntax.mutuals1 = uu___5;_}; + FStar_Syntax_Syntax.ty_lid = uu___4; + FStar_Syntax_Syntax.num_ty_params = num_ty_params; + FStar_Syntax_Syntax.mutuals1 = uu___5; + FStar_Syntax_Syntax.injective_type_params1 = + injective_type_params;_}; FStar_Syntax_Syntax.sigrng = uu___6; FStar_Syntax_Syntax.sigquals = uu___7; FStar_Syntax_Syntax.sigmeta = uu___8; @@ -3584,12 +3623,11 @@ let (typ_of_datacon : env -> FStar_Ident.lident -> FStar_Ident.lident) = FStar_Syntax_Syntax.sigopts = uu___11;_}, uu___12), uu___13) - -> l - | uu___1 -> - let uu___2 = - let uu___3 = FStar_Syntax_Print.lid_to_string lid in - FStar_Compiler_Util.format1 "Not a datacon: %s" uu___3 in - FStar_Compiler_Effect.failwith uu___2 + -> + if injective_type_params + then FStar_Pervasives_Native.Some Prims.int_zero + else FStar_Pervasives_Native.Some num_ty_params + | uu___1 -> FStar_Pervasives_Native.None let (lookup_definition_qninfo_aux : Prims.bool -> delta_level Prims.list -> @@ -4427,15 +4465,16 @@ let (num_inductive_ty_params : FStar_Syntax_Syntax.num_uniform_params = uu___3; FStar_Syntax_Syntax.t = uu___4; FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6;_}; - FStar_Syntax_Syntax.sigrng = uu___7; - FStar_Syntax_Syntax.sigquals = uu___8; - FStar_Syntax_Syntax.sigmeta = uu___9; - FStar_Syntax_Syntax.sigattrs = uu___10; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___11; - FStar_Syntax_Syntax.sigopts = uu___12;_}, - uu___13), - uu___14) + FStar_Syntax_Syntax.ds = uu___6; + FStar_Syntax_Syntax.injective_type_params = uu___7;_}; + FStar_Syntax_Syntax.sigrng = uu___8; + FStar_Syntax_Syntax.sigquals = uu___9; + FStar_Syntax_Syntax.sigmeta = uu___10; + FStar_Syntax_Syntax.sigattrs = uu___11; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___12; + FStar_Syntax_Syntax.sigopts = uu___13;_}, + uu___14), + uu___15) -> FStar_Pervasives_Native.Some (FStar_Compiler_List.length tps) | uu___1 -> FStar_Pervasives_Native.None let (num_inductive_uniform_ty_params : @@ -4455,27 +4494,28 @@ let (num_inductive_uniform_ty_params : FStar_Syntax_Syntax.num_uniform_params = num_uniform; FStar_Syntax_Syntax.t = uu___4; FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6;_}; - FStar_Syntax_Syntax.sigrng = uu___7; - FStar_Syntax_Syntax.sigquals = uu___8; - FStar_Syntax_Syntax.sigmeta = uu___9; - FStar_Syntax_Syntax.sigattrs = uu___10; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___11; - FStar_Syntax_Syntax.sigopts = uu___12;_}, - uu___13), - uu___14) + FStar_Syntax_Syntax.ds = uu___6; + FStar_Syntax_Syntax.injective_type_params = uu___7;_}; + FStar_Syntax_Syntax.sigrng = uu___8; + FStar_Syntax_Syntax.sigquals = uu___9; + FStar_Syntax_Syntax.sigmeta = uu___10; + FStar_Syntax_Syntax.sigattrs = uu___11; + FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___12; + FStar_Syntax_Syntax.sigopts = uu___13;_}, + uu___14), + uu___15) -> (match num_uniform with | FStar_Pervasives_Native.None -> - let uu___15 = - let uu___16 = - let uu___17 = FStar_Ident.string_of_lid lid in + let uu___16 = + let uu___17 = + let uu___18 = FStar_Ident.string_of_lid lid in FStar_Compiler_Util.format1 "Internal error: Inductive %s is not decorated with its uniform type parameters" - uu___17 in - (FStar_Errors_Codes.Fatal_UnexpectedInductivetype, uu___16) in - let uu___16 = FStar_Ident.range_of_lid lid in - FStar_Errors.raise_error uu___15 uu___16 + uu___18 in + (FStar_Errors_Codes.Fatal_UnexpectedInductivetype, uu___17) in + let uu___17 = FStar_Ident.range_of_lid lid in + FStar_Errors.raise_error uu___16 uu___17 | FStar_Pervasives_Native.Some n -> FStar_Pervasives_Native.Some n) | uu___1 -> FStar_Pervasives_Native.None let (effect_decl_opt : diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize.ml index 45c3aa2d80c..2714cff0163 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize.ml @@ -1582,7 +1582,10 @@ let (reduce_equality : fun norm_cb -> fun cfg -> fun tm -> - reduce_primops norm_cb + let uu___ = + let uu___1 = + FStar_TypeChecker_Cfg.equality_ops + cfg.FStar_TypeChecker_Cfg.tcenv in { FStar_TypeChecker_Cfg.steps = { @@ -1652,8 +1655,7 @@ let (reduce_equality : FStar_TypeChecker_Cfg.debug = (cfg.FStar_TypeChecker_Cfg.debug); FStar_TypeChecker_Cfg.delta_level = (cfg.FStar_TypeChecker_Cfg.delta_level); - FStar_TypeChecker_Cfg.primitive_steps = - FStar_TypeChecker_Cfg.equality_ops; + FStar_TypeChecker_Cfg.primitive_steps = uu___1; FStar_TypeChecker_Cfg.strong = (cfg.FStar_TypeChecker_Cfg.strong); FStar_TypeChecker_Cfg.memoize_lazy = (cfg.FStar_TypeChecker_Cfg.memoize_lazy); @@ -1663,7 +1665,8 @@ let (reduce_equality : (cfg.FStar_TypeChecker_Cfg.reifying); FStar_TypeChecker_Cfg.compat_memo_ignore_cfg = (cfg.FStar_TypeChecker_Cfg.compat_memo_ignore_cfg) - } tm + } in + reduce_primops norm_cb uu___ tm type norm_request_t = | Norm_request_none | Norm_request_ready @@ -4970,7 +4973,8 @@ and (do_reify_monadic : (let maybe_range_arg = let uu___12 = FStar_Compiler_Util.for_some - (FStar_Syntax_Util.attr_eq + (FStar_TypeChecker_TermEqAndSimplify.eq_tm_bool + cfg.FStar_TypeChecker_Cfg.tcenv FStar_Syntax_Util.dm4f_bind_range_attr) ed.FStar_Syntax_Syntax.eff_attrs in if uu___12 @@ -6418,10 +6422,12 @@ and (maybe_simplify_aux : -> (t, false) | uu___32 -> let uu___33 = - norm_cb cfg in - reduce_equality - uu___33 cfg - env1 tm1)))))))))) + let uu___34 = + norm_cb cfg in + reduce_equality + uu___34 cfg + env1 in + uu___33 tm1)))))))))) | FStar_Syntax_Syntax.Tm_app { FStar_Syntax_Syntax.hd = @@ -6963,10 +6969,12 @@ and (maybe_simplify_aux : -> (t, false) | uu___28 -> let uu___29 = - norm_cb cfg in - reduce_equality - uu___29 cfg - env1 tm1)))))))))) + let uu___30 = + norm_cb cfg in + reduce_equality + uu___30 cfg + env1 in + uu___29 tm1)))))))))) | FStar_Syntax_Syntax.Tm_refine { FStar_Syntax_Syntax.b = bv; FStar_Syntax_Syntax.phi = t;_} @@ -8993,7 +9001,8 @@ let rec (elim_uvars : FStar_Syntax_Syntax.params = binders; FStar_Syntax_Syntax.num_uniform_params = num_uniform; FStar_Syntax_Syntax.t = typ; FStar_Syntax_Syntax.mutuals = lids; - FStar_Syntax_Syntax.ds = lids';_} + FStar_Syntax_Syntax.ds = lids'; + FStar_Syntax_Syntax.injective_type_params = injective_type_params;_} -> let uu___ = elim_uvars_aux_t env1 univ_names binders typ in (match uu___ with @@ -9008,7 +9017,9 @@ let rec (elim_uvars : FStar_Syntax_Syntax.num_uniform_params = num_uniform; FStar_Syntax_Syntax.t = typ1; FStar_Syntax_Syntax.mutuals = lids; - FStar_Syntax_Syntax.ds = lids' + FStar_Syntax_Syntax.ds = lids'; + FStar_Syntax_Syntax.injective_type_params = + injective_type_params }); FStar_Syntax_Syntax.sigrng = (s1.FStar_Syntax_Syntax.sigrng); FStar_Syntax_Syntax.sigquals = @@ -9050,7 +9061,9 @@ let rec (elim_uvars : FStar_Syntax_Syntax.t1 = typ; FStar_Syntax_Syntax.ty_lid = lident; FStar_Syntax_Syntax.num_ty_params = i; - FStar_Syntax_Syntax.mutuals1 = lids;_} + FStar_Syntax_Syntax.mutuals1 = lids; + FStar_Syntax_Syntax.injective_type_params1 = + injective_type_params;_} -> let uu___ = elim_uvars_aux_t env1 univ_names [] typ in (match uu___ with @@ -9064,7 +9077,9 @@ let rec (elim_uvars : FStar_Syntax_Syntax.t1 = typ1; FStar_Syntax_Syntax.ty_lid = lident; FStar_Syntax_Syntax.num_ty_params = i; - FStar_Syntax_Syntax.mutuals1 = lids + FStar_Syntax_Syntax.mutuals1 = lids; + FStar_Syntax_Syntax.injective_type_params1 = + injective_type_params }); FStar_Syntax_Syntax.sigrng = (s1.FStar_Syntax_Syntax.sigrng); FStar_Syntax_Syntax.sigquals = @@ -9629,7 +9644,7 @@ let (get_n_binders : FStar_Syntax_Syntax.term -> (FStar_Syntax_Syntax.binder Prims.list * FStar_Syntax_Syntax.comp)) = fun env1 -> fun n -> fun t -> get_n_binders' env1 [] n t -let (uu___3791 : unit) = +let (uu___3793 : unit) = FStar_Compiler_Effect.op_Colon_Equals __get_n_binders get_n_binders' let (maybe_unfold_head_fv : FStar_TypeChecker_Env.env -> diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Rel.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Rel.ml index b0078c87d6e..2eee3bc57e6 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Rel.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Rel.ml @@ -3226,8 +3226,10 @@ let (head_matches_delta : "FStar.TypeChecker.Rel.norm_with_steps.1" steps env t in let uu___4 = - let uu___5 = FStar_Syntax_Util.eq_tm t t' in - uu___5 = FStar_Syntax_Util.Equal in + let uu___5 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t + t' in + uu___5 = FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___4 then FStar_Pervasives_Native.None else @@ -3269,8 +3271,10 @@ let (head_matches_delta : match uu___ with | (head, head') -> let uu___1 = - let uu___2 = FStar_Syntax_Util.eq_tm head head' in - uu___2 = FStar_Syntax_Util.Equal in + let uu___2 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env head + head' in + uu___2 = FStar_TypeChecker_TermEqAndSimplify.Equal in Prims.op_Negation uu___1 in let rec aux retry n_delta t11 t21 = let r = head_matches env t11 t21 in @@ -6563,8 +6567,7 @@ and (solve_binders : match (a1, a2) with | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit b1), FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Implicit b2)) -> - FStar_Syntax_Util.Equal + (FStar_Syntax_Syntax.Implicit b2)) -> true | uu___1 -> FStar_Syntax_Util.eq_bqual a1 a2 in let compat_positivity_qualifiers p1 p2 = match p_rel orig with @@ -6591,10 +6594,9 @@ and (solve_binders : (let formula = p_guard rhs_prob in ((FStar_Pervasives.Inl ([rhs_prob], formula)), wl2)))) | (x::xs1, y::ys1) when - (let uu___1 = - eq_bqual x.FStar_Syntax_Syntax.binder_qual - y.FStar_Syntax_Syntax.binder_qual in - uu___1 = FStar_Syntax_Util.Equal) && + (eq_bqual x.FStar_Syntax_Syntax.binder_qual + y.FStar_Syntax_Syntax.binder_qual) + && (compat_positivity_qualifiers x.FStar_Syntax_Syntax.binder_positivity y.FStar_Syntax_Syntax.binder_positivity) @@ -6862,8 +6864,10 @@ and (solve_t_flex_rigid_eq : (fun x -> fun y -> let uu___7 = - FStar_Syntax_Util.eq_tm x y in - uu___7 = FStar_Syntax_Util.Equal) + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env x y in + uu___7 = + FStar_TypeChecker_TermEqAndSimplify.Equal) b.FStar_Syntax_Syntax.binder_attrs a.FStar_Syntax_Syntax.aqual_attributes) | uu___6 -> false in @@ -7566,10 +7570,10 @@ and (solve_t_flex_rigid_eq : let uu___17 = FStar_Syntax_Util.ctx_uvar_typ ctx_uv in - FStar_Syntax_Util.eq_tm - t_head uu___17 in + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env t_head uu___17 in uu___16 = - FStar_Syntax_Util.Equal in + FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___15 then solve_sub_probs_if_head_types_equal @@ -8235,8 +8239,10 @@ and (solve_t' : tprob -> worklist -> solution) = else (let uu___5 = (nargs = Prims.int_zero) || - (let uu___6 = FStar_Syntax_Util.eq_args args1 args2 in - uu___6 = FStar_Syntax_Util.Equal) in + (let uu___6 = + FStar_TypeChecker_TermEqAndSimplify.eq_args env + args1 args2 in + uu___6 = FStar_TypeChecker_TermEqAndSimplify.Equal) in if uu___5 then (if need_unif1 @@ -8440,19 +8446,21 @@ and (solve_t' : tprob -> worklist -> solution) = -> let uu___16 = let uu___17 = - FStar_Syntax_Util.eq_tm + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env1 head1' head1 in let uu___18 = - FStar_Syntax_Util.eq_tm + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env1 head2' head2 in (uu___17, uu___18) in (match uu___16 with - | (FStar_Syntax_Util.Equal, - FStar_Syntax_Util.Equal) + | (FStar_TypeChecker_TermEqAndSimplify.Equal, + FStar_TypeChecker_TermEqAndSimplify.Equal) -> ((let uu___18 = @@ -10734,11 +10742,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -10746,7 +10756,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -10755,8 +10764,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -10885,11 +10896,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -10897,7 +10910,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -10906,8 +10918,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -11036,11 +11050,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -11048,7 +11064,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -11057,8 +11072,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -11187,11 +11204,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -11199,7 +11218,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -11208,8 +11226,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -11338,11 +11358,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -11350,7 +11372,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -11359,8 +11380,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -11489,11 +11512,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -11501,7 +11526,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -11510,8 +11534,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -11640,11 +11666,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -11652,7 +11680,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -11661,8 +11688,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -11791,11 +11820,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -11803,7 +11834,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -11812,8 +11842,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -11942,11 +11974,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -11954,7 +11988,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -11963,8 +11996,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -12093,11 +12128,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -12105,7 +12142,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -12114,8 +12150,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -12244,11 +12282,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -12256,7 +12296,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -12265,8 +12304,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) @@ -12395,11 +12436,13 @@ and (solve_t' : tprob -> worklist -> solution) = uu___11 else ()); (let equal t11 t21 = - let r = FStar_Syntax_Util.eq_tm t11 t21 in + let env = p_env wl orig in + let r = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in match r with - | FStar_Syntax_Util.Equal -> true - | FStar_Syntax_Util.NotEqual -> false - | FStar_Syntax_Util.Unknown -> + | FStar_TypeChecker_TermEqAndSimplify.Equal -> true + | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStar_TypeChecker_TermEqAndSimplify.Unknown -> let steps = [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; @@ -12407,7 +12450,6 @@ and (solve_t' : tprob -> worklist -> solution) = FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Eager_unfolding; FStar_TypeChecker_Env.Iota] in - let env = p_env wl orig in let t12 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps @@ -12416,8 +12458,10 @@ and (solve_t' : tprob -> worklist -> solution) = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t21 in - let uu___10 = FStar_Syntax_Util.eq_tm t12 t22 in - uu___10 = FStar_Syntax_Util.Equal in + let uu___10 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in let uu___10 = ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcInductive.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcInductive.ml index 58240a147d0..64ba6339849 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcInductive.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcInductive.ml @@ -5,6 +5,288 @@ let (unfold_whnf : = FStar_TypeChecker_Normalize.unfold_whnf' [FStar_TypeChecker_Env.AllowUnboundUniverses] +let (check_sig_inductive_injectivity_on_params : + FStar_TypeChecker_Env.env_t -> + FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.sigelt) + = + fun tcenv -> + fun se -> + if tcenv.FStar_TypeChecker_Env.phase1 + then se + else + (let uu___1 = se.FStar_Syntax_Syntax.sigel in + match uu___1 with + | FStar_Syntax_Syntax.Sig_inductive_typ dd -> + let uu___2 = dd in + (match uu___2 with + | { FStar_Syntax_Syntax.lid = t; + FStar_Syntax_Syntax.us = universe_names; + FStar_Syntax_Syntax.params = tps; + FStar_Syntax_Syntax.num_uniform_params = uu___3; + FStar_Syntax_Syntax.t = k; + FStar_Syntax_Syntax.mutuals = uu___4; + FStar_Syntax_Syntax.ds = uu___5; + FStar_Syntax_Syntax.injective_type_params = uu___6;_} -> + let t_lid = t in + let uu___7 = + FStar_Syntax_Subst.univ_var_opening universe_names in + (match uu___7 with + | (usubst, uvs) -> + let uu___8 = + let uu___9 = + FStar_TypeChecker_Env.push_univ_vars tcenv uvs in + let uu___10 = + FStar_Syntax_Subst.subst_binders usubst tps in + let uu___11 = + let uu___12 = + FStar_Syntax_Subst.shift_subst + (FStar_Compiler_List.length tps) usubst in + FStar_Syntax_Subst.subst uu___12 k in + (uu___9, uu___10, uu___11) in + (match uu___8 with + | (tcenv1, tps1, k1) -> + let uu___9 = FStar_Syntax_Subst.open_term tps1 k1 in + (match uu___9 with + | (tps2, k2) -> + let uu___10 = + FStar_Syntax_Util.arrow_formals k2 in + (match uu___10 with + | (uu___11, k3) -> + let uu___12 = + FStar_TypeChecker_TcTerm.tc_binders + tcenv1 tps2 in + (match uu___12 with + | (tps3, env_tps, uu___13, us) -> + let u_k = + let uu___14 = + let uu___15 = + FStar_Syntax_Syntax.fvar t + FStar_Pervasives_Native.None in + let uu___16 = + let uu___17 = + FStar_Syntax_Util.args_of_binders + tps3 in + FStar_Pervasives_Native.snd + uu___17 in + let uu___17 = + FStar_Ident.range_of_lid t in + FStar_Syntax_Syntax.mk_Tm_app + uu___15 uu___16 uu___17 in + FStar_TypeChecker_TcTerm.level_of_type + env_tps uu___14 k3 in + let rec universe_leq u v = + match (u, v) with + | (FStar_Syntax_Syntax.U_zero, + uu___14) -> true + | (FStar_Syntax_Syntax.U_succ + u0, + FStar_Syntax_Syntax.U_succ + v0) -> universe_leq u0 v0 + | (FStar_Syntax_Syntax.U_name + u0, + FStar_Syntax_Syntax.U_name + v0) -> + FStar_Ident.ident_equals u0 + v0 + | (FStar_Syntax_Syntax.U_name + uu___14, + FStar_Syntax_Syntax.U_succ + v0) -> universe_leq u v0 + | (FStar_Syntax_Syntax.U_max + us1, uu___14) -> + FStar_Compiler_Util.for_all + (fun u1 -> + universe_leq u1 v) us1 + | (uu___14, + FStar_Syntax_Syntax.U_max vs) + -> + FStar_Compiler_Util.for_some + (universe_leq u) vs + | (FStar_Syntax_Syntax.U_unknown, + uu___14) -> + let uu___15 = + let uu___16 = + FStar_Ident.string_of_lid + t in + let uu___17 = + FStar_Syntax_Print.univ_to_string + u in + let uu___18 = + FStar_Syntax_Print.univ_to_string + v in + FStar_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___16 uu___17 uu___18 in + FStar_Compiler_Effect.failwith + uu___15 + | (uu___14, + FStar_Syntax_Syntax.U_unknown) + -> + let uu___15 = + let uu___16 = + FStar_Ident.string_of_lid + t in + let uu___17 = + FStar_Syntax_Print.univ_to_string + u in + let uu___18 = + FStar_Syntax_Print.univ_to_string + v in + FStar_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___16 uu___17 uu___18 in + FStar_Compiler_Effect.failwith + uu___15 + | (FStar_Syntax_Syntax.U_unif + uu___14, uu___15) -> + let uu___16 = + let uu___17 = + FStar_Ident.string_of_lid + t in + let uu___18 = + FStar_Syntax_Print.univ_to_string + u in + let uu___19 = + FStar_Syntax_Print.univ_to_string + v in + FStar_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___17 uu___18 uu___19 in + FStar_Compiler_Effect.failwith + uu___16 + | (uu___14, + FStar_Syntax_Syntax.U_unif + uu___15) -> + let uu___16 = + let uu___17 = + FStar_Ident.string_of_lid + t in + let uu___18 = + FStar_Syntax_Print.univ_to_string + u in + let uu___19 = + FStar_Syntax_Print.univ_to_string + v in + FStar_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___17 uu___18 uu___19 in + FStar_Compiler_Effect.failwith + uu___16 + | uu___14 -> false in + let u_leq_u_k u = + let u1 = + FStar_TypeChecker_Normalize.normalize_universe + env_tps u in + universe_leq u1 u_k in + let tp_ok tp u_tp = + let t_tp = + (tp.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in + let uu___14 = u_leq_u_k u_tp in + if uu___14 + then true + else + (let t_tp1 = + FStar_TypeChecker_Normalize.normalize + [FStar_TypeChecker_Env.Unrefine; + FStar_TypeChecker_Env.Unascribe; + FStar_TypeChecker_Env.Unmeta; + FStar_TypeChecker_Env.Primops; + FStar_TypeChecker_Env.HNF; + FStar_TypeChecker_Env.UnfoldUntil + FStar_Syntax_Syntax.delta_constant; + FStar_TypeChecker_Env.Beta] + env_tps t_tp in + let uu___16 = + FStar_Syntax_Util.arrow_formals + t_tp1 in + match uu___16 with + | (formals, t1) -> + let uu___17 = + FStar_TypeChecker_TcTerm.tc_binders + env_tps formals in + (match uu___17 with + | (uu___18, uu___19, + uu___20, u_formals) + -> + let inj = + FStar_Compiler_Util.for_all + (fun u_formal -> + u_leq_u_k + u_formal) + u_formals in + if inj + then + let uu___21 = + let uu___22 = + FStar_Syntax_Subst.compress + t1 in + uu___22.FStar_Syntax_Syntax.n in + (match uu___21 + with + | FStar_Syntax_Syntax.Tm_type + u -> + u_leq_u_k u + | uu___22 -> + false) + else false)) in + let injective_type_params = + FStar_Compiler_List.forall2 + tp_ok tps3 us in + ((let uu___15 = + FStar_TypeChecker_Env.debug + tcenv1 + (FStar_Options.Other + "TcInductive") in + if uu___15 + then + let uu___16 = + FStar_Ident.string_of_lid t in + FStar_Compiler_Util.print2 + "%s injectivity for %s\n" + (if injective_type_params + then "YES" + else "NO") uu___16 + else ()); + { + FStar_Syntax_Syntax.sigel = + (FStar_Syntax_Syntax.Sig_inductive_typ + { + FStar_Syntax_Syntax.lid + = + (dd.FStar_Syntax_Syntax.lid); + FStar_Syntax_Syntax.us = + (dd.FStar_Syntax_Syntax.us); + FStar_Syntax_Syntax.params + = + (dd.FStar_Syntax_Syntax.params); + FStar_Syntax_Syntax.num_uniform_params + = + (dd.FStar_Syntax_Syntax.num_uniform_params); + FStar_Syntax_Syntax.t = + (dd.FStar_Syntax_Syntax.t); + FStar_Syntax_Syntax.mutuals + = + (dd.FStar_Syntax_Syntax.mutuals); + FStar_Syntax_Syntax.ds = + (dd.FStar_Syntax_Syntax.ds); + FStar_Syntax_Syntax.injective_type_params + = + injective_type_params + }); + FStar_Syntax_Syntax.sigrng = + (se.FStar_Syntax_Syntax.sigrng); + FStar_Syntax_Syntax.sigquals = + (se.FStar_Syntax_Syntax.sigquals); + FStar_Syntax_Syntax.sigmeta = + (se.FStar_Syntax_Syntax.sigmeta); + FStar_Syntax_Syntax.sigattrs = + (se.FStar_Syntax_Syntax.sigattrs); + FStar_Syntax_Syntax.sigopens_and_abbrevs + = + (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); + FStar_Syntax_Syntax.sigopts = + (se.FStar_Syntax_Syntax.sigopts) + })))))))) let (tc_tycon : FStar_TypeChecker_Env.env_t -> FStar_Syntax_Syntax.sigelt -> @@ -19,36 +301,37 @@ let (tc_tycon : FStar_Syntax_Syntax.params = tps; FStar_Syntax_Syntax.num_uniform_params = n_uniform; FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = mutuals; - FStar_Syntax_Syntax.ds = data;_} + FStar_Syntax_Syntax.ds = data; + FStar_Syntax_Syntax.injective_type_params = uu___;_} -> let env0 = env in - let uu___ = FStar_Syntax_Subst.univ_var_opening uvs in - (match uu___ with + let uu___1 = FStar_Syntax_Subst.univ_var_opening uvs in + (match uu___1 with | (usubst, uvs1) -> - let uu___1 = - let uu___2 = FStar_TypeChecker_Env.push_univ_vars env uvs1 in - let uu___3 = FStar_Syntax_Subst.subst_binders usubst tps in - let uu___4 = - let uu___5 = + let uu___2 = + let uu___3 = FStar_TypeChecker_Env.push_univ_vars env uvs1 in + let uu___4 = FStar_Syntax_Subst.subst_binders usubst tps in + let uu___5 = + let uu___6 = FStar_Syntax_Subst.shift_subst (FStar_Compiler_List.length tps) usubst in - FStar_Syntax_Subst.subst uu___5 k in - (uu___2, uu___3, uu___4) in - (match uu___1 with + FStar_Syntax_Subst.subst uu___6 k in + (uu___3, uu___4, uu___5) in + (match uu___2 with | (env1, tps1, k1) -> - let uu___2 = FStar_Syntax_Subst.open_term tps1 k1 in - (match uu___2 with + let uu___3 = FStar_Syntax_Subst.open_term tps1 k1 in + (match uu___3 with | (tps2, k2) -> - let uu___3 = + let uu___4 = FStar_TypeChecker_TcTerm.tc_binders env1 tps2 in - (match uu___3 with + (match uu___4 with | (tps3, env_tps, guard_params, us) -> - let uu___4 = - let uu___5 = + let uu___5 = + let uu___6 = FStar_TypeChecker_TcTerm.tc_tot_or_gtot_term env_tps k2 in - match uu___5 with - | (k3, uu___6, g) -> + match uu___6 with + | (k3, uu___7, g) -> let k4 = FStar_TypeChecker_Normalize.normalize [FStar_TypeChecker_Env.Exclude @@ -60,23 +343,23 @@ let (tc_tycon : FStar_TypeChecker_Env.Exclude FStar_TypeChecker_Env.Beta] env_tps k3 in - let uu___7 = - FStar_Syntax_Util.arrow_formals k4 in let uu___8 = - let uu___9 = + FStar_Syntax_Util.arrow_formals k4 in + let uu___9 = + let uu___10 = FStar_TypeChecker_Env.conj_guard guard_params g in FStar_TypeChecker_Rel.discharge_guard - env_tps uu___9 in - (uu___7, uu___8) in - (match uu___4 with + env_tps uu___10 in + (uu___8, uu___9) in + (match uu___5 with | ((indices, t), guard) -> let k3 = - let uu___5 = + let uu___6 = FStar_Syntax_Syntax.mk_Total t in - FStar_Syntax_Util.arrow indices uu___5 in - let uu___5 = FStar_Syntax_Util.type_u () in - (match uu___5 with + FStar_Syntax_Util.arrow indices uu___6 in + let uu___6 = FStar_Syntax_Util.type_u () in + (match uu___6 with | (t_type, u) -> let valid_type = (((FStar_Syntax_Util.is_eqtype_no_unrefine @@ -96,21 +379,21 @@ let (tc_tycon : env1 t t_type) in (if Prims.op_Negation valid_type then - (let uu___7 = - let uu___8 = - let uu___9 = + (let uu___8 = + let uu___9 = + let uu___10 = FStar_Syntax_Print.term_to_string t in - let uu___10 = + let uu___11 = FStar_Ident.string_of_lid tc in FStar_Compiler_Util.format2 "Type annotation %s for inductive %s is not Type or eqtype, or it is eqtype but contains noeq/unopteq qualifiers" - uu___9 uu___10 in + uu___10 uu___11 in (FStar_Errors_Codes.Error_InductiveAnnotNotAType, - uu___8) in + uu___9) in FStar_Errors.raise_error_text - uu___7 + uu___8 s.FStar_Syntax_Syntax.sigrng) else (); (let usubst1 = @@ -120,22 +403,22 @@ let (tc_tycon : FStar_TypeChecker_Util.close_guard_implicits env1 false tps3 guard in let t_tc = - let uu___7 = - let uu___8 = + let uu___8 = + let uu___9 = FStar_Syntax_Subst.subst_binders usubst1 tps3 in - let uu___9 = - let uu___10 = + let uu___10 = + let uu___11 = FStar_Syntax_Subst.shift_subst (FStar_Compiler_List.length tps3) usubst1 in FStar_Syntax_Subst.subst_binders - uu___10 indices in + uu___11 indices in FStar_Compiler_List.op_At - uu___8 uu___9 in - let uu___8 = - let uu___9 = - let uu___10 = + uu___9 uu___10 in + let uu___9 = + let uu___10 = + let uu___11 = FStar_Syntax_Subst.shift_subst ((FStar_Compiler_List.length tps3) @@ -143,46 +426,46 @@ let (tc_tycon : (FStar_Compiler_List.length indices)) usubst1 in FStar_Syntax_Subst.subst - uu___10 t in + uu___11 t in FStar_Syntax_Syntax.mk_Total - uu___9 in - FStar_Syntax_Util.arrow uu___7 - uu___8 in + uu___10 in + FStar_Syntax_Util.arrow uu___8 + uu___9 in let tps4 = FStar_Syntax_Subst.close_binders tps3 in let k4 = FStar_Syntax_Subst.close tps4 k3 in - let uu___7 = - let uu___8 = + let uu___8 = + let uu___9 = FStar_Syntax_Subst.subst_binders usubst1 tps4 in - let uu___9 = - let uu___10 = + let uu___10 = + let uu___11 = FStar_Syntax_Subst.shift_subst (FStar_Compiler_List.length tps4) usubst1 in FStar_Syntax_Subst.subst - uu___10 k4 in - (uu___8, uu___9) in - match uu___7 with + uu___11 k4 in + (uu___9, uu___10) in + match uu___8 with | (tps5, k5) -> let fv_tc = FStar_Syntax_Syntax.lid_as_fv tc FStar_Pervasives_Native.None in - let uu___8 = + let uu___9 = FStar_Syntax_Subst.open_univ_vars uvs1 t_tc in - (match uu___8 with + (match uu___9 with | (uvs2, t_tc1) -> - let uu___9 = + let uu___10 = FStar_TypeChecker_Env.push_let_binding env0 (FStar_Pervasives.Inr fv_tc) (uvs2, t_tc1) in - (uu___9, + (uu___10, { FStar_Syntax_Syntax.sigel = @@ -201,7 +484,9 @@ let (tc_tycon : FStar_Syntax_Syntax.mutuals = mutuals; FStar_Syntax_Syntax.ds - = data + = data; + FStar_Syntax_Syntax.injective_type_params + = false }); FStar_Syntax_Syntax.sigrng = @@ -245,47 +530,50 @@ let (tc_data : FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = tc_lid; FStar_Syntax_Syntax.num_ty_params = ntps; - FStar_Syntax_Syntax.mutuals1 = mutual_tcs;_} + FStar_Syntax_Syntax.mutuals1 = mutual_tcs; + FStar_Syntax_Syntax.injective_type_params1 = uu___;_} -> - let uu___ = FStar_Syntax_Subst.univ_var_opening _uvs in - (match uu___ with + let uu___1 = FStar_Syntax_Subst.univ_var_opening _uvs in + (match uu___1 with | (usubst, _uvs1) -> - let uu___1 = - let uu___2 = + let uu___2 = + let uu___3 = FStar_TypeChecker_Env.push_univ_vars env _uvs1 in - let uu___3 = FStar_Syntax_Subst.subst usubst t in - (uu___2, uu___3) in - (match uu___1 with + let uu___4 = FStar_Syntax_Subst.subst usubst t in + (uu___3, uu___4) in + (match uu___2 with | (env1, t1) -> - let uu___2 = + let uu___3 = let tps_u_opt = FStar_Compiler_Util.find_map tcs - (fun uu___3 -> - match uu___3 with + (fun uu___4 -> + match uu___4 with | (se1, u_tc) -> - let uu___4 = - let uu___5 = - let uu___6 = + let uu___5 = + let uu___6 = + let uu___7 = FStar_Syntax_Util.lid_of_sigelt se1 in - FStar_Compiler_Util.must uu___6 in - FStar_Ident.lid_equals tc_lid uu___5 in - if uu___4 + FStar_Compiler_Util.must uu___7 in + FStar_Ident.lid_equals tc_lid uu___6 in + if uu___5 then (match se1.FStar_Syntax_Syntax.sigel with | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = uu___5; - FStar_Syntax_Syntax.us = uu___6; + { FStar_Syntax_Syntax.lid = uu___6; + FStar_Syntax_Syntax.us = uu___7; FStar_Syntax_Syntax.params = tps; FStar_Syntax_Syntax.num_uniform_params - = uu___7; - FStar_Syntax_Syntax.t = uu___8; + = uu___8; + FStar_Syntax_Syntax.t = uu___9; FStar_Syntax_Syntax.mutuals = - uu___9; - FStar_Syntax_Syntax.ds = uu___10;_} + uu___10; + FStar_Syntax_Syntax.ds = uu___11; + FStar_Syntax_Syntax.injective_type_params + = uu___12;_} -> let tps1 = - let uu___11 = + let uu___13 = FStar_Syntax_Subst.subst_binders usubst tps in FStar_Compiler_List.map @@ -304,37 +592,37 @@ let (tc_data : FStar_Syntax_Syntax.binder_attrs = (x.FStar_Syntax_Syntax.binder_attrs) - }) uu___11 in + }) uu___13 in let tps2 = FStar_Syntax_Subst.open_binders tps1 in - let uu___11 = - let uu___12 = + let uu___13 = + let uu___14 = FStar_TypeChecker_Env.push_binders env1 tps2 in - (uu___12, tps2, u_tc) in + (uu___14, tps2, u_tc) in FStar_Pervasives_Native.Some - uu___11 - | uu___5 -> + uu___13 + | uu___6 -> FStar_Compiler_Effect.failwith "Impossible") else FStar_Pervasives_Native.None) in match tps_u_opt with | FStar_Pervasives_Native.Some x -> x | FStar_Pervasives_Native.None -> - let uu___3 = + let uu___4 = FStar_Ident.lid_equals tc_lid FStar_Parser_Const.exn_lid in - if uu___3 + if uu___4 then (env1, [], FStar_Syntax_Syntax.U_zero) else FStar_Errors.raise_error (FStar_Errors_Codes.Fatal_UnexpectedDataConstructor, "Unexpected data constructor") se.FStar_Syntax_Syntax.sigrng in - (match uu___2 with + (match uu___3 with | (env2, tps, u_tc) -> - let uu___3 = + let uu___4 = let t2 = FStar_TypeChecker_Normalize.normalize (FStar_Compiler_List.op_At @@ -342,18 +630,18 @@ let (tc_data : [FStar_TypeChecker_Env.AllowUnboundUniverses]) env2 t1 in let t3 = FStar_Syntax_Util.canon_arrow t2 in - let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress t3 in - uu___5.FStar_Syntax_Syntax.n in - match uu___4 with + let uu___5 = + let uu___6 = FStar_Syntax_Subst.compress t3 in + uu___6.FStar_Syntax_Syntax.n in + match uu___5 with | FStar_Syntax_Syntax.Tm_arrow { FStar_Syntax_Syntax.bs1 = bs; FStar_Syntax_Syntax.comp = res;_} -> - let uu___5 = + let uu___6 = FStar_Compiler_Util.first_N ntps bs in - (match uu___5 with - | (uu___6, bs') -> + (match uu___6 with + | (uu___7, bs') -> let t4 = FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_arrow @@ -364,71 +652,71 @@ let (tc_data : let subst = FStar_Compiler_List.mapi (fun i -> - fun uu___7 -> - match uu___7 with + fun uu___8 -> + match uu___8 with | { FStar_Syntax_Syntax.binder_bv = x; FStar_Syntax_Syntax.binder_qual - = uu___8; - FStar_Syntax_Syntax.binder_positivity = uu___9; + FStar_Syntax_Syntax.binder_positivity + = uu___10; FStar_Syntax_Syntax.binder_attrs - = uu___10;_} + = uu___11;_} -> FStar_Syntax_Syntax.DB ((ntps - (Prims.int_one + i)), x)) tps in - let uu___7 = - let uu___8 = + let uu___8 = + let uu___9 = FStar_Syntax_Subst.subst subst t4 in FStar_Syntax_Util.arrow_formals_comp - uu___8 in - (match uu___7 with + uu___9 in + (match uu___8 with | (bs1, c1) -> - let uu___8 = + let uu___9 = (FStar_Options.ml_ish ()) || (FStar_Syntax_Util.is_total_comp c1) in - if uu___8 + if uu___9 then (bs1, (FStar_Syntax_Util.comp_result c1)) else - (let uu___10 = + (let uu___11 = FStar_Ident.range_of_lid (FStar_Syntax_Util.comp_effect_name c1) in FStar_Errors.raise_error (FStar_Errors_Codes.Fatal_UnexpectedConstructorType, "Constructors cannot have effects") - uu___10))) - | uu___5 -> ([], t3) in - (match uu___3 with + uu___11))) + | uu___6 -> ([], t3) in + (match uu___4 with | (arguments, result) -> - ((let uu___5 = + ((let uu___6 = FStar_TypeChecker_Env.debug env2 FStar_Options.Low in - if uu___5 + if uu___6 then - let uu___6 = - FStar_Syntax_Print.lid_to_string c in let uu___7 = + FStar_Syntax_Print.lid_to_string c in + let uu___8 = FStar_Syntax_Print.binders_to_string "->" arguments in - let uu___8 = + let uu___9 = FStar_Syntax_Print.term_to_string result in FStar_Compiler_Util.print3 "Checking datacon %s : %s -> %s \n" - uu___6 uu___7 uu___8 + uu___7 uu___8 uu___9 else ()); - (let uu___5 = + (let uu___6 = FStar_TypeChecker_TcTerm.tc_tparams env2 arguments in - match uu___5 with + match uu___6 with | (arguments1, env', us) -> let type_u_tc = FStar_Syntax_Syntax.mk @@ -437,23 +725,23 @@ let (tc_data : let env'1 = FStar_TypeChecker_Env.set_expected_typ env' type_u_tc in - let uu___6 = + let uu___7 = FStar_TypeChecker_TcTerm.tc_trivial_guard env'1 result in - (match uu___6 with + (match uu___7 with | (result1, res_lcomp) -> - let uu___7 = + let uu___8 = FStar_Syntax_Util.head_and_args_full result1 in - (match uu___7 with + (match uu___8 with | (head, args) -> let g_uvs = - let uu___8 = - let uu___9 = + let uu___9 = + let uu___10 = FStar_Syntax_Subst.compress head in - uu___9.FStar_Syntax_Syntax.n in - match uu___8 with + uu___10.FStar_Syntax_Syntax.n in + match uu___9 with | FStar_Syntax_Syntax.Tm_uinst ({ FStar_Syntax_Syntax.n @@ -461,11 +749,11 @@ let (tc_data : FStar_Syntax_Syntax.Tm_fvar fv; FStar_Syntax_Syntax.pos - = uu___9; - FStar_Syntax_Syntax.vars = uu___10; + FStar_Syntax_Syntax.vars + = uu___11; FStar_Syntax_Syntax.hash_code - = uu___11;_}, + = uu___12;_}, tuvs) when FStar_Syntax_Syntax.fv_eq_lid @@ -482,15 +770,15 @@ let (tc_data : (fun g -> fun u1 -> fun u2 -> - let uu___12 + let uu___13 = - let uu___13 + let uu___14 = FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_type u1) FStar_Compiler_Range_Type.dummyRange in - let uu___14 + let uu___15 = FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_type @@ -499,10 +787,10 @@ let (tc_data : FStar_Compiler_Range_Type.dummyRange in FStar_TypeChecker_Rel.teq env'1 - uu___13 - uu___14 in + uu___14 + uu___15 in FStar_TypeChecker_Env.conj_guard - g uu___12) + g uu___13) FStar_TypeChecker_Env.trivial_guard tuvs _uvs1 else @@ -516,138 +804,138 @@ let (tc_data : fv tc_lid -> FStar_TypeChecker_Env.trivial_guard - | uu___9 -> - let uu___10 = - let uu___11 = - let uu___12 = + | uu___10 -> + let uu___11 = + let uu___12 = + let uu___13 = FStar_Syntax_Print.lid_to_string tc_lid in - let uu___13 = + let uu___14 = FStar_Syntax_Print.term_to_string head in FStar_Compiler_Util.format2 "Expected a constructor of type %s; got %s" - uu___12 uu___13 in + uu___13 uu___14 in (FStar_Errors_Codes.Fatal_UnexpectedConstructorType, - uu___11) in + uu___12) in FStar_Errors.raise_error - uu___10 + uu___11 se.FStar_Syntax_Syntax.sigrng in let g = FStar_Compiler_List.fold_left2 (fun g1 -> - fun uu___8 -> + fun uu___9 -> fun u_x -> - match uu___8 with + match uu___9 with | { FStar_Syntax_Syntax.binder_bv = x; FStar_Syntax_Syntax.binder_qual - = uu___9; - FStar_Syntax_Syntax.binder_positivity = uu___10; + FStar_Syntax_Syntax.binder_positivity + = uu___11; FStar_Syntax_Syntax.binder_attrs - = uu___11;_} + = uu___12;_} -> - let uu___12 = + let uu___13 = FStar_TypeChecker_Rel.universe_inequality u_x u_tc in FStar_TypeChecker_Env.conj_guard - g1 uu___12) + g1 uu___13) g_uvs arguments1 us in (FStar_Errors.stop_if_err (); (let p_args = - let uu___9 = + let uu___10 = FStar_Compiler_Util.first_N (FStar_Compiler_List.length tps) args in FStar_Pervasives_Native.fst - uu___9 in + uu___10 in FStar_Compiler_List.iter2 - (fun uu___10 -> - fun uu___11 -> - match (uu___10, - uu___11) + (fun uu___11 -> + fun uu___12 -> + match (uu___11, + uu___12) with | ({ FStar_Syntax_Syntax.binder_bv = bv; FStar_Syntax_Syntax.binder_qual - = uu___12; - FStar_Syntax_Syntax.binder_positivity = uu___13; + FStar_Syntax_Syntax.binder_positivity + = uu___14; FStar_Syntax_Syntax.binder_attrs - = uu___14;_}, - (t2, uu___15)) -> - let uu___16 = - let uu___17 = + = uu___15;_}, + (t2, uu___16)) -> + let uu___17 = + let uu___18 = FStar_Syntax_Subst.compress t2 in - uu___17.FStar_Syntax_Syntax.n in - (match uu___16 + uu___18.FStar_Syntax_Syntax.n in + (match uu___17 with | FStar_Syntax_Syntax.Tm_name bv' when FStar_Syntax_Syntax.bv_eq bv bv' -> () - | uu___17 -> - let uu___18 - = - let uu___19 + | uu___18 -> + let uu___19 = let uu___20 = + let uu___21 + = FStar_Syntax_Print.bv_to_string bv in - let uu___21 + let uu___22 = FStar_Syntax_Print.term_to_string t2 in FStar_Compiler_Util.format2 "This parameter is not constant: expected %s, got %s" - uu___20 - uu___21 in + uu___21 + uu___22 in (FStar_Errors_Codes.Error_BadInductiveParam, - uu___19) in + uu___20) in FStar_Errors.raise_error - uu___18 + uu___19 t2.FStar_Syntax_Syntax.pos)) tps p_args; (let ty = - let uu___10 = + let uu___11 = unfold_whnf env2 res_lcomp.FStar_TypeChecker_Common.res_typ in FStar_Syntax_Util.unrefine - uu___10 in - (let uu___11 = - let uu___12 = + uu___11 in + (let uu___12 = + let uu___13 = FStar_Syntax_Subst.compress ty in - uu___12.FStar_Syntax_Syntax.n in - match uu___11 with + uu___13.FStar_Syntax_Syntax.n in + match uu___12 with | FStar_Syntax_Syntax.Tm_type - uu___12 -> () - | uu___12 -> - let uu___13 = - let uu___14 = - let uu___15 = + uu___13 -> () + | uu___13 -> + let uu___14 = + let uu___15 = + let uu___16 = FStar_Syntax_Print.term_to_string result1 in - let uu___16 = + let uu___17 = FStar_Syntax_Print.term_to_string ty in FStar_Compiler_Util.format2 "The type of %s is %s, but since this is the result type of a constructor its type should be Type" - uu___15 uu___16 in + uu___16 uu___17 in (FStar_Errors_Codes.Fatal_WrongResultTypeAfterConstrutor, - uu___14) in + uu___15) in FStar_Errors.raise_error - uu___13 + uu___14 se.FStar_Syntax_Syntax.sigrng); (let t2 = - let uu___11 = - let uu___12 = + let uu___12 = + let uu___13 = FStar_Compiler_List.map (fun b -> { @@ -667,12 +955,12 @@ let (tc_data : (b.FStar_Syntax_Syntax.binder_attrs) }) tps in FStar_Compiler_List.op_At - uu___12 arguments1 in - let uu___12 = + uu___13 arguments1 in + let uu___13 = FStar_Syntax_Syntax.mk_Total result1 in FStar_Syntax_Util.arrow - uu___11 uu___12 in + uu___12 uu___13 in let t3 = FStar_Syntax_Subst.close_univ_vars _uvs1 t2 in @@ -692,7 +980,9 @@ let (tc_data : FStar_Syntax_Syntax.num_ty_params = ntps; FStar_Syntax_Syntax.mutuals1 - = mutual_tcs + = mutual_tcs; + FStar_Syntax_Syntax.injective_type_params1 + = false }); FStar_Syntax_Syntax.sigrng = @@ -737,12 +1027,13 @@ let (generalize_and_inst_within : FStar_Syntax_Syntax.num_uniform_params = uu___4; FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6;_} + FStar_Syntax_Syntax.ds = uu___6; + FStar_Syntax_Syntax.injective_type_params = uu___7;_} -> - let uu___7 = - let uu___8 = FStar_Syntax_Syntax.mk_Total k in - FStar_Syntax_Util.arrow tps uu___8 in - FStar_Syntax_Syntax.null_binder uu___7 + let uu___8 = + let uu___9 = FStar_Syntax_Syntax.mk_Total k in + FStar_Syntax_Util.arrow tps uu___9 in + FStar_Syntax_Syntax.null_binder uu___8 | uu___2 -> FStar_Compiler_Effect.failwith "Impossible")) tcs in let binders' = @@ -755,7 +1046,8 @@ let (generalize_and_inst_within : FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___2; FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4;_} + FStar_Syntax_Syntax.mutuals1 = uu___4; + FStar_Syntax_Syntax.injective_type_params1 = uu___5;_} -> FStar_Syntax_Syntax.null_binder t | uu___ -> FStar_Compiler_Effect.failwith "Impossible") datas in let t = @@ -828,19 +1120,21 @@ let (generalize_and_inst_within : FStar_Syntax_Syntax.mutuals = mutuals; FStar_Syntax_Syntax.ds = - datas1;_} + datas1; + FStar_Syntax_Syntax.injective_type_params + = uu___15;_} -> let ty = FStar_Syntax_Subst.close_univ_vars uvs1 x.FStar_Syntax_Syntax.sort in - let uu___15 = - let uu___16 = - let uu___17 = + let uu___16 = + let uu___17 = + let uu___18 = FStar_Syntax_Subst.compress ty in - uu___17.FStar_Syntax_Syntax.n in - match uu___16 with + uu___18.FStar_Syntax_Syntax.n in + match uu___17 with | FStar_Syntax_Syntax.Tm_arrow { FStar_Syntax_Syntax.bs1 @@ -848,18 +1142,18 @@ let (generalize_and_inst_within : FStar_Syntax_Syntax.comp = c;_} -> - let uu___17 = + let uu___18 = FStar_Compiler_Util.first_N (FStar_Compiler_List.length tps) binders1 in - (match uu___17 with + (match uu___18 with | (tps1, rest) -> let t3 = match rest with | [] -> FStar_Syntax_Util.comp_result c - | uu___18 -> + | uu___19 -> FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_arrow { @@ -870,8 +1164,8 @@ let (generalize_and_inst_within : }) (x.FStar_Syntax_Syntax.sort).FStar_Syntax_Syntax.pos in (tps1, t3)) - | uu___17 -> ([], ty) in - (match uu___15 with + | uu___18 -> ([], ty) in + (match uu___16 with | (tps1, t3) -> { FStar_Syntax_Syntax.sigel @@ -891,7 +1185,9 @@ let (generalize_and_inst_within : FStar_Syntax_Syntax.mutuals = mutuals; FStar_Syntax_Syntax.ds - = datas1 + = datas1; + FStar_Syntax_Syntax.injective_type_params + = false }); FStar_Syntax_Syntax.sigrng = @@ -945,19 +1241,21 @@ let (generalize_and_inst_within : FStar_Syntax_Syntax.mutuals = uu___13; FStar_Syntax_Syntax.ds = - uu___14;_}; + uu___14; + FStar_Syntax_Syntax.injective_type_params + = uu___15;_}; FStar_Syntax_Syntax.sigrng = - uu___15; - FStar_Syntax_Syntax.sigquals = uu___16; - FStar_Syntax_Syntax.sigmeta = + FStar_Syntax_Syntax.sigquals = uu___17; - FStar_Syntax_Syntax.sigattrs = + FStar_Syntax_Syntax.sigmeta = uu___18; + FStar_Syntax_Syntax.sigattrs = + uu___19; FStar_Syntax_Syntax.sigopens_and_abbrevs - = uu___19; + = uu___20; FStar_Syntax_Syntax.sigopts = - uu___20;_} + uu___21;_} -> (tc, uvs_universes) | uu___9 -> FStar_Compiler_Effect.failwith @@ -991,15 +1289,17 @@ let (generalize_and_inst_within : FStar_Syntax_Syntax.num_ty_params = ntps; FStar_Syntax_Syntax.mutuals1 - = mutuals;_} + = mutuals; + FStar_Syntax_Syntax.injective_type_params1 + = uu___14;_} -> let ty = - let uu___14 = + let uu___15 = FStar_Syntax_InstFV.instantiate tc_insts t3.FStar_Syntax_Syntax.sort in FStar_Syntax_Subst.close_univ_vars - uvs1 uu___14 in + uvs1 uu___15 in { FStar_Syntax_Syntax.sigel = @@ -1016,7 +1316,9 @@ let (generalize_and_inst_within : FStar_Syntax_Syntax.num_ty_params = ntps; FStar_Syntax_Syntax.mutuals1 - = mutuals + = mutuals; + FStar_Syntax_Syntax.injective_type_params1 + = false }); FStar_Syntax_Syntax.sigrng = @@ -1049,7 +1351,8 @@ let (datacon_typ : FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.term) = { FStar_Syntax_Syntax.lid1 = uu___; FStar_Syntax_Syntax.us1 = uu___1; FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___2; FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4;_} + FStar_Syntax_Syntax.mutuals1 = uu___4; + FStar_Syntax_Syntax.injective_type_params1 = uu___5;_} -> t | uu___ -> FStar_Compiler_Effect.failwith "Impossible!" let (haseq_suffix : Prims.string) = "__uu___haseq" @@ -1102,7 +1405,8 @@ let (get_optimized_haseq_axiom : FStar_Syntax_Syntax.num_uniform_params = uu___2; FStar_Syntax_Syntax.t = t; FStar_Syntax_Syntax.mutuals = uu___3; - FStar_Syntax_Syntax.ds = uu___4;_} + FStar_Syntax_Syntax.ds = uu___4; + FStar_Syntax_Syntax.injective_type_params = uu___5;_} -> (lid, bs, t) | uu___1 -> FStar_Compiler_Effect.failwith "Impossible!" in match uu___ with @@ -1359,7 +1663,8 @@ let (optimized_haseq_ty : FStar_Syntax_Syntax.num_uniform_params = uu___2; FStar_Syntax_Syntax.t = uu___3; FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5;_} + FStar_Syntax_Syntax.ds = uu___5; + FStar_Syntax_Syntax.injective_type_params = uu___6;_} -> lid1 | uu___ -> FStar_Compiler_Effect.failwith "Impossible!" in let uu___ = acc in @@ -1387,7 +1692,9 @@ let (optimized_haseq_ty : FStar_Syntax_Syntax.ty_lid = t_lid; FStar_Syntax_Syntax.num_ty_params = uu___9; - FStar_Syntax_Syntax.mutuals1 = uu___10;_} + FStar_Syntax_Syntax.mutuals1 = uu___10; + FStar_Syntax_Syntax.injective_type_params1 + = uu___11;_} -> t_lid = lid | uu___6 -> FStar_Compiler_Effect.failwith @@ -1425,7 +1732,8 @@ let (optimized_haseq_scheme : FStar_Syntax_Syntax.num_uniform_params = uu___3; FStar_Syntax_Syntax.t = t; FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5;_} + FStar_Syntax_Syntax.ds = uu___5; + FStar_Syntax_Syntax.injective_type_params = uu___6;_} -> (us, t) | uu___1 -> FStar_Compiler_Effect.failwith "Impossible!" in match uu___ with @@ -1652,7 +1960,8 @@ let (unoptimized_haseq_ty : FStar_Syntax_Syntax.num_uniform_params = uu___2; FStar_Syntax_Syntax.t = t; FStar_Syntax_Syntax.mutuals = uu___3; - FStar_Syntax_Syntax.ds = d_lids;_} + FStar_Syntax_Syntax.ds = d_lids; + FStar_Syntax_Syntax.injective_type_params = uu___4;_} -> (lid, bs, t, d_lids) | uu___1 -> FStar_Compiler_Effect.failwith "Impossible!" in match uu___ with @@ -1715,7 +2024,9 @@ let (unoptimized_haseq_ty : FStar_Syntax_Syntax.ty_lid = t_lid; FStar_Syntax_Syntax.num_ty_params = uu___5; - FStar_Syntax_Syntax.mutuals1 = uu___6;_} + FStar_Syntax_Syntax.mutuals1 = uu___6; + FStar_Syntax_Syntax.injective_type_params1 + = uu___7;_} -> t_lid = lid | uu___2 -> FStar_Compiler_Effect.failwith "Impossible") @@ -1820,7 +2131,8 @@ let (unoptimized_haseq_scheme : FStar_Syntax_Syntax.num_uniform_params = uu___2; FStar_Syntax_Syntax.t = uu___3; FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5;_} + FStar_Syntax_Syntax.ds = uu___5; + FStar_Syntax_Syntax.injective_type_params = uu___6;_} -> lid | uu___ -> FStar_Compiler_Effect.failwith "Impossible!") tcs in let uu___ = @@ -1832,7 +2144,8 @@ let (unoptimized_haseq_scheme : FStar_Syntax_Syntax.num_uniform_params = uu___2; FStar_Syntax_Syntax.t = uu___3; FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5;_} + FStar_Syntax_Syntax.ds = uu___5; + FStar_Syntax_Syntax.injective_type_params = uu___6;_} -> (lid, us) | uu___1 -> FStar_Compiler_Effect.failwith "Impossible!" in match uu___ with @@ -1933,7 +2246,9 @@ let (check_inductive_well_typedness : FStar_Syntax_Syntax.num_uniform_params = uu___6; FStar_Syntax_Syntax.t = uu___7; FStar_Syntax_Syntax.mutuals = uu___8; - FStar_Syntax_Syntax.ds = uu___9;_} + FStar_Syntax_Syntax.ds = uu___9; + FStar_Syntax_Syntax.injective_type_params = + uu___10;_} -> uvs | uu___4 -> FStar_Compiler_Effect.failwith @@ -2045,49 +2360,51 @@ let (check_inductive_well_typedness : = num_uniform; FStar_Syntax_Syntax.t = typ; FStar_Syntax_Syntax.mutuals = ts; - FStar_Syntax_Syntax.ds = ds;_} + FStar_Syntax_Syntax.ds = ds; + FStar_Syntax_Syntax.injective_type_params + = uu___5;_} -> let fail expected inferred = - let uu___5 = - let uu___6 = - let uu___7 = + let uu___6 = + let uu___7 = + let uu___8 = FStar_Syntax_Print.tscheme_to_string expected in - let uu___8 = + let uu___9 = FStar_Syntax_Print.tscheme_to_string inferred in FStar_Compiler_Util.format2 "Expected an inductive with type %s; got %s" - uu___7 uu___8 in + uu___8 uu___9 in (FStar_Errors_Codes.Fatal_UnexpectedInductivetype, - uu___6) in - FStar_Errors.raise_error uu___5 + uu___7) in + FStar_Errors.raise_error uu___6 se.FStar_Syntax_Syntax.sigrng in let copy_binder_attrs_from_val binders1 expected = let expected_attrs = - let uu___5 = - let uu___6 = + let uu___6 = + let uu___7 = FStar_TypeChecker_Normalize.get_n_binders env1 (FStar_Compiler_List.length binders1) expected in FStar_Pervasives_Native.fst - uu___6 in + uu___7 in FStar_Compiler_List.map - (fun uu___6 -> - match uu___6 with + (fun uu___7 -> + match uu___7 with | { FStar_Syntax_Syntax.binder_bv - = uu___7; - FStar_Syntax_Syntax.binder_qual = uu___8; + FStar_Syntax_Syntax.binder_qual + = uu___9; FStar_Syntax_Syntax.binder_positivity = pqual; FStar_Syntax_Syntax.binder_attrs = attrs;_} -> (attrs, pqual)) - uu___5 in + uu___6 in if (FStar_Compiler_List.length expected_attrs) @@ -2095,44 +2412,44 @@ let (check_inductive_well_typedness : (FStar_Compiler_List.length binders1) then - let uu___5 = - let uu___6 = - let uu___7 = + let uu___6 = + let uu___7 = + let uu___8 = FStar_Compiler_Util.string_of_int (FStar_Compiler_List.length binders1) in - let uu___8 = + let uu___9 = FStar_Syntax_Print.term_to_string expected in FStar_Compiler_Util.format2 "Could not get %s type parameters from val type %s" - uu___7 uu___8 in + uu___8 uu___9 in (FStar_Errors_Codes.Fatal_UnexpectedInductivetype, - uu___6) in - FStar_Errors.raise_error uu___5 + uu___7) in + FStar_Errors.raise_error uu___6 se.FStar_Syntax_Syntax.sigrng else FStar_Compiler_List.map2 - (fun uu___6 -> + (fun uu___7 -> fun b -> - match uu___6 with + match uu___7 with | (ex_attrs, pqual) -> - ((let uu___8 = - let uu___9 = + ((let uu___9 = + let uu___10 = FStar_TypeChecker_Common.check_positivity_qual true pqual b.FStar_Syntax_Syntax.binder_positivity in Prims.op_Negation - uu___9 in - if uu___8 + uu___10 in + if uu___9 then - let uu___9 = + let uu___10 = FStar_Syntax_Syntax.range_of_bv b.FStar_Syntax_Syntax.binder_bv in FStar_Errors.raise_error (FStar_Errors_Codes.Fatal_UnexpectedInductivetype, "Incompatible positivity annotation") - uu___9 + uu___10 else ()); { FStar_Syntax_Syntax.binder_bv @@ -2155,32 +2472,32 @@ let (check_inductive_well_typedness : let body = match binders1 with | [] -> typ - | uu___5 -> - let uu___6 = - let uu___7 = - let uu___8 = + | uu___6 -> + let uu___7 = + let uu___8 = + let uu___9 = FStar_Syntax_Syntax.mk_Total typ in { FStar_Syntax_Syntax.bs1 = binders1; FStar_Syntax_Syntax.comp - = uu___8 + = uu___9 } in FStar_Syntax_Syntax.Tm_arrow - uu___7 in + uu___8 in FStar_Syntax_Syntax.mk - uu___6 + uu___7 se.FStar_Syntax_Syntax.sigrng in (univs1, body) in - let uu___5 = + let uu___6 = FStar_TypeChecker_Env.try_lookup_val_decl env0 l in - (match uu___5 with + (match uu___6 with | FStar_Pervasives_Native.None -> se | FStar_Pervasives_Native.Some - (expected_typ, uu___6) -> + (expected_typ, uu___7) -> if (FStar_Compiler_List.length univs1) @@ -2189,32 +2506,32 @@ let (check_inductive_well_typedness : (FStar_Pervasives_Native.fst expected_typ)) then - let uu___7 = + let uu___8 = FStar_Syntax_Subst.open_univ_vars univs1 (FStar_Pervasives_Native.snd expected_typ) in - (match uu___7 with - | (uu___8, expected) -> + (match uu___8 with + | (uu___9, expected) -> let binders1 = copy_binder_attrs_from_val binders expected in let inferred_typ = inferred_typ_with_binders binders1 in - let uu___9 = + let uu___10 = FStar_Syntax_Subst.open_univ_vars univs1 (FStar_Pervasives_Native.snd inferred_typ) in - (match uu___9 with - | (uu___10, inferred) + (match uu___10 with + | (uu___11, inferred) -> - let uu___11 = + let uu___12 = FStar_TypeChecker_Rel.teq_nosmt_force env0 inferred expected in - if uu___11 + if uu___12 then { FStar_Syntax_Syntax.sigel @@ -2236,7 +2553,9 @@ let (check_inductive_well_typedness : FStar_Syntax_Syntax.mutuals = ts; FStar_Syntax_Syntax.ds - = ds + = ds; + FStar_Syntax_Syntax.injective_type_params + = false }); FStar_Syntax_Syntax.sigrng = @@ -2261,11 +2580,94 @@ let (check_inductive_well_typedness : fail expected_typ inferred_typ)) else - (let uu___8 = + (let uu___9 = inferred_typ_with_binders binders in - fail expected_typ uu___8)) + fail expected_typ uu___9)) | uu___5 -> se) tcs1 in + let tcs3 = + FStar_Compiler_List.map + (check_sig_inductive_injectivity_on_params + env0) tcs2 in + let is_injective l = + let uu___5 = + FStar_Compiler_List.tryPick + (fun se -> + let uu___6 = + se.FStar_Syntax_Syntax.sigel in + match uu___6 with + | FStar_Syntax_Syntax.Sig_inductive_typ + { FStar_Syntax_Syntax.lid = lid; + FStar_Syntax_Syntax.us = uu___7; + FStar_Syntax_Syntax.params = + uu___8; + FStar_Syntax_Syntax.num_uniform_params + = uu___9; + FStar_Syntax_Syntax.t = uu___10; + FStar_Syntax_Syntax.mutuals = + uu___11; + FStar_Syntax_Syntax.ds = uu___12; + FStar_Syntax_Syntax.injective_type_params + = injective_type_params;_} + -> + let uu___13 = + FStar_Ident.lid_equals l lid in + if uu___13 + then + FStar_Pervasives_Native.Some + injective_type_params + else FStar_Pervasives_Native.None) + tcs3 in + match uu___5 with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some i -> i in + let datas3 = + FStar_Compiler_List.map + (fun se -> + let uu___5 = + se.FStar_Syntax_Syntax.sigel in + match uu___5 with + | FStar_Syntax_Syntax.Sig_datacon dd -> + let uu___6 = + let uu___7 = + let uu___8 = + is_injective + dd.FStar_Syntax_Syntax.ty_lid in + { + FStar_Syntax_Syntax.lid1 = + (dd.FStar_Syntax_Syntax.lid1); + FStar_Syntax_Syntax.us1 = + (dd.FStar_Syntax_Syntax.us1); + FStar_Syntax_Syntax.t1 = + (dd.FStar_Syntax_Syntax.t1); + FStar_Syntax_Syntax.ty_lid = + (dd.FStar_Syntax_Syntax.ty_lid); + FStar_Syntax_Syntax.num_ty_params + = + (dd.FStar_Syntax_Syntax.num_ty_params); + FStar_Syntax_Syntax.mutuals1 = + (dd.FStar_Syntax_Syntax.mutuals1); + FStar_Syntax_Syntax.injective_type_params1 + = uu___8 + } in + FStar_Syntax_Syntax.Sig_datacon + uu___7 in + { + FStar_Syntax_Syntax.sigel = uu___6; + FStar_Syntax_Syntax.sigrng = + (se.FStar_Syntax_Syntax.sigrng); + FStar_Syntax_Syntax.sigquals = + (se.FStar_Syntax_Syntax.sigquals); + FStar_Syntax_Syntax.sigmeta = + (se.FStar_Syntax_Syntax.sigmeta); + FStar_Syntax_Syntax.sigattrs = + (se.FStar_Syntax_Syntax.sigattrs); + FStar_Syntax_Syntax.sigopens_and_abbrevs + = + (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); + FStar_Syntax_Syntax.sigopts = + (se.FStar_Syntax_Syntax.sigopts) + }) datas2 in let sig_bndle = let uu___5 = FStar_TypeChecker_Env.get_range env0 in @@ -2278,8 +2680,8 @@ let (check_inductive_well_typedness : (FStar_Syntax_Syntax.Sig_bundle { FStar_Syntax_Syntax.ses = - (FStar_Compiler_List.op_At tcs2 - datas2); + (FStar_Compiler_List.op_At tcs3 + datas3); FStar_Syntax_Syntax.lids = lids }); FStar_Syntax_Syntax.sigrng = uu___5; @@ -2292,7 +2694,7 @@ let (check_inductive_well_typedness : FStar_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None } in - (sig_bndle, tcs2, datas2))))) + (sig_bndle, tcs3, datas3))))) let (early_prims_inductives : Prims.string Prims.list) = ["empty"; "trivial"; "equals"; "pair"; "sum"] let (mk_discriminator_and_indexed_projectors : @@ -3156,142 +3558,145 @@ let (mk_data_operations : FStar_Syntax_Syntax.us1 = uvs; FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = typ_lid; FStar_Syntax_Syntax.num_ty_params = n_typars; - FStar_Syntax_Syntax.mutuals1 = uu___;_} + FStar_Syntax_Syntax.mutuals1 = uu___; + FStar_Syntax_Syntax.injective_type_params1 = uu___1;_} -> - let uu___1 = FStar_Syntax_Subst.univ_var_opening uvs in - (match uu___1 with + let uu___2 = FStar_Syntax_Subst.univ_var_opening uvs in + (match uu___2 with | (univ_opening, uvs1) -> let t1 = FStar_Syntax_Subst.subst univ_opening t in - let uu___2 = FStar_Syntax_Util.arrow_formals t1 in - (match uu___2 with - | (formals, uu___3) -> - let uu___4 = + let uu___3 = FStar_Syntax_Util.arrow_formals t1 in + (match uu___3 with + | (formals, uu___4) -> + let uu___5 = let tps_opt = FStar_Compiler_Util.find_map tcs (fun se1 -> - let uu___5 = - let uu___6 = - let uu___7 = + let uu___6 = + let uu___7 = + let uu___8 = FStar_Syntax_Util.lid_of_sigelt se1 in - FStar_Compiler_Util.must uu___7 in - FStar_Ident.lid_equals typ_lid uu___6 in - if uu___5 + FStar_Compiler_Util.must uu___8 in + FStar_Ident.lid_equals typ_lid uu___7 in + if uu___6 then match se1.FStar_Syntax_Syntax.sigel with | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = uu___6; + { FStar_Syntax_Syntax.lid = uu___7; FStar_Syntax_Syntax.us = uvs'; FStar_Syntax_Syntax.params = tps; FStar_Syntax_Syntax.num_uniform_params - = uu___7; + = uu___8; FStar_Syntax_Syntax.t = typ0; FStar_Syntax_Syntax.mutuals = - uu___8; - FStar_Syntax_Syntax.ds = constrs;_} + uu___9; + FStar_Syntax_Syntax.ds = constrs; + FStar_Syntax_Syntax.injective_type_params + = uu___10;_} -> FStar_Pervasives_Native.Some (tps, typ0, ((FStar_Compiler_List.length constrs) > Prims.int_one)) - | uu___6 -> + | uu___7 -> FStar_Compiler_Effect.failwith "Impossible" else FStar_Pervasives_Native.None) in match tps_opt with | FStar_Pervasives_Native.Some x -> x | FStar_Pervasives_Native.None -> - let uu___5 = + let uu___6 = FStar_Ident.lid_equals typ_lid FStar_Parser_Const.exn_lid in - if uu___5 + if uu___6 then ([], FStar_Syntax_Util.ktype0, true) else FStar_Errors.raise_error (FStar_Errors_Codes.Fatal_UnexpectedDataConstructor, "Unexpected data constructor") se.FStar_Syntax_Syntax.sigrng in - (match uu___4 with + (match uu___5 with | (inductive_tps, typ0, should_refine) -> let inductive_tps1 = FStar_Syntax_Subst.subst_binders univ_opening inductive_tps in let typ01 = - let uu___5 = + let uu___6 = FStar_Syntax_Subst.shift_subst (FStar_Compiler_List.length inductive_tps1) univ_opening in - FStar_Syntax_Subst.subst uu___5 typ0 in - let uu___5 = + FStar_Syntax_Subst.subst uu___6 typ0 in + let uu___6 = FStar_Syntax_Util.arrow_formals typ01 in - (match uu___5 with - | (indices, uu___6) -> + (match uu___6 with + | (indices, uu___7) -> let refine_domain = - let uu___7 = + let uu___8 = FStar_Compiler_Util.for_some - (fun uu___8 -> - match uu___8 with + (fun uu___9 -> + match uu___9 with | FStar_Syntax_Syntax.RecordConstructor - uu___9 -> true - | uu___9 -> false) + uu___10 -> true + | uu___10 -> false) se.FStar_Syntax_Syntax.sigquals in - if uu___7 then false else should_refine in + if uu___8 then false else should_refine in let fv_qual = - let filter_records uu___7 = - match uu___7 with + let filter_records uu___8 = + match uu___8 with | FStar_Syntax_Syntax.RecordConstructor - (uu___8, fns) -> + (uu___9, fns) -> FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Record_ctor (typ_lid, fns)) - | uu___8 -> + | uu___9 -> FStar_Pervasives_Native.None in - let uu___7 = + let uu___8 = FStar_Compiler_Util.find_map se.FStar_Syntax_Syntax.sigquals filter_records in - match uu___7 with + match uu___8 with | FStar_Pervasives_Native.None -> FStar_Syntax_Syntax.Data_ctor | FStar_Pervasives_Native.Some q -> q in let fields = - let uu___7 = + let uu___8 = FStar_Compiler_Util.first_N n_typars formals in - match uu___7 with + match uu___8 with | (imp_tps, fields1) -> let rename = FStar_Compiler_List.map2 - (fun uu___8 -> - fun uu___9 -> - match (uu___8, uu___9) + (fun uu___9 -> + fun uu___10 -> + match (uu___9, uu___10) with | ({ FStar_Syntax_Syntax.binder_bv = x; FStar_Syntax_Syntax.binder_qual - = uu___10; - FStar_Syntax_Syntax.binder_positivity = uu___11; + FStar_Syntax_Syntax.binder_positivity + = uu___12; FStar_Syntax_Syntax.binder_attrs - = uu___12;_}, + = uu___13;_}, { FStar_Syntax_Syntax.binder_bv = x'; FStar_Syntax_Syntax.binder_qual - = uu___13; - FStar_Syntax_Syntax.binder_positivity = uu___14; + FStar_Syntax_Syntax.binder_positivity + = uu___15; FStar_Syntax_Syntax.binder_attrs - = uu___15;_}) + = uu___16;_}) -> - let uu___16 = - let uu___17 = + let uu___17 = + let uu___18 = FStar_Syntax_Syntax.bv_to_name x' in - (x, uu___17) in + (x, uu___18) in FStar_Syntax_Syntax.NT - uu___16) imp_tps + uu___17) imp_tps inductive_tps1 in FStar_Syntax_Subst.subst_binders rename fields1 in diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcTerm.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcTerm.ml index 5852a96f007..63243babb64 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcTerm.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcTerm.ml @@ -1341,8 +1341,10 @@ let (guard_letrecs : FStar_Syntax_Util.unrefine uu___ in let rec warn t11 t21 = let uu___ = - let uu___1 = FStar_Syntax_Util.eq_tm t11 t21 in - uu___1 = FStar_Syntax_Util.Equal in + let uu___1 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env2 t11 + t21 in + uu___1 = FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___ then false else @@ -1531,8 +1533,10 @@ let (guard_letrecs : uu___1 :: uu___2 in FStar_Syntax_Syntax.mk_Tm_app rel uu___ r in let uu___ = - let uu___1 = FStar_Syntax_Util.eq_tm rel rel_prev in - uu___1 = FStar_Syntax_Util.Equal in + let uu___1 = + FStar_TypeChecker_TermEqAndSimplify.eq_tm env2 rel + rel_prev in + uu___1 = FStar_TypeChecker_TermEqAndSimplify.Equal in if uu___ then rel_guard else @@ -5994,7 +5998,7 @@ and (tc_abs_check_binders : let uu___2 = (Prims.op_Negation (special imp imp')) && (let uu___3 = FStar_Syntax_Util.eq_bqual imp imp' in - uu___3 <> FStar_Syntax_Util.Equal) in + Prims.op_Negation uu___3) in if uu___2 then let uu___3 = @@ -6126,9 +6130,10 @@ and (tc_abs_check_binders : FStar_Compiler_List.existsb (fun attr -> let uu___5 = - FStar_Syntax_Util.eq_tm attr - attr' in - uu___5 = FStar_Syntax_Util.Equal) + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env1 attr attr' in + uu___5 = + FStar_TypeChecker_TermEqAndSimplify.Equal) attrs1 in Prims.op_Negation uu___4) attrs'1 in FStar_Compiler_List.op_At attrs1 diff in From d950b26a32da33add7f9788e53cd3a8219cd6b2d Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Fri, 26 Apr 2024 23:41:28 -0700 Subject: [PATCH 38/42] tweak a test; we seemt to run out of stack a bit sooner on unembedding large lists; try to optimize eq_tm a bit --- examples/native_tactics/Simple.Test.fst | 2 +- .../FStar_TypeChecker_TermEqAndSimplify.ml | 106 +++++++----------- .../FStar.TypeChecker.TermEqAndSimplify.fst | 85 +++++++------- 3 files changed, 84 insertions(+), 109 deletions(-) diff --git a/examples/native_tactics/Simple.Test.fst b/examples/native_tactics/Simple.Test.fst index 566866fd193..a50465e818d 100644 --- a/examples/native_tactics/Simple.Test.fst +++ b/examples/native_tactics/Simple.Test.fst @@ -20,6 +20,6 @@ type t = | This | That let test0 = assert_norm (id 1000000 = 1000000) let test1 = assert_norm (poly_id 1000000 This = This) let test2 = assert_norm (mk_n_list 10 This = [This;This;This;This;This;This;This;This;This;This]) -let test3 = assert_norm (poly_list_id (mk_n_list 100000 This) = mk_n_list 100000 This) +let test3 = assert_norm (poly_list_id (mk_n_list 40000 This) = mk_n_list 40000 This) let test4 = assert_norm (eq_int_list (poly_list_id (mk_n_list 100000 0)) (mk_n_list 100000 0)) diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml index b63e05a5320..e606fdf9d14 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml @@ -56,35 +56,37 @@ let rec (eq_tm : fun env -> fun t1 -> fun t2 -> - let eq_tm1 = eq_tm env in let t11 = FStar_Syntax_Util.canon_app t1 in let t21 = FStar_Syntax_Util.canon_app t2 in - let equal_data f1 parms1 args1 f2 parms2 args2 = + let equal_data f1 args1 f2 args2 n_parms = let uu___ = FStar_Syntax_Syntax.fv_eq f1 f2 in if uu___ then - (if - ((FStar_Compiler_List.length parms1) = - (FStar_Compiler_List.length parms2)) - && - ((FStar_Compiler_List.length args1) = - (FStar_Compiler_List.length args2)) + let n1 = FStar_Compiler_List.length args1 in + let n2 = FStar_Compiler_List.length args2 in + (if (n1 = n2) && (n_parms <= n1) then - let eq_arg_list as1 as2 = - FStar_Compiler_List.fold_left2 - (fun acc -> - fun uu___1 -> - fun uu___2 -> - match (uu___1, uu___2) with - | ((a1, q1), (a2, q2)) -> - let uu___3 = eq_tm1 a1 a2 in eq_inj acc uu___3) - Equal as1 as2 in - let args_eq = eq_arg_list args1 args2 in - (if args_eq = Equal - then - let parms_eq = eq_arg_list parms1 parms2 in - (if parms_eq = Equal then Equal else Unknown) - else args_eq) + let uu___1 = FStar_Compiler_List.splitAt n_parms args1 in + match uu___1 with + | (parms1, args11) -> + let uu___2 = FStar_Compiler_List.splitAt n_parms args2 in + (match uu___2 with + | (parms2, args21) -> + let eq_arg_list as1 as2 = + FStar_Compiler_List.fold_left2 + (fun acc -> + fun uu___3 -> + fun uu___4 -> + match (uu___3, uu___4) with + | ((a1, q1), (a2, q2)) -> + let uu___5 = eq_tm env a1 a2 in + eq_inj acc uu___5) Equal as1 as2 in + let args_eq = eq_arg_list args11 args21 in + if args_eq = Equal + then + let parms_eq = eq_arg_list parms1 parms2 in + (if parms_eq = Equal then Equal else Unknown) + else args_eq) else Unknown) else NotEqual in let qual_is_inj uu___ = @@ -120,34 +122,13 @@ let rec (eq_tm : (qual_is_inj g.FStar_Syntax_Syntax.fv_qual) -> let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.lid_of_fv f in - FStar_TypeChecker_Env.num_datacon_non_injective_ty_params - env uu___5 in - let uu___5 = - let uu___6 = FStar_Syntax_Syntax.lid_of_fv g in - FStar_TypeChecker_Env.num_datacon_non_injective_ty_params - env uu___6 in - (uu___4, uu___5) in + let uu___4 = FStar_Syntax_Syntax.lid_of_fv f in + FStar_TypeChecker_Env.num_datacon_non_injective_ty_params + env uu___4 in (match uu___3 with - | (FStar_Pervasives_Native.Some n1, - FStar_Pervasives_Native.Some n2) -> - if - (n1 <= (FStar_Compiler_List.length args1)) && - (n2 <= (FStar_Compiler_List.length args2)) - then - let uu___4 = - FStar_Compiler_List.splitAt n1 args1 in - (match uu___4 with - | (parms1, args11) -> - let uu___5 = - FStar_Compiler_List.splitAt n2 args2 in - (match uu___5 with - | (parms2, args21) -> - FStar_Pervasives_Native.Some - (f, parms1, args11, g, parms2, - args21))) - else FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some n -> + FStar_Pervasives_Native.Some + (f, args1, g, args2, n) | uu___4 -> FStar_Pervasives_Native.None) | uu___3 -> FStar_Pervasives_Native.None)) in let t12 = FStar_Syntax_Util.unmeta t11 in @@ -158,9 +139,9 @@ let rec (eq_tm : equal_if (bv1.FStar_Syntax_Syntax.index = bv2.FStar_Syntax_Syntax.index) | (FStar_Syntax_Syntax.Tm_lazy uu___, uu___1) -> - let uu___2 = FStar_Syntax_Util.unlazy t12 in eq_tm1 uu___2 t22 + let uu___2 = FStar_Syntax_Util.unlazy t12 in eq_tm env uu___2 t22 | (uu___, FStar_Syntax_Syntax.Tm_lazy uu___1) -> - let uu___2 = FStar_Syntax_Util.unlazy t22 in eq_tm1 t12 uu___2 + let uu___2 = FStar_Syntax_Util.unlazy t22 in eq_tm env t12 uu___2 | (FStar_Syntax_Syntax.Tm_name a, FStar_Syntax_Syntax.Tm_name b) -> let uu___ = FStar_Syntax_Syntax.bv_eq a b in equal_if uu___ | uu___ when @@ -170,13 +151,12 @@ let rec (eq_tm : let uu___1 = FStar_Compiler_Util.must heads_and_args_in_case_both_data in (match uu___1 with - | (f, parms1, args1, g, parms2, args2) -> - equal_data f parms1 args1 g parms2 args2) + | (f, args1, g, args2, n) -> equal_data f args1 g args2 n) | (FStar_Syntax_Syntax.Tm_fvar f, FStar_Syntax_Syntax.Tm_fvar g) -> let uu___ = FStar_Syntax_Syntax.fv_eq f g in equal_if uu___ | (FStar_Syntax_Syntax.Tm_uinst (f, us), FStar_Syntax_Syntax.Tm_uinst (g, vs)) -> - let uu___ = eq_tm1 f g in + let uu___ = eq_tm env f g in eq_and uu___ (fun uu___1 -> let uu___2 = FStar_Syntax_Util.eq_univs_list us vs in @@ -217,9 +197,9 @@ let rec (eq_tm : let uu___2 = FStar_Syntax_Syntax.lid_of_fv f1 in FStar_Ident.string_of_lid uu___2 in FStar_Compiler_List.mem uu___1 injectives) - -> equal_data f1 [] args1 f2 [] args2 + -> equal_data f1 args1 f2 args2 Prims.int_zero | uu___1 -> - let uu___2 = eq_tm1 h1 h2 in + let uu___2 = eq_tm env h1 h2 in eq_and uu___2 (fun uu___3 -> eq_args env args1 args2)) | (FStar_Syntax_Syntax.Tm_match { FStar_Syntax_Syntax.scrutinee = t13; @@ -237,7 +217,7 @@ let rec (eq_tm : (FStar_Compiler_List.length bs2) then let uu___4 = FStar_Compiler_List.zip bs1 bs2 in - let uu___5 = eq_tm1 t13 t23 in + let uu___5 = eq_tm env t13 t23 in FStar_Compiler_List.fold_right (fun uu___6 -> fun a -> @@ -256,9 +236,9 @@ let rec (eq_tm : { FStar_Syntax_Syntax.b = t23; FStar_Syntax_Syntax.phi = phi2;_}) -> let uu___ = - eq_tm1 t13.FStar_Syntax_Syntax.sort + eq_tm env t13.FStar_Syntax_Syntax.sort t23.FStar_Syntax_Syntax.sort in - eq_and uu___ (fun uu___1 -> eq_tm1 phi1 phi2) + eq_and uu___ (fun uu___1 -> eq_tm env phi1 phi2) | (FStar_Syntax_Syntax.Tm_abs { FStar_Syntax_Syntax.bs = bs1; FStar_Syntax_Syntax.body = body1; FStar_Syntax_Syntax.rc_opt = uu___;_}, @@ -276,11 +256,11 @@ let rec (eq_tm : fun b2 -> eq_and r (fun uu___3 -> - eq_tm1 + eq_tm env (b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort (b2.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort)) Equal bs1 bs2 in - eq_and uu___2 (fun uu___3 -> eq_tm1 body1 body2) + eq_and uu___2 (fun uu___3 -> eq_tm env body1 body2) | (FStar_Syntax_Syntax.Tm_arrow { FStar_Syntax_Syntax.bs1 = bs1; FStar_Syntax_Syntax.comp = c1;_}, FStar_Syntax_Syntax.Tm_arrow @@ -296,7 +276,7 @@ let rec (eq_tm : fun b2 -> eq_and r (fun uu___1 -> - eq_tm1 + eq_tm env (b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort (b2.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort)) Equal bs1 bs2 in diff --git a/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst b/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst index e7d5ae2cc4f..386d664457f 100644 --- a/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst +++ b/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst @@ -77,65 +77,60 @@ let eq_and r s = (* Precondition: terms are well-typed in a common environment, or this can return false positives *) let rec eq_tm (env:env_t) (t1:term) (t2:term) : eq_result = - let eq_tm = eq_tm env in let t1 = canon_app t1 in let t2 = canon_app t2 in - let equal_data (f1:fv) (parms1 args1:Syntax.args) (f2:fv) (parms2 args2:Syntax.args) = + let equal_data (f1:S.fv) (args1:Syntax.args) (f2:fv) (args2:Syntax.args) (n_parms:int) = // we got constructors! we know they are injective and disjoint, so we can do some // good analysis on them if fv_eq f1 f2 then ( - if List.length parms1 = List.length parms2 - && List.length args1 = List.length args2 + let n1 = List.length args1 in + let n2 = List.length args2 in + if n1 = n2 && n_parms <= n1 then ( + let parms1, args1 = List.splitAt n_parms args1 in + let parms2, args2 = List.splitAt n_parms args2 in let eq_arg_list as1 as2 = - List.fold_left2 - (fun acc (a1, q1) (a2, q2) -> - //if q1 <> q2 - //then failwith (U.format1 "Arguments of %s mismatch on implicit qualifier\n" - // (Ident.string_of_lid f1.fv_name.v)); - //NS: 05/06/2018 ...this does not always hold - // it's been succeeding because the assert is disabled in the non-debug builds - //assert (q1 = q2); - eq_inj acc (eq_tm a1 a2)) - Equal - as1 - as2 + List.fold_left2 + (fun acc (a1, q1) (a2, q2) -> + //if q1 <> q2 + //then failwith (U.format1 "Arguments of %s mismatch on implicit qualifier\n" + // (Ident.string_of_lid f1.fv_name.v)); + //NS: 05/06/2018 ...this does not always hold + // it's been succeeding because the assert is disabled in the non-debug builds + //assert (q1 = q2); + eq_inj acc (eq_tm env a1 a2)) + Equal + as1 + as2 in let args_eq = eq_arg_list args1 args2 in if args_eq = Equal - then let parms_eq = eq_arg_list parms1 parms2 in - if parms_eq = Equal - then Equal - else Unknown + then + let parms_eq = eq_arg_list parms1 parms2 in + if parms_eq = Equal + then Equal + else Unknown else args_eq ) else Unknown - ) else NotEqual + ) + else NotEqual in let qual_is_inj = function | Some Data_ctor | Some (Record_ctor _) -> true | _ -> false in - let heads_and_args_in_case_both_data :option (fv * args * args * fv * args * args) = + let heads_and_args_in_case_both_data : option (S.fv * args * S.fv * args * int) = let head1, args1 = t1 |> unmeta |> head_and_args in let head2, args2 = t2 |> unmeta |> head_and_args in match (un_uinst head1).n, (un_uinst head2).n with | Tm_fvar f, Tm_fvar g when qual_is_inj f.fv_qual && qual_is_inj g.fv_qual -> ( - match Env.num_datacon_non_injective_ty_params env (lid_of_fv f), - Env.num_datacon_non_injective_ty_params env (lid_of_fv g) with - | Some n1, Some n2 -> - if n1 <= List.length args1 - && n2 <= List.length args2 - then ( - let parms1, args1 = List.splitAt n1 args1 in - let parms2, args2 = List.splitAt n2 args2 in - Some (f, parms1, args1, g, parms2, args2) - ) - else None + match Env.num_datacon_non_injective_ty_params env (lid_of_fv f) with + | Some n -> Some (f, args1, g, args2, n) | _ -> None ) | _ -> None @@ -148,15 +143,15 @@ let rec eq_tm (env:env_t) (t1:term) (t2:term) : eq_result = | Tm_bvar bv1, Tm_bvar bv2 -> equal_if (bv1.index = bv2.index) - | Tm_lazy _, _ -> eq_tm (unlazy t1) t2 - | _, Tm_lazy _ -> eq_tm t1 (unlazy t2) + | Tm_lazy _, _ -> eq_tm env (unlazy t1) t2 + | _, Tm_lazy _ -> eq_tm env t1 (unlazy t2) | Tm_name a, Tm_name b -> equal_if (bv_eq a b) | _ when heads_and_args_in_case_both_data |> Some? -> //matches only when both are data constructors - heads_and_args_in_case_both_data |> must |> (fun (f, parms1, args1, g, parms2, args2) -> - equal_data f parms1 args1 g parms2 args2 + heads_and_args_in_case_both_data |> must |> (fun (f, args1, g, args2, n) -> + equal_data f args1 g args2 n ) | Tm_fvar f, Tm_fvar g -> equal_if (fv_eq f g) @@ -164,7 +159,7 @@ let rec eq_tm (env:env_t) (t1:term) (t2:term) : eq_result = | Tm_uinst(f, us), Tm_uinst(g, vs) -> // If the fvars and universe instantiations match, then Equal, // otherwise Unknown. - eq_and (eq_tm f g) (fun () -> equal_if (eq_univs_list us vs)) + eq_and (eq_tm env f g) (fun () -> equal_if (eq_univs_list us vs)) | Tm_constant (Const_range _), Tm_constant (Const_range _) -> // Ranges should be opaque, even to the normalizer. c.f. #1312 @@ -195,17 +190,17 @@ let rec eq_tm (env:env_t) (t1:term) (t2:term) : eq_result = | Tm_app {hd=h1; args=args1}, Tm_app {hd=h2; args=args2} -> begin match (un_uinst h1).n, (un_uinst h2).n with | Tm_fvar f1, Tm_fvar f2 when fv_eq f1 f2 && List.mem (string_of_lid (lid_of_fv f1)) injectives -> - equal_data f1 [] args1 f2 [] args2 + equal_data f1 args1 f2 args2 0 | _ -> // can only assert they're equal if they syntactically match, nothing else - eq_and (eq_tm h1 h2) (fun () -> eq_args env args1 args2) + eq_and (eq_tm env h1 h2) (fun () -> eq_args env args1 args2) end | Tm_match {scrutinee=t1; brs=bs1}, Tm_match {scrutinee=t2; brs=bs2} -> //AR: note: no return annotations if List.length bs1 = List.length bs2 then List.fold_right (fun (b1, b2) a -> eq_and a (fun () -> branch_matches env b1 b2)) (List.zip bs1 bs2) - (eq_tm t1 t2) + (eq_tm env t1 t2) else Unknown | Tm_type u, Tm_type v -> @@ -221,7 +216,7 @@ let rec eq_tm (env:env_t) (t1:term) (t2:term) : eq_result = Unknown | Tm_refine {b=t1; phi=phi1}, Tm_refine {b=t2; phi=phi2} -> - eq_and (eq_tm t1.sort t2.sort) (fun () -> eq_tm phi1 phi2) + eq_and (eq_tm env t1.sort t2.sort) (fun () -> eq_tm env phi1 phi2) (* * AR: ignoring residual comp here, that's an ascription added by the typechecker @@ -230,13 +225,13 @@ let rec eq_tm (env:env_t) (t1:term) (t2:term) : eq_result = | Tm_abs {bs=bs1; body=body1}, Tm_abs {bs=bs2; body=body2} when List.length bs1 = List.length bs2 -> - eq_and (List.fold_left2 (fun r b1 b2 -> eq_and r (fun () -> eq_tm b1.binder_bv.sort b2.binder_bv.sort)) + eq_and (List.fold_left2 (fun r b1 b2 -> eq_and r (fun () -> eq_tm env b1.binder_bv.sort b2.binder_bv.sort)) Equal bs1 bs2) - (fun () -> eq_tm body1 body2) + (fun () -> eq_tm env body1 body2) | Tm_arrow {bs=bs1; comp=c1}, Tm_arrow {bs=bs2; comp=c2} when List.length bs1 = List.length bs2 -> - eq_and (List.fold_left2 (fun r b1 b2 -> eq_and r (fun () -> eq_tm b1.binder_bv.sort b2.binder_bv.sort)) + eq_and (List.fold_left2 (fun r b1 b2 -> eq_and r (fun () -> eq_tm env b1.binder_bv.sort b2.binder_bv.sort)) Equal bs1 bs2) (fun () -> eq_comp env c1 c2) From 18b55b2a52b20e3cea968e8ce79e3f7b4609be8a Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Sun, 28 Apr 2024 13:09:27 -0700 Subject: [PATCH 39/42] rlimit bump & retry on Lib.Vec.Lemmas --- tests/hacl/Lib.Vec.Lemmas.fst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/hacl/Lib.Vec.Lemmas.fst b/tests/hacl/Lib.Vec.Lemmas.fst index bde6bd5a505..2e458cae49c 100644 --- a/tests/hacl/Lib.Vec.Lemmas.fst +++ b/tests/hacl/Lib.Vec.Lemmas.fst @@ -202,7 +202,7 @@ let repeat_gen_blocks_multi_vec_step #inp_t w blocksize n hi_f inp a a_vec f f_v assert (repeat_gen_blocks_multi_vec_equiv_pre w blocksize n hi_f a a_vec f f_v normalize_v i b_v acc_v) -#push-options "--z3rlimit_factor 12" +#push-options "--z3rlimit_factor 16 --retry 2" let lemma_repeat_gen_blocks_multi_vec #inp_t w blocksize n hi_f inp a a_vec f f_v normalize_v acc_v0 = let len = length inp in let blocksize_v = w * blocksize in From 596cc5c35c8eb458e32f74c630c006e4c78b218f Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Mon, 29 Apr 2024 11:07:51 -0700 Subject: [PATCH 40/42] another test --- tests/bug-reports/BugBoxInjectivity.fst | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/tests/bug-reports/BugBoxInjectivity.fst b/tests/bug-reports/BugBoxInjectivity.fst index 11639740730..538de27e266 100644 --- a/tests/bug-reports/BugBoxInjectivity.fst +++ b/tests/bug-reports/BugBoxInjectivity.fst @@ -89,6 +89,10 @@ noeq type test3 (a:idx) : Type u#1 = | Mk3 : test3 a +[@@expect_failure] +let eq_test3_should_fail (x0 : test3 A1) (x1 : test3 A2) : unit = + assert (test3 A1 == test3 A2) + let case0 (x0 : test3 A1) (x1 : test3 A2) : Lemma False = assume (test3 A1 == test3 A2); assume (~ (Mk3 #A1 == coerce_eq () (Mk3 #A2))) From b85bee9c3184653eef8397a465cba21d686e182b Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Tue, 30 Apr 2024 09:47:23 -0700 Subject: [PATCH 41/42] eq_tm and eq_t disregard non-injective type parameters in equality tests of data constructors --- .../generated/FStar_TypeChecker_NBETerm.ml | 19 +------------------ .../FStar_TypeChecker_TermEqAndSimplify.ml | 7 +------ src/typechecker/FStar.TypeChecker.NBETerm.fst | 6 +----- .../FStar.TypeChecker.TermEqAndSimplify.fst | 9 +-------- tests/bug-reports/BugBoxInjectivity.fst | 9 +++------ 5 files changed, 7 insertions(+), 43 deletions(-) diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml index 14b4af2363b..2894ce29619 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml @@ -520,24 +520,7 @@ let rec (eq_t : | (parms1, args11) -> let uu___4 = FStar_Compiler_List.splitAt n args2 in (match uu___4 with - | (parms2, args21) -> - let uu___5 = - let uu___6 = eq_args1 args11 args21 in - uu___6 = - FStar_TypeChecker_TermEqAndSimplify.Equal in - if uu___5 - then - let uu___6 = - let uu___7 = eq_args1 parms1 parms2 in - uu___7 = - FStar_TypeChecker_TermEqAndSimplify.Equal in - (if uu___6 - then - FStar_TypeChecker_TermEqAndSimplify.Equal - else - FStar_TypeChecker_TermEqAndSimplify.Unknown) - else - FStar_TypeChecker_TermEqAndSimplify.NotEqual)) + | (parms2, args21) -> eq_args1 args11 args21)) else FStar_TypeChecker_TermEqAndSimplify.Unknown)) else FStar_TypeChecker_TermEqAndSimplify.NotEqual | (FV (v1, us1, args1), FV (v2, us2, args2)) -> diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml index e606fdf9d14..3adb921da18 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml @@ -81,12 +81,7 @@ let rec (eq_tm : | ((a1, q1), (a2, q2)) -> let uu___5 = eq_tm env a1 a2 in eq_inj acc uu___5) Equal as1 as2 in - let args_eq = eq_arg_list args11 args21 in - if args_eq = Equal - then - let parms_eq = eq_arg_list parms1 parms2 in - (if parms_eq = Equal then Equal else Unknown) - else args_eq) + eq_arg_list args11 args21) else Unknown) else NotEqual in let qual_is_inj uu___ = diff --git a/src/typechecker/FStar.TypeChecker.NBETerm.fst b/src/typechecker/FStar.TypeChecker.NBETerm.fst index 8a0d40ea096..827b5adc481 100644 --- a/src/typechecker/FStar.TypeChecker.NBETerm.fst +++ b/src/typechecker/FStar.TypeChecker.NBETerm.fst @@ -136,11 +136,7 @@ let rec eq_t env (t1 : t) (t2 : t) : TEQ.eq_result = in let parms1, args1 = List.splitAt n args1 in let parms2, args2 = List.splitAt n args2 in - if eq_args args1 args2 = TEQ.Equal - then if eq_args parms1 parms2 = TEQ.Equal - then TEQ.Equal - else TEQ.Unknown - else TEQ.NotEqual + eq_args args1 args2 ) else TEQ.Unknown end else TEQ.NotEqual diff --git a/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst b/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst index 386d664457f..87624e5b7aa 100644 --- a/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst +++ b/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst @@ -104,14 +104,7 @@ let rec eq_tm (env:env_t) (t1:term) (t2:term) : eq_result = as1 as2 in - let args_eq = eq_arg_list args1 args2 in - if args_eq = Equal - then - let parms_eq = eq_arg_list parms1 parms2 in - if parms_eq = Equal - then Equal - else Unknown - else args_eq + eq_arg_list args1 args2 ) else Unknown ) diff --git a/tests/bug-reports/BugBoxInjectivity.fst b/tests/bug-reports/BugBoxInjectivity.fst index 538de27e266..0651f1ea109 100644 --- a/tests/bug-reports/BugBoxInjectivity.fst +++ b/tests/bug-reports/BugBoxInjectivity.fst @@ -112,22 +112,19 @@ let case2 (x0 : test3 A1) (x1 : test3 A2) : Lemma False = T.trefl ()) -[@@expect_failure] let case4 (x0 : test3 A1) (x1 : test3 A2) : Lemma (test3 A1 == test3 A2 ==> Mk3 #A1 == coerce_eq () (Mk3 #A2)) = assume (test3 A1 == test3 A2); assert (Mk3 #A1 == coerce_eq () (Mk3 #A2)) by (T.norm [delta;primops]; - T.trivial()) //this can't be proven by the normalizer alone + T.trivial()) //this can be proven by the normalizer alone -[@@expect_failure] let case5 (x0 : test3 A1) (x1 : test3 A2) : Lemma (test3 A1 == test3 A2 ==> Mk3 #A1 == coerce_eq () (Mk3 #A2)) = assume (test3 A1 == test3 A2); assert (Mk3 #A1 == coerce_eq () (Mk3 #A2)) by (T.norm [delta;primops;nbe]; - T.trivial()) //this can't be proven by the normalizer alone; nor by nbe + T.trivial()) //this can be proven by the normalizer alone; nor by nbe let case6 (x0 : test3 A1) (x1 : test3 A2) : Lemma (test3 A1 == test3 A2 ==> Mk3 #A1 == coerce_eq () (Mk3 #A2)) = assume (test3 A1 == test3 A2); assert (Mk3 #A1 == coerce_eq () (Mk3 #A2)) - by (T.norm [delta;primops]; - T.smt()) //but it can by SMT, since the parameters are irrelevant + by (T.smt()) //but it can also by SMT, since the parameters are irrelevant From 3849844bc62687983bce7c4775bd69f7fa212938 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Tue, 30 Apr 2024 19:58:19 -0700 Subject: [PATCH 42/42] Fix test First few were failing due to `is_inj` not being found. Use codes for all of them. --- tests/bug-reports/BugBoxInjectivity.fst | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/tests/bug-reports/BugBoxInjectivity.fst b/tests/bug-reports/BugBoxInjectivity.fst index 0651f1ea109..bad8361afc5 100644 --- a/tests/bug-reports/BugBoxInjectivity.fst +++ b/tests/bug-reports/BugBoxInjectivity.fst @@ -1,5 +1,8 @@ module BugBoxInjectivity +open FStar.Functions +module CC = FStar.Cardinality.Universes + //The original bug; using an indirection to subvert the injectivity check let mytype1 = Type u#1 @@ -10,7 +13,7 @@ let inj_my_t (#a:Type u#1) (x:my_t a) : Lemma (x == My #a) = () -[@@expect_failure] +[@@expect_failure [19]] let my_t_injective : squash (is_inj my_t) = introduce forall f0 f1. my_t f0 == my_t f1 ==> f0 == f1 @@ -28,7 +31,7 @@ let inj_t (#a:Type u#1) (x:t a) : Lemma (x == Mk #a) = () -[@@expect_failure] +[@@expect_failure [19]] let t_injective : squash (is_inj t) = introduce forall f0 f1. t f0 == t f1 ==> f0 == f1 @@ -38,8 +41,6 @@ let t_injective : squash (is_inj t) = inj_t #f1 (coerce_eq () (Mk #f0)) ) -open FStar.Functions -module CC = FStar.Cardinality.Universes //Disabling the injectivity check on parameters is inconsistent #push-options "--ext 'compat:injectivity'" noeq @@ -73,7 +74,7 @@ type ceq (#a:Type) x : a -> Type = let test a (x y:a) (h:ceq #a x y) : Lemma (x == y) = () //But without collapsing -[@expect_failure] +[@expect_failure [19]] let bad (h0:ceq true true) (h1:ceq false false) : Lemma (true == false) = let Refl = h0 in let Refl = h1 in @@ -89,7 +90,7 @@ noeq type test3 (a:idx) : Type u#1 = | Mk3 : test3 a -[@@expect_failure] +[@@expect_failure [19]] let eq_test3_should_fail (x0 : test3 A1) (x1 : test3 A2) : unit = assert (test3 A1 == test3 A2) @@ -97,14 +98,14 @@ let case0 (x0 : test3 A1) (x1 : test3 A2) : Lemma False = assume (test3 A1 == test3 A2); assume (~ (Mk3 #A1 == coerce_eq () (Mk3 #A2))) -[@@expect_failure] +[@@expect_failure [228]] let case1 (x0 : test3 A1) (x1 : test3 A2) : Lemma False = assume (test3 A1 == test3 A2); assert (~ (Mk3 #A1 == coerce_eq () (Mk3 #A2))) by (T.norm [delta;primops]; T.trefl ()) -[@@expect_failure] +[@@expect_failure [228]] let case2 (x0 : test3 A1) (x1 : test3 A2) : Lemma False = assume (test3 A1 == test3 A2); assert (~ (Mk3 #A1 == coerce_eq () (Mk3 #A2))) @@ -122,7 +123,7 @@ let case5 (x0 : test3 A1) (x1 : test3 A2) : Lemma (test3 A1 == test3 A2 ==> Mk3 assume (test3 A1 == test3 A2); assert (Mk3 #A1 == coerce_eq () (Mk3 #A2)) by (T.norm [delta;primops;nbe]; - T.trivial()) //this can be proven by the normalizer alone; nor by nbe + T.trivial()) //this can be proven by the normalizer alone; and by nbe let case6 (x0 : test3 A1) (x1 : test3 A2) : Lemma (test3 A1 == test3 A2 ==> Mk3 #A1 == coerce_eq () (Mk3 #A2)) = assume (test3 A1 == test3 A2);