optimizations

doc/CHANGES.txt

@@ -2,6 +2,8 @@
 	fixed Int32.compare, added Int32.read and Int32.write
 	fixed type of unitialized registers in flash9
 	fixed Sqlite transactions (commit and rollback now restart a transaction)
+	optimized a...b loops (tmp variable can't be modified)
+	several flash9 optimizations
 
 2007-10-31: 1.16
 	use _sans font for default flash traces (better Linux support)

genswf9.ml

@@ -189,7 +189,7 @@ let jump_back ctx =
 		write ctx (A3Jump (cond,delta))
 	)
 
-let type_path ctx ?(getclass=false) path =
+let type_path ctx path =
 	let pack, name = (match path with
 		| [] , "Int" -> [] , "int"
 		| [] , "UInt" -> [] , "uint"
@@ -204,7 +204,7 @@ let type_path ctx ?(getclass=false) path =
 	let pid = string ctx (String.concat "." pack) in
 	let nameid = string ctx name in
 	let pid = lookup (A3NPublic (Some pid)) ctx.namespaces in
-	let tid = lookup (if getclass then A3MMultiName (Some nameid,lookup [pid] ctx.nsets) else A3MName (nameid,pid)) ctx.names in
+	let tid = lookup (A3MName (nameid,pid)) ctx.names in
 	tid
 
 let rec follow_basic t =
@@ -492,7 +492,7 @@ let begin_fun ctx args tret el stat =
 	ctx.locals <- PMap.foldi (fun name l acc ->
 		match l with
 		| LReg _ -> acc
-		| LScope _ -> PMap.add name (LGlobal (type_path ctx ~getclass:true ([],name))) acc
+		| LScope _ -> PMap.add name (LGlobal (type_path ctx ([],name))) acc
 		| LGlobal _ -> PMap.add name l acc
 	) ctx.locals PMap.empty;
 	List.iter (fun (name,_,t) ->
@@ -680,7 +680,7 @@ let gen_access ctx e (forset : 'a) : 'a access =
 		gen_expr ctx true eindex;
 		VArray
 	| TTypeExpr t ->
-		let id = type_path ctx ~getclass:true (t_path t) in
+		let id = type_path ctx (t_path t) in
 		if is_set forset then write ctx A3GetGlobalScope;
 		VGlobal id
 	| _ ->
@@ -697,7 +697,7 @@ let rec gen_expr_content ctx retval e =
 	| TParenthesis e ->
 		gen_expr ctx retval e
 	| TEnumField (e,s) ->
-		let id = type_path ctx ~getclass:true e.e_path in
+		let id = type_path ctx e.e_path in
 		write ctx (A3GetLex id);
 		write ctx (A3GetProp (ident ctx s));
 	| TObjectDecl fl ->
@@ -751,7 +751,7 @@ let rec gen_expr_content ctx retval e =
 	| TBinop (op,e1,e2) ->
 		gen_binop ctx retval op e1 e2 e.etype
 	| TCall (e,el) ->
-		gen_call ctx e el
+		gen_call ctx retval e el
 	| TNew (c,_,pl) ->
 		let id = type_path ctx c.cl_path in
 		write ctx (A3FindPropStrict id);
@@ -990,7 +990,7 @@ let rec gen_expr_content ctx retval e =
 		free_reg ctx rindex;
 		free_reg ctx rparams
 
-and gen_call ctx e el =
+and gen_call ctx retval e el =
 	match e.eexpr , el with
 	| TLocal "__is__" , [e;t] ->
 		gen_expr ctx true e;
@@ -1060,34 +1060,37 @@ and gen_call ctx e el =
 		let id = ident ctx f in
 		write ctx (A3FindPropStrict id);
 		List.iter (gen_expr ctx true) el;
-		write ctx (A3CallProperty (id,List.length el));
+		write ctx (if retval then A3CallProperty (id,List.length el) else A3CallPropVoid (id,List.length el));
 	| TField (e1,f) , _ ->
 		gen_expr ctx true e1;
 		List.iter (gen_expr ctx true) el;
-		write ctx (A3CallProperty (property ctx f e1.etype,List.length el));
-		let coerce() =
-			match follow e.etype with
-			| TFun (_,r) -> coerce ctx (classify ctx r)
-			| _ -> ()
-		in
-		(match follow e1.etype with
-		| TInst ({ cl_path = [],"Array" },_) -> 
-			(match f with
-			| "copy" | "remove" -> coerce()
-			| _ -> ())
-		| TInst ({ cl_path = [],"Date" },_) -> 
-			coerce() (* all date methods are typed as Number in AS3 and Int in haXe *) 
-		| TAnon a when (match !(a.a_status) with Statics { cl_path = ([],"Date") } -> true | _ -> false) ->
-			(match f with
-			| "now" | "fromString" | "fromTime"  -> coerce()
-			| _ -> ())
-		| TAnon a when (match !(a.a_status) with Statics { cl_path = ([],"Math") } -> true | _ -> false) ->
-			(match f with
-			| "isFinite" | "isNaN" -> coerce()
-			| _ -> ())
-		| _ -> ())
+		if not retval then
+			write ctx (A3CallPropVoid (property ctx f e1.etype,List.length el))
+		else
+			let coerce() =
+				match follow e.etype with
+				| TFun (_,r) -> coerce ctx (classify ctx r)
+				| _ -> ()
+			in
+			write ctx (A3CallProperty (property ctx f e1.etype,List.length el));
+			(match follow e1.etype with
+			| TInst ({ cl_path = [],"Array" },_) -> 
+				(match f with
+				| "copy" | "remove" -> coerce()
+				| _ -> ())
+			| TInst ({ cl_path = [],"Date" },_) -> 
+				coerce() (* all date methods are typed as Number in AS3 and Int in haXe *) 
+			| TAnon a when (match !(a.a_status) with Statics { cl_path = ([],"Date") } -> true | _ -> false) ->
+				(match f with
+				| "now" | "fromString" | "fromTime"  -> coerce()
+				| _ -> ())
+			| TAnon a when (match !(a.a_status) with Statics { cl_path = ([],"Math") } -> true | _ -> false) ->
+				(match f with
+				| "isFinite" | "isNaN" -> coerce()
+				| _ -> ())
+			| _ -> ())		
 	| TEnumField (e,f) , _ ->
-		let id = type_path ctx ~getclass:true e.e_path in
+		let id = type_path ctx e.e_path in
 		write ctx (A3GetLex id);
 		List.iter (gen_expr ctx true) el;
 		write ctx (A3CallProperty (ident ctx f,List.length el));
@@ -1267,7 +1270,7 @@ let generate_class_init ctx c slot =
 		let path = (match c.cl_super with None -> ([],"Object") | Some (sup,_) -> sup.cl_path) in
 		write ctx (A3GetLex (type_path ctx path));
 		write ctx A3Scope;
-		write ctx (A3GetLex (type_path ctx ~getclass:true path));
+		write ctx (A3GetLex (type_path ctx path));
 	end;
 	write ctx (A3ClassDef (As3parse.magic_index slot));
 	List.iter (fun f ->
@@ -1310,7 +1313,7 @@ let generate_enum_init ctx e slot =
 	write ctx A3GetGlobalScope;
 	write ctx (A3GetLex (type_path ctx path));
 	write ctx A3Scope;
-	write ctx (A3GetLex (type_path ~getclass:true ctx path));
+	write ctx (A3GetLex (type_path ctx path));
 	write ctx (A3ClassDef (As3parse.magic_index slot));
 	write ctx A3PopScope;
 	let r = alloc_reg ctx KDynamic in
@@ -1355,7 +1358,7 @@ let generate_field_kind ctx f c stat =
 		else
 			Some (A3FMethod {
 				m3_type = generate_method ctx fdata stat;
-				m3_final = false;
+				m3_final = stat;
 				m3_override = not stat && loop c;
 				m3_kind = MK3Normal;
 			})
@@ -1468,7 +1471,7 @@ let generate_enum ctx e =
 	write ctx A3RetVoid;
 	let construct = f() in
 	let f = begin_fun ctx [] t_string [] true in
-	write ctx (A3GetLex (type_path ctx ~getclass:true ([],ctx.boot)));
+	write ctx (A3GetLex (type_path ctx ([],ctx.boot)));
 	write ctx A3This;
 	write ctx (A3CallProperty (ident ctx "enum_to_string",1));
 	write ctx A3Ret;
@@ -1477,7 +1480,7 @@ let generate_enum ctx e =
 		cl3_name = name_id;
 		cl3_super = Some (type_path ctx ([],"Object"));
 		cl3_sealed = true;
-		cl3_final = false;
+		cl3_final = true;
 		cl3_interface = false;
 		cl3_namespace = None;
 		cl3_implements = [||];
@@ -1492,7 +1495,7 @@ let generate_enum ctx e =
 				f3_slot = 0;
 				f3_kind = A3FMethod {
 					m3_type = tostring;
-					m3_final = false;
+					m3_final = true;
 					m3_override = false;
 					m3_kind = MK3Normal;
 				};
@@ -1520,7 +1523,7 @@ let generate_enum ctx e =
 					let fid = fdata() in
 					A3FMethod {
 						m3_type = fid;
-						m3_final = false;
+						m3_final = true;
 						m3_override = false;
 						m3_kind = MK3Normal;
 					}

transform.ml

@@ -16,8 +16,41 @@
  *  along with this program; if not, write to the Free Software
  *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  *)
+open Ast
 open Type
 
+let rec iter f e =
+	match e.eexpr with
+	| TConst _
+	| TLocal _
+	| TEnumField _
+	| TBreak
+	| TContinue
+	| TTypeExpr _ -> ()
+	| TArray (e1,e2)
+	| TBinop (_,e1,e2)
+	| TFor (_,_,e1,e2)
+	| TWhile (e1,e2,_)
+		-> f e1; f e2
+	| TThrow e
+	| TField (e,_)
+	| TParenthesis e
+	| TUnop (_,_,e)
+	| TFunction { tf_expr = e }
+		-> f e
+	| TArrayDecl el 
+	| TNew (_,_,el)
+	| TBlock el
+		-> List.iter f el
+	| TObjectDecl el -> List.iter (fun (_,e) -> f e) el
+	| TCall (e,el) -> f e; List.iter f el
+	| TVars vl -> List.iter (fun (_,_,eo) -> match eo with None -> () | Some e -> f e) vl
+	| TIf (e,e1,e2) -> f e; f e1; (match e2 with None -> () | Some e -> f e)
+	| TSwitch (e,cases,def) -> f e; List.iter (fun (el,e) -> List.iter f el; f e) cases; (match def with None -> () | Some e -> f e)
+	| TMatch (e,_,cases,def) -> f e; List.iter (fun (_,_,e) -> f e) cases; (match def with None -> () | Some e -> f e)
+	| TTry (e,catches) -> f e; List.iter (fun (_,_,e) -> f e) catches
+	| TReturn eo -> (match eo with None -> () | Some e -> f e)
+
 let rec map f e =
 	match e.eexpr with
 	| TConst _
@@ -198,7 +231,7 @@ let block_vars e =
 	in
 	out_loop e
 
-let emk e = mk e (mk_mono()) Ast.null_pos
+let emk e = mk e (mk_mono()) null_pos
 
 let block e =
 	match e.eexpr with
@@ -215,12 +248,12 @@ let stack_push useadd (c,m) =
 	emk (TCall (emk (TField (stack_e,"push")),[
 		if useadd then
 			emk (TBinop (
-				Ast.OpAdd,
-				emk (TConst (TString (Ast.s_type_path c.cl_path ^ "::"))),
+				OpAdd,
+				emk (TConst (TString (s_type_path c.cl_path ^ "::"))),
 				emk (TConst (TString m))
 			))
 		else
-			emk (TConst (TString (Ast.s_type_path c.cl_path ^ "::" ^ m)))
+			emk (TConst (TString (s_type_path c.cl_path ^ "::" ^ m)))
 	]))
 
 let stack_save_pos =
@@ -229,9 +262,9 @@ let stack_save_pos =
 let stack_restore_pos =
 	let ev = emk (TLocal exc_stack_var) in
 	[
-	emk (TBinop (Ast.OpAssign, ev, emk (TArrayDecl [])));
+	emk (TBinop (OpAssign, ev, emk (TArrayDecl [])));
 	emk (TWhile (
-		emk (TBinop (Ast.OpGte,
+		emk (TBinop (OpGte,
 			emk (TField (stack_e,"length")),
 			emk (TLocal stack_var_pos)
 		)),
@@ -242,7 +275,7 @@ let stack_restore_pos =
 				[]
 			))]
 		)),
-		Ast.NormalWhile
+		NormalWhile
 	));
 	emk (TCall (emk (TField (stack_e,"push")),[ emk (TArray (ev,emk (TConst (TInt 0l)))) ]))
 	]
@@ -290,3 +323,41 @@ let rec is_volatile t =
 		| _ -> is_volatile (apply_params t.t_types tl t.t_type))
 	| _ ->
 		false
+
+let optimize_for_loop i pt e1 make_e2 p t_void t_bool gen_local error =
+	match e1.eexpr with
+	| TNew ({ cl_path = ([],"IntIter") },[],[i1;i2]) ->
+		(match i1.eexpr , i2.eexpr with
+		| TConst (TInt a), TConst (TInt b) when Int32.compare b a <= 0 -> error "Range operate can't iterate backwards" p
+		| _ -> ());
+		let rec check e =
+			match e.eexpr with
+			| TBinop (OpAssign,{ eexpr = TLocal l },_)
+			| TBinop (OpAssignOp _,{ eexpr = TLocal l },_)
+			| TUnop (Increment,_,{ eexpr = TLocal l })
+			| TUnop (Decrement,_,{ eexpr = TLocal l })  when l = i ->
+				error "Loop variable cannot be modified" e.epos
+			| TFunction f when List.exists (fun (l,_,_) -> l = i) f.tf_args ->
+				()
+			| _ ->
+				iter check e
+		in
+		let max = gen_local i2.etype in
+		let e2 = make_e2() in
+		check e2;
+		let ident = mk (TLocal i) i1.etype p in
+		let incr = mk (TUnop (Increment,Prefix,ident)) i1.etype p in
+		let block = match e2.eexpr with
+			| TBlock el -> mk (TBlock (el@[incr])) t_void e2.epos
+			| _ -> mk (TBlock [e2;incr]) t_void p
+		in
+		mk (TBlock [
+			mk (TVars [i,i1.etype,Some i1;max,i2.etype,Some i2]) t_void p;
+			mk (TWhile (
+				mk (TBinop (OpLt, ident, mk (TLocal max) i2.etype p)) t_bool p,
+				block,
+				NormalWhile
+			)) t_void p;
+		]) t_void p
+	| _ ->
+		mk (TFor (i,pt,e1,make_e2())) t_void p

typer.ml

@@ -1739,33 +1739,7 @@ and type_expr ctx ?(need_val=true) (e,p) =
 		let old_locals = save_locals ctx in
 		let i = add_local ctx i pt in
 		ctx.in_loop <- true;
-		let e = (match e1.eexpr with
-		| TNew ({ cl_path = ([],"IntIter") },[],[i1;i2]) ->
-			(match i1.eexpr , i2.eexpr with
-			| TConst (TInt a), TConst (TInt b) when Int32.compare b a <= 0 ->
-				error "Range operate can't iterate backwards" p
-			| _ -> ());
-			let max = gen_local ctx i2.etype in
-			let n = gen_local ctx i1.etype in
-			let e2 = type_expr ~need_val:false ctx e2 in
-			let block = [
-				mk (TVars [i,i1.etype,Some (mk (TLocal n) i1.etype p)]) (t_void ctx) p;
-				mk (TUnop (Increment,Prefix,mk (TLocal n) i1.etype p)) i1.etype p;
-				e2
-			] in
-			let ident = mk (TLocal n) i1.etype p in
-			mk (TBlock [
-				mk (TVars [n,i1.etype,Some i1;max,i2.etype,Some i2]) (t_void ctx) p;
-				mk (TWhile (
-					mk (TBinop (OpLt, ident, mk (TLocal max) i2.etype p)) (t_bool ctx) p,
-					mk (TBlock block) (t_void ctx) p,
-					NormalWhile
-				)) (t_void ctx) p;
-			]) (t_void ctx) p
-		| _ ->
-			let e2 = type_expr ~need_val:false ctx e2 in
-			mk (TFor (i,pt,e1,e2)) (t_void ctx) p
-		) in
+		let e = Transform.optimize_for_loop i pt e1 (fun () -> type_expr ~need_val:false ctx e2) p (t_void ctx) (t_bool ctx) (gen_local ctx) error in
 		ctx.in_loop <- old_loop;
 		old_locals();
 		e