Merge branch 'egil/compiler/is_tagged_tuple/OTP-12148'

* egil/compiler/is_tagged_tuple/OTP-12148:
  Update primary bootstrap
  compiler: Cover beam_record in tests
  hipe: Transform is_tagged_tuple instruction
  compiler: Add is_tagged_tuple instruction

9 files changed, 160 insertions, 7 deletions

diff --git a/lib/compiler/src/Makefile b/lib/compiler/src/Makefile
index cf60355a40..59b80ade5d 100644
--- a/lib/compiler/src/Makefile
+++ b/lib/compiler/src/Makefile
@@ -63,6 +63,7 @@ MODULES =  \
 	beam_peep \
 	beam_receive \
 	beam_reorder \
+	beam_record \
 	beam_split \
 	beam_trim \
 	beam_type \
diff --git a/lib/compiler/src/beam_disasm.erl b/lib/compiler/src/beam_disasm.erl
index c699672db1..8fd0b36d05 100644
--- a/lib/compiler/src/beam_disasm.erl
+++ b/lib/compiler/src/beam_disasm.erl
@@ -815,6 +815,9 @@ resolve_inst({is_tuple=I,Args0},_,_,_) ->
 resolve_inst({test_arity=I,Args0},_,_,_) ->
     [L|Args] = resolve_args(Args0),
     {test,I,L,Args};
+resolve_inst({is_tagged_tuple=I,Args0},_,_,_) ->
+    [F|Args] = resolve_args(Args0),
+    {test,I,F,Args};
 resolve_inst({select_val,Args},_,_,_) ->
     [Reg,FLbl,{{z,1},{u,_Len},List0}] = Args,
     List = resolve_args(List0),
diff --git a/lib/compiler/src/beam_record.erl b/lib/compiler/src/beam_record.erl
new file mode 100644
index 0000000000..419089b1bc
--- /dev/null
+++ b/lib/compiler/src/beam_record.erl
@@ -0,0 +1,106 @@
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2014-2017. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+%%
+%% File:    beam_record.erl
+%% Author:  Björn-Egil Dahlberg
+%% Created: 2014-09-03
+%%
+
+-module(beam_record).
+-export([module/2]).
+
+%% Rewrite the instruction stream on tagged tuple tests.
+%% Tagged tuples means a tuple of any arity with an atom as its first element.
+%% Typically records, ok-tuples and error-tuples.
+%% 
+%% from:
+%%     ...
+%%     {test,is_tuple,Fail,[Src]}.
+%%     {test,test_arity,Fail,[Src,Sz]}.
+%%     ...
+%%     {get_tuple_element,Src,0,Dst}.
+%%     ...
+%%     {test,is_eq_exact,Fail,[Dst,Atom]}.
+%%     ...
+%% to:
+%%     ...
+%%     {test,is_tagged_tuple,Fail,[Src,Sz,Atom]}.
+%%     ...
+
+
+-import(lists, [reverse/1]).
+
+-spec module(beam_utils:module_code(), [compile:option()]) ->
+                    {'ok',beam_utils:module_code()}.
+
+module({Mod,Exp,Attr,Fs0,Lc}, _Opt) ->
+    Fs = [function(F) || F <- Fs0],
+    {ok,{Mod,Exp,Attr,Fs,Lc}}.
+
+function({function,Name,Arity,CLabel,Is}) ->
+    try
+        Idx = beam_utils:index_labels(Is),
+        {function,Name,Arity,CLabel,rewrite(Is,Idx)}
+    catch
+        Class:Error ->
+            Stack = erlang:get_stacktrace(),
+            io:fwrite("Function: ~w/~w\n", [Name,Arity]),
+            erlang:raise(Class, Error, Stack)
+    end.
+
+rewrite(Is,Idx) ->
+    rewrite(Is,Idx,[]).
+
+rewrite([{test,is_tuple,Fail,[Src]}=I1,
+         {test,test_arity,Fail,[Src,N]}=I2|Is],Idx,Acc) ->
+    case is_tagged_tuple(Is,Fail,Src,Idx) of
+        no ->
+            rewrite(Is,Idx,[I2,I1|Acc]);
+        {Atom,[{block,[]}|Is1]} ->
+            rewrite(Is1,Idx,[{test,is_tagged_tuple,Fail,[Src,N,Atom]}|Acc]);
+        {Atom,Is1} ->
+            rewrite(Is1,Idx,[{test,is_tagged_tuple,Fail,[Src,N,Atom]}|Acc])
+    end;
+rewrite([I|Is],Idx,Acc) ->
+    rewrite(Is,Idx,[I|Acc]);
+rewrite([],_,Acc) -> reverse(Acc).
+
+is_tagged_tuple([{block,[{set,[Dst],[Src],{get_tuple_element,0}}=B|Bs]},
+                 {test,is_eq_exact,Fail,[Dst,{atom,_}=Atom]}|Is],Fail,Src,Idx) ->
+
+    %% if Dst is killed in the instruction stream and at fail label,
+    %% we can safely remove get_tuple_element.
+    %%
+    %% if Dst is not killed in the stream, we cannot remove get_tuple_element
+    %% since it is referenced.
+
+    case is_killed(Dst,Is,Fail,Idx) of
+        true  -> {Atom,[{block,Bs}|Is]};
+        false -> {Atom,[{block,[B|Bs]}|Is]}
+    end;
+is_tagged_tuple([{block,[{set,_,_,_}=B|Bs]},
+                 {test,is_eq_exact,_,_}=I|Is],Fail,Src,Idx) ->
+    case is_tagged_tuple([{block,Bs},I|Is],Fail,Src,Idx) of
+        {Atom,[{block,Bsr}|Isr]} -> {Atom,[{block,[B|Bsr]}|Isr]};
+        no                       -> no
+    end;
+is_tagged_tuple(_Is,_Fail,_Src,_Idx) ->
+    no.
+
+is_killed(Dst,Is,{_,Lbl},Idx) ->
+    beam_utils:is_killed(Dst,Is,Idx) andalso
+        beam_utils:is_killed_at(Dst,Lbl,Idx).
diff --git a/lib/compiler/src/beam_validator.erl b/lib/compiler/src/beam_validator.erl
index bf33ae0aeb..c26e5719aa 100644
--- a/lib/compiler/src/beam_validator.erl
+++ b/lib/compiler/src/beam_validator.erl
@@ -653,6 +653,9 @@ valfun_4({test,is_nonempty_list,{f,Lbl},[Cons]}, Vst) ->
 valfun_4({test,test_arity,{f,Lbl},[Tuple,Sz]}, Vst) when is_integer(Sz) ->
     assert_type(tuple, Tuple, Vst),
     set_type_reg({tuple,Sz}, Tuple, branch_state(Lbl, Vst));
+valfun_4({test,is_tagged_tuple,{f,Lbl},[Src,Sz,_Atom]}, Vst) ->
+    validate_src([Src], Vst),
+    set_type_reg({tuple, Sz}, Src, branch_state(Lbl, Vst));
 valfun_4({test,has_map_fields,{f,Lbl},Src,{list,List}}, Vst) ->
     assert_type(map, Src, Vst),
     assert_unique_map_keys(List),
diff --git a/lib/compiler/src/compile.erl b/lib/compiler/src/compile.erl
index c849306c0d..03b52932d1 100644
--- a/lib/compiler/src/compile.erl
+++ b/lib/compiler/src/compile.erl
@@ -216,19 +216,19 @@ expand_opt(return, Os) ->
 expand_opt(r12, Os) ->
     [no_recv_opt,no_line_info,no_utf8_atoms|Os];
 expand_opt(r13, Os) ->
-    [no_recv_opt,no_line_info,no_utf8_atoms|Os];
+    [no_record_opt,no_recv_opt,no_line_info,no_utf8_atoms|Os];
 expand_opt(r14, Os) ->
-    [no_line_info,no_utf8_atoms|Os];
+    [no_record_opt,no_line_info,no_utf8_atoms|Os];
 expand_opt(r15, Os) ->
-    [no_utf8_atoms|Os];
+    [no_record_opt,no_utf8_atoms|Os];
 expand_opt(r16, Os) ->
-    [no_utf8_atoms|Os];
+    [no_record_opt,no_utf8_atoms|Os];
 expand_opt(r17, Os) ->
-    [no_utf8_atoms|Os];
+    [no_record_opt,no_utf8_atoms|Os];
 expand_opt(r18, Os) ->
-    [no_utf8_atoms|Os];
+    [no_record_opt,no_utf8_atoms|Os];
 expand_opt(r19, Os) ->
-    [no_utf8_atoms|Os];
+    [no_record_opt,no_utf8_atoms|Os];
 expand_opt({debug_info_key,_}=O, Os) ->
     [encrypt_debug_info,O|Os];
 expand_opt(no_float_opt, Os) ->
@@ -755,6 +755,8 @@ asm_passes() ->
 	 {iff,dbsm,{listing,"bsm"}},
 	 {unless,no_recv_opt,{pass,beam_receive}},
 	 {iff,drecv,{listing,"recv"}},
+	 {unless,no_record_opt,{pass,beam_record}},
+	 {iff,drecord,{listing,"record"}},
 	 {unless,no_stack_trimming,{pass,beam_trim}},
 	 {iff,dtrim,{listing,"trim"}},
 	 {pass,beam_flatten}]},
@@ -1849,6 +1851,7 @@ pre_load() ->
 	 beam_opcodes,
 	 beam_peep,
 	 beam_receive,
+         beam_record,
 	 beam_reorder,
 	 beam_split,
 	 beam_trim,
diff --git a/lib/compiler/src/compiler.app.src b/lib/compiler/src/compiler.app.src
index 3cb991687b..3961b2af86 100644
--- a/lib/compiler/src/compiler.app.src
+++ b/lib/compiler/src/compiler.app.src
@@ -38,6 +38,7 @@
 	     beam_peep,
 	     beam_receive,
 	     beam_reorder,
+	     beam_record,
 	     beam_split,
 	     beam_trim,
 	     beam_type,
diff --git a/lib/compiler/src/genop.tab b/lib/compiler/src/genop.tab
index dcbdeb32e6..5e0c2b3ebf 100755
--- a/lib/compiler/src/genop.tab
+++ b/lib/compiler/src/genop.tab
@@ -537,3 +537,9 @@ BEAM_FORMAT_NUMBER=0
 156: is_map/2
 157: has_map_fields/3
 158: get_map_elements/3
+
+## @spec is_tagged_tuple Lbl Reg N Atom
+## @doc Test the type of Reg and jumps to Lbl if it is not a tuple.
+##      Test the arity of Reg and jumps to Lbl if it is not N.
+##      Test the first element of the tuple and jumps to Lbl if it is not Atom.
+159: is_tagged_tuple/4
diff --git a/lib/compiler/test/misc_SUITE.erl b/lib/compiler/test/misc_SUITE.erl
index 621524114f..fa6d5ee957 100644
--- a/lib/compiler/test/misc_SUITE.erl
+++ b/lib/compiler/test/misc_SUITE.erl
@@ -280,6 +280,23 @@ silly_coverage(Config) when is_list(Config) ->
 		       {block,[a|b]}]}],0},
     expect_error(fun() -> beam_receive:module(ReceiveInput, []) end),
 
+    %% beam_record.
+    RecordInput = {?MODULE,[{foo,0}],[],
+		    [{function,foo,1,2,
+		      [{label,1},
+		       {func_info,{atom,?MODULE},{atom,foo},1},
+                       {label,2},
+                       {test,is_tuple,{f,1},[{x,0}]},
+                       {test,test_arity,{f,1},[{x,0},3]},
+                       {block,[{set,[{x,1}],[{x,0}],{get_tuple_element,0}}]},
+                       {test,is_eq_exact,{f,1},[{x,1},{atom,bar}]},
+                       {block,[{set,[{x,2}],[{x,0}],{get_tuple_element,1}}|a]},
+                       {test,is_eq_exact,{f,1},[{x,2},{integer,1}]},
+                       {block,[{set,[{x,0}],[{atom,ok}],move}]},
+                       return]}],0},
+
+    expect_error(fun() -> beam_record:module(RecordInput, []) end),
+
     BeamZInput = {?MODULE,[{foo,0}],[],
 		  [{function,foo,0,2,
 		    [{label,1},
diff --git a/lib/hipe/icode/hipe_beam_to_icode.erl b/lib/hipe/icode/hipe_beam_to_icode.erl
index 610578dfbc..2abecf7f18 100644
--- a/lib/hipe/icode/hipe_beam_to_icode.erl
+++ b/lib/hipe/icode/hipe_beam_to_icode.erl
@@ -513,6 +513,19 @@ trans_fun([{test,test_arity,{f,Lbl},[Reg,N]}|Instructions], Env) ->
   I = hipe_icode:mk_type([trans_arg(Reg)],{tuple,N}, 
 			 hipe_icode:label_name(True),map_label(Lbl)),
   [I,True | trans_fun(Instructions,Env)];
+%%--- test_is_tagged_tuple  ---
+trans_fun([{test,is_tagged_tuple,{f,Lbl},[Reg,N,Atom]}|Instructions], Env) ->
+  TrueArity = mk_label(new),
+  IArity = hipe_icode:mk_type([trans_arg(Reg)],{tuple,N},
+			       hipe_icode:label_name(TrueArity),map_label(Lbl)),
+  Var = hipe_icode:mk_new_var(),
+  IGet = hipe_icode:mk_primop([Var],
+			      #unsafe_element{index=1},
+			      [trans_arg(Reg)]),
+  TrueAtom = mk_label(new),
+  IEQ = hipe_icode:mk_type([Var], Atom, hipe_icode:label_name(TrueAtom),
+			   map_label(Lbl)),
+  [IArity,TrueArity,IGet,IEQ,TrueAtom | trans_fun(Instructions,Env)];
 %%--- is_map ---
 trans_fun([{test,is_map,{f,Lbl},[Arg]}|Instructions], Env) ->
   {Code,Env1} = trans_type_test(map,Lbl,Arg,Env),