replace HL OSetMethod by object method binding (for static & dynamic methods)

src/generators/genhl.ml

@@ -533,6 +533,7 @@ and class_type ?(tref=None) ctx c pl statics =
 			pfunctions = PMap.empty;
 			pnfields = -1;
 			pinterfaces = PMap.empty;
+			pbindings = [];
 		} in
 		let t = HObj p in
 		(match tref with
@@ -562,7 +563,7 @@ and class_type ?(tref=None) ctx c pl statics =
 		let todo = ref [] in
 		List.iter (fun f ->
 			if is_extern_field f || (statics && f.cf_name = "__meta__") then () else
-			match f.cf_kind with
+			let fid = (match f.cf_kind with
 			| Method m when m <> MethDynamic && not statics ->
 				let g = alloc_fid ctx c f in
 				p.pfunctions <- PMap.add f.cf_name g p.pfunctions;
@@ -578,9 +579,10 @@ and class_type ?(tref=None) ctx c pl statics =
 				end else
 					None
 				in
-				DynArray.add pa { fname = f.cf_name; fid = alloc_string ctx f.cf_name; fmethod = g; fvirtual = virt; }
+				DynArray.add pa { fname = f.cf_name; fid = alloc_string ctx f.cf_name; fmethod = g; fvirtual = virt; };
+				None
 			| Method MethDynamic when List.exists (fun ff -> ff.cf_name = f.cf_name) c.cl_overrides ->
-				()
+				Some (try fst (get_index f.cf_name p) with Not_found -> assert false)
 			| _ ->
 				let fid = DynArray.length fa in
 				p.pindex <- PMap.add f.cf_name (fid + start_field, t) p.pindex;
@@ -590,6 +592,11 @@ and class_type ?(tref=None) ctx c pl statics =
 					p.pindex <- PMap.add f.cf_name (fid + start_field, t) p.pindex;
 					Array.set p.pfields fid (f.cf_name, alloc_string ctx f.cf_name, t)
 				) :: !todo;
+				Some (fid + start_field)
+			) in
+			match f.cf_kind, fid with
+			| Method _, Some fid -> p.pbindings <- (fid, alloc_fun_path ctx c.cl_path f.cf_name) :: p.pbindings
+			| _ -> ()
 		) (if statics then c.cl_ordered_statics else c.cl_ordered_fields);
 		if not statics then begin
 			(* add interfaces *)
@@ -606,6 +613,11 @@ and class_type ?(tref=None) ctx c pl statics =
 				DynArray.add pa { fname = "__string"; fid = alloc_string ctx "__string"; fmethod = alloc_fun_path ctx c.cl_path "__string"; fvirtual = None; }
 			with Not_found ->
 				());
+		end else begin
+			(match c.cl_constructor with
+			| Some f when not (is_extern_field f) ->
+				p.pbindings <- ((try fst (get_index "__constructor__" p) with Not_found -> assert false),alloc_fid ctx c f) :: p.pbindings
+			| _ -> ());
 		end;
 		p.pnfields <- DynArray.length fa + start_field;
 		p.pfields <- DynArray.to_array fa;
@@ -661,6 +673,7 @@ and enum_class ctx e =
 			pfunctions = PMap.empty;
 			pnfields = -1;
 			pinterfaces = PMap.empty;
+			pbindings = [];
 		} in
 		let t = HObj p in
 		ctx.cached_types <- PMap.add cpath t ctx.cached_types;
@@ -3040,10 +3053,6 @@ let generate_static_init ctx types main =
 				op ctx (OString (rname, alloc_string ctx (s_type_path path)));
 				op ctx (OCall2 (alloc_tmp ctx HVoid, alloc_fun_path ctx ([],"Type") "register",rname,rc));
 
-				(match c.cl_constructor with
-				| Some f when not (is_extern_field f) -> op ctx (OSetMethod (rc,index "__constructor__",alloc_fid ctx c f))
-				| _ -> ());
-
 				let gather_implements() =
 					let classes = ref [] in
 					let rec lookup cv =
@@ -3069,16 +3078,6 @@ let generate_static_init ctx types main =
 					op ctx (OSetField (rc,index "__implementedBy__",ra));
 				end;
 
-				(* register static funs *)
-
-				List.iter (fun f ->
-					match f.cf_kind with
-					| Method _ when not (is_extern_field f) ->
-						op ctx (OSetMethod (rc,index f.cf_name,alloc_fid ctx c f));
-					| _ ->
-						()
-				) c.cl_ordered_statics;
-
 				(match Codegen.build_metadata ctx.com (TClassDecl c) with
 				| None -> ()
 				| Some e ->
@@ -3378,8 +3377,10 @@ let write_code ch code debug =
 			| Some g -> write_index (g + 1));
 			write_index (Array.length p.pfields);
 			write_index (Array.length p.pproto);
+			write_index (List.length p.pbindings);
 			Array.iter (fun (_,n,t) -> write_index n; write_type t) p.pfields;
 			Array.iter (fun f -> write_index f.fid; write_index f.fmethod; write_index (match f.fvirtual with None -> -1 | Some i -> i)) p.pproto;
+			List.iter (fun (fid,fidx) -> write_index fid; write_index fidx) p.pbindings;
 		| HArray ->
 			byte 11
 		| HType ->

src/generators/hl2c.ml

@@ -762,9 +762,6 @@ let generate_function ctx f =
 				assert false)
 		| OStaticClosure (r,fid) ->
 			sexpr "%s = &cl$%d" (reg r) fid
-		| OSetMethod (o,f,fid) ->
-			let name, t = resolve_field (match rtype o with HObj o -> o | _ -> assert false) f in
-			sexpr "%s->%s = (%s)&cl$%d" (reg o) (ident name) (ctype t) fid
 		| OInstanceClosure (r,fid,ptr) ->
 			let ft = ctx.ftable.(fid) in
 			sexpr "%s = hl_alloc_closure_ptr(%s,%s,%s)" (reg r) (type_value (HFun (ft.fe_args,ft.fe_ret))) (funname fid) (reg ptr)
@@ -1005,7 +1002,7 @@ let write_c version file (code:code) =
 	Array.iter (fun f ->
 		Array.iteri (fun i op ->
 			match op with
-			| OStaticClosure (_,fid) | OSetMethod (_,_,fid) ->
+			| OStaticClosure (_,fid) ->
 				Hashtbl.replace used_closures fid ()
 			| OBytes (_,sid) ->
 				Hashtbl.replace bytes_strings sid ()
@@ -1165,7 +1162,7 @@ let write_c version file (code:code) =
 			sexpr "vbyte bytes$%d[] = {%s}" i (String.concat "," (loop str 0))
 		else if String.length str >= string_data_limit then
 			let s = utf8_to_utf16 str in
-			sline "// %s" (String.escaped str);
+			sline "// %s..." (String.escaped (String.sub str 0 (string_data_limit-4)));
 			sexpr "vbyte string$%d[] = {%s}" i (String.concat "," (loop s 0))
 	) code.strings;
 
@@ -1204,13 +1201,21 @@ let write_c version file (code:code) =
 				sexpr "static hl_obj_proto %s[] = {%s}" name (String.concat "," (List.map proto_value (Array.to_list o.pproto)));
 				name
 			in
+			let bindings =
+				if o.pbindings = [] then "NULL" else
+				let name = sprintf "bindings$%d" i in
+				sexpr "static int %s[] = {%s}" name (String.concat "," (List.map (fun (fid,fidx) -> string_of_int fid ^ "," ^ string_of_int fidx) o.pbindings));
+				name
+			in
 			let ofields = [
 				string_of_int (Array.length o.pfields);
 				string_of_int (Array.length o.pproto);
+				string_of_int (List.length o.pbindings);
 				sprintf "(const uchar*)%s" (string ctx o.pid);
 				(match o.psuper with None -> "NULL" | Some c -> sprintf "%s__val" (tname c.pname));
 				fields;
-				proto
+				proto;
+				bindings
 			] in
 			sexpr "static hl_type_obj obj$%d = {%s}" i (String.concat "," ofields);
 		| HEnum e ->
@@ -1301,17 +1306,29 @@ let write_c version file (code:code) =
 	generate_reflection ctx;
 
 	let gen_functions = Hashtbl.create 0 in
+	let all_protos = Hashtbl.create 0 in
 	Array.iter (fun t ->
 		match t with
 		| HObj o ->
+			Hashtbl.add all_protos o.pname o
+		| _ -> ()
+	) all_types;
+
+	Array.iter (fun t ->
+		match t with
+		| HObj o when Hashtbl.mem all_protos o.pname ->
 			let file = ref false in
-			Array.iter (fun p ->
-				match ctx.ftable.(p.fmethod).fe_decl with
+			let base_name, path = match List.rev (ExtString.String.nsplit o.pname ".") with
+				| [] -> assert false
+				| name :: acc -> (if name.[0] = '$' then String.sub name 1 (String.length name - 1) else name), List.rev acc
+			in
+			let generate fid =
+				match ctx.ftable.(fid).fe_decl with
 				| None -> ()
 				| Some f ->
 					if not !file then begin
 						file := true;
-						let path = ExtString.String.nsplit o.pname "." in
+						let path = path @ [base_name] in
 						let path = List.map (fun n -> if String.length n > 128 then Digest.to_hex (Digest.string n) else n) path in
 						let path = (match path with [name] -> ["_std";name] | _ -> path) in
 						open_file ctx (String.concat "/" path ^ ".c");
@@ -1320,7 +1337,19 @@ let write_c version file (code:code) =
 					end;
 					Hashtbl.replace gen_functions f.findex ();
 					generate_function ctx f
-			) o.pproto;
+			in
+			let gen_proto name =
+				try
+					let full_name = String.concat "." (path @ [name]) in
+					let o = Hashtbl.find all_protos full_name in
+					Array.iter (fun p -> generate p.fmethod) o.pproto;
+					List.iter (fun (_,mid) -> generate mid) o.pbindings;
+					Hashtbl.remove all_protos full_name;
+				with Not_found ->
+					()
+			in
+			gen_proto base_name;
+			gen_proto ("$" ^ base_name);
 		| _ -> ()
 	) all_types;
 

src/generators/hlcode.ml

@@ -58,6 +58,7 @@ and class_proto = {
 	mutable pindex : (string, int * ttype) PMap.t;
 	mutable pfunctions : (string, int) PMap.t;
 	mutable pinterfaces : (ttype, int) PMap.t;
+	mutable pbindings : (int * int) list;
 }
 
 and enum_proto = {
@@ -133,7 +134,6 @@ type opcode =
 	| OSetThis of field index * reg
 	| ODynGet of reg * reg * string index
 	| ODynSet of reg * string index * reg
-	| OSetMethod of reg * field index * functable index (* init static method *)
 	(* jumps *)
 	| OJTrue of reg * int
 	| OJFalse of reg * int
@@ -232,6 +232,7 @@ let null_proto =
 		pindex = PMap.empty;
 		pfunctions = PMap.empty;
 		pinterfaces = PMap.empty;
+		pbindings = [];
 	}
 
 let list_iteri f l =
@@ -499,7 +500,6 @@ let ostr fstr o =
 	| OCallThis (r,f,rl) -> Printf.sprintf "callthis %d, [%d](%s)" r f (String.concat "," (List.map string_of_int rl))
 	| OStaticClosure (r,f) -> Printf.sprintf "staticclosure %d, %s" r (fstr f)
 	| OInstanceClosure (r,f,v) -> Printf.sprintf "instanceclosure %d, %s(%d)" r (fstr f) v
-	| OSetMethod (o,f,fid) -> Printf.sprintf "setmethod %d[%d], %d" o f fid
 	| OGetGlobal (r,g) -> Printf.sprintf "global %d, %d" r g
 	| OSetGlobal (g,r) -> Printf.sprintf "setglobal %d, %d" g r
 	| ORet r -> Printf.sprintf "ret %d" r
@@ -640,11 +640,20 @@ let dump pr code =
 		| None -> ()
 		| Some p -> pr ("		extends " ^ p.pname));
 		pr ("		" ^ string_of_int (Array.length p.pfields) ^ " fields");
+		let rec loop = function
+			| None -> 0
+			| Some p -> Array.length p.pfields + loop p.psuper
+		in
+		let start_field = loop p.psuper in
 		Array.iteri (fun i (_,id,t) ->
-			pr ("		  @" ^ string_of_int i ^ " " ^ str id ^ " " ^ tstr t)
+			pr ("		  @" ^ string_of_int (i + start_field) ^ " " ^ str id ^ " " ^ tstr t)
 		) p.pfields;
 		pr ("		" ^ string_of_int (Array.length p.pproto) ^ " methods");
 		Array.iteri (fun i f ->
 			pr ("		  @" ^ string_of_int i ^ " " ^ str f.fid ^ " fun@" ^ string_of_int f.fmethod ^ (match f.fvirtual with None -> "" | Some p -> "[" ^ string_of_int p ^ "]"))
 		) p.pproto;
+		pr ("		" ^ string_of_int (List.length p.pbindings) ^ " bindings");
+		List.iter (fun (i,fidx) ->
+			pr ("		  @" ^ string_of_int i ^ " fun@" ^ string_of_int fidx)
+		) p.pbindings;
 	) protos

src/generators/hlinterp.ml

@@ -111,7 +111,7 @@ type context = {
 	mutable on_error : value -> (fundecl * int ref) list -> unit;
 	mutable resolve_macro_api : string -> (value list -> value) option;
 	checked : bool;
-	cached_protos : (int, vproto * ttype array) Hashtbl.t;
+	cached_protos : (int, vproto * ttype array * (int * (value -> value)) list) Hashtbl.t;
 	cached_strings : (int, string) Hashtbl.t;
 	cached_hashes : (int32, string) Hashtbl.t;
 }
@@ -175,10 +175,17 @@ let rec get_proto ctx p =
 	try
 		Hashtbl.find ctx.cached_protos p.pid
 	with Not_found ->
-		let fields = (match p.psuper with None -> [||] | Some p -> snd(get_proto ctx p)) in
+		let fields, bindings = (match p.psuper with None -> [||],[] | Some p -> let _, fields, bindings = get_proto ctx p in fields, bindings) in
 		let meths = Array.map (get_function ctx) p.pvirtuals in
 		let fields = Array.append fields (Array.map (fun (_,_,t) -> t) p.pfields) in
-		let proto = ({ pclass = p; pmethods = meths },fields) in
+		let bindings = List.fold_left (fun acc (fid,fidx) ->
+			let f = get_function ctx fidx in
+			let ft = (match f with FFun f -> f.ftype | FNativeFun _ -> assert false) in
+			let need_closure = (match ft, fields.(fid) with HFun (args,_), HFun(args2,_) -> List.length args > List.length args2 | HFun _, HDyn -> false | _ -> assert false) in
+			let acc = List.filter (fun (fid2,_) -> fid2 <> fid) acc in
+			(fid, (fun v -> VClosure (f,if need_closure then Some v else None))) :: acc
+		) bindings p.pbindings in
+		let proto = ({ pclass = p; pmethods = meths },fields,bindings) in
 		Hashtbl.replace ctx.cached_protos p.pid proto;
 		proto
 
@@ -187,8 +194,11 @@ let alloc_obj ctx t =
 	| HDynObj ->
 		VDynObj { dfields = Hashtbl.create 0; dvalues = [||]; dtypes = [||]; dvirtuals = []; }
 	| HObj p ->
-		let p, fields = get_proto ctx p in
-		VObj { oproto = p; ofields = Array.map default fields }
+		let p, fields, bindings = get_proto ctx p in
+		let ftable = Array.map default fields in
+		let obj = VObj { oproto = p; ofields = ftable } in
+		List.iter (fun (fid,mk) -> ftable.(fid) <- mk obj) bindings;
+		obj
 	| HVirtual v ->
 		let o = {
 			dfields = Hashtbl.create 0;
@@ -743,7 +753,7 @@ let interp ctx f args =
 	let check_obj v o fid =
 		if ctx.checked then match o with
 		| VObj o ->
-			let _, fields = get_proto ctx o.oproto.pclass in
+			let _, fields, _ = get_proto ctx o.oproto.pclass in
 			check v fields.(fid) (fun() -> "obj field")
 		| VVirtual vp ->
 			let _,_, t = vp.vtype.vfields.(fid) in
@@ -903,11 +913,6 @@ let interp ctx f args =
 				check_obj rv o fid;
 				v.ofields.(fid) <- rv
 			| _ -> assert false)
-		| OSetMethod (o,fid,mid) ->
-			let o = get o in
-			(match o with
-			| VObj v -> v.ofields.(fid) <- VClosure (get_function ctx mid,None)
-			| _ -> assert false)
 		| OCallMethod (r,m,rl) ->
 			(match get (List.hd rl) with
 			| VObj v -> set r (fcall v.oproto.pmethods.(m) (List.map get rl))
@@ -2290,8 +2295,6 @@ let check code macros =
 				reg r (tfield 0 fid false)
 			| OStaticClosure (r,f) ->
 				reg r ftypes.(f)
-			| OSetMethod (o,f,fid) ->
-				check ftypes.(fid) (tfield o f false)
 			| OVirtualClosure (r,o,fid) ->
 				(match rtype o with
 				| HObj _ ->
@@ -2745,7 +2748,6 @@ let make_spec (code:code) (f:fundecl) =
 			| OCallThis (d,fid,rl) -> args.(d) <- make_call (SMethod fid) (List.map (fun r -> args.(r)) (0 :: rl))
 			| OCallClosure (d,r,rl) -> args.(d) <- make_call (SClosure args.(r)) (List.map (fun r -> args.(r)) rl)
 			| OStaticClosure (d,fid) -> args.(d) <- SFun (fid,None)
-			| OSetMethod (o,f,fid) -> semit (SFieldSet (args.(o),f,SFun(fid,None)))
 			| OInstanceClosure (d,fid,r) -> args.(d) <- SFun (fid,Some args.(r))
 			| OVirtualClosure (d,r,index) -> args.(d) <- SMeth (args.(r),index)
 			| OGetGlobal (d,g) -> args.(d) <- SGlobal g

src/generators/hlopt.ml

@@ -111,8 +111,6 @@ let opcode_fx frw op =
 		write d
 	| OSetGlobal (_,a) ->
 		read a;
-	| OSetMethod (o,_,_) ->
-		read o;
 	| OField (d,a,_) | ODynGet (d,a,_) ->
 		read a; write d
 	| OSetField (a,_,b) | ODynSet (a,_,b)->
@@ -272,8 +270,6 @@ let opcode_map read write op =
 		OGetGlobal (write d, g)
 	| OSetGlobal (g,r) ->
 		OSetGlobal (g, read r)
-	| OSetMethod (o,f,m) ->
-		OSetMethod (read o, f, m)
 	| OField (d,a,f) ->
 		let a = read a in
 		OField (write d, a, f)

src/macro/hlmacro.ml

@@ -403,7 +403,7 @@ let enc_inst path fields =
 	let t = (match ctx.gen with None -> assert false | Some gen -> try Genhl.resolve_type gen path with Not_found -> assert false) in
 	match t with
 	| HObj o ->
-		let proto, _ = Hlinterp.get_proto ctx.interp o in
+		let proto, _, _ = Hlinterp.get_proto ctx.interp o in
 		VObj { oproto = proto; ofields = fields }
 	| _ ->
 		assert false