Run -D dump in parallel (#12081)

* generate dumps in parallel

* mutex mkdir

haxe.opam

@@ -34,4 +34,5 @@ depends: [
   "luv" {>= "0.5.13"}
   "ipaddr"
   "terminal_size"
+  "domainslib"
 ]

src/codegen/dump.ml

@@ -27,7 +27,7 @@ let dump_types com pretty =
 		| [] -> ""
 		| l -> Printf.sprintf "<%s>" (String.concat ", " (List.map s_type_param l))
 	in
-	List.iter (fun mt ->
+	let f mt =
 		let path = Type.t_path mt in
 		let buf,close = create_dumpfile_from_path com path in
 		let print fmt = Printf.kprintf (fun s -> Buffer.add_string buf s) fmt in
@@ -117,11 +117,14 @@ let dump_types com pretty =
 			(String.concat " " (List.map (fun t -> " from " ^ s_type t) a.a_from))
 			(String.concat " " (List.map (fun t -> " to " ^ s_type t) a.a_to));
 		);
-		close();
-	) com.types
+		close()
+	in
+	Parallel.run_in_new_pool (fun pool ->
+		Parallel.run_parallel_on_array pool (Array.of_list com.types) f
+	)
 
 let dump_record com =
-	List.iter (fun mt ->
+	let f mt =
 		let buf,close = create_dumpfile_from_path com (t_path mt) in
 		let s = match mt with
 			| TClassDecl c -> Printer.s_tclass "" c
@@ -130,11 +133,14 @@ let dump_record com =
 			| TAbstractDecl a -> Printer.s_tabstract "" a
 		in
 		Buffer.add_string buf s;
-		close();
-	) com.types
+		close()
+	in
+	Parallel.run_in_new_pool (fun pool ->
+		Parallel.run_parallel_on_array pool (Array.of_list com.types) f
+	)
 
 let dump_position com =
-	List.iter (fun mt ->
+	let f mt =
 		match mt with
 			| TClassDecl c ->
 				let buf,close = create_dumpfile_from_path com (t_path mt) in
@@ -153,7 +159,10 @@ let dump_position com =
 				close();
 			| _ ->
 				()
-	) com.types
+	in
+	Parallel.run_in_new_pool (fun pool ->
+		Parallel.run_parallel_on_array pool (Array.of_list com.types) f
+	)
 
 let dump_types com =
 	match Common.defined_value_safe com Define.Dump with

src/compiler/generate.ml

@@ -135,8 +135,10 @@ let delete_file f = try Sys.remove f with _ -> ()
 let maybe_generate_dump ctx tctx =
 	let com = tctx.Typecore.com in
 	if Common.defined com Define.Dump then begin
+		let t = Timer.timer ["generate";"dump"] in
 		Dump.dump_types com;
-		Option.may Dump.dump_types (com.get_macros())
+		Option.may Dump.dump_types (com.get_macros());
+		t()
 	end;
 	if Common.defined com Define.DumpDependencies then begin
 		Dump.dump_dependencies com;

src/context/parallel.ml

@@ -0,0 +1,17 @@
+let run_parallel_for num_domains ?(chunk_size=0) length f =
+	let pool = Domainslib.Task.setup_pool ~num_domains:(num_domains - 1) () in
+	Domainslib.Task.run pool (fun _ -> Domainslib.Task.parallel_for pool ~chunk_size ~start:0 ~finish:(length-1) ~body:f);
+	Domainslib.Task.teardown_pool pool
+
+let run_parallel_on_array pool a f =
+	let f' idx = f a.(idx) in
+	let old = Atomic.exchange Timer.in_parallel true in
+	Domainslib.Task.run pool (fun _ -> Domainslib.Task.parallel_for pool ~start:0 ~finish:(Array.length a - 1) ~body:f');
+	Atomic.set Timer.in_parallel old
+
+let run_parallel_on_seq pool seq f =
+	run_parallel_on_array pool (Array.of_seq seq) f
+
+let run_in_new_pool f =
+	let pool = Domainslib.Task.setup_pool ~num_domains:(Domain.recommended_domain_count()) () in
+	Std.finally (fun () -> Domainslib.Task.teardown_pool pool) f pool

src/core/path.ml

@@ -317,6 +317,8 @@ let module_name_of_file file =
 	| [] ->
 		Globals.die "" __LOC__
 
+let mkdir_mutex = Mutex.create ()
+
 let rec create_file bin ext acc = function
 	| [] -> Globals.die "" __LOC__
 	| d :: [] ->
@@ -327,7 +329,7 @@ let rec create_file bin ext acc = function
 		ch
 	| d :: l ->
 		let dir = String.concat "/" (List.rev (d :: acc)) in
-		if not (Sys.file_exists (remove_trailing_slash dir)) then Unix.mkdir dir 0o755;
+		Mutex.protect mkdir_mutex (fun () -> if not (Sys.file_exists (remove_trailing_slash dir)) then Unix.mkdir dir 0o755);
 		create_file bin ext (d :: acc) l
 
 let rec mkdir_recursive base dir_list =

src/core/timer.ml

@@ -25,6 +25,8 @@ type timer_infos = {
 	mutable calls : int;
 }
 
+let in_parallel = Atomic.make false
+
 let measure_times = ref false
 
 let get_time = Extc.time
@@ -70,7 +72,7 @@ let rec close now t =
 			close now tt
 
 let timer id =
-	if !measure_times then (
+	if !measure_times && not (Atomic.get in_parallel) then (
 		let t = new_timer id in
 		curtime := t :: !curtime;
 		(function() -> close (get_time()) t)

src/dune

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