Merge branch 'bjorn/compiler/beam_validator'

* bjorn/compiler/beam_validator:
  Add additional coverage and smoke test of beam_validator
  beam_validator: Strengthen validation of match states
  beam_validator: Use a record representing the match context

2 files changed, 190 insertions, 36 deletions

diff --git a/lib/compiler/src/beam_validator.erl b/lib/compiler/src/beam_validator.erl
index 1af17dc641..13aa31b7c9 100644
--- a/lib/compiler/src/beam_validator.erl
+++ b/lib/compiler/src/beam_validator.erl
@@ -161,6 +161,13 @@ validate_0(Module, [{function,Name,Ar,Entry,Code}|Fs], Ft) ->
 	 		% in the module (those that start with bs_start_match2).
 	}).
 
+%% Match context type.
+-record(ms,
+	{id=make_ref() :: reference(),		%Unique ID.
+	 valid=0 :: non_neg_integer(),		%Valid slots
+	 slots=0 :: non_neg_integer()		%Number of slots
+	}).
+
 validate_1(Is, Name, Arity, Entry, Ft) ->
     validate_2(labels(Is), Name, Arity, Entry, Ft).
 
@@ -274,7 +281,7 @@ valfun_1({bs_context_to_binary,Ctx}, #vst{current=#st{x=Xs}}=Vst) ->
     case Ctx of
 	{Tag,X} when Tag =:= x; Tag =:= y ->
 	    Type = case gb_trees:lookup(X, Xs) of
-		       {value,{match_context,_,_}} -> term;
+		       {value,#ms{}} -> term;
 		       _ -> get_term_type(Ctx, Vst)
 		   end,
 	    set_type_reg(Type, Ctx, Vst);
@@ -575,7 +582,7 @@ valfun_4({test,bs_start_match2,{f,Fail},Live,[Ctx,NeedSlots],Ctx}, Vst0) ->
     verify_live(Live, Vst0),
     Vst1 = prune_x_regs(Live, Vst0),
     BranchVst = case CtxType of
-		    {match_context,_,_} ->
+		    #ms{} ->
 			%% The failure branch will never be taken when Ctx
 			%% is a match context. Therefore, the type for Ctx
 			%% at the failure label must not be match_context
@@ -828,7 +835,7 @@ kill_state_1(Vst) ->
 %%  The stackframe must be initialized.
 %%  The instruction will return to the instruction following the call.
 call(Name, Live, #vst{current=St}=Vst) ->
-    verify_live(Live, Vst),
+    verify_call_args(Name, Live, Vst),
     verify_y_init(Vst),
     case return_type(Name, Vst) of
 	Type when Type =/= exception ->
@@ -840,44 +847,74 @@ call(Name, Live, #vst{current=St}=Vst) ->
 %% Tail call.
 %%  The stackframe must have a known size and be initialized.
 %%  Does not return to the instruction following the call.
-tail_call(Name, Live, Vst) ->
+tail_call(Name, Live, Vst0) ->
+    verify_y_init(Vst0),
+    Vst = deallocate(Vst0),
     verify_call_args(Name, Live, Vst),
-    verify_y_init(Vst),
     verify_no_ct(Vst),
     kill_state(Vst).
 
 verify_call_args(_, 0, #vst{}) ->
     ok;
 verify_call_args({f,Lbl}, Live, Vst) when is_integer(Live)->
-    Verify = fun(R) ->
-		     case get_move_term_type(R, Vst) of
-			 {match_context,_,_} ->
-			     verify_call_match_context(Lbl, Vst);
-			 _ ->
-			     ok
-		     end
-	     end,
-    verify_call_args_1(Live, Verify, Vst);
+    verify_local_call(Lbl, Live, Vst);
 verify_call_args(_, Live, Vst) when is_integer(Live)->
-    Verify = fun(R) -> get_term_type(R, Vst) end,
-    verify_call_args_1(Live, Verify, Vst);
+    verify_call_args_1(Live, Vst);
 verify_call_args(_, Live, _) ->
     error({bad_number_of_live_regs,Live}).
 
-verify_call_args_1(0, _, _) -> ok;
-verify_call_args_1(N, Verify, Vst) ->
+verify_call_args_1(0, _) -> ok;
+verify_call_args_1(N, Vst) ->
     X = N - 1,
-    Verify({x,X}),
-    verify_call_args_1(X, Verify, Vst).
+    get_term_type({x,X}, Vst),
+    verify_call_args_1(X, Vst).
+
+verify_local_call(Lbl, Live, Vst) ->
+    case all_ms_in_x_regs(Live, Vst) of
+	[{R,Ctx}] ->
+	    %% Verify that there is a suitable bs_start_match2 instruction.
+	    verify_call_match_context(Lbl, R, Vst),
+
+	    %% Since the callee has consumed the match context,
+	    %% there must be no additional copies in Y registers.
+	    #ms{id=Id} = Ctx,
+	    case ms_in_y_regs(Id, Vst) of
+		[] ->
+		    ok;
+		[_|_]=Ys ->
+		    error({multiple_match_contexts,[R|Ys]})
+	    end;
+	[_,_|_]=Xs0 ->
+	    Xs = [R || {R,_} <- Xs0],
+	    error({multiple_match_contexts,Xs});
+	[] ->
+	    ok
+    end.
+
+all_ms_in_x_regs(0, _Vst) ->
+    [];
+all_ms_in_x_regs(Live0, Vst) ->
+    Live = Live0 - 1,
+    R = {x,Live},
+    case get_move_term_type(R, Vst) of
+	#ms{}=M ->
+	    [{R,M}|all_ms_in_x_regs(Live, Vst)];
+	_ ->
+	    all_ms_in_x_regs(Live, Vst)
+    end.
+
+ms_in_y_regs(Id, #vst{current=#st{y=Ys0}}) ->
+    Ys = gb_trees:to_list(Ys0),
+    [Y || {Y,#ms{id=OtherId}} <- Ys, OtherId =:= Id].
 
-verify_call_match_context(Lbl, #vst{ft=Ft}) ->
+verify_call_match_context(Lbl, Ctx, #vst{ft=Ft}) ->
     case gb_trees:lookup(Lbl, Ft) of
 	none ->
 	    error(no_bs_start_match2);
 	{value,[{test,bs_start_match2,_,_,[Ctx,_],Ctx}|_]} ->
 	    ok;
-	{value,[{test,bs_start_match2,_,_,[Bin,_,_],Ctx}|_]} ->
-	    error({binary_and_context_regs_different,Bin,Ctx})
+	{value,[{test,bs_start_match2,_,_,_,_}=I|_]} ->
+	    error({unsuitable_bs_start_match2,I})
     end.
 
 allocate(Zero, Stk, Heap, Live, #vst{current=#st{numy=none}=St}=Vst0) ->
@@ -1009,7 +1046,7 @@ assert_unique_map_keys([_,_|_]=Ls) ->
 %%%
 
 bsm_match_state(Slots) ->
-    {match_context,0,Slots}.
+    #ms{slots=Slots}.
 
 bsm_validate_context(Reg, Vst) ->
     _ = bsm_get_context(Reg, Vst),
@@ -1017,7 +1054,7 @@ bsm_validate_context(Reg, Vst) ->
 
 bsm_get_context({x,X}=Reg, #vst{current=#st{x=Xs}}=_Vst) when is_integer(X) ->
     case gb_trees:lookup(X, Xs) of
-	{value,{match_context,_,_}=Ctx} -> Ctx;
+	{value,#ms{}=Ctx} -> Ctx;
 	_ -> error({no_bsm_context,Reg})
     end;
 bsm_get_context(Reg, _) -> error({bad_source,Reg}).
@@ -1029,8 +1066,8 @@ bsm_save(Reg, {atom,start}, Vst) ->
     Vst;
 bsm_save(Reg, SavePoint, Vst) ->
     case bsm_get_context(Reg, Vst) of
-	{match_context,Bits,Slots} when SavePoint < Slots ->
-	    Ctx = {match_context,Bits bor (1 bsl SavePoint),Slots},
+	#ms{valid=Bits,slots=Slots}=Ctxt0 when SavePoint < Slots ->
+	    Ctx = Ctxt0#ms{valid=Bits bor (1 bsl SavePoint),slots=Slots},
 	    set_type_reg(Ctx, Reg, Vst);
 	_ -> error({illegal_save,SavePoint})
     end.
@@ -1042,7 +1079,7 @@ bsm_restore(Reg, {atom,start}, Vst) ->
     Vst;
 bsm_restore(Reg, SavePoint, Vst) ->
     case bsm_get_context(Reg, Vst) of
-	{match_context,Bits,Slots} when SavePoint < Slots ->
+	#ms{valid=Bits,slots=Slots} when SavePoint < Slots ->
 	    case Bits band (1 bsl SavePoint) of
 		0 -> error({illegal_restore,SavePoint,not_set});
 		_ -> Vst
@@ -1123,7 +1160,7 @@ assert_term(Src, Vst) ->
 %%			Thus 'exception' is never stored as type descriptor
 %%			for a register.
 %%
-%% {match_context,_,_}	A matching context for bit syntax matching. We do allow
+%% #ms{}	        A match context for bit syntax matching. We do allow
 %%			it to moved/to from stack, but otherwise it must only
 %%			be accessed by bit syntax matching instructions.
 %%
@@ -1230,7 +1267,7 @@ get_term_type(Src, Vst) ->
 	initialized -> error({unassigned,Src});
 	{catchtag,_} -> error({catchtag,Src});
 	{trytag,_} -> error({trytag,Src});
-	{match_context,_,_} -> error({match_context,Src});
+	#ms{} -> error({match_context,Src});
 	Type -> Type
     end.
 
@@ -1382,11 +1419,12 @@ merge_types(bool, {atom,A}) ->
     merge_bool(A);
 merge_types({atom,A}, bool) ->
     merge_bool(A);
-merge_types({match_context,B0,Slots},{match_context,B1,Slots}) ->
-    {match_context,B0 bor B1,Slots};
-merge_types({match_context,_,_}=M, _) ->
+merge_types(#ms{id=Id,valid=B0,slots=Slots}=M,
+	    #ms{id=Id,valid=B1,slots=Slots}) ->
+    M#ms{valid=B0 bor B1,slots=Slots};
+merge_types(#ms{}=M, _) ->
     M;
-merge_types(_, {match_context,_,_}=M) ->
+merge_types(_, #ms{}=M) ->
     M;
 merge_types(T1, T2) when T1 =/= T2 ->
     %% Too different. All we know is that the type is a 'term'.
diff --git a/lib/compiler/test/beam_validator_SUITE.erl b/lib/compiler/test/beam_validator_SUITE.erl
index 7c4e88ca3e..263fd2ca7e 100644
--- a/lib/compiler/test/beam_validator_SUITE.erl
+++ b/lib/compiler/test/beam_validator_SUITE.erl
@@ -32,7 +32,7 @@
 	 bad_bin_match/1,bad_dsetel/1,
 	 state_after_fault_in_catch/1,no_exception_in_catch/1,
 	 undef_label/1,illegal_instruction/1,failing_gc_guard_bif/1,
-	 map_field_lists/1]).
+	 map_field_lists/1,cover_bin_opt/1]).
 	 
 -include_lib("common_test/include/ct.hrl").
 
@@ -60,7 +60,7 @@ groups() ->
        freg_state,bad_bin_match,bad_dsetel,
        state_after_fault_in_catch,no_exception_in_catch,
        undef_label,illegal_instruction,failing_gc_guard_bif,
-       map_field_lists]}].
+       map_field_lists,cover_bin_opt]}].
 
 init_per_suite(Config) ->
     Config.
@@ -406,8 +406,124 @@ map_field_lists(Config) ->
        empty_field_list}}
     ] = Errors.
 
+%% Coverage and smoke test of beam_validator.
+cover_bin_opt(_Config) ->
+    Ms = [beam_utils_SUITE,
+	  bs_match_SUITE,
+	  bs_bincomp_SUITE,
+	  bs_bit_binaries_SUITE,
+	  bs_utf_SUITE],
+    test_lib:p_run(fun try_bin_opt/1, Ms),
+    ok.
+
+try_bin_opt(Mod) ->
+    try
+	do_bin_opt(Mod)
+    catch
+	Class:Error ->
+	    io:format("~p: ~p ~p\n~p\n",
+		      [Mod,Class,Error,erlang:get_stacktrace()]),
+	    error
+    end.
+
+do_bin_opt(Mod) ->
+    Beam = code:which(Mod),
+    {ok,{Mod,[{abstract_code,
+	       {raw_abstract_v1,Abstr}}]}} =
+	beam_lib:chunks(Beam, [abstract_code]),
+    {ok,Mod,Asm} = compile:forms(Abstr, ['S']),
+    do_bin_opt(Mod, Asm).
+
+do_bin_opt(Mod, Asm) ->
+    do_bin_opt(fun enable_bin_opt/1, Mod, Asm),
+    do_bin_opt(fun remove_bs_start_match/1, Mod, Asm),
+    do_bin_opt(fun remove_bs_save/1, Mod, Asm),
+    do_bin_opt(fun destroy_ctxt/1, Mod, Asm),
+    do_bin_opt(fun destroy_save_point/1, Mod, Asm),
+    ok.
+
+do_bin_opt(Transform, Mod, Asm0) ->
+    Asm = Transform(Asm0),
+    case compile:forms(Asm, [from_asm,no_postopt,return]) of
+	{ok,[],Code,_Warnings} when is_binary(Code) ->
+	    ok;
+	{error,Errors0,_} ->
+	    %% beam_validator must return errors, not simply crash,
+	    %% when illegal code is found.
+	    ModString = atom_to_list(Mod),
+	    [{ModString,Errors}] = Errors0,
+	    _ = [verify_bin_opt_error(E) || E <- Errors],
+	    ok
+    end.
+
+verify_bin_opt_error({beam_validator,_}) ->
+    ok.
+
+enable_bin_opt(Module) ->
+    transform_is(fun enable_bin_opt_body/1, Module).
+
+enable_bin_opt_body([_,{'%',{no_bin_opt,_Reason,_Anno}}|Is]) ->
+    enable_bin_opt_body(Is);
+enable_bin_opt_body([I|Is]) ->
+    [I|enable_bin_opt_body(Is)];
+enable_bin_opt_body([]) ->
+    [].
+
+remove_bs_start_match(Module) ->
+    transform_remove(fun({test,bs_start_match2,_,_,_,_}) -> true;
+			(_) -> false
+		     end, Module).
+
+remove_bs_save(Module) ->
+    transform_remove(fun({bs_save2,_,_}) -> true;
+			(_) -> false
+		     end, Module).
+
+destroy_save_point(Module) ->
+    transform_i(fun do_destroy_save_point/1, Module).
+
+do_destroy_save_point({I,Ctx,_Point})
+  when I =:= bs_save2; I =:= bs_restore2 ->
+    {I,Ctx,42};
+do_destroy_save_point(I) ->
+    I.
+
+destroy_ctxt(Module) ->
+    transform_i(fun do_destroy_ctxt/1, Module).
+
+do_destroy_ctxt({bs_save2=I,Ctx,Point}) ->
+    {I,destroy_reg(Ctx),Point};
+do_destroy_ctxt({bs_restore2=I,Ctx,Point}) ->
+    {I,destroy_reg(Ctx),Point};
+do_destroy_ctxt({bs_context_to_binary=I,Ctx}) ->
+    {I,destroy_reg(Ctx)};
+do_destroy_ctxt(I) ->
+    I.
+
+destroy_reg({Tag,N}) ->
+    case rand:uniform() of
+	R when R < 0.6 ->
+	    {Tag,N+1};
+	_ ->
+	    {y,N+1}
+    end.
+
 %%%-------------------------------------------------------------------------
 
+transform_remove(Remove, Module) ->
+    transform_is(fun(Is) -> [I || I <- Is, not Remove(I)] end, Module).
+
+transform_i(Transform, Module) ->
+    transform_is(fun(Is) -> [Transform(I) || I <- Is] end, Module).
+
+transform_is(Transform, {Mod,Exp,Imp,Fs0,Lc}) ->
+    Fs = [transform_is_1(Transform, F) || F <- Fs0],
+    {Mod,Exp,Imp,Fs,Lc}.
+
+transform_is_1(Transform, {function,N,A,E,Is0}) ->
+    Is = Transform(Is0),
+    {function,N,A,E,Is}.
+
 do_val(Mod, Config) ->
     Data = proplists:get_value(data_dir, Config),
     Base = atom_to_list(Mod),