Skip to content

Commit

Permalink
[typer] support safe nav for assign ops
Browse files Browse the repository at this point in the history 
closes HaxeFoundation#11379
  • Loading branch information
@Simn @0b1kn00b
Simn authored and 0b1kn00b committed Jan 25, 2024
1 parent 37b70df commit 232e3ef
Show file tree
Hide file tree
Showing 4 changed files with 191 additions and 155 deletions.
17 changes: 1 addition & 16 deletions src/typing/calls.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -192,22 +192,7 @@ let rec acc_get ctx g =
else acc_get ctx acc;
| AKExpr e -> e
| AKSafeNav sn ->
(* generate null-check branching for the safe navigation chain *)
let eobj = sn.sn_base in
let enull = Builder.make_null eobj.etype sn.sn_pos in
let eneq = Builder.binop OpNotEq eobj enull ctx.t.tbool sn.sn_pos in
let ethen = acc_get ctx sn.sn_access in
let tnull = ctx.t.tnull ethen.etype in
let ethen = if not (is_nullable ethen.etype) then
mk (TCast(ethen,None)) tnull ethen.epos
else
ethen
in
let eelse = Builder.make_null tnull sn.sn_pos in
let eif = mk (TIf(eneq,ethen,Some eelse)) tnull sn.sn_pos in
(match sn.sn_temp_var with
| None -> eif
| Some evar -> { eif with eexpr = TBlock [evar; eif] })
safe_nav_branch ctx sn (fun () -> acc_get ctx sn.sn_access)
| AKAccess _ -> die "" __LOC__
| AKResolve(sea,name) ->
(dispatcher sea.se_access.fa_pos)#resolve_call sea name
Expand Down
287 changes: 148 additions & 139 deletions src/typing/operators.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -575,7 +575,9 @@ let type_assign ctx e1 e2 with_type p =
if not (Common.ignore_error ctx.com) then
raise_typing_error "This expression cannot be accessed for writing" p
else check_acc acc
| AKUsingField _ | AKSafeNav _ ->
| AKSafeNav sn ->
safe_nav_branch ctx sn (fun () -> check_acc sn.sn_access)
| AKUsingField _ ->
raise_typing_error "Invalid operation" p
| AKExpr { eexpr = TLocal { v_kind = VUser TVOLocalFunction; v_name = name } } ->
raise_typing_error ("Cannot access function " ^ name ^ " for writing") p
Expand Down Expand Up @@ -668,79 +670,83 @@ let type_assign_op ctx op e1 e2 with_type p =
let e = BinopResult.to_texpr vr r_rhs assign in
vr#to_texpr e
in
(match !type_access_ref ctx (fst e1) (snd e1) (MSet (Some e2)) with_type with
| AKNo(_,p) ->
(* try abstract operator overloading *)
begin try
type_non_assign_op ctx op e1 e2 true true with_type p
with Not_found ->
raise_typing_error "This expression cannot be accessed for writing" p
end
| AKUsingField _ | AKSafeNav _ ->
raise_typing_error "Invalid operation" p
| AKExpr e ->
let e,vr = process_lhs_expr ctx "lhs" e in
let e_rhs = type_binop2 ctx op e e2 true WithType.value p in
assign vr e e_rhs
| AKField fa ->
let vr = new value_reference ctx in
let ef = vr#get_expr_part "fh" fa.fa_on in
let _,e_rhs = field_rhs op fa.fa_field ef in
let e_lhs = FieldAccess.get_field_expr {fa with fa_on = ef} FWrite in
assign vr e_lhs e_rhs
| AKAccessor fa ->
let vr = new value_reference ctx in
let ef = vr#get_expr_part "fh" fa.fa_on in
let t_lhs,e_rhs = field_rhs op fa.fa_field ef in
set vr {fa with fa_on = ef} t_lhs e_rhs []
| AKUsingAccessor sea ->
let fa = sea.se_access in
let ef,vr = process_lhs_expr ctx "fh" sea.se_this in
let t_lhs,e_rhs = field_rhs op fa.fa_field ef in
set vr sea.se_access t_lhs e_rhs [ef]
| AKAccess(a,tl,c,ebase,ekey) ->
let cf_get,tf_get,r_get,ekey = AbstractCast.find_array_read_access ctx a tl ekey p in
(* bind complex keys to a variable so they do not make it into the output twice *)
let save = save_locals ctx in
let vr = new value_reference ctx in
let maybe_bind_to_temp name e = match Optimizer.make_constant_expression ctx e with
| Some e -> e
| None -> vr#as_var name e
in
let ebase = maybe_bind_to_temp "base" ebase in
let ekey = maybe_bind_to_temp "key" ekey in
let eget = mk_array_get_call ctx (cf_get,tf_get,r_get,ekey) c ebase p in
let eget = type_binop2 ctx op eget e2 true WithType.value p in
let eget = BinopResult.to_texpr vr eget (fun e -> e) in
unify ctx eget.etype r_get p;
let cf_set,tf_set,r_set,ekey,eget = AbstractCast.find_array_write_access ctx a tl ekey eget p in
let et = type_module_type ctx (TClassDecl c) p in
let e = match cf_set.cf_expr,cf_get.cf_expr with
| None,None ->
let ea = mk (TArray(ebase,ekey)) r_get p in
mk (TBinop(OpAssignOp op,ea,type_expr ctx e2 (WithType.with_type r_get))) r_set p
| Some _,Some _ ->
let ef_set = mk (TField(et,(FStatic(c,cf_set)))) tf_set p in
let el = [make_call ctx ef_set [ebase;ekey;eget] r_set p] in
begin match el with
| [e] -> e
| el -> mk (TBlock el) r_set p
end
| _ ->
raise_typing_error "Invalid array access getter/setter combination" p
in
save();
vr#to_texpr e
| AKResolve(sea,name) ->
let e,vr = process_lhs_expr ctx "fh" sea.se_this in
let t_lhs,r_rhs = field_rhs_by_name op name e WithType.value in
let assign e_rhs =
let e_name = Texpr.Builder.make_string ctx.t name null_pos in
(new call_dispatcher ctx (MCall [e2]) with_type p)#field_call sea.se_access [sea.se_this;e_name;e_rhs] []
in
let e = BinopResult.to_texpr vr r_rhs assign in
vr#to_texpr e
)
let rec loop acc = match acc with
| AKNo(_,p) ->
(* try abstract operator overloading *)
begin try
type_non_assign_op ctx op e1 e2 true true with_type p
with Not_found ->
raise_typing_error "This expression cannot be accessed for writing" p
end
| AKSafeNav sn ->
safe_nav_branch ctx sn (fun () -> loop sn.sn_access)
| AKUsingField _ ->
raise_typing_error "Invalid operation" p
| AKExpr e ->
let e,vr = process_lhs_expr ctx "lhs" e in
let e_rhs = type_binop2 ctx op e e2 true WithType.value p in
assign vr e e_rhs
| AKField fa ->
let vr = new value_reference ctx in
let ef = vr#get_expr_part "fh" fa.fa_on in
let _,e_rhs = field_rhs op fa.fa_field ef in
let e_lhs = FieldAccess.get_field_expr {fa with fa_on = ef} FWrite in
assign vr e_lhs e_rhs
| AKAccessor fa ->
let vr = new value_reference ctx in
let ef = vr#get_expr_part "fh" fa.fa_on in
let t_lhs,e_rhs = field_rhs op fa.fa_field ef in
set vr {fa with fa_on = ef} t_lhs e_rhs []
| AKUsingAccessor sea ->
let fa = sea.se_access in
let ef,vr = process_lhs_expr ctx "fh" sea.se_this in
let t_lhs,e_rhs = field_rhs op fa.fa_field ef in
set vr sea.se_access t_lhs e_rhs [ef]
| AKAccess(a,tl,c,ebase,ekey) ->
let cf_get,tf_get,r_get,ekey = AbstractCast.find_array_read_access ctx a tl ekey p in
(* bind complex keys to a variable so they do not make it into the output twice *)
let save = save_locals ctx in
let vr = new value_reference ctx in
let maybe_bind_to_temp name e = match Optimizer.make_constant_expression ctx e with
| Some e -> e
| None -> vr#as_var name e
in
let ebase = maybe_bind_to_temp "base" ebase in
let ekey = maybe_bind_to_temp "key" ekey in
let eget = mk_array_get_call ctx (cf_get,tf_get,r_get,ekey) c ebase p in
let eget = type_binop2 ctx op eget e2 true WithType.value p in
let eget = BinopResult.to_texpr vr eget (fun e -> e) in
unify ctx eget.etype r_get p;
let cf_set,tf_set,r_set,ekey,eget = AbstractCast.find_array_write_access ctx a tl ekey eget p in
let et = type_module_type ctx (TClassDecl c) p in
let e = match cf_set.cf_expr,cf_get.cf_expr with
| None,None ->
let ea = mk (TArray(ebase,ekey)) r_get p in
mk (TBinop(OpAssignOp op,ea,type_expr ctx e2 (WithType.with_type r_get))) r_set p
| Some _,Some _ ->
let ef_set = mk (TField(et,(FStatic(c,cf_set)))) tf_set p in
let el = [make_call ctx ef_set [ebase;ekey;eget] r_set p] in
begin match el with
| [e] -> e
| el -> mk (TBlock el) r_set p
end
| _ ->
raise_typing_error "Invalid array access getter/setter combination" p
in
save();
vr#to_texpr e
| AKResolve(sea,name) ->
let e,vr = process_lhs_expr ctx "fh" sea.se_this in
let t_lhs,r_rhs = field_rhs_by_name op name e WithType.value in
let assign e_rhs =
let e_name = Texpr.Builder.make_string ctx.t name null_pos in
(new call_dispatcher ctx (MCall [e2]) with_type p)#field_call sea.se_access [sea.se_this;e_name;e_rhs] []
in
let e = BinopResult.to_texpr vr r_rhs assign in
vr#to_texpr e
in
loop (!type_access_ref ctx (fst e1) (snd e1) (MSet (Some e2)) with_type)


let type_binop ctx op e1 e2 is_assign_op with_type p =
match op with
Expand Down Expand Up @@ -854,69 +860,72 @@ let type_unop ctx op flag e with_type p =
| None -> vr#to_texpr e
| Some e' -> vr#to_texpr_el [e] e'
in
let access_set = !type_access_ref ctx (fst e) (snd e) (MSet None) WithType.value (* WITHTYPETODO *) in
match access_set with
| AKNo(acc,p) ->
begin try
try_abstract_unop_overloads (acc_get ctx acc)
with Not_found ->
raise_typing_error "This expression cannot be accessed for writing" p
end
| AKExpr e ->
find_overload_or_make e
| AKField fa ->
let vr = new value_reference ctx in
let ef = vr#get_expr_part "fh" fa.fa_on in
let access_get = type_field_default_cfg ctx ef fa.fa_field.cf_name p MGet WithType.value in
let e,e_out = match access_get with
| AKField _ ->
let e = FieldAccess.get_field_expr {fa with fa_on = ef} FGet in
find_overload_or_make e,None
| _ ->
let e_set = FieldAccess.get_field_expr {fa with fa_on = ef} FWrite in
let e_lhs = acc_get ctx access_get in
let e_lhs,e_out = maybe_tempvar_postfix vr e_lhs in
let e_op = mk (TBinop(binop,e_lhs,e_one)) e_lhs.etype p in
mk (TBinop(OpAssign,e_set,e_op)) e_set.etype p,e_out
in
generate vr e_out e
| AKAccessor fa ->
let vr = new value_reference ctx in
let ef = vr#get_expr_part "fh" fa.fa_on in
let fa = {fa with fa_on = ef} in
let e_lhs,e_out = read_on vr ef fa in
let e_op = mk (TBinop(binop,e_lhs,e_one)) e_lhs.etype p in
let dispatcher = new call_dispatcher ctx (MSet None) WithType.value p in
let e = dispatcher#accessor_call fa [e_op] [] in
generate vr e_out e
| AKUsingAccessor sea ->
let ef,vr = process_lhs_expr ctx "fh" sea.se_this in
let e_lhs,e_out = read_on vr ef sea.se_access in
let e_op = mk (TBinop(binop,e_lhs,e_one)) e_lhs.etype p in
let dispatcher = new call_dispatcher ctx (MSet None) WithType.value p in
let e = dispatcher#accessor_call sea.se_access [ef;e_op] [] in
generate vr e_out e
| AKAccess(a,tl,c,ebase,ekey) ->
begin try
(match op with Increment | Decrement -> () | _ -> raise Not_found);
let v_key = alloc_var VGenerated "tmp" ekey.etype ekey.epos in
let evar_key = mk (TVar(v_key,Some ekey)) ctx.com.basic.tvoid ekey.epos in
let ekey = mk (TLocal v_key) ekey.etype ekey.epos in
(* get *)
let e_get = mk_array_get_call ctx (AbstractCast.find_array_read_access_raise ctx a tl ekey p) c ebase p in
let v_get = alloc_var VGenerated "tmp" e_get.etype e_get.epos in
let ev_get = mk (TLocal v_get) v_get.v_type p in
let evar_get = mk (TVar(v_get,Some e_get)) ctx.com.basic.tvoid p in
(* op *)
let e_one = mk (TConst (TInt (Int32.of_int 1))) ctx.com.basic.tint p in
let e_op = mk (TBinop((if op = Increment then OpAdd else OpSub),ev_get,e_one)) ev_get.etype p in
(* set *)
let e_set = mk_array_set_call ctx (AbstractCast.find_array_write_access_raise ctx a tl ekey e_op p) c ebase p in
let el = evar_key :: evar_get :: e_set :: (if flag = Postfix then [ev_get] else []) in
mk (TBlock el) e_set.etype p
with Not_found ->
let e = mk_array_get_call ctx (AbstractCast.find_array_read_access ctx a tl ekey p) c ebase p in
let rec loop access_set = match access_set with
| AKNo(acc,p) ->
begin try
try_abstract_unop_overloads (acc_get ctx acc)
with Not_found ->
raise_typing_error "This expression cannot be accessed for writing" p
end
| AKExpr e ->
find_overload_or_make e
end
| AKUsingField _ | AKResolve _ | AKSafeNav _ ->
raise_typing_error "Invalid operation" p
| AKField fa ->
let vr = new value_reference ctx in
let ef = vr#get_expr_part "fh" fa.fa_on in
let access_get = type_field_default_cfg ctx ef fa.fa_field.cf_name p MGet WithType.value in
let e,e_out = match access_get with
| AKField _ ->
let e = FieldAccess.get_field_expr {fa with fa_on = ef} FGet in
find_overload_or_make e,None
| _ ->
let e_set = FieldAccess.get_field_expr {fa with fa_on = ef} FWrite in
let e_lhs = acc_get ctx access_get in
let e_lhs,e_out = maybe_tempvar_postfix vr e_lhs in
let e_op = mk (TBinop(binop,e_lhs,e_one)) e_lhs.etype p in
mk (TBinop(OpAssign,e_set,e_op)) e_set.etype p,e_out
in
generate vr e_out e
| AKAccessor fa ->
let vr = new value_reference ctx in
let ef = vr#get_expr_part "fh" fa.fa_on in
let fa = {fa with fa_on = ef} in
let e_lhs,e_out = read_on vr ef fa in
let e_op = mk (TBinop(binop,e_lhs,e_one)) e_lhs.etype p in
let dispatcher = new call_dispatcher ctx (MSet None) WithType.value p in
let e = dispatcher#accessor_call fa [e_op] [] in
generate vr e_out e
| AKUsingAccessor sea ->
let ef,vr = process_lhs_expr ctx "fh" sea.se_this in
let e_lhs,e_out = read_on vr ef sea.se_access in
let e_op = mk (TBinop(binop,e_lhs,e_one)) e_lhs.etype p in
let dispatcher = new call_dispatcher ctx (MSet None) WithType.value p in
let e = dispatcher#accessor_call sea.se_access [ef;e_op] [] in
generate vr e_out e
| AKAccess(a,tl,c,ebase,ekey) ->
begin try
(match op with Increment | Decrement -> () | _ -> raise Not_found);
let v_key = alloc_var VGenerated "tmp" ekey.etype ekey.epos in
let evar_key = mk (TVar(v_key,Some ekey)) ctx.com.basic.tvoid ekey.epos in
let ekey = mk (TLocal v_key) ekey.etype ekey.epos in
(* get *)
let e_get = mk_array_get_call ctx (AbstractCast.find_array_read_access_raise ctx a tl ekey p) c ebase p in
let v_get = alloc_var VGenerated "tmp" e_get.etype e_get.epos in
let ev_get = mk (TLocal v_get) v_get.v_type p in
let evar_get = mk (TVar(v_get,Some e_get)) ctx.com.basic.tvoid p in
(* op *)
let e_one = mk (TConst (TInt (Int32.of_int 1))) ctx.com.basic.tint p in
let e_op = mk (TBinop((if op = Increment then OpAdd else OpSub),ev_get,e_one)) ev_get.etype p in
(* set *)
let e_set = mk_array_set_call ctx (AbstractCast.find_array_write_access_raise ctx a tl ekey e_op p) c ebase p in
let el = evar_key :: evar_get :: e_set :: (if flag = Postfix then [ev_get] else []) in
mk (TBlock el) e_set.etype p
with Not_found ->
let e = mk_array_get_call ctx (AbstractCast.find_array_read_access ctx a tl ekey p) c ebase p in
find_overload_or_make e
end
| AKSafeNav sn ->
safe_nav_branch ctx sn (fun () -> loop sn.sn_access)
| AKUsingField _ | AKResolve _ ->
raise_typing_error "Invalid operation" p
in
loop (!type_access_ref ctx (fst e) (snd e) (MSet None) WithType.value (* WITHTYPETODO *))
18 changes: 18 additions & 0 deletions src/typing/typerBase.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -351,3 +351,21 @@ let get_abstract_froms ctx a pl =
| _ ->
acc
) l a.a_from_field

let safe_nav_branch ctx sn f_then =
(* generate null-check branching for the safe navigation chain *)
let eobj = sn.sn_base in
let enull = Builder.make_null eobj.etype sn.sn_pos in
let eneq = Builder.binop OpNotEq eobj enull ctx.t.tbool sn.sn_pos in
let ethen = f_then () in
let tnull = ctx.t.tnull ethen.etype in
let ethen = if not (is_nullable ethen.etype) then
mk (TCast(ethen,None)) tnull ethen.epos
else
ethen
in
let eelse = Builder.make_null tnull sn.sn_pos in
let eif = mk (TIf(eneq,ethen,Some eelse)) tnull sn.sn_pos in
(match sn.sn_temp_var with
| None -> eif
| Some evar -> { eif with eexpr = TBlock [evar; eif] })
24 changes: 24 additions & 0 deletions tests/unit/src/unit/issues/Issue11379.hx
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,24 @@
package unit.issues;

private class SafeNavThing {
static public function doSafeNavThings(test:SafeNavThing) {
test?.int = 0;
test?.int += 1;
test?.int++;
++test?.int;
}

public var int:Int;

public function new() {}
}

class Issue11379 extends Test {
function test() {
final test = new SafeNavThing();
SafeNavThing.doSafeNavThings(test);
eq(3, test.int);

SafeNavThing.doSafeNavThings(null);
}
}

0 comments on commit 232e3ef

Please sign in to comment.