rewrote DCE

common.ml

@@ -129,7 +129,7 @@ let create v =
 
 let clone com =
 	let t = com.basic in
-	{ com with basic = { t with tvoid = t.tvoid } }
+	{ com with basic = { t with tvoid = t.tvoid }; main_class = None; }
 
 let platforms = [
 	Flash;

main.ml

@@ -342,7 +342,7 @@ let rec process_params flush acc = function
 		(match !global_cache with
 		| None ->
 			let host, port = (try ExtString.String.split hp ":" with _ -> "127.0.0.1", hp) in
-			do_connect host (try int_of_string port with _ -> raise (Arg.Bad "Invalid port")) ((List.rev acc) @ l) 
+			do_connect host (try int_of_string port with _ -> raise (Arg.Bad "Invalid port")) ((List.rev acc) @ l)
 		| Some _ ->
 			(* already connected : skip *)
 			process_params flush acc l)
@@ -366,7 +366,7 @@ and wait_loop boot_com host port =
 		c_modules = Hashtbl.create 0;
 	} in
 	global_cache := Some cache;
-	let get_signature com = 
+	let get_signature com =
 		match com.defines_signature with
 		| Some s -> s
 		| None ->
@@ -394,7 +394,7 @@ and wait_loop boot_com host port =
 	);
 	let cache_module sign m =
 		Hashtbl.replace cache.c_modules (m.Type.mpath,sign) (file_time m.Type.mfile,m);
-		List.iter (fun t -> 
+		List.iter (fun t ->
 			match t with
 			| Type.TClassDecl c -> c.Type.cl_restore()
 			| _ -> ()
@@ -411,7 +411,7 @@ and wait_loop boot_com host port =
 				Hashtbl.find modules_added m.Type.mpath
 			with Not_found -> try
 				!(Hashtbl.find modules_checked m.Type.mpath)
-			with Not_found -> 
+			with Not_found ->
 			let ok = ref true in
 			Hashtbl.add modules_checked m.Type.mpath ok;
 			try
@@ -496,7 +496,7 @@ and wait_loop boot_com host port =
 		Unix.close sin;
 	done
 
-and do_connect host port args =	
+and do_connect host port args =
 	let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
 	(try Unix.connect sock (Unix.ADDR_INET (Unix.inet_addr_of_string host,port)) with _ -> failwith ("Couldn't connect on " ^ host ^ ":" ^ string_of_int port));
 	ssend sock ("--cwd " ^ Unix.getcwd() ^ "\n");
@@ -505,7 +505,7 @@ and do_connect host port args =
 	let buf = Buffer.create 0 in
 	let tmp = String.create 100 in
 	let rec loop() =
-		let b = Unix.recv sock tmp 0 100 [] in		
+		let b = Unix.recv sock tmp 0 100 [] in
 		Buffer.add_substring buf tmp 0 b;
 		if b > 0 then loop()
 	in
@@ -818,7 +818,7 @@ try
 		t();
 		if ctx.has_error then raise Abort;
 		let t = Common.timer "filters" in
-		let main, types, modules = Typer.generate tctx com.main_class in
+		let main, types, modules = Typer.generate tctx in
 		com.main <- main;
 		com.types <- types;
 		com.modules <- modules;

typeload.ml

@@ -148,7 +148,7 @@ let rec load_instance ctx t p allow_no_params =
 						| EConst (String s) -> "S" ^ s
 						| EConst (Int i) -> "I" ^ i
 						| EConst (Float f) -> "F" ^ f
-						| _ -> "Expr"			
+						| _ -> "Expr"
 					) in
 					let c = mk_class ([],name) p in
 					c.cl_kind <- KExpr e;
@@ -585,9 +585,9 @@ let type_function ctx args ret fmode f p =
 		| _ -> Type.iter loop e
 	in
 	let has_super_constr() =
-		match ctx.curclass.cl_super with 
+		match ctx.curclass.cl_super with
 		| None -> false
-		| Some (csup,_) -> 
+		| Some (csup,_) ->
 			try ignore(get_constructor (fun f->f.cf_type) csup); true with Not_found -> false
 	in
 	if fmode = FConstructor && has_super_constr() then
@@ -756,7 +756,7 @@ let init_class ctx c p herits fields =
 		c.cl_extern <- true;
 		List.filter (fun f -> List.mem AStatic f.cff_access) fields, []
 	end else fields, herits in
-	if core_api && not ctx.com.display then delay ctx ((fun() -> init_core_api ctx c));
+	if core_api && not (ctx.com.display || ctx.com.dead_code_elimination) then delay ctx (fun() -> init_core_api ctx c);
 	let tthis = TInst (c,List.map snd c.cl_types) in
 	let rec extends_public c =
 		List.exists (fun (c,_) -> c.cl_path = (["haxe"],"Public") || extends_public c) c.cl_implements ||
@@ -800,73 +800,6 @@ let init_class ctx c p herits fields =
 			PMap.exists f c.cl_fields || has_field f c.cl_super || List.exists (fun i -> has_field f (Some i)) c.cl_implements
 	in
 
-	(* ----------------------- DEAD CODE ELIMINATION ----------------------------- *)
-
-	let is_main n = (match ctx.com.main_class with | Some cl when c.cl_path = cl -> true | _ -> false) && n = "main" in
-	let must_keep_types pf = match pf with
-		| Flash -> [["flash"], "Boot"]
-		| Flash9 -> [["flash"; "_Boot"], "RealBoot"; ["flash"], "Boot"]
-		| Js -> [["js"], "Boot"]
-		| Neko -> [["neko"], "Boot"]
-		| Php -> [["php"], "Boot"]
-		| Cpp -> [["cpp"], "Boot"]
-		| _ -> [] in
-	let must_keep_class =
-		List.exists (fun p -> p = c.cl_path) (must_keep_types ctx.com.platform)
-		|| c.cl_extern
-		|| has_meta ":keep" c.cl_meta 
-	in
-	let keep f stat =
-		   core_api 
-		|| (is_main f.cff_name)
-		|| must_keep_class 
-		|| has_meta ":keep" f.cff_meta 
-		|| (stat && f.cff_name = "__init__") 
-		|| (not stat 
-			&& f.cff_name = "resolve"
-			&& (match c.cl_dynamic with
-			| Some _ -> true
-			| None -> false
-			);
-		)
-	in
-	let rec setkeeper c =
-		match c.cl_super with
-		| Some (s,_) -> 
-			s.cl_meta <- if has_meta ":keep" s.cl_meta then s.cl_meta else begin
-				if ctx.com.verbose then print_endline ("Marking class " ^ (s_type_path s.cl_path) ^ " with :keep");
-				(":keep", [], p) :: s.cl_meta
-			end;
-			setkeeper s
-		| _ -> ()
-	in
-	let remove_by_cfname item lst = List.filter (fun i -> item <> i.cf_name) lst in
-	let remove_field cf stat =
-		if stat then begin
-			c.cl_statics <- PMap.remove cf.cf_name c.cl_statics;
-			c.cl_ordered_statics <- remove_by_cfname cf.cf_name c.cl_ordered_statics;
-		end else begin
-			if cf.cf_name = "new" then c.cl_constructor <- None;
-			c.cl_fields <- PMap.remove cf.cf_name c.cl_fields;
-			c.cl_ordered_fields <- remove_by_cfname cf.cf_name c.cl_ordered_fields;
-		end
-	in
-	let remove_method_if_unreferenced cf stat = (fun () ->
-		match cf.cf_expr with
-		| None ->
-			if ctx.com.verbose then print_endline ("Remove method " ^ (s_type_path c.cl_path) ^ "." ^ cf.cf_name);
-			remove_field cf stat
-		| _ -> 
-			setkeeper c;
-			())
-	in
-	let remove_var_if_unreferenced cf stat = (fun () ->
-		if not (has_meta ":?keep" cf.cf_meta) then begin
-			if ctx.com.verbose then print_endline ("Remove var " ^ (s_type_path c.cl_path) ^ "." ^ cf.cf_name);
-			remove_field cf stat
-		end else setkeeper c)
-	in
-
 	(* ----------------------- COMPLETION ----------------------------- *)
 
 	let display_file = if ctx.com.display then String.lowercase (Common.get_full_path p.pfile) = String.lowercase (!Parser.resume_display).pfile else false in
@@ -895,7 +828,7 @@ let init_class ctx c p herits fields =
 			(fun () -> ())
 		else begin
 			cf.cf_type <- TLazy r;
-			(fun () -> ignore(!r()))
+			if ctx.com.dead_code_elimination && cf.cf_name <> "__init__" then (fun() -> ()) else (fun () -> ignore(!r()))
 		end
 	in
 
@@ -907,6 +840,9 @@ let init_class ctx c p herits fields =
 		let stat = List.mem AStatic f.cff_access in
 		let inline = List.mem AInline f.cff_access in
 		let ctx = { ctx with curclass = c; tthis = tthis } in
+		let mark_used cf =
+			if ctx.com.dead_code_elimination then cf.cf_meta <- (":?used",[],p) :: cf.cf_meta
+		in
 		match f.cff_kind with
 		| FVar (t,e) ->
 			if not stat && has_field name c.cl_super then error ("Redefinition of variable " ^ name ^ " in subclass is not allowed") p;
@@ -937,44 +873,22 @@ let init_class ctx c p herits fields =
 				cf_public = is_public f.cff_access None;
 				cf_params = [];
 			} in
-			let delay = if (ctx.com.dead_code_elimination && not ctx.com.display) then begin
-				(match e with
-				| None ->
-					let r = exc_protect (fun r ->
-						r := (fun() -> t);
-						cf.cf_meta <- if has_meta ":?keep" cf.cf_meta then f.cff_meta else (":?keep", [], p) :: f.cff_meta;
-						t
-					) in
-					cf.cf_type <- TLazy r;
-					(fun() ->
-						if not (keep f stat) then
-							delay ctx (remove_var_if_unreferenced cf stat)
-						else
-							ignore(!r())
-					)
-				| Some e ->
+			let delay = (match e with
+				| None when ctx.com.dead_code_elimination && not ctx.com.display ->
 					let r = exc_protect (fun r ->
 						r := (fun() -> t);
-						if ctx.com.verbose then print_endline ("Typing " ^ s_type_path c.cl_path ^ "." ^ name);
-						cf.cf_meta <- if has_meta ":?keep" cf.cf_meta then f.cff_meta else (":?keep", [], p) :: f.cff_meta;
-						cf.cf_expr <- Some (type_static_var ctx t e p);
-						cf.cf_type <- t;
+						mark_used cf;
 						t
 					) in
 					cf.cf_type <- TLazy r;
-					(fun () ->
-						if not (keep f stat) then
-							delay ctx (remove_var_if_unreferenced cf stat)
-						else
-							ignore(!r())
-					)
-				)
-			end else (match e with
-				| None -> (fun() -> ())
+					(fun() -> ())
+				| None ->
+					(fun() -> ())
 				| Some e ->
 					let r = exc_protect (fun r ->
 						r := (fun() -> t);
 						if ctx.com.verbose then print_endline ("Typing " ^ s_type_path c.cl_path ^ "." ^ name);
+						mark_used cf;
 						cf.cf_expr <- Some (type_static_var ctx t e p);
 						cf.cf_type <- t;
 						t
@@ -1068,25 +982,12 @@ let init_class ctx c p herits fields =
 					(match e.eexpr with
 					| TBlock [] | TBlock [{ eexpr = TConst _ }] | TConst _ | TObjectDecl [] -> ()
 					| _ -> c.cl_init <- Some e);
+				mark_used cf;
 				cf.cf_expr <- Some (mk (TFunction f) t p);
 				cf.cf_type <- t;
 				t
 			) in
-			let delay = if (ctx.com.dead_code_elimination && not ctx.com.display) then begin
-				if ((c.cl_extern && not inline) || c.cl_interface) && cf.cf_name <> "__init__" then
-					(fun() -> ())
-				else if is_macro && not ctx.in_macro then 
-					(fun () -> ())
-				else begin
-					cf.cf_type <- TLazy r;
-					(fun() ->
-						if not (keep f stat) then begin
-							delay ctx (remove_method_if_unreferenced cf stat)
-						end else
-							ignore((!r)())
-					)
-				end
-			end else if ((c.cl_extern && not inline) || c.cl_interface) && cf.cf_name <> "__init__" then
+			let delay = if ((c.cl_extern && not inline) || c.cl_interface) && cf.cf_name <> "__init__" then
 				(fun() -> ())
 			else
 				bind_type cf r (match fd.f_expr with Some e -> snd e | None -> f.cff_pos) is_macro
@@ -1163,7 +1064,7 @@ let init_class ctx c p herits fields =
 	in
 	let cl_req = check_require c.cl_meta in
 	let fl = List.fold_left (fun acc f ->
-		try 
+		try
 			let p = f.cff_pos in
 			let fd , constr, f , delayed = loop_cf f in
 			let is_static = List.mem AStatic fd.cff_access in
@@ -1211,11 +1112,11 @@ let init_class ctx c p herits fields =
 					| _ -> assert false
 				) in
 				let p = c.cl_pos in
-				let vars = List.map (fun (n,o,t) -> 
+				let vars = List.map (fun (n,o,t) ->
 					let t = if o then ctx.t.tnull t else t in
 					alloc_var n t, (if o then Some TNull else None)
 				) args in
-				let super_call = mk (TCall (mk (TConst TSuper) (TInst (csup,cparams)) p,List.map (fun (v,_) -> mk (TLocal v) v.v_type p) vars)) ctx.t.tvoid p in				
+				let super_call = mk (TCall (mk (TConst TSuper) (TInst (csup,cparams)) p,List.map (fun (v,_) -> mk (TLocal v) v.v_type p) vars)) ctx.t.tvoid p in
 				let constr = mk (TFunction {
 					tf_args = vars;
 					tf_type = TFun (args,ctx.t.tvoid);
@@ -1224,7 +1125,7 @@ let init_class ctx c p herits fields =
 				c.cl_constructor <- Some { cf with cf_pos = p; cf_type = constr.etype; cf_meta = []; cf_doc = None; cf_expr = Some constr })
 		| _ ->
 			(* nothing to do *)
-			()	
+			()
 	in
 	delay ctx (fun() -> add_constructor c);
 	List.rev fl
@@ -1530,7 +1431,7 @@ let load_module ctx m p =
 				parse_module ctx m p
 			with Not_found ->
 				let rec loop = function
-					| [] -> 
+					| [] ->
 						raise (Error (Module_not_found m,p))
 					| load :: l ->
 						match load m p with

typer.ml

@@ -90,6 +90,14 @@ let rec get_overloads ctx p = function
 	| [] ->
 		[]
 
+let rec mark_used_class ctx c =
+	if ctx.com.dead_code_elimination && not (has_meta ":?used" c.cl_meta) then begin
+		c.cl_meta <- (":?used",[],c.cl_pos) :: c.cl_meta;
+		match c.cl_super with
+		| Some (csup,_) -> mark_used_class ctx csup
+		| _ -> ()
+	end
+
 type type_class =
 	| KInt
 	| KFloat
@@ -1583,6 +1591,7 @@ and type_expr ctx ?(need_val=true) (e,p) =
 		let t = Typeload.load_instance ctx t p true in
 		let el, c , params = (match follow t with
 		| TInst (c,params) ->
+			mark_used_class ctx c;
 			let name = (match c.cl_path with [], name -> name | x :: _ , _ -> x) in
 			if PMap.mem name ctx.locals then error ("Local variable " ^ name ^ " is preventing usage of this class here") p;
 			let ct, f = get_constructor c params p in
@@ -1921,14 +1930,116 @@ and type_call ctx e el p =
 			) in
 			mk (TCall (e,el)) t p
 
+
+
+(* ---------------------------------------------------------------------- *)
+(* DEAD CODE ELIMINATION *)
+
+let dce_check_class ctx c =
+	let keep_whole_class = c.cl_extern || has_meta ":keep" c.cl_meta || (match c.cl_path with ["php"],"Boot" | ["neko"],"Boot" | ["flash"],"Boot" -> true | _ -> false)  in
+	let keep stat f =
+		keep_whole_class
+		|| has_meta ":?used" f.cf_meta
+		|| has_meta ":keep" f.cf_meta
+		|| (stat && f.cf_name = "__init__")
+		|| (not stat && f.cf_name = "resolve" && (match c.cl_dynamic with Some _ -> true | None -> false))
+		|| (f.cf_name = "new" && has_meta ":?used" c.cl_meta)
+		|| match String.concat "." (fst c.cl_path @ [snd c.cl_path;f.cf_name]) with
+		| "js.Boot.__init" | "flash._Boot.RealBoot.new"
+		| "js.Boot.__string_rec" (* used by $estr *)
+		| "js.Boot.__instanceof" (* used by catch( e : T ) *)
+			-> true
+		| _ -> false
+	in
+	keep
+
+(*
+	make sure that all things we are supposed to keep are correctly typed
+*)
+let dce_finalize ctx =
+	let check_class c =
+		let keep = dce_check_class ctx c in
+		let check stat f = if keep stat f then ignore(follow f.cf_type) in
+		(match c.cl_constructor with Some f -> check false f | _ -> ());
+		List.iter (check false) c.cl_ordered_fields;
+		List.iter (check true) c.cl_ordered_statics;
+	in
+	Hashtbl.iter (fun _ m ->
+		List.iter (fun t ->
+			match t with
+			| TClassDecl c -> check_class c
+			| _ -> ()
+		) m.mtypes
+	) ctx.g.modules
+
+(*
+	remove unused fields and mark unused classes as extern
+*)
+let dce_optimize ctx =
+	let check_class c =
+		let keep = dce_check_class ctx c in
+		c.cl_constructor <- (match c.cl_constructor with Some f when not (keep false f) -> None | x -> x);
+		c.cl_ordered_fields <- List.filter (keep false) c.cl_ordered_fields;
+		c.cl_ordered_statics <- List.filter (keep true) c.cl_ordered_statics;
+		c.cl_fields <- List.fold_left (fun acc f -> PMap.add f.cf_name f acc) PMap.empty c.cl_ordered_fields;
+		c.cl_statics <- List.fold_left (fun acc f -> PMap.add f.cf_name f acc) PMap.empty c.cl_ordered_statics;
+		if c.cl_ordered_statics = [] && c.cl_ordered_fields = [] then
+			match c with
+			| { cl_extern = true }
+			| { cl_path = ["flash";"_Boot"],"RealBoot" }
+				-> ()
+			| _ when has_meta ":?used" c.cl_meta || has_meta ":keep" c.cl_meta || (match c.cl_constructor with Some f -> has_meta ":?used" f.cf_meta | _ -> false)
+				-> ()
+			| _ ->
+				if ctx.com.verbose then print_endline ("Removing " ^ s_type_path c.cl_path);
+				c.cl_extern <- true;
+				(match c.cl_path with [],"Std" -> () | _ -> c.cl_init <- None);
+				c.cl_meta <- [":native",[(EConst (String "Dynamic"),c.cl_pos)],c.cl_pos]; (* make sure the type will not be referenced *)
+	in
+	if ctx.com.verbose then print_endline "Performing dead code optimization";
+	Hashtbl.iter (fun _ m ->
+		List.iter (fun t ->
+			match t with
+			| TClassDecl c -> check_class c
+			| _ -> ()
+		) m.mtypes
+	) ctx.g.modules
+
 (* ---------------------------------------------------------------------- *)
 (* FINALIZATION *)
 
+let get_main ctx =
+	match ctx.com.main_class with
+	| None -> None
+	| Some cl ->
+		let t = Typeload.load_type_def ctx null_pos { tpackage = fst cl; tname = snd cl; tparams = []; tsub = None } in
+		let ft, r = (match t with
+		| TEnumDecl _ | TTypeDecl _ ->
+			error ("Invalid -main : " ^ s_type_path cl ^ " is not a class") null_pos
+		| TClassDecl c ->
+			try
+				let f = PMap.find "main" c.cl_statics in
+				let t = field_type f in
+				(match follow t with
+				| TFun ([],r) -> t, r
+				| _ -> error ("Invalid -main : " ^ s_type_path cl ^ " has invalid main function") c.cl_pos);
+			with
+				Not_found -> error ("Invalid -main : " ^ s_type_path cl ^ " does not have static function main") c.cl_pos
+		) in
+		let emain = type_type ctx cl null_pos in
+		Some (mk (TCall (mk (TField (emain,"main")) ft null_pos,[])) r null_pos)
+
 let rec finalize ctx =
 	let delays = ctx.g.delayed in
 	ctx.g.delayed <- [];
 	match delays with
-	| [] -> () (* at last done *)
+	| [] when ctx.com.dead_code_elimination ->
+		ignore(get_main ctx);
+		dce_finalize ctx;
+		if ctx.g.delayed = [] then dce_optimize ctx else finalize ctx
+	| [] ->
+		(* at last done *)
+		()
 	| l ->
 		List.iter (fun f -> f()) l;
 		finalize ctx
@@ -1938,7 +2049,7 @@ type state =
 	| Done
 	| NotYet
 
-let generate ctx main =
+let generate ctx =
 	let types = ref [] in
 	let modules = ref [] in
 	let states = Hashtbl.create 0 in
@@ -2046,27 +2157,7 @@ let generate ctx main =
 
 	in
 	Hashtbl.iter (fun _ m -> modules := m :: !modules; List.iter loop m.mtypes) ctx.g.modules;
-	let main = (match main with
-	| None -> None
-	| Some cl ->
-		let t = Typeload.load_type_def ctx null_pos { tpackage = fst cl; tname = snd cl; tparams = []; tsub = None } in
-		let ft, r = (match t with
-		| TEnumDecl _ | TTypeDecl _ ->
-			error ("Invalid -main : " ^ s_type_path cl ^ " is not a class") null_pos
-		| TClassDecl c ->
-			try
-				let f = PMap.find "main" c.cl_statics in
-				let t = field_type f in
-				(match follow t with
-				| TFun ([],r) -> t, r
-				| _ -> error ("Invalid -main : " ^ s_type_path cl ^ " has invalid main function") c.cl_pos);
-			with
-				Not_found -> error ("Invalid -main : " ^ s_type_path cl ^ " does not have static function main") c.cl_pos
-		) in
-		let emain = type_type ctx cl null_pos in
-		Some (mk (TCall (mk (TField (emain,"main")) ft null_pos,[])) r null_pos);
-	) in
-	main, List.rev !types, List.rev !modules
+	get_main ctx, List.rev !types, List.rev !modules
 
 (* ---------------------------------------------------------------------- *)
 (* MACROS *)
@@ -2322,7 +2413,7 @@ let load_macro ctx cpath f p =
 			ignore(Typeload.load_module ctx2 (["haxe";"macro"],"Expr") p);
 			ignore(Typeload.load_module ctx2 (["haxe";"macro"],"Type") p);
 			finalize ctx2;
-			let _, types, _ = generate ctx2 None in
+			let _, types, _ = generate ctx2 in
 			Interp.add_types mctx types;
 			Interp.init mctx;
 			ctx2
@@ -2338,7 +2429,7 @@ let load_macro ctx cpath f p =
 	let in_macro = ctx.in_macro in
 	if not in_macro then begin
 		finalize ctx2;
-		let _, types, modules = generate ctx2 None in
+		let _, types, modules = generate ctx2 in
 		ctx2.com.types <- types;
 		ctx2.com.Common.modules <- modules;
 		Interp.add_types mctx types;