+19

.depend

reviewed

··· 77 77 utils/int_replace_polymorphic_compare.cmi : 78 78 utils/load_path.cmo : \ 79 79 utils/misc.cmi \ 80 80 + utils/local_store.cmi \ 81 81 + utils/config.cmi \ 80 82 utils/load_path.cmi 81 83 utils/load_path.cmx : \ 82 84 utils/misc.cmx \ 85 85 + utils/local_store.cmx \ 86 86 + utils/config.cmx \ 83 87 utils/load_path.cmi 84 88 utils/load_path.cmi : 89 89 + utils/local_store.cmo : \ 90 90 + utils/local_store.cmi 91 91 + utils/local_store.cmx : \ 92 92 + utils/local_store.cmi 93 93 + utils/local_store.cmi : 85 94 utils/misc.cmo : \ 86 95 utils/config.cmi \ 87 96 utils/build_path_prefix_map.cmi \ ··· 433 442 typing/btype.cmo : \ 434 443 typing/types.cmi \ 435 444 typing/path.cmi \ 445 445 + utils/local_store.cmi \ 436 446 typing/ident.cmi \ 437 447 parsing/asttypes.cmi \ 438 448 typing/btype.cmi 439 449 typing/btype.cmx : \ 440 450 typing/types.cmx \ 441 451 typing/path.cmx \ 452 452 + utils/local_store.cmx \ 442 453 typing/ident.cmx \ 443 454 parsing/asttypes.cmi \ 444 455 typing/btype.cmi ··· 483 494 utils/misc.cmi \ 484 495 parsing/longident.cmi \ 485 496 parsing/location.cmi \ 497 497 + utils/local_store.cmi \ 486 498 typing/ident.cmi \ 487 499 typing/env.cmi \ 488 500 utils/clflags.cmi \ ··· 498 510 utils/misc.cmx \ 499 511 parsing/longident.cmx \ 500 512 parsing/location.cmx \ 513 513 + utils/local_store.cmx \ 501 514 typing/ident.cmx \ 502 515 typing/env.cmx \ 503 516 utils/clflags.cmx \ ··· 542 555 utils/misc.cmi \ 543 556 parsing/longident.cmi \ 544 557 parsing/location.cmi \ 558 558 + utils/local_store.cmi \ 545 559 utils/load_path.cmi \ 546 560 typing/ident.cmi \ 547 561 typing/datarepr.cmi \ ··· 561 575 utils/misc.cmx \ 562 576 parsing/longident.cmx \ 563 577 parsing/location.cmx \ 578 578 + utils/local_store.cmx \ 564 579 utils/load_path.cmx \ 565 580 typing/ident.cmx \ 566 581 typing/datarepr.cmx \ ··· 606 621 typing/env.cmi 607 622 typing/ident.cmo : \ 608 623 utils/misc.cmi \ 624 624 + utils/local_store.cmi \ 609 625 utils/identifiable.cmi \ 610 626 utils/clflags.cmi \ 611 627 typing/ident.cmi 612 628 typing/ident.cmx : \ 613 629 utils/misc.cmx \ 630 630 + utils/local_store.cmx \ 614 631 utils/identifiable.cmx \ 615 632 utils/clflags.cmx \ 616 633 typing/ident.cmi ··· 1066 1083 parsing/parsetree.cmi \ 1067 1084 utils/misc.cmi \ 1068 1085 parsing/location.cmi \ 1086 1086 + utils/local_store.cmi \ 1069 1087 typing/ident.cmi \ 1070 1088 utils/clflags.cmi \ 1071 1089 typing/btype.cmi \ ··· 1077 1095 parsing/parsetree.cmi \ 1078 1096 utils/misc.cmx \ 1079 1097 parsing/location.cmx \ 1098 1098 + utils/local_store.cmx \ 1080 1099 typing/ident.cmx \ 1081 1100 utils/clflags.cmx \ 1082 1101 typing/btype.cmx \

+3

Changes

reviewed

··· 466 466 - #9003: Start compilation from Emit when the input file is in Linear IR format. 467 467 (Greta Yorsh, review by Jérémie Dimino, Gabriel Scherer and Frédéric Bour) 468 468 469 469 + - #9963: Centralized tracking of frontend's global state 470 470 + (Frédéric Bour and Thomas Refis, review by Gabriel Scherer) 471 471 + 469 472 ### Build system: 470 473 471 474 - #7121, #9558: Always the autoconf-discovered ld in PACKLD. For

+2 -1

compilerlibs/Makefile.compilerlibs

reviewed

··· 26 26 27 27 UTILS=utils/config.cmo utils/build_path_prefix_map.cmo utils/misc.cmo \ 28 28 utils/identifiable.cmo utils/numbers.cmo utils/arg_helper.cmo \ 29 29 - utils/clflags.cmo utils/profile.cmo utils/load_path.cmo \ 29 29 + utils/clflags.cmo utils/profile.cmo utils/local_store.cmo \ 30 30 + utils/load_path.cmo \ 30 31 utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \ 31 32 utils/consistbl.cmo utils/strongly_connected_components.cmo \ 32 33 utils/targetint.cmo utils/int_replace_polymorphic_compare.cmo \

+1 -1

dune

reviewed

··· 45 45 ;; UTILS 46 46 config build_path_prefix_map misc identifiable numbers arg_helper clflags 47 47 profile terminfo ccomp warnings consistbl strongly_connected_components 48 48 - targetint load_path int_replace_polymorphic_compare binutils 48 48 + targetint load_path int_replace_polymorphic_compare binutils local_store 49 49 50 50 ;; PARSING 51 51 location longident docstrings syntaxerr ast_helper camlinternalMenhirLib

+1

otherlibs/dynlink/Makefile

reviewed

··· 82 82 utils/consistbl.ml \ 83 83 utils/terminfo.ml \ 84 84 utils/warnings.ml \ 85 85 + utils/local_store.ml \ 85 86 utils/load_path.ml \ 86 87 utils/int_replace_polymorphic_compare.ml \ 87 88 parsing/location.ml \

+2 -2

tools/Makefile

reviewed

··· 113 113 114 114 ocamlcp_cmos = config.cmo build_path_prefix_map.cmo misc.cmo profile.cmo \ 115 115 warnings.cmo identifiable.cmo numbers.cmo arg_helper.cmo \ 116 116 - clflags.cmo \ 116 116 + clflags.cmo local_store.cmo \ 117 117 terminfo.cmo location.cmo load_path.cmo ccomp.cmo compenv.cmo \ 118 118 main_args.cmo 119 119 ··· 161 161 OCAMLMKTOP=ocamlmktop.cmo 162 162 OCAMLMKTOP_IMPORTS=config.cmo build_path_prefix_map.cmo misc.cmo \ 163 163 identifiable.cmo numbers.cmo arg_helper.cmo clflags.cmo \ 164 164 - load_path.cmo profile.cmo ccomp.cmo 164 164 + local_store.cmo load_path.cmo profile.cmo ccomp.cmo 165 165 166 166 $(call byte_and_opt,ocamlmktop,$(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP),) 167 167

+11 -9

typing/btype.ml

reviewed

··· 18 18 open Asttypes 19 19 open Types 20 20 21 21 + open Local_store 22 22 + 21 23 (**** Sets, maps and hashtables of types ****) 22 24 23 25 module TypeSet = Set.Make(TypeOps) ··· 40 42 41 43 (**** Some type creators ****) 42 44 43 43 - let new_id = ref (-1) 45 45 + let new_id = s_ref (-1) 44 46 45 47 let newty2 level desc = 46 48 incr new_id; { desc; level; scope = lowest_level; id = !new_id } ··· 82 84 | Unchanged 83 85 | Invalid 84 86 85 85 - let trail = Weak.create 1 87 87 + let trail = s_table Weak.create 1 86 88 87 89 let log_change ch = 88 88 - match Weak.get trail 0 with None -> () 90 90 + match Weak.get !trail 0 with None -> () 89 91 | Some r -> 90 92 let r' = ref Unchanged in 91 93 r := Change (ch, r'); 92 92 - Weak.set trail 0 (Some r') 94 94 + Weak.set !trail 0 (Some r') 93 95 94 96 (**** Representative of a type ****) 95 97 ··· 633 635 | _ -> () 634 636 *) 635 637 636 636 - let memo = ref [] 638 638 + let memo = s_ref [] 637 639 (* Contains the list of saved abbreviation expansions. *) 638 640 639 641 let cleanup_abbrev () = ··· 718 720 | Ctypeset (r, v) -> r := v 719 721 720 722 type snapshot = changes ref * int 721 721 - let last_snapshot = ref 0 723 723 + let last_snapshot = s_ref 0 722 724 723 725 let log_type ty = 724 726 if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc)) ··· 771 773 let snapshot () = 772 774 let old = !last_snapshot in 773 775 last_snapshot := !new_id; 774 774 - match Weak.get trail 0 with Some r -> (r, old) 776 776 + match Weak.get !trail 0 with Some r -> (r, old) 775 777 | None -> 776 778 let r = ref Unchanged in 777 777 - Weak.set trail 0 (Some r); 779 779 + Weak.set !trail 0 (Some r); 778 780 (r, old) 779 781 780 782 let rec rev_log accu = function ··· 795 797 List.iter undo_change backlog; 796 798 changes := Unchanged; 797 799 last_snapshot := old; 798 798 - Weak.set trail 0 (Some changes) 800 800 + Weak.set !trail 0 (Some changes) 799 801 800 802 let rec rev_compress_log log r = 801 803 match !r with

+6 -4

typing/ctype.ml

reviewed

··· 20 20 open Types 21 21 open Btype 22 22 23 23 + open Local_store 24 24 + 23 25 (* 24 26 Type manipulation after type inference 25 27 ====================================== ··· 181 183 182 184 (**** Type level management ****) 183 185 184 184 - let current_level = ref 0 185 185 - let nongen_level = ref 0 186 186 - let global_level = ref 1 187 187 - let saved_level = ref [] 186 186 + let current_level = s_ref 0 187 187 + let nongen_level = s_ref 0 188 188 + let global_level = s_ref 1 189 189 + let saved_level = s_ref [] 188 190 189 191 type levels = 190 192 { current_level: int; nongen_level: int; global_level: int;

+54 -50

typing/env.ml

reviewed

··· 23 23 open Types 24 24 open Btype 25 25 26 26 + open Local_store 27 27 + 26 28 module String = Misc.Stdlib.String 27 29 28 30 let add_delayed_check_forward = ref (fun _ -> assert false) ··· 35 37 (inclusion test between signatures, cf Includemod.value_descriptions, ...). 36 38 *) 37 39 38 38 - let value_declarations : unit usage_tbl = Types.Uid.Tbl.create 16 39 39 - let type_declarations : unit usage_tbl = Types.Uid.Tbl.create 16 40 40 - let module_declarations : unit usage_tbl = Types.Uid.Tbl.create 16 40 40 + let value_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 41 41 + let type_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 42 42 + let module_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 41 43 42 44 type constructor_usage = Positive | Pattern | Privatize 43 45 type constructor_usages = ··· 64 66 let constructor_usages () = 65 67 {cu_positive = false; cu_pattern = false; cu_privatize = false} 66 68 67 67 - let used_constructors : constructor_usage usage_tbl = Types.Uid.Tbl.create 16 69 69 + let used_constructors : constructor_usage usage_tbl ref = 70 70 + s_table Types.Uid.Tbl.create 16 68 71 69 72 (** Map indexed by the name of module components. *) 70 73 module NameMap = String.Map ··· 769 772 770 773 let save_sign_of_cmi = sign_of_cmi ~freshen:false 771 774 772 772 - let persistent_env : module_data Persistent_env.t = 773 773 - Persistent_env.empty () 775 775 + let persistent_env : module_data Persistent_env.t ref = 776 776 + s_table Persistent_env.empty () 774 777 775 778 let without_cmis f x = 776 776 - Persistent_env.without_cmis persistent_env f x 779 779 + Persistent_env.without_cmis !persistent_env f x 777 780 778 778 - let imports () = Persistent_env.imports persistent_env 781 781 + let imports () = Persistent_env.imports !persistent_env 779 782 780 783 let import_crcs ~source crcs = 781 781 - Persistent_env.import_crcs persistent_env ~source crcs 784 784 + Persistent_env.import_crcs !persistent_env ~source crcs 782 785 783 786 let read_pers_mod modname filename = 784 784 - Persistent_env.read persistent_env read_sign_of_cmi modname filename 787 787 + Persistent_env.read !persistent_env read_sign_of_cmi modname filename 785 788 786 789 let find_pers_mod name = 787 787 - Persistent_env.find persistent_env read_sign_of_cmi name 790 790 + Persistent_env.find !persistent_env read_sign_of_cmi name 788 791 789 792 let check_pers_mod ~loc name = 790 790 - Persistent_env.check persistent_env read_sign_of_cmi ~loc name 793 793 + Persistent_env.check !persistent_env read_sign_of_cmi ~loc name 791 794 792 795 let crc_of_unit name = 793 793 - Persistent_env.crc_of_unit persistent_env read_sign_of_cmi name 796 796 + Persistent_env.crc_of_unit !persistent_env read_sign_of_cmi name 794 797 795 798 let is_imported_opaque modname = 796 796 - Persistent_env.is_imported_opaque persistent_env modname 799 799 + Persistent_env.is_imported_opaque !persistent_env modname 797 800 798 801 let register_import_as_opaque modname = 799 799 - Persistent_env.register_import_as_opaque persistent_env modname 802 802 + Persistent_env.register_import_as_opaque !persistent_env modname 800 803 801 804 let reset_declaration_caches () = 802 802 - Types.Uid.Tbl.clear value_declarations; 803 803 - Types.Uid.Tbl.clear type_declarations; 804 804 - Types.Uid.Tbl.clear module_declarations; 805 805 - Types.Uid.Tbl.clear used_constructors; 805 805 + Types.Uid.Tbl.clear !value_declarations; 806 806 + Types.Uid.Tbl.clear !type_declarations; 807 807 + Types.Uid.Tbl.clear !module_declarations; 808 808 + Types.Uid.Tbl.clear !used_constructors; 806 809 () 807 810 808 811 let reset_cache () = 809 812 Current_unit_name.set ""; 810 810 - Persistent_env.clear persistent_env; 813 813 + Persistent_env.clear !persistent_env; 811 814 reset_declaration_caches (); 812 815 () 813 816 814 817 let reset_cache_toplevel () = 815 815 - Persistent_env.clear_missing persistent_env; 818 818 + Persistent_env.clear_missing !persistent_env; 816 819 reset_declaration_caches (); 817 820 () 818 821 819 822 (* get_components *) 820 823 821 824 let get_components_res c = 822 822 - match Persistent_env.can_load_cmis persistent_env with 825 825 + match Persistent_env.can_load_cmis !persistent_env with 823 826 | Persistent_env.Can_load_cmis -> 824 827 EnvLazy.force !components_of_module_maker' c.comps 825 828 | Persistent_env.Cannot_load_cmis log -> ··· 1066 1069 | Papply _ -> 1067 1070 raise Not_found 1068 1071 1069 1069 - let required_globals = ref [] 1072 1072 + let required_globals = s_ref [] 1070 1073 let reset_required_globals () = required_globals := [] 1071 1074 let get_required_globals () = !required_globals 1072 1075 let add_required_global id = ··· 1243 1246 begin match may_subst Subst.module_path sub path with 1244 1247 | Pident id 1245 1248 when Ident.persistent id 1246 1246 - && not (Persistent_env.looked_up persistent_env (Ident.name id)) -> 1249 1249 + && not (Persistent_env.looked_up !persistent_env (Ident.name id)) -> 1247 1250 false 1248 1251 | path -> (* PR#6600: find_module may raise Not_found *) 1249 1252 try scrape_alias_for_visit env sub (find_module path env).md_type ··· 1283 1286 iter_components (Pident id) path data.mda_components 1284 1287 | Mod_persistent -> 1285 1288 let modname = Ident.name id in 1286 1286 - match Persistent_env.find_in_cache persistent_env modname with 1289 1289 + match Persistent_env.find_in_cache !persistent_env modname with 1287 1290 | None -> () 1288 1291 | Some data -> 1289 1292 iter_components (Pident id) path data.mda_components) ··· 1304 1307 env1.types == env2.types && env1.modules == env2.modules 1305 1308 1306 1309 let used_persistent () = 1307 1307 - Persistent_env.fold persistent_env 1310 1310 + Persistent_env.fold !persistent_env 1308 1311 (fun s _m r -> Concr.add s r) 1309 1312 Concr.empty 1310 1313 ··· 1674 1677 and store_value ?check id addr decl env = 1675 1678 check_value_name (Ident.name id) decl.val_loc; 1676 1679 Option.iter 1677 1677 - (fun f -> check_usage decl.val_loc id decl.val_uid f value_declarations) 1680 1680 + (fun f -> check_usage decl.val_loc id decl.val_uid f !value_declarations) 1678 1681 check; 1679 1682 let vda = { vda_description = decl; vda_address = addr } in 1680 1683 { env with ··· 1686 1689 if check then 1687 1690 check_usage loc id info.type_uid 1688 1691 (fun s -> Warnings.Unused_type_declaration s) 1689 1689 - type_declarations; 1692 1692 + !type_declarations; 1690 1693 let path = Pident id in 1691 1694 let constructors = 1692 1695 Datarepr.constructors_of_type path info ··· 1705 1708 let name = cstr.cstr_name in 1706 1709 let loc = cstr.cstr_loc in 1707 1710 let k = cstr.cstr_uid in 1708 1708 - if not (Types.Uid.Tbl.mem used_constructors k) then 1711 1711 + if not (Types.Uid.Tbl.mem !used_constructors k) then 1709 1712 let used = constructor_usages () in 1710 1710 - Types.Uid.Tbl.add used_constructors k 1713 1713 + Types.Uid.Tbl.add !used_constructors k 1711 1714 (add_constructor_usage ~rebind:false priv used); 1712 1715 if not (ty_name = "" || ty_name.[0] = '_') 1713 1716 then !add_delayed_check_forward ··· 1757 1760 let is_exception = Path.same ext.ext_type_path Predef.path_exn in 1758 1761 let name = cstr.cstr_name in 1759 1762 let k = cstr.cstr_uid in 1760 1760 - if not (Types.Uid.Tbl.mem used_constructors k) then begin 1763 1763 + if not (Types.Uid.Tbl.mem !used_constructors k) then begin 1761 1764 let used = constructor_usages () in 1762 1762 - Types.Uid.Tbl.add used_constructors k 1765 1765 + Types.Uid.Tbl.add !used_constructors k 1763 1766 (add_constructor_usage ~rebind priv used); 1764 1767 !add_delayed_check_forward 1765 1768 (fun () -> ··· 1778 1781 and store_module ~check ~freshening_sub id addr presence md env = 1779 1782 let loc = md.md_loc in 1780 1783 Option.iter 1781 1781 - (fun f -> check_usage loc id md.md_uid f module_declarations) check; 1784 1784 + (fun f -> check_usage loc id md.md_uid f !module_declarations) check; 1782 1785 let alerts = Builtin_attributes.alerts_of_attrs md.md_attributes in 1783 1786 let module_decl_lazy = 1784 1787 match freshening_sub with ··· 2125 2128 Subst.reset_for_saving (); 2126 2129 let sg = Subst.signature Make_local (Subst.for_saving Subst.identity) sg in 2127 2130 let cmi = 2128 2128 - Persistent_env.make_cmi persistent_env modname sg alerts 2131 2131 + Persistent_env.make_cmi !persistent_env modname sg alerts 2129 2132 |> cmi_transform in 2130 2133 let pm = save_sign_of_cmi 2131 2134 { Persistent_env.Persistent_signature.cmi; filename } in 2132 2132 - Persistent_env.save_cmi persistent_env 2135 2135 + Persistent_env.save_cmi !persistent_env 2133 2136 { Persistent_env.Persistent_signature.filename; cmi } pm; 2134 2137 cmi 2135 2138 ··· 2152 2155 (* Tracking usage *) 2153 2156 2154 2157 let mark_module_used uid = 2155 2155 - match Types.Uid.Tbl.find module_declarations uid with 2158 2158 + match Types.Uid.Tbl.find !module_declarations uid with 2156 2159 | mark -> mark () 2157 2160 | exception Not_found -> () 2158 2161 2159 2162 let mark_modtype_used _uid = () 2160 2163 2161 2164 let mark_value_used uid = 2162 2162 - match Types.Uid.Tbl.find value_declarations uid with 2165 2165 + match Types.Uid.Tbl.find !value_declarations uid with 2163 2166 | mark -> mark () 2164 2167 | exception Not_found -> () 2165 2168 2166 2169 let mark_type_used uid = 2167 2167 - match Types.Uid.Tbl.find type_declarations uid with 2170 2170 + match Types.Uid.Tbl.find !type_declarations uid with 2168 2171 | mark -> mark () 2169 2172 | exception Not_found -> () 2170 2173 ··· 2174 2177 | exception Not_found -> () 2175 2178 2176 2179 let mark_constructor_used usage cd = 2177 2177 - match Types.Uid.Tbl.find used_constructors cd.cd_uid with 2180 2180 + match Types.Uid.Tbl.find !used_constructors cd.cd_uid with 2178 2181 | mark -> mark usage 2179 2182 | exception Not_found -> () 2180 2183 2181 2184 let mark_extension_used usage ext = 2182 2182 - match Types.Uid.Tbl.find used_constructors ext.ext_uid with 2185 2185 + match Types.Uid.Tbl.find !used_constructors ext.ext_uid with 2183 2186 | mark -> mark usage 2184 2187 | exception Not_found -> () 2185 2188 ··· 2190 2193 | _ -> assert false 2191 2194 in 2192 2195 mark_type_path_used env ty_path; 2193 2193 - match Types.Uid.Tbl.find used_constructors cstr.cstr_uid with 2196 2196 + match Types.Uid.Tbl.find !used_constructors cstr.cstr_uid with 2194 2197 | mark -> mark usage 2195 2198 | exception Not_found -> () 2196 2199 ··· 2203 2206 mark_type_path_used env ty_path 2204 2207 2205 2208 let mark_class_used uid = 2206 2206 - match Types.Uid.Tbl.find type_declarations uid with 2209 2209 + match Types.Uid.Tbl.find !type_declarations uid with 2207 2210 | mark -> mark () 2208 2211 | exception Not_found -> () 2209 2212 2210 2213 let mark_cltype_used uid = 2211 2211 - match Types.Uid.Tbl.find type_declarations uid with 2214 2214 + match Types.Uid.Tbl.find !type_declarations uid with 2212 2215 | mark -> mark () 2213 2216 | exception Not_found -> () 2214 2217 2215 2218 let set_value_used_callback vd callback = 2216 2216 - Types.Uid.Tbl.add value_declarations vd.val_uid callback 2219 2219 + Types.Uid.Tbl.add !value_declarations vd.val_uid callback 2217 2220 2218 2221 let set_type_used_callback td callback = 2219 2222 if Uid.for_actual_declaration td.type_uid then 2220 2223 let old = 2221 2221 - try Types.Uid.Tbl.find type_declarations td.type_uid 2224 2224 + try Types.Uid.Tbl.find !type_declarations td.type_uid 2222 2225 with Not_found -> ignore 2223 2226 in 2224 2224 - Types.Uid.Tbl.replace type_declarations td.type_uid (fun () -> callback old) 2227 2227 + Types.Uid.Tbl.replace !type_declarations td.type_uid 2228 2228 + (fun () -> callback old) 2225 2229 2226 2230 (* Lookup by name *) 2227 2231 ··· 2866 2870 in 2867 2871 f name p md acc 2868 2872 | Mod_persistent -> 2869 2869 - match Persistent_env.find_in_cache persistent_env name with 2873 2873 + match Persistent_env.find_in_cache !persistent_env name with 2870 2874 | None -> acc 2871 2875 | Some mda -> 2872 2876 let md = ··· 2927 2931 | Mod_local _ -> acc 2928 2932 | Mod_unbound _ -> acc 2929 2933 | Mod_persistent -> 2930 2930 - match Persistent_env.find_in_cache persistent_env name with 2934 2934 + match Persistent_env.find_in_cache !persistent_env name with 2931 2935 | Some _ -> acc 2932 2936 | None -> 2933 2937 if f (Ident.create_persistent name) then ··· 2992 2996 if Path.Map.is_empty env.local_constraints then env.summary 2993 2997 else Env_constraints (env.summary, env.local_constraints) 2994 2998 2995 2995 - let last_env = ref empty 2996 2996 - let last_reduced_env = ref empty 2999 2999 + let last_env = s_ref empty 3000 3000 + let last_reduced_env = s_ref empty 2997 3001 2998 3002 let keep_only_summary env = 2999 3003 if !last_env == env then !last_reduced_env

+4 -2

typing/ident.ml

reviewed

··· 13 13 (* *) 14 14 (**************************************************************************) 15 15 16 16 + open Local_store 17 17 + 16 18 let lowest_scope = 0 17 19 let highest_scope = 100000000 18 20 ··· 26 28 27 29 (* A stamp of 0 denotes a persistent identifier *) 28 30 29 29 - let currentstamp = ref 0 30 30 - let predefstamp = ref 0 31 31 + let currentstamp = s_ref 0 32 32 + let predefstamp = s_ref 0 31 33 32 34 let create_scoped ~scope s = 33 35 incr currentstamp;

+3 -1

typing/subst.ml

reviewed

··· 20 20 open Types 21 21 open Btype 22 22 23 23 + open Local_store 24 24 + 23 25 type type_replacement = 24 26 | Path of Path.t 25 27 | Type_function of { params : type_expr list; body : type_expr } ··· 124 126 125 127 (* Special type ids for saved signatures *) 126 128 127 127 - let new_id = ref (-1) 129 129 + let new_id = s_ref (-1) 128 130 let reset_for_saving () = new_id := -1 129 131 130 132 let newpersty desc =

+6

utils/config.mli

reviewed

··· 244 244 245 245 val config_var : string -> string option 246 246 (** the configuration value of a variable, if it exists *) 247 247 + 248 248 + (**/**) 249 249 + 250 250 + val merlin : bool 251 251 + 252 252 + (**/**)

+2

utils/config.mlp

reviewed

··· 237 237 | Bool b -> string_of_bool b 238 238 in 239 239 Some s 240 240 + 241 241 + let merlin = false

+11 -3

utils/load_path.ml

reviewed

··· 12 12 (* *) 13 13 (**************************************************************************) 14 14 15 15 + open Local_store 16 16 + 15 17 module SMap = Misc.Stdlib.String.Map 16 18 17 19 (* Mapping from basenames to full filenames *) 18 20 type registry = string SMap.t ref 19 21 20 20 - let files : registry = ref SMap.empty 21 21 - let files_uncap : registry = ref SMap.empty 22 22 + let files : registry = s_ref SMap.empty 23 23 + let files_uncap : registry = s_ref SMap.empty 22 24 23 25 module Dir = struct 24 26 type t = { ··· 42 44 { path; files = Array.to_list (readdir_compat path) } 43 45 end 44 46 45 45 - let dirs = ref [] 47 47 + let dirs = s_ref [] 46 48 47 49 let reset () = 50 50 + assert (not Config.merlin || Local_store.is_bound ()); 48 51 files := SMap.empty; 49 52 files_uncap := SMap.empty; 50 53 dirs := [] ··· 64 67 name already exists in the cache simply by adding entries in reverse 65 68 order. *) 66 69 let add dir = 70 70 + assert (not Config.merlin || Local_store.is_bound ()); 67 71 let new_files, new_files_uncap = 68 72 add_to_maps (Filename.concat dir.Dir.path) 69 73 dir.Dir.files !files !files_uncap ··· 77 81 List.iter add !dirs 78 82 79 83 let remove_dir dir = 84 84 + assert (not Config.merlin || Local_store.is_bound ()); 80 85 let new_dirs = List.filter (fun d -> Dir.path d <> dir) !dirs in 81 86 if List.compare_lengths new_dirs !dirs <> 0 then begin 82 87 reset (); ··· 88 93 add a basename to the cache if it is not already present in the cache, in 89 94 order to enforce left-to-right precedence. *) 90 95 let add dir = 96 96 + assert (not Config.merlin || Local_store.is_bound ()); 91 97 let new_files, new_files_uncap = 92 98 add_to_maps (Filename.concat dir.Dir.path) dir.Dir.files 93 99 SMap.empty SMap.empty ··· 102 108 let is_basename fn = Filename.basename fn = fn 103 109 104 110 let find fn = 111 111 + assert (not Config.merlin || Local_store.is_bound ()); 105 112 if is_basename fn then 106 113 SMap.find fn !files 107 114 else 108 115 Misc.find_in_path (get_paths ()) fn 109 116 110 117 let find_uncap fn = 118 118 + assert (not Config.merlin || Local_store.is_bound ()); 111 119 if is_basename fn then 112 120 SMap.find (String.uncapitalize_ascii fn) !files_uncap 113 121 else

+74

utils/local_store.ml

reviewed

··· 1 1 + (**************************************************************************) 2 2 + (* *) 3 3 + (* OCaml *) 4 4 + (* *) 5 5 + (* Frederic Bour, Tarides *) 6 6 + (* Thomas Refis, Tarides *) 7 7 + (* *) 8 8 + (* Copyright 2020 Tarides *) 9 9 + (* *) 10 10 + (* All rights reserved. This file is distributed under the terms of *) 11 11 + (* the GNU Lesser General Public License version 2.1, with the *) 12 12 + (* special exception on linking described in the file LICENSE. *) 13 13 + (* *) 14 14 + (**************************************************************************) 15 15 + 16 16 + type ref_and_reset = 17 17 + | Table : { ref: 'a ref; init: unit -> 'a } -> ref_and_reset 18 18 + | Ref : { ref: 'a ref; mutable snapshot: 'a } -> ref_and_reset 19 19 + 20 20 + type bindings = { 21 21 + mutable refs: ref_and_reset list; 22 22 + mutable frozen : bool; 23 23 + mutable is_bound: bool; 24 24 + } 25 25 + 26 26 + let global_bindings = 27 27 + { refs = []; is_bound = false; frozen = false } 28 28 + 29 29 + let is_bound () = global_bindings.is_bound 30 30 + 31 31 + let reset () = 32 32 + assert (is_bound ()); 33 33 + List.iter (function 34 34 + | Table { ref; init } -> ref := init () 35 35 + | Ref { ref; snapshot } -> ref := snapshot 36 36 + ) global_bindings.refs 37 37 + 38 38 + let s_table create size = 39 39 + let init () = create size in 40 40 + let ref = ref (init ()) in 41 41 + assert (not global_bindings.frozen); 42 42 + global_bindings.refs <- (Table { ref; init }) :: global_bindings.refs; 43 43 + ref 44 44 + 45 45 + let s_ref k = 46 46 + let ref = ref k in 47 47 + assert (not global_bindings.frozen); 48 48 + global_bindings.refs <- 49 49 + (Ref { ref; snapshot = k }) :: global_bindings.refs; 50 50 + ref 51 51 + 52 52 + type slot = Slot : { ref : 'a ref; mutable value : 'a } -> slot 53 53 + type store = slot list 54 54 + 55 55 + let fresh () = 56 56 + let slots = 57 57 + List.map (function 58 58 + | Table { ref; init } -> Slot {ref; value = init ()} 59 59 + | Ref r -> 60 60 + if not global_bindings.frozen then r.snapshot <- !(r.ref); 61 61 + Slot { ref = r.ref; value = r.snapshot } 62 62 + ) global_bindings.refs 63 63 + in 64 64 + global_bindings.frozen <- true; 65 65 + slots 66 66 + 67 67 + let with_store slots f = 68 68 + assert (not global_bindings.is_bound); 69 69 + global_bindings.is_bound <- true; 70 70 + List.iter (fun (Slot {ref;value}) -> ref := value) slots; 71 71 + Fun.protect f ~finally:(fun () -> 72 72 + List.iter (fun (Slot s) -> s.value <- !(s.ref)) slots; 73 73 + global_bindings.is_bound <- false; 74 74 + )

+66

utils/local_store.mli

reviewed

··· 1 1 + (**************************************************************************) 2 2 + (* *) 3 3 + (* OCaml *) 4 4 + (* *) 5 5 + (* Frederic Bour, Tarides *) 6 6 + (* Thomas Refis, Tarides *) 7 7 + (* *) 8 8 + (* Copyright 2020 Tarides *) 9 9 + (* *) 10 10 + (* All rights reserved. This file is distributed under the terms of *) 11 11 + (* the GNU Lesser General Public License version 2.1, with the *) 12 12 + (* special exception on linking described in the file LICENSE. *) 13 13 + (* *) 14 14 + (**************************************************************************) 15 15 + 16 16 + (** This module provides some facilities for creating references (and hash 17 17 + tables) which can easily be snapshoted and restored to an arbitrary version. 18 18 + 19 19 + It is used throughout the frontend (read: typechecker), to register all 20 20 + (well, hopefully) the global state. Thus making it easy for tools like 21 21 + Merlin to go back and forth typechecking different files. *) 22 22 + 23 23 + (** {1 Creators} *) 24 24 + 25 25 + val s_ref : 'a -> 'a ref 26 26 + (** Similar to {!ref}, except the allocated reference is registered into the 27 27 + store. *) 28 28 + 29 29 + val s_table : ('a -> 'b) -> 'a -> 'b ref 30 30 + (** Used to register hash tables. Those also need to be placed into refs to be 31 31 + easily swapped out, but one can't just "snapshot" the initial value to 32 32 + create fresh instances, so instead an initializer is required. 33 33 + 34 34 + Use it like this: 35 35 + {[ 36 36 + let my_table = s_table Hashtbl.create 42 37 37 + ]} 38 38 + *) 39 39 + 40 40 + (** {1 State management} 41 41 + 42 42 + Note: all the following functions are currently unused inside the compiler 43 43 + codebase. Merlin is their only user at the moment. *) 44 44 + 45 45 + type store 46 46 + 47 47 + val fresh : unit -> store 48 48 + (** Returns a fresh instance of the store. 49 49 + 50 50 + The first time this function is called, it snapshots the value of all the 51 51 + registered references, later calls to [fresh] will return instances 52 52 + initialized to those values. *) 53 53 + 54 54 + val with_store : store -> (unit -> 'a) -> 'a 55 55 + (** [with_scope s f] resets all the registered references to the value they have 56 56 + in [s] for the run of [f]. 57 57 + If [f] updates any of the registered refs, [s] is updated to remember those 58 58 + changes. *) 59 59 + 60 60 + val reset : unit -> unit 61 61 + (** Resets all the references to the initial snapshot (i.e. to the same values 62 62 + that new instances start with). *) 63 63 + 64 64 + val is_bound : unit -> bool 65 65 + (** Returns [true] when a scope is active (i.e. when called from the callback 66 66 + passed to {!with_scope}), [false] otherwise. *)