|
@@ -518,76 +518,273 @@ module Fusion = struct
|
|
|
| Cs when is_null e1.etype || is_null e2.etype -> false (* C# hates OpAssignOp on Null<T> *)
|
|
|
| _ -> true
|
|
|
|
|
|
- let apply actx e =
|
|
|
+ let handle_assigned_local actx v1 e1 el =
|
|
|
let config = actx.AnalyzerTypes.config in
|
|
|
let com = actx.com in
|
|
|
- let state = new fusion_state in
|
|
|
- actx.with_timer ["<-";"fusion";"infer_from_texpr"] (fun () -> state#infer_from_texpr e);
|
|
|
- (* Handles block-level expressions, e.g. by removing side-effect-free ones and recursing into compound constructs like
|
|
|
- array or object declarations. The resulting element list is reversed.
|
|
|
- INFO: `el` is a reversed list of expressions in a block.
|
|
|
- *)
|
|
|
- let rec block_element ?(loop_bottom=false) acc el = match el with
|
|
|
+ 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 switch ->
|
|
|
+ let e1 = match com.platform with
|
|
|
+ | Lua | Python -> explore switch.switch_subject
|
|
|
+ | _ -> replace switch.switch_subject
|
|
|
+ in
|
|
|
+ if not !found then raise Exit;
|
|
|
+ let switch = { switch with switch_subject = e1 } in
|
|
|
+ {e with eexpr = TSwitch switch}
|
|
|
+ (* 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;
|
|
|
+ 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
|
|
|
+
|
|
|
+ (* Handles block-level expressions, e.g. by removing side-effect-free ones and recursing into compound constructs like
|
|
|
+ array or object declarations. The resulting element list is reversed.
|
|
|
+ INFO: `el` is a reversed list of expressions in a block.
|
|
|
+ *)
|
|
|
+ let rec block_element config state loop_bottom acc el =
|
|
|
+ let rec loop acc el = match el with
|
|
|
| {eexpr = TBinop(OpAssign, { eexpr = TLocal v1 }, { eexpr = TLocal v2 })} :: el when v1 == v2 ->
|
|
|
- block_element acc el
|
|
|
+ loop acc el
|
|
|
| {eexpr = TBinop((OpAssign | OpAssignOp _),_,_) | TUnop((Increment | Decrement),_,_)} as e1 :: el ->
|
|
|
- block_element (e1 :: acc) el
|
|
|
+ loop (e1 :: acc) el
|
|
|
| {eexpr = TLocal _} as e1 :: el when not config.local_dce ->
|
|
|
- block_element (e1 :: acc) el
|
|
|
+ loop (e1 :: acc) el
|
|
|
| {eexpr = TLocal v} :: el ->
|
|
|
state#dec_reads v;
|
|
|
- block_element acc el
|
|
|
+ loop acc el
|
|
|
| {eexpr = TField (_,fa)} as e1 :: el when PurityState.is_explicitly_impure fa ->
|
|
|
- block_element (e1 :: acc) el
|
|
|
+ loop (e1 :: acc) el
|
|
|
(* no-side-effect *)
|
|
|
| {eexpr = TFunction _ | TConst _ | TTypeExpr _} :: el ->
|
|
|
- block_element acc el
|
|
|
+ loop acc el
|
|
|
| {eexpr = TMeta((Meta.Pure,_,_),_)} :: el ->
|
|
|
- block_element acc el
|
|
|
+ loop acc el
|
|
|
| {eexpr = TCall({eexpr = TField(e1,fa)},el1)} :: el2 when PurityState.is_pure_field_access fa && config.local_dce ->
|
|
|
- block_element acc (e1 :: el1 @ el2)
|
|
|
+ loop acc (e1 :: el1 @ el2)
|
|
|
| {eexpr = TNew(c,tl,el1)} :: el2 when (match c.cl_constructor with Some cf when PurityState.is_pure c cf -> true | _ -> false) && config.local_dce ->
|
|
|
- block_element acc (el1 @ el2)
|
|
|
+ loop acc (el1 @ el2)
|
|
|
| {eexpr = TIf ({ eexpr = TConst (TBool t) },e1,e2)} :: el ->
|
|
|
if t then
|
|
|
- block_element acc (e1 :: el)
|
|
|
+ loop acc (e1 :: el)
|
|
|
else begin match e2 with
|
|
|
| None ->
|
|
|
- block_element acc el
|
|
|
+ loop acc el
|
|
|
| Some e ->
|
|
|
- block_element acc (e :: el)
|
|
|
+ loop acc (e :: el)
|
|
|
end
|
|
|
| ({eexpr = TSwitch switch} as e) :: el ->
|
|
|
begin match Optimizer.check_constant_switch switch with
|
|
|
- | Some e -> block_element acc (e :: el)
|
|
|
- | None -> block_element (e :: acc) el
|
|
|
+ | Some e -> loop acc (e :: el)
|
|
|
+ | None -> loop (e :: acc) el
|
|
|
end
|
|
|
(* no-side-effect composites *)
|
|
|
| {eexpr = TParenthesis e1 | TMeta(_,e1) | TCast(e1,None) | TField(e1,_) | TUnop(_,_,e1) | TEnumIndex e1 | TEnumParameter(e1,_,_)} :: el ->
|
|
|
- block_element acc (e1 :: el)
|
|
|
+ loop acc (e1 :: el)
|
|
|
| {eexpr = TArray(e1,e2) | TBinop(_,e1,e2)} :: el ->
|
|
|
- block_element acc (e1 :: e2 :: el)
|
|
|
+ loop acc (e1 :: e2 :: el)
|
|
|
| {eexpr = TArrayDecl el1 | TCall({eexpr = TField(_,FEnum _)},el1)} :: el2 -> (* TODO: check e1 of FEnum *)
|
|
|
- block_element acc (el1 @ el2)
|
|
|
+ loop acc (el1 @ el2)
|
|
|
| {eexpr = TObjectDecl fl} :: el ->
|
|
|
- block_element acc ((List.map snd fl) @ el)
|
|
|
+ loop acc ((List.map snd fl) @ el)
|
|
|
| {eexpr = TIf(e1,e2,None)} :: el when not (has_side_effect e2) ->
|
|
|
- block_element acc (e1 :: el)
|
|
|
+ loop acc (e1 :: el)
|
|
|
| {eexpr = TIf(e1,e2,Some e3)} :: el when not (has_side_effect e2) && not (has_side_effect e3) ->
|
|
|
- block_element acc (e1 :: el)
|
|
|
+ loop acc (e1 :: el)
|
|
|
| {eexpr = TBlock [e1]} :: el ->
|
|
|
- block_element acc (e1 :: el)
|
|
|
+ loop acc (e1 :: el)
|
|
|
| {eexpr = TBlock []} :: el ->
|
|
|
- block_element acc el
|
|
|
+ loop acc el
|
|
|
| { eexpr = TContinue } :: el when loop_bottom ->
|
|
|
- block_element [] el
|
|
|
+ loop [] el
|
|
|
| e1 :: el ->
|
|
|
- block_element (e1 :: acc) el
|
|
|
+ loop (e1 :: acc) el
|
|
|
| [] ->
|
|
|
acc
|
|
|
in
|
|
|
- let block_element ?(loop_bottom=false) acc el =
|
|
|
- actx.with_timer ["<-";"fusion";"block_element"] (fun () -> block_element ~loop_bottom acc el)
|
|
|
+ loop acc el
|
|
|
+
|
|
|
+ let apply actx e =
|
|
|
+ let config = actx.AnalyzerTypes.config in
|
|
|
+ let com = actx.com in
|
|
|
+ let state = new fusion_state in
|
|
|
+ actx.with_timer ["<-";"fusion";"infer_from_texpr"] (fun () -> state#infer_from_texpr e);
|
|
|
+ let block_element loop_bottom acc el =
|
|
|
+ actx.with_timer ["<-";"fusion";"block_element"] (fun () -> block_element config state loop_bottom acc el)
|
|
|
in
|
|
|
let can_be_fused v e =
|
|
|
let num_uses = state#get_reads v in
|
|
@@ -624,200 +821,6 @@ 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 switch ->
|
|
|
- let e1 = match com.platform with
|
|
|
- | Lua | Python -> explore switch.switch_subject
|
|
|
- | _ -> replace switch.switch_subject
|
|
|
- in
|
|
|
- if not !found then raise Exit;
|
|
|
- let switch = { switch with switch_subject = e1 } in
|
|
|
- {e with eexpr = TSwitch switch}
|
|
|
- (* 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;
|
|
@@ -914,8 +917,10 @@ module Fusion = struct
|
|
|
fuse (ev :: acc) (e2 :: el)
|
|
|
end
|
|
|
| _ ->
|
|
|
- begin match handle_assigned_local v1 e1 el with
|
|
|
+ begin match handle_assigned_local actx v1 e1 el with
|
|
|
| Some el ->
|
|
|
+ state#changed;
|
|
|
+ state#dec_reads v1;
|
|
|
fuse acc el
|
|
|
| None ->
|
|
|
fuse (ev :: acc) el
|
|
@@ -986,14 +991,14 @@ module Fusion = struct
|
|
|
Type.map_expr loop e
|
|
|
and block loop_body el t p =
|
|
|
let el = List.rev_map loop el in
|
|
|
- let el = block_element ~loop_bottom:loop_body [] el in
|
|
|
+ let el = block_element loop_body [] el in
|
|
|
(* fuse flips element order, but block_element doesn't care and flips it back *)
|
|
|
let el = fuse [] el in
|
|
|
- let el = block_element [] el in
|
|
|
+ let el = block_element false [] el in
|
|
|
let rec fuse_loop el =
|
|
|
state#reset;
|
|
|
let el = fuse [] el in
|
|
|
- let el = block_element [] el in
|
|
|
+ let el = block_element false [] el in
|
|
|
if state#did_change then fuse_loop el else el
|
|
|
in
|
|
|
let el = fuse_loop el in
|