Add the beam_except pass to optimize exceptions

In order to save space, rewrite suitable calls to erlang:error/{1,2}
to special BEAM instructions.

This code is probably longer than the code taken out of v3_life and
v3_codegen in the previous commit, but it is much easier to
understand and maintain since the BEAM assembler format is better
understood than the v3_life format.

7 files changed, 240 insertions, 2 deletions

diff --git a/lib/compiler/src/Makefile b/lib/compiler/src/Makefile
index 7a237608ad..3415517fff 100644
--- a/lib/compiler/src/Makefile
+++ b/lib/compiler/src/Makefile
@@ -53,6 +53,7 @@ MODULES =  \
 	beam_dead \
 	beam_dict \
 	beam_disasm \
+	beam_except \
 	beam_flatten \
 	beam_jump \
 	beam_listing \
diff --git a/lib/compiler/src/beam_except.erl b/lib/compiler/src/beam_except.erl
new file mode 100644
index 0000000000..fb1a43cd9e
--- /dev/null
+++ b/lib/compiler/src/beam_except.erl
@@ -0,0 +1,149 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2011. 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%
+%%
+
+-module(beam_except).
+-export([module/2]).
+
+%%% Rewrite certain calls to erlang:error/{1,2} to specialized
+%%% instructions:
+%%%
+%%% erlang:error({badmatch,Value})       => badmatch Value
+%%% erlang:error({case_clause,Value})    => case_end Value
+%%% erlang:error({try_clause,Value})     => try_case_end Value
+%%% erlang:error(if_clause)              => if_end
+%%% erlang:error(function_clause, Args)  => jump FuncInfoLabel
+%%%
+
+-import(lists, [reverse/1]).
+
+module({Mod,Exp,Attr,Fs0,Lc}, _Opt) ->
+    Fs = [function(F) || F <- Fs0],
+    {ok,{Mod,Exp,Attr,Fs,Lc}}.
+
+function({function,Name,Arity,CLabel,Is0}) ->
+    try
+	Is = function_1(Is0),
+	{function,Name,Arity,CLabel,Is}
+    catch
+	Class:Error ->
+	    Stack = erlang:get_stacktrace(),
+	    io:fwrite("Function: ~w/~w\n", [Name,Arity]),
+	    erlang:raise(Class, Error, Stack)
+    end.
+
+-record(st,
+	{lbl,					%func_info label
+	 loc					%location for func_info
+	 }).
+
+function_1(Is0) ->
+    case Is0 of
+	[{label,Lbl},{line,Loc}|_] ->
+	    St = #st{lbl=Lbl,loc=Loc},
+	    translate(Is0, St, []);
+	[{label,_}|_] ->
+	    %% No line numbers. The source must be a .S file.
+	    %% There is no need to do anything.
+	    Is0
+    end.
+
+translate([{call_ext,Ar,{extfunc,erlang,error,Ar}}=I|Is], St, Acc) ->
+    translate_1(Ar, I, Is, St, Acc);
+translate([{call_ext_only,Ar,{extfunc,erlang,error,Ar}}=I|Is], St, Acc) ->
+    translate_1(Ar, I, Is, St, Acc);
+translate([{call_ext_last,Ar,{extfunc,erlang,error,Ar},_}=I|Is], St, Acc) ->
+    translate_1(Ar, I, Is, St, Acc);
+translate([I|Is], St, Acc) ->
+    translate(Is, St, [I|Acc]);
+translate([], _, Acc) ->
+    reverse(Acc).
+
+translate_1(Ar, I, Is, St, [{line,_}=Line|Acc1]=Acc0) ->
+    case dig_out(Ar, Acc1) of
+	no ->
+	    translate(Is, St, [I|Acc0]);
+	{yes,function_clause,Acc2} ->
+	    case {Line,St} of
+		{{line,Loc},#st{lbl=Fi,loc=Loc}} ->
+		    Instr = {jump,{f,Fi}},
+		    translate(Is, St, [Instr|Acc2]);
+		{_,_} ->
+		    %% This must be "error(function_clause, Args)" in
+		    %% the Erlang source code. Don't translate.
+		    translate(Is, St, [I|Acc0])
+	    end;
+	{yes,Instr,Acc2} ->
+	    translate(Is, St, [Instr,Line|Acc2])
+    end.
+
+dig_out(Ar, [{kill,_}|Is]) ->
+    dig_out(Ar, Is);
+dig_out(1, [{block,Bl0}|Is]) ->
+    case dig_out_block(reverse(Bl0)) of
+	no -> no;
+	{yes,What,[]} ->
+	    {yes,What,Is};
+	{yes,What,Bl} ->
+	    {yes,What,[{block,Bl}|Is]}
+    end;
+dig_out(2, [{block,Bl}|Is]) ->
+    case dig_out_block_fc(Bl) of
+	no -> no;
+	{yes,What} -> {yes,What,Is}
+    end;
+dig_out(_, _) -> no.
+
+dig_out_block([{set,[{x,0}],[{atom,if_clause}],move}]) ->
+    {yes,if_end,[]};
+dig_out_block([{set,[{x,0}],[{literal,{Exc,Value}}],move}|Is]) ->
+    translate_exception(Exc, {literal,Value}, Is, 0);
+dig_out_block([{set,[{x,0}],[Tuple],move},
+	       {set,[],[Value],put},
+	       {set,[],[{atom,Exc}],put},
+	       {set,[Tuple],[],{put_tuple,2}}|Is]) ->
+    translate_exception(Exc, Value, Is, 3);
+dig_out_block([{set,[],[Value],put},
+	       {set,[],[{atom,Exc}],put},
+	       {set,[{x,0}],[],{put_tuple,2}}|Is]) ->
+    translate_exception(Exc, Value, Is, 3);
+dig_out_block(_) -> no.
+
+translate_exception(badmatch, Val, Is, Words) ->
+    {yes,{badmatch,Val},fix_block(Is, Words)};
+translate_exception(case_clause, Val, Is, Words) ->
+    {yes,{case_end,Val},fix_block(Is, Words)};
+translate_exception(try_clause, Val, Is, Words) ->
+    {yes,{try_case_end,Val},fix_block(Is, Words)};
+translate_exception(_, _, _, _) -> no.
+
+fix_block(Is, 0) ->
+    reverse(Is);
+fix_block(Is0, Words) ->
+    [{set,[],[],{alloc,Live,{F1,F2,Needed,F3}}}|Is] = reverse(Is0),
+    [{set,[],[],{alloc,Live,{F1,F2,Needed-Words,F3}}}|Is].
+
+dig_out_block_fc([{set,[],[],{alloc,Live,_}}|Bl]) ->
+    dig_out_fc(Bl, Live-1, nil);
+dig_out_block_fc(_) -> no.
+
+dig_out_fc([{set,[Dst],[{x,Reg},Dst0],put_list}|Is], Reg, Dst0) ->
+    dig_out_fc(Is, Reg-1, Dst);
+dig_out_fc([{set,[{x,0}],[{atom,function_clause}],move}], -1, {x,1}) ->
+    {yes,function_clause};
+dig_out_fc(_, _, _) -> no.
diff --git a/lib/compiler/src/compile.erl b/lib/compiler/src/compile.erl
index a17a10046e..9b505ad15c 100644
--- a/lib/compiler/src/compile.erl
+++ b/lib/compiler/src/compile.erl
@@ -629,6 +629,8 @@ asm_passes() ->
       [{unless,no_postopt,
 	[{pass,beam_block},
 	 {iff,dblk,{listing,"block"}},
+	 {unless,no_except,{pass,beam_except}},
+	 {iff,dexcept,{listing,"except"}},
 	 {unless,no_bopt,{pass,beam_bool}},
 	 {iff,dbool,{listing,"bool"}},
 	 {unless,no_topt,{pass,beam_type}},
diff --git a/lib/compiler/src/compiler.app.src b/lib/compiler/src/compiler.app.src
index fb06f2521c..1133882728 100644
--- a/lib/compiler/src/compiler.app.src
+++ b/lib/compiler/src/compiler.app.src
@@ -28,6 +28,7 @@
 	     beam_dead,
 	     beam_dict,
 	     beam_disasm,
+	     beam_except,
 	     beam_flatten,
 	     beam_jump,
 	     beam_listing,
diff --git a/lib/compiler/test/Makefile b/lib/compiler/test/Makefile
index b90adaf917..2ea50b9112 100644
--- a/lib/compiler/test/Makefile
+++ b/lib/compiler/test/Makefile
@@ -10,6 +10,7 @@ MODULES= \
 	apply_SUITE \
 	beam_validator_SUITE \
 	beam_disasm_SUITE \
+	beam_expect_SUITE \
 	bs_bincomp_SUITE \
 	bs_bit_binaries_SUITE \
 	bs_construct_SUITE \
@@ -39,6 +40,7 @@ MODULES= \
 NO_OPT= \
 	andor \
 	apply \
+	beam_expect \
 	bs_construct \
         bs_match \
 	bs_utf \
diff --git a/lib/compiler/test/beam_expect_SUITE.erl b/lib/compiler/test/beam_expect_SUITE.erl
new file mode 100644
index 0000000000..6f216eac4f
--- /dev/null
+++ b/lib/compiler/test/beam_expect_SUITE.erl
@@ -0,0 +1,67 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2011. 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%
+%%
+-module(beam_expect_SUITE).
+
+-export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1,
+	 init_per_group/2,end_per_group/2,
+	 coverage/1]).
+
+suite() -> [{ct_hooks,[ts_install_cth]}].
+
+all() ->
+    [coverage].
+
+groups() ->
+    [].
+
+init_per_suite(Config) ->
+    Config.
+
+end_per_suite(_Config) ->
+    ok.
+
+init_per_group(_GroupName, Config) ->
+    Config.
+
+end_per_group(_GroupName, Config) ->
+    Config.
+
+coverage(_) ->
+    File = {file,"fake.erl"},
+    ok = fc(a),
+    {'EXIT',{function_clause,
+	     [{?MODULE,fc,[[x]],[File,{line,2}]}|_]}} =
+	(catch fc([x])),
+    {'EXIT',{function_clause,
+	     [{?MODULE,fc,[y],[File,{line,2}]}|_]}} =
+	(catch fc(y)),
+    {'EXIT',{function_clause,
+	     [{?MODULE,fc,[[a,b,c]],[File,{line,6}]}|_]}} =
+	(catch fc([a,b,c])),
+
+    {'EXIT',{undef,[{erlang,error,[a,b,c],_}|_]}} =
+	(catch erlang:error(a, b, c)),
+    ok.
+
+-file("fake.erl", 1).
+fc(a) ->	                                %Line 2
+    ok;						%Line 3
+fc(L) when length(L) > 2 ->			%Line 4
+    %% Not the same as a "real" function_clause error.
+    error(function_clause, [L]).		%Line 6
diff --git a/lib/compiler/test/misc_SUITE.erl b/lib/compiler/test/misc_SUITE.erl
index 9b414cade6..5e13a93c52 100644
--- a/lib/compiler/test/misc_SUITE.erl
+++ b/lib/compiler/test/misc_SUITE.erl
@@ -190,6 +190,15 @@ silly_coverage(Config) when is_list(Config) ->
 		     {label,2}|non_proper_list]}],99},
     ?line expect_error(fun() -> beam_block:module(BlockInput, []) end),
 
+    %% beam_except
+    ExceptInput = {?MODULE,[{foo,0}],[],
+		   [{function,foo,0,2,
+		     [{label,1},
+		      {line,loc},
+		      {func_info,{atom,?MODULE},{atom,foo},0},
+		      {label,2}|non_proper_list]}],99},
+    expect_error(fun() -> beam_except:module(ExceptInput, []) end),
+
     %% beam_bool
     BoolInput = {?MODULE,[{foo,0}],[],
 		  [{function,foo,0,2,
@@ -253,8 +262,15 @@ expect_error(Fun) ->
 	    io:format("~p", [Any]),
 	    ?t:fail(call_was_supposed_to_fail)
     catch
-	_:_ ->
-	    io:format("~p\n", [erlang:get_stacktrace()])
+	Class:Reason ->
+	    Stk = erlang:get_stacktrace(),
+	    io:format("~p:~p\n~p\n", [Class,Reason,Stk]),
+	    case {Class,Reason} of
+		{error,undef} ->
+		    ?t:fail(not_supposed_to_fail_with_undef);
+		{_,_} ->
+		    ok
+	    end
     end.
 
 confused_literals(Config) when is_list(Config) ->