1%%
2%% %CopyrightBegin%
3%%
4%% Copyright Ericsson AB 2011-2020. All Rights Reserved.
5%%
6%% Licensed under the Apache License, Version 2.0 (the "License");
7%% you may not use this file except in compliance with the License.
8%% You may obtain a copy of the License at
9%%
10%%     http://www.apache.org/licenses/LICENSE-2.0
11%%
12%% Unless required by applicable law or agreed to in writing, software
13%% distributed under the License is distributed on an "AS IS" BASIS,
14%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
15%% See the License for the specific language governing permissions and
16%% limitations under the License.
17%%
18%% %CopyrightEnd%
19%%
20
21-module(beam_except).
22-export([module/2]).
23
24%%% Rewrite certain calls to erlang:error/{1,2} to specialized
25%%% instructions:
26%%%
27%%% erlang:error({badmatch,Value})       => badmatch Value
28%%% erlang:error({case_clause,Value})    => case_end Value
29%%% erlang:error({try_clause,Value})     => try_case_end Value
30%%% erlang:error(if_clause)              => if_end
31%%% erlang:error(function_clause, Args)  => jump FuncInfoLabel
32%%%
33
34-import(lists, [reverse/1,reverse/2,seq/2,splitwith/2]).
35
36-spec module(beam_utils:module_code(), [compile:option()]) ->
37                    {'ok',beam_utils:module_code()}.
38
39module({Mod,Exp,Attr,Fs0,Lc}, _Opt) ->
40    Fs = [function(F) || F <- Fs0],
41    {ok,{Mod,Exp,Attr,Fs,Lc}}.
42
43function({function,Name,Arity,CLabel,Is0}) ->
44    try
45	Is = function_1(Is0),
46	{function,Name,Arity,CLabel,Is}
47    catch
48        Class:Error:Stack ->
49	    io:fwrite("Function: ~w/~w\n", [Name,Arity]),
50	    erlang:raise(Class, Error, Stack)
51    end.
52
53-record(st,
54	{lbl :: beam_asm:label(),              %func_info label
55	 loc :: [_],                           %location for func_info
56	 arity :: arity()                      %arity for function
57	 }).
58
59function_1(Is0) ->
60    case Is0 of
61	[{label,Lbl},{line,Loc},{func_info,_,_,Arity}|_] ->
62	    St = #st{lbl=Lbl,loc=Loc,arity=Arity},
63	    translate(Is0, St, []);
64	[{label,_}|_] ->
65	    %% No line numbers. The source must be a .S file.
66	    %% There is no need to do anything.
67	    Is0
68    end.
69
70translate([{call_ext,Ar,{extfunc,erlang,error,Ar}}=I|Is], St, Acc) ->
71    translate_1(Ar, I, Is, St, Acc);
72translate([I|Is], St, Acc) ->
73    translate(Is, St, [I|Acc]);
74translate([], _, Acc) ->
75    reverse(Acc).
76
77translate_1(Ar, I, Is, #st{arity=Arity}=St, [{line,_}=Line|Acc1]=Acc0) ->
78    case dig_out(Ar, Arity, Acc1) of
79	no ->
80	    translate(Is, St, [I|Acc0]);
81	{yes,function_clause,Acc2} ->
82	    case {Is,Line,St} of
83		{[return|_],{line,Loc},#st{lbl=Fi,loc=Loc}} ->
84		    Instr = {jump,{f,Fi}},
85		    translate(Is, St, [Instr|Acc2]);
86		{_,_,_} ->
87                    %% Not a call_only instruction, or not the same
88                    %% location information as in in the line instruction
89                    %% before the func_info instruction. Not safe
90                    %% to translate to a jump.
91		    translate(Is, St, [I|Acc0])
92	    end;
93	{yes,Instr,Acc2} ->
94	    translate(Is, St, [Instr,Line|Acc2])
95    end.
96
97dig_out(1, _Arity, Is) ->
98    dig_out(Is);
99dig_out(2, Arity, Is) ->
100    dig_out_fc(Arity, Is);
101dig_out(_, _, _) -> no.
102
103dig_out([{block,Bl0}|Is]) ->
104    case dig_out_block(reverse(Bl0)) of
105	no -> no;
106	{yes,What,[]} ->
107	    {yes,What,Is};
108	{yes,What,Bl} ->
109	    {yes,What,[{block,Bl}|Is]}
110    end;
111dig_out(_) -> no.
112
113dig_out_block([{set,[{x,0}],[{atom,if_clause}],move}]) ->
114    {yes,if_end,[]};
115dig_out_block([{set,[{x,0}],[{literal,{Exc,Value}}],move}|Is]) ->
116    translate_exception(Exc, {literal,Value}, Is, 0);
117dig_out_block([{set,[{x,0}],[{atom,Exc},Value],put_tuple2}|Is]) ->
118    translate_exception(Exc, Value, Is, 3);
119dig_out_block(_) -> no.
120
121translate_exception(badmatch, Val, Is, Words) ->
122    {yes,{badmatch,Val},fix_block(Is, Words)};
123translate_exception(case_clause, Val, Is, Words) ->
124    {yes,{case_end,Val},fix_block(Is, Words)};
125translate_exception(try_clause, Val, Is, Words) ->
126    {yes,{try_case_end,Val},fix_block(Is, Words)};
127translate_exception(_, _, _, _) -> no.
128
129fix_block(Is, 0) ->
130    reverse(Is);
131fix_block(Is, Words) ->
132    reverse(fix_block_1(Is, Words)).
133
134fix_block_1([{set,[],[],{alloc,Live,{F1,F2,Needed0,F3}}}|Is], Words)
135  when is_integer(Needed0) ->
136    case Needed0 - Words of
137        0 ->
138            Is;
139        Needed ->
140            true = Needed >= 0,				%Assertion.
141            [{set,[],[],{alloc,Live,{F1,F2,Needed,F3}}}|Is]
142    end;
143fix_block_1([I|Is], Words) ->
144    [I|fix_block_1(Is, Words)];
145fix_block_1([], _Words) ->
146    %% Rare. The heap allocation was probably done by a binary
147    %% construction instruction.
148    [].
149
150dig_out_fc(Arity, Is0) ->
151    Regs0 = maps:from_list([{{x,X},{arg,X}} || X <- seq(0, Arity-1)]),
152    {Is,Acc0} = splitwith(fun({label,_}) -> false;
153                             ({test,_,_,_}) -> false;
154                             (_) -> true
155                          end, Is0),
156    {Regs,Acc} = dig_out_fc_1(reverse(Is), Arity, Regs0, Acc0),
157    case Regs of
158        #{{x,0}:={atom,function_clause},{x,1}:=Args} ->
159            case moves_from_stack(Args, 0, []) of
160                {Moves,Arity} ->
161                    {yes,function_clause,reverse(Moves, Acc)};
162                {_,_} ->
163                    no
164            end;
165        #{} ->
166            no
167    end.
168
169dig_out_fc_1([{block,Bl}|Is], Arity, Regs0, Acc) ->
170    Regs = dig_out_fc_block(Bl, Regs0),
171    dig_out_fc_1(Is, Arity, Regs, Acc);
172dig_out_fc_1([{bs_set_position,_,_}=I|Is], Arity, Regs, Acc) ->
173    dig_out_fc_1(Is, Arity, Regs, [I|Acc]);
174dig_out_fc_1([{bs_get_tail,Src,Dst,Live0}|Is], Arity, Regs0, Acc) ->
175    case Src of
176        {x,X} when X < Arity ->
177            %% The heuristic for determining the number of live
178            %% registers is likely to give an incorrect result.
179            %% Give up.
180            {#{},[]};
181        _ ->
182            Regs = prune_xregs(Live0, Regs0),
183            Live = dig_out_stack_live(Regs, Live0),
184            I = {bs_get_tail,Src,Dst,Live},
185            dig_out_fc_1(Is, Arity, Regs, [I|Acc])
186    end;
187dig_out_fc_1([_|_], _Arity, _Regs, _Acc) ->
188    {#{},[]};
189dig_out_fc_1([], _Arity, Regs, Acc) ->
190    {Regs,Acc}.
191
192dig_out_fc_block([{set,[],[],{alloc,Live,_}}|Is], Regs0) ->
193    Regs = prune_xregs(Live, Regs0),
194    dig_out_fc_block(Is, Regs);
195dig_out_fc_block([{set,[Dst],[Hd,Tl],put_list}|Is], Regs0) ->
196    Regs = Regs0#{Dst=>{cons,get_reg(Hd, Regs0),get_reg(Tl, Regs0)}},
197    dig_out_fc_block(Is, Regs);
198dig_out_fc_block([{set,[Dst],[Src],move}|Is], Regs0) ->
199    Regs = Regs0#{Dst=>get_reg(Src, Regs0)},
200    dig_out_fc_block(Is, Regs);
201dig_out_fc_block([{set,_,_,_}|_], _Regs) ->
202    %% Unknown instruction. Fail.
203    #{};
204dig_out_fc_block([], Regs) -> Regs.
205
206dig_out_stack_live(Regs, Default) ->
207    Reg = {x,2},
208    case Regs of
209        #{Reg:=List} ->
210            dig_out_stack_live_1(List, Default);
211        #{} ->
212            Default
213    end.
214
215dig_out_stack_live_1({cons,{arg,N},T}, Live) ->
216    dig_out_stack_live_1(T, max(N + 1, Live));
217dig_out_stack_live_1({cons,_,T}, Live) ->
218    dig_out_stack_live_1(T, Live);
219dig_out_stack_live_1(nil, Live) ->
220    Live;
221dig_out_stack_live_1(_, Live) -> Live.
222
223prune_xregs(Live, Regs) ->
224    maps:filter(fun({x,X}, _) -> X < Live end, Regs).
225
226moves_from_stack({cons,{arg,N},_}, I, _Acc) when N =/= I ->
227    %% Wrong argument. Give up.
228    {[],-1};
229moves_from_stack({cons,H,T}, I, Acc) ->
230    case H of
231        {arg,I} ->
232            moves_from_stack(T, I+1, Acc);
233        _ ->
234            moves_from_stack(T, I+1, [{move,H,{x,I}}|Acc])
235    end;
236moves_from_stack(nil, I, Acc) ->
237    {reverse(Acc),I};
238moves_from_stack({literal,[H|T]}, I, Acc) ->
239    Cons = {cons,tag_literal(H),tag_literal(T)},
240    moves_from_stack(Cons, I, Acc);
241moves_from_stack(_, _, _) ->
242    %% Not understood. Give up.
243    {[],-1}.
244
245
246get_reg(R, Regs) ->
247    case Regs of
248        #{R:=Val} -> Val;
249        #{} -> R
250    end.
251
252tag_literal([]) -> nil;
253tag_literal(T) when is_atom(T) -> {atom,T};
254tag_literal(T) when is_float(T) -> {float,T};
255tag_literal(T) when is_integer(T) -> {integer,T};
256tag_literal(T) -> {literal,T}.
257