[hl] Indicate catch types for debug when wrapping (#12356)

* [hl] Indicate catch types for debug when wrapping

Add meta ExceptionTypeCheck to wrapped ifs.
Add opcode OCatch g.

* [hl] skip other TMeta when extracting

* [optim] fix unop optimizer not working with meta

* [hl] use Type.iter instead of manual match

* [optim] do recudsion only inside Not branch

* [misc] rename get_ to type_global, move begin/end

src-json/meta.json

@@ -1127,6 +1127,12 @@
 		"doc": "Internally used for exceptions wrapping in `throw` expressions.",
 		"internal": true
 	},
+	{
+		"name": "ExceptionTypeCheck",
+		"metadata": ":exceptionTypeCheck",
+		"doc": "Internally used for transformed exception type check wrt to `catch`.",
+		"internal": true
+	},
 	{
 		"name": "NativeArrayAccess",
 		"metadata": ":nativeArrayAccess",

src/filters/exception/exceptions.ml

@@ -74,6 +74,9 @@ let haxe_exception_instance_call ctx haxe_exception method_name args p =
 		make_call ctx.scom efield args rt p
 	| _ -> raise_typing_error ((s_type (print_context()) haxe_exception.etype) ^ "." ^ method_name ^ " is expected to be an instance method") p
 
+let add_meta_exception_type_check e =
+	mk (TMeta((Meta.ExceptionTypeCheck,[],e.epos),e)) e.etype e.epos
+
 (**
 	Generate `Std.isOfType(e, t)`
 *)
@@ -81,7 +84,8 @@ let std_is ctx e t p =
 	let t = follow t in
 	let type_expr = TyperBase.type_module_type_simple (module_type_of_type t) p in
 	let (std_cls,isOfType_field,return_type) = ctx.is_of_type in
-	make_static_call ctx.scom std_cls isOfType_field [e; type_expr] return_type p
+	let e = make_static_call ctx.scom std_cls isOfType_field [e; type_expr] return_type p in
+	add_meta_exception_type_check e
 
 (**
 	Check if type path of `t` exists in `lst`
@@ -260,7 +264,7 @@ let catches_to_ifs ctx catches t p =
 						let condition =
 							(* catch(e:haxe.Exception) is a wildcard catch *)
 							if fast_eq (haxe_exception_type ctx) current_t then
-								mk (TConst (TBool true)) ctx.basic.tbool v.v_pos
+								add_meta_exception_type_check (mk (TConst (TBool true)) ctx.basic.tbool v.v_pos)
 							else
 								std_is ctx (catch#get_haxe_exception v.v_pos) v.v_type v.v_pos
 						in

src/generators/genhl.ml

@@ -1087,32 +1087,34 @@ let before_break_continue ctx =
 	in
 	loop (ctx.m.mtrys - ctx.m.mloop_trys)
 
-let type_value ctx t p =
+let type_global ctx t p =
 	match t with
 	| TClassDecl c ->
-		let g, t = class_global ctx c in
-		let r = alloc_tmp ctx t in
-		op ctx (OGetGlobal (r, g));
-		r
+		class_global ctx c
 	| TAbstractDecl a ->
-		let r = alloc_tmp ctx (class_type ctx ctx.base_type [] false) in
-		(match a.a_path with
-		| [], "Int" -> op ctx (OGetGlobal (r, alloc_global ctx "$Int" (rtype ctx r)))
-		| [], "Float" -> op ctx (OGetGlobal (r, alloc_global ctx "$Float" (rtype ctx r)))
-		| [], "Bool" -> op ctx (OGetGlobal (r, alloc_global ctx "$Bool" (rtype ctx r)))
-		| [], "Class" -> op ctx (OGetGlobal (r, fst (class_global ctx ctx.base_class)))
-		| [], "Enum" -> op ctx (OGetGlobal (r, fst (class_global ctx ctx.base_enum)))
-		| [], "Dynamic" -> op ctx (OGetGlobal (r, alloc_global ctx "$Dynamic" (rtype ctx r)))
-		| _ -> abort ("Unsupported type value " ^ s_type_path (t_path t)) p);
-		r
+		let rt = class_type ctx ctx.base_type [] false in
+		let g = (match a.a_path with
+		| [], "Int" -> alloc_global ctx "$Int" rt
+		| [], "Float" -> alloc_global ctx "$Float" rt
+		| [], "Bool" -> alloc_global ctx "$Bool" rt
+		| [], "Class" -> fst (class_global ctx ctx.base_class)
+		| [], "Enum" -> fst (class_global ctx ctx.base_enum)
+		| [], "Dynamic" -> alloc_global ctx "$Dynamic" rt
+		| _ -> abort ("Unsupported type value " ^ s_type_path (t_path t)) p) in
+		g, rt
 	| TEnumDecl e ->
-		let r = alloc_tmp ctx (enum_class ctx e) in
-		let rt = rtype ctx r in
-		op ctx (OGetGlobal (r, alloc_global ctx (match rt with HObj o -> o.pname | _ -> die "" __LOC__) rt));
-		r
+		let rt = enum_class ctx e in
+		let g = alloc_global ctx (match rt with HObj o -> o.pname | _ -> die "" __LOC__) rt in
+		g, rt
 	| TTypeDecl _ ->
 		die "" __LOC__
 
+let type_value ctx t p =
+	let g, rt = type_global ctx t p in
+	let r = alloc_tmp ctx rt in
+	op ctx (OGetGlobal (r, g));
+	r
+
 let rec eval_to ctx e (t:ttype) =
 	match e.eexpr, t with
 	| TConst (TInt i), HF64 ->
@@ -2212,9 +2214,9 @@ and eval_expr ctx e =
 			| AInstanceField (f, index, _) -> op ctx (OPrefetch (eval_expr ctx f, index + 1, mode))
 			| _ -> op ctx (OPrefetch (eval_expr ctx value, 0, mode)));
 			alloc_tmp ctx HVoid
-        | "$unsafecast", [value] ->
+		| "$unsafecast", [value] ->
 			let r = alloc_tmp ctx (to_type ctx e.etype) in
-            op ctx (OUnsafeCast (r, eval_expr ctx value));
+			op ctx (OUnsafeCast (r, eval_expr ctx value));
 			r
 		| "$asm", [mode; value] ->
 			let mode = (match get_const mode with
@@ -3042,6 +3044,21 @@ and eval_expr ctx e =
 		let rtrap = alloc_tmp ctx HDyn in
 		op ctx (OTrap (rtrap,-1)); (* loop *)
 		ctx.m.mtrys <- ctx.m.mtrys + 1;
+		if ctx.hl_ver >= "1.16" then begin
+			let catched_types = ref [] in
+			let rec find_meta e =
+				(match e.eexpr with
+				(* Std.isOfType(e, t) *)
+				| TMeta ((Meta.ExceptionTypeCheck,_,_),{eexpr=TCall(_,_::[{eexpr=TTypeExpr(mt)}])}) ->
+					catched_types := fst (type_global ctx mt e.epos) :: !catched_types
+				| TMeta ((Meta.ExceptionTypeCheck,_,_),{eexpr=TConst(TBool(true))}) ->
+					catched_types := alloc_global ctx "$Dynamic" HDyn :: !catched_types
+				| _ -> Type.iter find_meta e
+				)
+			in
+			List.iter (fun (_,texpr) -> Type.iter find_meta texpr) catches;
+			List.iter (fun gt -> op ctx (OCatch gt)) (List.rev !catched_types);
+		end;
 		let tret = to_type ctx e.etype in
 		let result = alloc_tmp ctx tret in
 		let r = eval_expr ctx etry in

src/generators/hl2c.ml

@@ -1027,15 +1027,15 @@ let generate_function gctx ctx f =
 		| OGetMem (r,b,idx) ->
 			sexpr "%s = *(%s*)(%s + %s)" (reg r) (ctype (rtype r)) (reg b) (reg idx)
 		| OGetArray (r, arr, idx) ->
-            (match rtype arr with
-            | HAbstract _ ->
-                (match rtype r with
-                | HStruct _ | HObj _ ->
-			        sexpr "%s = ((%s)%s) + %s" (reg r) (ctype (rtype r)) (reg arr) (reg idx)
-                | _ ->
-			        sexpr "%s = ((%s*)%s)[%s]" (reg r) (ctype (rtype r)) (reg arr) (reg idx))
-            | _ ->
-			    sexpr "%s = ((%s*)(%s + 1))[%s]" (reg r) (ctype (rtype r)) (reg arr) (reg idx))
+			(match rtype arr with
+			| HAbstract _ ->
+				(match rtype r with
+				| HStruct _ | HObj _ ->
+					sexpr "%s = ((%s)%s) + %s" (reg r) (ctype (rtype r)) (reg arr) (reg idx)
+				| _ ->
+					sexpr "%s = ((%s*)%s)[%s]" (reg r) (ctype (rtype r)) (reg arr) (reg idx))
+			| _ ->
+				sexpr "%s = ((%s*)(%s + 1))[%s]" (reg r) (ctype (rtype r)) (reg arr) (reg idx))
 		| OSetUI8 (b,idx,r) ->
 			sexpr "*(unsigned char*)(%s + %s) = (unsigned char)%s" (reg b) (reg idx) (reg r)
 		| OSetUI16 (b,idx,r) ->
@@ -1149,6 +1149,8 @@ let generate_function gctx ctx f =
 			sexpr "__hl_prefetch_m%d(%s)" mode expr
 		| OAsm _ ->
 			sexpr "UNSUPPORTED ASM OPCODE";
+		| OCatch _ ->
+			()
 	) f.code;
 	flush_options (Array.length f.code);
 	unblock();

src/generators/hlcode.ml

@@ -203,7 +203,8 @@ type opcode =
 	| ORefOffset of reg * reg * reg
 	| ONop of string
 	| OPrefetch of reg * field index * int
-    | OAsm of int * int * reg
+	| OAsm of int * int * reg
+	| OCatch of global
 
 type fundecl = {
 	fpath : string * string;
@@ -602,7 +603,7 @@ let ostr fstr o =
 	| ONop s -> if s = "" then "nop" else "nop " ^ s
 	| OPrefetch (r,f,mode) -> Printf.sprintf "prefetch %d[%d] %d" r f mode
 	| OAsm (mode, value, reg) ->
-		match mode with
+		(match mode with
 		| 0 when reg = 0 ->
 			Printf.sprintf "asm %.2X" value
 		| 1 when reg = 0 ->
@@ -613,6 +614,8 @@ let ostr fstr o =
 			Printf.sprintf "asm %d := R%d" (reg - 1) value
 		| _ ->
 			Printf.sprintf "asm[%d] %d%s" mode value (if reg = 0 then "" else ", " ^ string_of_int (reg-1))
+		)
+	| OCatch g -> Printf.sprintf "catch %d" g
 
 let fundecl_name f = if snd f.fpath = "" then "fun$" ^ (string_of_int f.findex) else (fst f.fpath) ^ "." ^ (snd f.fpath)
 

src/generators/hlinterp.ml

@@ -1156,7 +1156,7 @@ let interp ctx f args =
 			| _ -> Globals.die "" __LOC__)
 		| OAsm _ ->
 			throw_msg ctx "Unsupported ASM"
-		| ONop _ | OPrefetch _ ->
+		| ONop _ | OPrefetch _ | OCatch _ ->
 			()
 		);
 		loop()
@@ -2448,7 +2448,7 @@ let check comerror code =
 				(match rtype a with HAbstract ("hl_carray",_) | HArray _ -> () | _ -> reg a (HArray HDyn));
 				reg i HI32;
 				ignore(rtype v);
-            | OUnsafeCast (a,b) | OSafeCast (a,b) ->
+			| OUnsafeCast (a,b) | OSafeCast (a,b) ->
 				ignore(rtype a);
 				ignore(rtype b);
 			| OArraySize (r,a) ->
@@ -2540,6 +2540,8 @@ let check comerror code =
 				if f = 0 then ignore(rtype r) else ignore(tfield r (f - 1) false)
 			| OAsm (_,_,r) ->
 				if r > 0 then ignore(rtype (r - 1))
+			| OCatch _ ->
+				()
 		) f.code
 		(* TODO : check that all path correctly initialize NULL values and reach a return *)
 	in

src/generators/hlopt.ml

@@ -170,12 +170,14 @@ let opcode_fx frw op =
 		()
 	| OPrefetch (r,_,_) ->
 		read r
-    | OAsm (_,_,r) ->
-        if r > 0 then begin
-            (* assume both *)
-            read (r - 1);
-            write (r - 1);
-        end
+	| OAsm (_,_,r) ->
+		if r > 0 then begin
+			(* assume both *)
+			read (r - 1);
+			write (r - 1);
+		end
+	| OCatch _ ->
+		()
 
 let opcode_eq a b =
 	match a, b with
@@ -452,6 +454,8 @@ let opcode_map read write op =
 	| OAsm (mode, value, r) ->
 		let r2 = read (r - 1) in
 		OAsm (mode, value, (write r2) + 1)
+	| OCatch _ ->
+		op
 
 (* build code graph *)
 

src/optimization/optimizerTexpr.ml

@@ -220,24 +220,30 @@ let optimize_unop e op flag esub =
 		| _ -> false
 	in
 	match op, esub.eexpr with
-		| Not, (TConst (TBool f) | TParenthesis({eexpr = TConst (TBool f)})) -> { e with eexpr = TConst (TBool (not f)) }
-		| Not, (TBinop(op,e1,e2) | TParenthesis({eexpr = TBinop(op,e1,e2)})) ->
-			begin
-				let is_int = is_int e1.etype && is_int e2.etype in
-				try
-					let op = match is_int, op with
-						| true, OpGt -> OpLte
-						| true, OpGte -> OpLt
-						| true, OpLt -> OpGte
-						| true, OpLte -> OpGt
-						| _, OpEq -> OpNotEq
-						| _, OpNotEq -> OpEq
-						| _ -> raise Exit
-					in
-					{e with eexpr = TBinop(op,e1,e2)}
-				with Exit ->
-					e
-			end
+		| Not, _ ->
+			let rec transform e esub = match esub.eexpr with
+				| TConst (TBool f) -> { e with eexpr = TConst (TBool (not f)) }
+				| TBinop(op,e1,e2) ->
+					let is_int = is_int e1.etype && is_int e2.etype in
+					(try
+						let op = match is_int, op with
+							| true, OpGt -> OpLte
+							| true, OpGte -> OpLt
+							| true, OpLt -> OpGte
+							| true, OpLte -> OpGt
+							| _, OpEq -> OpNotEq
+							| _, OpNotEq -> OpEq
+							| _ -> raise Exit
+						in
+						{e with eexpr = TBinop(op,e1,e2)}
+					with Exit ->
+						e
+					)
+				| TParenthesis(e1) -> transform e e1
+				| TMeta(m, e1) -> { e with eexpr = TMeta (m, transform { e1 with eexpr = TUnop(op,flag,e1) } e1 ) }
+				| _ -> e
+			in
+			transform e esub
 		| Neg, TConst (TInt i) -> { e with eexpr = TConst (TInt (Int32.neg i)) }
 		| NegBits, TConst (TInt i) -> { e with eexpr = TConst (TInt (Int32.lognot i)) }
 		| Neg, TConst (TFloat f) ->