[typer] start keeping track of monomorphs

src/context/typecore.ml

@@ -132,10 +132,17 @@ and typer = {
 	mutable opened : anon_status ref list;
 	mutable vthis : tvar option;
 	mutable in_call_args : bool;
+	mutable monomorphs : monomorphs;
 	(* events *)
 	mutable on_error : typer -> string -> pos -> unit;
 	memory_marker : float array;
 }
+
+and monomorphs = {
+	mutable percall : (tmono * pos) list;
+	mutable perfunction : (tmono * pos) list;
+}
+
 exception Forbid_package of (string * path * pos) * pos list * string
 
 exception WithTypeError of error_msg * pos
@@ -513,6 +520,22 @@ let merge_core_doc ctx mt =
 		end
 	| _ -> ())
 
+let spawn_constrained_monos ctx p map params =
+	let monos = List.map (fun (s,_) ->
+		let mono = Monomorph.create() in
+		(* if Meta.has (Meta.Custom ":debug.monomorphs") ctx.curfield.cf_meta then Monomorph.add_constraint mono "debug" p (MDebug s); *)
+		ctx.monomorphs.percall <- (mono,p) :: ctx.monomorphs.percall;
+		TMono mono
+	) params in
+	monos
+
+let with_contextual_monos ctx f =
+	let old_monos = ctx.monomorphs.percall in
+	ctx.monomorphs.percall <- [];
+	let r = f() in
+	ctx.monomorphs.percall <- old_monos;
+	r
+
 (* -------------- debug functions to activate when debugging typer passes ------------------------------- *)
 (*/*
 

src/typing/calls.ml

@@ -354,7 +354,8 @@ let type_generic_function ctx (e,fa) el ?(using_param=None) with_type p =
 		| _ -> die "" __LOC__
 	in
 	if cf.cf_params = [] then error "Function has no type parameters and cannot be generic" p;
-	let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
+	let map = if stat then (fun t -> t) else apply_params c.cl_params tl in
+	let monos = spawn_constrained_monos ctx p map cf.cf_params in
 	let map_monos t = apply_params cf.cf_params monos t in
 	let map t = if stat then map_monos t else apply_params c.cl_params tl (map_monos t) in
 	let t = map cf.cf_type in
@@ -373,7 +374,9 @@ let type_generic_function ctx (e,fa) el ?(using_param=None) with_type p =
 		| WithType.WithType(t,_) -> unify ctx ret t p
 		| _ -> ()
 	end;
-	let el,_ = unify_call_args ctx el args ret p false false in
+	let el,_ = with_contextual_monos ctx (fun () ->
+		unify_call_args ctx el args ret p false false
+	) in
 	begin try
 		check_constraints ctx cf.cf_name cf.cf_params monos map false p
 	with Unify_error l ->

src/typing/fields.ml

@@ -497,7 +497,7 @@ let rec type_field cfg ctx e i p mode =
 						FAnon f, Type.field_type f
 					| l ->
 						(* handle possible constraints *)
-						let monos = List.map (fun _ -> mk_mono()) l in
+						let monos = spawn_constrained_monos ctx p (fun t -> t) f.cf_params in
 						let t = apply_params f.cf_params monos f.cf_type in
 						add_constraint_checks ctx [] [] f monos p;
 						FAnon f, t

src/typing/typeload.ml

@@ -732,7 +732,10 @@ let t_iterator ctx =
 *)
 let load_type_hint ?(opt=false) ctx pcur t =
 	let t = match t with
-		| None -> mk_mono()
+		| None ->
+			let mono = Monomorph.create () in
+			ctx.monomorphs.perfunction <- (mono,pcur) :: ctx.monomorphs.perfunction;
+			TMono mono
 		| Some (t,p) ->	load_complex_type ctx true (t,p)
 	in
 	if opt then ctx.t.tnull t else t

src/typing/typeloadFunction.ml

@@ -45,12 +45,14 @@ let save_field_state ctx =
 	let old_ret = ctx.ret in
 	let old_fun = ctx.curfun in
 	let old_opened = ctx.opened in
+	let old_monos = ctx.monomorphs.perfunction in
 	let locals = ctx.locals in
 	(fun () ->
 		ctx.locals <- locals;
 		ctx.ret <- old_ret;
 		ctx.curfun <- old_fun;
 		ctx.opened <- old_opened;
+		ctx.monomorphs.perfunction <- old_monos;
 	)
 
 let type_var_field ctx t e stat do_display p =
@@ -108,6 +110,7 @@ let type_function ctx args ret fmode f do_display p =
 	ctx.curfun <- fmode;
 	ctx.ret <- ret;
 	ctx.opened <- [];
+	ctx.monomorphs.perfunction <- [];
 	let e = match f.f_expr with
 		| None ->
 			if ctx.com.display.dms_error_policy = EPIgnore then

src/typing/typeloadModule.ml

@@ -971,6 +971,10 @@ let type_types_into_module ctx m tdecls p =
 		in_loop = false;
 		opened = [];
 		in_call_args = false;
+		monomorphs = {
+			percall = [];
+			perfunction = [];
+		};
 		vthis = None;
 		memory_marker = Typecore.memory_marker;
 	} in

src/typing/typer.ml

@@ -1012,7 +1012,7 @@ and type_binop2 ?(abstract_overload_only=false) ctx op (e1 : texpr) (e2 : Ast.ex
 					| TFun([(_,_,t1);(_,_,t2)],tret) ->
 						let check e1 e2 swapped =
 							let map_arguments () =
-								let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
+								let monos = spawn_constrained_monos ctx p (fun t -> t) cf.cf_params in
 								let map t = map (apply_params cf.cf_params monos t) in
 								let t1 = map t1 in
 								let t2 = map t2 in
@@ -1794,7 +1794,7 @@ and type_new ctx path el with_type force_inline p =
 		(* Try to infer generic parameters from the argument list (issue #2044) *)
 		begin match resolve_typedef (Typeload.load_type_def ctx p (fst path)) with
 		| TClassDecl ({cl_constructor = Some cf} as c) ->
-			let monos = List.map (fun _ -> mk_mono()) c.cl_params in
+			let monos = spawn_constrained_monos ctx p (fun t -> t) c.cl_params in
 			let ct, f = get_constructor ctx c monos p in
 			ignore (unify_constructor_call c monos f ct);
 			begin try
@@ -2403,8 +2403,10 @@ and type_call_target ctx e with_type inline p =
 
 and type_call ?(mode=MGet) ctx e el (with_type:WithType.t) inline p =
 	let def () =
-		let e = type_call_target ctx e with_type inline p in
-		build_call ~mode ctx e el with_type p
+		with_contextual_monos ctx (fun () ->
+			let e = type_call_target ctx e with_type inline p in
+			build_call ~mode ctx e el with_type p;
+		)
 	in
 	match e, el with
 	| (EConst (Ident "trace"),p) , e :: el ->
@@ -2695,6 +2697,10 @@ let rec create com =
 		opened = [];
 		vthis = None;
 		in_call_args = false;
+		monomorphs = {
+			percall = [];
+			perfunction = [];
+		};
 		on_error = (fun ctx msg p -> ctx.com.error msg p);
 		memory_marker = Typecore.memory_marker;
 	} in

src/typing/typerBase.ml

@@ -119,7 +119,7 @@ let rec type_module_type ctx t tparams p =
 		let t_tmp = class_module_type c in
 		mk (TTypeExpr (TClassDecl c)) (TType (t_tmp,[])) p
 	| TEnumDecl e ->
-		let types = (match tparams with None -> List.map (fun _ -> mk_mono()) e.e_params | Some l -> l) in
+		let types = (match tparams with None -> spawn_constrained_monos ctx p (fun t -> t) e.e_params | Some l -> l) in
 		mk (TTypeExpr (TEnumDecl e)) (TType (e.e_type,types)) p
 	| TTypeDecl s ->
 		let t = apply_params s.t_params (List.map (fun _ -> mk_mono()) s.t_params) s.t_type in