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_CheckedFiles.ml b/ocaml/fstar-lib/generated/FStar_CheckedFiles.ml index 767d4dff399..d2c3052e64f 100644 --- a/ocaml/fstar-lib/generated/FStar_CheckedFiles.ml +++ b/ocaml/fstar-lib/generated/FStar_CheckedFiles.ml @@ -1,7 +1,7 @@ open Prims let (dbg : Prims.bool FStar_Compiler_Effect.ref) = FStar_Compiler_Debug.get_toggle "CheckedFiles" -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 5f9ac7c432e..7736e0f1b26 100644 --- a/ocaml/fstar-lib/generated/FStar_Extraction_ML_Modul.ml +++ b/ocaml/fstar-lib/generated/FStar_Extraction_ML_Modul.ml @@ -452,13 +452,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 @@ -473,93 +474,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; @@ -1031,17 +1034,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___;_}, @@ -2060,17 +2064,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 50e4adc12cc..a641457f466 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 b8744245c80..80272ec4cdb 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml @@ -707,70 +707,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 - ("PreType", [xx]) in - (tapp, uu___10) 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 -> @@ -2106,8 +2126,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 @@ -3761,1578 +3782,671 @@ 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 : +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 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_Compiler_Effect.op_Bang dbg_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 = + | 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; + FStar_Syntax_Syntax.injective_type_params = injective_type_params;_} + -> + 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 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_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_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_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.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___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_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 = + 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___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 = + 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 + 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 : 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_Compiler_Effect.op_Bang dbg_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___ = 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.new_term_constant_and_tok_from_lid - env1 a.FStar_Syntax_Syntax.action_name arity in + FStar_SMTEncoding_Env.fresh_fvar + env1.FStar_SMTEncoding_Env.current_module_name "f" + FStar_SMTEncoding_Term.Fuel_sort in (match uu___5 with - | (aname, atok, env2) -> + | (fuel_var, fuel_tm) -> + let s_fuel_tm = + FStar_SMTEncoding_Util.mkApp ("SFuel", [fuel_tm]) in let uu___6 = - FStar_SMTEncoding_EncodeTerm.encode_term - action_defn env2 in + FStar_SMTEncoding_EncodeTerm.encode_binders + (FStar_Pervasives_Native.Some fuel_tm) formals + env1 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 + | (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 = - 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_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 - (xxsym, + (ddtok, 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 = + [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 = - 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 + 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___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 + uu___10 uu___11 + | uu___8 -> tok_typing in + let uu___8 = 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_Compiler_Effect.op_Bang dbg_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_Compiler_Effect.op_Bang dbg_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 tcenv = env.FStar_SMTEncoding_Env.tcenv in - let is_injective = - 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 uu___10 = - FStar_TypeChecker_Normalize.normalize_universe - env_tps u in - universe_leq uu___10 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 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 - FStar_Compiler_List.forall2 tp_ok tps3 - us)))) in - ((let uu___4 = FStar_Compiler_Effect.op_Bang dbg_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 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 = - if is_injective - 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 [] 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_SMTEncoding_Term.field_name = - uu___11; - FStar_SMTEncoding_Term.field_sort = - uu___12; - FStar_SMTEncoding_Term.field_projectible - = false - }) vars in - let uu___11 = - let uu___12 = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id - () in - FStar_Pervasives_Native.Some uu___12 in - { - FStar_SMTEncoding_Term.constr_name = tname; - FStar_SMTEncoding_Term.constr_fields = - uu___10; - FStar_SMTEncoding_Term.constr_sort = - FStar_SMTEncoding_Term.Term_sort; - FStar_SMTEncoding_Term.constr_id = uu___11 - } in - constructor_or_logic_type_decl uu___9 in - let uu___9 = - match vars with - | [] -> - let uu___10 = - let uu___11 = - let uu___12 = - FStar_SMTEncoding_Util.mkApp - (tname, []) in - FStar_Pervasives_Native.Some uu___12 in - FStar_SMTEncoding_Env.push_free_var env1 - t arity tname uu___11 in - ([], uu___10) - | uu___10 -> - let ttok_decl = - FStar_SMTEncoding_Term.DeclFun - (ttok, [], - FStar_SMTEncoding_Term.Term_sort, - (FStar_Pervasives_Native.Some - "token")) in - let ttok_fresh = - let uu___11 = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id - () in - FStar_SMTEncoding_Term.fresh_token - (ttok, - FStar_SMTEncoding_Term.Term_sort) - uu___11 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 = - FStar_Ident.range_of_lid t in - let uu___14 = - let uu___15 = - FStar_SMTEncoding_Util.mkEq - (ttok_app, tapp) in - (pats, - FStar_Pervasives_Native.None, - vars, uu___15) in - FStar_SMTEncoding_Term.mkForall' - uu___13 uu___14 in - (uu___12, - (FStar_Pervasives_Native.Some - "name-token correspondence"), - (Prims.strcat - "token_correspondence_" ttok)) in - FStar_SMTEncoding_Util.mkAssume uu___11 in - ([ttok_decl; ttok_fresh; name_tok_corr], - env1) in - match uu___9 with - | (tok_decls, env2) -> - ((FStar_Compiler_List.op_At tname_decl - tok_decls), env2) in - (match uu___8 with - | (decls, env2) -> - let kindingAx = - let uu___9 = - FStar_SMTEncoding_EncodeTerm.encode_term_pred - FStar_Pervasives_Native.None res env' - tapp in - match uu___9 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 = - FStar_SMTEncoding_Term.mk_PreType - ttok_tm in - FStar_SMTEncoding_Term.mk_tester - "Tm_arrow" uu___13 in - (uu___12, - (FStar_Pervasives_Native.Some - "kinding"), - (Prims.strcat "pre_kinding_" - ttok)) in - FStar_SMTEncoding_Util.mkAssume - uu___11 in - [uu___10] - else [] in - let rng = FStar_Ident.range_of_lid t in - let tot_fun_axioms = - let uu___10 = - FStar_Compiler_List.map - (fun uu___11 -> - 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 = - FStar_SMTEncoding_Util.mkImp - (guard, k1) in - ([[tapp]], vars, - uu___19) in - FStar_SMTEncoding_Term.mkForall - rng uu___18 in - (tot_fun_axioms, uu___17) in - FStar_SMTEncoding_Util.mkAnd - uu___16 in - (uu___15, - FStar_Pervasives_Native.None, - (Prims.strcat "kinding_" - ttok)) in - FStar_SMTEncoding_Util.mkAssume - uu___14 in - [uu___13] in - FStar_Compiler_List.op_At karr - uu___12 in - FStar_SMTEncoding_Term.mk_decls_trivial - uu___11 in - FStar_Compiler_List.op_At decls1 - uu___10 in - let aux = - let uu___9 = - let uu___10 = - inversion_axioms env2 tapp vars in - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Ident.range_of_lid t in - pretype_axiom uu___14 env2 tapp - vars in - [uu___13] 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 = - 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 - = - 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 - args - encoded_args in - FStar_Compiler_List.fold_left - (fun uu___19 -> - fun uu___20 - -> - match - (uu___19, + 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 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), @@ -5359,14 +4473,6 @@ and (encode_sigelt' : 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 @@ -5382,112 +4488,152 @@ 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 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, + 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, - ( - FStar_Pervasives_Native.Some + uu___26 + uu___27 in + (uu___25, + (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___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 -> @@ -5496,90 +4642,92 @@ and (encode_sigelt' : 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, - ( - FStar_Pervasives_Native.Some + uu___26 + uu___27 in + (uu___25, + (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___24 in + let uu___24 + = + let uu___25 + = + FStar_Compiler_Util.first_N n_tps formals in - match uu___21 - with - | (uu___22, - formals') + 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 = @@ -5592,26 +4740,26 @@ and (encode_sigelt' : 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, @@ -5622,28 +4770,28 @@ and (encode_sigelt' : 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) @@ -5654,25 +4802,25 @@ and (encode_sigelt' : [] -> 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 @@ -5682,61 +4830,61 @@ and (encode_sigelt' : 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 (); @@ -5745,18 +4893,18 @@ and (encode_sigelt' : 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 (); @@ -5765,85 +4913,86 @@ and (encode_sigelt' : 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 + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env1.FStar_SMTEncoding_Env.tcenv head1 head' in - (match uu___33 + (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' | - 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 @@ -5854,90 +5003,90 @@ and (encode_sigelt' : 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, @@ -5950,141 +5099,94 @@ and (encode_sigelt' : ([], 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) - -> - ((FStar_Compiler_List.op_At + (match uu___24 + 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 - = - 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 - args - encoded_args in - FStar_Compiler_List.fold_left - (fun uu___15 -> - fun uu___16 - -> - match - (uu___15, + 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, uu___16) - with - | ((env2, + with + | ((env2, arg_vars, eqns_or_guards, i), @@ -6111,14 +5213,6 @@ and (encode_sigelt' : 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 @@ -6134,112 +5228,152 @@ 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 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, + 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, - ( - FStar_Pervasives_Native.Some + uu___22 + uu___23 in + (uu___21, + (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___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 -> @@ -6248,90 +5382,92 @@ and (encode_sigelt' : 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, - ( - FStar_Pervasives_Native.Some + uu___22 + uu___23 in + (uu___21, + (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___20 in + let uu___20 + = + let uu___21 + = + FStar_Compiler_Util.first_N n_tps formals in - match uu___17 - with - | (uu___18, - formals') + 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 = @@ -6344,26 +5480,26 @@ and (encode_sigelt' : 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, @@ -6374,28 +5510,28 @@ and (encode_sigelt' : 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) @@ -6406,25 +5542,25 @@ and (encode_sigelt' : [] -> 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 @@ -6434,61 +5570,61 @@ and (encode_sigelt' : 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 (); @@ -6497,18 +5633,18 @@ and (encode_sigelt' : 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 (); @@ -6517,85 +5653,86 @@ and (encode_sigelt' : 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 + FStar_TypeChecker_TermEqAndSimplify.eq_tm + env1.FStar_SMTEncoding_Env.tcenv head1 head' in - (match uu___29 + (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' | - 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 @@ -6606,90 +5743,90 @@ and (encode_sigelt' : 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, @@ -6702,123 +5839,122 @@ and (encode_sigelt' : ([], 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) - -> - ((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))))) - | 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 + 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 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 - = - FStar_Compiler_List.map2 + 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 -> fun fresh_a @@ -6828,15 +5964,14 @@ and (encode_sigelt' : 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 @@ -6850,111 +5985,109 @@ and (encode_sigelt' : FStar_SMTEncoding_Term.rng = (t_res_tm.FStar_SMTEncoding_Term.rng) - } in - let uu___14 = - let uu___15 - = - 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, - 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 - = - let uu___20 + } in + let uu___14 = + let uu___15 + = + 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, + 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 + = + 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___21 - = - let uu___22 + let uu___19 = + let uu___20 = + let uu___21 + = + let uu___22 = let uu___23 = @@ -6973,55 +6106,781 @@ and (encode_sigelt' : 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_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 : + 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)))))))) +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_Compiler_Effect.op_Bang dbg_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_Compiler_Effect.op_Bang dbg_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_Compiler_Effect.op_Bang dbg_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_Compiler_Effect.op_Bang dbg_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 = + 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 env1 se1 + | FStar_Syntax_Syntax.Sig_datacon uu___5 -> + encode_datacon 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/ocaml/fstar-lib/generated/FStar_SMTEncoding_Term.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Term.ml index b661b4802aa..89925a4e440 100644 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Term.ml +++ b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Term.ml @@ -260,27 +260,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 @@ -1490,13 +1500,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 +1530,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 @@ -1528,7 +1538,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 @@ -1609,6 +1618,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 = @@ -1622,10 +1695,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 @@ -1949,7 +2024,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 @@ -2028,7 +2104,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/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_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 793bb50b226..b3fc89264c6 100644 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Print.ml +++ b/ocaml/fstar-lib/generated/FStar_Syntax_Print.ml @@ -1452,41 +1452,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;_} @@ -1728,20 +1730,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 3aea0687b97..e09b08ea5a0 100644 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Resugar.ml +++ b/ocaml/fstar-lib/generated/FStar_Syntax_Resugar.ml @@ -2383,96 +2383,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 @@ -2480,32 +2484,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 @@ -2823,16 +2829,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 cb73ad57f8b..08a9131e5b2 100644 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Syntax.ml +++ b/ocaml/fstar-lib/generated/FStar_Syntax_Syntax.ml @@ -1766,7 +1766,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 ; @@ -1778,7 +1779,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 ; @@ -1856,17 +1858,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 -> @@ -1874,23 +1879,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 @@ -1902,37 +1916,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_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_Hooks.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Hooks.ml index 3ee32e8a0ea..ef387ec7a04 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Hooks.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_Hooks.ml @@ -1263,9 +1263,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) -> ((let uu___9 = FStar_Compiler_Effect.op_Bang diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_V1_Basic.ml b/ocaml/fstar-lib/generated/FStar_Tactics_V1_Basic.ml index 96167d0b5a5..dc6b1f1c378 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_V1_Basic.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_V1_Basic.ml @@ -7429,7 +7429,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 @@ -7437,36 +7439,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 @@ -7478,34 +7480,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 -> @@ -7513,16 +7515,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 @@ -7543,17 +7545,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 @@ -7562,7 +7566,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 @@ -7573,17 +7577,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 @@ -7591,26 +7595,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 = @@ -7619,26 +7623,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 @@ -7653,13 +7657,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); @@ -7674,100 +7678,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 = { @@ -7778,28 +7782,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 @@ -7811,17 +7815,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 @@ -7830,22 +7834,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)) @@ -7857,22 +7861,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 @@ -7884,9 +7888,9 @@ let (t_destruct : = FStar_Compiler_List.map (fun - uu___31 + uu___33 -> - match uu___31 + match uu___33 with | { @@ -7895,9 +7899,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 @@ -7927,7 +7931,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 { @@ -8088,23 +8092,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 @@ -8112,38 +8116,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 @@ -8151,7 +8155,7 @@ let (t_destruct : "destruct branch" env1 nty FStar_Pervasives_Native.None - uu___38 + uu___40 (rangeof g) in Obj.magic @@ -8159,18 +8163,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) @@ -8186,48 +8190,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 @@ -8235,9 +8239,9 @@ let (t_destruct : FStar_Tactics_Monad.monad_tac () () (Obj.magic - uu___16) + uu___17) (fun - uu___17 + uu___18 -> (fun goal_brs @@ -8246,11 +8250,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, @@ -8272,7 +8276,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 @@ -8280,21 +8284,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 @@ -8302,25 +8306,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 6f87446b2cd..5926d58e105 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_V2_Basic.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_V2_Basic.ml @@ -8089,7 +8089,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 @@ -8097,36 +8099,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 @@ -8138,34 +8140,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 -> @@ -8173,16 +8175,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 @@ -8203,33 +8205,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 @@ -8242,7 +8246,7 @@ let (t_destruct : FStar_Syntax_DsEnv.fv_qual_of_se se2 | - uu___20 + uu___22 -> fallback () in @@ -8250,7 +8254,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 @@ -8261,17 +8265,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 @@ -8279,26 +8283,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 = @@ -8307,26 +8311,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 @@ -8341,13 +8345,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); @@ -8362,100 +8366,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 = { @@ -8466,28 +8470,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 @@ -8499,17 +8503,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 @@ -8518,22 +8522,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)) @@ -8545,22 +8549,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 @@ -8572,9 +8576,9 @@ let (t_destruct : = FStar_Compiler_List.map (fun - uu___31 + uu___33 -> - match uu___31 + match uu___33 with | { @@ -8583,9 +8587,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 @@ -8615,7 +8619,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 { @@ -8776,23 +8780,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 @@ -8800,38 +8804,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 @@ -8839,7 +8843,7 @@ let (t_destruct : "destruct branch" env1 nty FStar_Pervasives_Native.None - uu___38 + uu___40 (rangeof g) in Obj.magic @@ -8847,18 +8851,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) @@ -8874,51 +8878,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 @@ -8926,9 +8930,9 @@ let (t_destruct : FStar_Tactics_Monad.monad_tac () () (Obj.magic - uu___16) + uu___17) (fun - uu___17 + uu___18 -> (fun goal_brs @@ -8937,11 +8941,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, @@ -8963,7 +8967,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 @@ -8971,21 +8975,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 @@ -8993,28 +8997,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 b7575c957ff..e8abafbd65d 100644 --- a/ocaml/fstar-lib/generated/FStar_ToSyntax_ToSyntax.ml +++ b/ocaml/fstar-lib/generated/FStar_ToSyntax_ToSyntax.ml @@ -1054,30 +1054,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 = @@ -1097,22 +1100,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 = @@ -6504,32 +6510,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___ -> []) @@ -6915,7 +6922,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; @@ -6981,7 +6990,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 = @@ -6990,22 +7001,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 :: @@ -7015,17 +7026,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 = @@ -7264,37 +7275,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 = @@ -7306,7 +7319,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; @@ -7456,7 +7471,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 @@ -7558,7 +7576,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; @@ -7626,16 +7647,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 @@ -7645,35 +7668,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 = @@ -9115,12 +9140,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) @@ -9140,7 +9167,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 @@ -9151,44 +9179,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 = []; @@ -9196,11 +9224,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 @@ -9703,7 +9731,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 a93274b1be0..a9b3409d57e 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 = @@ -2441,7 +2449,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 = 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 let uu___ = 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 ab1f0ea99e5..07dd360e1a8 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Core.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Core.ml @@ -3583,8 +3583,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 @@ -3646,8 +3647,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 733fcd70fce..6185862c8ee 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_DMFF.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_DMFF.ml @@ -3670,7 +3670,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 ba48df9bef1..2030c19eb1e 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Env.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Env.ml @@ -3140,18 +3140,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 = @@ -3195,32 +3196,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 = @@ -3231,32 +3233,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 @@ -3480,18 +3483,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 @@ -3515,18 +3519,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 @@ -3549,7 +3554,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; @@ -3558,9 +3590,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 @@ -3572,9 +3609,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; @@ -3583,12 +3622,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 -> @@ -4426,15 +4464,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 : @@ -4454,27 +4493,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_NBE.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_NBE.ml index e238925816f..956d49a01b5 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_NBE.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_NBE.ml @@ -2337,7 +2337,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 @@ -2893,9 +2894,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 -> @@ -2962,9 +2963,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 @@ -2981,9 +2982,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 @@ -3009,9 +3010,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..2894ce29619 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml @@ -418,124 +418,172 @@ 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 = + let uu___3 = FStar_Syntax_Syntax.lid_of_fv v1 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 + | 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) -> eq_args1 args11 args21)) + 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 + 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 991f0058a09..8ea83978024 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize.ml @@ -1584,7 +1584,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 = { @@ -1654,8 +1657,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); @@ -1665,7 +1667,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;_} @@ -8991,7 +8999,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 @@ -9006,7 +9015,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 = @@ -9048,7 +9059,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 @@ -9062,7 +9075,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 = @@ -9627,7 +9642,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_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_Positivity.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Positivity.ml index 6fa6b94eefe..881f4d8dd28 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Positivity.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Positivity.ml @@ -139,10 +139,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 = @@ -373,7 +374,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 @@ -391,31 +394,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 = @@ -474,7 +479,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_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 012abcc3a63..dca9b326c23 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Rel.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Rel.ml @@ -3254,8 +3254,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 @@ -3296,8 +3298,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 @@ -6579,8 +6583,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 @@ -6607,10 +6610,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) @@ -6878,8 +6880,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 @@ -7582,10 +7586,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 @@ -8249,8 +8253,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 @@ -8454,19 +8460,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 = @@ -10745,11 +10753,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; @@ -10757,7 +10767,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 @@ -10766,8 +10775,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)) @@ -10896,11 +10907,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; @@ -10908,7 +10921,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 @@ -10917,8 +10929,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)) @@ -11047,11 +11061,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; @@ -11059,7 +11075,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 @@ -11068,8 +11083,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)) @@ -11198,11 +11215,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; @@ -11210,7 +11229,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 @@ -11219,8 +11237,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)) @@ -11349,11 +11369,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; @@ -11361,7 +11383,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 @@ -11370,8 +11391,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)) @@ -11500,11 +11523,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; @@ -11512,7 +11537,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 @@ -11521,8 +11545,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)) @@ -11651,11 +11677,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; @@ -11663,7 +11691,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 @@ -11672,8 +11699,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)) @@ -11802,11 +11831,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; @@ -11814,7 +11845,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 @@ -11823,8 +11853,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)) @@ -11953,11 +11985,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; @@ -11965,7 +11999,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 @@ -11974,8 +12007,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)) @@ -12104,11 +12139,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; @@ -12116,7 +12153,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 @@ -12125,8 +12161,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)) @@ -12255,11 +12293,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; @@ -12267,7 +12307,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 @@ -12276,8 +12315,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)) @@ -12406,11 +12447,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; @@ -12418,7 +12461,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 @@ -12427,8 +12469,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_Tc.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Tc.ml index 48516b8a16f..211a4750dfa 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Tc.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Tc.ml @@ -20,13 +20,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; @@ -445,7 +447,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 @@ -474,7 +478,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 @@ -516,7 +522,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_TcEffect.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcEffect.ml index acec18567e9..9eada3e1a95 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcEffect.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcEffect.ml @@ -697,11 +697,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 @@ -711,11 +712,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 @@ -968,11 +970,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 @@ -1195,11 +1198,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 @@ -1928,11 +1932,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 @@ -2057,12 +2062,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 @@ -2674,11 +2680,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 @@ -2737,11 +2744,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 @@ -3471,10 +3479,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 @@ -7529,7 +7539,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_TcInductive.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcInductive.ml index 5b73f17e71c..667d0acc8f9 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcInductive.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcInductive.ml @@ -3,12 +3,294 @@ let (dbg_GenUniverses : Prims.bool FStar_Compiler_Effect.ref) = FStar_Compiler_Debug.get_toggle "GenUniverses" let (dbg_LogTypes : Prims.bool FStar_Compiler_Effect.ref) = FStar_Compiler_Debug.get_toggle "LogTypes" +let (dbg_Injectivity : Prims.bool FStar_Compiler_Effect.ref) = + FStar_Compiler_Debug.get_toggle "Injectivity" let (unfold_whnf : FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = 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_Compiler_Effect.op_Bang + dbg_Injectivity 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 -> @@ -23,36 +305,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 @@ -64,23 +347,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 @@ -100,21 +383,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 = @@ -124,22 +407,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) @@ -147,46 +430,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 = @@ -205,7 +488,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 = @@ -249,47 +534,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 @@ -308,37 +596,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 @@ -346,18 +634,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 @@ -368,69 +656,69 @@ 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 = FStar_Compiler_Debug.low () in - if uu___5 + ((let uu___6 = FStar_Compiler_Debug.low () in + 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 @@ -439,23 +727,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 @@ -463,11 +751,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 @@ -484,15 +772,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 @@ -501,10 +789,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 @@ -518,138 +806,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 -> { @@ -669,12 +957,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 @@ -694,7 +982,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 = @@ -739,12 +1029,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' = @@ -757,7 +1048,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 = @@ -826,19 +1118,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 @@ -846,18 +1140,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 { @@ -868,8 +1162,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 @@ -889,7 +1183,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 = @@ -943,19 +1239,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 @@ -989,15 +1287,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 = @@ -1014,7 +1314,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 = @@ -1047,7 +1349,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" @@ -1100,7 +1403,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 @@ -1374,7 +1678,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 @@ -1402,7 +1707,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 @@ -1440,7 +1747,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 @@ -1667,7 +1975,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 @@ -1730,7 +2039,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") @@ -1835,7 +2146,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___ = @@ -1847,7 +2159,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 @@ -1948,7 +2261,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 @@ -2057,49 +2372,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) @@ -2107,44 +2424,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 @@ -2167,32 +2484,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) @@ -2201,32 +2518,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 @@ -2248,7 +2565,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 = @@ -2273,11 +2592,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 @@ -2290,8 +2692,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; @@ -2304,7 +2706,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 : @@ -3163,142 +3565,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 f6dbea580ca..8980bfd17a7 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcTerm.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcTerm.ml @@ -1355,8 +1355,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 @@ -1545,8 +1547,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 @@ -5989,7 +5993,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 = @@ -6121,9 +6125,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..3adb921da18 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml @@ -0,0 +1,1324 @@ +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 t11 = FStar_Syntax_Util.canon_app t1 in + let t21 = FStar_Syntax_Util.canon_app t2 in + let equal_data f1 args1 f2 args2 n_parms = + let uu___ = FStar_Syntax_Syntax.fv_eq f1 f2 in + if uu___ + then + let n1 = FStar_Compiler_List.length args1 in + let n2 = FStar_Compiler_List.length args2 in + (if (n1 = n2) && (n_parms <= n1) + then + 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 + eq_arg_list args11 args21) + else Unknown) + 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) + -> + let uu___3 = + 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 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 + 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_tm env uu___2 t22 + | (uu___, FStar_Syntax_Syntax.Tm_lazy uu___1) -> + 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 + 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, 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_tm env 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 Prims.int_zero + | uu___1 -> + 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; + 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 env 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_tm env t13.FStar_Syntax_Syntax.sort + t23.FStar_Syntax_Syntax.sort in + 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___;_}, + 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 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_tm env 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 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___ (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 4ae03e87a65..fdfb141aa1d 100644 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Util.ml +++ b/ocaml/fstar-lib/generated/FStar_TypeChecker_Util.ml @@ -5903,8 +5903,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 = FStar_Compiler_Debug.extreme () in @@ -6494,11 +6497,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 @@ -8219,24 +8220,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 -> @@ -8244,8 +8247,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 -> @@ -8256,13 +8259,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/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/fstar/FStar.CheckedFiles.fst b/src/fstar/FStar.CheckedFiles.fst index 1e35e25a626..3b3c75743f9 100644 --- a/src/fstar/FStar.CheckedFiles.fst +++ b/src/fstar/FStar.CheckedFiles.fst @@ -36,7 +36,7 @@ let dbg = Debug.get_toggle "CheckedFiles" * 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 9d65ca8a5a5..0ee51771545 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 dbg_SMTEncoding = Debug.get_toggle "SMTEncoding" let dbg_SMTQuery = Debug.get_toggle "SMTQuery" @@ -172,14 +173,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(tapp, 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)))) @@ -537,7 +543,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 @@ -1003,6 +1009,463 @@ let encode_top_level_let : let decl = Caption ("let rec unencodeable: Skipping: " ^msg) in [decl] |> mk_decls_trivial, env +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; injective_type_params } = 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 is_l = mk_data_tester env l xx in + let inversion_case, decls' = + if injective_type_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, inversion_case), 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()); + constr_base=false + } + 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 (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 (env:env_t) (se:sigelt) +: decls_t * env_t += 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 + 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 injective_type_params = + injective_type_params || Options.ext_getv "compat:injectivity" <> "" + in + let fields = + names |> + List.mapi + (fun n x -> + let field_projectible = + n >= n_tps || //either this field is not a type parameter + 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; + field_projectible }) + in + let datacons = { + constr_name=ddconstrsym; + constr_fields=fields; + constr_sort=Term_sort; + constr_id=Some (varops.next_id()); + 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 + 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 _, 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 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 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 -> + 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 + 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, 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 + 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 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 + | 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 @@ -1218,514 +1681,62 @@ 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 tcenv = env.tcenv in - let is_injective = - 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 = - universe_leq (N.normalize_universe env_tps 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 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 - if !dbg_SMTEncoding - then BU.print2 "%s injectivity for %s\n" - (if is_injective 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 - then List.map2 (fun v a -> mkEq(mkFreeV v, a)) vars indices - else [] 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 [] + let g, env = + ses |> + List.fold_left + (fun (g, env) se -> + let g', env = + match se.sigel with + | Sig_inductive_typ _ -> + encode_sig_inductive env se + | Sig_datacon _ -> + encode_datacon env se + | _ -> + encode_sigelt env se 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 - - 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) - 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)) + 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 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: 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 + (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. diff --git a/src/smtencoding/FStar.SMTEncoding.Term.fst b/src/smtencoding/FStar.SMTEncoding.Term.fst index 26e9b57e2a1..0088c0644df 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 @@ -583,23 +581,23 @@ 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 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 @@ -636,8 +634,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)] (****************************************************************************) @@ -904,7 +930,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 @@ -984,7 +1011,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 249bdca5e30..38604196f5a 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 = 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 8934c154c38..cb8949e9ea3 100644 --- a/src/syntax/FStar.Syntax.Syntax.fsti +++ b/src/syntax/FStar.Syntax.Syntax.fsti @@ -661,6 +661,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, @@ -678,6 +679,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.Util.fst b/src/syntax/FStar.Syntax.Util.fst index cd780770653..58c6469defc 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 @@ -1688,7 +1651,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} -> @@ -1738,11 +1701,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 = @@ -1770,6 +1733,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; @@ -2361,7 +2374,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/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/tactics/FStar.Tactics.Hooks.fst b/src/tactics/FStar.Tactics.Hooks.fst index dbf17d331b3..596acf876e5 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. *) @@ -581,7 +582,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 !dbg_SpinoffAll 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/tosyntax/FStar.ToSyntax.ToSyntax.fst b/src/tosyntax/FStar.ToSyntax.ToSyntax.fst index a0a2c8c02bc..4f2a97084ac 100644 --- a/src/tosyntax/FStar.ToSyntax.ToSyntax.fst +++ b/src/tosyntax/FStar.ToSyntax.ToSyntax.fst @@ -591,14 +591,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} -> @@ -2964,7 +2966,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; @@ -3105,7 +3108,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 @@ -3134,7 +3138,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 ; @@ -3156,7 +3161,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 ; @@ -4041,7 +4047,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 95f03a6d954..d1f4fa10d66 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 -> @@ -385,7 +386,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 (env_dependent_ops e) (cached_steps ())) psteps in let dbg_flag = List.contains NormDebug s in { tcenv = e; 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 ab9d90a439d..5ea1d828ae5 100644 --- a/src/typechecker/FStar.TypeChecker.Common.fsti +++ b/src/typechecker/FStar.TypeChecker.Common.fsti @@ -205,7 +205,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 084de6eb176..ac88107b760 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 @@ -1136,7 +1138,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 7912022395a..efa5a2b6d7a 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 @@ -1300,7 +1301,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 55d081e60f0..3099e3a51d8 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.Env.fst b/src/typechecker/FStar.TypeChecker.Env.fst index 976e4a5a6f0..75c5ef69b7e 100644 --- a/src/typechecker/FStar.TypeChecker.Env.fst +++ b/src/typechecker/FStar.TypeChecker.Env.fst @@ -747,6 +747,12 @@ 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_non_injective_ty_params env lid = + match lookup_qname env lid with + | 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) = 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 a0c3eae54f6..578f4588f08 100644 --- a/src/typechecker/FStar.TypeChecker.Env.fsti +++ b/src/typechecker/FStar.TypeChecker.Env.fsti @@ -343,6 +343,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_non_injective_ty_params : env -> lident -> option int val delta_depth_of_qninfo : env -> fv -> qninfo -> delta_depth val delta_depth_of_fv : env -> fv -> delta_depth diff --git a/src/typechecker/FStar.TypeChecker.NBE.fst b/src/typechecker/FStar.TypeChecker.NBE.fst index e4ac18a964f..467201b9c96 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 @@ -1073,7 +1074,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 [] @@ -1292,7 +1293,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 ) @@ -1329,7 +1330,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 ) @@ -1341,7 +1342,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 ) @@ -1383,7 +1384,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..827b5adc481 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,88 @@ 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 + match Env.num_datacon_non_injective_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 + eq_args args1 args2 + ) + else TEQ.Unknown + 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 41d921d99e7..a28eb99dd0e 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 @@ -752,7 +752,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 *) @@ -1980,7 +1980,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 [] @@ -3293,7 +3293,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; @@ -3301,19 +3302,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 ce76ba58c40..b0789f04a2f 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.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 5258931aae6..f7c077c19bc 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 let dbg_Disch = Debug.get_toggle "Disch" let dbg_Discharge = Debug.get_toggle "Discharge" @@ -1374,7 +1375,7 @@ let head_matches_delta env (logical:bool) smt_ok t1 t2 : (match_result & option //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 !dbg_RelDelta then BU.print2 "Inlined %s to %s\n" @@ -1397,7 +1398,7 @@ let head_matches_delta env (logical:bool) smt_ok t1 t2 : (match_result & option *) 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 @@ -2690,7 +2691,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 @@ -2726,7 +2727,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 @@ -2861,7 +2862,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 @@ -3178,7 +3179,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 @@ -3446,7 +3447,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 -> @@ -3518,8 +3519,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 !dbg_Rel then BU.print4 "Unfolding didn't make progress ... got %s ~> %s;\nand %s ~> %s\n" @@ -4237,21 +4238,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 4a8fff0f425..71772f8eea8 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 @@ -257,9 +258,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 @@ -304,7 +305,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 @@ -338,7 +339,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 @@ -582,7 +583,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 @@ -603,7 +604,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 @@ -813,7 +814,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 @@ -824,7 +825,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 @@ -1081,7 +1082,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 @@ -2224,7 +2225,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.TcInductive.fst b/src/typechecker/FStar.TypeChecker.TcInductive.fst index 847f3888f10..e3aeda86ed4 100644 --- a/src/typechecker/FStar.TypeChecker.TcInductive.fst +++ b/src/typechecker/FStar.TypeChecker.TcInductive.fst @@ -46,9 +46,95 @@ module C = FStar.Parser.Const let dbg_GenUniverses = Debug.get_toggle "GenUniverses" let dbg_LogTypes = Debug.get_toggle "LogTypes" +let dbg_Injectivity = Debug.get_toggle "Injectivity" let unfold_whnf = N.unfold_whnf' [Env.AllowUnboundUniverses] +let check_sig_inductive_injectivity_on_params (tcenv:env_t) (se:sigelt) + : sigelt + = 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 + 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 !dbg_Injectivity + 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 *) @@ -107,7 +193,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 @@ -238,7 +325,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" @@ -293,7 +381,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 @@ -313,7 +402,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 @@ -866,13 +956,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 env0) 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.TcTerm.fst b/src/typechecker/FStar.TypeChecker.TcTerm.fst index 659d41db17b..17b1f78a3e2 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 let dbg_Exports = Debug.get_toggle "Exports" let dbg_LayeredEffects = Debug.get_toggle "LayeredEffects" @@ -565,7 +566,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 @@ -629,7 +630,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, @@ -2163,7 +2164,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) @@ -2224,7 +2225,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..87624e5b7aa --- /dev/null +++ b/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst @@ -0,0 +1,550 @@ +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 t1 = canon_app t1 in + let t2 = canon_app t2 in + 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 ( + 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 env a1 a2)) + Equal + as1 + as2 + in + eq_arg_list args1 args2 + ) + else Unknown + ) + 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 (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) with + | Some n -> Some (f, args1, g, args2, n) + | _ -> None + ) + | _ -> 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 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, args1, g, args2, n) -> + equal_data f args1 g args2 n + ) + + | 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 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 + 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 0 + + | _ -> // can only assert they're equal if they syntactically match, nothing else + 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 env 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 env t1.sort t2.sort) (fun () -> eq_tm env 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 env b1.binder_bv.sort b2.binder_bv.sort)) + Equal bs1 bs2) + (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 env 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 cf509784616..4dd0eea1242 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 @@ -2666,8 +2667,8 @@ 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 Debug.extreme () + 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 Debug.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); set_result_typ c, g_c @@ -2860,7 +2861,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 diff --git a/tests/bug-reports/BugBoxInjectivity.fst b/tests/bug-reports/BugBoxInjectivity.fst new file mode 100644 index 00000000000..bad8361afc5 --- /dev/null +++ b/tests/bug-reports/BugBoxInjectivity.fst @@ -0,0 +1,131 @@ +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 + +type my_t (a:mytype1) : Type u#0 = + | My : my_t a + +let inj_my_t (#a:Type u#1) (x:my_t a) +: Lemma (x == My #a) += () + +[@@expect_failure [19]] +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) += () + +[@@expect_failure [19]] +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)) + ) + +//Disabling the injectivity check on parameters is inconsistent +#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 + () +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 + + +//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 [19]] +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 + +[@@expect_failure [19]] +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))) + +[@@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 [228]] +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 ()) + + +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 be proven by the normalizer alone + +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 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); + assert (Mk3 #A1 == coerce_eq () (Mk3 #A2)) + by (T.smt()) //but it can also by SMT, since the parameters are irrelevant 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 880d5bd667f..ce2246e09d5 100644 --- a/tests/bug-reports/Makefile +++ b/tests/bug-reports/Makefile @@ -77,7 +77,8 @@ SHOULD_VERIFY_CLOSED=\ 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 Bug3252.fst + Bug2155.fst Bug3224a.fst Bug3224b.fst Bug3236.fst Bug3252.fst \ + BugBoxInjectivity.fst BugTypeParamProjector.fst SHOULD_VERIFY_INTERFACE_CLOSED=Bug771.fsti Bug771b.fsti SHOULD_VERIFY_AND_WARN_CLOSED=Bug016.fst 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 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