move unification stacks into unification context (#12080)

src/compiler/hxb/hxbWriter.ml

@@ -1017,7 +1017,7 @@ module HxbWriter = struct
 		end
 
 	and write_anon_ref writer (an : tanon) =
-		let pfm = Option.get (writer.anon_id#identify_anon ~strict:true an) in
+		let pfm = writer.anon_id#identify_anon ~strict:true an in
 		try
 			let index = Pool.get writer.anons pfm.pfm_path in
 			Chunk.write_u8 writer.chunk 0;

src/context/abstractCast.ml

@@ -110,7 +110,7 @@ and do_check_cast ctx uctx tleft eright p =
 
 and cast_or_unify_raise ctx ?(uctx=None) tleft eright p =
 	let uctx = match uctx with
-		| None -> default_unification_context
+		| None -> default_unification_context ()
 		| Some uctx -> uctx
 	in
 	try
@@ -200,7 +200,7 @@ let find_array_write_access ctx a tl e1 e2 p =
 		raise_typing_error (Printf.sprintf "No @:arrayAccess function for %s accepts arguments of %s and %s" (s_type (TAbstract(a,tl))) (s_type e1.etype) (s_type e2.etype)) p
 
 let find_multitype_specialization' com a pl p =
-	let uctx = default_unification_context in
+	let uctx = default_unification_context () in
 	let m = mk_mono() in
 	let tl,definitive_types = Abstract.find_multitype_params a pl in
 	if com.platform = Globals.Js && a.a_path = (["haxe";"ds"],"Map") then begin match tl with

src/context/typecore.ml

@@ -408,7 +408,7 @@ let unify_raise_custom uctx t1 t2 p =
 			(* no untyped check *)
 			raise_error_msg (Unify l) p
 
-let unify_raise = unify_raise_custom default_unification_context
+let unify_raise a b = unify_raise_custom (default_unification_context()) a b
 
 let save_locals ctx =
 	let locals = ctx.f.locals in

src/core/abstract.ml

@@ -63,8 +63,6 @@ let find_to uctx b ab tl =
 				Some(find_field_to uctx a b ab tl)
 		)
 
-let underlying_type_stack = new_rec_stack()
-
 (**
 	Returns type parameters and the list of types, which should be known at compile time
 	to be able to choose multitype specialization.
@@ -98,14 +96,14 @@ let rec find_multitype_params a pl =
 		tl,!definitive_types
 
 and find_multitype_specialization_type a pl =
-	let uctx = default_unification_context in
+	let uctx = default_unification_context () in
 	let m = mk_mono() in
 	let tl,definitive_types = find_multitype_params a pl in
 	ignore(find_to uctx m a tl);
 	if List.exists (fun t -> has_mono t) definitive_types then raise Not_found;
 	follow m
 
-and get_underlying_type ?(return_first=false) a pl =
+and get_underlying_type' stack ?(return_first=false) a pl =
 	let maybe_recurse t =
 		let rec loop t = match t with
 			| TMono r ->
@@ -119,12 +117,12 @@ and get_underlying_type ?(return_first=false) a pl =
 			| TType (t,tl) ->
 				loop (apply_typedef t tl)
 			| TAbstract(a,tl) when not (Meta.has Meta.CoreType a.a_meta) ->
-				if rec_stack_exists (fast_eq t) underlying_type_stack then begin
+				if rec_stack_exists (fast_eq t) stack then begin
 					let pctx = print_context() in
-					let s = String.concat " -> " (List.map (fun t -> s_type pctx t) (List.rev (t :: underlying_type_stack.rec_stack))) in
+					let s = String.concat " -> " (List.map (fun t -> s_type pctx t) (List.rev (t :: stack.rec_stack))) in
 					raise_typing_error ("Abstract chain detected: " ^ s) a.a_pos
 				end;
-				get_underlying_type a tl
+				get_underlying_type' stack a tl
 			| _ ->
 				t
 		in
@@ -132,7 +130,7 @@ and get_underlying_type ?(return_first=false) a pl =
 			Even if only the first underlying type was requested
 			keep traversing to detect mutually recursive abstracts
 		*)
-		let result = rec_stack_loop underlying_type_stack (TAbstract(a,pl)) loop t in
+		let result = rec_stack_loop stack (TAbstract(a,pl)) loop t in
 		if return_first then t
 		else result
 	in
@@ -145,6 +143,9 @@ and get_underlying_type ?(return_first=false) a pl =
 		else
 			maybe_recurse (apply_params a.a_params pl a.a_this)
 
+and get_underlying_type ?(return_first=false) a pl =
+	get_underlying_type' (new_rec_stack()) ~return_first a pl
+
 and follow_with_abstracts t = match follow t with
 	| TAbstract(a,tl) when not (Meta.has Meta.CoreType a.a_meta) ->
 		follow_with_abstracts (get_underlying_type a tl)

src/core/tUnification.ml

@@ -40,6 +40,10 @@ type type_param_mode =
 	| TpDefault
 	| TpDefinition of type_param_unification_context
 
+type 'a rec_stack = {
+	mutable rec_stack : 'a list;
+}
+
 type unification_context = {
 	allow_transitive_cast   : bool;
 	allow_abstract_cast     : bool; (* allows a non-transitive abstract cast (from,to,@:from,@:to) *)
@@ -49,6 +53,11 @@ type unification_context = {
 	equality_underlying     : bool;
 	strict_field_kind       : bool;
 	type_param_mode         : type_param_mode;
+	unify_stack             : (t * t) rec_stack;
+	eq_stack                : (t * t) rec_stack;
+	variance_stack          : (t * t) rec_stack;
+	abstract_cast_stack     : (t * t) rec_stack;
+	unify_new_monos         : t rec_stack;
 }
 
 type unify_min_result =
@@ -66,7 +75,9 @@ let check_constraint name f =
 let unify_ref : (unification_context -> t -> t -> unit) ref = ref (fun _ _ _ -> ())
 let unify_min_ref : (unification_context -> t -> t list -> unify_min_result) ref = ref (fun _ _ _ -> assert false)
 
-let default_unification_context = {
+let new_rec_stack() = { rec_stack = [] }
+
+let default_unification_context () = {
 	allow_transitive_cast   = true;
 	allow_abstract_cast     = true;
 	allow_dynamic_to_cast   = true;
@@ -75,6 +86,11 @@ let default_unification_context = {
 	equality_underlying     = false;
 	strict_field_kind       = false;
 	type_param_mode         = TpDefault;
+	unify_stack             = new_rec_stack();
+	eq_stack                = new_rec_stack();
+	variance_stack          = new_rec_stack();
+	abstract_cast_stack     = new_rec_stack();
+	unify_new_monos         = new_rec_stack();
 }
 
 (* Unify like targets (e.g. Java) probably would. *)
@@ -87,6 +103,11 @@ let native_unification_context = {
 	allow_arg_name_mismatch = true;
 	strict_field_kind       = false;
 	type_param_mode         = TpDefault;
+	unify_stack             = new_rec_stack();
+	eq_stack                = new_rec_stack();
+	variance_stack          = new_rec_stack();
+	abstract_cast_stack     = new_rec_stack();
+	unify_new_monos         = new_rec_stack();
 }
 
 module Monomorph = struct
@@ -193,14 +214,14 @@ module Monomorph = struct
 			()
 		| CTypes tl ->
 			List.iter (fun (t2,name) ->
-				let f () = (!unify_ref) default_unification_context t t2 in
+				let f () = (!unify_ref) (default_unification_context()) t t2 in
 				match name with
 				| Some name -> check_constraint name f
 				| None -> f()
 			) tl
 		| CStructural(fields,is_open) ->
 			let t2 = mk_anon ~fields (ref Closed) in
-			(!unify_ref) default_unification_context t t2
+			(!unify_ref) (default_unification_context()) t t2
 		| CMixed l ->
 			List.iter (fun constr -> check_down_constraints constr t) l
 
@@ -224,7 +245,7 @@ module Monomorph = struct
 	let check_up_constraints m t =
 		List.iter (fun (t2,constraint_name) ->
 			let check() =
-				(!unify_ref) default_unification_context t2 t
+				(!unify_ref) (default_unification_context()) t2 t
 			in
 			match constraint_name with
 			| Some name -> check_constraint name check
@@ -519,11 +540,6 @@ let unify_kind ~(strict:bool) k1 k2 =
 				| _ -> false)
 		| _ -> false
 
-type 'a rec_stack = {
-	mutable rec_stack : 'a list;
-}
-
-let new_rec_stack() = { rec_stack = [] }
 let rec_stack_exists f s = List.exists f s.rec_stack
 let rec_stack_memq v s = List.memq v s.rec_stack
 let rec_stack_loop stack value f arg =
@@ -536,8 +552,6 @@ let rec_stack_loop stack value f arg =
 		stack.rec_stack <- List.tl stack.rec_stack;
 		raise e
 
-let eq_stack = new_rec_stack()
-
 let rec_stack stack value fcheck frun ferror =
 	if not (rec_stack_exists fcheck stack) then begin
 		try
@@ -604,11 +618,11 @@ let rec type_eq uctx a b =
 	| TType (t1,tl1), TType (t2,tl2) when (t1 == t2 || (param = EqCoreType && t1.t_path = t2.t_path)) && List.length tl1 = List.length tl2 ->
 		type_eq_params uctx a b tl1 tl2
 	| TType (t,tl) , _ when can_follow a ->
-		rec_stack eq_stack (a,b) (fast_eq_pair (a,b))
+		rec_stack uctx.eq_stack (a,b) (fast_eq_pair (a,b))
 			(fun() -> try_apply_params_rec t.t_params tl t.t_type (fun a -> type_eq uctx a b))
 			(fun l -> error (cannot_unify a b :: l))
 	| _ , TType (t,tl) when can_follow b ->
-		rec_stack eq_stack (a,b) (fast_eq_pair (a,b))
+		rec_stack uctx.eq_stack (a,b) (fast_eq_pair (a,b))
 			(fun() -> try_apply_params_rec t.t_params tl t.t_type (type_eq uctx a))
 			(fun l -> error (cannot_unify a b :: l))
 	| TEnum (e1,tl1) , TEnum (e2,tl2) ->
@@ -711,27 +725,22 @@ let type_iseq uctx a b =
 
 let type_iseq_strict a b =
 	try
-		type_eq {default_unification_context with equality_kind = EqStricter} a b;
+		type_eq {(default_unification_context()) with equality_kind = EqStricter} a b;
 		true
 	with Unify_error _ ->
 		false
 
-let unify_stack = new_rec_stack()
-let variance_stack = new_rec_stack()
-let abstract_cast_stack = new_rec_stack()
-let unify_new_monos = new_rec_stack()
-
-let print_stacks() =
+let print_stacks uctx =
 	let ctx = print_context() in
 	let st = s_type ctx in
 	print_endline "unify_stack";
-	List.iter (fun (a,b) -> Printf.printf "\t%s , %s\n" (st a) (st b)) unify_stack.rec_stack;
+	List.iter (fun (a,b) -> Printf.printf "\t%s , %s\n" (st a) (st b)) uctx.unify_stack.rec_stack;
 	print_endline "variance_stack";
-	List.iter (fun (a,b) -> Printf.printf "\t%s , %s\n" (st a) (st b)) variance_stack.rec_stack;
+	List.iter (fun (a,b) -> Printf.printf "\t%s , %s\n" (st a) (st b)) uctx.variance_stack.rec_stack;
 	print_endline "monos";
-	List.iter (fun m -> print_endline ("\t" ^ st m)) unify_new_monos.rec_stack;
+	List.iter (fun m -> print_endline ("\t" ^ st m)) uctx.unify_new_monos.rec_stack;
 	print_endline "abstract_cast_stack";
-	List.iter (fun (a,b) -> Printf.printf "\t%s , %s\n" (st a) (st b)) abstract_cast_stack.rec_stack
+	List.iter (fun (a,b) -> Printf.printf "\t%s , %s\n" (st a) (st b)) uctx.abstract_cast_stack.rec_stack
 
 let rec unify (uctx : unification_context) a b =
 	if a == b then
@@ -748,12 +757,12 @@ let rec unify (uctx : unification_context) a b =
 		| None -> if uctx.equality_kind = EqStricter || not (link uctx t b a) then error [cannot_unify a b]
 		| Some t -> unify uctx a t)
 	| TType (t,tl) , _ ->
-		rec_stack unify_stack (a,b)
+		rec_stack uctx.unify_stack (a,b)
 			(fun(a2,b2) -> fast_eq_unbound_mono a a2 && fast_eq b b2)
 			(fun() -> try_apply_params_rec t.t_params tl t.t_type (fun a -> unify uctx a b))
 			(fun l -> error (cannot_unify a b :: l))
 	| _ , TType (t,tl) ->
-		rec_stack unify_stack (a,b)
+		rec_stack uctx.unify_stack (a,b)
 			(fun(a2,b2) -> fast_eq a a2 && fast_eq_unbound_mono b b2)
 			(fun() -> try_apply_params_rec t.t_params tl t.t_type (unify uctx a))
 			(fun l -> error (cannot_unify a b :: l))
@@ -859,22 +868,22 @@ let rec unify (uctx : unification_context) a b =
 				(match f2.cf_kind with
 				| Var { v_read = AccNo } | Var { v_read = AccNever } ->
 					(* we will do a recursive unification, so let's check for possible recursion *)
-					let old_monos = unify_new_monos.rec_stack in
-					unify_new_monos.rec_stack <- !monos @ unify_new_monos.rec_stack;
-					rec_stack unify_stack (ft,f2.cf_type)
-						(fun (a2,b2) -> fast_eq b2 f2.cf_type && fast_eq_mono unify_new_monos.rec_stack ft a2)
-						(fun() -> try unify_with_access uctx f1 ft f2 with e -> unify_new_monos.rec_stack <- old_monos; raise e)
+					let old_monos = uctx.unify_new_monos.rec_stack in
+					uctx.unify_new_monos.rec_stack <- !monos @ uctx.unify_new_monos.rec_stack;
+					rec_stack uctx.unify_stack (ft,f2.cf_type)
+						(fun (a2,b2) -> fast_eq b2 f2.cf_type && fast_eq_mono uctx.unify_new_monos.rec_stack ft a2)
+						(fun() -> try unify_with_access uctx f1 ft f2 with e -> uctx.unify_new_monos.rec_stack <- old_monos; raise e)
 						(fun l -> error (invalid_field n :: l));
-					unify_new_monos.rec_stack <- old_monos;
+					uctx.unify_new_monos.rec_stack <- old_monos;
 				| Method MethNormal | Method MethInline | Var { v_write = AccNo } | Var { v_write = AccNever } ->
 					(* same as before, but unification is reversed (read-only var) *)
-					let old_monos = unify_new_monos.rec_stack in
-					unify_new_monos.rec_stack <- !monos @ unify_new_monos.rec_stack;
-					rec_stack unify_stack (f2.cf_type,ft)
-						(fun(a2,b2) -> fast_eq_mono unify_new_monos.rec_stack b2 ft && fast_eq f2.cf_type a2)
-						(fun() -> try unify_with_access uctx f1 ft f2 with e -> unify_new_monos.rec_stack <- old_monos; raise e)
+					let old_monos = uctx.unify_new_monos.rec_stack in
+					uctx.unify_new_monos.rec_stack <- !monos @ uctx.unify_new_monos.rec_stack;
+					rec_stack uctx.unify_stack (f2.cf_type,ft)
+						(fun(a2,b2) -> fast_eq_mono uctx.unify_new_monos.rec_stack b2 ft && fast_eq f2.cf_type a2)
+						(fun() -> try unify_with_access uctx f1 ft f2 with e -> uctx.unify_new_monos.rec_stack <- old_monos; raise e)
 						(fun l -> error (invalid_field n :: l));
-					unify_new_monos.rec_stack <- old_monos;
+					uctx.unify_new_monos.rec_stack <- old_monos;
 				| _ ->
 					(* will use fast_eq, which have its own stack *)
 					try
@@ -1074,7 +1083,7 @@ and get_nested_context uctx =
 	{uctx with allow_abstract_cast = true}
 
 and unifies_with_abstract uctx a b f =
-	rec_stack_default abstract_cast_stack (a,b) (fast_eq_pair (a,b)) (fun() ->
+	rec_stack_default uctx.abstract_cast_stack (a,b) (fast_eq_pair (a,b)) (fun() ->
 		(uctx.allow_transitive_cast && f {uctx with allow_transitive_cast = false}) || f uctx
 	) false
 
@@ -1153,7 +1162,7 @@ and unify_with_variance uctx f t1 t2 =
 	let t1 = follow_without_type t1 in
 	let t2 = follow_without_type t2 in
 	let fail () = error [cannot_unify t1 t2] in
-	let unify_rec f = rec_stack variance_stack (t1,t2) (fast_eq_pair (t1,t2)) f (fun _ -> fail()) in
+	let unify_rec f = rec_stack uctx.variance_stack (t1,t2) (fast_eq_pair (t1,t2)) f (fun _ -> fail()) in
 	let unify_nested t1 t2 = with_variance (get_nested_context uctx) f t1 t2 in
 	let unify_tls tl1 tl2 = List.iter2 unify_nested tl1 tl2 in
 	let get_this_type ab tl = follow_without_type (apply_params ab.a_params tl ab.a_this) in
@@ -1162,7 +1171,7 @@ and unify_with_variance uctx f t1 t2 =
 	let unifies_abstract uctx a b ab tl ats =
 		try
 			let uctx = get_abstract_context uctx a b ab in
-			rec_stack_default abstract_cast_stack (a,b) (fast_eq_pair (a,b)) (fun() ->
+			rec_stack_default uctx.abstract_cast_stack (a,b) (fast_eq_pair (a,b)) (fun() ->
 				List.exists (does_func_unify_arg (fun at ->
 					let at = apply_params ab.a_params tl at in
 					if ats == ab.a_to then
@@ -1242,19 +1251,21 @@ and unify_with_access uctx f1 t1 f2 =
 
 let does_unify a b =
 	try
-		unify default_unification_context a b;
+		unify (default_unification_context()) a b;
 		true
 	with Unify_error _ ->
 		false
 
 let unify_custom = unify
-let unify = unify default_unification_context
+let unify a b = unify (default_unification_context()) a b
 
 let type_eq_custom = type_eq
-let type_eq param = type_eq {default_unification_context with equality_kind = param}
+
+let type_eq param a b = type_eq {(default_unification_context()) with equality_kind = param} a b
 
 let type_iseq_custom = type_iseq
-let type_iseq = type_iseq default_unification_context
+
+let type_iseq a b = type_iseq (default_unification_context ()) a b
 
 module UnifyMinT = struct
 	let collect_base_types t =

src/typing/tanon_identification.ml

@@ -70,7 +70,12 @@ object(self)
 			equality_underlying = false;
 			strict_field_kind = true;
 			type_param_mode = TpDefault;
-		} else {default_unification_context with equality_kind = EqDoNotFollowNull} in
+			unify_stack = new_rec_stack();
+			eq_stack = new_rec_stack();
+			variance_stack = new_rec_stack();
+			abstract_cast_stack = new_rec_stack();
+			unify_new_monos = new_rec_stack();
+		} else {(default_unification_context()) with equality_kind = EqDoNotFollowNull} in
 
 		let check () =
 			let pair_up fields =
@@ -160,11 +165,11 @@ object(self)
 		match !(an.a_status) with
 		| ClassStatics {cl_path = path} | EnumStatics {e_path = path} | AbstractStatics {a_path = path} ->
 			begin try
-				Some (Hashtbl.find pfms path)
+				Hashtbl.find pfms path
 			with Not_found ->
 				let pfm = make_pfm path in
 				self#add_pfm path pfm;
-				Some pfm
+				pfm
 			end
 		| _ ->
 			let arity,fields = PMap.fold (fun cf (i,acc) ->
@@ -173,7 +178,7 @@ object(self)
 			) an.a_fields (0,PMap.empty) in
 			let an = { a_fields = fields; a_status = an.a_status; } in
 			try
-				Some (self#find_compatible ~strict arity (TAnon an))
+				self#find_compatible ~strict arity (TAnon an)
 			with Not_found ->
 				let id = num in
 				num <- num + 1;
@@ -186,7 +191,7 @@ object(self)
 					pfm_arity = count_fields an.a_fields;
 				} in
 				self#add_pfm path pfm;
-				Some pfm
+				pfm
 
 	method identify ?(strict:bool = false) (accept_anons : bool) (t : Type.t) =
 		match t with
@@ -205,7 +210,7 @@ object(self)
 		| TLazy f ->
 			self#identify accept_anons (lazy_type f)
 		| TAnon an when accept_anons && not (PMap.is_empty an.a_fields) ->
-			self#identify_anon ~strict an
+			Some (self#identify_anon ~strict an)
 		| _ ->
 			None
 end

src/typing/typeloadCheck.ml

@@ -52,7 +52,7 @@ let valid_redefinition map1 map2 f1 t1 f2 t2 = (* child, parent *)
 		type_param_pairs = [];
 		known_type_params = f1.cf_params
 	} in
-	let uctx = {default_unification_context with type_param_mode = TpDefinition tctx} in
+	let uctx = {(default_unification_context()) with type_param_mode = TpDefinition tctx} in
 	let valid t1 t2 =
 		unify_custom uctx t1 t2;
 		if is_null t1 <> is_null t2 || ((follow t1) == t_dynamic && (follow t2) != t_dynamic) then raise (Unify_error [Cannot_unify (t1,t2)]);

src/typing/typer.ml

@@ -232,7 +232,7 @@ let rec unify_min_raise ctx (el:texpr list) : t =
 					raise Exit
 			) el in
 			let common_types = UnifyMinT.collect_base_types tr0 in
-			let tr = match UnifyMinT.unify_min' default_unification_context common_types rets with
+			let tr = match UnifyMinT.unify_min' (default_unification_context()) common_types rets with
 			| UnifyMinOk t ->
 				t
 			| UnifyMinError(l,index) ->
@@ -255,7 +255,7 @@ let rec unify_min_raise ctx (el:texpr list) : t =
 			let common_types = (match List.rev dyn_types with [] -> common_types | l -> common_types @ l) in
 			let el = List.tl el in
 			let tl = List.map (fun e -> e.etype) el in
-			begin match UnifyMinT.unify_min' default_unification_context common_types tl with
+			begin match UnifyMinT.unify_min' (default_unification_context()) common_types tl with
 			| UnifyMinOk t ->
 				t
 			| UnifyMinError(l,index) ->

src/typing/typerBase.ml

@@ -326,7 +326,7 @@ let unify_static_extension ctx e t p =
 	if multitype_involed e.etype t then
 		AbstractCast.cast_or_unify_raise ctx t e p
 	else begin
-		Type.unify_custom {default_unification_context with allow_dynamic_to_cast = false} e.etype t;
+		Type.unify_custom {(default_unification_context()) with allow_dynamic_to_cast = false} e.etype t;
 		e
 	end