Browse Source

[typer] use record for field call candidates/results

Simon Krajewski 5 years ago
parent
commit
da17cdb976
5 changed files with 51 additions and 33 deletions
  1. 9 9
      src/codegen/overloads.ml
  2. 14 0
      src/context/typecore.ml
  3. 11 10
      src/typing/calls.ml
  4. 13 10
      src/typing/overloadResolution.ml
  5. 4 4
      src/typing/typer.ml

+ 9 - 9
src/codegen/overloads.ml

@@ -239,7 +239,7 @@ struct
 
 	let rec rm_duplicates acc ret = match ret with
 		| [] -> acc
-		| ( el, t, _ ) :: ret when List.exists (fun (_,t2,_) -> type_iseq t t2) acc ->
+		| fcc :: ret when List.exists (fun fcc2 -> type_iseq fcc.fc_type fcc2.fc_type) acc ->
 			rm_duplicates acc ret
 		| r :: ret ->
 			rm_duplicates (r :: acc) ret
@@ -256,15 +256,15 @@ struct
 	let rec fewer_optionals acc compatible = match acc, compatible with
 		| _, [] -> acc
 		| [], c :: comp -> fewer_optionals [c] comp
-		| (elist_acc, _, _) :: _, ((elist, _, _) as cur) :: comp ->
-			let acc_opt = count_optionals elist_acc in
-			let comp_opt = count_optionals elist in
+		| fcc_acc :: _, fcc :: comp ->
+			let acc_opt = count_optionals fcc_acc.fc_args in
+			let comp_opt = count_optionals fcc.fc_args in
 			if acc_opt = comp_opt then
-				fewer_optionals (cur :: acc) comp
+				fewer_optionals (fcc :: acc) comp
 			else if acc_opt < comp_opt then
 				fewer_optionals acc comp
 			else
-				fewer_optionals [cur] comp
+				fewer_optionals [fcc] comp
 
 	let reduce_compatible compatible = match fewer_optionals [] (rm_duplicates [] compatible) with
 		| [] -> []
@@ -287,9 +287,9 @@ struct
 			in
 
 			let rated = ref [] in
-			List.iter (function
-				| (elist,TFun(args,ret),d) -> (try
-					rated := ( (elist,TFun(args,ret),d), mk_rate [] elist args ) :: !rated
+			List.iter (fun fcc -> match fcc.fc_type with
+				| TFun(args,ret) -> (try
+					rated := ( fcc, mk_rate [] fcc.fc_args args ) :: !rated
 					with | Not_found -> ())
 				| _ -> die "" __LOC__
 			) compatible;

+ 14 - 0
src/context/typecore.ml

@@ -143,6 +143,13 @@ and monomorphs = {
 	mutable perfunction : (tmono * pos) list;
 }
 
+type 'a field_call_candidate = {
+	fc_args : (texpr * bool) list;
+	fc_type : Type.t;
+	fc_field : tclass_field;
+	fc_data : 'a;
+}
+
 exception Forbid_package of (string * path * pos) * pos list * string
 
 exception WithTypeError of error_msg * pos
@@ -537,6 +544,13 @@ let safe_mono_close ctx m p =
 		Unify_error l ->
 			raise_or_display ctx l p
 
+let make_field_call_candidate args t cf data = {
+	fc_args = args;
+	fc_type = t;
+	fc_field = cf;
+	fc_data = data;
+}
+
 (* -------------- debug functions to activate when debugging typer passes ------------------------------- *)
 (*/*
 

+ 11 - 10
src/typing/calls.ml

@@ -271,7 +271,7 @@ let unify_field_call ctx fa el args ret p inline =
 				let ef = mk (TField(ethis,mk_fa cf)) t p_field in
 				make_call ctx ef (List.map fst el) ret ~force_inline:inline p
 			in
-			el,tf,mk_call
+			make_field_call_candidate el tf cf mk_call
 		| _ ->
 			die "" __LOC__
 	in
@@ -312,15 +312,16 @@ let unify_field_call ctx fa el args ret p inline =
 	in
 	let fail_fun () =
 		let tf = TFun(args,ret) in
-		[],tf,(fun ethis p_field _ ->
+		let call = (fun ethis p_field _ ->
 			let e1 = mk (TField(ethis,mk_fa cf)) tf p_field in
 			mk (TCall(e1,[])) ret p)
+		in
+		make_field_call_candidate [] tf cf call
 	in
 	match candidates with
 	| [t,cf] ->
 		begin try
-			let el,tf,mk_call = attempt_call t cf in
-			List.map fst el,tf,mk_call
+			attempt_call t cf
 		with Error _ when ctx.com.display.dms_error_policy = EPIgnore ->
 			fail_fun();
 		end
@@ -343,11 +344,11 @@ let unify_field_call ctx fa el args ret p inline =
 		in
 		if is_overload && ctx.com.config.pf_overload then begin match Overloads.Resolution.reduce_compatible candidates with
 			| [] -> fail()
-			| [el,tf,mk_call] -> List.map fst el,tf,mk_call
+			| [fcc] -> fcc
 			| _ -> error "Ambiguous overload" p
 		end else begin match List.rev candidates with
 			| [] -> fail()
-			| (el,tf,mk_call) :: _ -> List.map fst el,tf,mk_call
+			| fcc :: _ -> fcc
 		end
 
 let type_generic_function ctx (e,fa) el ?(using_param=None) with_type p =
@@ -619,8 +620,8 @@ let rec build_call ?(mode=MGet) ctx acc el (with_type:WithType.t) p =
 		check_assign();
 		(match follow t with
 			| TFun (args,r) ->
-				let _,_,mk_call = unify_field_call ctx fmode el args r p true in
-				mk_call ethis p true
+				let fcc = unify_field_call ctx fmode el args r p true in
+				fcc.fc_data ethis p true
 			| _ ->
 				error (s_type (print_context()) t ^ " cannot be called") p
 		)
@@ -727,8 +728,8 @@ let rec build_call ?(mode=MGet) ctx acc el (with_type:WithType.t) p =
 						| FInstance(_,_,cf) | FStatic(_,cf) when Meta.has Meta.Generic cf.cf_meta ->
 							type_generic_function ctx (e1,fa) el with_type p
 						| _ ->
-							let _,_,mk_call = unify_field_call ctx fa el args r p false in
-							mk_call e1 e.epos false
+							let fcc = unify_field_call ctx fa el args r p false in
+							fcc.fc_data e1 e.epos false
 					end
 				| _ ->
 					let el, tfunc = unify_call_args ctx el args r p false false in

+ 13 - 10
src/typing/overloadResolution.ml

@@ -1,3 +1,4 @@
+open Typecore
 open TType
 open TUnification
 open TFunctions
@@ -16,7 +17,8 @@ let unify_cf map_type c cf el =
 						| TAbstract({a_path=["haxe";"extern"],"Rest"},[t]),[] ->
 							begin try
 								let el = List.map (fun e -> unify t e.etype; e,o) el in
-								Some ((List.rev acc) @ el,tf,(c,cf,monos))
+								let fcc = make_field_call_candidate ((List.rev acc) @ el) tf cf (c,cf,monos) in
+								Some fcc
 							with _ ->
 								None
 							end
@@ -24,7 +26,8 @@ let unify_cf map_type c cf el =
 							None
 					end
 				| [],[] ->
-					Some ((List.rev acc),tf,(c,cf,monos))
+					let fcc = make_field_call_candidate (List.rev acc) tf cf (c,cf,monos) in
+					Some fcc
 				| _ ->
 					None
 			in
@@ -48,20 +51,20 @@ let find_overload map_type c cf el =
 
 let filter_overloads candidates =
 	match Overloads.Resolution.reduce_compatible candidates with
-	| [_,_,(c,cf,tl)] -> Some(c,cf,tl)
+	| [fcc] -> Some(fcc.fc_data)
 	| [] -> None
-	| ((_,_,(c,cf,tl)) :: _) (* as resolved *) ->
+	| ((fcc) :: _) (* as resolved *) ->
 		(* let st = s_type (print_context()) in
 		print_endline (Printf.sprintf "Ambiguous overload for %s(%s)" name (String.concat ", " (List.map (fun e -> st e.etype) el)));
 		List.iter (fun (_,t,(c,cf)) ->
 			print_endline (Printf.sprintf "\tCandidate: %s.%s(%s)" (s_type_path c.cl_path) cf.cf_name (st t));
 		) resolved; *)
-		Some(c,cf,tl)
+		Some(fcc.fc_data)
 
 let resolve_instance_overload is_ctor map_type c name el =
 	let candidates = ref [] in
-	let has_function t1 (_,t2,_) =
-		begin match follow t1,t2 with
+	let has_function t1 fcc2 =
+		begin match follow t1,fcc2.fc_type with
 		| TFun(tl1,_),TFun(tl2,_) -> type_iseq (TFun(tl1,t_dynamic)) (TFun(tl2,t_dynamic))
 		| _ -> false
 		end
@@ -76,8 +79,8 @@ let resolve_instance_overload is_ctor map_type c name el =
 			begin match find_overload map_type c cf el with
 			| [] -> raise Not_found
 			| l ->
-				List.iter (fun ((_,t,_) as ca) ->
-					if not (List.exists (has_function t) !candidates) then candidates := ca :: !candidates
+				List.iter (fun fcc ->
+					if not (List.exists (has_function fcc.fc_type) !candidates) then candidates := fcc :: !candidates
 				) l
 			end;
 			if Meta.has Meta.Overload cf.cf_meta || cf.cf_overloads <> [] then raise Not_found
@@ -96,5 +99,5 @@ let maybe_resolve_instance_overload is_ctor map_type c cf el =
 	if Meta.has Meta.Overload cf.cf_meta || cf.cf_overloads <> [] then
 		resolve_instance_overload is_ctor map_type c cf.cf_name el
 	else match unify_cf map_type c cf el with
-		| Some (_,_,(c,cf,tl)) -> Some (c,cf,tl)
+		| Some fcc -> Some (fcc.fc_data)
 		| None -> Some(c,cf,List.map snd cf.cf_params)

+ 4 - 4
src/typing/typer.ml

@@ -1776,8 +1776,8 @@ and type_new ctx path el with_type force_inline p =
 	let unify_constructor_call c params f ct = match follow ct with
 		| TFun (args,r) ->
 			(try
-				let el,_,_ = unify_field_call ctx (FInstance(c,params,f)) el args r p false in
-				el
+				let fcc = unify_field_call ctx (FInstance(c,params,f)) el args r p false in
+				List.map fst fcc.fc_args
 			with Error (e,p) ->
 				display_error ctx (error_msg e) p;
 				[])
@@ -2485,8 +2485,8 @@ and type_call ?(mode=MGet) ctx e el (with_type:WithType.t) inline p =
 			if (Meta.has Meta.CompilerGenerated f.cf_meta) then display_error ctx (error_msg (No_constructor (TClassDecl c))) p;
 			let el = (match follow ct with
 			| TFun (args,r) ->
-				let el,_,_ = unify_field_call ctx (FInstance(c,params,f)) el args r p false in
-				el
+				let fcc = unify_field_call ctx (FInstance(c,params,f)) el args r p false in
+				List.map fst fcc.fc_args
 			| _ ->
 				error "Constructor is not a function" p
 			) in