Merge pull request #3723 from HaxeFoundation/some_assembly_required

Filters & AST fixes

codegen.ml

@@ -1345,7 +1345,11 @@ let rec create_dumpfile acc = function
 let dump_types com =
 	let s_type = s_type (Type.print_context()) in
 	let params = function [] -> "" | l -> Printf.sprintf "<%s>" (String.concat "," (List.map (fun (n,t) -> n ^ " : " ^ s_type t) l)) in
-	let s_expr = try if Common.defined_value com Define.Dump = "pretty" then Type.s_expr_pretty "\t" else Type.s_expr with Not_found -> Type.s_expr in
+	let s_expr = match Common.defined_value_safe com Define.Dump with
+		| "pretty" -> Type.s_expr_pretty "\t"
+		| "ast" -> Type.s_expr_ast "\t"
+		| _ -> Type.s_expr
+	in
 	List.iter (fun mt ->
 		let path = Type.t_path mt in
 		let buf,close = create_dumpfile [] ("dump" :: (Common.platform_name com.platform) :: fst path @ [snd path]) in
@@ -1358,7 +1362,7 @@ let dump_types com =
 				(match f.cf_expr with
 				| None -> ()
 				| Some e -> print "\n\n\t = %s" (s_expr s_type e));
-				print ";\n\n";
+				print "\n\n";
 				List.iter (fun f -> print_field stat f) f.cf_overloads
 			in
 			print "%s%s%s %s%s" (if c.cl_private then "private " else "") (if c.cl_extern then "extern " else "") (if c.cl_interface then "interface" else "class") (s_type_path path) (params c.cl_params);

common.ml

@@ -96,8 +96,6 @@ type platform_config = {
 	pf_pattern_matching : bool;
 	(** can the platform use default values for non-nullable arguments *)
 	pf_can_skip_non_nullable_argument : bool;
-	(** generator ignores TCast(_,None) *)
-	pf_ignore_unsafe_cast : bool;
 }
 
 type display_mode =
@@ -518,7 +516,6 @@ let default_config =
 		pf_overload = false;
 		pf_pattern_matching = false;
 		pf_can_skip_non_nullable_argument = true;
-		pf_ignore_unsafe_cast = false;
 	}
 
 let get_config com =
@@ -539,7 +536,6 @@ let get_config com =
 			pf_overload = false;
 			pf_pattern_matching = false;
 			pf_can_skip_non_nullable_argument = true;
-			pf_ignore_unsafe_cast = false;
 		}
 	| Js ->
 		{
@@ -554,7 +550,6 @@ let get_config com =
 			pf_overload = false;
 			pf_pattern_matching = false;
 			pf_can_skip_non_nullable_argument = true;
-			pf_ignore_unsafe_cast = true;
 		}
 	| Neko ->
 		{
@@ -569,7 +564,6 @@ let get_config com =
 			pf_overload = false;
 			pf_pattern_matching = false;
 			pf_can_skip_non_nullable_argument = true;
-			pf_ignore_unsafe_cast = true;
 		}
 	| Flash when defined Define.As3 ->
 		{
@@ -584,7 +578,6 @@ let get_config com =
 			pf_overload = false;
 			pf_pattern_matching = false;
 			pf_can_skip_non_nullable_argument = false;
-			pf_ignore_unsafe_cast = false;
 		}
 	| Flash ->
 		{
@@ -599,7 +592,6 @@ let get_config com =
 			pf_overload = false;
 			pf_pattern_matching = false;
 			pf_can_skip_non_nullable_argument = false;
-			pf_ignore_unsafe_cast = false;
 		}
 	| Php ->
 		{
@@ -614,7 +606,6 @@ let get_config com =
 			pf_overload = false;
 			pf_pattern_matching = false;
 			pf_can_skip_non_nullable_argument = true;
-			pf_ignore_unsafe_cast = false;
 		}
 	| Cpp ->
 		{
@@ -629,7 +620,6 @@ let get_config com =
 			pf_overload = false;
 			pf_pattern_matching = false;
 			pf_can_skip_non_nullable_argument = true;
-			pf_ignore_unsafe_cast = false;
 		}
 	| Cs ->
 		{
@@ -644,7 +634,6 @@ let get_config com =
 			pf_overload = true;
 			pf_pattern_matching = false;
 			pf_can_skip_non_nullable_argument = true;
-			pf_ignore_unsafe_cast = false;
 		}
 	| Java ->
 		{
@@ -659,7 +648,6 @@ let get_config com =
 			pf_overload = true;
 			pf_pattern_matching = false;
 			pf_can_skip_non_nullable_argument = true;
-			pf_ignore_unsafe_cast = false;
 		}
 	| Python ->
 		{
@@ -674,7 +662,6 @@ let get_config com =
 			pf_overload = false;
 			pf_pattern_matching = false;
 			pf_can_skip_non_nullable_argument = true;
-			pf_ignore_unsafe_cast = true;
 		}
 
 let memory_marker = [|Unix.time()|]

filters.ml

@@ -45,7 +45,7 @@ let rec blockify_ast e =
 	x = { exprs; value; } -> { exprs; x = value; }
 	var x = { exprs; value; } -> { var x; exprs; x = value; }
 *)
-let promote_complex_rhs ctx e =
+let promote_complex_rhs com e =
 	let rec is_complex e = match e.eexpr with
 		| TBlock _ | TSwitch _ | TIf _ | TTry _ | TCast(_,Some _) -> true
 		| TBinop(_,e1,e2) -> is_complex e1 || is_complex e2
@@ -59,12 +59,12 @@ let promote_complex_rhs ctx e =
 				| [] -> e
 			end
 		| TSwitch(es,cases,edef) ->
-			{e with eexpr = TSwitch(es,List.map (fun (el,e) -> List.map find el,loop f e) cases,match edef with None -> None | Some e -> Some (loop f e))}
+			{e with eexpr = TSwitch(es,List.map (fun (el,e) -> List.map find el,loop f e) cases,match edef with None -> None | Some e -> Some (loop f e)); etype = com.basic.tvoid}
 		| TIf(eif,ethen,eelse) ->
-			{e with eexpr = TIf(find eif, loop f ethen, match eelse with None -> None | Some e -> Some (loop f e))}
+			{e with eexpr = TIf(find eif, loop f ethen, match eelse with None -> None | Some e -> Some (loop f e)); etype = com.basic.tvoid}
 		| TTry(e1,el) ->
-			{e with eexpr = TTry(loop f e1, List.map (fun (el,e) -> el,loop f e) el)}
-		| TParenthesis e1 when not (Common.defined ctx Define.As3) ->
+			{e with eexpr = TTry(loop f e1, List.map (fun (el,e) -> el,loop f e) el); etype = com.basic.tvoid}
+		| TParenthesis e1 when not (Common.defined com Define.As3) ->
 			{e with eexpr = TParenthesis(loop f e1)}
 		| TMeta(m,e1) ->
 			{ e with eexpr = TMeta(m,loop f e1)}
@@ -72,8 +72,6 @@ let promote_complex_rhs ctx e =
 			find e
 		| TContinue | TBreak ->
 			e
-		| TCast(e1,None) when ctx.config.pf_ignore_unsafe_cast ->
-			loop f e1
 		| _ ->
 			f (find e)
 	and block el =
@@ -84,11 +82,11 @@ let promote_complex_rhs ctx e =
 				begin match eo with
 					| Some e when is_complex e ->
 						r := (loop (fun e -> mk (TBinop(OpAssign,mk (TLocal v) v.v_type e.epos,e)) v.v_type e.epos) e)
-							:: ((mk (TVar (v,None)) ctx.basic.tvoid e.epos))
+							:: ((mk (TVar (v,None)) com.basic.tvoid e.epos))
 							:: !r
 					| Some e ->
-						r := (mk (TVar (v,Some (find e))) ctx.basic.tvoid e.epos) :: !r
-					| None -> r := (mk (TVar (v,None)) ctx.basic.tvoid e.epos) :: !r
+						r := (mk (TVar (v,Some (find e))) com.basic.tvoid e.epos) :: !r
+					| None -> r := (mk (TVar (v,None)) com.basic.tvoid e.epos) :: !r
 				end
 			| TReturn (Some e1) when (match follow e1.etype with TAbstract({a_path=[],"Void"},_) -> true | _ -> false) ->
 				r := ({e with eexpr = TReturn None}) :: e1 :: !r
@@ -96,7 +94,7 @@ let promote_complex_rhs ctx e =
 		) el;
 		List.rev !r
 	and find e = match e.eexpr with
-		| TReturn (Some e1) -> loop (fun e -> {e with eexpr = TReturn (Some e)}) e1
+		| TReturn (Some e1) -> loop (fun er -> {e with eexpr = TReturn (Some er)}) e1
 		| TBinop(OpAssign | OpAssignOp _ as op, ({eexpr = TLocal _ | TField _ | TArray _} as e1), e2) -> loop (fun er -> {e with eexpr = TBinop(op, e1, er)}) e2
 		| TBlock(el) -> {e with eexpr = TBlock (block el)}
 		| _ -> Type.map_expr find e
@@ -991,29 +989,29 @@ let run_expression_filters ctx filters t =
 
 let pp_counter = ref 1
 
-let post_process ctx filters t =
-	(* ensure that we don't process twice the same (cached) module *)
+let is_cached t =
 	let m = (t_infos t).mt_module.m_extra in
 	if m.m_processed = 0 then m.m_processed <- !pp_counter;
-	if m.m_processed = !pp_counter then
-	run_expression_filters ctx filters t
+	m.m_processed <> !pp_counter
 
-let post_process_end() =
+let apply_filters_once ctx filters t =
+	if not (is_cached t) then run_expression_filters ctx filters t
+
+let next_compilation() =
 	incr pp_counter
 
-let iter_expressions com fl =
-	List.iter (fun mt -> match mt with
-		| TClassDecl c ->
-			let field cf = match cf.cf_expr with
-				| None -> ()
-				| Some e -> List.iter (fun f -> f e) fl
-			in
-			List.iter field c.cl_ordered_statics;
-			List.iter field c.cl_ordered_fields;
-			(match c.cl_constructor with None -> () | Some cf -> field cf)
-		| _ ->
-			()
-	) com.types
+let iter_expressions fl mt =
+	match mt with
+	| TClassDecl c ->
+		let field cf = match cf.cf_expr with
+			| None -> ()
+			| Some e -> List.iter (fun f -> f e) fl
+		in
+		List.iter field c.cl_ordered_statics;
+		List.iter field c.cl_ordered_fields;
+		(match c.cl_constructor with None -> () | Some cf -> field cf)
+	| _ ->
+		()
 
 let run com tctx main =
 	begin match com.display with
@@ -1026,6 +1024,7 @@ let run com tctx main =
 		Codegen.DeprecationCheck.run com;
 	let use_static_analyzer = Common.defined com Define.Analyzer in
 	(* this part will be a bit messy until we make the analyzer the default *)
+	let new_types = List.filter (fun t -> not (is_cached t)) com.types in
 	if use_static_analyzer then begin
 		(* PASS 1: general expression filters *)
 		let filters = [
@@ -1036,24 +1035,15 @@ let run com tctx main =
 			blockify_ast;
 			captured_vars com;
 		] in
-		List.iter (post_process tctx filters) com.types;
-		Analyzer.apply tctx;
-		post_process_end();
-		iter_expressions com [verify_ast];
-		List.iter (fun f -> f()) (List.rev com.filters);
-		(* save class state *)
-		List.iter (save_class_state tctx) com.types;
-		(* PASS 2: destructive type and expression filters *)
+		List.iter (run_expression_filters tctx filters) new_types;
+		Analyzer.apply tctx; (* TODO *)
+		List.iter (iter_expressions [verify_ast]) new_types;
 		let filters = [
 			Optimizer.sanitize com;
 			if com.config.pf_add_final_return then add_final_return else (fun e -> e);
 			rename_local_vars tctx;
 		] in
-		List.iter (fun t ->
-			remove_generic_base tctx t;
-			remove_extern_fields tctx t;
-			run_expression_filters tctx filters t;
-		) com.types;
+		List.iter (run_expression_filters tctx filters) new_types;
 	end else begin
 		(* PASS 1: general expression filters *)
 		let filters = [
@@ -1072,25 +1062,20 @@ let run com tctx main =
 			if com.foptimize then (fun e -> Optimizer.reduce_expression tctx (Optimizer.inline_constructors tctx e)) else Optimizer.sanitize com;
 			check_local_vars_init;
 			captured_vars com;
-		] in
-		List.iter (post_process tctx filters) com.types;
-		post_process_end();
-		iter_expressions com [verify_ast];
-		List.iter (fun f -> f()) (List.rev com.filters);
-		(* save class state *)
-		List.iter (save_class_state tctx) com.types;
-		(* PASS 2: destructive type and expression filters *)
-		let filters = [
 			promote_complex_rhs com;
 			if com.config.pf_add_final_return then add_final_return else (fun e -> e);
 			rename_local_vars tctx;
 		] in
-		List.iter (fun t ->
-			remove_generic_base tctx t;
-			remove_extern_fields tctx t;
-			run_expression_filters tctx filters t;
-		) com.types;
+		List.iter (run_expression_filters tctx filters) new_types;
+		List.iter (iter_expressions [verify_ast]) new_types;
 	end;
+	next_compilation();
+	List.iter (fun f -> f()) (List.rev com.filters); (* macros onGenerate etc. *)
+	List.iter (save_class_state tctx) new_types;
+	List.iter (fun t ->
+		remove_generic_base tctx t;
+		remove_extern_fields tctx t;
+	) com.types;
 	(* update cache dependencies before DCE is run *)
 	Codegen.update_cache_dependencies com;
 	(* check @:remove metadata before DCE so it is ignored there (issue #2923) *)

type.ml

@@ -1042,6 +1042,86 @@ let rec s_expr_pretty tabs s_type e =
 	| TMeta ((n,el,_),e) ->
 		sprintf "@%s%s %s" (Meta.to_string n) (match el with [] -> "" | _ -> "(" ^ (String.concat ", " (List.map Ast.s_expr el)) ^ ")") (loop e)
 
+let rec s_expr_ast tabs s_type e =
+	let sprintf = Printf.sprintf in
+	let loop ?(extra_tabs="") = s_expr_ast (tabs ^ "\t" ^ extra_tabs) s_type in
+	let tag_args tabs sl = match sl with
+		| [] -> ""
+		| [s] when not (String.contains s '\n') -> " " ^ s
+		| _ ->
+			let tabs = "\n" ^ tabs ^ "\t" in
+			tabs ^ (String.concat tabs sl)
+	in
+	let tag s ?(t=None) ?(extra_tabs="") sl =
+		let st = match t with
+			| None -> s_type e.etype
+			| Some t -> s_type t
+		in
+		sprintf "[%s:%s]%s" s st (tag_args (tabs ^ extra_tabs) sl)
+	in
+	let const c = sprintf "[Const %s:%s]" (s_const c) (s_type e.etype) in
+	let local v = sprintf "[Local %s(%i):%s]" v.v_name v.v_id (s_type v.v_type) in
+	let var v sl = sprintf "[Var %s(%i):%s]%s" v.v_name v.v_id (s_type v.v_type) (tag_args tabs sl) in
+	let module_type mt = sprintf "[TypeExpr %s:%s]" (s_type_path (t_path mt)) (s_type e.etype) in
+	match e.eexpr with
+	| TConst c -> const c
+	| TLocal v -> local v
+	| TArray (e1,e2) -> tag "Array" [loop e1; loop e2]
+	| TBinop (op,e1,e2) -> tag "Binop" [loop e1; s_binop op; loop e2]
+	| TUnop (op,flag,e1) -> tag "Unop" [s_unop op; if flag = Postfix then "Postfix" else "Prefix"; loop e1]
+	| TEnumParameter (e1,ef,i) -> tag "EnumParameter" [loop e1; ef.ef_name; string_of_int i]
+	| TField (e1,fa) ->
+		let sfa = match fa with
+			| FInstance(c,tl,cf) -> tag "FInstance" ~extra_tabs:"\t" [s_type (TInst(c,tl)); cf.cf_name]
+			| FStatic(c,cf) -> tag "FStatic" ~extra_tabs:"\t" [s_type_path c.cl_path; cf.cf_name]
+			| FClosure(co,cf) -> tag "FClosure" ~extra_tabs:"\t" [(match co with None -> "None" | Some c -> s_type_path c.cl_path); cf.cf_name]
+			| FAnon cf -> tag "FAnon" ~extra_tabs:"\t" [cf.cf_name]
+			| FDynamic s -> tag "FDynamic" ~extra_tabs:"\t" [s]
+			| FEnum(en,ef) -> tag "FEnum" ~extra_tabs:"\t" [s_type_path en.e_path; ef.ef_name]
+		in
+		tag "Field" [loop e1; sfa]
+	| TTypeExpr mt -> module_type mt
+	| TParenthesis e1 -> tag "Parenthesis" [loop e1]
+	| TObjectDecl fl -> tag "ObjectDecl" (List.map (fun (s,e) -> sprintf "%s: %s" s (loop e)) fl)
+	| TArrayDecl el -> tag "ArrayDecl" (List.map loop el)
+	| TCall (e1,el) -> tag "Call" (loop e1 :: (List.map loop el))
+	| TNew (c,tl,el) -> tag "New" ((s_type (TInst(c,tl))) :: (List.map loop el))
+	| TFunction f -> tag "Function" [loop f.tf_expr]
+	| TVar (v,eo) -> var v (match eo with None -> [] | Some e -> [loop e])
+	| TBlock el -> tag "Block" (List.map loop el)
+	| TIf (e,e1,e2) -> tag "If" (loop e :: ("Then " ^ loop e1) :: (match e2 with None -> [] | Some e -> ["Else " ^ (loop e)]))
+	| TCast (e1,None) -> tag "Cast" [loop e1]
+	| TCast (e1,Some mt) -> tag "Cast" [loop e1; module_type mt]
+	| TThrow e1 -> tag "Throw" [loop e1]
+	| TBreak -> tag "Break" []
+	| TContinue -> tag "Continue" []
+	| TReturn None -> tag "Return" []
+	| TReturn (Some e1) -> tag "Return" [loop e1]
+	| TWhile (e1,e2,NormalWhile) -> tag "While" [loop e1; loop e2]
+	| TWhile (e1,e2,DoWhile) -> tag "Do" [loop e1; loop e2]
+	| TFor (v,e1,e2) -> tag "For" [local v; loop e1; loop e2]
+	| TTry (e1,catches) ->
+		let sl = List.map (fun (v,e) ->
+			sprintf "Catch %s%s" (local v) (tag_args (tabs ^ "\t") [loop ~extra_tabs:"\t" e]);
+		) catches in
+		tag "Try" ((loop e1) :: sl)
+	| TSwitch (e1,cases,eo) ->
+		let sl = List.map (fun (el,e) ->
+			tag "Case" ~t:(Some e.etype) ~extra_tabs:"\t" ((List.map loop el) @ [loop ~extra_tabs:"\t" e])
+		) cases in
+		let sl = match eo with
+			| None -> sl
+			| Some e -> sl @ [tag "Default" ~t:(Some e.etype) ~extra_tabs:"\t" [loop ~extra_tabs:"\t" e]]
+		in
+		tag "Switch" ((loop e1) :: sl)
+	| TMeta ((m,el,_),e1) ->
+		let s = Meta.to_string m in
+		let s = match el with
+			| [] -> s
+			| _ -> sprintf "%s(%s)" s (String.concat ", " (List.map Ast.s_expr el))
+		in
+		tag "Meta" [s; loop e1]
+
 let s_types ?(sep = ", ") tl =
 	let pctx = print_context() in
 	String.concat sep (List.map (s_type pctx) tl)

typer.ml

@@ -4490,12 +4490,12 @@ and flush_macro_context mint ctx =
 	let expr_filters = [Codegen.AbstractCast.handle_abstract_casts mctx; Filters.captured_vars mctx.com; Filters.rename_local_vars mctx] in
 	let type_filters = [Filters.add_field_inits mctx] in
 	let ready = fun t ->
-		Filters.post_process mctx expr_filters t;
+		Filters.apply_filters_once mctx expr_filters t;
 		List.iter (fun f -> f t) type_filters
 	in
 	(try Interp.add_types mint types ready
 	with Error (e,p) -> raise (Fatal_error(error_msg e,p)));
-	Filters.post_process_end()
+	Filters.next_compilation()
 
 let create_macro_interp ctx mctx =
 	let com2 = mctx.com in