From 2ad591b069179953d7d6b34fee4b0f85f41ad99c Mon Sep 17 00:00:00 2001 From: Rudy Ges Date: Mon, 20 Jan 2025 14:55:57 +0100 Subject: [PATCH] Only delay make_lazy_type with PForce; use PConnectField for delaying chunks reading --- src/compiler/server.ml | 8 ++++---- src/context/display/displayTexpr.ml | 2 +- src/typing/typeloadCacheHook.ml | 2 +- src/typing/typeloadModule.ml | 2 +- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/compiler/server.ml b/src/compiler/server.ml index 97b449781ff..b2f6bc408b3 100644 --- a/src/compiler/server.ml +++ b/src/compiler/server.ml @@ -410,7 +410,7 @@ let get_hxb_module com cc path = class hxb_reader_api_server (com : Common.context) (cc : context_cache) - (delay : (unit -> unit) -> unit) + (delay : Typecore.typer_pass -> (unit -> unit) -> unit) = object(self) method make_module (path : path) (file : string) = @@ -453,7 +453,7 @@ class hxb_reader_api_server (* We try to avoid reading expressions as much as possible, so we only do this for our current display file if we're in display mode. *) if full_restore then ignore(f_next chunks EOM) - else delay (fun () -> ignore(f_next chunks EOF)); + else delay PConnectField (fun () -> ignore(f_next chunks EOF)); m | BadModule reason -> die (Printf.sprintf "Unexpected BadModule %s (%s)" (s_type_path path) (Printer.s_module_skip_reason reason)) __LOC__ @@ -476,7 +476,7 @@ class hxb_reader_api_server method make_lazy_type t f = let r = make_unforced_lazy t f "server-api" in - delay (fun () -> ignore(lazy_type r)); + delay PForce (fun () -> ignore(lazy_type r)); TLazy r end @@ -605,7 +605,7 @@ and type_module sctx com delay mpath p = (* We try to avoid reading expressions as much as possible, so we only do this for our current display file if we're in display mode. *) if full_restore then ignore(f_next chunks EOM) - else delay (fun () -> ignore(f_next chunks EOF)); + else delay PConnectField (fun () -> ignore(f_next chunks EOF)); add_modules true m; | Some reason -> skip mpath reason diff --git a/src/context/display/displayTexpr.ml b/src/context/display/displayTexpr.ml index 588698b50aa..8fcd6149b7b 100644 --- a/src/context/display/displayTexpr.ml +++ b/src/context/display/displayTexpr.ml @@ -174,7 +174,7 @@ let check_display_file ctx cs = let m = try ctx.com.module_lut#find path with Not_found -> - begin match !TypeloadCacheHook.type_module_hook ctx.com (delay ctx.g PForce) path null_pos with + begin match !TypeloadCacheHook.type_module_hook ctx.com (delay ctx.g) path null_pos with | NoModule | BadModule _ -> raise Not_found | BinaryModule mc -> let api = (new TypeloadModule.hxb_reader_api_typeload ctx.com ctx.g TypeloadModule.load_module' p :> HxbReaderApi.hxb_reader_api) in diff --git a/src/typing/typeloadCacheHook.ml b/src/typing/typeloadCacheHook.ml index f43d3a60bed..2ad5b31fc91 100644 --- a/src/typing/typeloadCacheHook.ml +++ b/src/typing/typeloadCacheHook.ml @@ -9,7 +9,7 @@ type find_module_result = | BinaryModule of HxbData.module_cache | NoModule -let type_module_hook : (Common.context -> ((unit -> unit) -> unit) -> path -> pos -> find_module_result) ref = ref (fun _ _ _ _ -> NoModule) +let type_module_hook : (Common.context -> (Typecore.typer_pass -> (unit -> unit) -> unit) -> path -> pos -> find_module_result) ref = ref (fun _ _ _ _ -> NoModule) let fake_modules = Hashtbl.create 0 diff --git a/src/typing/typeloadModule.ml b/src/typing/typeloadModule.ml index 7d0451ea7d2..6db894ffcbd 100644 --- a/src/typing/typeloadModule.ml +++ b/src/typing/typeloadModule.ml @@ -813,7 +813,7 @@ and load_module' com g m p = com.module_lut#find m with Not_found -> (* Check cache *) - match !TypeloadCacheHook.type_module_hook com (delay g PForce) m p with + match !TypeloadCacheHook.type_module_hook com (delay g) m p with | GoodModule m -> m | BinaryModule _ ->