The R13B03 release.OTP_R13B03

1 files changed, 153 insertions, 0 deletions

diff --git a/lib/hipe/cerl/cerl_hybrid_transform.erl b/lib/hipe/cerl/cerl_hybrid_transform.erl
new file mode 100644
index 0000000000..b248b0ccd0
--- /dev/null
+++ b/lib/hipe/cerl/cerl_hybrid_transform.erl
@@ -0,0 +1,153 @@
+%%
+%% %CopyrightBegin%
+%% 
+%% Copyright Ericsson AB 2004-2009. 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(cerl_hybrid_transform).
+
+%% Use compile option `{core_transform, cerl_hybrid_transform}' to
+%% insert this as a compilation pass.
+
+-export([transform/2, core_transform/2]).
+
+-spec core_transform(cerl:cerl(), [term()]) -> cerl:cerl().
+
+core_transform(Code, Opts) ->
+    cerl:to_records(transform(cerl:from_records(Code), Opts)).
+
+-spec transform(cerl:cerl(), [term()]) -> cerl:cerl().
+
+transform(Code, _Opts) ->
+    Code0 = cerl_trees:map(fun unfold_literal/1, Code),
+    {Code1, _} = cerl_trees:label(Code0),
+    io:fwrite("Running hybrid heap analysis..."),
+    {T1,_} = statistics(runtime),
+    {Code2, _, Vars} = cerl_messagean:annotate(Code1),
+    {T2,_} = statistics(runtime),
+    io:fwrite("(~w ms), transform...", [T2 - T1]),
+    Code3 = rewrite(Code2, Vars),
+    io:fwrite("done.\n"),
+    cerl_trees:map(fun fold_literal/1, Code3).
+
+unfold_literal(T) ->
+    cerl:unfold_literal(T).
+
+fold_literal(T) ->
+    cerl:fold_literal(T).
+
+%% If escape-annotated:
+%% {...} => hybrid:tuple([...])
+%% [H | T] => hybrid:cons(H, T)
+%%
+%% Wrapper for args to hybrid:cons/hybrid:tuple that may need copying:
+%% hybrid:copy(A)
+
+rewrite(Node, Vars) ->
+    case cerl:type(Node) of
+	tuple ->
+	    Es = rewrite_list(cerl:tuple_es(Node), Vars),
+	    case is_escaping(Node) of
+		false ->
+		    cerl:update_c_tuple(Node, Es);
+		true ->
+		    Es1 = wrap(Es, Node, Vars),
+		    cerl:update_c_call(Node,
+				       cerl:abstract(hybrid),
+				       cerl:abstract(tuple),
+				       [cerl:make_list(Es1)])
+%%% 		    cerl:update_c_call(Node, cerl:abstract(hybrid),
+%%% 				       cerl:abstract(tuple), Es1)
+	    end;
+	cons ->
+	    H = rewrite(cerl:cons_hd(Node), Vars),
+	    T = rewrite(cerl:cons_tl(Node), Vars),
+	    case is_escaping(Node) of
+		false ->
+		    cerl:update_c_cons(Node, H, T);
+		true ->
+		    Es = wrap([H, T], Node, Vars),
+		    cerl:update_c_call(Node,
+				       cerl:abstract(hybrid),
+				       cerl:abstract(cons),
+				       Es)
+	    end;
+%%% 	call ->
+%%% 	    M = rewrite(cerl:call_module(Node)),
+%%% 	    F = rewrite(cerl:call_name(Node)),
+%%% 	    As = rewrite_list(cerl:call_args(Node)),
+%%% 	    case cerl:is_c_atom(M) andalso cerl:is_c_atom(F) of
+%%% 		true ->
+%%% 		    case {cerl:atom_val(M), cerl:atom_val(F), length(As)} of
+%%% 			{erlang, '!', 2} ->
+%%% 			    cerl:update_c_call(Node,
+%%% 					       cerl:abstract(hipe_bifs),
+%%% 					       cerl:abstract(send),
+%%% 					       [cerl:make_list(As)]);
+%%% 			_ ->
+%%% 			    cerl:update_c_call(Node, M, F, As)
+%%% 		    end;
+%%% 		false ->
+%%% 		    cerl:update_c_call(Node, M, F, As)
+%%% 	    end;
+	clause ->
+	    B = rewrite(cerl:clause_body(Node), Vars),
+	    cerl:update_c_clause(Node, cerl:clause_pats(Node),
+				 cerl:clause_guard(Node), B);
+	primop ->
+	    case cerl:atom_val(cerl:primop_name(Node)) of
+		match_fail ->
+		    Node;
+		_ ->
+		    As = rewrite_list(cerl:primop_args(Node), Vars),
+		    cerl:update_c_primop(Node, cerl:primop_name(Node), As)
+	    end;
+	_T ->
+	    case cerl:subtrees(Node) of
+		[] ->
+		    Node;
+		Gs ->
+		    cerl:update_tree(Node, [rewrite_list(Ns, Vars)
+					    || Ns <- Gs])
+	    end
+    end.
+
+rewrite_list([N | Ns], Vars) ->
+    [rewrite(N, Vars) | rewrite_list(Ns, Vars)];
+rewrite_list([], _) ->
+    [].
+
+is_escaping(T) ->
+    lists:member(escapes, cerl:get_ann(T)).
+
+wrap(Es, Node, Vars) ->
+    L = cerl_trees:get_label(Node),
+    Xs = dict:fetch(L, Vars),
+    wrap(Es, Xs).
+
+wrap([E | Es], [{S, _} | Xs]) ->
+    case ordsets:is_element(unsafe, S) of
+%%  case cerl:type(E) =/= literal of
+	true ->
+	    [cerl:c_call(cerl:abstract(hybrid),
+			 cerl:abstract(copy),
+			 [E])
+	     | wrap(Es, Xs)];
+	false ->
+	    [E | wrap(Es, Xs)]
+    end;
+wrap([], _) ->
+    [].