[analyzer] reorganize local handling in fusion a bit

src/optimization/analyzerTexpr.ml

@@ -625,6 +625,199 @@ module Fusion = struct
 			end;
 			b
 		in
+		let handle_assigned_local v1 e1 el =
+			let found = ref false in
+			let blocked = ref false in
+			let ir = InterferenceReport.from_texpr e1 in
+			if config.fusion_debug then print_endline (Printf.sprintf "INTERFERENCE: %s\nINTO: %s"
+				(InterferenceReport.to_string ir) (Type.s_expr_pretty true "" false (s_type (print_context())) (mk (TBlock el) t_dynamic null_pos)));
+			(* This function walks the AST in order of evaluation and tries to find an occurrence of v1. If successful, that occurrence is
+			replaced with e1. If there's an interference "on the way" the replacement is canceled. *)
+			let rec replace e =
+				let explore e =
+					let old = !blocked in
+					blocked := true;
+					let e = replace e in
+					blocked := old;
+					e
+				in
+				let handle_el' el =
+					(* This mess deals with the fact that the order of evaluation is undefined for call
+						arguments on these targets. Even if we find a replacement, we pretend that we
+						didn't in order to find possible interferences in later call arguments. *)
+					let temp_found = false in
+					let really_found = ref !found in
+					let el = List.map (fun e ->
+						found := temp_found;
+						let e = replace e in
+						if !found then really_found := true;
+						e
+					) el in
+					found := !really_found;
+					el
+				in
+				let handle_el = if not (target_handles_side_effect_order com) then handle_el' else List.map replace in
+				let handle_call e2 el = match com.platform with
+					| Neko ->
+						(* Neko has this reversed at the moment (issue #4787) *)
+						let el = List.map replace el in
+						let e2 = replace e2 in
+						e2,el
+					| Cpp ->
+						let e2 = replace e2 in
+						let el = handle_el el in
+						e2,el
+					| _ ->
+						let e2 = replace e2 in
+						let el = List.map replace el in
+						e2,el
+				in
+				if !found then e else match e.eexpr with
+					| TWhile _ | TTry _ ->
+						raise Exit
+					| TFunction _ ->
+						e
+					| TIf(e1,e2,eo) ->
+						let e1 = replace e1 in
+						if not !found && (has_state_write ir || has_any_field_write ir || has_any_var_write ir) then raise Exit;
+						let e2 = replace e2 in
+						let eo = Option.map replace eo in
+						{e with eexpr = TIf(e1,e2,eo)}
+					| TSwitch(e1,cases,edef) ->
+						let e1 = match com.platform with
+							| Lua | Python -> explore e1
+							| _ -> replace e1
+						in
+						if not !found then raise Exit;
+						{e with eexpr = TSwitch(e1,cases,edef)}
+					(* locals *)
+					| TLocal v2 when v1 == v2 && not !blocked ->
+						found := true;
+						if type_change_ok com v1.v_type e1.etype then e1 else mk (TCast(e1,None)) v1.v_type e.epos
+					| TLocal v ->
+						if has_var_write ir v || ((has_var_flag v VCaptured || ExtType.has_reference_semantics v.v_type) && (has_state_write ir)) then raise Exit;
+						e
+					| TBinop(OpAssign,({eexpr = TLocal v} as e1),e2) ->
+						let e2 = replace e2 in
+						if not !found && has_var_read ir v then raise Exit;
+						{e with eexpr = TBinop(OpAssign,e1,e2)}
+					(* Never fuse into write-positions (issue #7298) *)
+					| TBinop(OpAssignOp _,{eexpr = TLocal v2},_) | TUnop((Increment | Decrement),_,{eexpr = TLocal v2}) when v1 == v2 ->
+						raise Exit
+					| TBinop(OpAssignOp _ as op,({eexpr = TLocal v} as e1),e2) ->
+						let e2 = replace e2 in
+						if not !found && (has_var_read ir v || has_var_write ir v) then raise Exit;
+						{e with eexpr = TBinop(op,e1,e2)}
+					| TUnop((Increment | Decrement),_,{eexpr = TLocal v}) when has_var_read ir v || has_var_write ir v ->
+						raise Exit
+					(* fields *)
+					| TField(e1,fa) ->
+						let e1 = replace e1 in
+						if not !found && not (is_read_only_field_access e1 fa) && (has_field_write ir (field_name fa) || has_state_write ir) then raise Exit;
+						{e with eexpr = TField(e1,fa)}
+					| TBinop(OpAssign,({eexpr = TField(e1,fa)} as ef),e2) ->
+						let e1 = replace e1 in
+						let e2 = replace e2 in
+						if not !found && (has_field_read ir (field_name fa) || has_state_read ir) then raise Exit;
+						{e with eexpr = TBinop(OpAssign,{ef with eexpr = TField(e1,fa)},e2)}
+					| TBinop(OpAssignOp _ as op,({eexpr = TField(e1,fa)} as ef),e2) ->
+						let e1 = replace e1 in
+						let s = field_name fa in
+						if not !found && (has_field_write ir s || has_state_write ir) then raise Exit;
+						let e2 = replace e2 in
+						if not !found && (has_field_read ir s || has_state_read ir) then raise Exit;
+						{e with eexpr = TBinop(op,{ef with eexpr = TField(e1,fa)},e2)}
+					| TUnop((Increment | Decrement),_,{eexpr = TField(e1,fa)}) when has_field_read ir (field_name fa) || has_state_read ir
+						|| has_field_write ir (field_name fa) || has_state_write ir ->
+						raise Exit
+					(* array *)
+					| TArray(e1,e2) ->
+						let e1 = replace e1 in
+						let e2 = replace e2 in
+						if not !found && has_state_write ir then raise Exit;
+						{e with eexpr = TArray(e1,e2)}
+					| TBinop(OpAssign,({eexpr = TArray(e1,e2)} as ef),e3) ->
+						let e1 = replace e1 in
+						let e2 = replace e2 in
+						let e3 = replace e3 in
+						if not !found && (has_state_read ir) then raise Exit;
+						{e with eexpr = TBinop(OpAssign,{ef with eexpr = TArray(e1,e2)},e3)}
+					| TBinop(OpAssignOp _ as op,({eexpr = TArray(e1,e2)} as ef),e3) ->
+						let e1 = replace e1 in
+						let e2 = replace e2 in
+						if not !found && has_state_write ir then raise Exit;
+						let e3 = replace e3 in
+						if not !found && has_state_read ir then raise Exit;
+						{e with eexpr = TBinop(op,{ef with eexpr = TArray(e1,e2)},e3)}
+					| TUnop((Increment | Decrement),_,{eexpr = TArray _}) when has_state_read ir || has_state_write ir ->
+						raise Exit
+					(* state *)
+					| TCall({eexpr = TIdent s},el) when not (is_unbound_call_that_might_have_side_effects s el) ->
+						e
+					| TNew(c,tl,el) when (match c.cl_constructor with Some cf when PurityState.is_pure c cf -> true | _ -> false) ->
+						let el = handle_el el in
+						if not !found && (has_state_write ir || has_any_field_write ir) then raise Exit;
+						{e with eexpr = TNew(c,tl,el)}
+					| TNew(c,tl,el) ->
+						let el = handle_el el in
+						if not !found && (has_state_write ir || has_state_read ir || has_any_field_read ir || has_any_field_write ir) then raise Exit;
+						{e with eexpr = TNew(c,tl,el)}
+					| TCall({eexpr = TField(_,FEnum _)} as ef,el) ->
+						let el = handle_el el in
+						{e with eexpr = TCall(ef,el)}
+					| TCall({eexpr = TField(_,fa)} as ef,el) when PurityState.is_pure_field_access fa ->
+						let ef,el = handle_call ef el in
+						if not !found && (has_state_write ir || has_any_field_write ir) then raise Exit;
+						{e with eexpr = TCall(ef,el)}
+					| TCall(e1,el) ->
+						let e1,el = match e1.eexpr with
+							| TIdent s when s <> "`trace" && s <> "__int__" -> e1,el
+							| _ -> handle_call e1 el
+						in
+						if not !found && (((has_state_read ir || has_any_field_read ir)) || has_state_write ir || has_any_field_write ir) then raise Exit;
+						{e with eexpr = TCall(e1,el)}
+					| TObjectDecl fl ->
+						(* The C# generator has trouble with evaluation order in structures (#7531). *)
+						let el = (match com.platform with Cs -> handle_el' | _ -> handle_el) (List.map snd fl) in
+						if not !found && (has_state_write ir || has_any_field_write ir) then raise Exit;
+						{e with eexpr = TObjectDecl (List.map2 (fun (s,_) e -> s,e) fl el)}
+					| TArrayDecl el ->
+						let el = handle_el el in
+						(*if not !found && (has_state_write ir || has_any_field_write ir) then raise Exit;*)
+						{e with eexpr = TArrayDecl el}
+					| TBinop(op,e1,e2) when (match com.platform with Cpp -> true | _ -> false) ->
+						let e1 = replace e1 in
+						let temp_found = !found in
+						found := false;
+						let e2 = replace e2 in
+						found := !found || temp_found;
+						{e with eexpr = TBinop(op,e1,e2)}
+					| _ ->
+						Type.map_expr replace e
+			in
+			let replace e =
+				actx.with_timer ["<-";"fusion";"fuse";"replace"] (fun () -> replace e)
+			in
+			begin try
+				let rec loop acc el = match el with
+					| e :: el ->
+						let e = replace e in
+						if !found then (List.rev (e :: acc)) @ el
+						else loop (e :: acc) el
+					| [] ->
+						List.rev acc
+				in
+				let el = loop [] el in
+				if not !found then raise Exit;
+				state#changed;
+				state#dec_reads v1;
+				if config.fusion_debug then print_endline (Printf.sprintf "YES: %s" (s_expr_pretty (mk (TBlock el) t_dynamic null_pos)));
+				Some el
+			with Exit ->
+				if config.fusion_debug then print_endline (Printf.sprintf "NO: %s" (Printexc.get_backtrace()));
+				None
+			end
+		in
 		let rec fuse acc el = match el with
 			| ({eexpr = TVar(v1,None)} as e1) :: {eexpr = TBinop(OpAssign,{eexpr = TLocal v2},e2)} :: el when v1 == v2 ->
 				state#changed;
@@ -697,218 +890,34 @@ module Fusion = struct
 				with Exit ->
 					fuse (ev :: acc) el
 				end
+
 			| ({eexpr = TVar(v1,Some e1)} as ev) :: el when can_be_fused v1 e1 ->
-				let found = ref false in
-				let blocked = ref false in
-				let ir = InterferenceReport.from_texpr e1 in
-				if config.fusion_debug then print_endline (Printf.sprintf "INTERFERENCE: %s\nINTO: %s"
-					 (InterferenceReport.to_string ir) (Type.s_expr_pretty true "" false (s_type (print_context())) (mk (TBlock el) t_dynamic null_pos)));
-				(* This function walks the AST in order of evaluation and tries to find an occurrence of v1. If successful, that occurrence is
-				   replaced with e1. If there's an interference "on the way" the replacement is canceled. *)
-				let rec replace e =
-					let explore e =
-						let old = !blocked in
-						blocked := true;
-						let e = replace e in
-						blocked := old;
-						e
-					in
-					let handle_el' el =
-						(* This mess deals with the fact that the order of evaluation is undefined for call
-							arguments on these targets. Even if we find a replacement, we pretend that we
-							didn't in order to find possible interferences in later call arguments. *)
-						let temp_found = false in
-						let really_found = ref !found in
-						let el = List.map (fun e ->
-							found := temp_found;
-							let e = replace e in
-							if !found then really_found := true;
-							e
-						) el in
-						found := !really_found;
-						el
-					in
-					let handle_el = if not (target_handles_side_effect_order com) then handle_el' else List.map replace in
-					let handle_call e2 el = match com.platform with
-						| Neko ->
-							(* Neko has this reversed at the moment (issue #4787) *)
-							let el = List.map replace el in
-							let e2 = replace e2 in
-							e2,el
-						| Cpp ->
-							let e2 = replace e2 in
-							let el = handle_el el in
-							e2,el
-						| _ ->
-							let e2 = replace e2 in
-							let el = List.map replace el in
-							e2,el
-					in
-					if !found then e else match e.eexpr with
-						| TWhile _ | TTry _ ->
-							raise Exit
-						| TFunction _ ->
-							e
-						| TIf(e1,e2,eo) ->
-							let e1 = replace e1 in
-							if not !found && (has_state_write ir || has_any_field_write ir || has_any_var_write ir) then raise Exit;
-							let e2 = replace e2 in
-							let eo = Option.map replace eo in
-							{e with eexpr = TIf(e1,e2,eo)}
-						| TSwitch(e1,cases,edef) ->
-							let e1 = match com.platform with
-								| Lua | Python -> explore e1
-								| _ -> replace e1
-							in
-							if not !found then raise Exit;
-							{e with eexpr = TSwitch(e1,cases,edef)}
-						(* locals *)
-						| TLocal v2 when v1 == v2 && not !blocked ->
+				begin match el with
+				| ({eexpr = TUnop((Increment | Decrement) as op,Prefix,{eexpr = TLocal v1})} as e2) :: el ->
+					let found = ref false in
+					let rec replace e = match e.eexpr with
+						| TLocal v2 when v1 == v2 ->
+							if !found then raise Exit;
 							found := true;
-							if type_change_ok com v1.v_type e1.etype then e1 else mk (TCast(e1,None)) v1.v_type e.epos
-						| TLocal v ->
-							if has_var_write ir v || ((has_var_flag v VCaptured || ExtType.has_reference_semantics v.v_type) && (has_state_write ir)) then raise Exit;
-							e
-						| TBinop(OpAssign,({eexpr = TLocal v} as e1),e2) ->
-							let e2 = replace e2 in
-							if not !found && has_var_read ir v then raise Exit;
-							{e with eexpr = TBinop(OpAssign,e1,e2)}
-						(* Never fuse into write-positions (issue #7298) *)
-						| TBinop(OpAssignOp _,{eexpr = TLocal v2},_) | TUnop((Increment | Decrement),_,{eexpr = TLocal v2}) when v1 == v2 ->
-							raise Exit
-						| TBinop(OpAssignOp _ as op,({eexpr = TLocal v} as e1),e2) ->
-							let e2 = replace e2 in
-							if not !found && (has_var_read ir v || has_var_write ir v) then raise Exit;
-							{e with eexpr = TBinop(op,e1,e2)}
-						| TUnop((Increment | Decrement),_,{eexpr = TLocal v}) when has_var_read ir v || has_var_write ir v ->
-							raise Exit
-						(* fields *)
-						| TField(e1,fa) ->
-							let e1 = replace e1 in
-							if not !found && not (is_read_only_field_access e1 fa) && (has_field_write ir (field_name fa) || has_state_write ir) then raise Exit;
-							{e with eexpr = TField(e1,fa)}
-						| TBinop(OpAssign,({eexpr = TField(e1,fa)} as ef),e2) ->
-							let e1 = replace e1 in
-							let e2 = replace e2 in
-							if not !found && (has_field_read ir (field_name fa) || has_state_read ir) then raise Exit;
-							{e with eexpr = TBinop(OpAssign,{ef with eexpr = TField(e1,fa)},e2)}
-						| TBinop(OpAssignOp _ as op,({eexpr = TField(e1,fa)} as ef),e2) ->
-							let e1 = replace e1 in
-							let s = field_name fa in
-							if not !found && (has_field_write ir s || has_state_write ir) then raise Exit;
-							let e2 = replace e2 in
-							if not !found && (has_field_read ir s || has_state_read ir) then raise Exit;
-							{e with eexpr = TBinop(op,{ef with eexpr = TField(e1,fa)},e2)}
-						| TUnop((Increment | Decrement),_,{eexpr = TField(e1,fa)}) when has_field_read ir (field_name fa) || has_state_read ir
-							|| has_field_write ir (field_name fa) || has_state_write ir ->
+							{e with eexpr = TUnop(op,Postfix,e)}
+						| TIf _ | TSwitch _ | TTry _ | TWhile _ | TFor _ ->
 							raise Exit
-						(* array *)
-						| TArray(e1,e2) ->
-							let e1 = replace e1 in
-							let e2 = replace e2 in
-							if not !found && has_state_write ir then raise Exit;
-							{e with eexpr = TArray(e1,e2)}
-						| TBinop(OpAssign,({eexpr = TArray(e1,e2)} as ef),e3) ->
-							let e1 = replace e1 in
-							let e2 = replace e2 in
-							let e3 = replace e3 in
-							if not !found && (has_state_read ir) then raise Exit;
-							{e with eexpr = TBinop(OpAssign,{ef with eexpr = TArray(e1,e2)},e3)}
-						| TBinop(OpAssignOp _ as op,({eexpr = TArray(e1,e2)} as ef),e3) ->
-							let e1 = replace e1 in
-							let e2 = replace e2 in
-							if not !found && has_state_write ir then raise Exit;
-							let e3 = replace e3 in
-							if not !found && has_state_read ir then raise Exit;
-							{e with eexpr = TBinop(op,{ef with eexpr = TArray(e1,e2)},e3)}
-						| TUnop((Increment | Decrement),_,{eexpr = TArray _}) when has_state_read ir || has_state_write ir ->
-							raise Exit
-						(* state *)
-						| TCall({eexpr = TIdent s},el) when not (is_unbound_call_that_might_have_side_effects s el) ->
-							e
-						| TNew(c,tl,el) when (match c.cl_constructor with Some cf when PurityState.is_pure c cf -> true | _ -> false) ->
-							let el = handle_el el in
-							if not !found && (has_state_write ir || has_any_field_write ir) then raise Exit;
-							{e with eexpr = TNew(c,tl,el)}
-						| TNew(c,tl,el) ->
-							let el = handle_el el in
-							if not !found && (has_state_write ir || has_state_read ir || has_any_field_read ir || has_any_field_write ir) then raise Exit;
-							{e with eexpr = TNew(c,tl,el)}
-						| TCall({eexpr = TField(_,FEnum _)} as ef,el) ->
-							let el = handle_el el in
-							{e with eexpr = TCall(ef,el)}
-						| TCall({eexpr = TField(_,fa)} as ef,el) when PurityState.is_pure_field_access fa ->
-							let ef,el = handle_call ef el in
-							if not !found && (has_state_write ir || has_any_field_write ir) then raise Exit;
-							{e with eexpr = TCall(ef,el)}
-						| TCall(e1,el) ->
-							let e1,el = match e1.eexpr with
-								| TIdent s when s <> "`trace" && s <> "__int__" -> e1,el
-								| _ -> handle_call e1 el
-							in
-							if not !found && (((has_state_read ir || has_any_field_read ir)) || has_state_write ir || has_any_field_write ir) then raise Exit;
-							{e with eexpr = TCall(e1,el)}
-						| TObjectDecl fl ->
-							(* The C# generator has trouble with evaluation order in structures (#7531). *)
-							let el = (match com.platform with Cs -> handle_el' | _ -> handle_el) (List.map snd fl) in
-							if not !found && (has_state_write ir || has_any_field_write ir) then raise Exit;
-							{e with eexpr = TObjectDecl (List.map2 (fun (s,_) e -> s,e) fl el)}
-						| TArrayDecl el ->
-							let el = handle_el el in
-							(*if not !found && (has_state_write ir || has_any_field_write ir) then raise Exit;*)
-							{e with eexpr = TArrayDecl el}
-						| TBinop(op,e1,e2) when (match com.platform with Cpp -> true | _ -> false) ->
-							let e1 = replace e1 in
-							let temp_found = !found in
-							found := false;
-							let e2 = replace e2 in
-							found := !found || temp_found;
-							{e with eexpr = TBinop(op,e1,e2)}
 						| _ ->
 							Type.map_expr replace e
-				in
-				let replace e =
-					actx.with_timer ["<-";"fusion";"fuse";"replace"] (fun () -> replace e)
-				in
-				begin try
-					let rec loop acc el = match el with
-						| e :: el ->
-							let e = replace e in
-							if !found then (List.rev (e :: acc)) @ el
-							else loop (e :: acc) el
-						| [] ->
-							List.rev acc
 					in
-					let el = loop [] el in
-					if not !found then raise Exit;
-					state#changed;
-					state#dec_reads v1;
-					if config.fusion_debug then print_endline (Printf.sprintf "YES: %s" (s_expr_pretty (mk (TBlock el) t_dynamic null_pos)));
-					fuse acc el
-				with Exit ->
-					if config.fusion_debug then print_endline (Printf.sprintf "NO: %s" (Printexc.get_backtrace()));
-					begin match el with
-					| ({eexpr = TUnop((Increment | Decrement) as op,Prefix,{eexpr = TLocal v1})} as e2) :: el ->
-						let found = ref false in
-						let rec replace e = match e.eexpr with
-							| TLocal v2 when v1 == v2 ->
-								if !found then raise Exit;
-								found := true;
-								{e with eexpr = TUnop(op,Postfix,e)}
-							| TIf _ | TSwitch _ | TTry _ | TWhile _ | TFor _ ->
-								raise Exit
-							| _ ->
-								Type.map_expr replace e
-						in
-						begin try
-							let ev = replace ev in
-							if not !found then raise Exit;
-							state#changed;
-							fuse acc (ev :: el)
-						with Exit ->
-							fuse (ev :: acc) (e2 :: el)
-						end
-					| _ ->
+					begin try
+						let ev = replace ev in
+						if not !found then raise Exit;
+						state#changed;
+						fuse acc (ev :: el)
+					with Exit ->
+						fuse (ev :: acc) (e2 :: el)
+					end
+				| _ ->
+					begin match handle_assigned_local v1 e1 el with
+					| Some el ->
+						fuse acc el
+					| None ->
 						fuse (ev :: acc) el
 					end
 				end