[server] fix memory leak, tweak GC (#12412)

* [typer] delayed Lazy.force to avoid default abstract value leak
* [server] gc tweaks for ocaml 5
* [display] add server/gcCompact, remove Gc.compact() from server/memory calls

haxe.opam

@@ -37,4 +37,5 @@ depends: [
   "domainslib" {>= "0.5.2"}
   "saturn"
   "thread-local-storage"
+  "dynamic_gc"
 ]

src/compiler/haxe.ml

@@ -46,6 +46,14 @@ open Server
 ;;
 Sys.catch_break true;
 
+DynamicGc.(setup_dynamic_tuning
+  {
+    min_space_overhead = 100;
+    max_space_overhead = 120;
+    heap_start_worrying_mb = 4_096;
+    heap_really_worry_mb = 8_192;
+  });
+
 let args = List.tl (Array.to_list Sys.argv) in
 set_binary_mode_out stdout true;
 set_binary_mode_out stderr true;

src/compiler/serverMessage.ml

@@ -24,7 +24,6 @@ type server_message_options = {
 	mutable print_signature : bool;
 	mutable print_display_position : bool;
 	mutable print_stats : bool;
-	mutable print_gc_stats : bool;
 	mutable print_message : bool;
 	mutable print_socket_message : bool;
 	mutable print_uncaught_error : bool;
@@ -52,7 +51,6 @@ let config = {
 	print_signature = false;
 	print_display_position = false;
 	print_stats = false;
-	print_gc_stats = false;
 	print_message = false;
 	print_socket_message = false;
 	print_uncaught_error = false;
@@ -144,18 +142,6 @@ let stats stats time =
 let message s =
 	if config.print_message then print_endline ("> " ^ s)
 
-let gc_stats time stats_before did_compact space_overhead =
-	if config.print_stats || config.print_gc_stats then begin
-		let stats = Gc.quick_stat() in
-		print_endline (Printf.sprintf "GC %s done in %.2fs with space_overhead = %i\n\tbefore: %s\n\tafter: %s"
-			(if did_compact then "compaction" else "collection")
-			time
-			space_overhead
-			(Memory.fmt_word (float_of_int stats_before.Gc.heap_words))
-			(Memory.fmt_word (float_of_int stats.heap_words))
-		)
-	end
-
 let socket_message s =
 	if config.print_socket_message then print_endline s
 
@@ -182,7 +168,6 @@ let enable_all () =
 	config.print_signature <- true;
 	config.print_display_position <- true;
 	config.print_stats <- true;
-	config.print_gc_stats <- true;
 	config.print_message <- true;
 	config.print_socket_message <- true;
 	config.print_uncaught_error <- true;
@@ -208,7 +193,6 @@ let set_by_name name value = match name with
 	| "signature" -> config.print_signature <- value;
 	| "displayPosition" -> config.print_display_position <- value;
 	| "stats" -> config.print_stats <- value;
-	| "gcStats" -> config.print_gc_stats <- value;
 	| "message" -> config.print_message <- value;
 	| "socketMessage" -> config.print_socket_message <- value;
 	| "uncaughtError" -> config.print_uncaught_error <- value;

src/context/display/displayJson.ml

@@ -320,6 +320,17 @@ let handler =
 				"success", jbool true
 			]);
 		);
+		"server/gcCompact", (fun hctx ->
+			let t0 = Extc.time() in
+			let stats_before = Gc.stat() in
+			Gc.compact();
+			let stats = Gc.quick_stat() in
+			hctx.send_result (jobject [
+				"time", jfloat (Extc.time() -. t0);
+				"before", jint (stats_before.Gc.heap_words * Sys.word_size / 8);
+				"after", jint (stats.Gc.heap_words * Sys.word_size / 8);
+			]);
+		);
 		"server/readClassPaths", (fun hctx ->
 			hctx.com.callbacks#add_after_init_macros (fun () ->
 				let cc = hctx.display#get_cs#get_context (Define.get_signature hctx.com.defines) in

src/context/display/displayMemory.ml

@@ -7,16 +7,6 @@ open Type
 let get_memory_json (cs : CompilationCache.t) mreq =
 	begin match mreq with
 	| MCache ->
-		let t0 = Extc.time() in
-		let stats = Gc.stat() in
-		let old_gc = Gc.get() in
-		Gc.set { old_gc with
-			Gc.max_overhead = 0;
-			Gc.space_overhead = 0
-		};
-		Gc.compact();
-		Gc.set old_gc;
-		ServerMessage.gc_stats (Extc.time() -. t0) stats true 0;
 		let stat = Gc.quick_stat() in
 		let size = (float_of_int stat.Gc.heap_words) *. (float_of_int (Sys.word_size / 8)) in
 		let cache_mem = cs#get_pointers in

src/dune

@@ -22,7 +22,7 @@
 		unix ipaddr str bigarray threads dynlink
 		xml-light extlib sha terminal_size
 		luv
-		domainslib saturn thread-local-storage
+		domainslib saturn thread-local-storage dynamic_gc
 	)
 	(modules (:standard \ haxe prebuild))
 	(preprocess (per_module

src/macro/eval/evalIntegers.ml

@@ -2,12 +2,10 @@ module GInt64 = Int64
 module GInt32 = Int32
 
 open Globals
-open EvalContext
 open EvalExceptions
 open EvalValue
 open EvalEncode
 open EvalDecode
-open EvalHash
 open EvalMisc
 open Unsigned
 open Signed

src/typing/typeloadModule.ml

@@ -213,6 +213,9 @@ module ModuleLevel = struct
 						a_enum = List.mem AbEnum d.d_flags || p_enum_meta <> None;
 						a_default;
 					} in
+					delay ctx_m.g PBuildModule (fun () ->
+						match a.a_default with | None -> () | Some l -> ignore(Lazy.force l)
+					);
 					begin match p_enum_meta with
 						| None when a.a_enum -> a.a_meta <- (Meta.Enum,[],null_pos) :: a.a_meta; (* HAXE5: remove *)
 						| None -> ()

std/haxe/display/Server.hx

@@ -37,6 +37,7 @@ class ServerMethods {
 	static inline var Invalidate = new HaxeRequestMethod<FileParams, Response<NoData>>("server/invalidate");
 	static inline var Contexts = new HaxeRequestMethod<NoData, Response<Array<HaxeServerContext>>>("server/contexts");
 	static inline var Memory = new HaxeRequestMethod<NoData, Response<HaxeMemoryResult>>("server/memory");
+	static inline var GcCompact = new HaxeRequestMethod<NoData, Response<GcCompactResult>>("server/gcCompact");
 	static inline var ContextMemory = new HaxeRequestMethod<ContextParams, Response<HaxeContextMemoryResult>>("server/memory/context");
 	static inline var ModuleMemory = new HaxeRequestMethod<ModuleParams, Response<HaxeModuleMemoryResult>>("server/memory/module");
 	static inline var Modules = new HaxeRequestMethod<ContextParams, Response<Array<String>>>("server/modules");
@@ -132,6 +133,12 @@ typedef HaxeMemoryResult = {
 	}
 }
 
+typedef GcCompactResult = {
+	final time:Float;
+	final before:Int;
+	final after:Int;
+}
+
 typedef HaxeContextMemoryResult = {
 	final moduleCache:{
 		final size:Int;