first stab at singly-implemented interface elimination

Let's see what the tests say.

filters.ml

@@ -1099,6 +1099,70 @@ let check_remove_metadata ctx t = match t with
 	| _ ->
 		()
 
+
+let do_the_tivo_thing ctx =
+	let get_substitute_class c = match c.cl_dependent with
+		| [({cl_params = []} as c2),[]] when c.cl_interface && c.cl_params = [] ->
+			c2
+		| _ -> c
+	in
+	let rec substitute_type t = match follow t with
+		| TInst(c,[])->
+			let c2 = get_substitute_class c in
+			if c == c2 then
+				t
+			else if is_null t then
+				ctx.t.tnull (TInst(c2,[]))
+			else
+				TInst(c2,[])
+		| _ ->
+			Type.map substitute_type t
+	in
+	let substitute_expr e =
+		let build_var v =
+			v.v_type <- (substitute_type v.v_type);
+			v
+		in
+		let rec build_expr e = match e.eexpr with
+			| TTypeExpr (TClassDecl c) ->
+				let c2 = get_substitute_class c in
+				if c != c2 then begin
+					{e with eexpr = TTypeExpr (TClassDecl c2); etype = mk_type_expr_type c}
+				end else
+					e
+			| TCast(e1,Some (TClassDecl c)) ->
+				let e1 = build_expr e1 in
+				{e with eexpr = TCast(e1,Some (TClassDecl (get_substitute_class c))); etype = substitute_type e.etype}
+			| _ ->
+				map_expr_type build_expr substitute_type build_var e
+		in
+		build_expr e
+	in
+	let run = substitute_expr in
+	List.iter (fun mt -> match mt with
+		| TClassDecl c ->
+			let rec process_field f =
+				f.cf_type <- substitute_type f.cf_type;
+				begin match f.cf_expr with
+					| Some e ->
+						f.cf_expr <- Some (run e);
+					| _ -> ()
+				end;
+				List.iter process_field f.cf_overloads
+			in
+			List.iter process_field c.cl_ordered_fields;
+			List.iter process_field c.cl_ordered_statics;
+			(match c.cl_constructor with
+			| None -> ()
+			| Some f -> process_field f);
+			(match c.cl_init with
+			| None -> ()
+			| Some e ->
+				c.cl_init <- Some (run e));
+		| _ ->
+			()
+	) ctx.com.types
+
 (* Checks for Void class fields *)
 let check_void_field ctx t = match t with
 	| TClassDecl c ->
@@ -1266,6 +1330,7 @@ let run com tctx main =
 		remove_generic_base tctx t;
 		remove_extern_fields tctx t;
 	) com.types;
+	do_the_tivo_thing tctx;
 	(* update cache dependencies before DCE is run *)
 	Codegen.update_cache_dependencies com;
 	(* check @:remove metadata before DCE so it is ignored there (issue #2923) *)

tests/unit/src/unit/issues/Issue4603.hx

@@ -0,0 +1,15 @@
+package unit.issues;
+
+private interface I {}
+
+private class C implements I {
+	public function new() { }
+}
+
+class Issue4603 extends Test {
+	function test() {
+		var i:I = new C();
+		t(Std.is(i, I));
+		eq(i, cast(i, I));
+	}
+}

type.ml

@@ -200,7 +200,7 @@ and tclass = {
 	mutable cl_constructor : tclass_field option;
 	mutable cl_init : texpr option;
 	mutable cl_overrides : tclass_field list;
-
+	mutable cl_dependent : (tclass * tparams) list;
 	mutable cl_build : unit -> bool;
 	mutable cl_restore : unit -> unit;
 }
@@ -371,6 +371,7 @@ let mk_class m path pos =
 		cl_constructor = None;
 		cl_init = None;
 		cl_overrides = [];
+		cl_dependent = [];
 		cl_build = (fun() -> true);
 		cl_restore = (fun() -> ());
 	}
@@ -406,6 +407,22 @@ let mk_field name t p = {
 	cf_overloads = [];
 }
 
+let mk_type_expr_type c =
+	let t_tmp = {
+		t_path = [],"Class<" ^ (s_type_path c.cl_path) ^ ">" ;
+		t_module = c.cl_module;
+		t_doc = None;
+		t_pos = c.cl_pos;
+		t_type = TAnon {
+			a_fields = c.cl_statics;
+			a_status = ref (Statics c);
+		};
+		t_private = true;
+		t_params = [];
+		t_meta = [];
+	} in
+	(TType (t_tmp,[]))
+
 let null_module = {
 		m_id = alloc_mid();
 		m_path = [] , "";

typeload.ml

@@ -1076,6 +1076,7 @@ let check_extends ctx c t p = match follow t with
 	| TInst ({ cl_path = [],"Xml"; cl_extern = basic_extern },_) when not (c.cl_extern && basic_extern) ->
 		error "Cannot extend basic class" p;
 	| TInst (csup,params) ->
+		csup.cl_dependent <- (c,params) :: csup.cl_dependent;
 		if is_parent c csup then error "Recursive class" p;
 		begin match csup.cl_kind with
 			| KTypeParameter _ when not (is_generic_parameter ctx csup) -> error "Cannot extend non-generic type parameters" p
@@ -1395,6 +1396,7 @@ let set_heritance ctx c herits p =
 				c.cl_array_access <- Some t
 			| TInst (intf,params) ->
 				if is_parent c intf then error "Recursive class" p;
+				intf.cl_dependent <- (c,params) :: intf.cl_dependent;
 				if not (intf.cl_build()) then cancel_build intf;
 				if c.cl_interface then error "Interfaces cannot implement another interface (use extends instead)" p;
 				if not intf.cl_interface then error "You can only implement an interface" p;

typer.ml

@@ -838,20 +838,7 @@ let fast_enum_field e ef p =
 let rec type_module_type ctx t tparams p =
 	match t with
 	| TClassDecl c ->
-		let t_tmp = {
-			t_path = [],"Class<" ^ (s_type_path c.cl_path) ^ ">" ;
-			t_module = c.cl_module;
-			t_doc = None;
-			t_pos = c.cl_pos;
-			t_type = TAnon {
-				a_fields = c.cl_statics;
-				a_status = ref (Statics c);
-			};
-			t_private = true;
-			t_params = [];
-			t_meta = no_meta;
-		} in
-		mk (TTypeExpr (TClassDecl c)) (TType (t_tmp,[])) p
+		mk (TTypeExpr (TClassDecl c)) (mk_type_expr_type c) p
 	| TEnumDecl e ->
 		let types = (match tparams with None -> List.map (fun _ -> mk_mono()) e.e_params | Some l -> l) in
 		mk (TTypeExpr (TEnumDecl e)) (TType (e.e_type,types)) p