review all global stacks using explicit primitives for stack push/pop: prevent leaks from unhandled exception.

use memq instead of mem for some lookups (faster)
close #7667

src/codegen/codegen.ml

@@ -476,7 +476,7 @@ let default_cast ?(vtmp="$t") com e texpr t p =
 	mk (TBlock [var;check;vexpr]) t p
 
 module UnificationCallback = struct
-	let tf_stack = ref []
+	let tf_stack = new_rec_stack()
 
 	let check_call_params f el tl =
 		let rec loop acc el tl = match el,tl with
@@ -544,7 +544,7 @@ module UnificationCallback = struct
 					| _ -> e
 				end
 			| TReturn (Some e1) ->
-				begin match !tf_stack with
+				begin match tf_stack.rec_stack with
 					| tf :: _ -> { e with eexpr = TReturn (Some (f e1 tf.tf_type))}
 					| _ -> e
 				end
@@ -553,8 +553,7 @@ module UnificationCallback = struct
 		in
 		match e.eexpr with
 			| TFunction tf ->
-				tf_stack := tf :: !tf_stack;
-				Std.finally (fun() -> tf_stack := List.tl !tf_stack) (fun() -> {e with eexpr = TFunction({tf with tf_expr = run f tf.tf_expr})}) ()
+				rec_stack_loop tf_stack tf (fun() -> {e with eexpr = TFunction({tf with tf_expr = run f tf.tf_expr})}) ()
 			| _ ->
 				check (Type.map_expr (run ff) e)
 end;;

src/context/abstractCast.ml

@@ -5,7 +5,7 @@ open Type
 open Typecore
 open Error
 
-let cast_stack = ref []
+let cast_stack = new_rec_stack()
 
 let make_static_call ctx c cf a pl args t p =
 	if cf.cf_kind = Method MethMacro then begin
@@ -26,10 +26,8 @@ let make_static_call ctx c cf a pl args t p =
 
 let do_check_cast ctx tleft eright p =
 	let recurse cf f =
-		if cf == ctx.curfield || List.mem cf !cast_stack then error "Recursive implicit cast" p;
-		cast_stack := cf :: !cast_stack;
-		let r = Std.finally (fun() -> cast_stack := List.tl !cast_stack) f () in
-		r
+		if cf == ctx.curfield || rec_stack_memq cf cast_stack then error "Recursive implicit cast" p;
+		rec_stack_loop cast_stack cf f ()
 	in
 	let find a tl f =
 		let tcf,cf = f() in

src/core/abstract.ml

@@ -47,11 +47,10 @@ let find_from ab pl a b =
 	else
 		find_field_from ab pl a b
 
-let underlying_type_stack = ref []
+let underlying_type_stack = new_rec_stack()
 
 let rec get_underlying_type a pl =
 	let maybe_recurse t =
-		underlying_type_stack := (TAbstract(a,pl)) :: !underlying_type_stack;
 		let rec loop t = match t with
 			| TMono r ->
 				(match !r with
@@ -64,17 +63,16 @@ let rec get_underlying_type a pl =
 			| TType (t,tl) ->
 				loop (apply_params t.t_params tl t.t_type)
 			| TAbstract(a,tl) when not (Meta.has Meta.CoreType a.a_meta) ->
-				if List.exists (fast_eq t) !underlying_type_stack then begin
+				if rec_stack_exists (fast_eq t) underlying_type_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))) in
-					underlying_type_stack := [];
+					let s = String.concat " -> " (List.map (fun t -> s_type pctx t) (List.rev (t :: underlying_type_stack.rec_stack))) in
 					error ("Abstract chain detected: " ^ s) a.a_pos
 				end;
 				get_underlying_type a tl
 			| _ ->
 				t
 		in
-		Std.finally (fun() -> underlying_type_stack := List.tl !underlying_type_stack) loop t
+		rec_stack_loop underlying_type_stack (TAbstract(a,pl)) loop t
 	in
 	try
 		if not (Meta.has Meta.MultiType a.a_meta) then raise Not_found;

src/core/type.ml

@@ -1750,50 +1750,57 @@ let unify_kind k1 k2 =
 			| MethDynamic, MethNormal -> true
 			| _ -> false
 
-let eq_stack = ref []
+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 =
+	stack.rec_stack <- value :: stack.rec_stack;
+	try
+		let r = f arg in
+		stack.rec_stack <- List.tl stack.rec_stack;
+		r
+	with e ->
+		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 (List.exists fcheck !stack) then begin
+	if not (rec_stack_exists fcheck stack) then begin
 		try
-			stack := value :: !stack;
+			stack.rec_stack <- value :: stack.rec_stack;
 			let v = frun() in
-			stack := List.tl !stack;
+			stack.rec_stack <- List.tl stack.rec_stack;
 			v
 		with
 			Unify_error l ->
-				stack := List.tl !stack;
+				stack.rec_stack <- List.tl stack.rec_stack;
 				ferror l
 			| e ->
-				stack := List.tl !stack;
+				stack.rec_stack <- List.tl stack.rec_stack;
 				raise e
 	end
 
 let rec_stack_default stack value fcheck frun def =
-	if not (List.exists fcheck !stack) then begin
-		try
-			stack := value :: !stack;
-			let v = frun() in
-			stack := List.tl !stack;
-			v
-		with
-			| e ->
-				stack := List.tl !stack;
-				raise e
-	end	else def
+	if not (rec_stack_exists fcheck stack) then rec_stack_loop stack value frun () else def
 
 let rec_stack_bool stack value fcheck frun =
-	if (List.exists fcheck !stack) then false else begin
+	if (rec_stack_exists fcheck stack) then false else begin
 		try
-			stack := value :: !stack;
+			stack.rec_stack <- value :: stack.rec_stack;
 			frun();
-			stack := List.tl !stack;
+			stack.rec_stack <- List.tl stack.rec_stack;
 			true
 		with
 			Unify_error l ->
-				stack := List.tl !stack;
+				stack.rec_stack <- List.tl stack.rec_stack;
 				false
 			| e ->
-				stack := List.tl !stack;
+				stack.rec_stack <- List.tl stack.rec_stack;
 				raise e
 	end
 
@@ -1926,19 +1933,19 @@ let type_iseq_strict a b =
 	with Unify_error _ ->
 		false
 
-let unify_stack = ref []
-let abstract_cast_stack = ref []
-let unify_new_monos = ref []
+let unify_stack = new_rec_stack()
+let abstract_cast_stack = new_rec_stack()
+let unify_new_monos = new_rec_stack()
 
 let print_stacks() =
 	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;
+	List.iter (fun (a,b) -> Printf.printf "\t%s , %s\n" (st a) (st b)) unify_stack.rec_stack;
 	print_endline "monos";
-	List.iter (fun m -> print_endline ("\t" ^ st m)) !unify_new_monos;
+	List.iter (fun m -> print_endline ("\t" ^ st m)) 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
+	List.iter (fun (a,b) -> Printf.printf "\t%s , %s\n" (st a) (st b)) abstract_cast_stack.rec_stack
 
 let rec unify a b =
 	if a == b then
@@ -2055,22 +2062,22 @@ let rec unify 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 in
-					unify_new_monos := !monos @ !unify_new_monos;
+					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 ft a2)
-						(fun() -> try unify_with_access f1 ft f2 with e -> unify_new_monos := old_monos; raise e)
+						(fun (a2,b2) -> fast_eq b2 f2.cf_type && fast_eq_mono unify_new_monos.rec_stack ft a2)
+						(fun() -> try unify_with_access f1 ft f2 with e -> unify_new_monos.rec_stack <- old_monos; raise e)
 						(fun l -> error (invalid_field n :: l));
-					unify_new_monos := old_monos;
+					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 in
-					unify_new_monos := !monos @ !unify_new_monos;
+					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 b2 ft && fast_eq f2.cf_type a2)
-						(fun() -> try unify_with_access f1 ft f2 with e -> unify_new_monos := old_monos; raise e)
+						(fun(a2,b2) -> fast_eq_mono unify_new_monos.rec_stack b2 ft && fast_eq f2.cf_type a2)
+						(fun() -> try unify_with_access f1 ft f2 with e -> unify_new_monos.rec_stack <- old_monos; raise e)
 						(fun l -> error (invalid_field n :: l));
-					unify_new_monos := old_monos;
+					unify_new_monos.rec_stack <- old_monos;
 				| _ ->
 					(* will use fast_eq, which have its own stack *)
 					try

src/filters/filtersCommon.ml

@@ -50,8 +50,7 @@ let run_expression_filters ctx filters t =
 			ctx.curfield <- f;
 			(match f.cf_expr with
 			| Some e when not (is_removable_field ctx f) ->
-				AbstractCast.cast_stack := f :: !AbstractCast.cast_stack;
-				f.cf_expr <- Some (Std.finally (fun() -> AbstractCast.cast_stack := List.tl !AbstractCast.cast_stack) run e);
+				f.cf_expr <- Some (rec_stack_loop AbstractCast.cast_stack f run e);
 			| _ -> ());
 			List.iter process_field f.cf_overloads
 		in

src/optimization/optimizer.ml

@@ -255,7 +255,7 @@ let reduce_control_flow ctx e = match e.eexpr with
 	| _ ->
 		e
 
-let inline_stack = ref []
+let inline_stack = new_rec_stack()
 
 let rec reduce_loop ctx e =
 	let e = Type.map_expr (reduce_loop ctx) e in
@@ -270,7 +270,7 @@ let rec reduce_loop ctx e =
 				(match inl with
 				| None -> reduce_expr ctx e
 				| Some e -> reduce_loop ctx e)
-			| {eexpr = TField(ef,(FStatic(_,cf) | FInstance(_,_,cf)))} when cf.cf_kind = Method MethInline && not (List.memq cf !inline_stack) ->
+			| {eexpr = TField(ef,(FStatic(_,cf) | FInstance(_,_,cf)))} when cf.cf_kind = Method MethInline && not (rec_stack_memq cf inline_stack) ->
 				begin match cf.cf_expr with
 				| Some {eexpr = TFunction tf} ->
 					let rt = (match follow e1.etype with TFun (_,rt) -> rt | _ -> assert false) in