debug support.

doc/CHANGES.txt

@@ -11,7 +11,7 @@
 	added remoting over XMLSocket and LocalConnection for Flash9
 	fixed Std.is(*,null) = false
 	allowed >64K haXe/neko strings
-	(TODO) -debug support for both Flash and JS
+	-debug and stack traces support for Flash and JS
 	(TODO) resources in Flash9
 
 2006-08-28: 1.06

genjs.ml

@@ -28,6 +28,8 @@ type ctx = {
 	mutable in_value : bool;
 	mutable handle_break : bool;
 	mutable id_counter : int;
+	debug : bool;
+	mutable curmethod : (string * bool);
 }
 
 let s_path = function
@@ -67,16 +69,19 @@ let rec concat ctx s f = function
 		spr ctx s;
 		concat ctx s f l
 
+let block = Transform.block
+
+let fun_block ctx f =
+	if ctx.debug then
+		Transform.stack_block (ctx.current,fst ctx.curmethod) f.tf_expr
+	else
+		block f.tf_expr
+
 let parent e =
 	match e.eexpr with
 	| TParenthesis _ -> e
 	| _ -> mk (TParenthesis e) e.etype e.epos
 
-let block e =
-	match e.eexpr with
-	| TBlock (_ :: _) -> e
-	| _ -> mk (TBlock [e]) e.etype e.epos
-
 let open_block ctx =
 	let oldt = ctx.tabs in
 	ctx.tabs <- "\t" ^ ctx.tabs;
@@ -241,9 +246,15 @@ and gen_expr ctx e =
 		print ctx "}";
 	| TFunction f ->
 		let old = ctx.in_value in
+		let old_meth = ctx.curmethod in
 		ctx.in_value <- false;
+		if snd ctx.curmethod then
+			ctx.curmethod <- (fst ctx.curmethod ^ "@" ^ string_of_int (Lexer.get_error_line e.epos), true)
+		else
+			ctx.curmethod <- (fst ctx.curmethod, true);
 		print ctx "function(%s) " (String.concat "," (List.map ident (List.map arg_name f.tf_args)));
-		gen_expr ctx (block f.tf_expr);
+		gen_expr ctx (fun_block ctx f);
+		ctx.curmethod <- old_meth;
 		ctx.in_value <- old;
 	| TCall (e,el) ->
 		gen_call ctx e el
@@ -562,6 +573,7 @@ let gen_class_static_field ctx c f =
 		let e = Transform.block_vars e in
 		match e.eexpr with
 		| TFunction _ ->
+			ctx.curmethod <- (f.cf_name,false);
 			print ctx "%s%s = " (s_path c.cl_path) (field f.cf_name);
 			gen_value ctx e;
 			newline ctx
@@ -575,22 +587,24 @@ let gen_class_field ctx c f =
 		print ctx "null";
 		newline ctx
 	| Some e ->
+		ctx.curmethod <- (f.cf_name,false);
 		gen_value ctx (Transform.block_vars e);
 		newline ctx
 
 let generate_class ctx c =
 	ctx.current <- c;
+	ctx.curmethod <- ("new",true);
 	let p = s_path c.cl_path in
 	generate_package_create ctx c.cl_path;
 	print ctx "%s = " p;
 	(match c.cl_constructor with
-	| Some { cf_expr = Some e } -> 
+	| Some { cf_expr = Some e } ->
 		(match Transform.block_vars e with
 		| { eexpr = TFunction f } ->
 			let args  = List.map arg_name f.tf_args in
 			let a, args = (match args with [] -> "p" , ["p"] | x :: _ -> x, args) in
 			print ctx "function(%s) { if( %s === $_ ) return; " (String.concat "," (List.map ident args)) a;
-			gen_expr ctx (block f.tf_expr);
+			gen_expr ctx (fun_block ctx f);
 			print ctx "}";
 		| _ -> assert false)
 	| _ -> print ctx "function() { }");
@@ -661,13 +675,21 @@ let generate file types hres =
 		tabs = "";
 		in_value = false;
 		handle_break = false;
+		debug = Plugin.defined "debug";
 		id_counter = 0;
+		curmethod = ("",false);
 	} in
 	List.iter (generate_type ctx) types;
 	print ctx "$_ = {}";
 	newline ctx;
 	print ctx "js.Boot.__res = {}";
 	newline ctx;
+	if ctx.debug then begin
+		print ctx "%s = []" Transform.stack_var;
+		newline ctx;
+		print ctx "%s = []" Transform.exc_stack_var;
+		newline ctx;
+	end;
 	Hashtbl.iter (fun name data ->
 		if String.contains data '\000' then failwith ("Resource " ^ name ^ " contains \\0 characters that can't be used in JavaScript");
 		print ctx "js.Boot.__res[\"%s\"] = \"%s\"" (Ast.s_escape name) (Ast.s_escape data);

genswf8.ml

@@ -43,8 +43,9 @@ type context = {
 	mutable reg_max : int;
 	mutable fun_stack : int;
 	version : int;
-	mutable curclass : (string list * string);
-	mutable curmethod : string;
+	debug : bool;
+	mutable curclass : tclass;
+	mutable curmethod : (string * bool);
 	mutable fun_pargs : (int * bool list) list;
 
 	(* loops *)
@@ -111,7 +112,7 @@ let stack_delta = function
 	| op -> failwith ("Unknown stack delta for " ^ (ActionScript.action_string (fun _ -> "") 0 op))
 
 let overflow ctx =
-	failwith ("In or near the method " ^ s_type_path ctx.curclass ^ "." ^ ctx.curmethod ^
+	failwith ("In or near the method " ^ s_type_path ctx.curclass.cl_path ^ "." ^ fst ctx.curmethod ^
 	" too much code is causing an overflow that can't be handled by the SWF format. " ^
 	"Please split your code in several methods so it can be correctly compiled.")
 
@@ -411,7 +412,7 @@ let free_reg ctx r p =
 (* Generation Helpers *)
 
 let define_var ctx v ef exprs =
-	if ctx.version = 6 || List.exists (Transform.local_find false v) exprs then begin
+	if ctx.version = 6 || List.exists (Transform.local_find false v) exprs || v = Transform.stack_var_pos then begin
 		push ctx [VStr (v,false)];
 		ctx.regs <- PMap.add v NoReg ctx.regs;
 		match ef with
@@ -571,12 +572,6 @@ and gen_try_catch ctx retval e catchs =
 			write ctx ANot;
 			cjmp ctx
 		) in
-		(* @exc.pop() *)
-		push ctx [VInt 0;VStr ("@exc",false)];
-		write ctx AEval;
-		push ctx [VStr ("pop",true)];
-		call ctx VarObj 0;
-		write ctx APop;
 		let block = open_block ctx in
 		define_var ctx name (Some (fun() -> push ctx [VReg 0])) [e];
 		gen_expr ctx retval e;
@@ -884,7 +879,12 @@ and gen_expr_2 ctx retval e =
 	| TFunction f ->
 		let block = open_block ctx in
 		let old_in_loop = ctx.in_loop in
+		let old_meth = ctx.curmethod in
 		let reg_super = Transform.local_find true "super" f.tf_expr in
+		if snd ctx.curmethod then
+			ctx.curmethod <- (fst ctx.curmethod ^ "@" ^ string_of_int (Lexer.get_error_line e.epos), true)
+		else
+			ctx.curmethod <- (fst ctx.curmethod, true);
 		(* only keep None bindings, for protect *)
 		ctx.regs <- PMap.foldi (fun v x acc ->
 			match x with
@@ -909,8 +909,30 @@ and gen_expr_2 ctx retval e =
 		) f.tf_args in
 		let tf = func ctx reg_super (Transform.local_find true "__arguments__" f.tf_expr) rargs in
 		ctx.fun_pargs <- (ctx.code_pos, List.rev !pargs) :: ctx.fun_pargs;
-		gen_expr ctx false f.tf_expr;
+		if ctx.debug then begin
+			let start_try = gen_try ctx in
+			gen_expr ctx false (Transform.stack_block (ctx.curclass,fst ctx.curmethod) f.tf_expr);
+			let end_try = start_try() in
+			(* if $spos == 1 , then no upper call, so report as uncaught *)
+			push ctx [VInt 1; VStr (Transform.stack_var_pos,false)];
+			write ctx AEval;
+			write ctx AEqual;
+			write ctx ANot;
+			let j = cjmp ctx in
+			push ctx [VReg 0];
+			push ctx [VInt 1];
+			getvar ctx (gen_path ctx (["flash"],"Boot") (!extern_boot));
+			push ctx [VStr ("__exc",false)];
+			call ctx VarObj 1;
+			write ctx AReturn;
+			j();
+			push ctx [VReg 0];
+			write ctx AThrow;
+			end_try();
+		end else
+			gen_expr ctx false f.tf_expr;
 		ctx.in_loop <- old_in_loop;
+		ctx.curmethod <- old_meth;
 		tf();
 		block();
 	| TIf (cond,e,None) ->
@@ -977,15 +999,7 @@ and gen_expr_2 ctx retval e =
 	| TSwitch (e,cases,def) ->
 		gen_switch ctx retval e cases def
 	| TThrow e ->
-		(* call @exc.push(e) *)
 		gen_expr ctx true e;
-		write ctx (ASetReg 0);
-		push ctx [VInt 1; VStr ("@exc",false)];
-		write ctx AEval;
-		push ctx [VStr ("push",true)];
-		call ctx VarObj 1;
-		write ctx APop;
-		push ctx [VReg 0];
 		write ctx AThrow;
 		no_value ctx retval
 	| TTry (e,catchs) ->
@@ -1039,15 +1053,15 @@ let gen_class_static_field ctx c flag f =
 		match e.eexpr with
 		| TFunction _ ->
 			push ctx [VReg 0; VStr (f.cf_name,flag)];
-			ctx.curmethod <- f.cf_name;
+			ctx.curmethod <- (f.cf_name,false);
 			gen_expr ctx true e;
 			setvar ctx VarObj
 		| _ ->
 			ctx.statics <- (c,flag,f.cf_name,e) :: ctx.statics
 
 let gen_class_static_init ctx (c,flag,name,e) =
-	ctx.curclass <- c.cl_path;
-	ctx.curmethod <- name;
+	ctx.curclass <- c;
+	ctx.curmethod <- (name,false);
 	getvar ctx (gen_path ctx c.cl_path c.cl_extern);
 	push ctx [VStr (name,flag)];
 	gen_expr ctx true e;
@@ -1059,7 +1073,7 @@ let gen_class_field ctx f flag =
 	| None ->
 		push ctx [VNull]
 	| Some e ->
-		ctx.curmethod <- f.cf_name;
+		ctx.curmethod <- (f.cf_name,false);
 		gen_expr ctx true (Transform.block_vars e));
 	setvar ctx VarObj
 
@@ -1164,11 +1178,11 @@ let gen_type_def ctx t =
 					loop s
 		in
 		loop c;
-		ctx.curclass <- c.cl_path;
+		ctx.curclass <- c;
 		(match c.cl_constructor with
 		| Some { cf_expr = Some e } ->
 			have_constr := true;
-			ctx.curmethod <- "new";
+			ctx.curmethod <- ("new",false);
 			gen_expr ctx true (Transform.block_vars e)
 		| _ ->
 			let f = func ctx true false [] in
@@ -1325,14 +1339,23 @@ let generate_code file ver types hres =
 		movieclips = [];
 		inits = [];
 		version = ver;
-		curclass = ([],"");
-		curmethod = "";
+		curclass = null_class;
+		curmethod = ("",false);
 		fun_pargs = [];
 		in_loop = false;
+		debug = Plugin.defined "debug";
 	} in
 	write ctx (AStringPool []);
 	protect_all := not (Plugin.defined "swf-mark");
 	extern_boot := true;
+	if ctx.debug then begin
+		push ctx [VStr (Transform.stack_var,false); VInt 0];
+		write ctx AInitArray;
+		write ctx ALocalAssign;
+		push ctx [VStr (Transform.exc_stack_var,false); VInt 0];
+		write ctx AInitArray;
+		write ctx ALocalAssign;
+	end;
 	List.iter (fun t -> gen_type_def ctx t) types;
 	gen_boot ctx hres;
 	List.iter (fun m -> gen_movieclip ctx m) ctx.movieclips;
@@ -1341,13 +1364,11 @@ let generate_code file ver types hres =
 	List.iter (gen_class_static_init ctx) (List.rev ctx.statics);
 	let end_try = global_try() in
 	(* flash.Boot.__trace(exc) *)
-	push ctx [VStr ("fileName",false); VStr ("(uncaught exception)",true); VInt 1];
-	write ctx AObject;
-	ctx.stack_size <- ctx.stack_size - 2;
-	push ctx [VReg 0; VInt 2];
+	push ctx [VReg 0; VInt 1];
 	getvar ctx (gen_path ctx (["flash"],"Boot") (!extern_boot));
-	push ctx [VStr ("__trace",false)];
-	call ctx VarObj 2;
+	push ctx [VStr ("__exc",false)];
+	call ctx VarObj 1;
+	write ctx APop;
 	end_try();
 	let idents = ctx.idents in
 	let idents = Hashtbl.fold (fun ident pos acc -> (ident,pos) :: acc) idents [] in
@@ -1404,7 +1425,7 @@ let generate file ver header infile types hres =
 		tag ~ext:true (TExport [{ exp_id = !base_id; exp_name = s_type_path m }]) ::
 		acc
 	) [] (!movieclips) in
-	let tagclips9() = 
+	let tagclips9() =
 		if ver = 9 then
 			[tag (TF9Classes !f9clips)]
 		else

std/flash/Boot.hx

@@ -26,8 +26,6 @@ package flash;
 
 class Boot {
 
-	private static var exc : Array<Dynamic>;
-
 	private static function __string_rec(o : Dynamic,s : String) {
 		untyped {
 			if( s.length >= 20 )
@@ -174,6 +172,17 @@ class Boot {
 		}
 	}
 
+	static function __exc(v) {
+		var s = "";
+		#if debug
+		var a : Array<String> = untyped __eval__("$s");
+		for( i in 0...a.length-1 )
+			s += "\nCalled from "+a[i];
+		a.splice(0,a.length);
+		#end
+		__trace(__string_rec(v,"")+s,cast { fileName : "(uncaught exception)" });
+	}
+
 	private static function __clear_trace() {
 		untyped {
 			var root = flash.Lib.current;
@@ -238,9 +247,6 @@ class Boot {
 			if( _global["flash"] == null )
 				_global["flash"] = __new__(obj);
 		}
-		// create the array stack
-		if( exc == null )
-			exc = new Array();
 		// set the Lib variables
 		current.flash.Lib._global = _global;
 		current.flash.Lib._root = _root;
@@ -248,7 +254,6 @@ class Boot {
 		// prevent closure creation by setting untyped
 		current[__unprotect__("@instanceof")] = untyped __instanceof;
 		current[__unprotect__("@closure")] = untyped __closure;
-		current[__unprotect__("@exc")] = exc;
 		// fix firefox default alignement
 		if( _global["Stage"]["align"] == "" )
 			_global["Stage"]["align"] = "LT";

std/flash/Lib.hx

@@ -71,12 +71,6 @@ class Lib {
 		untyped _global["Object"]["registerClass"](name,cl);
 	}
 
-	public static function throwException() {
-		var exc : Array<Dynamic> = untyped Boot.exc;
-		if( exc.length != 0 )
-			throw(exc.pop());
-	}
-
 }
 
 

std/js/Lib.hx

@@ -32,6 +32,7 @@ class Lib {
 	public static var isOpera : Bool;
 	public static var document : Document = untyped __js__("document");
 	public static var window : Window = untyped __js__("window");
+	static var onerror : String -> Array<String> -> Bool = null;
 
 	public static function alert( v : Dynamic ) {
 		untyped __js__("alert")(js.Boot.__string_rec(v,""));
@@ -41,13 +42,38 @@ class Lib {
 		return untyped __js__("eval")(code);
 	}
 
-	public static function setErrorHandler( f : String -> String -> Int -> Bool ) {
-		untyped onerror = f;
+	public static function setErrorHandler( f ) {
+		onerror = f;
 	}
 
-	public static function defaultHandler( msg : String, url : String, line : Int ) {
-		alert("Error "+url+" ("+line+")\n\n"+msg);
-		return true;
+	static function __init__() untyped {
+		#if debug
+		__js__('
+			onerror = function(msg,url,line) {
+				var stack = $s.copy();
+				var f = js.Lib.onerror;
+				$s.splice(0,$s.length);
+				if( f == null ) {
+					var i = stack.length;
+					var s = "";
+					while( --i >= 0 )
+						s += "Called from "+stack[i]+"\\n";
+					alert(msg+"\\n\\n"+s);
+					return false;
+				}
+				return f(msg,stack);
+			}
+		');
+		#else true
+		__js__('
+			onerror = function(msg,url,line) {
+				var f = js.Lib.onerror;
+				if( f == null )
+					return false;
+				return f(msg,[url+":"+line]);
+			}
+		');
+		#end
 	}
 
 }

transform.ml

@@ -194,3 +194,74 @@ let block_vars e =
 			map out_loop e
 	in
 	out_loop e
+
+let emk e = mk e t_dynamic Ast.null_pos
+
+let block e =
+	match e.eexpr with
+	| TBlock (_ :: _) -> e
+	| _ -> mk (TBlock [e]) e.etype e.epos
+
+let stack_var = "$s"
+let exc_stack_var = "$e"
+let stack_var_pos = "$spos"
+let stack_e = emk (TLocal stack_var)
+let stack_pop = emk (TCall (emk (TField (stack_e,"pop")),[]))
+
+let stack_push (c,m) =
+	emk (TCall (emk (TField (stack_e,"push")),[
+		emk (TConst (TString (Ast.s_type_path c.cl_path ^ "::" ^ m)))
+	]))
+
+let stack_save_pos =
+	emk (TVars [stack_var_pos, t_dynamic, Some (emk (TField (stack_e,"length")))])
+
+let stack_restore_pos =
+	let ev = emk (TLocal exc_stack_var) in
+	[
+	emk (TBinop (Ast.OpAssign, ev, emk (TArrayDecl [])));
+	emk (TWhile (
+		emk (TBinop (Ast.OpGte,
+			emk (TField (stack_e,"length")),
+			emk (TLocal stack_var_pos)
+		)),
+		emk (TCall (
+			emk (TField (ev,"unshift")),
+			[emk (TCall (
+				emk (TField (stack_e,"pop")),
+				[]
+			))]
+		)),
+		Ast.NormalWhile
+	));
+	emk (TCall (emk (TField (stack_e,"push")),[ emk (TArray (ev,emk (TConst (TInt 0l)))) ]))
+	]
+
+let stack_block ctx e =
+	let rec loop e =
+		match e.eexpr with
+		| TFunction _ ->
+			e
+		| TReturn (Some e) ->
+			mk (TBlock [
+				mk (TVars ["$tmp", t_dynamic, Some (loop e)]) t_dynamic e.epos;
+				stack_pop;
+				mk (TReturn (Some (mk (TLocal "$tmp") t_dynamic e.epos))) t_dynamic e.epos
+			]) e.etype e.epos
+		| TTry (v,cases) ->
+			let v = loop v in
+			let cases = List.map (fun (n,t,e) ->
+				let e = loop e in
+				let e = (match (block e).eexpr with
+					| TBlock l -> mk (TBlock (stack_restore_pos @ l)) e.etype e.epos
+					| _ -> assert false
+				) in
+				n , t , e
+			) cases in
+			mk (TTry (v,cases)) e.etype e.epos
+		| _ ->
+			map loop e
+	in
+	match (block e).eexpr with
+	| TBlock l -> mk (TBlock (stack_push ctx :: stack_save_pos :: List.map loop l @ [stack_pop])) e.etype e.epos
+	| _ -> assert false