+48

.depend

reviewed

··· 1223 1223 typing/path.cmi \ 1224 1224 utils/identifiable.cmi \ 1225 1225 typing/ident.cmi 1226 1226 + typing/shape_reduce.cmo : \ 1227 1227 + typing/shape.cmi \ 1228 1228 + utils/local_store.cmi \ 1229 1229 + typing/ident.cmi \ 1230 1230 + typing/env.cmi \ 1231 1231 + typing/shape_reduce.cmi 1232 1232 + typing/shape_reduce.cmx : \ 1233 1233 + typing/shape.cmx \ 1234 1234 + utils/local_store.cmx \ 1235 1235 + typing/ident.cmx \ 1236 1236 + typing/env.cmx \ 1237 1237 + typing/shape_reduce.cmi 1238 1238 + typing/shape_reduce.cmi : \ 1239 1239 + typing/shape.cmi \ 1240 1240 + typing/env.cmi 1226 1241 typing/signature_group.cmo : \ 1227 1242 typing/types.cmi \ 1228 1243 typing/ident.cmi \ ··· 1498 1513 typing/typedecl_immediacy.cmi \ 1499 1514 typing/type_immediacy.cmi \ 1500 1515 typing/subst.cmi \ 1516 1516 + typing/shape.cmi \ 1501 1517 typing/printtyp.cmi \ 1502 1518 typing/primitive.cmi \ 1503 1519 typing/predef.cmi \ ··· 1535 1551 typing/typedecl_immediacy.cmx \ 1536 1552 typing/type_immediacy.cmx \ 1537 1553 typing/subst.cmx \ 1554 1554 + typing/shape.cmx \ 1538 1555 typing/printtyp.cmx \ 1539 1556 typing/primitive.cmx \ 1540 1557 typing/predef.cmx \ ··· 1566 1583 typing/typedecl_variance.cmi \ 1567 1584 typing/typedecl_separability.cmi \ 1568 1585 typing/typedecl_immediacy.cmi \ 1586 1586 + typing/shape.cmi \ 1569 1587 typing/path.cmi \ 1570 1588 parsing/parsetree.cmi \ 1571 1589 parsing/longident.cmi \ ··· 1733 1751 typing/typeclass.cmi \ 1734 1752 typing/subst.cmi \ 1735 1753 typing/signature_group.cmi \ 1754 1754 + typing/shape_reduce.cmi \ 1736 1755 typing/shape.cmi \ 1737 1756 typing/printtyp.cmi \ 1738 1757 typing/path.cmi \ ··· 1768 1787 typing/typeclass.cmx \ 1769 1788 typing/subst.cmx \ 1770 1789 typing/signature_group.cmx \ 1790 1790 + typing/shape_reduce.cmx \ 1771 1791 typing/shape.cmx \ 1772 1792 typing/printtyp.cmx \ 1773 1793 typing/path.cmx \ ··· 4069 4089 typing/types.cmi \ 4070 4090 typing/typedtree.cmi \ 4071 4091 typing/tast_mapper.cmi \ 4092 4092 + typing/tast_iterator.cmi \ 4093 4093 + typing/shape_reduce.cmi \ 4072 4094 typing/shape.cmi \ 4095 4095 + typing/predef.cmi \ 4096 4096 + typing/path.cmi \ 4073 4097 utils/misc.cmi \ 4098 4098 + parsing/longident.cmi \ 4074 4099 parsing/location.cmi \ 4075 4100 utils/load_path.cmi \ 4076 4101 parsing/lexer.cmi \ 4102 4102 + typing/ident.cmi \ 4077 4103 typing/env.cmi \ 4078 4104 utils/config.cmi \ 4079 4105 file_formats/cmi_format.cmi \ 4080 4106 utils/clflags.cmi \ 4107 4107 + typing/btype.cmi \ 4081 4108 file_formats/cmt_format.cmi 4082 4109 file_formats/cmt_format.cmx : \ 4083 4110 parsing/unit_info.cmx \ 4084 4111 typing/types.cmx \ 4085 4112 typing/typedtree.cmx \ 4086 4113 typing/tast_mapper.cmx \ 4114 4114 + typing/tast_iterator.cmx \ 4115 4115 + typing/shape_reduce.cmx \ 4087 4116 typing/shape.cmx \ 4117 4117 + typing/predef.cmx \ 4118 4118 + typing/path.cmx \ 4088 4119 utils/misc.cmx \ 4120 4120 + parsing/longident.cmx \ 4089 4121 parsing/location.cmx \ 4090 4122 utils/load_path.cmx \ 4091 4123 parsing/lexer.cmx \ 4124 4124 + typing/ident.cmx \ 4092 4125 typing/env.cmx \ 4093 4126 utils/config.cmx \ 4094 4127 file_formats/cmi_format.cmx \ 4095 4128 utils/clflags.cmx \ 4129 4129 + typing/btype.cmx \ 4096 4130 file_formats/cmt_format.cmi 4097 4131 file_formats/cmt_format.cmi : \ 4098 4132 parsing/unit_info.cmi \ 4099 4133 typing/types.cmi \ 4100 4134 typing/typedtree.cmi \ 4135 4135 + typing/shape_reduce.cmi \ 4101 4136 typing/shape.cmi \ 4102 4137 utils/misc.cmi \ 4138 4138 + parsing/longident.cmi \ 4103 4139 parsing/location.cmi \ 4104 4140 utils/load_path.cmi \ 4105 4141 typing/env.cmi \ ··· 6688 6724 toplevel/topcommon.cmi \ 6689 6725 bytecomp/symtable.cmi \ 6690 6726 lambda/simplif.cmi \ 6727 6727 + typing/shape_reduce.cmi \ 6691 6728 typing/shape.cmi \ 6692 6729 typing/printtyped.cmi \ 6693 6730 typing/printtyp.cmi \ ··· 6722 6759 toplevel/topcommon.cmx \ 6723 6760 bytecomp/symtable.cmx \ 6724 6761 lambda/simplif.cmx \ 6762 6762 + typing/shape_reduce.cmx \ 6725 6763 typing/shape.cmx \ 6726 6764 typing/printtyped.cmx \ 6727 6765 typing/printtyp.cmx \ ··· 6825 6863 toplevel/native/tophooks.cmi \ 6826 6864 toplevel/topcommon.cmi \ 6827 6865 lambda/simplif.cmi \ 6866 6866 + typing/shape_reduce.cmi \ 6828 6867 typing/shape.cmi \ 6829 6868 typing/printtyped.cmi \ 6830 6869 typing/printtyp.cmi \ ··· 6856 6895 toplevel/native/tophooks.cmx \ 6857 6896 toplevel/topcommon.cmx \ 6858 6897 lambda/simplif.cmx \ 6898 6898 + typing/shape_reduce.cmx \ 6859 6899 typing/shape.cmx \ 6860 6900 typing/printtyped.cmx \ 6861 6901 typing/printtyp.cmx \ ··· 7148 7188 tools/make_opcodes.cmi 7149 7189 tools/make_opcodes.cmi : 7150 7190 tools/objinfo.cmo : \ 7191 7191 + typing/typedtree.cmi \ 7151 7192 bytecomp/symtable.cmi \ 7152 7193 middle_end/symbol.cmi \ 7194 7194 + typing/shape_reduce.cmi \ 7153 7195 typing/shape.cmi \ 7154 7196 middle_end/printclambda.cmi \ 7197 7197 + parsing/pprintast.cmi \ 7155 7198 utils/misc.cmi \ 7199 7199 + parsing/location.cmi \ 7156 7200 middle_end/linkage_name.cmi \ 7157 7201 typing/ident.cmi \ 7158 7202 middle_end/flambda/export_info.cmi \ ··· 7166 7210 utils/binutils.cmi \ 7167 7211 tools/objinfo.cmi 7168 7212 tools/objinfo.cmx : \ 7213 7213 + typing/typedtree.cmx \ 7169 7214 bytecomp/symtable.cmx \ 7170 7215 middle_end/symbol.cmx \ 7216 7216 + typing/shape_reduce.cmx \ 7171 7217 typing/shape.cmx \ 7172 7218 middle_end/printclambda.cmx \ 7219 7219 + parsing/pprintast.cmx \ 7173 7220 utils/misc.cmx \ 7221 7221 + parsing/location.cmx \ 7174 7222 middle_end/linkage_name.cmx \ 7175 7223 typing/ident.cmx \ 7176 7224 middle_end/flambda/export_info.cmx \

+6

Changes

reviewed

··· 665 665 - #12764: Move all installable headers in `caml/` sub-directories. 666 666 (Antonin Décimo, review by Gabriel Scherer and David Allsopp) 667 667 668 668 + - #12508 : Add compiler-side support for project-wide occurrences in Merlin, by 669 669 + generating index tables of all identifier occurrences. This extra data in .cmt 670 670 + files is only added when the new flag -bin-annot-occurrences is passed. 671 671 + (Ulysse Gérard, Nathanaëlle Courant, suggestions by Gabriel Scherer and Thomas 672 672 + Refis, review by Florian Angeletti, Gabriel Scherer and Thomas Refis) 673 673 + 668 674 ### Build system: 669 675 670 676 - #12198, #12321, #12586, #12616, #12706: continue the merge of the

+1

Makefile

reviewed

··· 138 138 typing/tast_iterator.mli typing/tast_iterator.ml \ 139 139 typing/tast_mapper.mli typing/tast_mapper.ml \ 140 140 typing/stypes.mli typing/stypes.ml \ 141 141 + typing/shape_reduce.mli typing/shape_reduce.ml \ 141 142 file_formats/cmt_format.mli file_formats/cmt_format.ml \ 142 143 typing/cmt2annot.mli typing/cmt2annot.ml \ 143 144 typing/untypeast.mli typing/untypeast.ml \

+11

driver/main_args.ml

reviewed

··· 40 40 let mk_binannot f = 41 41 "-bin-annot", Arg.Unit f, " Save typedtree in <filename>.cmt" 42 42 43 43 + let mk_binannot_occurrences f = 44 44 + "-bin-annot-occurrences", Arg.Unit f, 45 45 + " Store every occurrence of a bound name in the .cmt file.\n\ 46 46 + This information can be used by external tools to provide\n\ 47 47 + features such as project-wide occurrences. This flag has\n\ 48 48 + no effect in the absence of '-bin-annot'." 49 49 + 43 50 let mk_c f = 44 51 "-c", Arg.Unit f, " Compile only (do not link)" 45 52 ··· 820 827 val _a : unit -> unit 821 828 val _annot : unit -> unit 822 829 val _binannot : unit -> unit 830 830 + val _binannot_occurrences : unit -> unit 823 831 val _c : unit -> unit 824 832 val _cc : string -> unit 825 833 val _cclib : string -> unit ··· 1015 1023 mk_no_absname F._no_absname; 1016 1024 mk_annot F._annot; 1017 1025 mk_binannot F._binannot; 1026 1026 + mk_binannot_occurrences F._binannot_occurrences; 1018 1027 mk_c F._c; 1019 1028 mk_cc F._cc; 1020 1029 mk_cclib F._cclib; ··· 1208 1217 mk_afl_inst_ratio F._afl_inst_ratio; 1209 1218 mk_annot F._annot; 1210 1219 mk_binannot F._binannot; 1220 1220 + mk_binannot_occurrences F._binannot_occurrences; 1211 1221 mk_inline_branch_factor F._inline_branch_factor; 1212 1222 mk_c F._c; 1213 1223 mk_cc F._cc; ··· 1736 1746 let _args = Arg.read_arg 1737 1747 let _args0 = Arg.read_arg0 1738 1748 let _binannot = set binary_annotations 1749 1749 + let _binannot_occurrences = set store_occurrences 1739 1750 let _c = set compile_only 1740 1751 let _cc s = c_compiler := (Some s) 1741 1752 let _cclib s = Compenv.defer (ProcessObjects (Misc.rev_split_words s))

+1

driver/main_args.mli

reviewed

··· 77 77 val _a : unit -> unit 78 78 val _annot : unit -> unit 79 79 val _binannot : unit -> unit 80 80 + val _binannot_occurrences : unit -> unit 80 81 val _c : unit -> unit 81 82 val _cc : string -> unit 82 83 val _cclib : string -> unit

+297 -13

file_formats/cmt_format.ml

reviewed

··· 36 36 | Partial_interface of binary_part array 37 37 38 38 and binary_part = 39 39 - | Partial_structure of structure 40 40 - | Partial_structure_item of structure_item 41 41 - | Partial_expression of expression 42 42 - | Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part 43 43 - | Partial_class_expr of class_expr 44 44 - | Partial_signature of signature 45 45 - | Partial_signature_item of signature_item 46 46 - | Partial_module_type of module_type 39 39 + | Partial_structure of structure 40 40 + | Partial_structure_item of structure_item 41 41 + | Partial_expression of expression 42 42 + | Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part 43 43 + | Partial_class_expr of class_expr 44 44 + | Partial_signature of signature 45 45 + | Partial_signature_item of signature_item 46 46 + | Partial_module_type of module_type 47 47 48 48 type cmt_infos = { 49 49 cmt_modname : string; ··· 60 60 cmt_imports : (string * Digest.t option) list; 61 61 cmt_interface_digest : Digest.t option; 62 62 cmt_use_summaries : bool; 63 63 - cmt_uid_to_loc : Location.t Shape.Uid.Tbl.t; 63 63 + cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t; 64 64 cmt_impl_shape : Shape.t option; (* None for mli *) 65 65 + cmt_ident_occurrences : 66 66 + (Longident.t Location.loc * Shape_reduce.result) list 65 67 } 66 68 67 69 type error = 68 70 Not_a_typedtree of string 69 71 72 72 + let iter_on_parts (it : Tast_iterator.iterator) = function 73 73 + | Partial_structure s -> it.structure it s 74 74 + | Partial_structure_item s -> it.structure_item it s 75 75 + | Partial_expression e -> it.expr it e 76 76 + | Partial_pattern (_category, p) -> it.pat it p 77 77 + | Partial_class_expr ce -> it.class_expr it ce 78 78 + | Partial_signature s -> it.signature it s 79 79 + | Partial_signature_item s -> it.signature_item it s 80 80 + | Partial_module_type s -> it.module_type it s 81 81 + 82 82 + let iter_on_annots (it : Tast_iterator.iterator) = function 83 83 + | Implementation s -> it.structure it s 84 84 + | Interface s -> it.signature it s 85 85 + | Packed _ -> () 86 86 + | Partial_implementation array -> Array.iter (iter_on_parts it) array 87 87 + | Partial_interface array -> Array.iter (iter_on_parts it) array 88 88 + 89 89 + let iter_on_declaration f decl = 90 90 + match decl with 91 91 + | Value vd -> f vd.val_val.val_uid decl; 92 92 + | Value_binding vb -> 93 93 + let bound_idents = let_bound_idents_full [vb] in 94 94 + List.iter (fun (_, _, _, uid) -> f uid decl) bound_idents 95 95 + | Type td -> 96 96 + if not (Btype.is_row_name (Ident.name td.typ_id)) then 97 97 + f td.typ_type.type_uid (Type td) 98 98 + | Constructor cd -> f cd.cd_uid decl 99 99 + | Extension_constructor ec -> f ec.ext_type.ext_uid decl; 100 100 + | Label ld -> f ld.ld_uid decl 101 101 + | Module md -> f md.md_uid decl 102 102 + | Module_type mtd -> f mtd.mtd_uid decl 103 103 + | Module_substitution ms -> f ms.ms_uid decl 104 104 + | Module_binding mb -> f mb.mb_uid decl 105 105 + | Class cd -> f cd.ci_decl.cty_uid decl 106 106 + | Class_type ct -> f ct.ci_decl.cty_uid decl 107 107 + 108 108 + let iter_on_declarations ~(f: Shape.Uid.t -> item_declaration -> unit) = { 109 109 + Tast_iterator.default_iterator with 110 110 + item_declaration = (fun _sub decl -> iter_on_declaration f decl); 111 111 + } 112 112 + 70 113 let need_to_clear_env = 71 114 try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false 72 115 with Not_found -> true 73 116 74 117 let keep_only_summary = Env.keep_only_summary 75 75 - 76 76 - open Tast_mapper 77 118 78 119 let cenv = 79 120 {Tast_mapper.default with env = fun _sub env -> keep_only_summary env} ··· 103 144 104 145 else binary_annots 105 146 147 147 + (* Every typedtree node with a located longident corresponding to user-facing 148 148 + syntax should be indexed. *) 149 149 + let iter_on_occurrences 150 150 + ~(f : namespace:Shape.Sig_component_kind.t -> 151 151 + Env.t -> Path.t -> Longident.t Location.loc -> 152 152 + unit) = 153 153 + let path_in_type typ name = 154 154 + match Types.get_desc typ with 155 155 + | Tconstr (type_path, _, _) -> 156 156 + Some (Path.Pdot (type_path, name)) 157 157 + | _ -> None 158 158 + in 159 159 + let add_constructor_description env lid = 160 160 + function 161 161 + | { Types.cstr_tag = Cstr_extension (path, _); _ } -> 162 162 + f ~namespace:Extension_constructor env path lid 163 163 + | { Types.cstr_uid = Predef name; _} -> 164 164 + let id = List.assoc name Predef.builtin_idents in 165 165 + f ~namespace:Constructor env (Pident id) lid 166 166 + | { Types.cstr_res; cstr_name; _ } -> 167 167 + let path = path_in_type cstr_res cstr_name in 168 168 + Option.iter (fun path -> f ~namespace:Constructor env path lid) path 169 169 + in 170 170 + let add_label env lid { Types.lbl_name; lbl_res; _ } = 171 171 + let path = path_in_type lbl_res lbl_name in 172 172 + Option.iter (fun path -> f ~namespace:Label env path lid) path 173 173 + in 174 174 + let with_constraint ~env (_path, _lid, with_constraint) = 175 175 + match with_constraint with 176 176 + | Twith_module (path', lid') | Twith_modsubst (path', lid') -> 177 177 + f ~namespace:Module env path' lid' 178 178 + | _ -> () 179 179 + in 180 180 + Tast_iterator.{ default_iterator with 181 181 + 182 182 + expr = (fun sub ({ exp_desc; exp_env; _ } as e) -> 183 183 + (match exp_desc with 184 184 + | Texp_ident (path, lid, _) -> 185 185 + f ~namespace:Value exp_env path lid 186 186 + | Texp_construct (lid, constr_desc, _) -> 187 187 + add_constructor_description exp_env lid constr_desc 188 188 + | Texp_field (_, lid, label_desc) 189 189 + | Texp_setfield (_, lid, label_desc, _) -> 190 190 + add_label exp_env lid label_desc 191 191 + | Texp_new (path, lid, _) -> 192 192 + f ~namespace:Class exp_env path lid 193 193 + | Texp_record { fields; _ } -> 194 194 + Array.iter (fun (label_descr, record_label_definition) -> 195 195 + match record_label_definition with 196 196 + | Overridden ( 197 197 + { Location.txt; loc}, 198 198 + {exp_loc; _}) 199 199 + when not exp_loc.loc_ghost 200 200 + && loc.loc_start = exp_loc.loc_start 201 201 + && loc.loc_end = exp_loc.loc_end -> 202 202 + (* In the presence of punning we want to index the label 203 203 + even if it is ghosted *) 204 204 + let lid = { Location.txt; loc = {loc with loc_ghost = false} } in 205 205 + add_label exp_env lid label_descr 206 206 + | Overridden (lid, _) -> add_label exp_env lid label_descr 207 207 + | Kept _ -> ()) fields 208 208 + | Texp_instvar (_self_path, path, name) -> 209 209 + let lid = { name with txt = Longident.Lident name.txt } in 210 210 + f ~namespace:Value exp_env path lid 211 211 + | Texp_setinstvar (_self_path, path, name, _) -> 212 212 + let lid = { name with txt = Longident.Lident name.txt } in 213 213 + f ~namespace:Value exp_env path lid 214 214 + | Texp_override (_self_path, modifs) -> 215 215 + List.iter (fun (id, (name : string Location.loc), _exp) -> 216 216 + let lid = { name with txt = Longident.Lident name.txt } in 217 217 + f ~namespace:Value exp_env (Path.Pident id) lid) 218 218 + modifs 219 219 + | Texp_extension_constructor (lid, path) -> 220 220 + f ~namespace:Extension_constructor exp_env path lid 221 221 + | Texp_constant _ | Texp_let _ | Texp_function _ | Texp_apply _ 222 222 + | Texp_match _ | Texp_try _ | Texp_tuple _ | Texp_variant _ | Texp_array _ 223 223 + | Texp_ifthenelse _ | Texp_sequence _ | Texp_while _ | Texp_for _ 224 224 + | Texp_send _ 225 225 + | Texp_letmodule _ | Texp_letexception _ | Texp_assert _ | Texp_lazy _ 226 226 + | Texp_object _ | Texp_pack _ | Texp_letop _ | Texp_unreachable 227 227 + | Texp_open _ -> ()); 228 228 + default_iterator.expr sub e); 229 229 + 230 230 + (* Remark: some types get iterated over twice due to how constraints are 231 231 + encoded in the typedtree. For example, in [let x : t = 42], [t] is 232 232 + present in both a [Tpat_constraint] and a [Texp_constraint] node) *) 233 233 + typ = 234 234 + (fun sub ({ ctyp_desc; ctyp_env; _ } as ct) -> 235 235 + (match ctyp_desc with 236 236 + | Ttyp_constr (path, lid, _ctyps) -> 237 237 + f ~namespace:Type ctyp_env path lid 238 238 + | Ttyp_package {pack_path; pack_txt} -> 239 239 + f ~namespace:Module_type ctyp_env pack_path pack_txt 240 240 + | Ttyp_class (path, lid, _typs) -> 241 241 + (* Deprecated syntax to extend a polymorphic variant *) 242 242 + f ~namespace:Type ctyp_env path lid 243 243 + | Ttyp_open (path, lid, _ct) -> 244 244 + f ~namespace:Module ctyp_env path lid 245 245 + | Ttyp_any | Ttyp_var _ | Ttyp_arrow _ | Ttyp_tuple _ | Ttyp_object _ 246 246 + | Ttyp_alias _ | Ttyp_variant _ | Ttyp_poly _ -> ()); 247 247 + default_iterator.typ sub ct); 248 248 + 249 249 + pat = 250 250 + (fun (type a) sub 251 251 + ({ pat_desc; pat_extra; pat_env; _ } as pat : a general_pattern) -> 252 252 + (match pat_desc with 253 253 + | Tpat_construct (lid, constr_desc, _, _) -> 254 254 + add_constructor_description pat_env lid constr_desc 255 255 + | Tpat_record (fields, _) -> 256 256 + List.iter (fun (lid, label_descr, pat) -> 257 257 + let lid = 258 258 + let open Location in 259 259 + (* In the presence of punning we want to index the label 260 260 + even if it is ghosted *) 261 261 + if (not pat.pat_loc.loc_ghost 262 262 + && lid.loc.loc_start = pat.pat_loc.loc_start 263 263 + && lid.loc.loc_end = pat.pat_loc.loc_end) 264 264 + then {lid with loc = {lid.loc with loc_ghost = false}} 265 265 + else lid 266 266 + in 267 267 + add_label pat_env lid label_descr) 268 268 + fields 269 269 + | Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_constant _ | Tpat_tuple _ 270 270 + | Tpat_variant _ | Tpat_array _ | Tpat_lazy _ | Tpat_value _ 271 271 + | Tpat_exception _ | Tpat_or _ -> ()); 272 272 + List.iter (fun (pat_extra, _, _) -> 273 273 + match pat_extra with 274 274 + | Tpat_open (path, lid, _) -> 275 275 + f ~namespace:Module pat_env path lid 276 276 + | Tpat_type (path, lid) -> 277 277 + f ~namespace:Type pat_env path lid 278 278 + | Tpat_constraint _ | Tpat_unpack -> ()) 279 279 + pat_extra; 280 280 + default_iterator.pat sub pat); 281 281 + 282 282 + binding_op = (fun sub ({bop_op_path; bop_op_name; bop_exp; _} as bop) -> 283 283 + let lid = { bop_op_name with txt = Longident.Lident bop_op_name.txt } in 284 284 + f ~namespace:Value bop_exp.exp_env bop_op_path lid; 285 285 + default_iterator.binding_op sub bop); 286 286 + 287 287 + module_expr = 288 288 + (fun sub ({ mod_desc; mod_env; _ } as me) -> 289 289 + (match mod_desc with 290 290 + | Tmod_ident (path, lid) -> f ~namespace:Module mod_env path lid 291 291 + | Tmod_structure _ | Tmod_functor _ | Tmod_apply _ | Tmod_apply_unit _ 292 292 + | Tmod_constraint _ | Tmod_unpack _ -> ()); 293 293 + default_iterator.module_expr sub me); 294 294 + 295 295 + open_description = 296 296 + (fun sub ({ open_expr = (path, lid); open_env; _ } as od) -> 297 297 + f ~namespace:Module open_env path lid; 298 298 + default_iterator.open_description sub od); 299 299 + 300 300 + module_type = 301 301 + (fun sub ({ mty_desc; mty_env; _ } as mty) -> 302 302 + (match mty_desc with 303 303 + | Tmty_ident (path, lid) -> 304 304 + f ~namespace:Module_type mty_env path lid 305 305 + | Tmty_with (_mty, l) -> 306 306 + List.iter (with_constraint ~env:mty_env) l 307 307 + | Tmty_alias (path, lid) -> 308 308 + f ~namespace:Module mty_env path lid 309 309 + | Tmty_signature _ | Tmty_functor _ | Tmty_typeof _ -> ()); 310 310 + default_iterator.module_type sub mty); 311 311 + 312 312 + class_expr = 313 313 + (fun sub ({ cl_desc; cl_env; _} as ce) -> 314 314 + (match cl_desc with 315 315 + | Tcl_ident (path, lid, _) -> f ~namespace:Class cl_env path lid 316 316 + | Tcl_structure _ | Tcl_fun _ | Tcl_apply _ | Tcl_let _ 317 317 + | Tcl_constraint _ | Tcl_open _ -> ()); 318 318 + default_iterator.class_expr sub ce); 319 319 + 320 320 + class_type = 321 321 + (fun sub ({ cltyp_desc; cltyp_env; _} as ct) -> 322 322 + (match cltyp_desc with 323 323 + | Tcty_constr (path, lid, _) -> f ~namespace:Class_type cltyp_env path lid 324 324 + | Tcty_signature _ | Tcty_arrow _ | Tcty_open _ -> ()); 325 325 + default_iterator.class_type sub ct); 326 326 + 327 327 + signature_item = 328 328 + (fun sub ({ sig_desc; sig_env; _ } as sig_item) -> 329 329 + (match sig_desc with 330 330 + | Tsig_exception { 331 331 + tyexn_constructor = { ext_kind = Text_rebind (path, lid)}} -> 332 332 + f ~namespace:Extension_constructor sig_env path lid 333 333 + | Tsig_modsubst { ms_manifest; ms_txt } -> 334 334 + f ~namespace:Module sig_env ms_manifest ms_txt 335 335 + | Tsig_typext { tyext_path; tyext_txt } -> 336 336 + f ~namespace:Type sig_env tyext_path tyext_txt 337 337 + | Tsig_value _ | Tsig_type _ | Tsig_typesubst _ | Tsig_exception _ 338 338 + | Tsig_module _ | Tsig_recmodule _ | Tsig_modtype _ | Tsig_modtypesubst _ 339 339 + | Tsig_open _ | Tsig_include _ | Tsig_class _ | Tsig_class_type _ 340 340 + | Tsig_attribute _ -> ()); 341 341 + default_iterator.signature_item sub sig_item); 342 342 + 343 343 + structure_item = 344 344 + (fun sub ({ str_desc; str_env; _ } as str_item) -> 345 345 + (match str_desc with 346 346 + | Tstr_exception { 347 347 + tyexn_constructor = { ext_kind = Text_rebind (path, lid)}} -> 348 348 + f ~namespace:Extension_constructor str_env path lid 349 349 + | Tstr_typext { tyext_path; tyext_txt } -> 350 350 + f ~namespace:Type str_env tyext_path tyext_txt 351 351 + | Tstr_eval _ | Tstr_value _ | Tstr_primitive _ | Tstr_type _ 352 352 + | Tstr_exception _ | Tstr_module _ | Tstr_recmodule _ 353 353 + | Tstr_modtype _ | Tstr_open _ | Tstr_class _ | Tstr_class_type _ 354 354 + | Tstr_include _ | Tstr_attribute _ -> ()); 355 355 + default_iterator.structure_item sub str_item) 356 356 + } 357 357 + 358 358 + let index_declarations binary_annots = 359 359 + let index : item_declaration Types.Uid.Tbl.t = Types.Uid.Tbl.create 16 in 360 360 + let f uid fragment = Types.Uid.Tbl.add index uid fragment in 361 361 + iter_on_annots (iter_on_declarations ~f) binary_annots; 362 362 + index 363 363 + 364 364 + let index_occurrences binary_annots = 365 365 + let index : (Longident.t Location.loc * Shape_reduce.result) list ref = 366 366 + ref [] 367 367 + in 368 368 + let f ~namespace env path lid = 369 369 + let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in 370 370 + if not_ghost lid then 371 371 + match Env.shape_of_path ~namespace env path with 372 372 + | exception Not_found -> () 373 373 + | { uid = Some (Predef _); _ } -> () 374 374 + | path_shape -> 375 375 + let result = Shape_reduce.local_reduce_for_uid env path_shape in 376 376 + index := (lid, result) :: !index 377 377 + in 378 378 + iter_on_annots (iter_on_occurrences ~f) binary_annots; 379 379 + !index 380 380 + 106 381 exception Error of error 107 382 108 383 let input_cmt ic = (input_value ic : cmt_infos) ··· 175 450 | Some cmi -> Some (output_cmi temp_file_name oc cmi) 176 451 in 177 452 let sourcefile = Unit_info.Artifact.source_file target in 453 453 + let cmt_ident_occurrences = 454 454 + if !Clflags.store_occurrences then 455 455 + index_occurrences binary_annots 456 456 + else 457 457 + [] 458 458 + in 459 459 + let cmt_annots = clear_env binary_annots in 460 460 + let cmt_uid_to_decl = index_declarations cmt_annots in 178 461 let source_digest = Option.map Digest.file sourcefile in 179 462 let cmt = { 180 463 cmt_modname = Unit_info.Artifact.modname target; 181 181 - cmt_annots = clear_env binary_annots; 464 464 + cmt_annots; 182 465 cmt_value_dependencies = !value_deps; 183 466 cmt_comments = Lexer.comments (); 184 467 cmt_args = Sys.argv; ··· 191 474 cmt_imports = List.sort compare (Env.imports ()); 192 475 cmt_interface_digest = this_crc; 193 476 cmt_use_summaries = need_to_clear_env; 194 194 - cmt_uid_to_loc = Env.get_uid_to_loc_tbl (); 477 477 + cmt_uid_to_decl; 195 478 cmt_impl_shape = shape; 479 479 + cmt_ident_occurrences; 196 480 } in 197 481 output_cmt oc cmt) 198 482 end;

+3 -2

file_formats/cmt_format.mli

reviewed

··· 65 65 cmt_imports : crcs; 66 66 cmt_interface_digest : Digest.t option; 67 67 cmt_use_summaries : bool; 68 68 - cmt_uid_to_loc : Location.t Shape.Uid.Tbl.t; 68 68 + cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t; 69 69 cmt_impl_shape : Shape.t option; (* None for mli *) 70 70 + cmt_ident_occurrences : 71 71 + (Longident.t Location.loc * Shape_reduce.result) list 70 72 } 71 73 72 74 type error = ··· 109 111 110 112 val record_value_dependency: 111 113 Types.value_description -> Types.value_description -> unit 112 112 - 113 114 114 115 (* 115 116

+18 -18

lambda/matching.ml

reviewed

··· 212 212 | Tpat_any 213 213 | Tpat_var _ -> 214 214 p 215 215 - | Tpat_alias (q, id, s) -> 216 216 - { p with pat_desc = Tpat_alias (simpl_under_orpat q, id, s) } 215 215 + | Tpat_alias (q, id, s, uid) -> 216 216 + { p with pat_desc = Tpat_alias (simpl_under_orpat q, id, s, uid) } 217 217 | Tpat_or (p1, p2, o) -> 218 218 let p1, p2 = (simpl_under_orpat p1, simpl_under_orpat p2) in 219 219 if le_pat p1 p2 then ··· 236 236 in 237 237 match p.pat_desc with 238 238 | `Any -> stop p `Any 239 239 - | `Var (id, s) -> continue p (`Alias (Patterns.omega, id, s)) 240 240 - | `Alias (p, id, _) -> 239 239 + | `Var (id, s, uid) -> continue p (`Alias (Patterns.omega, id, s, uid)) 240 240 + | `Alias (p, id, _, _) -> 241 241 aux 242 242 ( (General.view p, patl), 243 243 bind_alias p id ~arg ~action ) ··· 331 331 match p.pat_desc with 332 332 | `Or (p1, p2, _) -> 333 333 split_explode p1 aliases (split_explode p2 aliases rem) 334 334 - | `Alias (p, id, _) -> split_explode p (id :: aliases) rem 335 335 - | `Var (id, str) -> 334 334 + | `Alias (p, id, _, _) -> split_explode p (id :: aliases) rem 335 335 + | `Var (id, str, uid) -> 336 336 explode 337 337 - { p with pat_desc = `Alias (Patterns.omega, id, str) } 337 337 + { p with pat_desc = `Alias (Patterns.omega, id, str, uid) } 338 338 aliases rem 339 339 | #view as view -> 340 340 (* We are doing two things here: ··· 585 585 match p.pat_desc with 586 586 | `Or (p1, p2, _) -> 587 587 filter_rec ((left, p1, right) :: (left, p2, right) :: rem) 588 588 - | `Alias (p, _, _) -> filter_rec ((left, p, right) :: rem) 588 588 + | `Alias (p, _, _, _) -> filter_rec ((left, p, right) :: rem) 589 589 | `Var _ -> filter_rec ((left, Patterns.omega, right) :: rem) 590 590 | #Simple.view as view -> ( 591 591 let p = { p with pat_desc = view } in ··· 635 635 | Tpat_tuple args -> args :: k 636 636 | Tpat_or (p1, p2, _) -> 637 637 flatten_pat_line size p1 (flatten_pat_line size p2 k) 638 638 - | Tpat_alias (p, _, _) -> 638 638 + | Tpat_alias (p, _, _, _) -> 639 639 (* Note: we are only called from flatten_matrix, 640 640 which is itself only ever used in places 641 641 where variables do not matter (default environments, ··· 713 713 | (p, ps) :: rem -> ( 714 714 let p = General.view p in 715 715 match p.pat_desc with 716 716 - | `Alias (p, _, _) -> filter_rec ((p, ps) :: rem) 716 716 + | `Alias (p, _, _, _) -> filter_rec ((p, ps) :: rem) 717 717 | `Var _ -> filter_rec ((Patterns.omega, ps) :: rem) 718 718 | `Or (p1, p2, _) -> filter_rec_or p1 p2 ps rem 719 719 | #Simple.view as view -> ( ··· 1251 1251 | Tpat_any 1252 1252 | Tpat_var _ -> 1253 1253 true 1254 1254 - | Tpat_alias (p, _, _) -> omega_like p 1254 1254 + | Tpat_alias (p, _, _, _) -> omega_like p 1255 1255 | Tpat_or (p1, p2, _) -> omega_like p1 || omega_like p2 1256 1256 | _ -> false 1257 1257 ··· 1645 1645 (* variables bound in the or-pattern 1646 1646 that are used in the orpm actions *) 1647 1647 Typedtree.pat_bound_idents_full orp 1648 1648 - |> List.filter (fun (id, _, _) -> Ident.Set.mem id pm_fv) 1649 1649 - |> List.map (fun (id, _, ty) -> 1648 1648 + |> List.filter (fun (id, _, _, _) -> Ident.Set.mem id pm_fv) 1649 1649 + |> List.map (fun (id, _, ty, _) -> 1650 1650 (id, Typeopt.value_kind orp.pat_env ty)) 1651 1651 in 1652 1652 let or_num = next_raise_count () in ··· 3351 3351 let rec name_pattern default = function 3352 3352 | ((pat, _), _) :: rem -> ( 3353 3353 match pat.pat_desc with 3354 3354 - | Tpat_var (id, _) -> id 3355 3355 - | Tpat_alias (_, id, _) -> id 3354 3354 + | Tpat_var (id, _, _) -> id 3355 3355 + | Tpat_alias (_, id, _, _) -> id 3356 3356 | _ -> name_pattern default rem 3357 3357 ) 3358 3358 | _ -> Ident.create_local default ··· 3858 3858 (* This eliminates a useless variable (and stack slot in bytecode) 3859 3859 for "let _ = ...". See #6865. *) 3860 3860 Lsequence (param, body) 3861 3861 - | Tpat_var (id, _) | Tpat_alias ({ pat_desc = Tpat_any }, id, _) -> 3861 3861 + | Tpat_var (id, _, _) | Tpat_alias ({ pat_desc = Tpat_any }, id, _, _) -> 3862 3862 (* Fast path, and keep track of simple bindings to unboxable numbers. 3863 3863 3864 3864 Note: the (Tpat_alias (Tpat_any, id)) case needs to be ··· 3874 3874 let catch_ids = pat_bound_idents_full pat in 3875 3875 let ids_with_kinds = 3876 3876 List.map 3877 3877 - (fun (id, _, typ) -> (id, Typeopt.value_kind pat.pat_env typ)) 3877 3877 + (fun (id, _, typ, _) -> (id, Typeopt.value_kind pat.pat_env typ)) 3878 3878 catch_ids 3879 3879 in 3880 3880 - let ids = List.map (fun (id, _, _) -> id) catch_ids in 3880 3880 + let ids = List.map (fun (id, _, _, _) -> id) catch_ids in 3881 3881 let bind = 3882 3882 map_return (assign_pat ~scopes opt nraise ids loc pat) param in 3883 3883 if !opt then

+2 -2

lambda/translclass.ml

reviewed

··· 124 124 125 125 let name_pattern default p = 126 126 match p.pat_desc with 127 127 - | Tpat_var (id, _) -> id 128 128 - | Tpat_alias(_, id, _) -> id 127 127 + | Tpat_var (id, _, _) -> id 128 128 + | Tpat_alias(_, id, _, _) -> id 129 129 | _ -> Ident.create_local default 130 130 131 131 let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl =

+6 -6

lambda/translcore.ml

reviewed

··· 157 157 158 158 let rec iter_exn_names f pat = 159 159 match pat.pat_desc with 160 160 - | Tpat_var (id, _) -> f id 161 161 - | Tpat_alias (p, id, _) -> 160 160 + | Tpat_var (id, _, _) -> f id 161 161 + | Tpat_alias (p, id, _, _) -> 162 162 f id; 163 163 iter_exn_names f p 164 164 | _ -> () ··· 927 927 let idlist = 928 928 List.map 929 929 (fun {vb_pat=pat} -> match pat.pat_desc with 930 930 - Tpat_var (id,_) -> id 931 931 - | Tpat_alias ({pat_desc=Tpat_any}, id,_) -> id 930 930 + Tpat_var (id,_,_) -> id 931 931 + | Tpat_alias ({pat_desc=Tpat_any}, id,_,_) -> id 932 932 | _ -> assert false) 933 933 pat_expr_list in 934 934 let transl_case {vb_expr=expr; vb_attributes; vb_rec_kind = rkind; ··· 1069 1069 (* Simplif doesn't like it if binders are not uniq, so we make sure to 1070 1070 use different names in the value and the exception branches. *) 1071 1071 let ids_full = Typedtree.pat_bound_idents_full pv in 1072 1072 - let ids = List.map (fun (id, _, _) -> id) ids_full in 1072 1072 + let ids = List.map (fun (id, _, _, _) -> id) ids_full in 1073 1073 let ids_kinds = 1074 1074 - List.map (fun (id, _, ty) -> id, Typeopt.value_kind pv.pat_env ty) 1074 1074 + List.map (fun (id, _, ty, _) -> id, Typeopt.value_kind pv.pat_env ty) 1075 1075 ids_full 1076 1076 in 1077 1077 let vids = List.map Ident.rename ids in

+7 -7

ocamldoc/odoc_ast.ml

reviewed

··· 50 50 51 51 let iter_val_pattern = function 52 52 | Typedtree.Tpat_any -> None 53 53 - | Typedtree.Tpat_var (name, _) 54 54 - | Typedtree.Tpat_alias (_, name, _) -> Some (Name.from_ident name) 53 53 + | Typedtree.Tpat_var (name, _, _) 54 54 + | Typedtree.Tpat_alias (_, name, _, _) -> Some (Name.from_ident name) 55 55 | Typedtree.Tpat_tuple _ -> None (* FIXME when we will handle tuples *) 56 56 | _ -> None 57 57 ··· 251 251 let tt_param_info_from_pattern env f_desc pat = 252 252 let rec iter_pattern pat = 253 253 match pat.pat_desc with 254 254 - Typedtree.Tpat_var (ident, _) -> 254 254 + Typedtree.Tpat_var (ident, _, _) -> 255 255 let name = Name.from_ident ident in 256 256 Simple_name { sn_name = name ; 257 257 sn_text = f_desc name ; 258 258 sn_type = Odoc_env.subst_type env pat.pat_type 259 259 } 260 260 261 261 - | Typedtree.Tpat_alias (pat, _, _) -> 261 261 + | Typedtree.Tpat_alias (pat, _, _, _) -> 262 262 iter_pattern pat 263 263 264 264 | Typedtree.Tpat_tuple patlist -> ··· 334 334 let (pat, exp) = pat_exp in 335 335 let comment_opt = Odoc_sig.analyze_alerts comment_opt attrs in 336 336 match pat.pat_desc with 337 337 - | Tpat_var (ident, _) | Tpat_alias (_, ident, _) -> 337 337 + | Tpat_var (ident, _, _) | Tpat_alias (_, ident, _, _) -> 338 338 begin match exp.exp_desc with 339 339 | Texp_function (params, body) -> 340 340 ··· 673 673 a default value. In this case, we look for the good parameter pattern *) 674 674 let (parameter, next_tt_class_exp) = 675 675 match pat.Typedtree.pat_desc with 676 676 - Typedtree.Tpat_var (ident, _) when Name.from_ident ident = "*opt*" -> 676 676 + Typedtree.Tpat_var (ident, _, _) when Name.from_ident ident = "*opt*" -> 677 677 ( 678 678 (* there must be a Tcl_let just after *) 679 679 match tt_class_expr2.Typedtree.cl_desc with 680 680 - Typedtree.Tcl_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id,_) }; 680 680 + Typedtree.Tcl_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id,_,_) }; 681 681 vb_expr=exp} :: _, _, tt_class_expr3) -> 682 682 let name = Name.from_ident id in 683 683 let new_param = Simple_name

+1

otherlibs/dynlink/Makefile

reviewed

··· 114 114 file_formats/cmi_format.ml \ 115 115 typing/persistent_env.ml \ 116 116 typing/env.ml \ 117 117 + typing/shape_reduce.ml \ 117 118 typing/typedtree.ml \ 118 119 lambda/debuginfo.ml \ 119 120 lambda/lambda.ml \

+1

testsuite/tests/shape-index/auxiliaire.ml

reviewed

··· 1 1 + let z = 42

+69

testsuite/tests/shape-index/index.ml

reviewed

··· 1 1 + (* TEST 2 2 + 3 3 + flags = "-bin-annot -bin-annot-occurrences"; 4 4 + compile_only = "true"; 5 5 + readonly_files = "auxiliaire.ml"; 6 6 + setup-ocamlc.byte-build-env; 7 7 + all_modules = "auxiliaire.ml index.ml"; 8 8 + ocamlc.byte; 9 9 + check-ocamlc.byte-output; 10 10 + 11 11 + program = "-quiet -index -decls index.cmt"; 12 12 + output = "out_objinfo"; 13 13 + ocamlobjinfo; 14 14 + 15 15 + check-program-output; 16 16 + *) 17 17 + 18 18 + module type AS = sig 19 19 + type t 20 20 + val x : t 21 21 + end 22 22 + 23 23 + module A = struct 24 24 + type t = int 25 25 + let (x : t) = 42 26 26 + end 27 27 + 28 28 + module B = A 29 29 + 30 30 + module C : sig 31 31 + open A 32 32 + val c : t 33 33 + end = struct 34 34 + include A 35 35 + let c = 42 36 36 + end 37 37 + 38 38 + open A 39 39 + 40 40 + let y = A.x + Auxiliaire.z 41 41 + 42 42 + let () = print_int y 43 43 + 44 44 + let a = (module A : AS) 45 45 + module _ = (val a) 46 46 + 47 47 + module F (P : AS) = struct include P end 48 48 + module G = F (A) 49 49 + type u = F (A).t;; (* FIXME F and A are missing*) 50 50 + 51 51 + module type MS = sig 52 52 + module type MT 53 53 + module M : AS 54 54 + module X = A 55 55 + type u 56 56 + end 57 57 + module type MSA = MS with 58 58 + module M = A (* M, MT and u are missing *) 59 59 + and module type MT = AS 60 60 + and type u = B.t 61 61 + 62 62 + let () = match 4 with 63 63 + | A.(0) | _ -> () 64 64 + 65 65 + module type MSB = sig 66 66 + type u 67 67 + include AS with type t := u 68 68 + module G := A 69 69 + end

+63

testsuite/tests/shape-index/index.reference

reviewed

··· 1 1 + Indexed shapes: 2 2 + Resolved: Index.5 : A (File "index.ml", line 68, characters 14-15) 3 3 + Resolved: Index.25 : u (File "index.ml", line 67, characters 28-29) 4 4 + Resolved: Index.2 : AS (File "index.ml", line 67, characters 10-12) 5 5 + Resolved: Index.5 : A (File "index.ml", line 63, characters 4-5) 6 6 + Resolved: Index.3 : B.t (File "index.ml", line 60, characters 15-18) 7 7 + Resolved: Index.2 : AS (File "index.ml", line 59, characters 23-25) 8 8 + Resolved: Index.21 : MS (File "index.ml", line 57, characters 18-20) 9 9 + Resolved: Index.5 : A (File "index.ml", line 58, characters 13-14) 10 10 + Resolved: Index.5 : A (File "index.ml", line 54, characters 13-14) 11 11 + Resolved: Index.2 : AS (File "index.ml", line 53, characters 13-15) 12 12 + Resolved: Index.3 : F(A).t (File "index.ml", line 49, characters 9-16) 13 13 + Resolved: Index.5 : A (File "index.ml", line 48, characters 14-15) 14 14 + Resolved: Index.14 : F (File "index.ml", line 48, characters 11-12) 15 15 + Resolved: Index.13 : P (File "index.ml", line 47, characters 35-36) 16 16 + Resolved: Index.2 : AS (File "index.ml", line 47, characters 14-16) 17 17 + Resolved: Index.11 : a (File "index.ml", line 45, characters 16-17) 18 18 + Resolved: Index.5 : A (File "index.ml", line 44, characters 16-17) 19 19 + Resolved: Index.2 : AS (File "index.ml", line 44, characters 20-22) 20 20 + Resolved: Index.10 : y (File "index.ml", line 42, characters 19-20) 21 21 + Unresolved: CU Stdlib . "print_int"[value] : 22 22 + print_int (File "index.ml", line 42, characters 9-18) 23 23 + Unresolved: CU Auxiliaire . "z"[value] : 24 24 + Auxiliaire.z (File "index.ml", line 40, characters 14-26) 25 25 + Resolved: Index.4 : A.x (File "index.ml", line 40, characters 8-11) 26 26 + Unresolved: CU Stdlib . "+"[value] : 27 27 + (+) (File "index.ml", line 40, characters 12-13) 28 28 + Resolved: Index.5 : A (File "index.ml", line 38, characters 5-6) 29 29 + Resolved: Index.3 : t (File "index.ml", line 32, characters 10-11) 30 30 + Resolved: Index.5 : A (File "index.ml", line 31, characters 7-8) 31 31 + Resolved: Index.5 : A (File "index.ml", line 34, characters 10-11) 32 32 + Resolved: Index.5 : A (File "index.ml", line 28, characters 11-12) 33 33 + Resolved: Index.3 : t (File "index.ml", line 25, characters 11-12) 34 34 + Resolved: Index.0 : t (File "index.ml", line 20, characters 10-11) 35 35 + 36 36 + Uid of decls: 37 37 + Index.10: y (File "index.ml", line 40, characters 4-5) 38 38 + Index.21: MS (File "index.ml", line 51, characters 12-14) 39 39 + Index.5: A (File "index.ml", line 23, characters 7-8) 40 40 + Index.15: G (File "index.ml", line 48, characters 7-8) 41 41 + Index.0: t (File "index.ml", line 19, characters 7-8) 42 42 + Index.28: MSB (File "index.ml", line 65, characters 12-15) 43 43 + Index.3: t (File "index.ml", line 24, characters 7-8) 44 44 + Index.17: MT (File "index.ml", line 52, characters 14-16) 45 45 + Index.11: a (File "index.ml", line 44, characters 4-5) 46 46 + Index.25: u (File "index.ml", line 66, characters 7-8) 47 47 + Index.24: MSA (File "index.ml", line 57, characters 12-15) 48 48 + Index.1: x (File "index.ml", line 20, characters 6-7) 49 49 + Index.16: u (File "index.ml", line 49, characters 5-6) 50 50 + Index.8: c (File "index.ml", line 32, characters 6-7) 51 51 + Index.9: C (File "index.ml", line 30, characters 7-8) 52 52 + Index.23: u (File "index.ml", line 60, characters 11-12) 53 53 + Index.14: F (File "index.ml", line 47, characters 7-8) 54 54 + Index.12: _ (File "index.ml", line 45, characters 7-8) 55 55 + Index.27: G (File "index.ml", line 68, characters 9-10) 56 56 + Index.20: u (File "index.ml", line 55, characters 7-8) 57 57 + Index.26: t (File "index.ml", line 67, characters 23-24) 58 58 + Index.19: X (File "index.ml", line 54, characters 9-10) 59 59 + Index.6: B (File "index.ml", line 28, characters 7-8) 60 60 + Index.4: x (File "index.ml", line 25, characters 7-8) 61 61 + Index.18: M (File "index.ml", line 53, characters 9-10) 62 62 + Index.7: c (File "index.ml", line 35, characters 6-7) 63 63 + Index.2: AS (File "index.ml", line 18, characters 12-14)

+29

testsuite/tests/shape-index/index_aliases.ml

reviewed

··· 1 1 + (* TEST 2 2 + 3 3 + flags = "-bin-annot -bin-annot-occurrences"; 4 4 + compile_only = "true"; 5 5 + setup-ocamlc.byte-build-env; 6 6 + all_modules = "index_aliases.ml"; 7 7 + ocamlc.byte; 8 8 + check-ocamlc.byte-output; 9 9 + 10 10 + program = "-quiet -index -decls index_aliases.cmt"; 11 11 + output = "out_objinfo"; 12 12 + ocamlobjinfo; 13 13 + 14 14 + check-program-output; 15 15 + *) 16 16 + 17 17 + 18 18 + module A = struct type t end 19 19 + module B = A 20 20 + 21 21 + module F (X : sig type t end) = X 22 22 + module F' = F 23 23 + module C = F'(A) 24 24 + 25 25 + module C' = F(B) 26 26 + module D = C 27 27 + 28 28 + module G = B 29 29 + include G

+33

testsuite/tests/shape-index/index_aliases.reference

reviewed

··· 1 1 + Indexed shapes: 2 2 + Resolved_alias: Index_aliases.10 -> Index_aliases.2 -> Index_aliases.1 : 3 3 + G (File "index_aliases.ml", line 29, characters 8-9) 4 4 + Resolved_alias: Index_aliases.2 -> Index_aliases.1 : 5 5 + B (File "index_aliases.ml", line 28, characters 11-12) 6 6 + Resolved: Index_aliases.7 : 7 7 + C (File "index_aliases.ml", line 26, characters 11-12) 8 8 + Resolved_alias: Index_aliases.2 -> Index_aliases.1 : 9 9 + B (File "index_aliases.ml", line 25, characters 14-15) 10 10 + Resolved: Index_aliases.5 : 11 11 + F (File "index_aliases.ml", line 25, characters 12-13) 12 12 + Resolved: Index_aliases.1 : 13 13 + A (File "index_aliases.ml", line 23, characters 14-15) 14 14 + Resolved_alias: Index_aliases.6 -> Index_aliases.5 : 15 15 + F' (File "index_aliases.ml", line 23, characters 11-13) 16 16 + Resolved: Index_aliases.5 : 17 17 + F (File "index_aliases.ml", line 22, characters 12-13) 18 18 + Resolved: Index_aliases.4 : 19 19 + X (File "index_aliases.ml", line 21, characters 32-33) 20 20 + Resolved: Index_aliases.1 : 21 21 + A (File "index_aliases.ml", line 19, characters 11-12) 22 22 + 23 23 + Uid of decls: 24 24 + Index_aliases.1: A (File "index_aliases.ml", line 18, characters 7-8) 25 25 + Index_aliases.2: B (File "index_aliases.ml", line 19, characters 7-8) 26 26 + Index_aliases.5: F (File "index_aliases.ml", line 21, characters 7-8) 27 27 + Index_aliases.7: C (File "index_aliases.ml", line 23, characters 7-8) 28 28 + Index_aliases.9: D (File "index_aliases.ml", line 26, characters 7-8) 29 29 + Index_aliases.8: C' (File "index_aliases.ml", line 25, characters 7-9) 30 30 + Index_aliases.10: G (File "index_aliases.ml", line 28, characters 7-8) 31 31 + Index_aliases.6: F' (File "index_aliases.ml", line 22, characters 7-9) 32 32 + Index_aliases.3: t (File "index_aliases.ml", line 21, characters 23-24) 33 33 + Index_aliases.0: t (File "index_aliases.ml", line 18, characters 23-24)

+30

testsuite/tests/shape-index/index_bindingops.ml

reviewed

··· 1 1 + (* TEST 2 2 + 3 3 + flags = "-bin-annot -bin-annot-occurrences"; 4 4 + compile_only = "true"; 5 5 + setup-ocamlc.byte-build-env; 6 6 + all_modules = "index_bindingops.ml"; 7 7 + ocamlc.byte; 8 8 + check-ocamlc.byte-output; 9 9 + 10 10 + program = "-quiet -index -decls index_bindingops.cmt"; 11 11 + output = "out_objinfo"; 12 12 + ocamlobjinfo; 13 13 + 14 14 + check-program-output; 15 15 + *) 16 16 + 17 17 + let (let+) x f = Option.map f x 18 18 + 19 19 + let (and+) x y = 20 20 + Option.bind x @@ fun x -> 21 21 + Option.map (fun y -> (x, y)) y 22 22 + 23 23 + let minus_three = 24 24 + let+ foo = None 25 25 + and+ bar = None 26 26 + and+ man = None in 27 27 + foo + bar - man 28 28 + 29 29 + let _ = (let+) 30 30 + let _ = (and+)

+47

testsuite/tests/shape-index/index_bindingops.reference

reviewed

··· 1 1 + Indexed shapes: 2 2 + Resolved: Index_bindingops.3 : 3 3 + (and+) (File "index_bindingops.ml", line 30, characters 8-14) 4 4 + Resolved: Index_bindingops.0 : 5 5 + (let+) (File "index_bindingops.ml", line 29, characters 8-14) 6 6 + Resolved: Index_bindingops.11 : 7 7 + man (File "index_bindingops.ml", line 27, characters 14-17) 8 8 + Resolved: Index_bindingops.10 : 9 9 + bar (File "index_bindingops.ml", line 27, characters 8-11) 10 10 + Resolved: Index_bindingops.9 : 11 11 + foo (File "index_bindingops.ml", line 27, characters 2-5) 12 12 + Unresolved: CU Stdlib . "+"[value] : 13 13 + (+) (File "index_bindingops.ml", line 27, characters 6-7) 14 14 + Unresolved: CU Stdlib . "-"[value] : 15 15 + (-) (File "index_bindingops.ml", line 27, characters 12-13) 16 16 + Resolved: Index_bindingops.3 : 17 17 + (and+) (File "index_bindingops.ml", line 26, characters 2-6) 18 18 + Resolved: Index_bindingops.3 : 19 19 + (and+) (File "index_bindingops.ml", line 25, characters 2-6) 20 20 + Resolved: Index_bindingops.0 : 21 21 + (let+) (File "index_bindingops.ml", line 24, characters 2-6) 22 22 + Resolved: Index_bindingops.5 : 23 23 + y (File "index_bindingops.ml", line 21, characters 31-32) 24 24 + Resolved: Index_bindingops.7 : 25 25 + y (File "index_bindingops.ml", line 21, characters 27-28) 26 26 + Resolved: Index_bindingops.6 : 27 27 + x (File "index_bindingops.ml", line 21, characters 24-25) 28 28 + Unresolved: CU Stdlib . "Option"[module] . "map"[value] : 29 29 + Option.map (File "index_bindingops.ml", line 21, characters 2-12) 30 30 + Resolved: Index_bindingops.4 : 31 31 + x (File "index_bindingops.ml", line 20, characters 14-15) 32 32 + Unresolved: CU Stdlib . "Option"[module] . "bind"[value] : 33 33 + Option.bind (File "index_bindingops.ml", line 20, characters 2-13) 34 34 + Resolved: Index_bindingops.1 : 35 35 + x (File "index_bindingops.ml", line 17, characters 30-31) 36 36 + Resolved: Index_bindingops.2 : 37 37 + f (File "index_bindingops.ml", line 17, characters 28-29) 38 38 + Unresolved: CU Stdlib . "Option"[module] . "map"[value] : 39 39 + Option.map (File "index_bindingops.ml", line 17, characters 17-27) 40 40 + 41 41 + Uid of decls: 42 42 + Index_bindingops.8: 43 43 + minus_three (File "index_bindingops.ml", line 23, characters 4-15) 44 44 + Index_bindingops.0: 45 45 + let+ (File "index_bindingops.ml", line 17, characters 4-10) 46 46 + Index_bindingops.3: 47 47 + and+ (File "index_bindingops.ml", line 19, characters 4-10)

+32

testsuite/tests/shape-index/index_constrs.ml

reviewed

··· 1 1 + (* TEST 2 2 + 3 3 + flags = "-bin-annot -bin-annot-occurrences"; 4 4 + compile_only = "true"; 5 5 + readonly_files = "index_constrs.ml"; 6 6 + setup-ocamlc.byte-build-env; 7 7 + all_modules = "index_constrs.ml"; 8 8 + ocamlc.byte; 9 9 + check-ocamlc.byte-output; 10 10 + 11 11 + program = "-quiet -index -decls index_constrs.cmt"; 12 12 + output = "out_objinfo"; 13 13 + ocamlobjinfo; 14 14 + 15 15 + check-program-output; 16 16 + *) 17 17 + 18 18 + exception E 19 19 + module M = struct 20 20 + exception F = E 21 21 + end 22 22 + 23 23 + type t = E 24 24 + 25 25 + let x_ = E 26 26 + let () = raise E 27 27 + let f x = match x with 28 28 + | E -> () 29 29 + | exception E -> () 30 30 + 31 31 + let _ = None 32 32 + let _ = [%extension_constructor M.F]

+26

testsuite/tests/shape-index/index_constrs.reference

reviewed

··· 1 1 + Indexed shapes: 2 2 + Resolved: Index_constrs.1 : 3 3 + M.F (File "index_constrs.ml", line 32, characters 32-35) 4 4 + Resolved: Index_constrs.0 : 5 5 + E (File "index_constrs.ml", line 29, characters 14-15) 6 6 + Resolved: Index_constrs.4 : 7 7 + E (File "index_constrs.ml", line 28, characters 4-5) 8 8 + Resolved: Index_constrs.7 : 9 9 + x (File "index_constrs.ml", line 27, characters 16-17) 10 10 + Resolved: Index_constrs.0 : 11 11 + E (File "index_constrs.ml", line 26, characters 15-16) 12 12 + Unresolved: CU Stdlib . "raise"[value] : 13 13 + raise (File "index_constrs.ml", line 26, characters 9-14) 14 14 + Resolved: Index_constrs.4 : 15 15 + E (File "index_constrs.ml", line 25, characters 9-10) 16 16 + Resolved: Index_constrs.0 : 17 17 + E (File "index_constrs.ml", line 20, characters 16-17) 18 18 + 19 19 + Uid of decls: 20 20 + Index_constrs.6: f (File "index_constrs.ml", line 27, characters 4-5) 21 21 + Index_constrs.5: x_ (File "index_constrs.ml", line 25, characters 4-6) 22 22 + Index_constrs.0: E (File "index_constrs.ml", line 18, characters 10-11) 23 23 + Index_constrs.2: M (File "index_constrs.ml", line 19, characters 7-8) 24 24 + Index_constrs.1: F (File "index_constrs.ml", line 20, characters 12-13) 25 25 + Index_constrs.3: t (File "index_constrs.ml", line 23, characters 5-6) 26 26 + Index_constrs.4: E (File "index_constrs.ml", line 23, characters 9-10)

+44

testsuite/tests/shape-index/index_constrs_records.ml

reviewed

··· 1 1 + (* TEST 2 2 + 3 3 + flags = "-bin-annot -bin-annot-occurrences"; 4 4 + compile_only = "true"; 5 5 + readonly_files = "index_constrs_records.ml"; 6 6 + setup-ocamlc.byte-build-env; 7 7 + all_modules = "index_constrs_records.ml"; 8 8 + ocamlc.byte; 9 9 + check-ocamlc.byte-output; 10 10 + 11 11 + program = "-quiet -index -decls index_constrs_records.cmt"; 12 12 + output = "out_objinfo"; 13 13 + ocamlobjinfo; 14 14 + 15 15 + check-program-output; 16 16 + *) 17 17 + type l = { lbl : int } 18 18 + module M : sig 19 19 + type t = A of { l_c : int } 20 20 + end = struct 21 21 + type t = A of { l_c : int } 22 22 + let _ = A { l_c = 42 } 23 23 + end 24 24 + 25 25 + let _ = M.A { l_c = 42 } 26 26 + 27 27 + open M 28 28 + 29 29 + let _ = A { l_c = 42 } 30 30 + let f (A { l_c }) ({ lbl } as l) = l_c + lbl + l.lbl 31 31 + 32 32 + type u = .. 33 33 + type u += Ext of { l_ext : int } 34 34 + 35 35 + let f (x : u) = match x with 36 36 + | Ext { l_ext } -> l_ext 37 37 + | _ -> assert false 38 38 + 39 39 + exception Exn of {l_exn : int } 40 40 + 41 41 + let e = Exn { l_exn = 2} 42 42 + let _ = match e with 43 43 + | Exn { l_exn } -> l_exn 44 44 + | _ -> assert false

+93

testsuite/tests/shape-index/index_constrs_records.reference

reviewed

··· 1 1 + Indexed shapes: 2 2 + Resolved: Index_constrs_records.36 : 3 3 + l_exn (File "index_constrs_records.ml", line 43, characters 21-26) 4 4 + Resolved: Index_constrs_records.32 : 5 5 + l_exn (File "index_constrs_records.ml", line 43, characters 10-15) 6 6 + Resolved: Index_constrs_records.33 : 7 7 + Exn (File "index_constrs_records.ml", line 43, characters 4-7) 8 8 + Resolved: Index_constrs_records.35 : 9 9 + e (File "index_constrs_records.ml", line 42, characters 14-15) 10 10 + Resolved: Index_constrs_records.32 : 11 11 + l_exn (File "index_constrs_records.ml", line 41, characters 14-19) 12 12 + Resolved: Index_constrs_records.33 : 13 13 + Exn (File "index_constrs_records.ml", line 41, characters 8-11) 14 14 + Resolved: Index_constrs_records.31 : 15 15 + l_ext (File "index_constrs_records.ml", line 36, characters 21-26) 16 16 + Resolved: Index_constrs_records.26 : 17 17 + l_ext (File "index_constrs_records.ml", line 36, characters 10-15) 18 18 + Resolved: Index_constrs_records.27 : 19 19 + Ext (File "index_constrs_records.ml", line 36, characters 4-7) 20 20 + Resolved: Index_constrs_records.30 : 21 21 + x (File "index_constrs_records.ml", line 35, characters 22-23) 22 22 + Resolved: Index_constrs_records.25 : 23 23 + u (File "index_constrs_records.ml", line 35, characters 11-12) 24 24 + Resolved: Index_constrs_records.25 : 25 25 + u (File "index_constrs_records.ml", line 33, characters 5-6) 26 26 + Resolved: Index_constrs_records.24 : 27 27 + l (File "index_constrs_records.ml", line 30, characters 47-48) 28 28 + Resolved: Index_constrs_records.1 : 29 29 + lbl (File "index_constrs_records.ml", line 30, characters 49-52) 30 30 + Resolved: Index_constrs_records.23 : 31 31 + lbl (File "index_constrs_records.ml", line 30, characters 41-44) 32 32 + Resolved: Index_constrs_records.22 : 33 33 + l_c (File "index_constrs_records.ml", line 30, characters 35-38) 34 34 + Unresolved: CU Stdlib . "+"[value] : 35 35 + (+) (File "index_constrs_records.ml", line 30, characters 39-40) 36 36 + Unresolved: CU Stdlib . "+"[value] : 37 37 + (+) (File "index_constrs_records.ml", line 30, characters 45-46) 38 38 + Resolved: Index_constrs_records.1 : 39 39 + lbl (File "index_constrs_records.ml", line 30, characters 21-24) 40 40 + Resolved: Index_constrs_records.3 : 41 41 + l_c (File "index_constrs_records.ml", line 30, characters 11-14) 42 42 + Resolved: Index_constrs_records.4 : 43 43 + A (File "index_constrs_records.ml", line 30, characters 7-8) 44 44 + Resolved: Index_constrs_records.3 : 45 45 + l_c (File "index_constrs_records.ml", line 29, characters 12-15) 46 46 + Resolved: Index_constrs_records.4 : 47 47 + A (File "index_constrs_records.ml", line 29, characters 8-9) 48 48 + Resolved: Index_constrs_records.19 : 49 49 + M (File "index_constrs_records.ml", line 27, characters 5-6) 50 50 + Resolved: Index_constrs_records.3 : 51 51 + l_c (File "index_constrs_records.ml", line 25, characters 14-17) 52 52 + Resolved: Index_constrs_records.4 : 53 53 + M.A (File "index_constrs_records.ml", line 25, characters 8-11) 54 54 + Resolved: Index_constrs_records.3 : 55 55 + l_c (File "index_constrs_records.ml", line 22, characters 14-17) 56 56 + Resolved: Index_constrs_records.4 : 57 57 + A (File "index_constrs_records.ml", line 22, characters 10-11) 58 58 + 59 59 + Uid of decls: 60 60 + Index_constrs_records.4: 61 61 + A (File "index_constrs_records.ml", line 21, characters 11-12) 62 62 + Index_constrs_records.19: 63 63 + M (File "index_constrs_records.ml", line 18, characters 7-8) 64 64 + Index_constrs_records.33: 65 65 + Exn (File "index_constrs_records.ml", line 39, characters 10-13) 66 66 + Index_constrs_records.12: 67 67 + A (File "index_constrs_records.ml", line 19, characters 11-12) 68 68 + Index_constrs_records.10: 69 69 + t (File "index_constrs_records.ml", line 19, characters 7-8) 70 70 + Index_constrs_records.2: 71 71 + t (File "index_constrs_records.ml", line 21, characters 7-8) 72 72 + Index_constrs_records.29: 73 73 + f (File "index_constrs_records.ml", line 35, characters 4-5) 74 74 + Index_constrs_records.25: 75 75 + u (File "index_constrs_records.ml", line 32, characters 5-6) 76 76 + Index_constrs_records.21: 77 77 + f (File "index_constrs_records.ml", line 30, characters 4-5) 78 78 + Index_constrs_records.3: 79 79 + l_c (File "index_constrs_records.ml", line 21, characters 18-21) 80 80 + Index_constrs_records.35: 81 81 + e (File "index_constrs_records.ml", line 41, characters 4-5) 82 82 + Index_constrs_records.26: 83 83 + l_ext (File "index_constrs_records.ml", line 33, characters 19-24) 84 84 + Index_constrs_records.11: 85 85 + l_c (File "index_constrs_records.ml", line 19, characters 18-21) 86 86 + Index_constrs_records.27: 87 87 + Ext (File "index_constrs_records.ml", line 33, characters 10-13) 88 88 + Index_constrs_records.0: 89 89 + l (File "index_constrs_records.ml", line 17, characters 5-6) 90 90 + Index_constrs_records.32: 91 91 + l_exn (File "index_constrs_records.ml", line 39, characters 18-23) 92 92 + Index_constrs_records.1: 93 93 + lbl (File "index_constrs_records.ml", line 17, characters 11-14)

+22

testsuite/tests/shape-index/index_functor.ml

reviewed

··· 1 1 + (* TEST 2 2 + 3 3 + flags = "-bin-annot -bin-annot-occurrences"; 4 4 + compile_only = "true"; 5 5 + setup-ocamlc.byte-build-env; 6 6 + all_modules = "index_functor.ml"; 7 7 + ocamlc.byte; 8 8 + check-ocamlc.byte-output; 9 9 + 10 10 + program = "-quiet -index -decls index_functor.cmt"; 11 11 + output = "out_objinfo"; 12 12 + ocamlobjinfo; 13 13 + 14 14 + check-program-output; 15 15 + *) 16 16 + 17 17 + 18 18 + module F (X :sig end ) = struct module M = X end 19 19 + module N = F(struct end) 20 20 + module O = N.M 21 21 + include O 22 22 + include N

+17

testsuite/tests/shape-index/index_functor.reference

reviewed

··· 1 1 + Indexed shapes: 2 2 + Resolved: Index_functor.3 : 3 3 + N (File "index_functor.ml", line 22, characters 8-9) 4 4 + Resolved_alias: Index_functor.4 -> Index_functor.0 : 5 5 + O (File "index_functor.ml", line 21, characters 8-9) 6 6 + Resolved: Index_functor.0 : 7 7 + N.M (File "index_functor.ml", line 20, characters 11-14) 8 8 + Resolved: Index_functor.2 : 9 9 + F (File "index_functor.ml", line 19, characters 11-12) 10 10 + Resolved: Index_functor.0 : 11 11 + X (File "index_functor.ml", line 18, characters 43-44) 12 12 + 13 13 + Uid of decls: 14 14 + Index_functor.3: N (File "index_functor.ml", line 19, characters 7-8) 15 15 + Index_functor.4: O (File "index_functor.ml", line 20, characters 7-8) 16 16 + Index_functor.2: F (File "index_functor.ml", line 18, characters 7-8) 17 17 + Index_functor.1: M (File "index_functor.ml", line 18, characters 39-40)

+27

testsuite/tests/shape-index/index_labels.ml

reviewed

··· 1 1 + (* TEST 2 2 + 3 3 + flags = "-bin-annot -bin-annot-occurrences"; 4 4 + compile_only = "true"; 5 5 + readonly_files = "index_labels.ml"; 6 6 + setup-ocamlc.byte-build-env; 7 7 + all_modules = "index_labels.ml"; 8 8 + ocamlc.byte; 9 9 + check-ocamlc.byte-output; 10 10 + 11 11 + program = "-quiet -index -decls index_labels.cmt"; 12 12 + output = "out_objinfo"; 13 13 + ocamlobjinfo; 14 14 + 15 15 + check-program-output; 16 16 + *) 17 17 + 18 18 + type t = { mutable a: int; b: string } 19 19 + 20 20 + let x = { a = 42; b = "" } 21 21 + let _y = 22 22 + x.a <- 32; 23 23 + x.a 24 24 + 25 25 + let f = function 26 26 + | { a = 42; b } -> () 27 27 + | _ -> ()

+25

testsuite/tests/shape-index/index_labels.reference

reviewed

··· 1 1 + Indexed shapes: 2 2 + Resolved: Index_labels.2 : 3 3 + b (File "index_labels.ml", line 26, characters 14-15) 4 4 + Resolved: Index_labels.1 : 5 5 + a (File "index_labels.ml", line 26, characters 6-7) 6 6 + Resolved: Index_labels.3 : 7 7 + x (File "index_labels.ml", line 23, characters 2-3) 8 8 + Resolved: Index_labels.1 : 9 9 + a (File "index_labels.ml", line 23, characters 4-5) 10 10 + Resolved: Index_labels.3 : 11 11 + x (File "index_labels.ml", line 22, characters 2-3) 12 12 + Resolved: Index_labels.1 : 13 13 + a (File "index_labels.ml", line 22, characters 4-5) 14 14 + Resolved: Index_labels.2 : 15 15 + b (File "index_labels.ml", line 20, characters 18-19) 16 16 + Resolved: Index_labels.1 : 17 17 + a (File "index_labels.ml", line 20, characters 10-11) 18 18 + 19 19 + Uid of decls: 20 20 + Index_labels.5: f (File "index_labels.ml", line 25, characters 4-5) 21 21 + Index_labels.2: b (File "index_labels.ml", line 18, characters 27-28) 22 22 + Index_labels.3: x (File "index_labels.ml", line 20, characters 4-5) 23 23 + Index_labels.1: a (File "index_labels.ml", line 18, characters 19-20) 24 24 + Index_labels.4: _y (File "index_labels.ml", line 21, characters 4-6) 25 25 + Index_labels.0: t (File "index_labels.ml", line 18, characters 5-6)

+22

testsuite/tests/shape-index/index_modules.ml

reviewed

··· 1 1 + (* TEST 2 2 + 3 3 + flags = "-bin-annot -bin-annot-occurrences"; 4 4 + compile_only = "true"; 5 5 + setup-ocamlc.byte-build-env; 6 6 + all_modules = "index_modules.ml"; 7 7 + ocamlc.byte; 8 8 + check-ocamlc.byte-output; 9 9 + 10 10 + program = "-quiet -index -decls index_modules.cmt"; 11 11 + output = "out_objinfo"; 12 12 + ocamlobjinfo; 13 13 + 14 14 + check-program-output; 15 15 + *) 16 16 + 17 17 + (* Local modules: *) 18 18 + 19 19 + let () = 20 20 + let module A = struct let x = 42 end in 21 21 + let open A in 22 22 + print_int (x + A.x)

+14

testsuite/tests/shape-index/index_modules.reference

reviewed

··· 1 1 + Indexed shapes: 2 2 + Resolved: Index_modules.0 : 3 3 + A.x (File "index_modules.ml", line 22, characters 17-20) 4 4 + Resolved: Index_modules.0 : 5 5 + x (File "index_modules.ml", line 22, characters 13-14) 6 6 + Unresolved: CU Stdlib . "+"[value] : 7 7 + (+) (File "index_modules.ml", line 22, characters 15-16) 8 8 + Unresolved: CU Stdlib . "print_int"[value] : 9 9 + print_int (File "index_modules.ml", line 22, characters 2-11) 10 10 + Resolved: Index_modules.1 : 11 11 + A (File "index_modules.ml", line 21, characters 11-12) 12 12 + 13 13 + Uid of decls: 14 14 + Index_modules.0: x (File "index_modules.ml", line 20, characters 28-29)

+49

testsuite/tests/shape-index/index_objects.ml

reviewed

··· 1 1 + (* TEST 2 2 + 3 3 + flags = "-bin-annot -bin-annot-occurrences"; 4 4 + compile_only = "true"; 5 5 + readonly_files = "index_objects.ml"; 6 6 + setup-ocamlc.byte-build-env; 7 7 + all_modules = "index_objects.ml"; 8 8 + ocamlc.byte; 9 9 + check-ocamlc.byte-output; 10 10 + 11 11 + program = "-quiet -index -decls index_objects.cmt"; 12 12 + output = "out_objinfo"; 13 13 + ocamlobjinfo; 14 14 + 15 15 + check-program-output; 16 16 + *) 17 17 + 18 18 + let o = object 19 19 + method pop () = () 20 20 + end 21 21 + 22 22 + (* FIXME: method usages are not indexed yet *) 23 23 + let () = o#pop () 24 24 + 25 25 + class c = object 26 26 + method cpop () = () 27 27 + end 28 28 + 29 29 + let _ : c = new c 30 30 + 31 31 + class d = object 32 32 + inherit c 33 33 + end 34 34 + 35 35 + module type M = sig 36 36 + class ct : object 37 37 + method pop : unit 38 38 + end 39 39 + 40 40 + class dt : object inherit ct end 41 41 + end 42 42 + 43 43 + class ins_var = object (self) 44 44 + val mutable ins = 0 45 45 + method get_ins () = ins 46 46 + method set_ins i = ins <- i 47 47 + method other () = self#get_ins () 48 48 + method update = {< ins = 3 >} 49 49 + end

+32

testsuite/tests/shape-index/index_objects.reference

reviewed

··· 1 1 + Indexed shapes: 2 2 + Resolved: Index_objects.21 : 3 3 + ins (File "index_objects.ml", line 48, characters 21-24) 4 4 + Resolved: Index_objects.28 : 5 5 + self (File "index_objects.ml", line 47, characters 20-24) 6 6 + Resolved: Index_objects.26 : 7 7 + i (File "index_objects.ml", line 46, characters 28-29) 8 8 + Resolved: Index_objects.21 : 9 9 + ins (File "index_objects.ml", line 46, characters 21-24) 10 10 + Resolved: Index_objects.21 : 11 11 + ins (File "index_objects.ml", line 45, characters 22-25) 12 12 + Resolved: Index_objects.13 : 13 13 + ct (File "index_objects.ml", line 40, characters 28-30) 14 14 + Resolved: Index_objects.5 : 15 15 + c (File "index_objects.ml", line 32, characters 10-11) 16 16 + Resolved: Index_objects.5 : 17 17 + c (File "index_objects.ml", line 29, characters 8-9) 18 18 + Resolved: Index_objects.5 : 19 19 + c (File "index_objects.ml", line 29, characters 16-17) 20 20 + Resolved: Index_objects.5 : 21 21 + c (File "index_objects.ml", line 29, characters 8-9) 22 22 + Resolved: Index_objects.0 : 23 23 + o (File "index_objects.ml", line 23, characters 9-10) 24 24 + 25 25 + Uid of decls: 26 26 + Index_objects.10: d (File "index_objects.ml", line 31, characters 6-7) 27 27 + Index_objects.15: M (File "index_objects.ml", line 35, characters 12-13) 28 28 + Index_objects.14: dt (File "index_objects.ml", line 40, characters 8-10) 29 29 + Index_objects.5: c (File "index_objects.ml", line 25, characters 6-7) 30 30 + Index_objects.0: o (File "index_objects.ml", line 18, characters 4-5) 31 31 + Index_objects.16: ins_var (File "index_objects.ml", line 43, characters 6-13) 32 32 + Index_objects.13: ct (File "index_objects.ml", line 36, characters 8-10)

+41

testsuite/tests/shape-index/index_types.ml

reviewed

··· 1 1 + (* TEST 2 2 + 3 3 + flags = "-bin-annot -bin-annot-occurrences"; 4 4 + compile_only = "true"; 5 5 + readonly_files = "index_types.ml"; 6 6 + setup-ocamlc.byte-build-env; 7 7 + all_modules = "index_types.ml"; 8 8 + ocamlc.byte; 9 9 + check-ocamlc.byte-output; 10 10 + 11 11 + program = "-quiet -index -decls index_types.cmt"; 12 12 + output = "out_objinfo"; 13 13 + ocamlobjinfo; 14 14 + 15 15 + check-program-output; 16 16 + *) 17 17 + 18 18 + type t = int 19 19 + 20 20 + let x : t = 42 21 21 + 22 22 + module M = struct end 23 23 + 24 24 + let () = match 4 with 25 25 + | (_ : t) -> () 26 26 + 27 27 + type poly = [`A|`B] 28 28 + 29 29 + let () = match `A with #poly -> () 30 30 + 31 31 + module type S = sig 32 32 + type t2 = .. 33 33 + type t2 += B 34 34 + end 35 35 + 36 36 + type t1 = .. 37 37 + type t1 += B 38 38 + 39 39 + (* 5.2 local open for types *) 40 40 + module N = struct type t end 41 41 + type u = N.(t)

+26

testsuite/tests/shape-index/index_types.reference

reviewed

··· 1 1 + Indexed shapes: 2 2 + Resolved: Index_types.9 : 3 3 + t (File "index_types.ml", line 41, characters 12-13) 4 4 + Resolved: Index_types.10 : 5 5 + N (File "index_types.ml", line 41, characters 9-10) 6 6 + Resolved: Index_types.7 : t1 (File "index_types.ml", line 37, characters 5-7) 7 7 + Resolved: Index_types.4 : t2 (File "index_types.ml", line 33, characters 7-9) 8 8 + Resolved: Index_types.3 : 9 9 + poly (File "index_types.ml", line 29, characters 24-28) 10 10 + Resolved: Index_types.0 : t (File "index_types.ml", line 25, characters 9-10) 11 11 + Resolved: Index_types.0 : t (File "index_types.ml", line 20, characters 8-9) 12 12 + Resolved: Index_types.0 : t (File "index_types.ml", line 20, characters 8-9) 13 13 + 14 14 + Uid of decls: 15 15 + Index_types.11: u (File "index_types.ml", line 41, characters 5-6) 16 16 + Index_types.3: poly (File "index_types.ml", line 27, characters 5-9) 17 17 + Index_types.2: M (File "index_types.ml", line 22, characters 7-8) 18 18 + Index_types.6: S (File "index_types.ml", line 31, characters 12-13) 19 19 + Index_types.10: N (File "index_types.ml", line 40, characters 7-8) 20 20 + Index_types.5: B (File "index_types.ml", line 33, characters 13-14) 21 21 + Index_types.9: t (File "index_types.ml", line 40, characters 23-24) 22 22 + Index_types.4: t2 (File "index_types.ml", line 32, characters 7-9) 23 23 + Index_types.1: x (File "index_types.ml", line 20, characters 4-5) 24 24 + Index_types.8: B (File "index_types.ml", line 37, characters 11-12) 25 25 + Index_types.0: t (File "index_types.ml", line 18, characters 5-6) 26 26 + Index_types.7: t1 (File "index_types.ml", line 36, characters 5-7)

+22

testsuite/tests/shape-index/index_vb.ml

reviewed

··· 1 1 + (* TEST 2 2 + 3 3 + flags = "-bin-annot -bin-annot-occurrences"; 4 4 + compile_only = "true"; 5 5 + readonly_files = "index_vb.ml"; 6 6 + setup-ocamlc.byte-build-env; 7 7 + all_modules = "index_vb.ml"; 8 8 + ocamlc.byte; 9 9 + check-ocamlc.byte-output; 10 10 + 11 11 + program = "-quiet -index -decls index_vb.cmt"; 12 12 + output = "out_objinfo"; 13 13 + ocamlobjinfo; 14 14 + 15 15 + check-program-output; 16 16 + *) 17 17 + 18 18 + type t = { a : int; b : string * int } 19 19 + 20 20 + let { a; b = (c, d) } = { a = 42; b = ("", 4) } 21 21 + 22 22 + let () = print_int (a + d * (int_of_string c))

+24

testsuite/tests/shape-index/index_vb.reference

reviewed

··· 1 1 + Indexed shapes: 2 2 + Resolved: Index_vb.4 : c (File "index_vb.ml", line 22, characters 43-44) 3 3 + Unresolved: CU Stdlib . "int_of_string"[value] : 4 4 + int_of_string (File "index_vb.ml", line 22, characters 29-42) 5 5 + Resolved: Index_vb.5 : d (File "index_vb.ml", line 22, characters 24-25) 6 6 + Unresolved: CU Stdlib . "*"[value] : ( * 7 7 + ) (File "index_vb.ml", line 22, characters 26-27) 8 8 + Resolved: Index_vb.3 : a (File "index_vb.ml", line 22, characters 20-21) 9 9 + Unresolved: CU Stdlib . "+"[value] : 10 10 + (+) (File "index_vb.ml", line 22, characters 22-23) 11 11 + Unresolved: CU Stdlib . "print_int"[value] : 12 12 + print_int (File "index_vb.ml", line 22, characters 9-18) 13 13 + Resolved: Index_vb.2 : b (File "index_vb.ml", line 20, characters 34-35) 14 14 + Resolved: Index_vb.1 : a (File "index_vb.ml", line 20, characters 26-27) 15 15 + Resolved: Index_vb.2 : b (File "index_vb.ml", line 20, characters 9-10) 16 16 + Resolved: Index_vb.1 : a (File "index_vb.ml", line 20, characters 6-7) 17 17 + 18 18 + Uid of decls: 19 19 + Index_vb.3: a (File "index_vb.ml", line 20, characters 6-7) 20 20 + Index_vb.1: a (File "index_vb.ml", line 18, characters 11-12) 21 21 + Index_vb.0: t (File "index_vb.ml", line 18, characters 5-6) 22 22 + Index_vb.2: b (File "index_vb.ml", line 18, characters 20-21) 23 23 + Index_vb.5: a (File "index_vb.ml", line 20, characters 6-7) 24 24 + Index_vb.4: a (File "index_vb.ml", line 20, characters 6-7)

+127

testsuite/tests/shapes/aliases.ml

reviewed

··· 1 1 + (* TEST 2 2 + flags = "-dshape"; 3 3 + expect; 4 4 + *) 5 5 + 6 6 + module A = struct type t end 7 7 + module B = A 8 8 + [%%expect{| 9 9 + { 10 10 + "A"[module] -> {<.1> 11 11 + "t"[type] -> <.0>; 12 12 + }; 13 13 + } 14 14 + module A : sig type t end 15 15 + { 16 16 + "B"[module] -> Alias(<.2> 17 17 + {<.1> 18 18 + "t"[type] -> <.0>; 19 19 + }); 20 20 + } 21 21 + module B = A 22 22 + |}] 23 23 + 24 24 + type u = B.t 25 25 + 26 26 + [%%expect{| 27 27 + { 28 28 + "u"[type] -> <.3>; 29 29 + } 30 30 + type u = B.t 31 31 + |}] 32 32 + 33 33 + module F (X : sig type t end) = X 34 34 + module F' = F 35 35 + [%%expect{| 36 36 + { 37 37 + "F"[module] -> Abs<.6>(X, X<.5>); 38 38 + } 39 39 + module F : functor (X : sig type t end) -> sig type t = X.t end 40 40 + { 41 41 + "F'"[module] -> Alias(<.7> 42 42 + Abs<.6>(X, X<.5>)); 43 43 + } 44 44 + module F' = F 45 45 + |}] 46 46 + 47 47 + module C = F'(A) 48 48 + [%%expect{| 49 49 + { 50 50 + "C"[module] -> {<.8> 51 51 + "t"[type] -> <.0>; 52 52 + }; 53 53 + } 54 54 + module C : sig type t = A.t end 55 55 + |}] 56 56 + 57 57 + 58 58 + module C = F(B) 59 59 + 60 60 + [%%expect{| 61 61 + { 62 62 + "C"[module] -> Alias(<.9> 63 63 + {<.1> 64 64 + "t"[type] -> <.0>; 65 65 + }); 66 66 + } 67 67 + module C : sig type t = B.t end 68 68 + |}] 69 69 + 70 70 + module D = C 71 71 + 72 72 + [%%expect{| 73 73 + { 74 74 + "D"[module] -> Alias(<.10> 75 75 + Alias(<.9> 76 76 + {<.1> 77 77 + "t"[type] -> <.0>; 78 78 + })); 79 79 + } 80 80 + module D = C 81 81 + |}] 82 82 + 83 83 + module G (X : sig type t end) = struct include X end 84 84 + [%%expect{| 85 85 + { 86 86 + "G"[module] -> Abs<.13>(X, { 87 87 + "t"[type] -> X<.12> . "t"[type]; 88 88 + }); 89 89 + } 90 90 + module G : functor (X : sig type t end) -> sig type t = X.t end 91 91 + |}] 92 92 + 93 93 + module E = G(B) 94 94 + [%%expect{| 95 95 + { 96 96 + "E"[module] -> {<.14> 97 97 + "t"[type] -> <.0>; 98 98 + }; 99 99 + } 100 100 + module E : sig type t = B.t end 101 101 + |}] 102 102 + 103 103 + module M = struct type t let x = 1 end 104 104 + module N : sig type t end = M 105 105 + module O = N 106 106 + [%%expect{| 107 107 + { 108 108 + "M"[module] -> {<.17> 109 109 + "t"[type] -> <.15>; 110 110 + "x"[value] -> <.16>; 111 111 + }; 112 112 + } 113 113 + module M : sig type t val x : int end 114 114 + { 115 115 + "N"[module] -> {<.19> 116 116 + "t"[type] -> <.15>; 117 117 + }; 118 118 + } 119 119 + module N : sig type t end 120 120 + { 121 121 + "O"[module] -> Alias(<.20> 122 122 + {<.19> 123 123 + "t"[type] -> <.15>; 124 124 + }); 125 125 + } 126 126 + module O = N 127 127 + |}]

+9 -5

testsuite/tests/shapes/comp_units.ml

reviewed

··· 9 9 module Mdirect = Stdlib__Unit 10 10 [%%expect{| 11 11 { 12 12 - "Mdirect"[module] -> CU Stdlib__Unit; 12 12 + "Mdirect"[module] -> Alias(<.0> 13 13 + CU Stdlib__Unit); 13 14 } 14 15 module Mdirect = Unit 15 16 |}] ··· 17 18 module Mproj = Stdlib.Unit 18 19 [%%expect{| 19 20 { 20 20 - "Mproj"[module] -> (CU Stdlib . "Unit"[module])<.1>; 21 21 + "Mproj"[module] -> Alias(<.1> 22 22 + CU Stdlib . "Unit"[module]); 21 23 } 22 24 module Mproj = Unit 23 25 |}] ··· 25 27 module F (X : sig type t end) = X 26 28 [%%expect{| 27 29 { 28 28 - "F"[module] -> Abs<.4>(X/280, X/280<.3>); 30 30 + "F"[module] -> Abs<.4>(X, X<.3>); 29 31 } 30 32 module F : functor (X : sig type t end) -> sig type t = X.t end 31 33 |}] ··· 49 51 module App_direct_indir = F (Mdirect) 50 52 [%%expect{| 51 53 { 52 52 - "App_direct_indir"[module] -> CU Stdlib__Unit; 54 54 + "App_direct_indir"[module] -> Alias(<.7> 55 55 + CU Stdlib__Unit); 53 56 } 54 57 module App_direct_indir : sig type t = Mdirect.t end 55 58 |}] ··· 57 60 module App_proj_indir = F (Mproj) 58 61 [%%expect{| 59 62 { 60 60 - "App_proj_indir"[module] -> (CU Stdlib . "Unit"[module])<.1>; 63 63 + "App_proj_indir"[module] -> Alias(<.8> 64 64 + CU Stdlib . "Unit"[module]); 61 65 } 62 66 module App_proj_indir : sig type t = Mproj.t end 63 67 |}]

+54 -35

testsuite/tests/shapes/functors.ml

reviewed

··· 17 17 module Falias (X : S) = X 18 18 [%%expect{| 19 19 { 20 20 - "Falias"[module] -> Abs<.4>(X/282, X/282<.3>); 20 20 + "Falias"[module] -> Abs<.4>(X, X<.3>); 21 21 } 22 22 module Falias : functor (X : S) -> sig type t = X.t val x : t end 23 23 |}] ··· 29 29 { 30 30 "Finclude"[module] -> 31 31 Abs<.6> 32 32 - (X/286, 33 33 - { 34 34 - "t"[type] -> X/286<.5> . "t"[type]; 35 35 - "x"[value] -> X/286<.5> . "x"[value]; 36 36 - }); 32 32 + (X, { 33 33 + "t"[type] -> X<.5> . "t"[type]; 34 34 + "x"[value] -> X<.5> . "x"[value]; 35 35 + }); 37 36 } 38 37 module Finclude : functor (X : S) -> sig type t = X.t val x : t end 39 38 |}] ··· 44 43 end 45 44 [%%expect{| 46 45 { 47 47 - "Fredef"[module] -> 48 48 - Abs<.10>(X/293, { 49 49 - "t"[type] -> <.8>; 50 50 - "x"[value] -> <.9>; 51 51 - }); 46 46 + "Fredef"[module] -> Abs<.10>(X, { 47 47 + "t"[type] -> <.8>; 48 48 + "x"[value] -> <.9>; 49 49 + }); 52 50 } 53 51 module Fredef : functor (X : S) -> sig type t = X.t val x : X.t end 54 52 |}] ··· 60 58 [%%expect{| 61 59 { 62 60 "Fignore"[module] -> 63 63 - Abs<.14>(()/1, { 64 64 - "t"[type] -> <.11>; 65 65 - "x"[value] -> <.13>; 66 66 - }); 61 61 + Abs<.14> 62 62 + ((), 63 63 + { 64 64 + "t"[type] -> {<.11> 65 65 + "Fresh"[constructor] -> {<.12>}; 66 66 + }; 67 67 + "x"[value] -> <.13>; 68 68 + }); 67 69 } 68 70 module Fignore : S -> sig type t = Fresh val x : t end 69 71 |}] ··· 74 76 end 75 77 [%%expect{| 76 78 { 77 77 - "Arg"[module] -> {<.18> 78 78 - "t"[type] -> <.15>; 79 79 - "x"[value] -> <.17>; 80 80 - }; 79 79 + "Arg"[module] -> 80 80 + {<.18> 81 81 + "t"[type] -> {<.15> 82 82 + "T"[constructor] -> {<.16>}; 83 83 + }; 84 84 + "x"[value] -> <.17>; 85 85 + }; 81 86 } 82 87 module Arg : S 83 88 |}] ··· 85 90 include Falias(Arg) 86 91 [%%expect{| 87 92 { 88 88 - "t"[type] -> <.15>; 93 93 + "t"[type] -> {<.15> 94 94 + "T"[constructor] -> {<.16>}; 95 95 + }; 89 96 "x"[value] -> <.17>; 90 97 } 91 98 type t = Arg.t ··· 95 102 include Finclude(Arg) 96 103 [%%expect{| 97 104 { 98 98 - "t"[type] -> <.15>; 105 105 + "t"[type] -> {<.15> 106 106 + "T"[constructor] -> {<.16>}; 107 107 + }; 99 108 "x"[value] -> <.17>; 100 109 } 101 110 type t = Arg.t ··· 115 124 include Fignore(Arg) 116 125 [%%expect{| 117 126 { 118 118 - "t"[type] -> <.11>; 127 127 + "t"[type] -> {<.11> 128 128 + "Fresh"[constructor] -> {<.12>}; 129 129 + }; 119 130 "x"[value] -> <.13>; 120 131 } 121 132 type t = Fignore(Arg).t = Fresh ··· 155 166 include Fignore(struct type t = int let x = 0 end) 156 167 [%%expect{| 157 168 { 158 158 - "t"[type] -> <.11>; 169 169 + "t"[type] -> {<.11> 170 170 + "Fresh"[constructor] -> {<.12>}; 171 171 + }; 159 172 "x"[value] -> <.13>; 160 173 } 161 174 type t = Fresh ··· 168 181 end 169 182 [%%expect{| 170 183 { 171 171 - "Fgen"[module] -> Abs<.30>(()/1, { 172 172 - "t"[type] -> <.27>; 173 173 - "x"[value] -> <.29>; 174 174 - }); 184 184 + "Fgen"[module] -> 185 185 + Abs<.30> 186 186 + ((), 187 187 + { 188 188 + "t"[type] -> {<.27> 189 189 + "Fresher"[constructor] -> {<.28>}; 190 190 + }; 191 191 + "x"[value] -> <.29>; 192 192 + }); 175 193 } 176 194 module Fgen : functor () -> sig type t = Fresher val x : t end 177 195 |}] ··· 179 197 include Fgen () 180 198 [%%expect{| 181 199 { 182 182 - "t"[type] -> <.27>; 200 200 + "t"[type] -> {<.27> 201 201 + "Fresher"[constructor] -> {<.28>}; 202 202 + }; 183 203 "x"[value] -> <.29>; 184 204 } 185 205 type t = Fresher ··· 223 243 [%%expect{| 224 244 { 225 245 "Big_to_small1"[module] -> 226 226 - Abs<.40>(X/388, {<.39> 227 227 - "t"[type] -> X/388<.39> . "t"[type]; 228 228 - }); 246 246 + Abs<.40>(X, {<.39> 247 247 + "t"[type] -> X<.39> . "t"[type]; 248 248 + }); 229 249 } 230 250 module Big_to_small1 : B2S 231 251 |}] ··· 233 253 module Big_to_small2 : B2S = functor (X : Big) -> struct include X end 234 254 [%%expect{| 235 255 { 236 236 - "Big_to_small2"[module] -> 237 237 - Abs<.42>(X/391, { 238 238 - "t"[type] -> X/391<.41> . "t"[type]; 239 239 - }); 256 256 + "Big_to_small2"[module] -> Abs<.42>(X, { 257 257 + "t"[type] -> X<.41> . "t"[type]; 258 258 + }); 240 259 } 241 260 module Big_to_small2 : B2S 242 261 |}]

+2 -4

testsuite/tests/shapes/incl_md_typeof.ml

reviewed

··· 14 14 [%%expect{| 15 15 { 16 16 "Foo"[module] -> {<.2> 17 17 - "Bar"[module] -> {<.0> 18 18 - }; 17 17 + "Bar"[module] -> {<.0>}; 19 18 }; 20 19 } 21 20 module Foo : sig module Bar : sig end end ··· 42 41 [%%expect{| 43 42 { 44 43 "E"[module] -> {<.6> 45 45 - "Bar"[module] -> {<.5> 46 46 - }; 44 44 + "Bar"[module] -> {<.5>}; 47 45 }; 48 46 } 49 47 module E : Extended

+121

testsuite/tests/shapes/more_func.ml

reviewed

··· 1 1 + (* TEST 2 2 + flags = "-dshape"; 3 3 + expect; 4 4 + *) 5 5 + 6 6 + module M = struct end (* uid 0 *) 7 7 + module F(X : sig end) = M 8 8 + module App = F(List) 9 9 + [%%expect{| 10 10 + { 11 11 + "M"[module] -> {<.0>}; 12 12 + } 13 13 + module M : sig end 14 14 + { 15 15 + "F"[module] -> Abs<.2>(X, {<.0>}); 16 16 + } 17 17 + module F : functor (X : sig end) -> sig end 18 18 + { 19 19 + "App"[module] -> {<.3>}; 20 20 + } 21 21 + module App : sig end 22 22 + |}] 23 23 + 24 24 + 25 25 + module M = struct end (* uid 4 *) 26 26 + module F(X : sig end) = struct include M type t end 27 27 + module App = F(List) 28 28 + [%%expect{| 29 29 + { 30 30 + "M"[module] -> {<.4>}; 31 31 + } 32 32 + module M : sig end 33 33 + { 34 34 + "F"[module] -> Abs<.7>(X, { 35 35 + "t"[type] -> <.6>; 36 36 + }); 37 37 + } 38 38 + module F : functor (X : sig end) -> sig type t end 39 39 + { 40 40 + "App"[module] -> {<.8> 41 41 + "t"[type] -> <.6>; 42 42 + }; 43 43 + } 44 44 + module App : sig type t = F(List).t end 45 45 + |}] 46 46 + 47 47 + module M = struct end (* uid 9 *) 48 48 + module F(X : sig end) = X 49 49 + module App = F(M) 50 50 + [%%expect{| 51 51 + { 52 52 + "M"[module] -> {<.9>}; 53 53 + } 54 54 + module M : sig end 55 55 + { 56 56 + "F"[module] -> Abs<.11>(X, X<.10>); 57 57 + } 58 58 + module F : functor (X : sig end) -> sig end 59 59 + { 60 60 + "App"[module] -> {<.12>}; 61 61 + } 62 62 + module App : sig end 63 63 + |}] 64 64 + 65 65 + module Id(X : sig end) = X 66 66 + module Struct = struct 67 67 + module L = List 68 68 + end 69 69 + [%%expect{| 70 70 + { 71 71 + "Id"[module] -> Abs<.14>(X, X<.13>); 72 72 + } 73 73 + module Id : functor (X : sig end) -> sig end 74 74 + { 75 75 + "Struct"[module] -> 76 76 + {<.16> 77 77 + "L"[module] -> Alias(<.15> 78 78 + CU Stdlib . "List"[module]); 79 79 + }; 80 80 + } 81 81 + module Struct : sig module L = List end 82 82 + |}] 83 83 + 84 84 + module App = Id(List) (* this should have the App uid *) 85 85 + module Proj = Struct.L 86 86 + (* this should have the Proj uid and be an alias to Struct.L *) 87 87 + [%%expect{| 88 88 + { 89 89 + "App"[module] -> (CU Stdlib . "List"[module])<.17>; 90 90 + } 91 91 + module App : sig end 92 92 + { 93 93 + "Proj"[module] -> Alias(<.18> 94 94 + Alias(<.15> 95 95 + CU Stdlib . "List"[module])); 96 96 + } 97 97 + module Proj = Struct.L 98 98 + |}] 99 99 + 100 100 + module F (X :sig end ) = struct module M = X end 101 101 + module N = F(struct end) 102 102 + module O = N.M 103 103 + [%%expect{| 104 104 + { 105 105 + "F"[module] -> Abs<.21>(X, { 106 106 + "M"[module] -> X<.19>; 107 107 + }); 108 108 + } 109 109 + module F : functor (X : sig end) -> sig module M : sig end end 110 110 + { 111 111 + "N"[module] -> {<.22> 112 112 + "M"[module] -> {<.19>}; 113 113 + }; 114 114 + } 115 115 + module N : sig module M : sig end end 116 116 + { 117 117 + "O"[module] -> Alias(<.23> 118 118 + {<.19>}); 119 119 + } 120 120 + module O = N.M 121 121 + |}]

+50

testsuite/tests/shapes/nested_types.ml

reviewed

··· 1 1 + (* TEST 2 2 + flags = "-dshape"; 3 3 + expect; 4 4 + *) 5 5 + 6 6 + module M : sig 7 7 + 8 8 + exception Exn of { lbl_exn : int } 9 9 + type l = { lbl : int } 10 10 + type ext = .. 11 11 + type ext += Ext of { lbl_ext : int } 12 12 + type t = C of { lbl_cstr : int } 13 13 + end = struct 14 14 + exception Exn of { lbl_exn : int } 15 15 + type l = { lbl : int } 16 16 + type ext = .. 17 17 + type ext += Ext of { lbl_ext : int } 18 18 + type t = C of { lbl_cstr : int } 19 19 + end 20 20 + [%%expect{| 21 21 + { 22 22 + "M"[module] -> 23 23 + {<.37> 24 24 + "Exn"[extension constructor] -> {<.1> 25 25 + "lbl_exn"[label] -> <.0>; 26 26 + }; 27 27 + "Ext"[extension constructor] -> {<.7> 28 28 + "lbl_ext"[label] -> <.6>; 29 29 + }; 30 30 + "ext"[type] -> <.5>; 31 31 + "l"[type] -> {<.3> 32 32 + "lbl"[label] -> <.4>; 33 33 + }; 34 34 + "t"[type] -> 35 35 + {<.9> 36 36 + "C"[constructor] -> {<.11> 37 37 + "lbl_cstr"[label] -> <.10>; 38 38 + }; 39 39 + }; 40 40 + }; 41 41 + } 42 42 + module M : 43 43 + sig 44 44 + exception Exn of { lbl_exn : int; } 45 45 + type l = { lbl : int; } 46 46 + type ext = .. 47 47 + type ext += Ext of { lbl_ext : int; } 48 48 + type t = C of { lbl_cstr : int; } 49 49 + end 50 50 + |}]

+1 -2

testsuite/tests/shapes/open_arg.ml

reviewed

··· 22 22 23 23 [%%expect{| 24 24 { 25 25 - "Make"[module] -> Abs<.3>(I/282, { 26 26 - }); 25 25 + "Make"[module] -> Abs<.3>(I, {}); 27 26 } 28 27 module Make : functor (I : sig end) -> sig end 29 28 |}]

+38 -18

testsuite/tests/shapes/open_struct.ml

reviewed

··· 11 11 end 12 12 end 13 13 [%%expect{| 14 14 - { 15 15 - } 14 14 + {} 16 15 module M : sig type t = A end 17 16 |}] 18 17 19 18 include M 20 19 [%%expect{| 21 20 { 22 22 - "t"[type] -> <.0>; 21 21 + "t"[type] -> {<.0> 22 22 + "A"[constructor] -> {<.1>}; 23 23 + }; 23 24 } 24 25 type t = M.t = A 25 26 |}] ··· 27 28 module N = M 28 29 [%%expect{| 29 30 { 30 30 - "N"[module] -> {<.2> 31 31 - "t"[type] -> <.0>; 32 32 - }; 31 31 + "N"[module] -> 32 32 + Alias(<.3> 33 33 + {<.2> 34 34 + "t"[type] -> {<.0> 35 35 + "A"[constructor] -> {<.1>}; 36 36 + }; 37 37 + }); 33 38 } 34 39 module N = M 35 40 |}] ··· 46 51 [%%expect{| 47 52 { 48 53 "M'"[module] -> {<.6> 49 49 - "t"[type] -> <.4>; 54 54 + "t"[type] -> {<.4> 55 55 + "A"[constructor] -> {<.5>}; 56 56 + }; 50 57 }; 51 58 } 52 59 module M' : sig type t = A end ··· 55 62 module N' = M' 56 63 [%%expect{| 57 64 { 58 58 - "N'"[module] -> {<.6> 59 59 - "t"[type] -> <.4>; 60 60 - }; 65 65 + "N'"[module] -> 66 66 + Alias(<.7> 67 67 + {<.6> 68 68 + "t"[type] -> {<.4> 69 69 + "A"[constructor] -> {<.5>}; 70 70 + }; 71 71 + }); 61 72 } 62 73 module N' = M' 63 74 |}] ··· 69 80 end 70 81 [%%expect{| 71 82 { 72 72 - "Test"[module] -> {<.11> 73 73 - "M"[module] -> {<.10> 74 74 - "t"[type] -> <.8>; 75 75 - }; 83 83 + "Test"[module] -> 84 84 + {<.11> 85 85 + "M"[module] -> {<.10> 86 86 + "t"[type] -> {<.8> 87 87 + "A"[constructor] -> {<.9>}; 88 88 + }; 76 89 }; 90 90 + }; 77 91 } 78 92 module Test : sig module M : sig type t = A end end 79 93 |}] ··· 82 96 [%%expect{| 83 97 { 84 98 "M"[module] -> {<.10> 85 85 - "t"[type] -> <.8>; 99 99 + "t"[type] -> {<.8> 100 100 + "A"[constructor] -> {<.9>}; 101 101 + }; 86 102 }; 87 103 } 88 104 module M = Test.M ··· 91 107 module N = M 92 108 [%%expect{| 93 109 { 94 94 - "N"[module] -> {<.10> 95 95 - "t"[type] -> <.8>; 96 96 - }; 110 110 + "N"[module] -> 111 111 + Alias(<.12> 112 112 + {<.10> 113 113 + "t"[type] -> {<.8> 114 114 + "A"[constructor] -> {<.9>}; 115 115 + }; 116 116 + }); 97 117 } 98 118 module N = M 99 119 |}]

+17 -11

testsuite/tests/shapes/recmodules.ml

reviewed

··· 18 18 [%%expect{| 19 19 { 20 20 "A"[module] -> { 21 21 - "t"[type] -> <.8>; 21 21 + "t"[type] -> {<.8> 22 22 + "Leaf"[constructor] -> {<.9>}; 23 23 + }; 22 24 }; 23 25 "B"[module] -> { 24 26 "t"[type] -> <.10>; ··· 43 45 end = B 44 46 [%%expect{| 45 47 { 46 46 - "A"[module] -> A/305<.11>; 47 47 - "B"[module] -> B/306<.12>; 48 48 + "A"[module] -> A<.11>; 49 49 + "B"[module] -> B<.12>; 48 50 } 49 51 module rec A : sig type t = Leaf of B.t end 50 52 and B : sig type t = int end ··· 75 77 end = Set.Make(A) 76 78 [%%expect{| 77 79 { 78 78 - "A"[module] -> { 79 79 - "compare"[value] -> <.38>; 80 80 - "t"[type] -> <.35>; 81 81 - }; 80 80 + "A"[module] -> 81 81 + { 82 82 + "compare"[value] -> <.38>; 83 83 + "t"[type] -> 84 84 + {<.35> 85 85 + "Leaf"[constructor] -> {<.36>}; 86 86 + "Node"[constructor] -> {<.37>}; 87 87 + }; 88 88 + }; 82 89 "ASet"[module] -> 83 90 { 84 91 "compare"[value] -> 85 85 - CU Stdlib . "Set"[module] . "Make"[module](A/327<.19>) . 86 86 - "compare"[value]; 92 92 + CU Stdlib . "Set"[module] . "Make"[module](A<.19>) . "compare"[value]; 87 93 "elt"[type] -> 88 88 - CU Stdlib . "Set"[module] . "Make"[module](A/327<.19>) . "elt"[type]; 94 94 + CU Stdlib . "Set"[module] . "Make"[module](A<.19>) . "elt"[type]; 89 95 "t"[type] -> 90 90 - CU Stdlib . "Set"[module] . "Make"[module](A/327<.19>) . "t"[type]; 96 96 + CU Stdlib . "Set"[module] . "Make"[module](A<.19>) . "t"[type]; 91 97 }; 92 98 } 93 99 module rec A :

+5 -6

testsuite/tests/shapes/rotor_example.ml

reviewed

··· 25 25 [%%expect{| 26 26 { 27 27 "Pair"[module] -> 28 28 - Abs<.9>(X/282, Y/283, { 29 29 - "t"[type] -> <.5>; 30 30 - "to_string"[value] -> <.6>; 31 31 - }); 28 28 + Abs<.9>(X, Y, { 29 29 + "t"[type] -> <.5>; 30 30 + "to_string"[value] -> <.6>; 31 31 + }); 32 32 } 33 33 module Pair : 34 34 functor (X : Stringable) (Y : Stringable) -> ··· 80 80 81 81 P.to_string (0, ("!=", 1)) 82 82 [%%expect{| 83 83 - { 84 84 - } 83 83 + {} 85 84 - : string = "0 != 1" 86 85 |}]

+30 -14

testsuite/tests/shapes/simple.ml

reviewed

··· 23 23 and foo = Bar 24 24 [%%expect{| 25 25 { 26 26 - "foo"[type] -> <.3>; 27 27 - "t"[type] -> <.2>; 26 26 + "foo"[type] -> {<.3> 27 27 + "Bar"[constructor] -> {<.5>}; 28 28 + }; 29 29 + "t"[type] -> {<.2> 30 30 + "A"[constructor] -> {<.4>}; 31 31 + }; 28 32 } 29 33 type t = A of foo 30 34 and foo = Bar ··· 43 47 exception E 44 48 [%%expect{| 45 49 { 46 46 - "E"[extension constructor] -> <.8>; 50 50 + "E"[extension constructor] -> {<.8>}; 47 51 } 48 52 exception E 49 53 |}] ··· 59 63 type ext += A | B 60 64 [%%expect{| 61 65 { 62 62 - "A"[extension constructor] -> <.10>; 63 63 - "B"[extension constructor] -> <.11>; 66 66 + "A"[extension constructor] -> {<.10>}; 67 67 + "B"[extension constructor] -> {<.11>}; 64 68 } 65 69 type ext += A | B 66 70 |}] ··· 71 75 [%%expect{| 72 76 { 73 77 "M"[module] -> {<.13> 74 74 - "C"[extension constructor] -> <.12>; 78 78 + "C"[extension constructor] -> {<.12>}; 75 79 }; 76 80 } 77 81 module M : sig type ext += C end ··· 81 85 type t = Should_not_appear_in_shape 82 86 end 83 87 [%%expect{| 84 84 - { 85 85 - } 88 88 + {} 86 89 |}] 87 90 88 91 module rec M1 : sig ··· 101 104 [%%expect{| 102 105 { 103 106 "M1"[module] -> { 104 104 - "t"[type] -> <.27>; 107 107 + "t"[type] -> {<.27> 108 108 + "C"[constructor] -> {<.28>}; 109 109 + }; 105 110 }; 106 106 - "M2"[module] -> { 107 107 - "t"[type] -> <.29>; 108 108 - "x"[value] -> <.31>; 111 111 + "M2"[module] -> 112 112 + { 113 113 + "t"[type] -> {<.29> 114 114 + "T"[constructor] -> {<.30>}; 109 115 }; 116 116 + "x"[value] -> <.31>; 117 117 + }; 110 118 } 111 119 module rec M1 : sig type t = C of M2.t end 112 120 and M2 : sig type t val x : t end ··· 125 133 class type c = object end 126 134 [%%expect{| 127 135 { 128 128 - "c"[type] -> <.34>; 129 129 - "c"[class type] -> <.34>; 136 136 + "c"[type] -> <.35>; 137 137 + "c"[class type] -> <.35>; 130 138 } 131 139 class type c = object end 132 140 |}] 141 141 + 142 142 + type u = t 143 143 + [%%expect{| 144 144 + { 145 145 + "u"[type] -> <.36>; 146 146 + } 147 147 + type u = t 148 148 + |}]

+80 -20

tools/objinfo.ml

reviewed

··· 24 24 (* Command line options to prevent printing approximation, 25 25 function code and CRC 26 26 *) 27 27 + let quiet = ref false 27 28 let no_approx = ref false 28 29 let no_code = ref false 29 30 let no_crc = ref false 30 31 let shape = ref false 32 32 + let index = ref false 33 33 + let decls = ref false 31 34 32 35 module Magic_number = Misc.Magic_number 33 36 ··· 82 85 List.iter print_cmo_infos lib.lib_units 83 86 84 87 let print_cmi_infos name crcs = 85 85 - printf "Unit name: %s\n" name; 86 86 - printf "Interfaces imported:\n"; 87 87 - List.iter print_name_crc crcs 88 88 + if not !quiet then begin 89 89 + printf "Unit name: %s\n" name; 90 90 + printf "Interfaces imported:\n"; 91 91 + List.iter print_name_crc crcs 92 92 + end 88 93 89 94 let print_cmt_infos cmt = 90 95 let open Cmt_format in 91 91 - printf "Cmt unit name: %s\n" cmt.cmt_modname; 92 92 - print_string "Cmt interfaces imported:\n"; 93 93 - List.iter print_name_crc cmt.cmt_imports; 94 94 - printf "Source file: %s\n" 95 95 - (match cmt.cmt_sourcefile with None -> "(none)" | Some f -> f); 96 96 - printf "Compilation flags:"; 97 97 - Array.iter print_spaced_string cmt.cmt_args; 98 98 - printf "\nLoad path:\n Visible:"; 99 99 - List.iter print_spaced_string cmt.cmt_loadpath.visible; 100 100 - printf "\n Hidden:"; 101 101 - List.iter print_spaced_string cmt.cmt_loadpath.hidden; 102 102 - printf "\n"; 103 103 - printf "cmt interface digest: %s\n" 104 104 - (match cmt.cmt_interface_digest with 105 105 - | None -> "" 106 106 - | Some crc -> string_of_crc crc); 96 96 + if not !quiet then begin 97 97 + printf "Cmt unit name: %s\n" cmt.cmt_modname; 98 98 + print_string "Cmt interfaces imported:\n"; 99 99 + List.iter print_name_crc cmt.cmt_imports; 100 100 + printf "Source file: %s\n" 101 101 + (match cmt.cmt_sourcefile with None -> "(none)" | Some f -> f); 102 102 + printf "Compilation flags:"; 103 103 + Array.iter print_spaced_string cmt.cmt_args; 104 104 + printf "\nLoad path:\n Visible:"; 105 105 + List.iter print_spaced_string cmt.cmt_loadpath.visible; 106 106 + printf "\n Hidden:"; 107 107 + List.iter print_spaced_string cmt.cmt_loadpath.hidden; 108 108 + printf "\n"; 109 109 + printf "cmt interface digest: %s\n" 110 110 + (match cmt.cmt_interface_digest with 111 111 + | None -> "" 112 112 + | Some crc -> string_of_crc crc); 113 113 + end; 107 114 if !shape then begin 108 115 printf "Implementation shape: "; 109 116 (match cmt.cmt_impl_shape with 110 117 | None -> printf "(none)\n" 111 118 | Some shape -> Format.printf "\n%a" Shape.print shape) 119 119 + end; 120 120 + if !index then begin 121 121 + printf "Indexed shapes:\n"; 122 122 + List.iter (fun (loc, item) -> 123 123 + let pp_loc fmt { Location.txt; loc } = 124 124 + Format.fprintf fmt "%a (%a)" 125 125 + Pprintast.longident txt Location.print_loc loc 126 126 + in 127 127 + Format.printf "@[<hov 2>%a:@ %a@]@;" 128 128 + Shape_reduce.print_result item pp_loc loc) 129 129 + cmt.cmt_ident_occurrences; 130 130 + Format.print_flush () 131 131 + end; 132 132 + if !decls then begin 133 133 + printf "\nUid of decls:\n"; 134 134 + Shape.Uid.Tbl.iter (fun uid item -> 135 135 + let loc = match (item : Typedtree.item_declaration) with 136 136 + | Value vd -> vd.val_name 137 137 + | Value_binding vb -> 138 138 + let (_, name, _, _) = 139 139 + List.hd (Typedtree.let_bound_idents_full [vb]) 140 140 + in 141 141 + name 142 142 + | Type td -> td.typ_name 143 143 + | Constructor cd -> cd.cd_name 144 144 + | Extension_constructor ec -> ec.ext_name 145 145 + | Label ld -> ld.ld_name 146 146 + | Module md -> 147 147 + { md.md_name with 148 148 + txt = Option.value md.md_name.txt ~default:"_" } 149 149 + | Module_substitution ms -> ms.ms_name 150 150 + | Module_binding mb -> 151 151 + { mb.mb_name with 152 152 + txt = Option.value mb.mb_name.txt ~default:"_" } 153 153 + | Module_type mtd -> mtd.mtd_name 154 154 + | Class cd -> cd.ci_id_name 155 155 + | Class_type ctd -> ctd.ci_id_name 156 156 + in 157 157 + let pp_loc fmt { Location.txt; loc } = 158 158 + Format.fprintf fmt "%s (%a)" 159 159 + txt Location.print_loc loc 160 160 + in 161 161 + Format.printf "@[<hov 2>%a:@ %a@]@;" 162 162 + Shape.Uid.print uid 163 163 + pp_loc loc) 164 164 + cmt.cmt_uid_to_decl; 165 165 + Format.print_flush () 112 166 end 113 167 114 168 let print_general_infos name crc defines cmi cmx = ··· 367 421 dump_obj_by_kind filename ic Cmxs; 368 422 () 369 423 in 370 370 - printf "File %s\n" filename; 424 424 + if not !quiet then printf "File %s\n" filename; 371 425 let ic = open_in_bin filename in 372 426 match dump_standard ic with 373 427 | Ok () -> () ··· 380 434 else exit_magic_error ~expected_kind:None (Parse_error head_error) 381 435 382 436 let arg_list = [ 437 437 + "-quiet", Arg.Set quiet, 438 438 + " Only print explicitely required information"; 383 439 "-no-approx", Arg.Set no_approx, 384 440 " Do not print module approximation information"; 385 441 "-no-code", Arg.Set no_code, 386 442 " Do not print code from exported flambda functions"; 387 443 "-shape", Arg.Set shape, 388 444 " Print the shape of the module"; 445 445 + "-index", Arg.Set index, 446 446 + " Print a list of all usages of values, types, etc. in the module"; 447 447 + "-decls", Arg.Set decls, 448 448 + " Print a list of all declarations in the module"; 389 449 "-null-crc", Arg.Set no_crc, " Print a null CRC for imported interfaces"; 390 450 "-args", Arg.Expand Arg.read_arg, 391 451 "<file> Read additional newline separated command line arguments \n\

+1 -1

toplevel/byte/topeval.ml

reviewed

··· 131 131 let sg' = Typemod.Signature_names.simplify newenv sn sg in 132 132 ignore (Includemod.signatures ~mark:Mark_positive oldenv sg sg'); 133 133 Typecore.force_delayed_checks (); 134 134 - let shape = Shape.local_reduce shape in 134 134 + let shape = Shape_reduce.local_reduce Env.empty shape in 135 135 if !Clflags.dump_shape then Shape.print ppf shape; 136 136 let lam = Translmod.transl_toplevel_definition str in 137 137 Warnings.check_fatal ();

+2 -2

toplevel/native/topeval.ml

reviewed

··· 129 129 in 130 130 let sg = [Sig_value(id, vd, Exported)] in 131 131 let pat = 132 132 - { pat_desc = Tpat_var(id, mknoloc name); 132 132 + { pat_desc = Tpat_var(id, mknoloc name, vd.val_uid); 133 133 pat_loc = loc; 134 134 pat_extra = []; 135 135 pat_type = exp.exp_type; ··· 171 171 let sg' = Typemod.Signature_names.simplify newenv names sg in 172 172 ignore (Includemod.signatures oldenv ~mark:Mark_positive sg sg'); 173 173 Typecore.force_delayed_checks (); 174 174 - let shape = Shape.local_reduce shape in 174 174 + let shape = Shape_reduce.local_reduce Env.empty shape in 175 175 if !Clflags.dump_shape then Shape.print ppf shape; 176 176 (* `let _ = <expression>` or even just `<expression>` require special 177 177 handling in toplevels, or nothing is displayed. In bytecode, the

+1 -1

typing/cmt2annot.ml

reviewed

··· 23 23 let super = default_iterator in 24 24 let pat sub (type k) (p : k general_pattern) = 25 25 begin match p.pat_desc with 26 26 - | Tpat_var (id, _) | Tpat_alias (_, id, _) -> 26 26 + | Tpat_var (id, _, _) | Tpat_alias (_, id, _, _) -> 27 27 Stypes.record (Stypes.An_ident (p.pat_loc, 28 28 Ident.name id, 29 29 Annot.Idef scope))

+4 -10

typing/env.ml

reviewed

··· 40 40 let type_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 41 41 let module_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 42 42 43 43 - let uid_to_loc : Location.t Types.Uid.Tbl.t ref = 44 44 - s_table Types.Uid.Tbl.create 16 45 45 - 46 46 - let register_uid uid loc = Types.Uid.Tbl.add !uid_to_loc uid loc 47 47 - 48 48 - let get_uid_to_loc_tbl () = !uid_to_loc 49 49 - 50 43 type constructor_usage = Positive | Pattern | Exported_private | Exported 51 44 type constructor_usages = 52 45 { ··· 966 959 Types.Uid.Tbl.clear !module_declarations; 967 960 Types.Uid.Tbl.clear !used_constructors; 968 961 Types.Uid.Tbl.clear !used_labels; 969 969 - Types.Uid.Tbl.clear !uid_to_loc; 970 962 () 971 963 972 964 let reset_cache () = ··· 1273 1265 match ns with 1274 1266 | Type -> 1275 1267 (IdTbl.find_same id env.types).tda_shape 1268 1268 + | Constructor -> 1269 1269 + Shape.leaf ((TycompTbl.find_same id env.constrs).cda_description.cstr_uid) 1270 1270 + | Label -> 1271 1271 + Shape.leaf ((TycompTbl.find_same id env.labels).lbl_uid) 1276 1272 | Extension_constructor -> 1277 1273 (TycompTbl.find_same id env.constrs).cda_shape 1278 1274 | Value -> ··· 2357 2353 enter_signature_and_shape ~scope ~parent_shape (Some mod_shape) sg env 2358 2354 2359 2355 let add_value = add_value ?shape:None 2360 2360 - let add_type = add_type ?shape:None 2361 2361 - let add_extension = add_extension ?shape:None 2362 2356 let add_class = add_class ?shape:None 2363 2357 let add_cltype = add_cltype ?shape:None 2364 2358 let add_modtype = add_modtype ?shape:None

+4 -6

typing/env.mli

reviewed

··· 18 18 open Types 19 19 open Misc 20 20 21 21 - val register_uid : Uid.t -> Location.t -> unit 22 22 - 23 23 - val get_uid_to_loc_tbl : unit -> Location.t Types.Uid.Tbl.t 24 24 - 25 21 type value_unbound_reason = 26 22 | Val_unbound_instance_variable 27 23 | Val_unbound_self ··· 300 296 301 297 val add_value: 302 298 ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t 303 303 - val add_type: check:bool -> Ident.t -> type_declaration -> t -> t 299 299 + val add_type: 300 300 + check:bool -> ?shape:Shape.t -> Ident.t -> type_declaration -> t -> t 304 301 val add_extension: 305 305 - check:bool -> rebind:bool -> Ident.t -> extension_constructor -> t -> t 302 302 + check:bool -> ?shape:Shape.t -> rebind:bool -> Ident.t -> 303 303 + extension_constructor -> t -> t 306 304 val add_module: ?arg:bool -> ?shape:Shape.t -> 307 305 Ident.t -> module_presence -> module_type -> t -> t 308 306 val add_module_lazy: update_summary:bool ->

+2

typing/includemod.ml

reviewed

··· 745 745 type_declarations ~loc ~old_env env ~mark subst id1 tydec1 tydec2 746 746 in 747 747 let item = mark_error_as_unrecoverable item in 748 748 + (* Right now we don't filter hidden constructors / labels from the 749 749 + shape. *) 748 750 let shape_map = Shape.Map.add_type_proj shape_map id1 orig_shape in 749 751 id1, item, shape_map, false 750 752 | Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _) ->

+18 -15

typing/parmatch.ml

reviewed

··· 54 54 55 55 let extra_pat = 56 56 make_pat 57 57 - (Tpat_var (Ident.create_local "+", mknoloc "+")) 57 57 + (Tpat_var (Ident.create_local "+", mknoloc "+", 58 58 + Uid.internal_not_actually_unique)) 58 59 Ctype.none Env.empty 59 60 60 61 ··· 300 301 | ((Tpat_any|Tpat_var _),_) 301 302 | (_,(Tpat_any|Tpat_var _)) -> true 302 303 (* Structural induction *) 303 303 - | Tpat_alias (p,_,_),_ -> compat p q 304 304 - | _,Tpat_alias (q,_,_) -> compat p q 304 304 + | Tpat_alias (p,_,_,_),_ -> compat p q 305 305 + | _,Tpat_alias (q,_,_,_) -> compat p q 305 306 | Tpat_or (p1,p2,_),_ -> 306 307 (compat p1 q || compat p2 q) 307 308 | _,Tpat_or (q1,q2,_) -> ··· 938 939 (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *) 939 940 make_pat 940 941 (Tpat_var (Ident.create_local "*extension*", 941 941 - {txt="*extension*"; loc = d.pat_loc})) 942 942 + {txt="*extension*"; loc = d.pat_loc}, 943 943 + Uid.internal_not_actually_unique)) 942 944 Ctype.none Env.empty 943 945 | Construct _ -> 944 946 begin match ext with ··· 1068 1070 let rec has_instance p = match p.pat_desc with 1069 1071 | Tpat_variant (l,_,r) when is_absent l r -> false 1070 1072 | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true 1071 1071 - | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p 1073 1073 + | Tpat_alias (p,_,_,_) | Tpat_variant (_,Some p,_) -> has_instance p 1072 1074 | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2 1073 1075 | Tpat_construct (_,_,ps,_) | Tpat_tuple ps | Tpat_array ps -> 1074 1076 has_instances ps ··· 1522 1524 (* Standard or-args for left-to-right matching *) 1523 1525 let rec or_args p = match p.pat_desc with 1524 1526 | Tpat_or (p1,p2,_) -> p1,p2 1525 1525 - | Tpat_alias (p,_,_) -> or_args p 1527 1527 + | Tpat_alias (p,_,_,_) -> or_args p 1526 1528 | _ -> assert false 1527 1529 1528 1530 (* Just remove current column *) ··· 1702 1704 let rec le_pat p q = 1703 1705 match (p.pat_desc, q.pat_desc) with 1704 1706 | (Tpat_var _|Tpat_any),_ -> true 1705 1705 - | Tpat_alias(p,_,_), _ -> le_pat p q 1706 1706 - | _, Tpat_alias(q,_,_) -> le_pat p q 1707 1707 + | Tpat_alias(p,_,_,_), _ -> le_pat p q 1708 1708 + | _, Tpat_alias(q,_,_,_) -> le_pat p q 1707 1709 | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0 1708 1710 | Tpat_construct(_,c1,ps,_), Tpat_construct(_,c2,qs,_) -> 1709 1711 Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs ··· 1746 1748 *) 1747 1749 1748 1750 let rec lub p q = match p.pat_desc,q.pat_desc with 1749 1749 - | Tpat_alias (p,_,_),_ -> lub p q 1750 1750 - | _,Tpat_alias (q,_,_) -> lub p q 1751 1751 + | Tpat_alias (p,_,_,_),_ -> lub p q 1752 1752 + | _,Tpat_alias (q,_,_,_) -> lub p q 1751 1753 | (Tpat_any|Tpat_var _),_ -> q 1752 1754 | _,(Tpat_any|Tpat_var _) -> p 1753 1755 | Tpat_or (p1,p2,_),_ -> orlub p1 p2 q ··· 1868 1870 let contains_extension pat = 1869 1871 exists_pattern 1870 1872 (function 1871 1871 - | {pat_desc=Tpat_var (_, {txt="*extension*"})} -> true 1873 1873 + | {pat_desc=Tpat_var (_, {txt="*extension*"}, _)} -> true 1872 1874 | _ -> false) 1873 1875 pat 1874 1876 ··· 1953 1955 List.fold_left 1954 1956 (fun r (_, _, p) -> collect_paths_from_pat r p) 1955 1957 r lps 1956 1956 - | Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p 1958 1958 + | Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_,_) -> 1959 1959 + collect_paths_from_pat r p 1957 1960 | Tpat_or (p1,p2,_) -> 1958 1961 collect_paths_from_pat (collect_paths_from_pat r p1) p2 1959 1962 | Tpat_lazy p ··· 2085 2088 end 2086 2089 | Tpat_tuple ps | Tpat_construct (_, _, ps, _) -> 2087 2090 List.for_all (fun p -> loop p) ps 2088 2088 - | Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) -> 2091 2091 + | Tpat_alias (p,_,_,_) | Tpat_variant (_, Some p, _) -> 2089 2092 loop p 2090 2093 | Tpat_record (ldps,_) -> 2091 2094 List.for_all ··· 2204 2207 let simplify_head_amb_pat head_bound_variables varsets ~add_column p ps k = 2205 2208 let rec simpl head_bound_variables varsets p ps k = 2206 2209 match (Patterns.General.view p).pat_desc with 2207 2207 - | `Alias (p,x,_) -> 2210 2210 + | `Alias (p,x,_,_) -> 2208 2211 simpl (Ident.Set.add x head_bound_variables) varsets p ps k 2209 2209 - | `Var (x, _) -> 2212 2212 + | `Var (x,_,_) -> 2210 2213 simpl (Ident.Set.add x head_bound_variables) varsets Patterns.omega ps k 2211 2214 | `Or (p1,p2,_) -> 2212 2215 simpl head_bound_variables varsets p1 ps

+9 -9

typing/patterns.ml

reviewed

··· 79 79 module General = struct 80 80 type view = [ 81 81 | Half_simple.view 82 82 - | `Var of Ident.t * string loc 83 83 - | `Alias of pattern * Ident.t * string loc 82 82 + | `Var of Ident.t * string loc * Uid.t 83 83 + | `Alias of pattern * Ident.t * string loc * Uid.t 84 84 ] 85 85 type pattern = view pattern_data 86 86 87 87 let view_desc = function 88 88 | Tpat_any -> 89 89 `Any 90 90 - | Tpat_var (id, str) -> 91 91 - `Var (id, str) 92 92 - | Tpat_alias (p, id, str) -> 93 93 - `Alias (p, id, str) 90 90 + | Tpat_var (id, str, uid) -> 91 91 + `Var (id, str, uid) 92 92 + | Tpat_alias (p, id, str, uid) -> 93 93 + `Alias (p, id, str, uid) 94 94 | Tpat_constant cst -> 95 95 `Constant cst 96 96 | Tpat_tuple ps -> ··· 110 110 111 111 let erase_desc = function 112 112 | `Any -> Tpat_any 113 113 - | `Var (id, str) -> Tpat_var (id, str) 114 114 - | `Alias (p, id, str) -> Tpat_alias (p, id, str) 113 113 + | `Var (id, str, uid) -> Tpat_var (id, str, uid) 114 114 + | `Alias (p, id, str, uid) -> Tpat_alias (p, id, str, uid) 115 115 | `Constant cst -> Tpat_constant cst 116 116 | `Tuple ps -> Tpat_tuple ps 117 117 | `Construct (cstr, cst_descr, args) -> ··· 129 129 130 130 let rec strip_vars (p : pattern) : Half_simple.pattern = 131 131 match p.pat_desc with 132 132 - | `Alias (p, _, _) -> strip_vars (view p) 132 132 + | `Alias (p, _, _, _) -> strip_vars (view p) 133 133 | `Var _ -> { p with pat_desc = `Any } 134 134 | #Half_simple.view as view -> { p with pat_desc = view } 135 135 end

+2 -2

typing/patterns.mli

reviewed

··· 65 65 module General : sig 66 66 type view = [ 67 67 | Half_simple.view 68 68 - | `Var of Ident.t * string loc 69 69 - | `Alias of pattern * Ident.t * string loc 68 68 + | `Var of Ident.t * string loc * Uid.t 69 69 + | `Alias of pattern * Ident.t * string loc * Uid.t 70 70 ] 71 71 type pattern = view pattern_data 72 72

+2 -2

typing/printpat.ml

reviewed

··· 52 52 | [] -> 53 53 match v.pat_desc with 54 54 | Tpat_any -> fprintf ppf "_" 55 55 - | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x) 55 55 + | Tpat_var (x,_,_) -> fprintf ppf "%s" (Ident.name x) 56 56 | Tpat_constant c -> fprintf ppf "%s" (pretty_const c) 57 57 | Tpat_tuple vs -> 58 58 fprintf ppf "@[(%a)@]" (pretty_vals ",") vs ··· 98 98 fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs 99 99 | Tpat_lazy v -> 100 100 fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v 101 101 - | Tpat_alias (v, x,_) -> 101 101 + | Tpat_alias (v, x,_,_) -> 102 102 fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x 103 103 | Tpat_value v -> 104 104 fprintf ppf "%a" pretty_val (v :> pattern)

+8 -4

typing/printtyp.ml

reviewed

··· 55 55 type namespace = Sig_component_kind.t = 56 56 | Value 57 57 | Type 58 58 + | Constructor 59 59 + | Label 58 60 | Module 59 61 | Module_type 60 62 | Extension_constructor ··· 70 72 | Module_type -> 2 71 73 | Class -> 3 72 74 | Class_type -> 4 73 73 - | Extension_constructor | Value -> 5 75 75 + | Extension_constructor | Value | Constructor | Label -> 5 74 76 (* we do not handle those component *) 75 77 76 78 let size = 1 + id Value ··· 90 92 | Some Module_type -> to_lookup Env.find_modtype_by_name 91 93 | Some Class -> to_lookup Env.find_class_by_name 92 94 | Some Class_type -> to_lookup Env.find_cltype_by_name 93 93 - | None | Some(Value|Extension_constructor) -> fun _ -> raise Not_found 95 95 + | None | Some(Value|Extension_constructor|Constructor|Label) -> 96 96 + fun _ -> raise Not_found 94 97 95 98 let location namespace id = 96 99 let path = Path.Pident id in ··· 101 104 | Some Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc 102 105 | Some Class -> (in_printing_env @@ Env.find_class path).cty_loc 103 106 | Some Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc 104 104 - | Some (Extension_constructor|Value) | None -> Location.none 107 107 + | Some (Extension_constructor|Value|Constructor|Label) | None -> 108 108 + Location.none 105 109 ) with Not_found -> None 106 110 107 111 let best_class_namespace = function ··· 284 288 | Module_type -> Env.find_modtype_index id env 285 289 | Class -> Env.find_class_index id env 286 290 | Class_type-> Env.find_cltype_index id env 287 287 - | Value | Extension_constructor -> None 291 291 + | Value | Extension_constructor | Constructor | Label -> None 288 292 in 289 293 let index = 290 294 match M.find_opt (Ident.name id) !bound_in_recursion with

+2 -2

typing/printtyped.ml

reviewed

··· 235 235 end; 236 236 match x.pat_desc with 237 237 | Tpat_any -> line i ppf "Tpat_any\n"; 238 238 - | Tpat_var (s,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s; 239 239 - | Tpat_alias (p, s,_) -> 238 238 + | Tpat_var (s,_,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s; 239 239 + | Tpat_alias (p, s,_,_) -> 240 240 line i ppf "Tpat_alias \"%a\"\n" fmt_ident s; 241 241 pattern i ppf p; 242 242 | Tpat_constant (c) -> line i ppf "Tpat_constant %a\n" fmt_constant c;

+83 -264

typing/shape.ml

reviewed

··· 67 67 type t = 68 68 | Value 69 69 | Type 70 70 + | Constructor 71 71 + | Label 70 72 | Module 71 73 | Module_type 72 74 | Extension_constructor ··· 76 78 let to_string = function 77 79 | Value -> "value" 78 80 | Type -> "type" 81 81 + | Constructor -> "constructor" 82 82 + | Label -> "label" 79 83 | Module -> "module" 80 84 | Module_type -> "module type" 81 85 | Extension_constructor -> "extension constructor" ··· 87 91 | Extension_constructor -> 88 92 false 89 93 | Type 94 94 + | Constructor 95 95 + | Label 90 96 | Module 91 97 | Module_type 92 98 | Class ··· 99 105 type t = string * Sig_component_kind.t 100 106 let compare = compare 101 107 108 108 + let name (name, _) = name 109 109 + let kind (_, kind) = kind 110 110 + 102 111 let make str ns = str, ns 103 112 104 113 let value id = Ident.name id, Sig_component_kind.Value 105 114 let type_ id = Ident.name id, Sig_component_kind.Type 115 115 + let constr id = Ident.name id, Sig_component_kind.Constructor 116 116 + let label id = Ident.name id, Sig_component_kind.Label 106 117 let module_ id = Ident.name id, Sig_component_kind.Module 107 118 let module_type id = Ident.name id, Sig_component_kind.Module_type 108 119 let extension_constructor id = ··· 124 135 end 125 136 126 137 type var = Ident.t 127 127 - type t = { uid: Uid.t option; desc: desc } 138 138 + type t = { uid: Uid.t option; desc: desc; approximated: bool } 128 139 and desc = 129 140 | Var of var 130 141 | Abs of var * t 131 142 | App of t * t 132 143 | Struct of t Item.Map.t 144 144 + | Alias of t 133 145 | Leaf 134 146 | Proj of t * Item.t 135 147 | Comp_unit of string 148 148 + | Error of string 136 149 137 137 - let print fmt = 150 150 + let print fmt t = 138 151 let print_uid_opt = 139 152 Format.pp_print_option (fun fmt -> Format.fprintf fmt "<%a>" Uid.print) 140 153 in 141 154 let rec aux fmt { uid; desc } = 142 155 match desc with 143 156 | Var id -> 144 144 - Format.fprintf fmt "%a%a" Ident.print id print_uid_opt uid 157 157 + Format.fprintf fmt "%s%a" (Ident.name id) print_uid_opt uid 145 158 | Abs (id, t) -> 146 159 let rec collect_idents = function 147 160 | { uid = None; desc = Abs(id, t) } -> ··· 152 165 in 153 166 let (other_idents, body) = collect_idents t in 154 167 let pp_idents fmt idents = 168 168 + let idents_names = List.map Ident.name idents in 155 169 let pp_sep fmt () = Format.fprintf fmt ",@ " in 156 156 - Format.pp_print_list ~pp_sep Ident.print fmt idents 170 170 + Format.pp_print_list ~pp_sep Format.pp_print_string fmt idents_names 157 171 in 158 172 Format.fprintf fmt "Abs@[%a@,(@[%a,@ @[%a@]@])@]" 159 173 print_uid_opt uid pp_idents (id :: other_idents) aux body ··· 183 197 aux t 184 198 ) 185 199 in 186 186 - Format.fprintf fmt "{@[<v>%a@,%a@]}" print_uid_opt uid print_map map 200 200 + if Item.Map.is_empty map then 201 201 + Format.fprintf fmt "@[<hv>{%a}@]" print_uid_opt uid 202 202 + else 203 203 + Format.fprintf fmt "{@[<v>%a@,%a@]}" print_uid_opt uid print_map map 204 204 + | Alias t -> 205 205 + Format.fprintf fmt "Alias@[(@[<v>%a@,%a@])@]" print_uid_opt uid aux t 206 206 + | Error s -> 207 207 + Format.fprintf fmt "Error %s" s 187 208 in 188 188 - Format.fprintf fmt"@[%a@]@;" aux 209 209 + if t.approximated then 210 210 + Format.fprintf fmt "@[(approx)@ %a@]@;" aux t 211 211 + else 212 212 + Format.fprintf fmt "@[%a@]@;" aux t 213 213 + 214 214 + let rec strip_head_aliases = function 215 215 + | { desc = Alias t; _ } -> strip_head_aliases t 216 216 + | t -> t 189 217 190 218 let fresh_var ?(name="shape-var") uid = 191 219 let var = Ident.create_local name in 192 192 - var, { uid = Some uid; desc = Var var } 220 220 + var, { uid = Some uid; desc = Var var; approximated = false } 193 221 194 222 let for_unnamed_functor_param = Ident.create_local "()" 195 223 196 224 let var uid id = 197 197 - { uid = Some uid; desc = Var id } 225 225 + { uid = Some uid; desc = Var id; approximated = false } 198 226 199 227 let abs ?uid var body = 200 200 - { uid; desc = Abs (var, body) } 228 228 + { uid; desc = Abs (var, body); approximated = false } 201 229 202 230 let str ?uid map = 203 203 - { uid; desc = Struct map } 231 231 + { uid; desc = Struct map; approximated = false } 232 232 + 233 233 + let alias ?uid t = 234 234 + { uid; desc = Alias t; approximated = false} 204 235 205 236 let leaf uid = 206 206 - { uid = Some uid; desc = Leaf } 237 237 + { uid = Some uid; desc = Leaf; approximated = false } 238 238 + 239 239 + let approx t = { t with approximated = true} 207 240 208 241 let proj ?uid t item = 209 242 match t.desc with 210 243 | Leaf -> 211 244 (* When stuck projecting in a leaf we propagate the leaf 212 245 as a best effort *) 213 213 - t 246 246 + approx t 214 247 | Struct map -> 215 248 begin try Item.Map.find item map 216 216 - with Not_found -> t (* ill-typed program *) 249 249 + with Not_found -> approx t (* ill-typed program *) 217 250 end 218 251 | _ -> 219 219 - { uid; desc = Proj (t, item) } 252 252 + { uid; desc = Proj (t, item); approximated = false } 220 253 221 254 let app ?uid f ~arg = 222 222 - { uid; desc = App (f, arg) } 255 255 + { uid; desc = App (f, arg); approximated = false } 223 256 224 257 let decompose_abs t = 225 258 match t.desc with 226 259 | Abs (x, t) -> Some (x, t) 227 260 | _ -> None 228 261 229 229 - module Make_reduce(Params : sig 230 230 - type env 231 231 - val fuel : int 232 232 - val read_unit_shape : unit_name:string -> t option 233 233 - val find_shape : env -> Ident.t -> t 234 234 - end) = struct 235 235 - (* We implement a strong call-by-need reduction, following an 236 236 - evaluator from Nathanaelle Courant. *) 237 237 - 238 238 - type nf = { uid: Uid.t option; desc: nf_desc } 239 239 - and nf_desc = 240 240 - | NVar of var 241 241 - | NApp of nf * nf 242 242 - | NAbs of local_env * var * t * delayed_nf 243 243 - | NStruct of delayed_nf Item.Map.t 244 244 - | NProj of nf * Item.t 245 245 - | NLeaf 246 246 - | NComp_unit of string 247 247 - | NoFuelLeft of desc 248 248 - (* A type of normal forms for strong call-by-need evaluation. 249 249 - The normal form of an abstraction 250 250 - Abs(x, t) 251 251 - is a closure 252 252 - NAbs(env, x, t, dnf) 253 253 - when [env] is the local environment, and [dnf] is a delayed 254 254 - normal form of [t]. 255 255 - 256 256 - A "delayed normal form" is morally equivalent to (nf Lazy.t), but 257 257 - we use a different representation that is compatible with 258 258 - memoization (lazy values are not hashable/comparable by default 259 259 - comparison functions): we represent a delayed normal form as 260 260 - just a not-yet-computed pair [local_env * t] of a term in a 261 261 - local environment -- we could also see this as a term under 262 262 - an explicit substitution. This delayed thunked is "forced" 263 263 - by calling the normalization function as usual, but duplicate 264 264 - computations are precisely avoided by memoization. 265 265 - *) 266 266 - and delayed_nf = Thunk of local_env * t 267 267 - 268 268 - and local_env = delayed_nf option Ident.Map.t 269 269 - (* When reducing in the body of an abstraction [Abs(x, body)], we 270 270 - bind [x] to [None] in the environment. [Some v] is used for 271 271 - actual substitutions, for example in [App(Abs(x, body), t)], when 272 272 - [v] is a thunk that will evaluate to the normal form of [t]. *) 273 273 - 274 274 - let improve_uid uid (nf : nf) = 275 275 - match nf.uid with 276 276 - | Some _ -> nf 277 277 - | None -> { nf with uid } 278 278 - 279 279 - let in_memo_table memo_table memo_key f arg = 280 280 - match Hashtbl.find memo_table memo_key with 281 281 - | res -> res 282 282 - | exception Not_found -> 283 283 - let res = f arg in 284 284 - Hashtbl.replace memo_table memo_key res; 285 285 - res 262 262 + let dummy_mod = 263 263 + { uid = None; desc = Struct Item.Map.empty; approximated = false } 286 264 287 287 - type env = { 288 288 - fuel: int ref; 289 289 - global_env: Params.env; 290 290 - local_env: local_env; 291 291 - reduce_memo_table: (local_env * t, nf) Hashtbl.t; 292 292 - read_back_memo_table: (nf, t) Hashtbl.t; 293 293 - } 294 294 - 295 295 - let bind env var shape = 296 296 - { env with local_env = Ident.Map.add var shape env.local_env } 297 297 - 298 298 - let rec reduce_ env t = 299 299 - let memo_key = (env.local_env, t) in 300 300 - in_memo_table env.reduce_memo_table memo_key (reduce__ env) t 301 301 - (* Memoization is absolutely essential for performance on this 302 302 - problem, because the normal forms we build can in some real-world 303 303 - cases contain an exponential amount of redundancy. Memoization 304 304 - can avoid the repeated evaluation of identical subterms, 305 305 - providing a large speedup, but even more importantly it 306 306 - implicitly shares the memory of the repeated results, providing 307 307 - much smaller normal forms (that blow up again if printed back 308 308 - as trees). A functor-heavy file from Irmin has its shape normal 309 309 - form decrease from 100Mio to 2.5Mio when memoization is enabled. 310 310 - 311 311 - Note: the local environment is part of the memoization key, while 312 312 - it is defined using a type Ident.Map.t of non-canonical balanced 313 313 - trees: two maps could have exactly the same items, but be 314 314 - balanced differently and therefore hash differently, reducing 315 315 - the effectivenss of memoization. 316 316 - This could in theory happen, say, with the two programs 317 317 - (fun x -> fun y -> ...) 318 318 - and 319 319 - (fun y -> fun x -> ...) 320 320 - having "the same" local environments, with additions done in 321 321 - a different order, giving non-structurally-equal trees. Should we 322 322 - define our own hash functions to provide robust hashing on 323 323 - environments? 324 324 - 325 325 - We believe that the answer is "no": this problem does not occur 326 326 - in practice. We can assume that identifiers are unique on valid 327 327 - typedtree fragments (identifier "stamps" distinguish 328 328 - binding positions); in particular the two program fragments above 329 329 - in fact bind *distinct* identifiers x (with different stamps) and 330 330 - different identifiers y, so the environments are distinct. If two 331 331 - environments are structurally the same, they must correspond to 332 332 - the evaluation evnrionments of two sub-terms that are under 333 333 - exactly the same scope of binders. So the two environments were 334 334 - obtained by the same term traversal, adding binders in the same 335 335 - order, giving the same balanced trees: the environments have the 336 336 - same hash. 337 337 - *) 338 338 - 339 339 - and reduce__ ({fuel; global_env; local_env; _} as env) (t : t) = 340 340 - let reduce env t = reduce_ env t in 341 341 - let delay_reduce env t = Thunk (env.local_env, t) in 342 342 - let force (Thunk (local_env, t)) = 343 343 - reduce { env with local_env } t in 344 344 - let return desc : nf = { uid = t.uid; desc } in 345 345 - if !fuel < 0 then return (NoFuelLeft t.desc) 346 346 - else 347 347 - match t.desc with 348 348 - | Comp_unit unit_name -> 349 349 - begin match Params.read_unit_shape ~unit_name with 350 350 - | Some t -> reduce env t 351 351 - | None -> return (NComp_unit unit_name) 352 352 - end 353 353 - | App(f, arg) -> 354 354 - let f = reduce env f in 355 355 - begin match f.desc with 356 356 - | NAbs(clos_env, var, body, _body_nf) -> 357 357 - let arg = delay_reduce env arg in 358 358 - let env = bind { env with local_env = clos_env } var (Some arg) in 359 359 - reduce env body 360 360 - |> improve_uid t.uid 361 361 - | _ -> 362 362 - let arg = reduce env arg in 363 363 - return (NApp(f, arg)) 364 364 - end 365 365 - | Proj(str, item) -> 366 366 - let str = reduce env str in 367 367 - let nored () = return (NProj(str, item)) in 368 368 - begin match str.desc with 369 369 - | NStruct (items) -> 370 370 - begin match Item.Map.find item items with 371 371 - | exception Not_found -> nored () 372 372 - | nf -> 373 373 - force nf 374 374 - |> improve_uid t.uid 375 375 - end 376 376 - | _ -> 377 377 - nored () 378 378 - end 379 379 - | Abs(var, body) -> 380 380 - let body_nf = delay_reduce (bind env var None) body in 381 381 - return (NAbs(local_env, var, body, body_nf)) 382 382 - | Var id -> 383 383 - begin match Ident.Map.find id local_env with 384 384 - (* Note: instead of binding abstraction-bound variables to 385 385 - [None], we could unify it with the [Some v] case by 386 386 - binding the bound variable [x] to [NVar x]. 387 387 - 388 388 - One reason to distinguish the situations is that we can 389 389 - provide a different [Uid.t] location; for bound 390 390 - variables, we use the [Uid.t] of the bound occurrence 391 391 - (not the binding site), whereas for bound values we use 392 392 - their binding-time [Uid.t]. *) 393 393 - | None -> return (NVar id) 394 394 - | Some def -> force def 395 395 - | exception Not_found -> 396 396 - match Params.find_shape global_env id with 397 397 - | exception Not_found -> return (NVar id) 398 398 - | res when res = t -> return (NVar id) 399 399 - | res -> 400 400 - decr fuel; 401 401 - reduce env res 402 402 - end 403 403 - | Leaf -> return NLeaf 404 404 - | Struct m -> 405 405 - let mnf = Item.Map.map (delay_reduce env) m in 406 406 - return (NStruct mnf) 407 407 - 408 408 - let rec read_back env (nf : nf) : t = 409 409 - in_memo_table env.read_back_memo_table nf (read_back_ env) nf 410 410 - (* The [nf] normal form we receive may contain a lot of internal 411 411 - sharing due to the use of memoization in the evaluator. We have 412 412 - to memoize here again, otherwise the sharing is lost by mapping 413 413 - over the term as a tree. *) 414 414 - 415 415 - and read_back_ env (nf : nf) : t = 416 416 - { uid = nf.uid; desc = read_back_desc env nf.desc } 417 417 - 418 418 - and read_back_desc env desc = 419 419 - let read_back nf = read_back env nf in 420 420 - let read_back_force (Thunk (local_env, t)) = 421 421 - read_back (reduce_ { env with local_env } t) in 422 422 - match desc with 423 423 - | NVar v -> 424 424 - Var v 425 425 - | NApp (nft, nfu) -> 426 426 - App(read_back nft, read_back nfu) 427 427 - | NAbs (_env, x, _t, nf) -> 428 428 - Abs(x, read_back_force nf) 429 429 - | NStruct nstr -> 430 430 - Struct (Item.Map.map read_back_force nstr) 431 431 - | NProj (nf, item) -> 432 432 - Proj (read_back nf, item) 433 433 - | NLeaf -> Leaf 434 434 - | NComp_unit s -> Comp_unit s 435 435 - | NoFuelLeft t -> t 436 436 - 437 437 - let reduce global_env t = 438 438 - let fuel = ref Params.fuel in 439 439 - let reduce_memo_table = Hashtbl.create 42 in 440 440 - let read_back_memo_table = Hashtbl.create 42 in 441 441 - let local_env = Ident.Map.empty in 442 442 - let env = { 443 443 - fuel; 444 444 - global_env; 445 445 - reduce_memo_table; 446 446 - read_back_memo_table; 447 447 - local_env; 448 448 - } in 449 449 - reduce_ env t |> read_back env 450 450 - end 451 451 - 452 452 - module Local_reduce = 453 453 - (* Note: this definition with [type env = unit] is only suitable for 454 454 - reduction of toplevel shapes -- shapes of compilation units, 455 455 - where free variables are only Comp_unit names. If we wanted to 456 456 - reduce shapes inside module signatures, we would need to take 457 457 - a typing environment as parameter. *) 458 458 - Make_reduce(struct 459 459 - type env = unit 460 460 - let fuel = 10 461 461 - let read_unit_shape ~unit_name:_ = None 462 462 - let find_shape _env _id = raise Not_found 463 463 - end) 464 464 - 465 465 - let local_reduce shape = 466 466 - Local_reduce.reduce () shape 467 467 - 468 468 - let dummy_mod = { uid = None; desc = Struct Item.Map.empty } 469 469 - 470 470 - let of_path ~find_shape ~namespace = 265 265 + let of_path ~find_shape ~namespace path = 266 266 + (* We need to handle the following cases: 267 267 + Path of constructor: 268 268 + M.t.C 269 269 + Path of label: 270 270 + M.t.lbl 271 271 + Path of label of inline record: 272 272 + M.t.C.lbl *) 471 273 let rec aux : Sig_component_kind.t -> Path.t -> t = fun ns -> function 472 274 | Pident id -> find_shape ns id 473 473 - | Pdot (path, name) -> proj (aux Module path) (name, ns) 275 275 + | Pdot (path, name) -> 276 276 + let namespace : Sig_component_kind.t = 277 277 + match (ns : Sig_component_kind.t) with 278 278 + | Constructor -> Type 279 279 + | Label -> Type 280 280 + | _ -> Module 281 281 + in 282 282 + proj (aux namespace path) (name, ns) 474 283 | Papply (p1, p2) -> app (aux Module p1) ~arg:(aux Module p2) 475 284 | Pextra_ty (path, extra) -> begin 476 285 match extra with 477 477 - Pcstr_ty _ -> aux Type path 286 286 + Pcstr_ty name -> proj (aux Type path) (name, Constructor) 478 287 | Pext_ty -> aux Extension_constructor path 479 288 end 480 289 in 481 481 - aux namespace 290 290 + aux namespace path 482 291 483 292 let for_persistent_unit s = 484 293 { uid = Some (Uid.of_compilation_unit_id (Ident.create_persistent s)); 485 485 - desc = Comp_unit s } 294 294 + desc = Comp_unit s; approximated = false } 486 295 487 487 - let leaf_for_unpack = { uid = None; desc = Leaf } 296 296 + let leaf_for_unpack = { uid = None; desc = Leaf; approximated = false } 488 297 489 298 let set_uid_if_none t uid = 490 299 match t.uid with ··· 504 313 let item = Item.value id in 505 314 Item.Map.add item (proj shape item) t 506 315 507 507 - let add_type t id uid = Item.Map.add (Item.type_ id) (leaf uid) t 316 316 + let add_type t id shape = Item.Map.add (Item.type_ id) shape t 508 317 let add_type_proj t id shape = 509 318 let item = Item.type_ id in 510 319 Item.Map.add item (proj shape item) t 511 320 321 321 + let add_constr t id shape = Item.Map.add (Item.constr id) shape t 322 322 + let add_constr_proj t id shape = 323 323 + let item = Item.constr id in 324 324 + Item.Map.add item (proj shape item) t 325 325 + 326 326 + let add_label t id uid = Item.Map.add (Item.label id) (leaf uid) t 327 327 + let add_label_proj t id shape = 328 328 + let item = Item.label id in 329 329 + Item.Map.add item (proj shape item) t 330 330 + 512 331 let add_module t id shape = Item.Map.add (Item.module_ id) shape t 513 332 let add_module_proj t id shape = 514 333 let item = Item.module_ id in ··· 520 339 let item = Item.module_type id in 521 340 Item.Map.add item (proj shape item) t 522 341 523 523 - let add_extcons t id uid = 524 524 - Item.Map.add (Item.extension_constructor id) (leaf uid) t 342 342 + let add_extcons t id shape = 343 343 + Item.Map.add (Item.extension_constructor id) shape t 525 344 let add_extcons_proj t id shape = 526 345 let item = Item.extension_constructor id in 527 346 Item.Map.add item (proj shape item) t

+72 -28

typing/shape.mli

reviewed

··· 13 13 (* *) 14 14 (**************************************************************************) 15 15 16 16 + (** Shapes are an abstract representation of modules' implementations which 17 17 + allow the tracking of definitions through functor applications and other 18 18 + module-level operations. 19 19 + 20 20 + The Shape of a compilation unit is elaborated during typing, partially 21 21 + reduced (without loading external shapes) and written to the [cmt] file. 22 22 + 23 23 + External tools can retrieve the definition of any value (or type, or module, 24 24 + etc) by following this procedure: 25 25 + 26 26 + - Build the Shape corresponding to the value's path: 27 27 + [let shape = Env.shape_of_path ~namespace env path] 28 28 + 29 29 + - Instantiate the [Shape_reduce.Make] functor with a way to load shapes from 30 30 + external units and to looks for shapes in the environment (usually using 31 31 + [Env.shape_of_path]). 32 32 + 33 33 + - Completely reduce the shape: 34 34 + [let shape = My_reduce.(weak_)reduce env shape] 35 35 + 36 36 + - The [Uid.t] stored in the reduced shape should be the one of the 37 37 + definition. However, if the [approximate] field of the reduced shape is 38 38 + [true] then the [Uid.t] will not correspond to the definition, but to the 39 39 + closest parent module's uid. This happens when Shape reduction gets stuck, 40 40 + for example when hitting first-class modules. 41 41 + 42 42 + - The location of the definition can be easily found with the 43 43 + [cmt_format.cmt_uid_to_decl] table of the corresponding compilation unit. 44 44 + 45 45 + See: 46 46 + - {{: https://icfp22.sigplan.org/details/mlfamilyworkshop-2022-papers/10/Module-Shapes-for-Modern-Tooling } 47 47 + the design document} 48 48 + - {{: https://www.lix.polytechnique.fr/Labo/Gabriel.Scherer/research/shapes/2022-ml-workshop-shapes-talk.pdf } 49 49 + a talk about the reduction strategy 50 50 + *) 51 51 + 52 52 + (** A [Uid.t] is associated to every declaration in signatures and 53 53 + implementations. They uniquely identify bindings in the program. When 54 54 + associated with these bindings' locations they are useful to external tools 55 55 + when trying to jump to an identifier's declaration or definition. They are 56 56 + stored to that effect in the [uid_to_decl] table of cmt files. *) 16 57 module Uid : sig 17 58 type t = private 18 59 | Compilation_unit of string ··· 36 77 type t = 37 78 | Value 38 79 | Type 80 80 + | Constructor 81 81 + | Label 39 82 | Module 40 83 | Module_type 41 84 | Extension_constructor ··· 48 91 val can_appear_in_types : t -> bool 49 92 end 50 93 94 94 + (** Shape's items are elements of a structure or, in the case of constructors 95 95 + and labels, elements of a record or variants definition seen as a structure. 96 96 + These structures model module components and nested types' constructors and 97 97 + labels. *) 51 98 module Item : sig 52 52 - type t 99 99 + type t = string * Sig_component_kind.t 100 100 + val name : t -> string 101 101 + val kind : t -> Sig_component_kind.t 53 102 54 103 val make : string -> Sig_component_kind.t -> t 55 104 56 105 val value : Ident.t -> t 57 106 val type_ : Ident.t -> t 107 107 + val constr : Ident.t -> t 108 108 + val label : Ident.t -> t 58 109 val module_ : Ident.t -> t 59 110 val module_type : Ident.t -> t 60 111 val extension_constructor : Ident.t -> t 61 112 val class_ : Ident.t -> t 62 113 val class_type : Ident.t -> t 63 114 115 115 + val print : Format.formatter -> t -> unit 116 116 + 64 117 module Map : Map.S with type key = t 65 118 end 66 119 67 120 type var = Ident.t 68 68 - type t = { uid: Uid.t option; desc: desc } 121 121 + type t = { uid: Uid.t option; desc: desc; approximated: bool } 69 122 and desc = 70 123 | Var of var 71 124 | Abs of var * t 72 125 | App of t * t 73 126 | Struct of t Item.Map.t 127 127 + | Alias of t 74 128 | Leaf 75 129 | Proj of t * Item.t 76 130 | Comp_unit of string 131 131 + | Error of string 77 132 78 133 val print : Format.formatter -> t -> unit 79 134 135 135 + val strip_head_aliases : t -> t 136 136 + 80 137 (* Smart constructors *) 81 138 82 139 val for_unnamed_functor_param : var ··· 86 143 val abs : ?uid:Uid.t -> var -> t -> t 87 144 val app : ?uid:Uid.t -> t -> arg:t -> t 88 145 val str : ?uid:Uid.t -> t Item.Map.t -> t 146 146 + val alias : ?uid:Uid.t -> t -> t 89 147 val proj : ?uid:Uid.t -> t -> Item.t -> t 90 148 val leaf : Uid.t -> t 91 149 ··· 105 163 val add_value : t -> Ident.t -> Uid.t -> t 106 164 val add_value_proj : t -> Ident.t -> shape -> t 107 165 108 108 - val add_type : t -> Ident.t -> Uid.t -> t 166 166 + val add_type : t -> Ident.t -> shape -> t 109 167 val add_type_proj : t -> Ident.t -> shape -> t 110 168 169 169 + val add_constr : t -> Ident.t -> shape -> t 170 170 + val add_constr_proj : t -> Ident.t -> shape -> t 171 171 + 172 172 + val add_label : t -> Ident.t -> Uid.t -> t 173 173 + val add_label_proj : t -> Ident.t -> shape -> t 174 174 + 111 175 val add_module : t -> Ident.t -> shape -> t 112 176 val add_module_proj : t -> Ident.t -> shape -> t 113 177 114 178 val add_module_type : t -> Ident.t -> Uid.t -> t 115 179 val add_module_type_proj : t -> Ident.t -> shape -> t 116 180 117 117 - val add_extcons : t -> Ident.t -> Uid.t -> t 181 181 + val add_extcons : t -> Ident.t -> shape -> t 118 182 val add_extcons_proj : t -> Ident.t -> shape -> t 119 183 120 184 val add_class : t -> Ident.t -> Uid.t -> t ··· 126 190 127 191 val dummy_mod : t 128 192 193 193 + (** This function returns the shape corresponding to a given path. It requires a 194 194 + callback to find shapes in the environment. It is generally more useful to 195 195 + rely directly on the [Env.shape_of_path] function to get the shape 196 196 + associated with a given path. *) 129 197 val of_path : 130 198 find_shape:(Sig_component_kind.t -> Ident.t -> t) -> 131 199 namespace:Sig_component_kind.t -> Path.t -> t 132 200 133 201 val set_uid_if_none : t -> Uid.t -> t 134 134 - 135 135 - (** The [Make_reduce] functor is used to generate a reduction function for 136 136 - shapes. 137 137 - 138 138 - It is parametrized by: 139 139 - - an environment and a function to find shapes by path in that environment 140 140 - - a function to load the shape of an external compilation unit 141 141 - - some fuel, which is used to bound recursion when dealing with recursive 142 142 - shapes introduced by recursive modules. (FTR: merlin currently uses a 143 143 - fuel of 10, which seems to be enough for most practical examples) 144 144 - *) 145 145 - module Make_reduce(Context : sig 146 146 - type env 147 147 - 148 148 - val fuel : int 149 149 - 150 150 - val read_unit_shape : unit_name:string -> t option 151 151 - 152 152 - val find_shape : env -> Ident.t -> t 153 153 - end) : sig 154 154 - val reduce : Context.env -> t -> t 155 155 - end 156 156 - 157 157 - val local_reduce : t -> t

+347

typing/shape_reduce.ml

reviewed

··· 1 1 + (**************************************************************************) 2 2 + (* *) 3 3 + (* OCaml *) 4 4 + (* *) 5 5 + (* Ulysse Gérard, Thomas Refis, Tarides *) 6 6 + (* Nathanaëlle Courant, OCamlPro *) 7 7 + (* Gabriel Scherer, projet Picube, INRIA Paris *) 8 8 + (* *) 9 9 + (* Copyright 2021 Institut National de Recherche en Informatique et *) 10 10 + (* en Automatique. *) 11 11 + (* *) 12 12 + (* All rights reserved. This file is distributed under the terms of *) 13 13 + (* the GNU Lesser General Public License version 2.1, with the *) 14 14 + (* special exception on linking described in the file LICENSE. *) 15 15 + (* *) 16 16 + (**************************************************************************) 17 17 + 18 18 + open Shape 19 19 + 20 20 + type result = 21 21 + | Resolved of Uid.t 22 22 + | Resolved_alias of Uid.t list 23 23 + | Unresolved of t 24 24 + | Approximated of Uid.t option 25 25 + | Internal_error_missing_uid 26 26 + 27 27 + let print_result fmt result = 28 28 + match result with 29 29 + | Resolved uid -> 30 30 + Format.fprintf fmt "@[Resolved: %a@]@;" Uid.print uid 31 31 + | Resolved_alias uids -> 32 32 + Format.fprintf fmt "@[Resolved_alias: %a@]@;" 33 33 + Format.(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ -> ") 34 34 + Uid.print) uids 35 35 + | Unresolved shape -> 36 36 + Format.fprintf fmt "@[Unresolved: %a@]@;" print shape 37 37 + | Approximated (Some uid) -> 38 38 + Format.fprintf fmt "@[Approximated: %a@]@;" Uid.print uid 39 39 + | Approximated None -> 40 40 + Format.fprintf fmt "@[Approximated: No uid@]@;" 41 41 + | Internal_error_missing_uid -> 42 42 + Format.fprintf fmt "@[Missing uid@]@;" 43 43 + 44 44 + 45 45 + let find_shape env id = 46 46 + let namespace = Shape.Sig_component_kind.Module in 47 47 + Env.shape_of_path ~namespace env (Pident id) 48 48 + 49 49 + module Make(Params : sig 50 50 + val fuel : int 51 51 + val read_unit_shape : unit_name:string -> t option 52 52 + end) = struct 53 53 + (* We implement a strong call-by-need reduction, following an 54 54 + evaluator from Nathanaelle Courant. *) 55 55 + 56 56 + type nf = { uid: Uid.t option; desc: nf_desc; approximated: bool } 57 57 + and nf_desc = 58 58 + | NVar of var 59 59 + | NApp of nf * nf 60 60 + | NAbs of local_env * var * t * delayed_nf 61 61 + | NStruct of delayed_nf Item.Map.t 62 62 + | NAlias of delayed_nf 63 63 + | NProj of nf * Item.t 64 64 + | NLeaf 65 65 + | NComp_unit of string 66 66 + | NError of string 67 67 + 68 68 + (* A type of normal forms for strong call-by-need evaluation. 69 69 + The normal form of an abstraction 70 70 + Abs(x, t) 71 71 + is a closure 72 72 + NAbs(env, x, t, dnf) 73 73 + when [env] is the local environment, and [dnf] is a delayed 74 74 + normal form of [t]. 75 75 + 76 76 + A "delayed normal form" is morally equivalent to (nf Lazy.t), but 77 77 + we use a different representation that is compatible with 78 78 + memoization (lazy values are not hashable/comparable by default 79 79 + comparison functions): we represent a delayed normal form as 80 80 + just a not-yet-computed pair [local_env * t] of a term in a 81 81 + local environment -- we could also see this as a term under 82 82 + an explicit substitution. This delayed thunked is "forced" 83 83 + by calling the normalization function as usual, but duplicate 84 84 + computations are precisely avoided by memoization. 85 85 + *) 86 86 + and delayed_nf = Thunk of local_env * t 87 87 + 88 88 + and local_env = delayed_nf option Ident.Map.t 89 89 + (* When reducing in the body of an abstraction [Abs(x, body)], we 90 90 + bind [x] to [None] in the environment. [Some v] is used for 91 91 + actual substitutions, for example in [App(Abs(x, body), t)], when 92 92 + [v] is a thunk that will evaluate to the normal form of [t]. *) 93 93 + 94 94 + let approx_nf nf = { nf with approximated = true } 95 95 + 96 96 + let in_memo_table memo_table memo_key f arg = 97 97 + match Hashtbl.find memo_table memo_key with 98 98 + | res -> res 99 99 + | exception Not_found -> 100 100 + let res = f arg in 101 101 + Hashtbl.replace memo_table memo_key res; 102 102 + res 103 103 + 104 104 + type env = { 105 105 + fuel: int ref; 106 106 + global_env: Env.t; 107 107 + local_env: local_env; 108 108 + reduce_memo_table: (local_env * t, nf) Hashtbl.t; 109 109 + read_back_memo_table: (nf, t) Hashtbl.t; 110 110 + } 111 111 + 112 112 + let bind env var shape = 113 113 + { env with local_env = Ident.Map.add var shape env.local_env } 114 114 + 115 115 + let rec reduce_ env t = 116 116 + let local_env = env.local_env in 117 117 + let memo_key = (local_env, t) in 118 118 + in_memo_table env.reduce_memo_table memo_key (reduce__ env) t 119 119 + (* Memoization is absolutely essential for performance on this 120 120 + problem, because the normal forms we build can in some real-world 121 121 + cases contain an exponential amount of redundancy. Memoization 122 122 + can avoid the repeated evaluation of identical subterms, 123 123 + providing a large speedup, but even more importantly it 124 124 + implicitly shares the memory of the repeated results, providing 125 125 + much smaller normal forms (that blow up again if printed back 126 126 + as trees). A functor-heavy file from Irmin has its shape normal 127 127 + form decrease from 100Mio to 2.5Mio when memoization is enabled. 128 128 + 129 129 + Note: the local environment is part of the memoization key, while 130 130 + it is defined using a type Ident.Map.t of non-canonical balanced 131 131 + trees: two maps could have exactly the same items, but be 132 132 + balanced differently and therefore hash differently, reducing 133 133 + the effectivenss of memoization. 134 134 + This could in theory happen, say, with the two programs 135 135 + (fun x -> fun y -> ...) 136 136 + and 137 137 + (fun y -> fun x -> ...) 138 138 + having "the same" local environments, with additions done in 139 139 + a different order, giving non-structurally-equal trees. Should we 140 140 + define our own hash functions to provide robust hashing on 141 141 + environments? 142 142 + 143 143 + We believe that the answer is "no": this problem does not occur 144 144 + in practice. We can assume that identifiers are unique on valid 145 145 + typedtree fragments (identifier "stamps" distinguish 146 146 + binding positions); in particular the two program fragments above 147 147 + in fact bind *distinct* identifiers x (with different stamps) and 148 148 + different identifiers y, so the environments are distinct. If two 149 149 + environments are structurally the same, they must correspond to 150 150 + the evaluation evnrionments of two sub-terms that are under 151 151 + exactly the same scope of binders. So the two environments were 152 152 + obtained by the same term traversal, adding binders in the same 153 153 + order, giving the same balanced trees: the environments have the 154 154 + same hash. 155 155 + *) 156 156 + 157 157 + and reduce__ 158 158 + ({fuel; global_env; local_env; _} as env) (t : t) = 159 159 + let reduce env t = reduce_ env t in 160 160 + let delay_reduce env t = Thunk (env.local_env, t) in 161 161 + let force (Thunk (local_env, t)) = reduce { env with local_env } t in 162 162 + let return desc = { uid = t.uid; desc; approximated = t.approximated } in 163 163 + let rec force_aliases nf = match nf.desc with 164 164 + | NAlias delayed_nf -> 165 165 + let nf = force delayed_nf in 166 166 + force_aliases nf 167 167 + | _ -> nf 168 168 + in 169 169 + let reset_uid_if_new_binding t' = 170 170 + match t.uid with 171 171 + | None -> t' 172 172 + | Some _ as uid -> { t' with uid } 173 173 + in 174 174 + if !fuel < 0 then approx_nf (return (NError "NoFuelLeft")) 175 175 + else 176 176 + match t.desc with 177 177 + | Comp_unit unit_name -> 178 178 + begin match Params.read_unit_shape ~unit_name with 179 179 + | Some t -> reduce env t 180 180 + | None -> return (NComp_unit unit_name) 181 181 + end 182 182 + | App(f, arg) -> 183 183 + let f = reduce env f |> force_aliases in 184 184 + begin match f.desc with 185 185 + | NAbs(clos_env, var, body, _body_nf) -> 186 186 + let arg = delay_reduce env arg in 187 187 + let env = bind { env with local_env = clos_env } var (Some arg) in 188 188 + reduce env body |> reset_uid_if_new_binding 189 189 + | _ -> 190 190 + let arg = reduce env arg in 191 191 + return (NApp(f, arg)) 192 192 + end 193 193 + | Proj(str, item) -> 194 194 + let str = reduce env str |> force_aliases in 195 195 + let nored () = return (NProj(str, item)) in 196 196 + begin match str.desc with 197 197 + | NStruct (items) -> 198 198 + begin match Item.Map.find item items with 199 199 + | exception Not_found -> nored () 200 200 + | nf -> force nf |> reset_uid_if_new_binding 201 201 + end 202 202 + | _ -> 203 203 + nored () 204 204 + end 205 205 + | Abs(var, body) -> 206 206 + let body_nf = delay_reduce (bind env var None) body in 207 207 + return (NAbs(local_env, var, body, body_nf)) 208 208 + | Var id -> 209 209 + begin match Ident.Map.find id local_env with 210 210 + (* Note: instead of binding abstraction-bound variables to 211 211 + [None], we could unify it with the [Some v] case by 212 212 + binding the bound variable [x] to [NVar x]. 213 213 + 214 214 + One reason to distinguish the situations is that we can 215 215 + provide a different [Uid.t] location; for bound 216 216 + variables, we use the [Uid.t] of the bound occurrence 217 217 + (not the binding site), whereas for bound values we use 218 218 + their binding-time [Uid.t]. *) 219 219 + | None -> return (NVar id) 220 220 + | Some def -> 221 221 + begin match force def with 222 222 + | { uid = Some _; _ } as nf -> nf 223 223 + (* This var already has a binding uid *) 224 224 + | { uid = None; _ } as nf -> { nf with uid = t.uid } 225 225 + (* Set the var's binding uid *) 226 226 + end 227 227 + | exception Not_found -> 228 228 + match find_shape global_env id with 229 229 + | exception Not_found -> return (NVar id) 230 230 + | res when res = t -> return (NVar id) 231 231 + | res -> 232 232 + decr fuel; 233 233 + reduce env res 234 234 + end 235 235 + | Leaf -> return NLeaf 236 236 + | Struct m -> 237 237 + let mnf = Item.Map.map (delay_reduce env) m in 238 238 + return (NStruct mnf) 239 239 + | Alias t -> return (NAlias (delay_reduce env t)) 240 240 + | Error s -> approx_nf (return (NError s)) 241 241 + 242 242 + and read_back env (nf : nf) : t = 243 243 + in_memo_table env.read_back_memo_table nf (read_back_ env) nf 244 244 + (* The [nf] normal form we receive may contain a lot of internal 245 245 + sharing due to the use of memoization in the evaluator. We have 246 246 + to memoize here again, otherwise the sharing is lost by mapping 247 247 + over the term as a tree. *) 248 248 + 249 249 + and read_back_ env (nf : nf) : t = 250 250 + { uid = nf.uid ; 251 251 + desc = read_back_desc env nf.desc; 252 252 + approximated = nf.approximated } 253 253 + 254 254 + and read_back_desc env desc = 255 255 + let read_back nf = read_back env nf in 256 256 + let read_back_force (Thunk (local_env, t)) = 257 257 + read_back (reduce_ { env with local_env } t) in 258 258 + match desc with 259 259 + | NVar v -> 260 260 + Var v 261 261 + | NApp (nft, nfu) -> 262 262 + App(read_back nft, read_back nfu) 263 263 + | NAbs (_env, x, _t, nf) -> 264 264 + Abs(x, read_back_force nf) 265 265 + | NStruct nstr -> 266 266 + Struct (Item.Map.map read_back_force nstr) 267 267 + | NAlias nf -> Alias (read_back_force nf) 268 268 + | NProj (nf, item) -> 269 269 + Proj (read_back nf, item) 270 270 + | NLeaf -> Leaf 271 271 + | NComp_unit s -> Comp_unit s 272 272 + | NError s -> Error s 273 273 + 274 274 + (* Sharing the memo tables is safe at the level of a compilation unit since 275 275 + idents should be unique *) 276 276 + let reduce_memo_table = Local_store.s_table Hashtbl.create 42 277 277 + let read_back_memo_table = Local_store.s_table Hashtbl.create 42 278 278 + 279 279 + let reduce global_env t = 280 280 + let fuel = ref Params.fuel in 281 281 + let local_env = Ident.Map.empty in 282 282 + let env = { 283 283 + fuel; 284 284 + global_env; 285 285 + reduce_memo_table = !reduce_memo_table; 286 286 + read_back_memo_table = !read_back_memo_table; 287 287 + local_env; 288 288 + } in 289 289 + reduce_ env t |> read_back env 290 290 + 291 291 + let rec is_stuck_on_comp_unit (nf : nf) = 292 292 + match nf.desc with 293 293 + | NVar _ -> 294 294 + (* This should not happen if we only reduce closed terms *) 295 295 + false 296 296 + | NApp (nf, _) | NProj (nf, _) -> is_stuck_on_comp_unit nf 297 297 + | NStruct _ | NAbs _ -> false 298 298 + | NAlias _ -> false 299 299 + | NComp_unit _ -> true 300 300 + | NError _ -> false 301 301 + | NLeaf -> false 302 302 + 303 303 + let get_aliases_uids (t : t) = 304 304 + let rec aux acc (t : t) = match t with 305 305 + | { uid = Some uid; desc = Alias t; _ } -> aux (uid::acc) t 306 306 + | { uid = Some uid; _ } -> Resolved_alias (List.rev (uid::acc)) 307 307 + | _ -> Internal_error_missing_uid 308 308 + in 309 309 + aux [] t 310 310 + 311 311 + let reduce_for_uid global_env t = 312 312 + let fuel = ref Params.fuel in 313 313 + let local_env = Ident.Map.empty in 314 314 + let env = { 315 315 + fuel; 316 316 + global_env; 317 317 + reduce_memo_table = !reduce_memo_table; 318 318 + read_back_memo_table = !read_back_memo_table; 319 319 + local_env; 320 320 + } in 321 321 + let nf = reduce_ env t in 322 322 + if is_stuck_on_comp_unit nf then 323 323 + Unresolved (read_back env nf) 324 324 + else match nf with 325 325 + | { desc = NAlias _; approximated = false; _ } -> 326 326 + get_aliases_uids (read_back env nf) 327 327 + | { uid = Some uid; approximated = false; _ } -> 328 328 + Resolved uid 329 329 + | { uid; approximated = true; _ } -> 330 330 + Approximated uid 331 331 + | { uid = None; approximated = false; _ } -> 332 332 + (* A missing Uid after a complete reduction means the Uid was first 333 333 + missing in the shape which is a code error. Having the 334 334 + [Missing_uid] reported will allow Merlin (or another tool working 335 335 + with the index) to ask users to report the issue if it does happen. 336 336 + *) 337 337 + Internal_error_missing_uid 338 338 + end 339 339 + 340 340 + module Local_reduce = 341 341 + Make(struct 342 342 + let fuel = 10 343 343 + let read_unit_shape ~unit_name:_ = None 344 344 + end) 345 345 + 346 346 + let local_reduce = Local_reduce.reduce 347 347 + let local_reduce_for_uid = Local_reduce.reduce_for_uid

+62

typing/shape_reduce.mli

reviewed

··· 1 1 + (**************************************************************************) 2 2 + (* *) 3 3 + (* OCaml *) 4 4 + (* *) 5 5 + (* Ulysse Gérard, Thomas Refis, Tarides *) 6 6 + (* Nathanaëlle Courant, OCamlPro *) 7 7 + (* Gabriel Scherer, projet Picube, INRIA Paris *) 8 8 + (* *) 9 9 + (* Copyright 2021 Institut National de Recherche en Informatique et *) 10 10 + (* en Automatique. *) 11 11 + (* *) 12 12 + (* All rights reserved. This file is distributed under the terms of *) 13 13 + (* the GNU Lesser General Public License version 2.1, with the *) 14 14 + (* special exception on linking described in the file LICENSE. *) 15 15 + (* *) 16 16 + (**************************************************************************) 17 17 + 18 18 + (** The result of reducing a shape and looking for its uid *) 19 19 + type result = 20 20 + | Resolved of Shape.Uid.t (** Shape reduction succeeded and a uid was found *) 21 21 + | Resolved_alias of Shape.Uid.t list (** Reduction led to an alias chain *) 22 22 + | Unresolved of Shape.t (** Result still contains [Comp_unit] terms *) 23 23 + | Approximated of Shape.Uid.t option 24 24 + (** Reduction failed: it can arrive with first-clsss modules for example *) 25 25 + | Internal_error_missing_uid 26 26 + (** Reduction succeeded but no uid was found, this should never happen *) 27 27 + 28 28 + val print_result : Format.formatter -> result -> unit 29 29 + 30 30 + (** The [Make] functor is used to generate a reduction function for 31 31 + shapes. 32 32 + 33 33 + It is parametrized by: 34 34 + - a function to load the shape of an external compilation unit 35 35 + - some fuel, which is used to bound recursion when dealing with recursive 36 36 + shapes introduced by recursive modules. (FTR: merlin currently uses a 37 37 + fuel of 10, which seems to be enough for most practical examples) 38 38 + 39 39 + Usage warning: To ensure good performances, every reduction made with the 40 40 + same instance of that functor share the same ident-based memoization tables. 41 41 + Such an instance should only be used to perform reduction inside a unique 42 42 + compilation unit to prevent conflicting entries in these memoization tables. 43 43 + *) 44 44 + module Make(_ : sig 45 45 + val fuel : int 46 46 + 47 47 + val read_unit_shape : unit_name:string -> Shape.t option 48 48 + end) : sig 49 49 + val reduce : Env.t -> Shape.t -> Shape.t 50 50 + 51 51 + (** Perform weak reduction and return the head's uid if any. If reduction was 52 52 + incomplete the partially reduced shape is returned. *) 53 53 + val reduce_for_uid : Env.t -> Shape.t -> result 54 54 + end 55 55 + 56 56 + (** [local_reduce] will not reduce shapes that require loading external 57 57 + compilation units. *) 58 58 + val local_reduce : Env.t -> Shape.t -> Shape.t 59 59 + 60 60 + (** [local_reduce_for_uid] will not reduce shapes that require loading external 61 61 + compilation units. *) 62 62 + val local_reduce_for_uid : Env.t -> Shape.t -> result

+28 -8

typing/tast_iterator.ml

reviewed

··· 62 62 value_bindings: iterator -> (rec_flag * value_binding list) -> unit; 63 63 value_description: iterator -> value_description -> unit; 64 64 with_constraint: iterator -> with_constraint -> unit; 65 65 + item_declaration: iterator -> item_declaration -> unit; 65 66 } 66 67 67 68 let iter_snd f (_, y) = f y ··· 92 93 f x.ci_expr 93 94 94 95 let module_type_declaration sub x = 96 96 + sub.item_declaration sub (Module_type x); 95 97 sub.location sub x.mtd_loc; 96 98 sub.attributes sub x.mtd_attributes; 97 99 iter_loc sub x.mtd_name; 98 100 Option.iter (sub.module_type sub) x.mtd_type 99 101 100 100 - let module_declaration sub {md_loc; md_name; md_type; md_attributes; _} = 102 102 + let module_declaration sub md = 103 103 + let {md_loc; md_name; md_type; md_attributes; _} = md in 104 104 + sub.item_declaration sub (Module md); 101 105 sub.location sub md_loc; 102 106 sub.attributes sub md_attributes; 103 107 iter_loc sub md_name; 104 108 sub.module_type sub md_type 105 109 106 106 - let module_substitution sub {ms_loc; ms_name; ms_txt; ms_attributes; _} = 110 110 + let module_substitution sub ms = 111 111 + let {ms_loc; ms_name; ms_txt; ms_attributes; _} = ms in 112 112 + sub.item_declaration sub (Module_substitution ms); 107 113 sub.location sub ms_loc; 108 114 sub.attributes sub ms_attributes; 109 115 iter_loc sub ms_name; ··· 115 121 f incl_mod 116 122 117 123 let class_type_declaration sub x = 124 124 + sub.item_declaration sub (Class_type x); 118 125 class_infos sub (sub.class_type sub) x 119 126 120 127 let class_declaration sub x = 128 128 + sub.item_declaration sub (Class x); 121 129 class_infos sub (sub.class_expr sub) x 122 130 123 131 let structure_item sub {str_loc; str_desc; str_env; _} = ··· 143 151 | Tstr_attribute attr -> sub.attribute sub attr 144 152 145 153 let value_description sub x = 154 154 + sub.item_declaration sub (Value x); 146 155 sub.location sub x.val_loc; 147 156 sub.attributes sub x.val_attributes; 148 157 iter_loc sub x.val_name; 149 158 sub.typ sub x.val_desc 150 159 151 151 - let label_decl sub {ld_loc; ld_name; ld_type; ld_attributes; _} = 160 160 + let label_decl sub ({ld_loc; ld_name; ld_type; ld_attributes; _} as ld) = 161 161 + sub.item_declaration sub (Label ld); 152 162 sub.location sub ld_loc; 153 163 sub.attributes sub ld_attributes; 154 164 iter_loc sub ld_name; ··· 159 169 | Cstr_record l -> List.iter (label_decl sub) l 160 170 161 171 let constructor_decl sub x = 172 172 + sub.item_declaration sub (Constructor x); 162 173 sub.location sub x.cd_loc; 163 174 sub.attributes sub x.cd_attributes; 164 175 iter_loc sub x.cd_name; ··· 173 184 | Ttype_open -> () 174 185 175 186 let type_declaration sub x = 187 187 + sub.item_declaration sub (Type x); 176 188 sub.location sub x.typ_loc; 177 189 sub.attributes sub x.typ_attributes; 178 190 iter_loc sub x.typ_name; ··· 200 212 sub.attributes sub tyexn_attributes; 201 213 sub.extension_constructor sub tyexn_constructor 202 214 203 203 - let extension_constructor sub {ext_loc; ext_name; ext_kind; ext_attributes; _} = 215 215 + let extension_constructor sub ec = 216 216 + let {ext_loc; ext_name; ext_kind; ext_attributes; _} = ec in 217 217 + sub.item_declaration sub (Extension_constructor ec); 204 218 sub.location sub ext_loc; 205 219 sub.attributes sub ext_attributes; 206 220 iter_loc sub ext_name; ··· 229 243 List.iter (pat_extra sub) extra; 230 244 match pat_desc with 231 245 | Tpat_any -> () 232 232 - | Tpat_var (_, s) -> iter_loc sub s 246 246 + | Tpat_var (_, s, _) -> iter_loc sub s 233 247 | Tpat_constant _ -> () 234 248 | Tpat_tuple l -> List.iter (sub.pat sub) l 235 249 | Tpat_construct (lid, _, l, vto) -> ··· 241 255 | Tpat_record (l, _) -> 242 256 List.iter (fun (lid, _, i) -> iter_loc sub lid; sub.pat sub i) l 243 257 | Tpat_array l -> List.iter (sub.pat sub) l 244 244 - | Tpat_alias (p, _, s) -> sub.pat sub p; iter_loc sub s 258 258 + | Tpat_alias (p, _, s, _) -> sub.pat sub p; iter_loc sub s 245 259 | Tpat_lazy p -> sub.pat sub p 246 260 | Tpat_value p -> sub.pat sub (p :> pattern) 247 261 | Tpat_exception p -> sub.pat sub p ··· 399 413 | Tsig_attribute _ -> () 400 414 401 415 let class_description sub x = 416 416 + sub.item_declaration sub (Class_type x); 402 417 class_infos sub (sub.class_type sub) x 403 418 404 419 let functor_parameter sub = function ··· 483 498 sub.module_coercion sub c 484 499 | Tmod_unpack (exp, _) -> sub.expr sub exp 485 500 486 486 - let module_binding sub {mb_loc; mb_name; mb_expr; mb_attributes; _} = 501 501 + let module_binding sub ({mb_loc; mb_name; mb_expr; mb_attributes; _} as mb) = 502 502 + sub.item_declaration sub (Module_binding mb); 487 503 sub.location sub mb_loc; 488 504 sub.attributes sub mb_attributes; 489 505 iter_loc sub mb_name; ··· 616 632 Option.iter (sub.expr sub) c_guard; 617 633 sub.expr sub c_rhs 618 634 619 619 - let value_binding sub {vb_loc; vb_pat; vb_expr; vb_attributes; _} = 635 635 + let value_binding sub ({vb_loc; vb_pat; vb_expr; vb_attributes; _} as vb) = 636 636 + sub.item_declaration sub (Value_binding vb); 620 637 sub.location sub vb_loc; 621 638 sub.attributes sub vb_attributes; 622 639 sub.pat sub vb_pat; 623 640 sub.expr sub vb_expr 624 641 625 642 let env _sub _ = () 643 643 + 644 644 + let item_declaration _sub _ = () 626 645 627 646 let default_iterator = 628 647 { ··· 670 689 value_bindings; 671 690 value_description; 672 691 with_constraint; 692 692 + item_declaration; 673 693 }

+1

typing/tast_iterator.mli

reviewed

··· 66 66 value_bindings: iterator -> (rec_flag * value_binding list) -> unit; 67 67 value_description: iterator -> value_description -> unit; 68 68 with_constraint: iterator -> with_constraint -> unit; 69 69 + item_declaration: iterator -> item_declaration -> unit; 69 70 } 70 71 71 72 val default_iterator: iterator

+3 -2

typing/tast_mapper.ml

reviewed

··· 279 279 match x.pat_desc with 280 280 | Tpat_any 281 281 | Tpat_constant _ -> x.pat_desc 282 282 - | Tpat_var (id, s) -> Tpat_var (id, map_loc sub s) 282 282 + | Tpat_var (id, s, uid) -> Tpat_var (id, map_loc sub s, uid) 283 283 | Tpat_tuple l -> Tpat_tuple (List.map (sub.pat sub) l) 284 284 | Tpat_construct (loc, cd, l, vto) -> 285 285 let vto = Option.map (fun (vl,cty) -> ··· 290 290 | Tpat_record (l, closed) -> 291 291 Tpat_record (List.map (tuple3 (map_loc sub) id (sub.pat sub)) l, closed) 292 292 | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l) 293 293 - | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, map_loc sub s) 293 293 + | Tpat_alias (p, id, s, uid) -> 294 294 + Tpat_alias (sub.pat sub p, id, map_loc sub s, uid) 294 295 | Tpat_lazy p -> Tpat_lazy (sub.pat sub p) 295 296 | Tpat_value p -> 296 297 (as_computation_pattern (sub.pat sub (p :> pattern))).pat_desc

+1 -1

typing/typeclass.ml

reviewed

··· 1309 1309 Typecore.type_let In_class_def val_env rec_flag sdefs in 1310 1310 let (vals, met_env) = 1311 1311 List.fold_right 1312 1312 - (fun (id, _id_loc, _typ) (vals, met_env) -> 1312 1312 + (fun (id, _id_loc, _typ, _uid) (vals, met_env) -> 1313 1313 let path = Pident id in 1314 1314 (* do not mark the value as used *) 1315 1315 let vd = Env.find_value path val_env in

+30 -22

typing/typecore.ml

reviewed

··· 476 476 pv_loc: Location.t; 477 477 pv_as_var: bool; 478 478 pv_attributes: attributes; 479 479 + pv_uid : Uid.t; 479 480 } 480 481 481 482 type module_variable = ··· 595 596 end else 596 597 Ident.create_local name.txt 597 598 in 599 599 + let pv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in 598 600 tps.tps_pattern_variables <- 599 601 {pv_id = id; 600 602 pv_type = ty; 601 603 pv_loc = loc; 602 604 pv_as_var = is_as_variable; 603 603 - pv_attributes = attrs} :: tps.tps_pattern_variables; 604 604 - id 605 605 + pv_attributes = attrs; 606 606 + pv_uid} :: tps.tps_pattern_variables; 607 607 + id, pv_uid 605 608 606 609 let sort_pattern_variables vs = 607 610 List.sort ··· 671 674 672 675 and build_as_type_aux (env : Env.t) p = 673 676 match p.pat_desc with 674 674 - Tpat_alias(p1,_, _) -> build_as_type env p1 677 677 + Tpat_alias(p1,_, _, _) -> build_as_type env p1 675 678 | Tpat_tuple pl -> 676 679 let tyl = List.map (build_as_type env) pl in 677 680 newty (Ttuple tyl) ··· 1641 1644 pat_env = !!penv } 1642 1645 | Ppat_var name -> 1643 1646 let ty = instance expected_ty in 1644 1644 - let id = enter_variable tps loc name ty sp.ppat_attributes in 1647 1647 + let id, uid = enter_variable tps loc name ty sp.ppat_attributes in 1645 1648 rvp { 1646 1646 - pat_desc = Tpat_var (id, name); 1649 1649 + pat_desc = Tpat_var (id, name, uid); 1647 1650 pat_loc = loc; pat_extra=[]; 1648 1651 pat_type = ty; 1649 1652 pat_attributes = sp.ppat_attributes; ··· 1664 1667 (* We're able to pass ~is_module:true here without an error because 1665 1668 [Ppat_unpack] is a case identified by [may_contain_modules]. See 1666 1669 the comment on [may_contain_modules]. *) 1667 1667 - let id = 1670 1670 + let id, uid = 1668 1671 enter_variable tps loc v t ~is_module:true sp.ppat_attributes 1669 1672 in 1670 1673 rvp { 1671 1671 - pat_desc = Tpat_var (id, v); 1674 1674 + pat_desc = Tpat_var (id, v, uid); 1672 1675 pat_loc = sp.ppat_loc; 1673 1676 pat_extra=[Tpat_unpack, loc, sp.ppat_attributes]; 1674 1677 pat_type = t; ··· 1681 1684 (* explicitly polymorphic type *) 1682 1685 let cty, ty, ty' = 1683 1686 solve_Ppat_poly_constraint tps !!penv lloc sty expected_ty in 1684 1684 - let id = enter_variable tps lloc name ty' attrs in 1685 1685 - rvp { pat_desc = Tpat_var (id, name); 1687 1687 + let id, uid = enter_variable tps lloc name ty' attrs in 1688 1688 + rvp { pat_desc = Tpat_var (id, name, uid); 1686 1689 pat_loc = lloc; 1687 1690 pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes]; 1688 1691 pat_type = ty; ··· 1691 1694 | Ppat_alias(sq, name) -> 1692 1695 let q = type_pat tps Value sq expected_ty in 1693 1696 let ty_var = solve_Ppat_alias !!penv q in 1694 1694 - let id = 1697 1697 + let id, uid = 1695 1698 enter_variable 1696 1699 ~is_as_variable:true tps name.loc name ty_var sp.ppat_attributes 1697 1700 in 1698 1698 - rvp { pat_desc = Tpat_alias(q, id, name); 1701 1701 + rvp { pat_desc = Tpat_alias(q, id, name, uid); 1699 1702 pat_loc = loc; pat_extra=[]; 1700 1703 pat_type = q.pat_type; 1701 1704 pat_attributes = sp.ppat_attributes; ··· 1956 1959 let p = type_pat tps category sp expected_ty' in 1957 1960 let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in 1958 1961 begin match category, (p : k general_pattern) with 1959 1959 - | Value, {pat_desc = Tpat_var (id,s); _} -> 1962 1962 + | Value, {pat_desc = Tpat_var (id,s,uid); _} -> 1960 1963 { p with 1961 1964 pat_type = ty; 1962 1965 pat_desc = 1963 1966 Tpat_alias 1964 1964 - ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s); 1967 1967 + ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s, uid); 1965 1968 pat_extra = [extra]; 1966 1969 } 1967 1970 | _, p -> ··· 2002 2005 2003 2006 let add_pattern_variables ?check ?check_as env pv = 2004 2007 List.fold_right 2005 2005 - (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} env -> 2008 2008 + (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes; pv_uid} env -> 2006 2009 let check = if pv_as_var then check_as else check in 2007 2010 Env.add_value ?check pv_id 2008 2011 {val_type = pv_type; val_kind = Val_reg; Types.val_loc = pv_loc; 2009 2012 val_attributes = pv_attributes; 2010 2010 - val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); 2013 2013 + val_uid = pv_uid; 2011 2014 } env 2012 2015 ) 2013 2016 pv env ··· 2339 2342 in 2340 2343 check_rec ~info:(decrease 5) tp expected_ty k 2341 2344 end 2342 2342 - | Tpat_alias (p, _, _) -> check_rec ~info p expected_ty k 2345 2345 + | Tpat_alias (p, _, _, _) -> check_rec ~info p expected_ty k 2343 2346 | Tpat_constant cst -> 2344 2347 let cst = constant_or_raise !!penv loc (Untypeast.constant cst) in 2345 2348 k @@ solve_expected (mp (Tpat_constant cst) ~pat_type:(type_constant cst)) ··· 3093 3096 [] -> Ident.create_local default 3094 3097 | p :: rem -> 3095 3098 match p.pat_desc with 3096 3096 - Tpat_var (id, _) -> id 3097 3097 - | Tpat_alias(_, id, _) -> id 3099 3099 + Tpat_var (id, _, _) -> id 3100 3100 + | Tpat_alias(_, id, _, _) -> id 3098 3101 | _ -> name_pattern default rem 3099 3102 3100 3103 let name_cases default lst = ··· 4005 4008 | _ -> Mp_present 4006 4009 in 4007 4010 let scope = create_scope () in 4011 4011 + let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in 4012 4012 + let md_shape = Shape.set_uid_if_none md_shape md_uid in 4008 4013 let md = 4009 4014 { md_type = modl.mod_type; md_attributes = []; 4010 4015 md_loc = name.loc; 4011 4011 - md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } 4016 4016 + md_uid; } 4012 4017 in 4013 4018 let (id, new_env) = 4014 4019 match name.txt with ··· 4044 4049 exp_attributes = sexp.pexp_attributes; 4045 4050 exp_env = env } 4046 4051 | Pexp_letexception(cd, sbody) -> 4047 4047 - let (cd, newenv) = Typedecl.transl_exception env cd in 4052 4052 + let (cd, newenv, _shape) = Typedecl.transl_exception env cd in 4048 4053 let body = type_expect newenv sbody ty_expected_explained in 4049 4054 re { 4050 4055 exp_desc = Texp_letexception(cd, body); ··· 5181 5186 } 5182 5187 in 5183 5188 let exp_env = Env.add_value id desc env in 5184 5184 - {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[]; 5189 5189 + {pat_desc = 5190 5190 + Tpat_var (id, mknoloc name, desc.val_uid); 5191 5191 + pat_type = ty; 5192 5192 + pat_extra=[]; 5185 5193 pat_attributes = []; 5186 5194 pat_loc = Location.none; pat_env = env}, 5187 5195 {exp_type = ty; exp_loc = Location.none; exp_env = exp_env; ··· 6040 6048 List.iter 6041 6049 (fun {vb_pat=pat} -> match pat.pat_desc with 6042 6050 Tpat_var _ -> () 6043 6043 - | Tpat_alias ({pat_desc=Tpat_any}, _, _) -> () 6051 6051 + | Tpat_alias ({pat_desc=Tpat_any}, _, _, _) -> () 6044 6052 | _ -> raise(Error(pat.pat_loc, env, Illegal_letrec_pat))) 6045 6053 l; 6046 6054 List.iter (fun vb ->

+1

typing/typecore.mli

reviewed

··· 56 56 pv_loc: Location.t; 57 57 pv_as_var: bool; 58 58 pv_attributes: Typedtree.attributes; 59 59 + pv_uid : Uid.t; 59 60 } 60 61 61 62 val mk_expected:

+94 -44

typing/typedecl.ml

reviewed

··· 91 91 92 92 (* Enter all declared types in the environment as abstract types *) 93 93 94 94 - let add_type ~check id decl env = 94 94 + let add_type ~check ?shape id decl env = 95 95 Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes 96 96 - (fun () -> Env.add_type ~check id decl env) 96 96 + (fun () -> Env.add_type ~check ?shape id decl env) 97 97 98 98 (* Add a dummy type declaration to the environment, with the given arity. 99 99 The [type_kind] is [Type_abstract], but there is a generic [type_manifest] ··· 230 230 let arg = Ast_helper.Typ.force_poly arg in 231 231 let cty = transl_simple_type env ?univars ~closed arg in 232 232 {ld_id = Ident.create_local name.txt; 233 233 - ld_name = name; ld_mutable = mut; 233 233 + ld_name = name; 234 234 + ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); 235 235 + ld_mutable = mut; 234 236 ld_type = cty; ld_loc = loc; ld_attributes = attrs} 235 237 ) 236 238 in ··· 245 247 ld_type = ty; 246 248 ld_loc = ld.ld_loc; 247 249 ld_attributes = ld.ld_attributes; 248 248 - ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); 250 250 + ld_uid = ld.ld_uid; 249 251 } 250 252 ) 251 253 lbls in ··· 316 318 targs, Some tret_type, args, Some ret_type 317 319 end 318 320 321 321 + 322 322 + let shape_map_labels = 323 323 + List.fold_left (fun map { ld_id; ld_uid; _} -> 324 324 + Shape.Map.add_label map ld_id ld_uid) 325 325 + Shape.Map.empty 326 326 + 327 327 + let shape_map_cstrs = 328 328 + List.fold_left (fun map { cd_id; cd_uid; cd_args; _ } -> 329 329 + let cstr_shape_map = 330 330 + let label_decls = 331 331 + match cd_args with 332 332 + | Cstr_tuple _ -> [] 333 333 + | Cstr_record ldecls -> ldecls 334 334 + in 335 335 + shape_map_labels label_decls 336 336 + in 337 337 + Shape.Map.add_constr map cd_id 338 338 + @@ Shape.str ~uid:cd_uid cstr_shape_map) 339 339 + (Shape.Map.empty) 340 340 + 341 341 + 319 342 let transl_declaration env sdecl (id, uid) = 320 343 (* Bind type parameters *) 321 344 Ctype.with_local_level begin fun () -> ··· 402 425 let tcstr = 403 426 { cd_id = name; 404 427 cd_name = scstr.pcd_name; 428 428 + cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); 405 429 cd_vars = scstr.pcd_vars; 406 430 cd_args = targs; 407 431 cd_res = tret_type; ··· 414 438 cd_res = ret_type; 415 439 cd_loc = scstr.pcd_loc; 416 440 cd_attributes = scstr.pcd_attributes; 417 417 - cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } 441 441 + cd_uid = tcstr.cd_uid } 418 442 in 419 443 tcstr, cstr 420 444 in ··· 478 502 in 479 503 set_private_row env sdecl.ptype_loc p decl 480 504 end; 481 481 - { 482 482 - typ_id = id; 483 483 - typ_name = sdecl.ptype_name; 484 484 - typ_params = tparams; 485 485 - typ_type = decl; 486 486 - typ_cstrs = cstrs; 487 487 - typ_loc = sdecl.ptype_loc; 488 488 - typ_manifest = tman; 489 489 - typ_kind = tkind; 490 490 - typ_private = sdecl.ptype_private; 491 491 - typ_attributes = sdecl.ptype_attributes; 492 492 - } 505 505 + let decl = 506 506 + { 507 507 + typ_id = id; 508 508 + typ_name = sdecl.ptype_name; 509 509 + typ_params = tparams; 510 510 + typ_type = decl; 511 511 + typ_cstrs = cstrs; 512 512 + typ_loc = sdecl.ptype_loc; 513 513 + typ_manifest = tman; 514 514 + typ_kind = tkind; 515 515 + typ_private = sdecl.ptype_private; 516 516 + typ_attributes = sdecl.ptype_attributes; 517 517 + } 518 518 + in 519 519 + let typ_shape = 520 520 + let uid = decl.typ_type.type_uid in 521 521 + match decl.typ_kind with 522 522 + | Ttype_variant cstrs -> Shape.str ~uid (shape_map_cstrs cstrs) 523 523 + | Ttype_record labels -> Shape.str ~uid (shape_map_labels labels) 524 524 + | Ttype_abstract | Ttype_open -> Shape.leaf uid 525 525 + in 526 526 + decl, typ_shape 493 527 end 494 528 495 529 (* Generalize a type declaration *) ··· 1035 1069 | _ -> 1036 1070 () 1037 1071 1038 1038 - let add_types_to_env decls env = 1039 1039 - List.fold_right 1040 1040 - (fun (id, decl) env -> add_type ~check:true id decl env) 1041 1041 - decls env 1072 1072 + let add_types_to_env decls shapes env = 1073 1073 + List.fold_right2 1074 1074 + (fun (id, decl) shape env -> 1075 1075 + add_type ~check:true ~shape id decl env) 1076 1076 + decls shapes env 1042 1077 1043 1078 (* Translate a set of type declarations, mutually recursive or not *) 1044 1079 let transl_type_decl env rec_flag sdecl_list = ··· 1072 1107 (* Translate declarations, using a temporary environment where abbreviations 1073 1108 expand to a generic type variable. After that, we check the coherence of 1074 1109 the translated declarations in the resulting new environment. *) 1075 1075 - let tdecls, decls, new_env = 1110 1110 + let tdecls, decls, shapes, new_env = 1076 1111 Ctype.with_local_level_iter ~post:generalize_decl begin fun () -> 1077 1112 (* Enter types. *) 1078 1113 let temp_env = ··· 1109 1144 in 1110 1145 let tdecls = 1111 1146 List.map2 transl_declaration sdecl_list (List.map ids_slots ids_list) in 1112 1112 - let decls = 1113 1113 - List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in 1147 1147 + let decls, shapes = 1148 1148 + List.map (fun (tdecl, shape) -> 1149 1149 + (tdecl.typ_id, tdecl.typ_type), shape) tdecls 1150 1150 + |> List.split 1151 1151 + in 1114 1152 current_slot := None; 1115 1153 (* Check for duplicates *) 1116 1154 check_duplicates sdecl_list; 1117 1155 (* Build the final env. *) 1118 1118 - let new_env = add_types_to_env decls env in 1119 1119 - ((tdecls, decls, new_env), List.map snd decls) 1156 1156 + let new_env = add_types_to_env decls shapes env in 1157 1157 + ((tdecls, decls, shapes, new_env), List.map snd decls) 1120 1158 end 1121 1159 in 1122 1160 (* Check for ill-formed abbrevs *) ··· 1143 1181 (Path.Pident id) 1144 1182 decl to_check) 1145 1183 decls; 1146 1146 - List.iter 1147 1147 - (check_abbrev_regularity ~abs_env new_env id_loc_list to_check) 1184 1184 + List.iter (fun (tdecl, _shape) -> 1185 1185 + check_abbrev_regularity ~abs_env new_env id_loc_list to_check tdecl) 1148 1186 tdecls; 1149 1187 (* Check that all type variables are closed *) 1150 1188 List.iter2 1151 1151 - (fun sdecl tdecl -> 1189 1189 + (fun sdecl (tdecl, _shape) -> 1152 1190 let decl = tdecl.typ_type in 1153 1191 match Ctype.closed_type_decl decl with 1154 1192 Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl))) ··· 1173 1211 raise (Error (loc, Separability err)) 1174 1212 in 1175 1213 (* Compute the final environment with variance and immediacy *) 1176 1176 - let final_env = add_types_to_env decls env in 1214 1214 + let final_env = add_types_to_env decls shapes env in 1177 1215 (* Check re-exportation *) 1178 1216 List.iter2 (check_abbrev final_env) sdecl_list decls; 1179 1217 (* Keep original declaration *) 1180 1218 let final_decls = 1181 1219 List.map2 1182 1182 - (fun tdecl (_id2, decl) -> 1220 1220 + (fun (tdecl, _shape) (_id2, decl) -> 1183 1221 { tdecl with typ_type = decl } 1184 1222 ) tdecls decls 1185 1223 in 1186 1224 (* Done *) 1187 1187 - (final_decls, final_env) 1225 1225 + (final_decls, final_env, shapes) 1188 1226 1189 1227 (* Translating type extensions *) 1190 1228 ··· 1295 1333 ext_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); 1296 1334 } 1297 1335 in 1336 1336 + let ext_cstrs = 1298 1337 { ext_id = id; 1299 1338 ext_name = sext.pext_name; 1300 1339 ext_type = ext; 1301 1340 ext_kind = kind; 1302 1341 Typedtree.ext_loc = sext.pext_loc; 1303 1342 Typedtree.ext_attributes = sext.pext_attributes; } 1343 1343 + in 1344 1344 + let shape = 1345 1345 + let map = match ext_cstrs.ext_kind with 1346 1346 + | Text_decl (_, Cstr_record lbls, _) -> shape_map_labels lbls 1347 1347 + | _ -> Shape.Map.empty 1348 1348 + in 1349 1349 + Shape.str ~uid:ext_cstrs.ext_type.ext_uid map 1350 1350 + in 1351 1351 + ext_cstrs, shape 1304 1352 1305 1353 let transl_extension_constructor ~scope env type_path type_params 1306 1354 typext_params priv sext = ··· 1380 1428 (* Generalize types *) 1381 1429 List.iter Ctype.generalize type_params; 1382 1430 List.iter 1383 1383 - (fun ext -> 1431 1431 + (fun (ext, _shape) -> 1384 1432 Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; 1385 1433 Option.iter Ctype.generalize ext.ext_type.ext_ret_type) 1386 1434 constructors; ··· 1388 1436 in 1389 1437 (* Check that all type variables are closed *) 1390 1438 List.iter 1391 1391 - (fun ext -> 1439 1439 + (fun (ext, _shape) -> 1392 1440 match Ctype.closed_extension_constructor ext.ext_type with 1393 1441 Some ty -> 1394 1442 raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type))) ··· 1396 1444 constructors; 1397 1445 (* Check variances are correct *) 1398 1446 List.iter 1399 1399 - (fun ext-> 1447 1447 + (fun (ext, _shape) -> 1400 1448 (* Note that [loc] here is distinct from [type_decl.type_loc], which 1401 1449 makes the [loc] parameter to this function useful. [loc] is the 1402 1450 location of the extension, while [type_decl] points to the original ··· 1409 1457 (* Add extension constructors to the environment *) 1410 1458 let newenv = 1411 1459 List.fold_left 1412 1412 - (fun env ext -> 1460 1460 + (fun env (ext, shape) -> 1413 1461 let rebind = is_rebind ext in 1414 1414 - Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env) 1462 1462 + Env.add_extension ~check:true ~shape ~rebind 1463 1463 + ext.ext_id ext.ext_type env) 1415 1464 env constructors 1416 1465 in 1466 1466 + let constructors, shapes = List.split constructors in 1417 1467 let tyext = 1418 1468 { tyext_path = type_path; 1419 1469 tyext_txt = styext.ptyext_path; ··· 1423 1473 tyext_loc = styext.ptyext_loc; 1424 1474 tyext_attributes = styext.ptyext_attributes; } 1425 1475 in 1426 1426 - (tyext, newenv) 1476 1476 + (tyext, newenv, shapes) 1427 1477 1428 1478 let transl_type_extension extend env loc styext = 1429 1479 Builtin_attributes.warning_scope styext.ptyext_attributes 1430 1480 (fun () -> transl_type_extension extend env loc styext) 1431 1481 1432 1482 let transl_exception env sext = 1433 1433 - let ext = 1483 1483 + let ext, shape = 1434 1484 let scope = Ctype.create_scope () in 1435 1485 Ctype.with_local_level 1436 1486 (fun () -> 1437 1487 TyVarEnv.reset(); 1438 1488 transl_extension_constructor ~scope env 1439 1489 Predef.path_exn [] [] Asttypes.Public sext) 1440 1440 - ~post: begin fun ext -> 1490 1490 + ~post: begin fun (ext, _shape) -> 1441 1491 Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; 1442 1492 Option.iter Ctype.generalize ext.ext_type.ext_ret_type; 1443 1493 end ··· 1450 1500 end; 1451 1501 let rebind = is_rebind ext in 1452 1502 let newenv = 1453 1453 - Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env 1503 1503 + Env.add_extension ~check:true ~shape ~rebind ext.ext_id ext.ext_type env 1454 1504 in 1455 1455 - ext, newenv 1505 1505 + ext, newenv, shape 1456 1506 1457 1507 let transl_type_exception env t = 1458 1458 - let contructor, newenv = 1508 1508 + let contructor, newenv, shape = 1459 1509 Builtin_attributes.warning_scope t.ptyexn_attributes 1460 1510 (fun () -> 1461 1511 transl_exception env t.ptyexn_constructor ··· 1463 1513 in 1464 1514 {tyexn_constructor = contructor; 1465 1515 tyexn_loc = t.ptyexn_loc; 1466 1466 - tyexn_attributes = t.ptyexn_attributes}, newenv 1516 1516 + tyexn_attributes = t.ptyexn_attributes}, newenv, shape 1467 1517 1468 1518 1469 1519 type native_repr_attribute =

+4 -4

typing/typedecl.mli

reviewed

··· 20 20 21 21 val transl_type_decl: 22 22 Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list -> 23 23 - Typedtree.type_declaration list * Env.t 23 23 + Typedtree.type_declaration list * Env.t * Shape.t list 24 24 25 25 val transl_exception: 26 26 Env.t -> Parsetree.extension_constructor -> 27 27 - Typedtree.extension_constructor * Env.t 27 27 + Typedtree.extension_constructor * Env.t * Shape.t 28 28 29 29 val transl_type_exception: 30 30 Env.t -> 31 31 - Parsetree.type_exception -> Typedtree.type_exception * Env.t 31 31 + Parsetree.type_exception -> Typedtree.type_exception * Env.t * Shape.t 32 32 33 33 val transl_type_extension: 34 34 bool -> Env.t -> Location.t -> Parsetree.type_extension -> 35 35 - Typedtree.type_extension * Env.t 35 35 + Typedtree.type_extension * Env.t * Shape.t list 36 36 37 37 val transl_value_decl: 38 38 Env.t -> Location.t ->

+35 -14

typing/typedtree.ml

reviewed

··· 18 18 open Asttypes 19 19 open Types 20 20 21 21 + module Uid = Shape.Uid 22 22 + 21 23 (* Value expressions for the core language *) 22 24 23 25 type partial = Partial | Total ··· 53 55 and 'k pattern_desc = 54 56 (* value patterns *) 55 57 | Tpat_any : value pattern_desc 56 56 - | Tpat_var : Ident.t * string loc -> value pattern_desc 58 58 + | Tpat_var : Ident.t * string loc * Uid.t -> value pattern_desc 57 59 | Tpat_alias : 58 58 - value general_pattern * Ident.t * string loc -> value pattern_desc 60 60 + value general_pattern * Ident.t * string loc * Uid.t -> value pattern_desc 59 61 | Tpat_constant : constant -> value pattern_desc 60 62 | Tpat_tuple : value general_pattern list -> value pattern_desc 61 63 | Tpat_construct : ··· 313 315 { 314 316 mb_id: Ident.t option; 315 317 mb_name: string option loc; 318 318 + mb_uid: Uid.t; 316 319 mb_presence: module_presence; 317 320 mb_expr: module_expr; 318 321 mb_attributes: attribute list; ··· 393 396 { 394 397 md_id: Ident.t option; 395 398 md_name: string option loc; 399 399 + md_uid: Uid.t; 396 400 md_presence: module_presence; 397 401 md_type: module_type; 398 402 md_attributes: attribute list; ··· 403 407 { 404 408 ms_id: Ident.t; 405 409 ms_name: string loc; 410 410 + ms_uid: Uid.t; 406 411 ms_manifest: Path.t; 407 412 ms_txt: Longident.t loc; 408 413 ms_attributes: attributes; ··· 413 418 { 414 419 mtd_id: Ident.t; 415 420 mtd_name: string loc; 421 421 + mtd_uid: Uid.t; 416 422 mtd_type: module_type option; 417 423 mtd_attributes: attribute list; 418 424 mtd_loc: Location.t; ··· 536 542 { 537 543 ld_id: Ident.t; 538 544 ld_name: string loc; 545 545 + ld_uid: Uid.t; 539 546 ld_mutable: mutable_flag; 540 547 ld_type: core_type; 541 548 ld_loc: Location.t; ··· 546 553 { 547 554 cd_id: Ident.t; 548 555 cd_name: string loc; 556 556 + cd_uid: Uid.t; 549 557 cd_vars: string loc list; 550 558 cd_args: constructor_arguments; 551 559 cd_res: core_type option; ··· 653 661 shape: Shape.t; 654 662 } 655 663 664 664 + type item_declaration = 665 665 + | Value of value_description 666 666 + | Value_binding of value_binding 667 667 + | Type of type_declaration 668 668 + | Constructor of constructor_declaration 669 669 + | Extension_constructor of extension_constructor 670 670 + | Label of label_declaration 671 671 + | Module of module_declaration 672 672 + | Module_substitution of module_substitution 673 673 + | Module_binding of module_binding 674 674 + | Module_type of module_type_declaration 675 675 + | Class of class_declaration 676 676 + | Class_type of class_type_declaration 656 677 657 678 (* Auxiliary functions over the a.s.t. *) 658 679 ··· 698 719 let shallow_iter_pattern_desc 699 720 : type k . pattern_action -> k pattern_desc -> unit 700 721 = fun f -> function 701 701 - | Tpat_alias(p, _, _) -> f.f p 722 722 + | Tpat_alias(p, _, _, _) -> f.f p 702 723 | Tpat_tuple patl -> List.iter f.f patl 703 724 | Tpat_construct(_, _, patl, _) -> List.iter f.f patl 704 725 | Tpat_variant(_, pat, _) -> Option.iter f.f pat ··· 718 739 let shallow_map_pattern_desc 719 740 : type k . pattern_transformation -> k pattern_desc -> k pattern_desc 720 741 = fun f d -> match d with 721 721 - | Tpat_alias (p1, id, s) -> 722 722 - Tpat_alias (f.f p1, id, s) 742 742 + | Tpat_alias (p1, id, s, uid) -> 743 743 + Tpat_alias (f.f p1, id, s, uid) 723 744 | Tpat_tuple pats -> 724 745 Tpat_tuple (List.map f.f pats) 725 746 | Tpat_record (lpats, closed) -> ··· 780 801 : type k . _ -> k general_pattern -> _ 781 802 = fun f pat -> 782 803 match pat.pat_desc with 783 783 - | Tpat_var (id,s) -> 784 784 - f (id,s,pat.pat_type) 785 785 - | Tpat_alias(p, id, s) -> 804 804 + | Tpat_var (id, s, uid) -> 805 805 + f (id,s,pat.pat_type, uid) 806 806 + | Tpat_alias(p, id, s, uid) -> 786 807 iter_bound_idents f p; 787 787 - f (id,s,pat.pat_type) 808 808 + f (id,s,pat.pat_type, uid) 788 809 | Tpat_or(p1, _, _) -> 789 810 (* Invariant : both arguments bind the same variables *) 790 811 iter_bound_idents f p1 ··· 800 821 !idents_full 801 822 802 823 let rev_only_idents idents_full = 803 803 - List.rev_map (fun (id,_,_) -> id) idents_full 824 824 + List.rev_map (fun (id,_,_,_) -> id) idents_full 804 825 805 826 let pat_bound_idents_full pat = 806 827 List.rev (rev_pat_bound_idents_full pat) ··· 823 844 let rec alpha_pat 824 845 : type k . _ -> k general_pattern -> k general_pattern 825 846 = fun env p -> match p.pat_desc with 826 826 - | Tpat_var (id, s) -> (* note the ``Not_found'' case *) 847 847 + | Tpat_var (id, s, uid) -> (* note the ``Not_found'' case *) 827 848 {p with pat_desc = 828 828 - try Tpat_var (alpha_var env id, s) with 849 849 + try Tpat_var (alpha_var env id, s, uid) with 829 850 | Not_found -> Tpat_any} 830 830 - | Tpat_alias (p1, id, s) -> 851 851 + | Tpat_alias (p1, id, s, uid) -> 831 852 let new_p = alpha_pat env p1 in 832 853 begin try 833 833 - {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)} 854 854 + {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s, uid)} 834 855 with 835 856 | Not_found -> new_p 836 857 end

+30 -4

typing/typedtree.mli

reviewed

··· 22 22 *) 23 23 24 24 open Asttypes 25 25 + module Uid = Shape.Uid 25 26 26 27 (* Value expressions for the core language *) 27 28 ··· 77 78 (* value patterns *) 78 79 | Tpat_any : value pattern_desc 79 80 (** _ *) 80 80 - | Tpat_var : Ident.t * string loc -> value pattern_desc 81 81 + | Tpat_var : Ident.t * string loc * Uid.t -> value pattern_desc 81 82 (** x *) 82 83 | Tpat_alias : 83 83 - value general_pattern * Ident.t * string loc -> value pattern_desc 84 84 + value general_pattern * Ident.t * string loc * Uid.t -> value pattern_desc 84 85 (** P as a *) 85 86 | Tpat_constant : constant -> value pattern_desc 86 87 (** 1, 'a', "true", 1.0, 1l, 1L, 1n *) ··· 479 480 { 480 481 mb_id: Ident.t option; (** [None] for [module _ = struct ... end] *) 481 482 mb_name: string option loc; 483 483 + mb_uid: Uid.t; 482 484 mb_presence: Types.module_presence; 483 485 mb_expr: module_expr; 484 486 mb_attributes: attributes; ··· 570 572 { 571 573 md_id: Ident.t option; 572 574 md_name: string option loc; 575 575 + md_uid: Uid.t; 573 576 md_presence: Types.module_presence; 574 577 md_type: module_type; 575 578 md_attributes: attributes; ··· 580 583 { 581 584 ms_id: Ident.t; 582 585 ms_name: string loc; 586 586 + ms_uid: Uid.t; 583 587 ms_manifest: Path.t; 584 588 ms_txt: Longident.t loc; 585 589 ms_attributes: attributes; ··· 590 594 { 591 595 mtd_id: Ident.t; 592 596 mtd_name: string loc; 597 597 + mtd_uid: Uid.t; 593 598 mtd_type: module_type option; 594 599 mtd_attributes: attributes; 595 600 mtd_loc: Location.t; ··· 715 720 { 716 721 ld_id: Ident.t; 717 722 ld_name: string loc; 723 723 + ld_uid: Uid.t; 718 724 ld_mutable: mutable_flag; 719 725 ld_type: core_type; 720 726 ld_loc: Location.t; ··· 725 731 { 726 732 cd_id: Ident.t; 727 733 cd_name: string loc; 734 734 + cd_uid: Uid.t; 728 735 cd_vars: string loc list; 729 736 cd_args: constructor_arguments; 730 737 cd_res: core_type option; ··· 841 848 structure. 842 849 *) 843 850 851 851 + type item_declaration = 852 852 + | Value of value_description 853 853 + | Value_binding of value_binding 854 854 + | Type of type_declaration 855 855 + | Constructor of constructor_declaration 856 856 + | Extension_constructor of extension_constructor 857 857 + | Label of label_declaration 858 858 + | Module of module_declaration 859 859 + | Module_substitution of module_substitution 860 860 + | Module_binding of module_binding 861 861 + | Module_type of module_type_declaration 862 862 + | Class of class_declaration 863 863 + | Class_type of class_type_declaration 864 864 + (** [item_declaration] groups together items that correspond to the syntactic 865 865 + category of "declarations" which include types, values, modules, etc. 866 866 + declarations in signatures and their definitions in implementations. *) 867 867 + 844 868 (* Auxiliary functions over the a.s.t. *) 845 869 846 870 (** [as_computation_pattern p] is a computation pattern with description ··· 871 895 872 896 val let_bound_idents: value_binding list -> Ident.t list 873 897 val let_bound_idents_full: 874 874 - value_binding list -> (Ident.t * string loc * Types.type_expr) list 898 898 + value_binding list -> 899 899 + (Ident.t * string loc * Types.type_expr * Types.Uid.t) list 875 900 876 901 (** Alpha conversion of patterns *) 877 902 val alpha_pat: ··· 882 907 883 908 val pat_bound_idents: 'k general_pattern -> Ident.t list 884 909 val pat_bound_idents_full: 885 885 - 'k general_pattern -> (Ident.t * string loc * Types.type_expr) list 910 910 + 'k general_pattern -> 911 911 + (Ident.t * string loc * Types.type_expr * Types.Uid.t) list 886 912 887 913 (** Splits an or pattern into its value (left) and exception (right) parts. *) 888 914 val split_pattern:

+49 -74

typing/typemod.ml

reviewed

··· 1039 1039 let open Sig_component_kind in 1040 1040 match component with 1041 1041 | Value -> names.values 1042 1042 - | Type -> names.types 1042 1042 + | Type | Label | Constructor -> names.types 1043 1043 | Module -> names.modules 1044 1044 | Module_type -> names.modtypes 1045 1045 | Extension_constructor -> names.typexts ··· 1374 1374 Typedecl.transl_value_decl env item.psig_loc sdesc 1375 1375 in 1376 1376 Signature_names.check_value names tdesc.val_loc tdesc.val_id; 1377 1377 - Env.register_uid tdesc.val_val.val_uid tdesc.val_loc; 1378 1377 let (trem,rem, final_env) = transl_sig newenv srem in 1379 1378 mksig (Tsig_value tdesc) env loc :: trem, 1380 1379 Sig_value(tdesc.val_id, tdesc.val_val, Exported) :: rem, 1381 1380 final_env 1382 1381 | Psig_type (rec_flag, sdecls) -> 1383 1383 - let (decls, newenv) = 1382 1382 + let (decls, newenv, _) = 1384 1383 Typedecl.transl_type_decl env rec_flag sdecls 1385 1384 in 1386 1385 List.iter (fun td -> 1387 1386 Signature_names.check_type names td.typ_loc td.typ_id; 1388 1388 - if not (Btype.is_row_name (Ident.name td.typ_id)) then 1389 1389 - Env.register_uid td.typ_type.type_uid td.typ_loc 1390 1387 ) decls; 1391 1388 let (trem, rem, final_env) = transl_sig newenv srem in 1392 1389 let sg = ··· 1398 1395 sg, 1399 1396 final_env 1400 1397 | Psig_typesubst sdecls -> 1401 1401 - let (decls, newenv) = 1398 1398 + let (decls, newenv, _) = 1402 1399 Typedecl.transl_type_decl env Nonrecursive sdecls 1403 1400 in 1404 1401 List.iter (fun td -> ··· 1418 1415 in 1419 1416 Some (`Substituted_away subst) 1420 1417 in 1421 1421 - Signature_names.check_type ?info names td.typ_loc td.typ_id; 1422 1422 - Env.register_uid td.typ_type.type_uid td.typ_loc 1418 1418 + Signature_names.check_type ?info names td.typ_loc td.typ_id 1423 1419 ) decls; 1424 1420 let (trem, rem, final_env) = transl_sig newenv srem in 1425 1421 let sg = rem ··· 1428 1424 sg, 1429 1425 final_env 1430 1426 | Psig_typext styext -> 1431 1431 - let (tyext, newenv) = 1427 1427 + let (tyext, newenv, _shapes) = 1432 1428 Typedecl.transl_type_extension false env item.psig_loc styext 1433 1429 in 1434 1430 let constructors = tyext.tyext_constructors in 1435 1431 List.iter (fun ext -> 1436 1436 - Signature_names.check_typext names ext.ext_loc ext.ext_id; 1437 1437 - Env.register_uid ext.ext_type.ext_uid ext.ext_loc 1432 1432 + Signature_names.check_typext names ext.ext_loc ext.ext_id 1438 1433 ) constructors; 1439 1434 let (trem, rem, final_env) = transl_sig newenv srem in 1440 1435 mksig (Tsig_typext tyext) env loc :: trem, ··· 1443 1438 ) constructors rem, 1444 1439 final_env 1445 1440 | Psig_exception sext -> 1446 1446 - let (ext, newenv) = Typedecl.transl_type_exception env sext in 1441 1441 + let (ext, newenv, _s) = Typedecl.transl_type_exception env sext in 1447 1442 let constructor = ext.tyexn_constructor in 1448 1443 Signature_names.check_typext names constructor.ext_loc 1449 1444 constructor.ext_id; 1450 1450 - Env.register_uid 1451 1451 - constructor.ext_type.ext_uid 1452 1452 - constructor.ext_loc; 1453 1445 let (trem, rem, final_env) = transl_sig newenv srem in 1454 1446 mksig (Tsig_exception ext) env loc :: trem, 1455 1447 Sig_typext(constructor.ext_id, ··· 1485 1477 Signature_names.check_module names pmd.pmd_name.loc id; 1486 1478 Some id, newenv 1487 1479 in 1488 1488 - Env.register_uid md.md_uid md.md_loc; 1489 1480 let (trem, rem, final_env) = transl_sig newenv srem in 1490 1481 mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name; 1491 1491 - md_presence=pres; md_type=tmty; 1492 1492 - md_loc=pmd.pmd_loc; 1482 1482 + md_uid=md.md_uid; md_presence=pres; 1483 1483 + md_type=tmty; md_loc=pmd.pmd_loc; 1493 1484 md_attributes=pmd.pmd_attributes}) 1494 1485 env loc :: trem, 1495 1486 (match id with ··· 1525 1516 `Substituted_away (Subst.add_module id path Subst.identity) 1526 1517 in 1527 1518 Signature_names.check_module ~info names pms.pms_name.loc id; 1528 1528 - Env.register_uid md.md_uid md.md_loc; 1529 1519 let (trem, rem, final_env) = transl_sig newenv srem in 1530 1520 mksig (Tsig_modsubst {ms_id=id; ms_name=pms.pms_name; 1531 1531 - ms_manifest=path; ms_txt=pms.pms_manifest; 1532 1532 - ms_loc=pms.pms_loc; 1521 1521 + ms_uid=md.md_uid; ms_manifest=path; 1522 1522 + ms_txt=pms.pms_manifest; ms_loc=pms.pms_loc; 1533 1523 ms_attributes=pms.pms_attributes}) 1534 1524 env loc :: trem, 1535 1525 rem, ··· 1544 1534 | Some id -> Some (id, md, uid) 1545 1535 ) tdecls 1546 1536 in 1547 1547 - List.iter (fun (id, md, uid) -> 1537 1537 + List.iter (fun (id, md, _uid) -> 1548 1538 Signature_names.check_module names md.md_loc id; 1549 1549 - Env.register_uid uid md.md_loc 1550 1539 ) decls; 1551 1540 let (trem, rem, final_env) = transl_sig newenv srem in 1552 1541 mksig (Tsig_recmodule (List.map (fun (md, _, _) -> md) tdecls)) ··· 1563 1552 | Psig_modtype pmtd -> 1564 1553 let newenv, mtd, decl = transl_modtype_decl env pmtd in 1565 1554 Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id; 1566 1566 - Env.register_uid decl.mtd_uid mtd.mtd_loc; 1567 1555 let (trem, rem, final_env) = transl_sig newenv srem in 1568 1556 mksig (Tsig_modtype mtd) env loc :: trem, 1569 1557 Sig_modtype (mtd.mtd_id, decl, Exported) :: rem, 1570 1558 final_env 1571 1559 | Psig_modtypesubst pmtd -> 1572 1572 - let newenv, mtd, decl = transl_modtype_decl env pmtd in 1560 1560 + let newenv, mtd, _decl = transl_modtype_decl env pmtd in 1573 1561 let info = 1574 1562 let mty = match mtd.mtd_type with 1575 1563 | Some tmty -> tmty.mty_type ··· 1583 1571 | _ -> `Unpackable_modtype_substituted_away (mtd.mtd_id,subst) 1584 1572 in 1585 1573 Signature_names.check_modtype ~info names pmtd.pmtd_loc mtd.mtd_id; 1586 1586 - Env.register_uid decl.mtd_uid mtd.mtd_loc; 1587 1574 let (trem, rem, final_env) = transl_sig newenv srem in 1588 1575 mksig (Tsig_modtypesubst mtd) env loc :: trem, 1589 1576 rem, ··· 1625 1612 Signature_names.check_type names loc cls.cls_obj_id; 1626 1613 Signature_names.check_class names loc cls.cls_id; 1627 1614 Signature_names.check_class_type names loc cls.cls_ty_id; 1628 1628 - Env.register_uid cls.cls_decl.cty_uid cls.cls_decl.cty_loc; 1629 1615 ) classes; 1630 1616 let (trem, rem, final_env) = transl_sig newenv srem in 1631 1617 let sg = ··· 1652 1638 let loc = decl.clsty_id_loc.Location.loc in 1653 1639 Signature_names.check_class_type names loc decl.clsty_ty_id; 1654 1640 Signature_names.check_type names loc decl.clsty_obj_id; 1655 1655 - Env.register_uid 1656 1656 - decl.clsty_ty_decl.clty_uid 1657 1657 - decl.clsty_ty_decl.clty_loc; 1658 1641 ) classes; 1659 1642 let (trem,rem, final_env) = transl_sig newenv srem in 1660 1643 let sg = ··· 1720 1703 { 1721 1704 mtd_id=id; 1722 1705 mtd_name=pmtd_name; 1706 1706 + mtd_uid=decl.mtd_uid; 1723 1707 mtd_type=tmty; 1724 1708 mtd_attributes=pmtd_attributes; 1725 1709 mtd_loc=pmtd_loc; ··· 1802 1786 List.map2 (fun pmd (id_shape, id_loc, md, mty) -> 1803 1787 let tmd = 1804 1788 {md_id=Option.map fst id_shape; md_name=id_loc; md_type=mty; 1805 1805 - md_presence=Mp_present; 1789 1789 + md_uid=md.Types.md_uid; md_presence=Mp_present; 1806 1790 md_loc=pmd.pmd_loc; 1807 1791 md_attributes=pmd.pmd_attributes} 1808 1792 in 1809 1809 - tmd, md.md_uid, Option.map snd id_shape 1793 1793 + tmd, md.Types.md_uid, Option.map snd id_shape 1810 1794 ) sdecls dcl2 1811 1795 in 1812 1796 (dcl2, env2) ··· 2012 1996 { 2013 1997 mb_id = id; 2014 1998 mb_name = name; 1999 1999 + mb_uid = uid; 2015 2000 mb_presence = Mp_present; 2016 2001 mb_expr = modl'; 2017 2002 mb_attributes = attrs; ··· 2162 2147 let shape = 2163 2148 Env.shape_of_path ~namespace:Shape.Sig_component_kind.Module env path 2164 2149 in 2150 2150 + let shape = if alias && aliasable then Shape.alias shape else shape in 2165 2151 let md = 2166 2152 if alias && aliasable then 2167 2153 (Env.add_required_global (Path.head path); md) ··· 2518 2504 will be marked as being used during the signature inclusion test. *) 2519 2505 let items, shape_map = 2520 2506 List.fold_left 2521 2521 - (fun (acc, shape_map) (id, { Asttypes.loc; _ }, _typ)-> 2507 2507 + (fun (acc, shape_map) (id, { Asttypes.loc; _ }, _typ, _uid)-> 2522 2508 Signature_names.check_value names loc id; 2523 2509 let vd = Env.find_value (Pident id) newenv in 2524 2524 - Env.register_uid vd.val_uid vd.val_loc; 2525 2510 Sig_value(id, vd, Exported) :: acc, 2526 2511 Shape.Map.add_value shape_map id vd.val_uid 2527 2512 ) ··· 2535 2520 | Pstr_primitive sdesc -> 2536 2521 let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in 2537 2522 Signature_names.check_value names desc.val_loc desc.val_id; 2538 2538 - Env.register_uid desc.val_val.val_uid desc.val_val.val_loc; 2539 2523 Tstr_primitive desc, 2540 2524 [Sig_value(desc.val_id, desc.val_val, Exported)], 2541 2525 Shape.Map.add_value shape_map desc.val_id desc.val_val.val_uid, 2542 2526 newenv 2543 2527 | Pstr_type (rec_flag, sdecls) -> 2544 2544 - let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in 2528 2528 + let (decls, newenv, shapes) = 2529 2529 + Typedecl.transl_type_decl env rec_flag sdecls 2530 2530 + in 2545 2531 List.iter 2546 2532 Signature_names.(fun td -> check_type names td.typ_loc td.typ_id) 2547 2533 decls; ··· 2549 2535 (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs, Exported)) 2550 2536 decls [] 2551 2537 in 2552 2552 - let shape_map = List.fold_left 2553 2553 - (fun shape_map -> function 2554 2554 - | Sig_type (id, vd, _, _) -> 2555 2555 - if not (Btype.is_row_name (Ident.name id)) then begin 2556 2556 - Env.register_uid vd.type_uid vd.type_loc; 2557 2557 - Shape.Map.add_type shape_map id vd.type_uid 2558 2558 - end else shape_map 2559 2559 - | _ -> assert false 2560 2560 - ) 2538 2538 + let shape_map = List.fold_left2 2539 2539 + (fun map { typ_id; _} shape -> 2540 2540 + Shape.Map.add_type map typ_id shape) 2561 2541 shape_map 2562 2562 - items 2542 2542 + decls 2543 2543 + shapes 2563 2544 in 2564 2545 Tstr_type (rec_flag, decls), 2565 2546 items, 2566 2547 shape_map, 2567 2548 enrich_type_decls anchor decls env newenv 2568 2549 | Pstr_typext styext -> 2569 2569 - let (tyext, newenv) = 2550 2550 + let (tyext, newenv, shapes) = 2570 2551 Typedecl.transl_type_extension true env loc styext 2571 2552 in 2572 2553 let constructors = tyext.tyext_constructors in 2573 2573 - let shape_map = List.fold_left (fun shape_map ext -> 2554 2554 + let shape_map = List.fold_left2 (fun shape_map ext shape -> 2574 2555 Signature_names.check_typext names ext.ext_loc ext.ext_id; 2575 2575 - Env.register_uid ext.ext_type.ext_uid ext.ext_loc; 2576 2576 - Shape.Map.add_extcons shape_map ext.ext_id ext.ext_type.ext_uid 2577 2577 - ) shape_map constructors 2556 2556 + Shape.Map.add_extcons shape_map ext.ext_id shape 2557 2557 + ) shape_map constructors shapes 2578 2558 in 2579 2559 (Tstr_typext tyext, 2580 2560 map_ext ··· 2583 2563 shape_map, 2584 2564 newenv) 2585 2565 | Pstr_exception sext -> 2586 2586 - let (ext, newenv) = Typedecl.transl_type_exception env sext in 2566 2566 + let (ext, newenv, shape) = Typedecl.transl_type_exception env sext in 2587 2567 let constructor = ext.tyexn_constructor in 2588 2568 Signature_names.check_typext names constructor.ext_loc 2589 2569 constructor.ext_id; 2590 2590 - Env.register_uid 2591 2591 - constructor.ext_type.ext_uid 2592 2592 - constructor.ext_loc; 2593 2570 Tstr_exception ext, 2594 2571 [Sig_typext(constructor.ext_id, 2595 2572 constructor.ext_type, ··· 2597 2574 Exported)], 2598 2575 Shape.Map.add_extcons shape_map 2599 2576 constructor.ext_id 2600 2600 - constructor.ext_type.ext_uid, 2577 2577 + shape, 2601 2578 newenv 2602 2579 | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs; 2603 2580 pmb_loc; ··· 2625 2602 } 2626 2603 in 2627 2604 let md_shape = Shape.set_uid_if_none md_shape md_uid in 2628 2628 - Env.register_uid md_uid pmb_loc; 2629 2605 (*prerr_endline (Ident.unique_toplevel_name id);*) 2630 2606 Mtype.lower_nongen outer_scope md.md_type; 2631 2607 let id, newenv, sg = ··· 2648 2624 | Some id -> Shape.Map.add_module shape_map id md_shape 2649 2625 | None -> shape_map 2650 2626 in 2651 2651 - Tstr_module {mb_id=id; mb_name=name; mb_expr=modl; 2652 2652 - mb_presence=pres; mb_attributes=attrs; mb_loc=pmb_loc; }, 2627 2627 + Tstr_module {mb_id=id; mb_name=name; mb_uid = md.md_uid; 2628 2628 + mb_expr=modl; mb_presence=pres; mb_attributes=attrs; 2629 2629 + mb_loc=pmb_loc; }, 2653 2630 sg, 2654 2631 shape_map, 2655 2632 newenv ··· 2722 2699 ) bindings2 2723 2700 in 2724 2701 let shape_map = 2725 2725 - List.fold_left (fun map (id, mb, uid, shape) -> 2726 2726 - Env.register_uid uid mb.mb_loc; 2702 2702 + List.fold_left (fun map (id, _mb, _uid, shape) -> 2727 2703 Shape.Map.add_module map id shape 2728 2704 ) shape_map mbs 2729 2705 in ··· 2742 2718 (* check that it is non-abstract *) 2743 2719 let newenv, mtd, decl = transl_modtype_decl env pmtd in 2744 2720 Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id; 2745 2745 - Env.register_uid decl.mtd_uid decl.mtd_loc; 2746 2721 let id = mtd.mtd_id in 2747 2722 let map = Shape.Map.add_module_type shape_map id decl.mtd_uid in 2748 2723 Tstr_modtype mtd, [Sig_modtype (id, decl, Exported)], map, newenv ··· 2759 2734 Signature_names.check_class names loc cls.cls_id; 2760 2735 Signature_names.check_class_type names loc cls.cls_ty_id; 2761 2736 Signature_names.check_type names loc cls.cls_obj_id; 2762 2762 - Env.register_uid cls.cls_decl.cty_uid loc; 2763 2763 - let map f id acc = f acc id cls.cls_decl.cty_uid in 2764 2764 - map Shape.Map.add_class cls.cls_id acc 2765 2765 - |> map Shape.Map.add_class_type cls.cls_ty_id 2766 2766 - |> map Shape.Map.add_type cls.cls_obj_id 2737 2737 + let uid = cls.cls_decl.cty_uid in 2738 2738 + let map f id v acc = f acc id v in 2739 2739 + map Shape.Map.add_class cls.cls_id uid acc 2740 2740 + |> map Shape.Map.add_class_type cls.cls_ty_id uid 2741 2741 + |> map Shape.Map.add_type cls.cls_obj_id (Shape.leaf uid) 2767 2742 ) shape_map classes 2768 2743 in 2769 2744 Tstr_class ··· 2788 2763 let loc = decl.clsty_id_loc.Location.loc in 2789 2764 Signature_names.check_class_type names loc decl.clsty_ty_id; 2790 2765 Signature_names.check_type names loc decl.clsty_obj_id; 2791 2791 - Env.register_uid decl.clsty_ty_decl.clty_uid loc; 2792 2792 - let map f id acc = f acc id decl.clsty_ty_decl.clty_uid in 2793 2793 - map Shape.Map.add_class_type decl.clsty_ty_id acc 2794 2794 - |> map Shape.Map.add_type decl.clsty_obj_id 2766 2766 + let uid = decl.clsty_ty_decl.clty_uid in 2767 2767 + let map f id v acc = f acc id v in 2768 2768 + map Shape.Map.add_class_type decl.clsty_ty_id uid acc 2769 2769 + |> map Shape.Map.add_type decl.clsty_obj_id (Shape.leaf uid) 2795 2770 ) shape_map classes 2796 2771 in 2797 2772 Tstr_class_type ··· 3066 3041 let simple_sg = Signature_names.simplify finalenv names sg in 3067 3042 if !Clflags.print_types then begin 3068 3043 Typecore.force_delayed_checks (); 3069 3069 - let shape = Shape.local_reduce shape in 3044 3044 + let shape = Shape_reduce.local_reduce Env.empty shape in 3070 3045 Printtyp.wrap_printing_env ~error:false initial_env 3071 3046 (fun () -> fprintf std_formatter "%a@." 3072 3047 (Printtyp.printed_signature @@ Unit_info.source_file target) ··· 3100 3075 (* It is important to run these checks after the inclusion test above, 3101 3076 so that value declarations which are not used internally but 3102 3077 exported are not reported as being unused. *) 3103 3103 - let shape = Shape.local_reduce shape in 3078 3078 + let shape = Shape_reduce.local_reduce Env.empty shape in 3104 3079 let annots = Cmt_format.Implementation str in 3105 3080 save_cmt target annots initial_env None (Some shape); 3106 3081 { structure = str; ··· 3123 3098 the values being exported. We can still capture unused 3124 3099 declarations like "let x = true;; let x = 1;;", because in this 3125 3100 case, the inferred signature contains only the last declaration. *) 3126 3126 - let shape = Shape.local_reduce shape in 3101 3101 + let shape = Shape_reduce.local_reduce Env.empty shape in 3127 3102 if not !Clflags.dont_write_files then begin 3128 3103 let alerts = Builtin_attributes.alerts_of_str ast in 3129 3104 let cmi =

+2

typing/typemod.mli

reviewed

··· 76 76 type t = 77 77 | Value 78 78 | Type 79 79 + | Constructor 80 80 + | Label 79 81 | Module 80 82 | Module_type 81 83 | Extension_constructor

+7 -6

typing/untypeast.ml

reviewed

··· 288 288 match pat with 289 289 { pat_extra=[Tpat_unpack, loc, _attrs]; pat_desc = Tpat_any; _ } -> 290 290 Ppat_unpack { txt = None; loc } 291 291 - | { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } -> 291 291 + | { pat_extra=[Tpat_unpack, _, _attrs]; 292 292 + pat_desc = Tpat_var (_,name, _); _ } -> 292 293 Ppat_unpack { name with txt = Some name.txt } 293 294 | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } -> 294 295 Ppat_type (map_loc sub lid) ··· 298 299 | _ -> 299 300 match pat.pat_desc with 300 301 Tpat_any -> Ppat_any 301 301 - | Tpat_var (id, name) -> 302 302 + | Tpat_var (id, name, _) -> 302 303 begin 303 304 match (Ident.name id).[0] with 304 305 'A'..'Z' -> ··· 311 312 The compiler transforms (x:t) into (_ as x : t). 312 313 This avoids transforming a warning 27 into a 26. 313 314 *) 314 314 - | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name) 315 315 + | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name, _) 315 316 when pat_loc = pat.pat_loc -> 316 317 Ppat_var name 317 318 318 318 - | Tpat_alias (pat, _id, name) -> 319 319 + | Tpat_alias (pat, _id, name, _) -> 319 320 Ppat_alias (sub.pat sub pat, name) 320 321 | Tpat_constant cst -> Ppat_constant (constant cst) 321 322 | Tpat_tuple list -> ··· 805 806 806 807 let class_structure sub cs = 807 808 let rec remove_self = function 808 808 - | { pat_desc = Tpat_alias (p, id, _s) } 809 809 + | { pat_desc = Tpat_alias (p, id, _s, _) } 809 810 when string_is_prefix "selfpat-" (Ident.name id) -> 810 811 remove_self p 811 812 | p -> p ··· 835 836 Of.mk ~loc ~attrs desc 836 837 837 838 and is_self_pat = function 838 838 - | { pat_desc = Tpat_alias(_pat, id, _) } -> 839 839 + | { pat_desc = Tpat_alias(_pat, id, _, _) } -> 839 840 string_is_prefix "self-" (Ident.name id) 840 841 | _ -> false 841 842

+3 -3

typing/value_rec_check.ml

reviewed

··· 267 267 let old_env = env in 268 268 let add_value_binding env vb = 269 269 match vb.vb_pat.pat_desc with 270 270 - | Tpat_var (id, _loc) -> 270 270 + | Tpat_var (id, _loc, _uid) -> 271 271 let size = classify_expression old_env vb.vb_expr in 272 272 Ident.add id size env 273 273 | _ -> ··· 1347 1347 and is_destructuring_pattern : type k . k general_pattern -> bool = 1348 1348 fun pat -> match pat.pat_desc with 1349 1349 | Tpat_any -> false 1350 1350 - | Tpat_var (_, _) -> false 1351 1351 - | Tpat_alias (pat, _, _) -> is_destructuring_pattern pat 1350 1350 + | Tpat_var (_, _, _) -> false 1351 1351 + | Tpat_alias (pat, _, _, _) -> is_destructuring_pattern pat 1352 1352 | Tpat_constant _ -> true 1353 1353 | Tpat_tuple _ -> true 1354 1354 | Tpat_construct _ -> true

+1

utils/clflags.ml

reviewed

··· 73 73 let absname = ref false (* -absname *) 74 74 let annotations = ref false (* -annot *) 75 75 let binary_annotations = ref false (* -bin-annot *) 76 76 + let store_occurrences = ref false (* -bin-annot-occurrences *) 76 77 and use_threads = ref false (* -thread *) 77 78 and noassert = ref false (* -noassert *) 78 79 and verbose = ref false (* -verbose *)

+1

utils/clflags.mli

reviewed

··· 102 102 val absname : bool ref 103 103 val annotations : bool ref 104 104 val binary_annotations : bool ref 105 105 + val store_occurrences : bool ref 105 106 val use_threads : bool ref 106 107 val noassert : bool ref 107 108 val verbose : bool ref