[hl] Fix Out of memory on cyclic anonymous structures

src/generators/genhl.ml

@@ -105,7 +105,7 @@ type context = {
 	defined_funs : (int,unit) Hashtbl.t;
 	mutable cached_types : (string list, ttype) PMap.t;
 	mutable m : method_context;
-	mutable anons_cache : (tanon, ttype) PMap.t;
+	anons_cache : (int, (tanon * ttype) list) Hashtbl.t;
 	mutable method_wrappers : ((ttype * ttype), int) PMap.t;
 	mutable rec_cache : (Type.t * ttype option ref) list;
 	mutable cached_tuples : (ttype list, ttype) PMap.t;
@@ -241,7 +241,7 @@ let method_context id t captured hasthis =
 		mregs = new_lookup();
 		mops = DynArray.create();
 		mvars = Hashtbl.create 0;
-		mallocs = PMap.empty;
+		mallocs = PMap.create ttype_compare;
 		mret = t;
 		mbreaks = [];
 		mdeclared = [];
@@ -374,6 +374,73 @@ let fake_tnull =
 let is_excluded c =
 	has_class_flag c CExcluded && not (has_class_flag c CInterface)
 
+let tanon_tag = function
+	| TMono _ -> 0 | TEnum _ -> 1 | TInst _ -> 2 | TType _ -> 3 | TFun _ -> 4
+	| TAnon _ -> 5 | TDynamic _ -> 6 | TLazy _ -> 7 | TAbstract _ -> 8
+
+let tanon_is_method cf = match cf.cf_kind with Method (MethNormal | MethInline) -> true | _ -> false
+
+let rec tanon_reduce t = match t with
+	| TMono { tm_type = Some t } -> tanon_reduce t
+	| TLazy f -> tanon_reduce (lazy_type f)
+	| _ -> t
+
+let rec tanon_level seen an = match seen with
+	| [] -> -1
+	| (an',d) :: l -> if an' == an then d else tanon_level l an
+
+let rec tanon_cmp_t seen1 seen2 depth t1 t2 =
+	let t1 = tanon_reduce t1 and t2 = tanon_reduce t2 in
+	if t1 == t2 then 0 else
+	match t1, t2 with
+	| TAnon an1, TAnon an2 -> tanon_cmp_anon seen1 seen2 depth an1 an2
+	| TMono _, TMono _ -> 0
+	| TInst (c1,tl1), TInst (c2,tl2) -> let c = compare c1.cl_path c2.cl_path in if c <> 0 then c else tanon_cmp_tl seen1 seen2 depth tl1 tl2
+	| TEnum (e1,tl1), TEnum (e2,tl2) -> let c = compare e1.e_path e2.e_path in if c <> 0 then c else tanon_cmp_tl seen1 seen2 depth tl1 tl2
+	| TType (d1,tl1), TType (d2,tl2) -> let c = compare d1.t_path d2.t_path in if c <> 0 then c else tanon_cmp_tl seen1 seen2 depth tl1 tl2
+	| TAbstract (a1,tl1), TAbstract (a2,tl2) -> let c = compare a1.a_path a2.a_path in if c <> 0 then c else tanon_cmp_tl seen1 seen2 depth tl1 tl2
+	| TFun (args1,ret1), TFun (args2,ret2) -> let c = tanon_cmp_args seen1 seen2 depth args1 args2 in if c <> 0 then c else tanon_cmp_t seen1 seen2 depth ret1 ret2
+	| TDynamic d1, TDynamic d2 ->
+		(match d1, d2 with
+		| None, None -> 0
+		| None, _ -> -1
+		| _, None -> 1
+		| Some t1, Some t2 -> tanon_cmp_t seen1 seen2 depth t1 t2)
+	| _ -> compare (tanon_tag t1) (tanon_tag t2)
+and tanon_cmp_tl seen1 seen2 depth l1 l2 = match l1, l2 with
+	| [], [] -> 0
+	| [], _ -> -1
+	| _, [] -> 1
+	| t1 :: l1, t2 :: l2 -> let c = tanon_cmp_t seen1 seen2 depth t1 t2 in if c <> 0 then c else tanon_cmp_tl seen1 seen2 depth l1 l2
+and tanon_cmp_args seen1 seen2 depth l1 l2 = match l1, l2 with
+	| [], [] -> 0
+	| [], _ -> -1
+	| _, [] -> 1
+	| (n1,o1,t1) :: l1, (n2,o2,t2) :: l2 ->
+		let c = compare (n1 : string) n2 in if c <> 0 then c else
+		let c = compare (o1 : bool) o2 in if c <> 0 then c else
+		let c = tanon_cmp_t seen1 seen2 depth t1 t2 in if c <> 0 then c else tanon_cmp_args seen1 seen2 depth l1 l2
+and tanon_cmp_fields seen1 seen2 depth l1 l2 = match l1, l2 with
+	| [], [] -> 0
+	| [], _ -> -1
+	| _, [] -> 1
+	| (n1,cf1) :: l1, (n2,cf2) :: l2 ->
+		let c = compare (n1 : string) n2 in if c <> 0 then c else
+		let c = compare (tanon_is_method cf1) (tanon_is_method cf2) in if c <> 0 then c else
+		let c = tanon_cmp_t seen1 seen2 depth cf1.cf_type cf2.cf_type in if c <> 0 then c else tanon_cmp_fields seen1 seen2 depth l1 l2
+and tanon_cmp_anon seen1 seen2 depth an1 an2 =
+	let d1 = tanon_level seen1 an1 and d2 = tanon_level seen2 an2 in
+	if d1 >= 0 && d2 >= 0 then compare (d1 : int) d2
+	else if d1 >= 0 then -1
+	else if d2 >= 0 then 1
+	else
+		let fields an = PMap.foldi (fun n cf acc -> (n,cf) :: acc) an.a_fields [] in
+		tanon_cmp_fields ((an1,depth) :: seen1) ((an2,depth) :: seen2) (depth + 1) (fields an1) (fields an2)
+
+let tanon_compare a1 a2 = tanon_cmp_anon [] [] 0 a1 a2
+
+let anon_fields_hash a = PMap.foldi (fun n _ acc -> acc lxor Hashtbl.hash (n : string)) a.a_fields 0
+
 let get_rec_cache ctx t none_callback not_found_callback =
 	try
 		match !(snd (List.find (fun (t',_) -> fast_eq t' t) ctx.rec_cache)) with
@@ -417,20 +484,17 @@ let rec to_type ?tref ctx t =
 		| _ -> die "" __LOC__)
 	| TAnon a ->
 		if PMap.is_empty a.a_fields then HDyn else
-		(try
-			(* can't use physical comparison in PMap since addresses might change in GC compact,
-				maybe add an uid to tanon if too slow ? *)
-			PMap.find a ctx.anons_cache
-		with Not_found ->
-			let vp = {
-				vfields = [||];
-				vindex = PMap.empty;
-			} in
+		let key = anon_fields_hash a in
+		let bucket = try Hashtbl.find ctx.anons_cache key with Not_found -> [] in
+		(match List.find_opt (fun (a',_) -> tanon_compare a a' = 0) bucket with
+		| Some (_,t) -> t
+		| None ->
+			let vp = mk_virtual_proto [||] PMap.empty in
 			let t = HVirtual vp in
 			(match tref with
 			| None -> ()
 			| Some r -> r := Some t);
-			ctx.anons_cache <- PMap.add a t ctx.anons_cache;
+			Hashtbl.replace ctx.anons_cache key ((a,t) :: bucket);
 			let fields = PMap.fold (fun cf acc -> cfield_type ctx cf :: acc) a.a_fields [] in
 			let fields = List.sort (fun (n1,_,_) (n2,_,_) -> compare n1 n2) fields in
 			vp.vfields <- Array.of_list fields;
@@ -574,10 +638,7 @@ and class_type ?(tref=None) ctx c pl statics =
 	try
 		PMap.find key_path ctx.cached_types
 	with Not_found when (has_class_flag c CInterface) && not statics ->
-		let vp = {
-			vfields = [||];
-			vindex = PMap.empty;
-		} in
+		let vp = mk_virtual_proto [||] PMap.empty in
 		let t = HVirtual vp in
 		ctx.cached_types <- PMap.add key_path t ctx.cached_types;
 		let rec loop c =
@@ -608,7 +669,7 @@ and class_type ?(tref=None) ctx c pl statics =
 			pvirtuals = [||];
 			pfunctions = PMap.empty;
 			pnfields = -1;
-			pinterfaces = PMap.empty;
+			pinterfaces = PMap.create ttype_compare;
 			pbindings = [];
 		} in
 		let t = (if Meta.has Meta.Struct c.cl_meta && not statics then HStruct p else HObj p) in
@@ -777,7 +838,7 @@ and enum_class ctx e =
 			pvirtuals = [||];
 			pfunctions = PMap.empty;
 			pnfields = -1;
-			pinterfaces = PMap.empty;
+			pinterfaces = PMap.create ttype_compare;
 			pbindings = [];
 		} in
 		let t = HObj p in
@@ -4200,7 +4261,7 @@ let create_context com =
 		cfunctions = DynArray.create();
 		overrides = Hashtbl.create 0;
 		cached_types = PMap.empty;
-		cached_tuples = PMap.empty;
+		cached_tuples = PMap.create ttype_list_compare;
 		cfids = new_lookup();
 		defined_funs = Hashtbl.create 0;
 		tstring = HVoid;
@@ -4235,9 +4296,9 @@ let create_context com =
 		core_type = get_class "CoreType";
 		core_enum = get_class "CoreEnum";
 		ref_abstract = get_abstract "Ref";
-		anons_cache = PMap.empty;
+		anons_cache = Hashtbl.create 0;
 		rec_cache = [];
-		method_wrappers = PMap.empty;
+		method_wrappers = PMap.create ttype_pair_compare;
 		cdebug_files = new_lookup();
 		macro_typedefs = Hashtbl.create 0;
 		ct_delayed = [];

src/generators/hl2c.ml

@@ -120,7 +120,7 @@ let s_comp = function
 	| CNeq -> "!="
 
 let core_types =
-	let vp = { vfields = [||]; vindex = PMap.empty } in
+	let vp = mk_virtual_proto [||] PMap.empty in
 	let ep = { ename = ""; eid = 0; eglobal = None; efields = [||] } in
 	[HVoid;HUI8;HUI16;HI32;HI64;HF32;HF64;HBool;HBytes;HDyn;HFun ([],HVoid);HObj null_proto;HArray HDyn;HType;HRef HVoid;HVirtual vp;HDynObj;HAbstract ("",0);HEnum ep;HMethod ([],HVoid);HStruct null_proto]
 
@@ -339,7 +339,7 @@ let close_file ctx =
 	let content = (match defines with [] -> out | l -> String.concat "\n" l ^ "\n\n" ^ out) in
 	let str = if ctx.curfile = "hlc.json" then content else bom ^ content in
 	ctx.defines <- [];
-	ctx.defined_types <- PMap.empty;
+	ctx.defined_types <- PMap.create ttype_compare;
 	Hashtbl.clear ctx.hdefines;
 	Hashtbl.clear ctx.defined_funs;
 	Buffer.reset ctx.out;
@@ -382,7 +382,7 @@ let create_file_context dir file =
 		defines = [];
 		hdefines = Hashtbl.create 0;
 		defined_funs = Hashtbl.create 0;
-		defined_types = PMap.empty;
+		defined_types = PMap.create ttype_compare;
 		fun_index = 0;
 		file_prefix = (short_digest file) ^ "_";
 	} in
@@ -1173,7 +1173,7 @@ let native_name str =
 	if str.[0] = '?' then String.sub str 1 (String.length str - 1) else str
 
 let make_types_idents htypes =
-	let types_descs = ref PMap.empty in
+	let types_descs = ref (PMap.create (fun a b -> ttype_compare (HVirtual a) (HVirtual b))) in
 	let rec make_desc t =
 		match t with
 		| HVoid | HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 | HBool | HBytes | HDyn | HArray _ | HType | HRef _ | HDynObj | HNull _ | HGUID ->
@@ -1395,7 +1395,7 @@ let make_modules ctx all_types =
 		in
 		m.m_functions <- get_deps [] m.m_functions
 	) !all_modules;
-	let contexts = ref PMap.empty in
+	let contexts = ref (PMap.create ttype_compare) in
 	Array.iter (fun f ->
 		if f.fe_module = None && ExtString.String.starts_with f.fe_name "fun$" then f.fe_name <- "wrap" ^ type_name ctx (match f.fe_decl with None -> Globals.die "" __LOC__ | Some f -> f.ftype);
 		(* assign context to function module *)
@@ -1511,7 +1511,7 @@ let write_c com file (code:code) gnames num_domains =
 		htypes = types_ids;
 		gnames = gnames;
 		bytes_names = bnames;
-		type_module = PMap.empty;
+		type_module = PMap.create ttype_compare;
 		gcon = com;
 	} in
 	let modules = make_modules gctx all_types in

src/generators/hlcode.ml

@@ -335,29 +335,114 @@ let is_dynamic t =
 	| HDyn | HFun _ | HObj _ | HArray _ | HVirtual _ | HDynObj | HNull _ | HEnum _ -> true
 	| _ -> false
 
-let rec tsame t1 t2 =
+let mk_virtual_proto vfields vindex = { vfields; vindex }
+
+let rec tsame_rec seen t1 t2 =
 	if t1 == t2 then true else
 	match t1, t2 with
-	| HFun (args1,ret1), HFun (args2,ret2) when List.length args1 = List.length args2 -> List.for_all2 tsame args1 args2 && tsame ret2 ret1
-	| HMethod (args1,ret1), HMethod (args2,ret2) when List.length args1 = List.length args2 -> List.for_all2 tsame args1 args2 && tsame ret2 ret1
+	| HFun (args1,ret1), HFun (args2,ret2) when List.length args1 = List.length args2 -> List.for_all2 (tsame_rec seen) args1 args2 && tsame_rec seen ret2 ret1
+	| HMethod (args1,ret1), HMethod (args2,ret2) when List.length args1 = List.length args2 -> List.for_all2 (tsame_rec seen) args1 args2 && tsame_rec seen ret2 ret1
 	| HObj p1, HObj p2 -> p1 == p2
 	| HEnum e1, HEnum e2 -> e1 == e2
 	| HStruct p1, HStruct p2 -> p1 == p2
 	| HAbstract (_,a1), HAbstract (_,a2) -> a1 == a2
 	| HVirtual v1, HVirtual v2 ->
 		if v1 == v2 then true else
+		if List.exists (fun (a,b) -> a == v1 && b == v2) seen then true else
 		if Array.length v1.vfields <> Array.length v2.vfields then false else
+		let seen = (v1,v2) :: seen in
 		let rec loop i =
 			if i = Array.length v1.vfields then true else
 			let _, i1, t1 = v1.vfields.(i) in
 			let _, i2, t2 = v2.vfields.(i) in
-			if i1 = i2 && tsame t1 t2 then loop (i + 1) else false
+			if i1 = i2 && tsame_rec seen t1 t2 then loop (i + 1) else false
 		in
 		loop 0
-	| HNull t1, HNull t2 -> tsame t1 t2
-	| HRef t1, HRef t2 -> tsame t1 t2
+	| HNull t1, HNull t2 -> tsame_rec seen t1 t2
+	| HRef t1, HRef t2 -> tsame_rec seen t1 t2
 	| _ -> false
 
+let tsame t1 t2 = tsame_rec [] t1 t2
+
+let rec ttype_level seen v = match seen with
+	| [] -> -1
+	| (v',d) :: l -> if v' == v then d else ttype_level l v
+
+let rec ttype_cmp seen1 seen2 depth t1 t2 =
+	if t1 == t2 then 0 else
+	match t1, t2 with
+	| HVirtual v1, HVirtual v2 ->
+		let d1 = ttype_level seen1 v1 and d2 = ttype_level seen2 v2 in
+		if d1 >= 0 && d2 >= 0 then compare (d1 : int) d2
+		else if d1 >= 0 then -1
+		else if d2 >= 0 then 1
+		else ttype_cmp_vfields ((v1,depth) :: seen1) ((v2,depth) :: seen2) (depth + 1) v1.vfields v2.vfields
+	| HFun (args1,ret1), HFun (args2,ret2)
+	| HMethod (args1,ret1), HMethod (args2,ret2) ->
+		let c = ttype_cmp_list seen1 seen2 depth args1 args2 in
+		if c <> 0 then c else ttype_cmp seen1 seen2 depth ret1 ret2
+	| (HArray a, HArray b) | (HRef a, HRef b) | (HNull a, HNull b) | (HPacked a, HPacked b) -> ttype_cmp seen1 seen2 depth a b
+	| HObj a, HObj b -> compare (a.pname : string) b.pname
+	| HStruct a, HStruct b -> compare (a.pname : string) b.pname
+	| HEnum a, HEnum b ->
+		let c = compare (a.ename : string) b.ename in
+		if c <> 0 then c
+		else if a.ename <> "" then 0
+		else ttype_cmp_efields seen1 seen2 depth a.efields b.efields
+	| _ -> compare t1 t2
+and ttype_cmp_efields seen1 seen2 depth a b =
+	let c = compare (Array.length a) (Array.length b) in
+	if c <> 0 then c else
+	let rec loop i =
+		if i = Array.length a then 0 else
+		let (n1,_,ta) = a.(i) and (n2,_,tb) = b.(i) in
+		let c = compare (n1 : string) n2 in if c <> 0 then c else
+		let c = ttype_cmp_arr seen1 seen2 depth ta tb in if c <> 0 then c else
+		loop (i + 1)
+	in
+	loop 0
+and ttype_cmp_arr seen1 seen2 depth a b =
+	let c = compare (Array.length a) (Array.length b) in
+	if c <> 0 then c else
+	let rec loop i =
+		if i = Array.length a then 0 else
+		let c = ttype_cmp seen1 seen2 depth a.(i) b.(i) in if c <> 0 then c else loop (i + 1)
+	in
+	loop 0
+and ttype_cmp_list seen1 seen2 depth l1 l2 = match l1, l2 with
+	| [], [] -> 0
+	| [], _ -> -1
+	| _, [] -> 1
+	| x :: l1, y :: l2 -> let c = ttype_cmp seen1 seen2 depth x y in if c <> 0 then c else ttype_cmp_list seen1 seen2 depth l1 l2
+and ttype_cmp_vfields seen1 seen2 depth a b =
+	let c = compare (Array.length a) (Array.length b) in
+	if c <> 0 then c else
+	let rec loop i =
+		if i = Array.length a then 0 else
+		let (n1,i1,t1) = a.(i) and (n2,i2,t2) = b.(i) in
+		let c = compare (n1 : string) n2 in if c <> 0 then c else
+		let c = compare (i1 : int) i2 in if c <> 0 then c else
+		let c = ttype_cmp seen1 seen2 depth t1 t2 in if c <> 0 then c else
+		loop (i + 1)
+	in
+	loop 0
+
+let ttype_compare t1 t2 =
+	if t1 == t2 then 0 else
+	match t1 with
+	| HVirtual _ | HFun _ | HMethod _ | HArray _ | HRef _ | HNull _ | HPacked _
+	| HObj _ | HStruct _ | HEnum _ -> ttype_cmp [] [] 0 t1 t2
+	| _ -> compare t1 t2
+
+let rec ttype_list_compare l1 l2 = match l1, l2 with
+	| [], [] -> 0
+	| [], _ -> -1
+	| _, [] -> 1
+	| t1 :: l1, t2 :: l2 -> let c = ttype_compare t1 t2 in if c <> 0 then c else ttype_list_compare l1 l2
+
+let ttype_pair_compare (a1,b1) (a2,b2) =
+	let c = ttype_compare a1 a2 in if c <> 0 then c else ttype_compare b1 b2
+
 let compatible_element_types t1 t2 =
 	if t1 == t2 then
 		true (* equal types are always compatible *)
@@ -448,7 +533,7 @@ let resolve_field p fid =
 	loop [] p
 
 let gather_types (code:code) =
-	let types = ref PMap.empty in
+	let types = ref (PMap.create ttype_compare) in
 	let arr = DynArray.create() in
 	let rec get_type t =
 		(match t with

src/generators/hlinterp.ml

@@ -2470,7 +2470,7 @@ let check comerror code =
 			| OToVirtual (r,v) ->
 				(match rtype r with
 				| HVirtual _ -> ()
-				| _ -> reg r (HVirtual {vfields=[||];vindex=PMap.empty;}));
+				| _ -> reg r (HVirtual (mk_virtual_proto [||] PMap.empty)));
 				(match rtype v with
 				| HObj _ | HDynObj | HDyn | HVirtual _ -> ()
 				| _ -> reg v HDynObj)