[filters] Add AtomicLazy, use it for exceptions (#12340)

* Add AtomicLazy, use it for exceptions

* Use a mutex

* Whoops, partial update is bad..

* Simplify

* Match again inside mutex

Author: kLabz

src/core/ds/atomicLazy.ml

@@ -0,0 +1,24 @@
+open Atomic
+
+type 'a t = {
+	mutable value: 'a option;
+	mutex: Mutex.t;
+	compute: unit->'a
+}
+
+let from_fun f =
+	{ value = None; mutex = Mutex.create (); compute = (fun () -> f()) }
+
+let force lazy_val =
+	match lazy_val.value with
+		| None ->
+			Mutex.protect lazy_val.mutex (fun () ->
+				match lazy_val.value with
+					| None ->
+						let result = lazy_val.compute () in
+						lazy_val.value <- Some result;
+						result
+					| Some result -> result
+			)
+		| Some v -> v
+

src/filters/exception/exceptionInit.ml

@@ -6,6 +6,7 @@ open Exceptions
 open Type
 open Typecore
 open ExceptionFunctions
+open AtomicLazy
 
 let create_exception_context tctx =
 	match tctx.com.platform with (* TODO: implement for all targets *)
@@ -28,15 +29,15 @@ let create_exception_context tctx =
 			let t = Typeload.load_instance tctx (tp config.ec_base_throw) ParamSpawnMonos LoadNormal in
 			if is_dynamic t then t_dynamic
 			else t
-		and haxe_exception = Lazy.from_fun (fun () ->
+		and haxe_exception = AtomicLazy.from_fun (fun () ->
 			match Typeload.load_instance tctx (tp haxe_exception_type_path) ParamSpawnMonos LoadNormal with
 			| TInst(cls,_) as t -> t,cls
 			| _ -> raise_typing_error "haxe.Exception is expected to be a class" null_pos)
-		and value_exception = Lazy.from_fun (fun () ->
+		and value_exception = AtomicLazy.from_fun (fun () ->
 			match Typeload.load_instance tctx (tp value_exception_type_path) ParamSpawnMonos LoadNormal with
 			| TInst(cls,_) as t -> t,cls
 			| _ -> raise_typing_error "haxe.ValueException is expected to be a class" null_pos)
-		and haxe_native_stack_trace = Lazy.from_fun (fun () ->
+		and haxe_native_stack_trace = AtomicLazy.from_fun (fun () ->
 			match Typeload.load_instance tctx (tp (["haxe"],"NativeStackTrace")) ParamSpawnMonos LoadNormal with
 			| TInst(cls,_) -> cls
 			| TAbstract({ a_impl = Some cls },_) -> cls

src/filters/exception/exceptions.ml

@@ -3,6 +3,7 @@ open Type
 open PlatformConfig
 open Error
 open ExceptionFunctions
+open AtomicLazy
 
 type context = {
 	scom : SafeCom.t;
@@ -12,32 +13,32 @@ type context = {
 	base_throw_type : Type.t;
 	throws_anything : bool;
 	catches_anything : bool;
-	haxe_exception : (Type.t * tclass) Lazy.t;
-	haxe_native_stack_trace : tclass Lazy.t;
-	value_exception : (Type.t * tclass) Lazy.t;
+	haxe_exception : (Type.t * tclass) AtomicLazy.t;
+	haxe_native_stack_trace : tclass AtomicLazy.t;
+	value_exception : (Type.t * tclass) AtomicLazy.t;
 	is_of_type : (tclass * tclass_field * Type.t);
 }
 
 let haxe_exception_class ctx =
-	let cls = snd (Lazy.force ctx.haxe_exception) in
+	let cls = snd (AtomicLazy.force ctx.haxe_exception) in
 	assert (ctx.scom.curclass != null_class);
 	add_dependency ctx.scom.curclass.cl_module cls.cl_module MDepFromTyping;
 	cls
 
 let haxe_exception_type ctx =
-	let t,cls = Lazy.force ctx.haxe_exception in
+	let t,cls = AtomicLazy.force ctx.haxe_exception in
 	assert (ctx.scom.curclass != null_class);
 	add_dependency ctx.scom.curclass.cl_module cls.cl_module MDepFromTyping;
 	t
 
 let value_exception_class ctx =
-	let cls = snd (Lazy.force ctx.value_exception) in
+	let cls = snd (AtomicLazy.force ctx.value_exception) in
 	assert (ctx.scom.curclass != null_class);
 	add_dependency ctx.scom.curclass.cl_module cls.cl_module MDepFromTyping;
 	cls
 
 let value_exception_type ctx =
-	let t,cls = Lazy.force ctx.value_exception in
+	let t,cls = AtomicLazy.force ctx.value_exception in
 	assert (ctx.scom.curclass != null_class);
 	add_dependency ctx.scom.curclass.cl_module cls.cl_module MDepFromTyping;
 	t

src/filters/exception/saveStacks.ml

@@ -4,6 +4,7 @@ open Type
 open Error
 open ExceptionFunctions
 open Exceptions
+open AtomicLazy
 
 (**
 	Inserts `haxe.NativeStackTrace.saveStack(e)` in non-haxe.Exception catches.
@@ -20,7 +21,7 @@ let insert_save_stacks ectx scom =
 			check_expr contains_insertion_points e
 	in
 	let save_exception_stack catch_var =
-		let native_stack_trace_cls = Lazy.force ectx.haxe_native_stack_trace in
+		let native_stack_trace_cls = AtomicLazy.force ectx.haxe_native_stack_trace in
 		let method_field =
 			try PMap.find "saveStack" native_stack_trace_cls.cl_statics
 			with Not_found -> raise_typing_error ("haxe.NativeStackTrace has no field saveStack") catch_var.v_pos
@@ -65,7 +66,7 @@ let insert_save_stacks ectx scom =
 	Adds `this.__shiftStack()` calls to constructors of classes which extend `haxe.Exception`
 *)
 let patch_constructors ectx =
-	match fst (Lazy.force ectx.haxe_exception) with
+	match fst (AtomicLazy.force ectx.haxe_exception) with
 	(* Add only if `__shiftStack` method exists *)
 	| TInst(cls,_) when PMap.mem "__shiftStack" cls.cl_fields ->
 		(fun mt ->