compiler : fixed issue with cascading inline+haxe.rtti.Generic

optimizer : reduce constant int/float/bool expressions and immediate function calls
flash9/as3/php : don't add Boot.skip_constructor test if no side effects in constructor

codegen.ml

@@ -180,38 +180,7 @@ let build_generic ctx c p tl =
 			| _ ->
 				try List.assq t subst with Not_found -> Type.map build_type t
 		in
-		let rec build_expr e =
-			let t = build_type e.etype in
-			match e.eexpr with
-			| TFunction f ->
-				{
-					eexpr = TFunction {
-						tf_args = List.map (fun (n,o,t) -> n, o, build_type t) f.tf_args;
-						tf_type = build_type f.tf_type;
-						tf_expr = build_expr f.tf_expr;
-					};
-					etype = t;
-					epos = e.epos;
-				}
-			| TNew (c,tl,el) ->
-				let c, tl = (match follow t with TInst (c,tl) -> c, tl | _ -> assert false) in
-				{
-					eexpr = TNew (c,tl,List.map build_expr el);
-					etype = t;
-					epos = e.epos;
-				};
-			| TVars vl ->
-				{
-					eexpr = TVars (List.map (fun (v,t,eo) ->
-						v, build_type t, (match eo with None -> None | Some e -> Some (build_expr e))
-					) vl);
-					etype = t;
-					epos = e.epos;
-				}
-			(* there's still some 't' lefts in TFor, TMatch and TTry *)
-			| _ ->
-				Type.map_expr build_expr { e with etype = t }
-		in
+		let rec build_expr e = map_expr_type build_expr build_type e in
 		let build_field f =
 			let t = build_type f.cf_type in
 			{ f with cf_type = t; cf_expr = (match f.cf_expr with None -> None | Some e -> Some (build_expr e)) }
@@ -655,20 +624,20 @@ let check_local_vars_init e =
 		| _ ->
 			Type.iter (loop vars) e
 	in
-	loop (ref PMap.empty) e
+	loop (ref PMap.empty) e;
+	e
 
 (* -------------------------------------------------------------------------- *)
 (* POST PROCESS *)
 
-let post_process ctx =
+let post_process ctx filters =
 	List.iter (function
 		| TClassDecl c ->
 			let process_field f =
 				match f.cf_expr with
 				| None -> ()
 				| Some e ->
-					check_local_vars_init e; 
-					f.cf_expr <- Some (block_vars ctx e)
+					f.cf_expr <- Some (List.fold_left (fun e f -> f e) e filters)
 			in
 			List.iter process_field c.cl_ordered_fields;
 			List.iter process_field c.cl_ordered_statics;
@@ -677,9 +646,8 @@ let post_process ctx =
 			| Some f -> process_field f);
 			(match c.cl_init with
 			| None -> ()
-			| Some e ->
-				check_local_vars_init e;
-				c.cl_init <- Some (block_vars ctx e));
+			| Some e ->				
+				c.cl_init <- Some (List.fold_left (fun e f -> f e) e filters));
 		| TEnumDecl _ -> ()
 		| TTypeDecl _ -> ()
 	) ctx.types
@@ -859,3 +827,19 @@ let bytes_serialize data =
 	let tbl = Array.init (String.length b64) (fun i -> String.get b64 i) in
 	let str = Base64.str_encode ~tbl data in
 	"s" ^ string_of_int (String.length str) ^ ":" ^ str
+
+(*
+	Tells if the constructor might be called without any issue whatever its parameters
+*)
+let rec constructor_side_effects e =
+	match e.eexpr with
+	| TBinop (op,_,_) when op <> OpAssign ->
+		true
+	| TUnop _ | TArray _ | TField _ | TCall _ | TNew _ | TFor _ | TWhile _ | TSwitch _ | TMatch _ | TReturn _ | TThrow _ ->
+		true
+	| _ -> 
+		try 
+			Type.iter (fun e -> if constructor_side_effects e then raise Exit) e;
+			false;
+		with Exit ->
+			true

common.ml

@@ -47,6 +47,7 @@ type context_type_api = {
 	mutable build_instance : module_type -> pos -> ((string * t) list * path * (t list -> t));
 	mutable on_generate : module_type -> unit;
 	mutable get_type_module : module_type -> module_def;
+	mutable optimize : texpr -> texpr;
 }
 
 type context = {
@@ -104,6 +105,7 @@ let create v =
 			build_instance = (fun _ _ -> assert false);
 			on_generate = (fun _ -> ());
 			get_type_module = (fun _ -> assert false);
+			optimize = (fun _ -> assert false);
 		};
 		lines = Lexer.build_line_index();
 	}

doc/CHANGES.txt

@@ -1,8 +1,6 @@
 TODO :
 	SWC input support
-	optimizer : reduce/calculate expressions
 	flash9 : optimize enum parameters storage
-	don't use Boot.skip_constructor if no side effects in constructor
 	rtti : allow rtti on all types and store them in a global static Hash<CType> (instead of XML)
 
 2009-??-??: 2.03
@@ -34,6 +32,9 @@ TODO :
 	flash9 : fixed verify error with loop variable beeing a specific class
 	compiler : prevent truncating float dynamic values to int when using numerical operations
 	neko.db.Manager fix : synchronize fields after locking an unlocked cached object
+	compiler : fixed issue with cascading inline+haxe.rtti.Generic
+	optimizer : reduce constant int/float/bool expressions and immediate function calls
+	flash9/as3/php : don't add Boot.skip_constructor test if no side effects in constructor
 
 2008-11-23: 2.02
 	Std.is(MyInterface, Class) now returns true (haXe/PHP)

genas3.ml

@@ -477,7 +477,7 @@ and gen_expr ctx e =
 		let b = save_locals ctx in
 		print ctx "{";
 		let bend = open_block ctx in
-		let cb = (if not ctx.constructor_block then
+		let cb = (if not ctx.constructor_block || not (Codegen.constructor_side_effects e) then
 			(fun () -> ())
 		else begin
 			ctx.constructor_block <- false;

genphp.ml

@@ -1135,8 +1135,11 @@ and gen_expr ctx e =
 					newline ctx;
 				| _ -> ()
 			) ctx.dynamic_methods;
-			print ctx "if( !%s::$skip_constructor ) {" (s_path ctx (["php"],"Boot") false e.epos);
-			(fun() -> print ctx "}")
+			if Codegen.constructor_side_effects e then begin
+				print ctx "if( !%s::$skip_constructor ) {" (s_path ctx (["php"],"Boot") false e.epos);
+				(fun() -> print ctx "}")
+			end else
+				(fun() -> ())
 			end) in
 		List.iter (fun e -> newline ctx; gen_expr ctx e) el;
 		bend();

genswf9.ml

@@ -1565,6 +1565,7 @@ let generate_construct ctx fdata c =
 	(* if skip_constructor, then returns immediatly *)
 	(match c.cl_kind with
 	| KGenericInstance _ -> ()
+	| _ when not (Codegen.constructor_side_effects fdata.tf_expr) -> ()
 	| _ ->
 		let id = ident "skip_constructor" in
 		getvar ctx (VGlobal (type_path ctx (["flash"],"Boot")));

main.ml

@@ -438,7 +438,12 @@ try
 		if !no_output then com.platform <- Cross;
 		com.types <- Typer.types ctx com.main_class (!excludes);
 		com.lines <- Lexer.build_line_index();
-		Codegen.post_process com;
+		let filters = [
+			Codegen.check_local_vars_init;
+			Codegen.block_vars com;
+			Optimizer.reduce_expression com;
+		] in
+		Codegen.post_process com filters;
 		(match com.platform with
 		| Cross ->
 			()

optimizer.ml

@@ -143,7 +143,7 @@ let type_inline ctx cf f ethis params tret p =
 			| TBlock l, Some init -> mk (TBlock (init :: l)) tret e.epos
 			| _, Some init -> mk (TBlock [init;e]) tret e.epos
 		) in
-		(* we need to replace type-parameters that were used in the expression *)		
+		(* we need to replace type-parameters that were used in the expression *)
 		let tparams = (match follow ethis.etype with TInst (c,pl) -> (c.cl_types,pl) | _ -> ([],[])) in
 		match cf.cf_params, tparams with
 		| [], ([],_) -> Some e
@@ -157,11 +157,9 @@ let type_inline ctx cf f ethis params tret p =
 				this is very expensive since we are building the substitution list for 
 				every expression, but hopefully in such cases the expression size is small
 			*)
-			let rec map_type e = 
-				let e = { e with etype = apply_params tparams tmonos e.etype } in
-				Type.map_expr map_type e
-			in
-			Some (map_type e)
+			let map_type t = apply_params tparams tmonos t in
+			let rec map_expr_type e = Type.map_expr_type map_expr_type map_type e in
+			Some (map_expr_type e)
 
 (* ---------------------------------------------------------------------- *)
 (* LOOPS *)
@@ -269,3 +267,139 @@ let optimize_for_loop ctx i e1 e2 p =
 		]
 	| _ ->
 		None
+
+(* ---------------------------------------------------------------------- *)
+(* REDUCE *)
+
+let rec reduce_loop com is_sub e =
+	let is_float t =
+		match follow t with
+		| TInst ({ cl_path = ([],"Float") },_) -> true
+		| _ -> false
+	in
+	let is_text_platform() =
+		match com.platform with
+		| Js | Php -> true 
+		| Neko | Flash | Flash9 | Cross -> false
+	in
+	let e = Type.map_expr (reduce_loop com (match e.eexpr with TBlock _ -> false | _ -> true)) e in
+	match e.eexpr with
+	| TIf ({ eexpr = TConst (TBool t) },e1,e2) ->
+		(if t then e1 else match e2 with None -> { e with eexpr = TBlock [] } | Some e -> e)
+	| TWhile ({ eexpr = TConst (TBool false) },sub,flag) ->
+		(match flag with
+		| NormalWhile -> { e with eexpr = TBlock [] } (* erase sub *)
+		| DoWhile -> e) (* we cant remove while since sub can contain continue/break *)
+	| TBinop (op,e1,e2) ->		
+		let zero = (match op with
+			| OpAdd | OpSub | OpShl | OpShr | OpUShr | OpXor -> Some (0l,0.)
+			| OpMult | OpDiv -> Some (1l,1.)
+			| _ -> None
+		) in
+		(match e1.eexpr, e2.eexpr with
+		| TConst (TInt v) , _ when (match zero with Some (z,_) when z = v -> true | _ -> false) -> e2
+		| _ , TConst (TInt v) when (match zero with Some (z,_) when z = v -> true | _ -> false) -> e1
+		| TConst (TFloat v) , _ when (match zero with Some (_,z) when z = float_of_string v -> is_float e2.etype | _ -> false) -> e2
+		| _ , TConst (TFloat v) when (match zero with Some (_,z) when z = float_of_string v -> is_float e1.etype | _ -> false) -> e1
+		| TConst (TInt a), TConst (TInt b) ->
+			let opt f = try { e with eexpr = TConst (TInt (f a b)) } with Exit -> e in
+			let check_overflow f =
+				opt (fun a b ->
+					let v = f (Int64.of_int32 a) (Int64.of_int32 b) in
+					let iv = Int64.to_int32 v in
+					if Int64.compare (Int64.of_int32 iv) v <> 0 then raise Exit;
+					iv
+				)
+			in
+			let ebool t =
+				{ e with eexpr = TConst (TBool (t (Int32.compare a b))) }
+			in
+			(match op with
+			| OpAdd -> check_overflow Int64.add
+			| OpSub -> check_overflow Int64.sub
+			| OpMult -> check_overflow Int64.mul
+			| OpAnd -> opt Int32.logand
+			| OpOr -> opt Int32.logor
+			| OpXor -> opt Int32.logxor
+			| OpShl -> opt (fun a b -> Int32.shift_left a (Int32.to_int b))
+			| OpShr -> opt (fun a b -> Int32.shift_right a (Int32.to_int b))
+			| OpUShr -> opt (fun a b -> Int32.shift_right_logical a (Int32.to_int b))
+			| OpEq -> ebool ((=) 0)
+			| OpNotEq -> ebool ((<>) 0)
+			| OpGt -> ebool ((>) 0)
+			| OpGte -> ebool ((>=) 0)
+			| OpLt -> ebool ((<) 0)
+			| OpLte -> ebool ((<=) 0)
+			| _ -> e)
+		| TConst (TFloat a), TConst (TFloat b) ->
+			let fop f =
+				let v = f (float_of_string a) (float_of_string b) in
+				let vstr = string_of_float v in
+				if v = float_of_string vstr then
+					{ e with eexpr = TConst (TFloat vstr) }
+				else
+					e
+			in
+			let ebool t =
+				{ e with eexpr = TConst (TBool (t (compare a b))) }
+			in
+			(match op with
+			| OpAdd -> fop (+.)
+			| OpSub -> fop (-.)
+			| OpMult -> fop ( *. )
+			| OpEq -> ebool ((=) 0)
+			| OpNotEq -> ebool ((<>) 0)
+			| OpGt -> ebool ((>) 0)
+			| OpGte -> ebool ((>=) 0)
+			| OpLt -> ebool ((<) 0)
+			| OpLte -> ebool ((<=) 0)
+			| _ -> e)			
+		| TConst (TBool a), TConst (TBool b) ->
+			let ebool f =
+				{ e with eexpr = TConst (TBool (f a b)) }
+			in
+			(match op with
+			| OpEq -> ebool (=)
+			| OpNotEq -> ebool (<>)
+			| OpBoolAnd -> ebool (&&)
+			| OpBoolOr -> ebool (||)
+			| _ -> e)
+		| _ -> e)
+	| TCall ({ eexpr = TFunction func },el) ->
+		let rec build term e =
+			match e.eexpr with
+			| TBlock el ->
+				(match List.rev el with
+				| [] -> e
+				| e1 :: el ->
+					let el = List.map (build false) (List.rev el) in
+					let e1 = build term e1 in
+					{ e with eexpr = TBlock (e1 :: el) })
+			| TParenthesis _ | TIf (_,_,Some _) | TSwitch _ | TMatch _ | TTry _ ->
+				(* might only cause issues if some 'return' found in the first expression of if/switch/match *)
+				Type.map_expr (build term) e
+			| TReturn eo ->				
+				if not term then raise Exit;
+				(match eo with
+				| None -> { e with eexpr = TBlock [] }
+				| Some e -> build term e)
+			| _ ->
+				Type.map_expr (build false) e
+		in
+		(try
+			let body = build true func.tf_expr in
+			let body = (match body.eexpr with TBlock el -> el | _ -> [body]) in
+			let body = (match el with
+				| [] -> body
+				| _ ->					
+					if is_sub && is_text_platform() then raise Exit; 
+					mk (TVars (List.map2 (fun (p,_,t) e -> p,t,Some e) func.tf_args el)) com.type_api.tvoid e.epos :: body
+			) in
+			{ e with eexpr = TBlock body }
+		with
+			Exit -> e)
+	| _ -> 
+		e
+
+let reduce_expression com e =
+	reduce_loop com false e

type.ml

@@ -8,7 +8,7 @@
  *  (at your option) any later version.
  *
  *  This program is distributed in the hope that it will be useful,
- *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  but WITHOUT ANY WARRANTY; without even the implied warraTFnty of
  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  *  GNU General Public License for more details.
  *
@@ -758,7 +758,7 @@ and unify_with_access t f =
 	| _ , NoAccess -> unify t f.cf_type
 	| _ , _ -> type_eq EqBothDynamic t f.cf_type
 
-let rec iter f e =
+let iter f e =
 	match e.eexpr with
 	| TConst _
 	| TLocal _
@@ -809,7 +809,7 @@ let rec iter f e =
 	| TReturn eo ->
 		(match eo with None -> () | Some e -> f e)
 
-let rec map_expr f e =
+let map_expr f e =
 	match e.eexpr with
 	| TConst _
 	| TLocal _
@@ -858,3 +858,61 @@ let rec map_expr f e =
 		{ e with eexpr = TTry (f e1, List.map (fun (v,t,e) -> v, t, f e) catches) }
 	| TReturn eo ->
 		{ e with eexpr = TReturn (match eo with None -> None | Some e -> Some (f e)) }
+
+let map_expr_type f ft e =
+	match e.eexpr with
+	| TConst _
+	| TLocal _
+	| TEnumField _
+	| TBreak
+	| TContinue
+	| TTypeExpr _ ->
+		{ e with etype = ft e.etype }
+	| TArray (e1,e2) ->
+		{ e with eexpr = TArray (f e1,f e2); etype = ft e.etype }
+	| TBinop (op,e1,e2) ->
+		{ e with eexpr = TBinop (op,f e1,f e2); etype = ft e.etype }
+	| TFor (v,t,e1,e2) ->
+		{ e with eexpr = TFor (v,ft t,f e1,f e2); etype = ft e.etype }
+	| TWhile (e1,e2,flag) ->
+		{ e with eexpr = TWhile (f e1,f e2,flag); etype = ft e.etype }
+	| TThrow e1 ->
+		{ e with eexpr = TThrow (f e1); etype = ft e.etype }
+	| TField (e1,v) ->
+		{ e with eexpr = TField (f e1,v); etype = ft e.etype }
+	| TParenthesis e1 ->
+		{ e with eexpr = TParenthesis (f e1); etype = ft e.etype }
+	| TUnop (op,pre,e1) ->
+		{ e with eexpr = TUnop (op,pre,f e1); etype = ft e.etype }
+	| TArrayDecl el ->
+		{ e with eexpr = TArrayDecl (List.map f el); etype = ft e.etype }
+	| TNew (_,_,el) ->
+		let et = ft e.etype in
+		(* make sure that we use the class corresponding to the replaced type *)
+		let c, pl = (match follow et with TInst (c,pl) -> (c,pl) | _ -> assert false) in
+		{ e with eexpr = TNew (c,pl,List.map f el); etype = et }
+	| TBlock el ->
+		{ e with eexpr = TBlock (List.map f el); etype = ft e.etype }
+	| TObjectDecl el ->
+		{ e with eexpr = TObjectDecl (List.map (fun (v,e) -> v, f e) el); etype = ft e.etype }
+	| TCall (e1,el) ->
+		{ e with eexpr = TCall (f e1, List.map f el); etype = ft e.etype }
+	| TVars vl ->
+		{ e with eexpr = TVars (List.map (fun (v,t,e) -> v , ft t , match e with None -> None | Some e -> Some (f e)) vl); etype = ft e.etype }
+	| TFunction fu ->
+		let fu = {
+			tf_expr = f fu.tf_expr;
+			tf_args = List.map (fun (n,o,t) -> n, o, ft t) fu.tf_args;
+			tf_type = ft fu.tf_type;
+		} in
+		{ e with eexpr = TFunction fu; etype = ft e.etype }
+	| TIf (ec,e1,e2) ->
+		{ e with eexpr = TIf (f ec,f e1,match e2 with None -> None | Some e -> Some (f e)); etype = ft e.etype }
+	| TSwitch (e1,cases,def) ->
+		{ e with eexpr = TSwitch (f e1, List.map (fun (el,e2) -> List.map f el, f e2) cases, match def with None -> None | Some e -> Some (f e)); etype = ft e.etype }
+	| TMatch (e1,(en,pl),cases,def) ->
+		{ e with eexpr = TMatch (f e1, (en,List.map ft pl), List.map (fun (cl,params,e) -> cl, params, f e) cases, match def with None -> None | Some e -> Some (f e)); etype = ft e.etype }
+	| TTry (e1,catches) ->
+		{ e with eexpr = TTry (f e1, List.map (fun (v,t,e) -> v, ft t, f e) catches); etype = ft e.etype }
+	| TReturn eo ->
+		{ e with eexpr = TReturn (match eo with None -> None | Some e -> Some (f e)); etype = ft e.etype }

typeload.ml

@@ -466,7 +466,7 @@ let type_function ctx args ret static constr f p =
 			| None -> None
 			| Some e -> 
 				let p = pos e in
-				let e = type_expr ctx e true in
+				let e = ctx.api.optimize (type_expr ctx e true) in
 				unify ctx e.etype t p;
 				match e.eexpr with
 				| TConst c -> Some c

typer.ml

@@ -1728,6 +1728,7 @@ let create com =
 	ctx.api.build_instance <- Codegen.build_instance ctx;
 	ctx.api.on_generate <- Codegen.on_generate ctx;
 	ctx.api.get_type_module <- get_type_module ctx;
+	ctx.api.optimize <- Optimizer.reduce_expression com;
 	ctx.std <- (try
 		Typeload.load_module ctx ([],"StdTypes") null_pos
 	with