allow disable parallel (for benchmark purposes) (#12238)

* allow disable parallel (for benchmark purposes)

* add -D disable-parallelism

---------

Co-authored-by: Simon Krajewski <[email protected]>

src-json/define.json

@@ -78,6 +78,11 @@
 		"define": "disable-hxb-optimizations",
 		"doc": "Disable shortcuts used by hxb cache to speed up display requests."
 	},
+	{
+		"name": "DisableParallelism",
+		"define": "disable-parallelism",
+		"doc": "Disable all uses of parallelism in the compiler."
+	},
 	{
 		"name": "DisableUnicodeStrings",
 		"define": "disable-unicode-strings",

src/compiler/compiler.ml

@@ -270,6 +270,7 @@ module Setup = struct
 end
 
 let check_defines com =
+	if defined com Define.DisableParallelism then Parallel.enable := false;
 	PMap.iter (fun k v ->
 		try
 			let reason = Hashtbl.find Define.deprecation_lut k in

src/compiler/serverCompilationContext.ml

@@ -44,6 +44,7 @@ let reset sctx =
 	Hashtbl.clear sctx.changed_directories;
 	sctx.was_compilation <- false;
 	Parser.reset_state();
+	Parallel.enable := true;
 	Hashtbl.clear DeprecationCheck.warned_positions;
 	stats.s_files_parsed := 0;
 	stats.s_classes_built := 0;

src/context/parallel.ml

@@ -1,21 +1,36 @@
+let enable = ref true
+
 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
+	if not !enable then begin
+		for i = 0 to length - 1 do
+			f i
+		done
+	end else
+		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
 
 module ParallelArray = struct
 	let iter pool f a =
-		let f' idx = f a.(idx) in
-		Domainslib.Task.parallel_for pool ~start:0 ~finish:(Array.length a - 1) ~body:f'
+		match pool with
+		| None ->
+			Array.iter f a
+		| Some pool ->
+			let f' idx = f a.(idx) in
+			Domainslib.Task.parallel_for pool ~start:0 ~finish:(Array.length a - 1) ~body:f'
 
 	let map pool f a x =
-		let length = Array.length a in
-		let a_out = Array.make length x in
-		let f' idx =
-			Array.unsafe_set a_out idx (f (Array.unsafe_get a idx))
-		in
-		Domainslib.Task.parallel_for pool ~start:0 ~finish:(length - 1) ~body:f';
-		a_out
+		match pool with
+		| None ->
+			Array.map f a
+		| Some pool ->
+			let length = Array.length a in
+			let a_out = Array.make length x in
+			let f' idx =
+				Array.unsafe_set a_out idx (f (Array.unsafe_get a idx))
+			in
+			Domainslib.Task.parallel_for pool ~start:0 ~finish:(length - 1) ~body:f';
+			a_out
 end
 
 module ParallelSeq = struct
@@ -24,5 +39,8 @@ module ParallelSeq = struct
 end
 
 let run_in_new_pool timer_ctx f =
-	let pool = Timer.time timer_ctx ["domainslib";"setup"] (Domainslib.Task.setup_pool ~num_domains:(Domain.recommended_domain_count() - 1)) () in
-	Std.finally (fun () -> Timer.time timer_ctx ["domainslib";"teardown"] Domainslib.Task.teardown_pool pool) (Domainslib.Task.run pool) (fun () -> f pool)
+	if not !enable then
+		f None
+	else
+		let pool = Timer.time timer_ctx ["domainslib";"setup"] (Domainslib.Task.setup_pool ~num_domains:(Domain.recommended_domain_count() - 1)) () in
+		Std.finally (fun () -> Timer.time timer_ctx ["domainslib";"teardown"] Domainslib.Task.teardown_pool pool) (Domainslib.Task.run pool) (fun () -> f (Some pool))