Merge pull request #1701 from bjorng/bjorn/get_hd_tl

Eliminate get_list/3 internally in the compiler

16 files changed, 146 insertions, 55 deletions

diff --git a/erts/emulator/beam/instrs.tab b/erts/emulator/beam/instrs.tab
index f19027b1ec..6a531fcc09 100644
--- a/erts/emulator/beam/instrs.tab
+++ b/erts/emulator/beam/instrs.tab
@@ -322,6 +322,16 @@ get_list(Src, Hd, Tl) {
     $Tl = tl;
 }
 
+get_hd(Src, Hd) {
+    Eterm* tmp_ptr = list_val($Src);
+    $Hd = CAR(tmp_ptr);
+}
+
+get_tl(Src, Tl) {
+    Eterm* tmp_ptr = list_val($Src);
+    $Tl = CDR(tmp_ptr);
+}
+
 i_get(Src, Dst) {
     $Dst = erts_pd_hash_get(c_p, $Src);
 }
diff --git a/erts/emulator/beam/ops.tab b/erts/emulator/beam/ops.tab
index 1f4a8eadb0..77e375f2c0 100644
--- a/erts/emulator/beam/ops.tab
+++ b/erts/emulator/beam/ops.tab
@@ -182,6 +182,9 @@ get_list r x y
 get_list r y r
 get_list r x r
 
+get_hd xy xy
+get_tl xy xy
+
 # Old-style catch.
 catch y f
 catch_end y
diff --git a/lib/compiler/src/beam_a.erl b/lib/compiler/src/beam_a.erl
index 7df2edd714..91acb19971 100644
--- a/lib/compiler/src/beam_a.erl
+++ b/lib/compiler/src/beam_a.erl
@@ -61,6 +61,14 @@ rename_instrs([{'%live',_}|Is]) ->
     %% Ignore old type of live annotation. Only happens when compiling
     %% from very old .S files.
     rename_instrs(Is);
+rename_instrs([{get_list,S,D1,D2}|Is]) ->
+    %% Only happens when compiling from old .S files.
+    if
+        D1 =:= S ->
+            [{get_tl,S,D2},{get_hd,S,D1}|rename_instrs(Is)];
+        true ->
+            [{get_hd,S,D1},{get_tl,S,D2}|rename_instrs(Is)]
+    end;
 rename_instrs([I|Is]) ->
     [rename_instr(I)|rename_instrs(Is)];
 rename_instrs([]) -> [].
diff --git a/lib/compiler/src/beam_block.erl b/lib/compiler/src/beam_block.erl
index ecefeeae54..9543aa1355 100644
--- a/lib/compiler/src/beam_block.erl
+++ b/lib/compiler/src/beam_block.erl
@@ -110,7 +110,8 @@ collect({put_tuple,A,D})     -> {set,[D],[],{put_tuple,A}};
 collect({put,S})             -> {set,[],[S],put};
 collect({get_tuple_element,S,I,D}) -> {set,[D],[S],{get_tuple_element,I}};
 collect({set_tuple_element,S,D,I}) -> {set,[],[S,D],{set_tuple_element,I}};
-collect({get_list,S,D1,D2})  -> {set,[D1,D2],[S],get_list};
+collect({get_hd,S,D})  ->       {set,[D],[S],get_hd};
+collect({get_tl,S,D})  ->       {set,[D],[S],get_tl};
 collect(remove_message)      -> {set,[],[],remove_message};
 collect({put_map,F,Op,S,D,R,{list,Puts}}) ->
     {set,[D],[S|Puts],{alloc,R,{put_map,Op,F}}};
@@ -252,6 +253,16 @@ opt([{set,[D1],[{integer,Idx1},Reg],{bif,element,{f,L}}}=I1,
      {set,[D2],[{integer,Idx2},Reg],{bif,element,{f,L}}}=I2|Is])
   when Idx1 < Idx2, D1 =/= D2, D1 =/= Reg, D2 =/= Reg ->
     opt([I2,I1|Is]);
+opt([{set,Hd0,Cons,get_hd}=GetHd,
+     {set,Tl0,Cons,get_tl}=GetTl|Is0]) ->
+    case {opt_moves(Hd0, [GetTl|Is0]),opt_moves(Tl0, [GetHd|Is0])} of
+        {{Hd0,Is},{Tl0,_}} ->
+            [GetHd|opt(Is)];
+        {{Hd,Is},{Tl0,_}} ->
+            [{set,Hd,Cons,get_hd}|opt(Is)];
+        {{_,_},{Tl,Is}} ->
+            [{set,Tl,Cons,get_tl}|opt(Is)]
+    end;
 opt([{set,Ds0,Ss,Op}|Is0]) ->
     {Ds,Is} = opt_moves(Ds0, Is0),
     [{set,Ds,Ss,Op}|opt(Is)];
@@ -267,17 +278,6 @@ opt_moves([D0]=Ds, Is0) ->
     case opt_move(D0, Is0) of
 	not_possible -> {Ds,Is0};
 	{D1,Is} -> {[D1],Is}
-    end;
-opt_moves([X0,Y0], Is0) ->
-    {X,Is2} = case opt_move(X0, Is0) of
-		  not_possible -> {X0,Is0};
-		  {Y0,_} -> {X0,Is0};
-		  {_X1,_Is1} = XIs1 -> XIs1
-	      end,
-    case opt_move(Y0, Is2) of
-	not_possible -> {[X,Y0],Is2};
-	{X,_} -> {[X,Y0],Is2};
-	{Y,Is} -> {[X,Y],Is}
     end.
 
 %% opt_move(Dest, [Instruction]) -> {UpdatedDest,[Instruction]} | not_possible
diff --git a/lib/compiler/src/beam_disasm.erl b/lib/compiler/src/beam_disasm.erl
index 50b76d7f29..a68c4b5367 100644
--- a/lib/compiler/src/beam_disasm.erl
+++ b/lib/compiler/src/beam_disasm.erl
@@ -1090,6 +1090,10 @@ resolve_inst({build_stacktrace,[]},_,_,_) ->
     build_stacktrace;
 resolve_inst({raw_raise,[]},_,_,_) ->
     raw_raise;
+resolve_inst({get_hd,[Src,Dst]},_,_,_) ->
+    {get_hd,Src,Dst};
+resolve_inst({get_tl,[Src,Dst]},_,_,_) ->
+    {get_tl,Src,Dst};
 
 %%
 %% Catches instructions that are not yet handled.
diff --git a/lib/compiler/src/beam_flatten.erl b/lib/compiler/src/beam_flatten.erl
index a4d45a4ca6..4045ab6dc5 100644
--- a/lib/compiler/src/beam_flatten.erl
+++ b/lib/compiler/src/beam_flatten.erl
@@ -50,6 +50,9 @@ norm_block([{set,[],[],{alloc,R,Alloc}}|Is], Acc0) ->
 	Acc ->
 	    norm_block(Is, Acc)
     end;
+norm_block([{set,[D1],[S],get_hd},{set,[D2],[S],get_tl}|Is], Acc) ->
+    I = {get_list,S,D1,D2},
+    norm_block(Is, [I|Acc]);
 norm_block([I|Is], Acc) -> norm_block(Is, [norm(I)|Acc]);
 norm_block([], Acc) -> Acc.
     
@@ -64,7 +67,8 @@ norm({set,[D],[],{put_tuple,A}})  -> {put_tuple,A,D};
 norm({set,[],[S],put})            -> {put,S};
 norm({set,[D],[S],{get_tuple_element,I}}) -> {get_tuple_element,S,I,D};
 norm({set,[],[S,D],{set_tuple_element,I}}) -> {set_tuple_element,S,D,I};
-norm({set,[D1,D2],[S],get_list})          -> {get_list,S,D1,D2};
+norm({set,[D],[S],get_hd})        -> {get_hd,S,D};
+norm({set,[D],[S],get_tl})        -> {get_tl,S,D};
 norm({set,[D],[S|Puts],{alloc,R,{put_map,Op,F}}}) ->
     {put_map,F,Op,S,D,R,{list,Puts}};
 norm({set,[],[],remove_message})   -> remove_message;
diff --git a/lib/compiler/src/beam_type.erl b/lib/compiler/src/beam_type.erl
index a2e3af37d0..b83ed17b55 100644
--- a/lib/compiler/src/beam_type.erl
+++ b/lib/compiler/src/beam_type.erl
@@ -477,8 +477,6 @@ update({set,[D],[S1,S2],{alloc,_,{gc_bif,Op,{f,0}}}}, Ts0) ->
 update({set,[],_Src,_Op}, Ts0) -> Ts0;
 update({set,[D],_Src,_Op}, Ts0) ->
     tdb_update([{D,kill}], Ts0);
-update({set,[D1,D2],_Src,_Op}, Ts0) ->
-    tdb_update([{D1,kill},{D2,kill}], Ts0);
 update({kill,D}, Ts) ->
     tdb_update([{D,kill}], Ts);
 
diff --git a/lib/compiler/src/beam_utils.erl b/lib/compiler/src/beam_utils.erl
index 5333925589..4dcce30583 100644
--- a/lib/compiler/src/beam_utils.erl
+++ b/lib/compiler/src/beam_utils.erl
@@ -602,8 +602,11 @@ check_liveness(R, [{test_heap,N,Live}|Is], St) ->
 check_liveness(R, [{allocate_zero,N,Live}|Is], St) ->
     I = {block,[{set,[],[],{alloc,Live,{zero,N,0,[]}}}]},
     check_liveness(R, [I|Is], St);
-check_liveness(R, [{get_list,S,D1,D2}|Is], St) ->
-    I = {block,[{set,[D1,D2],[S],get_list}]},
+check_liveness(R, [{get_hd,S,D}|Is], St) ->
+    I = {block,[{set,[D],[S],get_hd}]},
+    check_liveness(R, [I|Is], St);
+check_liveness(R, [{get_tl,S,D}|Is], St) ->
+    I = {block,[{set,[D],[S],get_tl}]},
     check_liveness(R, [I|Is], St);
 check_liveness(R, [remove_message|Is], St) ->
     check_liveness(R, Is, St);
diff --git a/lib/compiler/src/beam_validator.erl b/lib/compiler/src/beam_validator.erl
index f8bf935132..7e5d86c177 100644
--- a/lib/compiler/src/beam_validator.erl
+++ b/lib/compiler/src/beam_validator.erl
@@ -591,6 +591,12 @@ valfun_4({get_list,Src,D1,D2}, Vst0) ->
     assert_type(cons, Src, Vst0),
     Vst = set_type_reg(term, D1, Vst0),
     set_type_reg(term, D2, Vst);
+valfun_4({get_hd,Src,Dst}, Vst) ->
+    assert_type(cons, Src, Vst),
+    set_type_reg(term, Dst, Vst);
+valfun_4({get_tl,Src,Dst}, Vst) ->
+    assert_type(cons, Src, Vst),
+    set_type_reg(term, Dst, Vst);
 valfun_4({get_tuple_element,Src,I,Dst}, Vst) ->
     assert_type({tuple_element,I+1}, Src, Vst),
     set_type_reg(term, Dst, Vst);
diff --git a/lib/compiler/src/beam_z.erl b/lib/compiler/src/beam_z.erl
index 1c56b95a9e..6c3a6995d7 100644
--- a/lib/compiler/src/beam_z.erl
+++ b/lib/compiler/src/beam_z.erl
@@ -24,18 +24,20 @@
 
 -export([module/2]).
 
--import(lists, [dropwhile/2]).
+-import(lists, [dropwhile/2,map/2]).
 
 -spec module(beam_utils:module_code(), [compile:option()]) ->
                     {'ok',beam_asm:module_code()}.
 
-module({Mod,Exp,Attr,Fs0,Lc}, _Opt) ->
-    Fs = [function(F) || F <- Fs0],
+module({Mod,Exp,Attr,Fs0,Lc}, Opts) ->
+    NoGetHdTl = proplists:get_bool(no_get_hd_tl, Opts),
+    Fs = [function(F, NoGetHdTl) || F <- Fs0],
     {ok,{Mod,Exp,Attr,Fs,Lc}}.
 
-function({function,Name,Arity,CLabel,Is0}) ->
+function({function,Name,Arity,CLabel,Is0}, NoGetHdTl) ->
     try
-	Is = undo_renames(Is0),
+	Is1 = undo_renames(Is0),
+        Is = maybe_eliminate_get_hd_tl(Is1, NoGetHdTl),
 	{function,Name,Arity,CLabel,Is}
     catch
         Class:Error:Stack ->
@@ -65,6 +67,10 @@ undo_renames([{bif,raise,_,_,_}=I|Is0]) ->
 		      (_) -> true
 		   end, Is0),
     [I|undo_renames(Is)];
+undo_renames([{get_hd,Src,Dst1},{get_tl,Src,Dst2}|Is]) ->
+    [{get_list,Src,Dst1,Dst2}|undo_renames(Is)];
+undo_renames([{get_tl,Src,Dst2},{get_hd,Src,Dst1}|Is]) ->
+    [{get_list,Src,Dst1,Dst2}|undo_renames(Is)];
 undo_renames([I|Is]) ->
     [undo_rename(I)|undo_renames(Is)];
 undo_renames([]) -> [].
@@ -107,3 +113,17 @@ undo_rename({get_map_elements,Fail,Src,{list,List}}) ->
 undo_rename({select,I,Reg,Fail,List}) ->
     {I,Reg,Fail,{list,List}};
 undo_rename(I) -> I.
+
+%%%
+%%% Eliminate get_hd/get_tl instructions if requested by
+%%% the no_get_hd_tl option.
+%%%
+
+maybe_eliminate_get_hd_tl(Is, true) ->
+    map(fun({get_hd,Cons,Hd}) ->
+                {get_list,Cons,Hd,{x,1022}};
+           ({get_tl,Cons,Tl}) ->
+                {get_list,Cons,{x,1022},Tl};
+           (I) -> I
+        end, Is);
+maybe_eliminate_get_hd_tl(Is, false) -> Is.
diff --git a/lib/compiler/src/compile.erl b/lib/compiler/src/compile.erl
index 1409c358c2..c6a0056a70 100644
--- a/lib/compiler/src/compile.erl
+++ b/lib/compiler/src/compile.erl
@@ -219,13 +219,15 @@ expand_opt(report, Os) ->
 expand_opt(return, Os) ->
     [return_errors,return_warnings|Os];
 expand_opt(r16, Os) ->
-    [no_record_opt,no_utf8_atoms|Os];
+    [no_get_hd_tl,no_record_opt,no_utf8_atoms|Os];
 expand_opt(r17, Os) ->
-    [no_record_opt,no_utf8_atoms|Os];
+    [no_get_hd_tl,no_record_opt,no_utf8_atoms|Os];
 expand_opt(r18, Os) ->
-    [no_record_opt,no_utf8_atoms|Os];
+    [no_get_hd_tl,no_record_opt,no_utf8_atoms|Os];
 expand_opt(r19, Os) ->
-    [no_record_opt,no_utf8_atoms|Os];
+    [no_get_hd_tl,no_record_opt,no_utf8_atoms|Os];
+expand_opt(r20, Os) ->
+    [no_get_hd_tl,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) ->
diff --git a/lib/compiler/src/genop.tab b/lib/compiler/src/genop.tab
index d59bb241a8..a47d4e8cf7 100755
--- a/lib/compiler/src/genop.tab
+++ b/lib/compiler/src/genop.tab
@@ -564,3 +564,13 @@ BEAM_FORMAT_NUMBER=0
 ##       exception, but store the atom 'badarg' in x(0) and execute the
 ##       next instruction.
 161: raw_raise/0
+
+## @spec get_hd  Source Head
+## @doc  Get the head (or car) part of a list (a cons cell) from Source and
+##       put it into the register Head.
+162: get_hd/2
+
+## @spec get_tl  Source Tail
+## @doc  Get the tail (or cdr) part of a list (a cons cell) from Source and
+##       put it into the register Tail.
+163: get_tl/2
diff --git a/lib/compiler/src/v3_codegen.erl b/lib/compiler/src/v3_codegen.erl
index a96d58a903..a8f4926e55 100644
--- a/lib/compiler/src/v3_codegen.erl
+++ b/lib/compiler/src/v3_codegen.erl
@@ -1495,28 +1495,34 @@ select_extract_map(Src, Vs, Fail, I, Vdb, Bef, St) ->
     {Code, Aft, St}.
 
 
-select_extract_cons(Src, [#k_var{name=Hd}, #k_var{name=Tl}], I, Vdb, Bef, St) ->
-    {Es,Aft} = case {vdb_find(Hd, Vdb), vdb_find(Tl, Vdb)} of
-		   {{_,_,Lhd}, {_,_,Ltl}} when Lhd =< I, Ltl =< I ->
-		       %% Both head and tail are dead.  No need to generate
-		       %% any instruction.
-		       {[], Bef};
-		   _ ->
-		       %% At least one of head and tail will be used,
-		       %% but we must always fetch both.  We will call
-		       %% clear_dead/2 to allow reuse of the register
-		       %% in case only of them is used.
-
-		       Reg0 = put_reg(Tl, put_reg(Hd, Bef#sr.reg)),
-		       Int0 = Bef#sr{reg=Reg0},
-		       Rsrc = fetch_var(Src, Int0),
-		       Rhd = fetch_reg(Hd, Reg0),
-		       Rtl = fetch_reg(Tl, Reg0),
-		       Int1 = clear_dead(Int0, I, Vdb),
-		       {[{get_list,Rsrc,Rhd,Rtl}], Int1}
-	       end,
-    {Es,Aft,St}.
-    
+select_extract_cons(Src, [#k_var{name=Hd},#k_var{name=Tl}], I, Vdb, Bef, St) ->
+    Rsrc = fetch_var(Src, Bef),
+    Int = clear_dead(Bef, I, Vdb),
+    {{_,_,Lhd},{_,_,Ltl}} = {vdb_find(Hd, Vdb),vdb_find(Tl, Vdb)},
+    case {Lhd =< I, Ltl =< I} of
+        {true,true} ->
+            %% Both dead.
+            {[],Bef,St};
+        {true,false} ->
+            %% Head dead.
+            Reg0 = put_reg(Tl, Bef#sr.reg),
+            Aft = Int#sr{reg=Reg0},
+            Rtl = fetch_reg(Tl, Reg0),
+            {[{get_tl,Rsrc,Rtl}],Aft,St};
+        {false,true} ->
+            %% Tail dead.
+            Reg0 = put_reg(Hd, Bef#sr.reg),
+            Aft = Int#sr{reg=Reg0},
+            Rhd = fetch_reg(Hd, Reg0),
+            {[{get_hd,Rsrc,Rhd}],Aft,St};
+        {false,false} ->
+            %% Both used.
+            Reg0 = put_reg(Tl, put_reg(Hd, Bef#sr.reg)),
+            Aft = Bef#sr{reg=Reg0},
+            Rhd = fetch_reg(Hd, Reg0),
+            Rtl = fetch_reg(Tl, Reg0),
+            {[{get_hd,Rsrc,Rhd},{get_tl,Rsrc,Rtl}],Aft,St}
+    end.
 
 guard_clause_cg(#k_guard_clause{anno=#l{vdb=Vdb},guard=G,body=B}, Fail, Bef, St0) ->
     {Gis,Int,St1} = guard_cg(G, Fail, Vdb, Bef, St0),
diff --git a/lib/compiler/test/compile_SUITE.erl b/lib/compiler/test/compile_SUITE.erl
index 35c11d894d..eee5bc733f 100644
--- a/lib/compiler/test/compile_SUITE.erl
+++ b/lib/compiler/test/compile_SUITE.erl
@@ -1455,19 +1455,21 @@ env_compiler_options(_Config) ->
 bc_options(Config) ->
     DataDir = proplists:get_value(data_dir, Config),
 
-    101 = highest_opcode(DataDir, small_float, [no_line_info]),
+    101 = highest_opcode(DataDir, small_float, [no_get_hd_tl,no_line_info]),
 
     103 = highest_opcode(DataDir, big,
-                         [no_record_opt,no_line_info,no_stack_trimming]),
+                         [no_get_hd_tl,no_record_opt,
+                          no_line_info,no_stack_trimming]),
 
-    125 = highest_opcode(DataDir, small_float, [no_line_info,no_float_opt]),
+    125 = highest_opcode(DataDir, small_float,
+                         [no_get_hd_tl,no_line_info,no_float_opt]),
 
     132 = highest_opcode(DataDir, small,
-                         [no_record_opt,no_float_opt,no_line_info]),
+                         [no_get_hd_tl,no_record_opt,no_float_opt,no_line_info]),
 
-    136 = highest_opcode(DataDir, big, [no_record_opt,no_line_info]),
+    136 = highest_opcode(DataDir, big, [no_get_hd_tl,no_record_opt,no_line_info]),
 
-    153 = highest_opcode(DataDir, big, [no_record_opt]),
+    153 = highest_opcode(DataDir, big, [no_get_hd_tl,no_record_opt]),
     153 = highest_opcode(DataDir, big, [r16]),
     153 = highest_opcode(DataDir, big, [r17]),
     153 = highest_opcode(DataDir, big, [r18]),
@@ -1478,9 +1480,10 @@ bc_options(Config) ->
     158 = highest_opcode(DataDir, small_maps, [r17]),
     158 = highest_opcode(DataDir, small_maps, [r18]),
     158 = highest_opcode(DataDir, small_maps, [r19]),
+    158 = highest_opcode(DataDir, small_maps, [r20]),
     158 = highest_opcode(DataDir, small_maps, []),
 
-    159 = highest_opcode(DataDir, big, []),
+    163 = highest_opcode(DataDir, big, []),
 
     ok.
 
diff --git a/lib/compiler/test/compile_SUITE_data/big.erl b/lib/compiler/test/compile_SUITE_data/big.erl
index 2e54ee8660..1db07755a1 100644
--- a/lib/compiler/test/compile_SUITE_data/big.erl
+++ b/lib/compiler/test/compile_SUITE_data/big.erl
@@ -741,3 +741,7 @@ snmp_access(suite) ->
 debug_support(suite) ->
     [  info, schema, schema, kill, lkill ].
 
+%% Cover translation of get_hd/2 to get_list/3 when option no_get_hd_tl
+%% is given.
+cover_get_hd([Hd|_]) ->
+    Hd.
diff --git a/lib/hipe/icode/hipe_beam_to_icode.erl b/lib/hipe/icode/hipe_beam_to_icode.erl
index 6e66ec057c..f429d40272 100644
--- a/lib/hipe/icode/hipe_beam_to_icode.erl
+++ b/lib/hipe/icode/hipe_beam_to_icode.erl
@@ -605,6 +605,16 @@ trans_fun([{get_list,List,Head,Tail}|Instructions], Env) ->
       ?error_msg("hd and tl regs identical in get_list~n",[]),
       erlang:error(not_handled)
   end;
+%%--- get_hd ---
+trans_fun([{get_hd,List,Head}|Instructions], Env) ->
+  TransList = [trans_arg(List)],
+  I = hipe_icode:mk_primop([mk_var(Head)],unsafe_hd,TransList),
+  [I | trans_fun(Instructions,Env)];
+%%--- get_tl ---
+trans_fun([{get_tl,List,Tail}|Instructions], Env) ->
+  TransList = [trans_arg(List)],
+  I = hipe_icode:mk_primop([mk_var(Tail)],unsafe_tl,TransList),
+  [I | trans_fun(Instructions,Env)];
 %%--- get_tuple_element ---
 trans_fun([{get_tuple_element,Xreg,Index,Dst}|Instructions], Env) ->
   I = hipe_icode:mk_primop([mk_var(Dst)],