new DCE initial

Makefile

@@ -30,7 +30,7 @@ EXPORT=../../../projects/motionTools/haxe
 
 MODULES=ast type lexer common genxml parser typecore optimizer typeload \
 	codegen genas3 gencommon gencpp genjs genneko genphp genswf8 \
-	gencs genjava genswf9 interp genswf typer main
+	gencs genjava genswf9 interp genswf typer dce main
 
 HAXE_LIBRARY_PATH=$(CURDIR)/std
 
@@ -64,6 +64,8 @@ codegen.cmx: typeload.cmx typecore.cmx type.cmx genxml.cmx common.cmx ast.cmx
 
 common.cmx: type.cmx ast.cmx
 
+dce.cmx: type.cmx typer.cmx
+
 genas3.cmx: type.cmx common.cmx codegen.cmx ast.cmx
 
 gencommon.cmx: type.cmx common.cmx codegen.cmx ast.cmx
@@ -90,7 +92,7 @@ genxml.cmx: type.cmx lexer.cmx common.cmx ast.cmx
 
 interp.cmx: typecore.cmx type.cmx lexer.cmx genneko.cmx common.cmx codegen.cmx ast.cmx
 
-main.cmx: typer.cmx typeload.cmx typecore.cmx type.cmx parser.cmx optimizer.cmx lexer.cmx interp.cmx genxml.cmx genswf.cmx genphp.cmx genneko.cmx genjs.cmx genjava.cmx gencs.cmx gencpp.cmx genas3.cmx common.cmx codegen.cmx ast.cmx
+main.cmx: dce.cmx typer.cmx typeload.cmx typecore.cmx type.cmx parser.cmx optimizer.cmx lexer.cmx interp.cmx genxml.cmx genswf.cmx genphp.cmx genneko.cmx genjs.cmx genjava.cmx gencs.cmx gencpp.cmx genas3.cmx common.cmx codegen.cmx ast.cmx
 
 optimizer.cmx: typecore.cmx type.cmx parser.cmx common.cmx ast.cmx
 

common.ml

@@ -231,7 +231,9 @@ let add_feature com f =
 	Hashtbl.replace com.features f true
 
 let rec has_feature com f =
-	try
+	(* disabled for now because of problems with new DCE *)
+	true
+(* 	try
 		Hashtbl.find com.features f
 	with Not_found ->
 		if com.types = [] then defined com "all_features" else
@@ -242,15 +244,15 @@ let rec has_feature com f =
 			let r = (try
 				let path = List.rev pack, cl in
 				(match List.find (fun t -> t_path t = path && not (has_meta ":realPath" (t_infos t).mt_meta)) com.types with
-				| t when meth = "*" -> (not com.dead_code_elimination) || has_meta ":?used" (t_infos t).mt_meta
+				| t when meth = "*" -> (not com.dead_code_elimination) || has_meta ":used" (t_infos t).mt_meta
 				| TClassDecl c -> PMap.exists meth c.cl_statics || PMap.exists meth c.cl_fields
 				| _ -> false)
 			with Not_found ->
 				false
 			) in
 			let r = r || defined com "all_features" in
 			Hashtbl.add com.features f r;
-			r
+			r *)
 
 let error msg p = raise (Abort (msg,p))
 

dce.ml

@@ -0,0 +1,328 @@
+(*
+ * Haxe DCE:
+ * With this new approach the typer is almost not aware of DCE at all. It instead types what
+ * it needs to types (and usually some more) and DCE then takes care of cleaning up. It does
+ * so by following the typed AST expressions and mark accessed classes and fields as used.
+ *
+ * The algorithm works as follows:
+ * 1. Find all entry point class fields:
+ *	- the main method if exists
+ *	- methods marked as @:keep
+ *	- methods of classes marked as @:keep
+ *
+ * 2. Mark implementing/overriding fields of these entry points as @:?used.
+ *
+ * 3. Mark entry points as @:used.
+ *
+ * 4. Follow the field expressions (if exists) and see what other classes/fields are added,
+ *    e.g. by a TField or TNew AST node.
+ *
+ * 5. If new fields were added, go back to 2 with the new fields as entry points.
+ *
+ * 6. Filter the types by keeping those that are used explicitly or have a used field.
+ *
+ * Notes:
+ *	- the only influence of the typer is @:?used marking on structural subtyping
+ *  - properties are currently tricky to handle on some targets
+ *  - cpp target does not like removing unused overridden fields
+ *  - most targets seem to require keeping a property field even if it is used only through its accessor methods
+ *	- I did not consider inlining at all because I'm pretty sure I don't have to at this compilation stage
+ * 
+ *)
+
+open Ast
+open Common
+open Type
+open Typecore
+
+type dce = {
+	ctx : typer;
+	all_types : module_type list;
+	debug : bool;
+	expr : dce -> texpr -> unit;
+	mutable added_fields : (tclass * tclass_field * bool) list;
+}
+
+(* checking *)
+
+(* check for @:keepSub metadata, which forces @:keep on child classes *)
+let rec super_forces_keep c =
+	has_meta ":keepSub" c.cl_meta || match c.cl_super with
+	| Some (csup,_) -> super_forces_keep csup
+	| _ -> false
+
+(* check if a class is kept entirely *)
+let keep_whole_class dce c =
+	has_meta ":keep" c.cl_meta
+	|| super_forces_keep c
+	|| (match c with
+		| { cl_extern = true }
+		| { cl_path = ["flash";"_Boot"],"RealBoot" } -> true
+		| { cl_path = [],"String" }
+		| { cl_path = [],"Array" } -> not (dce.ctx.com.platform = Js)
+		| _ -> false)
+
+(* check if a field is kept *)
+let keep_field dce cf =
+	has_meta ":keep" cf.cf_meta
+	|| has_meta ":used" cf.cf_meta
+	|| cf.cf_name = "__init__"
+
+
+(* marking *)
+
+(* mark a field as kept *)
+let mark_field dce c cf stat = if not (has_meta ":used" cf.cf_meta) then begin
+	cf.cf_meta <- (":used",[],cf.cf_pos) :: cf.cf_meta;
+	dce.added_fields <- (c,cf,stat) :: dce.added_fields;
+end
+
+(* mark a class as kept. If the class has fields marked as @:?keep, make sure to keep them *)
+let rec mark_class dce c = if not (has_meta ":used" c.cl_meta) then begin
+	(* mark all :?used fields as surely :used now *)
+	List.iter (fun cf ->
+		if has_meta ":?used" cf.cf_meta then mark_field dce c cf true
+	) c.cl_ordered_statics;
+	List.iter (fun cf ->
+		if has_meta ":?used" cf.cf_meta then mark_field dce c cf false
+	) c.cl_ordered_fields;
+	c.cl_meta <- (":used",[],c.cl_pos) :: c.cl_meta;
+	(* we always have to keep super classes and implemented interfaces *)
+	List.iter (fun (c,_) -> mark_class dce c) c.cl_implements;
+	match c.cl_super with None -> () | Some (csup,pl) -> mark_class dce csup;
+end
+
+(* mark a type as kept *)
+let rec mark_t dce t = match follow t with
+	| TInst({cl_kind = KTypeParameter tl},pl) -> List.iter (mark_t dce) tl; List.iter (mark_t dce) pl
+	| TInst(c,pl) -> mark_class dce c; List.iter (mark_t dce) pl
+	| TFun(args,ret) -> List.iter (fun (_,_,t) -> mark_t dce t) args; mark_t dce ret
+	| _ -> ()
+
+(* find all dependent fields by checking implementing/subclassing types *)
+let rec mark_dependent_fields dce csup n stat =
+	List.iter (fun mt -> match mt with
+		| TClassDecl c when is_parent csup c ->
+			let rec loop c =
+				(try
+					let cf = PMap.find n (if stat then c.cl_statics else c.cl_fields) in
+					(* if it's clear that the class is kept, the field has to be kept as well *)
+					if has_meta ":used" c.cl_meta then mark_field dce c cf stat
+					(* otherwise it might be kept if the class is kept later, so mark it as :?used *)
+					else if not (has_meta ":?used" cf.cf_meta) then cf.cf_meta <- (":?used",[],cf.cf_pos) :: cf.cf_meta;
+					(* Cpp currently requires all base methods to be marked too *)
+					if dce.ctx.com.platform = Cpp then match c.cl_super with None -> () | Some (csup,_) -> loop csup;
+				with Not_found ->
+					(* if the field is not present on current class, it might come from a base class *)
+					(match c.cl_super with None -> () | Some (csup,_) -> loop csup))
+			in
+			loop c
+		| _ -> ()
+	) dce.all_types
+
+(* expr and field evaluation *)
+
+let opt f e = match e with None -> () | Some e -> f e
+
+let rec field dce c n stat =
+	let find_field n =
+		if n = "new" then match c.cl_constructor with
+			| None -> raise Not_found
+			| Some cf -> cf
+		else PMap.find n (if stat then c.cl_statics else c.cl_fields)
+	in
+	(try
+		let cf = find_field n in
+		mark_field dce c cf stat;
+	with Not_found -> try
+		(* me might have a property access on an interface *)
+		let l = String.length n - 4 in
+		if l < 0 then raise Not_found;
+		let prefix = String.sub n 0 4 in
+		let pn = String.sub n 4 l in
+		let cf = find_field pn in
+		if not (has_meta ":used" cf.cf_meta) then begin
+			let keep () =
+				mark_dependent_fields dce c n stat;
+ 				match dce.ctx.com.platform with
+					(* these platforms currently need the real property field apparently *)
+					| Js | Neko | Php | Flash8 | Cpp | Java -> field dce c pn stat
+					| _ -> ()
+			in
+			(match prefix,cf.cf_kind with
+				| "get_",Var {v_read = AccCall s} when s = n -> keep()
+				| "set_",Var {v_write = AccCall s} when s = n -> keep()	
+				| _ -> raise Not_found
+			);
+		end;
+		raise Not_found
+	with Not_found ->
+		match c.cl_super with Some (csup,_) -> field dce csup n stat | None -> ());
+
+and expr dce e =
+	match e.eexpr with
+	| TNew(c,pl,el) ->
+		mark_class dce c;
+		let rec loop c =
+			field dce c "new" false;
+			match c.cl_super with None -> () | Some (csup,_) -> loop csup
+		in
+		loop c;
+		List.iter (expr dce) el;
+		List.iter (mark_t dce) pl;
+	| TVars vl ->
+		List.iter (fun (v,e) ->
+			opt (expr dce) e;
+			mark_t dce v.v_type;
+		) vl;
+	| TCast(e, Some (TClassDecl c)) ->
+		mark_class dce c;
+		expr dce e;
+	| TTry(e, vl) ->
+		expr dce e;
+		List.iter (fun (v,e) ->
+			expr dce e;
+			mark_t dce v.v_type;
+		) vl;
+	| TTypeExpr (TClassDecl c) ->
+		mark_class dce c;
+	| TCall ({eexpr = TConst TSuper} as e,el) ->
+		mark_t dce e.etype;
+		List.iter (expr dce) el;
+	| TClosure(e,n)
+	| TField(e,n) -> (match follow e.etype with
+		| TInst(c,_) ->
+			mark_class dce c;
+			field dce c n false;
+		| TAnon a ->
+			(match !(a.a_status) with
+			| Statics c ->
+				mark_class dce c;
+				field dce c n true;
+			| _ -> ())
+		| _ -> ());
+		expr dce e;
+	| _ -> Type.iter (expr dce) e
+
+let run ctx main types modules =
+	let dce = {
+		ctx = ctx;
+		all_types = types;
+		debug = Common.defined ctx.com "dce_debug";
+		expr = expr;
+		added_fields = [];
+	} in
+	(* first step: get all entry points, which is the main method and all class methods which are marked with @:keep *)
+	let rec loop acc types = match types with
+		| (TClassDecl c) :: l ->
+			let keep_class = keep_whole_class dce c in
+			if keep_class then mark_class dce c;
+			let rec loop2 acc cfl stat = match cfl with
+				| cf :: l when keep_class || keep_field dce cf ->
+					loop2 ((c,cf,stat) :: acc) l stat
+				| cf :: l ->
+					loop2 acc l stat
+				| [] ->
+					acc
+			in
+			let acc = loop2 acc c.cl_ordered_statics true in
+			let acc = loop2 acc c.cl_ordered_fields false in
+			(match c.cl_init with None -> () | Some init -> expr dce init);
+			loop acc l
+		| _ :: l ->
+			loop acc l
+		| [] ->
+			acc
+	in
+	let entry_points = match main with
+		| Some {eexpr = TCall({eexpr = TField(e,_)},_)} ->
+			(match follow e.etype with
+			| TAnon a ->
+				(match !(a.a_status) with
+				| Statics c ->
+					let cf = PMap.find "main" c.cl_statics in
+					loop [c,cf,true] types
+				| _ -> assert false)
+			| _ -> assert false)
+		| _ -> loop [] types
+	in	
+	if dce.debug then begin
+		List.iter (fun (c,cf,_) -> match cf.cf_expr with
+			| None -> ()
+			| Some _ -> print_endline ("[DCE] Entry point: " ^ (s_type_path c.cl_path) ^ "." ^ cf.cf_name)
+		) entry_points;
+	end;
+
+	(* second step: initiate DCE passes and keep going until no new fields were added *)
+	let rec loop cfl =
+		(* extend to dependent (= overriding/implementing) class fields *)	
+		List.iter (fun (c,cf,stat) -> mark_dependent_fields dce c cf.cf_name stat) cfl;
+		(* mark fields as used *)
+		List.iter (fun (c,cf,stat) -> mark_field dce c cf stat; mark_t dce cf.cf_type) cfl;
+		(* follow expressions to new types/fields *)
+		List.iter (fun (_,cf,_) -> opt (expr dce) cf.cf_expr) cfl;		
+		match dce.added_fields with
+		| [] -> ()
+		| cfl ->
+			dce.added_fields <- [];
+			loop cfl
+	in
+	loop entry_points;
+
+	(* third step: filter types *)
+	let rec loop acc types =
+		match types with
+		| (TClassDecl c) as mt :: l when keep_whole_class dce c ->
+			loop (mt :: acc) l
+		| (TClassDecl c) as mt :: l ->
+ 			c.cl_ordered_statics <- List.filter (fun cf ->
+				let b = keep_field dce cf in
+				if not b then begin
+					if dce.debug then print_endline ("[DCE] Removed field " ^ (s_type_path c.cl_path) ^ "." ^ (cf.cf_name));
+					c.cl_statics <- PMap.remove cf.cf_name c.cl_statics;
+				end;
+				b
+			) c.cl_ordered_statics;
+			c.cl_ordered_fields <- List.filter (fun cf ->
+				let b = keep_field dce cf in
+				if not b then begin
+					if dce.debug then print_endline ("[DCE] Removed field " ^ (s_type_path c.cl_path) ^ "." ^ (cf.cf_name));
+					c.cl_fields <- PMap.remove cf.cf_name c.cl_fields;
+				end;
+				b
+			) c.cl_ordered_fields;
+			(match c.cl_constructor with Some cf when not (keep_field dce cf) -> c.cl_constructor <- None | _ -> ());
+			(* we keep a class if it was used or has a used field *)
+			if has_meta ":used" c.cl_meta || c.cl_ordered_statics <> [] || c.cl_ordered_fields <> [] then loop (mt :: acc) l else begin
+				if dce.debug then print_endline ("[DCE] Removed class " ^ (s_type_path c.cl_path));
+				loop acc l
+			end
+		| mt :: l ->
+			loop (mt :: acc) l
+		| [] ->
+			acc
+	in
+	let types = loop [] (List.rev types) in
+
+	(* extra step to adjust properties that had accessors removed (required for Php and Cpp) *)
+	List.iter (fun mt -> match mt with
+		| (TClassDecl c) ->
+			let rec has_accessor c n stat =
+				PMap.mem n (if stat then c.cl_statics else c.cl_fields)
+				|| match c.cl_super with Some (csup,_) -> has_accessor csup n stat | None -> false
+			in
+			let check_prop stat cf =
+				(match cf.cf_kind with
+				| Var {v_read = AccCall s; v_write = a} ->
+					cf.cf_kind <- Var {v_read = if has_accessor c s stat then AccCall s else AccNever; v_write = a}
+				| _ -> ());
+				(match cf.cf_kind with
+				| Var {v_write = AccCall s; v_read = a} ->
+					cf.cf_kind <- Var {v_write = if has_accessor c s stat then AccCall s else AccNever; v_read = a}
+				| _ -> ())
+			in		
+			List.iter (check_prop true) c.cl_ordered_statics;
+			List.iter (check_prop false) c.cl_ordered_fields;
+		| _ -> ()
+	) types;
+	types,modules

main.ml

@@ -1047,6 +1047,7 @@ try
 		end;
 		let t = Common.timer "filters" in
 		let main, types, modules = Typer.generate tctx in
+		let types,modules = if ctx.com.dead_code_elimination then Dce.run tctx main types modules else types,modules in
 		com.main <- main;
 		com.types <- types;
 		com.modules <- modules;