compiler: Add is_tagged_tuple instruction

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]}.
    ...

9 files changed, 153 insertions, 7 deletions

diff --git a/erts/emulator/beam/beam_emu.c b/erts/emulator/beam/beam_emu.c
index 8be0f58227..9a91fdce08 100644
--- a/erts/emulator/beam/beam_emu.c
+++ b/erts/emulator/beam/beam_emu.c
@@ -850,6 +850,15 @@ do {                                            \
   } while (0)
 #endif
 
+#define IsTaggedTuple(Src,Arityval,Tag,Fail) \
+  do {                                       \
+    if (!(is_tuple(Src) &&                   \
+         (tuple_val(Src))[0] == Arityval &&  \
+         (tuple_val(Src))[1] == Tag)) {      \
+        Fail;                                \
+    }                                        \
+  } while (0)
+
 #define IsBoolean(X, Fail) if ((X) != am_true && (X) != am_false) { Fail; }
 
 #define IsBinary(Src, Fail) \
diff --git a/erts/emulator/beam/ops.tab b/erts/emulator/beam/ops.tab
index ec36b23059..9b5bd7a749 100644
--- a/erts/emulator/beam/ops.tab
+++ b/erts/emulator/beam/ops.tab
@@ -620,6 +620,20 @@ test_heap Need u==1 | put_list Y=y x==0 x==0 => test_heap_1_put_list Need Y
 %macro: test_heap_1_put_list TestHeapPutList -pack
 test_heap_1_put_list I y
 
+#
+# is_tagged_tuple Fail=f Src=rxy Arity Atom=a
+#
+
+is_tagged_tuple Fail Literal=q Arity Atom => \
+    move Literal x | is_tagged_tuple Fail x Arity Atom
+is_tagged_tuple Fail=f c Arity Atom  => jump Fail
+
+%macro:is_tagged_tuple IsTaggedTuple -fail_action
+
+is_tagged_tuple f r A a
+is_tagged_tuple f x A a
+is_tagged_tuple f y A a
+
 # Test tuple & arity (head)
 
 is_tuple Fail Literal=q => move Literal x | is_tuple Fail x
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