aboutsummaryrefslogtreecommitdiffstats
path: root/lib/hipe/cerl/cerl_cconv.erl
diff options
context:
space:
mode:
authorErlang/OTP <[email protected]>2009-11-20 14:54:40 +0000
committerErlang/OTP <[email protected]>2009-11-20 14:54:40 +0000
commit84adefa331c4159d432d22840663c38f155cd4c1 (patch)
treebff9a9c66adda4df2106dfd0e5c053ab182a12bd /lib/hipe/cerl/cerl_cconv.erl
downloadotp-84adefa331c4159d432d22840663c38f155cd4c1.tar.gz
otp-84adefa331c4159d432d22840663c38f155cd4c1.tar.bz2
otp-84adefa331c4159d432d22840663c38f155cd4c1.zip
The R13B03 release.OTP_R13B03
Diffstat (limited to 'lib/hipe/cerl/cerl_cconv.erl')
-rw-r--r--lib/hipe/cerl/cerl_cconv.erl777
1 files changed, 777 insertions, 0 deletions
diff --git a/lib/hipe/cerl/cerl_cconv.erl b/lib/hipe/cerl/cerl_cconv.erl
new file mode 100644
index 0000000000..cf4d317b0d
--- /dev/null
+++ b/lib/hipe/cerl/cerl_cconv.erl
@@ -0,0 +1,777 @@
+%%
+%% %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%
+%%
+%% @author Richard Carlsson <[email protected]>
+%% @copyright 2000-2004 Richard Carlsson
+%% @doc Closure conversion of Core Erlang modules. This is done as a
+%% step in the translation from Core Erlang down to HiPE Icode, and is
+%% very much tied to the calling conventions used in HiPE native code.
+%% @see cerl_to_icode
+
+%% Some information about function closures in Beam and HiPE:
+%%
+%% - In Beam, each fun-expression is lifted to a top-level function such
+%% that the arity of the new function is equal to the arity of the fun
+%% *plus* the number of free variables. The original fun-expression is
+%% replaced by a call to 'make_fun' which takes the *label* of the new
+%% function and the number of free variables as arguments (the arity
+%% of the fun can be found via the label). When a call is made through
+%% the closure, the free variables are extracted from the closure by
+%% the 'call_fun' operation and are placed in the X registers
+%% following the ones used for the normal parameters; then the call is
+%% made to the function label.
+%%
+%% - In HiPE (when compiling from Beam bytecode), the Beam-to-Icode
+%% translation rewrites the fun-functions (those referenced by
+%% 'make_fun' operations) so that the code expects only the normal
+%% parameters, plus *one* extra parameter containing the closure
+%% itself, and then immediately extracts the free variables from the
+%% closure - the code knows how many free variables it expects.
+%% However, the arity part of the function name is *not* changed;
+%% thus, the native code and the Beam code still use the same
+%% fun-table entry. The arity value used in native-code 'make_fun'
+%% operations should therefore be the same as in Beam, i.e., the sum
+%% of the number of parameters and the number of free variables.
+
+-module(cerl_cconv).
+
+-export([transform/2]).
+-export([core_transform/2]).
+
+-include("cerl_hipe_primops.hrl").
+
+%% A descriptor for top-level and letrec-bound functions. (Top-level
+%% functions always have an empty list of free variables.) The 'name'
+%% field is the name of the lifted function, and is thus unique over the
+%% whole module.
+
+-record(function, {name :: {atom(), arity()}, free}).
+
+%% A record for holding fun-information (if such information is attached
+%% as an annotation on a fun, it should preferably be preserved).
+
+-record(fun_info, {name :: atom(),
+ id = 0 :: integer(),
+ hash = 0 :: integer()}).
+
+%% @spec core_transform(Module::cerl_records(), Options::[term()]) ->
+%% cerl_records()
+%%
+%% @doc Transforms a module represented by records. See
+%% <code>transform/2</code> for details.
+%%
+%% <p>Use the compiler option <code>{core_transform, cerl_cconv}</code>
+%% to insert this function as a compilation pass.</p>
+%%
+%% @see transform/2
+
+-spec core_transform(cerl:cerl(), [term()]) -> cerl:cerl().
+
+core_transform(M, Opts) ->
+ cerl:to_records(transform(cerl:from_records(M), Opts)).
+
+
+%% @spec transform(Module::cerl(), Options::[term()]) -> cerl()
+%%
+%% cerl() = cerl:cerl()
+%%
+%% @doc Rewrites a Core Erlang module so that all fun-expressions
+%% (lambda expressions) in the code are in top level function
+%% definitions, and the operators of all `apply'-expressions are names
+%% of such top-level functions. The primitive operations `make_fun' and
+%% `call_fun' are inserted in the code to create and apply functional
+%% values; this transformation is known as "Closure Conversion"
+%%
+%% <p>See the module {@link cerl_to_icode} for details.</p>
+
+-spec transform(cerl:c_module(), [term()]) -> cerl:c_module().
+
+transform(E, _Options) ->
+ M = cerl:module_name(E),
+ S0 = s__new(cerl:atom_val(M)),
+ {Defs1, S1} = module_defs(cerl:module_defs(E), env__new(),
+ ren__new(), S0),
+ Defs2 = lists:reverse(s__get_defs(S1) ++ Defs1),
+ cerl:update_c_module(E, M, cerl:module_exports(E),
+ cerl:module_attrs(E), Defs2).
+
+%% Note that the environment is defined on the renamed variables.
+
+expr(E, Env, Ren, S0) ->
+ case cerl:type(E) of
+ literal ->
+ {E, S0};
+ var ->
+ var(E, Env, Ren, S0);
+ values ->
+ {Es, S1} = expr_list(cerl:values_es(E), Env, Ren, S0),
+ {cerl:update_c_values(E, Es), S1};
+ cons ->
+ {E1, S1} = expr(cerl:cons_hd(E), Env, Ren, S0),
+ {E2, S2} = expr(cerl:cons_tl(E), Env, Ren, S1),
+ {cerl:update_c_cons(E, E1, E2), S2};
+ tuple ->
+ {Es, S1} = expr_list(cerl:tuple_es(E), Env, Ren, S0),
+ {cerl:update_c_tuple(E, Es), S1};
+ 'let' ->
+ {A, S1} = expr(cerl:let_arg(E), Env, Ren, S0),
+ Vs = cerl:let_vars(E),
+ {Vs1, Env1, Ren1} = bind_vars(Vs, Env, Ren),
+ {B, S2} = expr(cerl:let_body(E), Env1, Ren1, S1),
+ {cerl:update_c_let(E, Vs1, A, B), S2};
+ seq ->
+ {A, S1} = expr(cerl:seq_arg(E), Env, Ren, S0),
+ {B, S2} = expr(cerl:seq_body(E), Env, Ren, S1),
+ {cerl:update_c_seq(E, A, B), S2};
+ apply ->
+ apply_expr(E, Env, Ren, S0);
+ call ->
+ {M, S1} = expr(cerl:call_module(E), Env, Ren, S0),
+ {N, S2} = expr(cerl:call_name(E), Env, Ren, S1),
+ {As, S3} = expr_list(cerl:call_args(E), Env, Ren, S2),
+ {cerl:update_c_call(E, M, N, As), S3};
+ primop ->
+ {As, S1} = expr_list(cerl:primop_args(E), Env, Ren, S0),
+ N = cerl:primop_name(E),
+ {cerl:update_c_primop(E, N, As), S1};
+ 'case' ->
+ {A, S1} = expr(cerl:case_arg(E), Env, Ren, S0),
+ {Cs, S2} = expr_list(cerl:case_clauses(E), Env, Ren, S1),
+ {cerl:update_c_case(E, A, Cs), S2};
+ clause ->
+ Vs = cerl:clause_vars(E),
+ {_, Env1, Ren1} = bind_vars(Vs, Env, Ren),
+ %% Visit patterns to rename variables.
+ Ps = pattern_list(cerl:clause_pats(E), Env1, Ren1),
+ {G, S1} = expr(cerl:clause_guard(E), Env1, Ren1, S0),
+ {B, S2} = expr(cerl:clause_body(E), Env1, Ren1, S1),
+ {cerl:update_c_clause(E, Ps, G, B), S2};
+ 'fun' ->
+ fun_expr(E, Env, Ren, S0);
+ 'receive' ->
+ {Cs, S1} = expr_list(cerl:receive_clauses(E), Env, Ren, S0),
+ {T, S2} = expr(cerl:receive_timeout(E), Env, Ren, S1),
+ {A, S3} = expr(cerl:receive_action(E), Env, Ren, S2),
+ {cerl:update_c_receive(E, Cs, T, A), S3};
+ 'try' ->
+ {A, S1} = expr(cerl:try_arg(E), Env, Ren, S0),
+ Vs = cerl:try_vars(E),
+ {Vs1, Env1, Ren1} = bind_vars(Vs, Env, Ren),
+ {B, S2} = expr(cerl:try_body(E), Env1, Ren1, S1),
+ Evs = cerl:try_evars(E),
+ {Evs1, Env2, Ren2} = bind_vars(Evs, Env, Ren),
+ {H, S3} = expr(cerl:try_handler(E), Env2, Ren2, S2),
+ {cerl:update_c_try(E, A, Vs1, B, Evs1, H), S3};
+ 'catch' ->
+ {B, S1} = expr(cerl:catch_body(E), Env, Ren, S0),
+ {cerl:update_c_catch(E, B), S1};
+ letrec ->
+ {Env1, Ren1, S1} = letrec_defs(cerl:letrec_defs(E), Env,
+ Ren, S0),
+ expr(cerl:letrec_body(E), Env1, Ren1, S1);
+ binary ->
+ {Segs, S1} = expr_list(cerl:binary_segments(E), Env, Ren, S0),
+ {cerl:update_c_binary(E, Segs),S1};
+ bitstr ->
+ {E1,S1} = expr(cerl:bitstr_val(E), Env, Ren, S0),
+ {E2,S2} = expr(cerl:bitstr_size(E), Env, Ren, S1),
+ E3 = cerl:bitstr_unit(E),
+ E4 = cerl:bitstr_type(E),
+ E5 = cerl:bitstr_flags(E),
+ {cerl:update_c_bitstr(E, E1, E2, E3, E4, E5), S2}
+ end.
+
+expr_list([E | Es], Env, Ren, S0) ->
+ {E1, S1} = expr(E, Env, Ren, S0),
+ {Es1, S2} = expr_list(Es, Env, Ren, S1),
+ {[E1 | Es1], S2};
+expr_list([], _, _, S) ->
+ {[], S}.
+
+pattern(E, Env, Ren) ->
+ case cerl:type(E) of
+ literal ->
+ E;
+ var ->
+ cerl:update_c_var(E, ren__map(cerl:var_name(E), Ren));
+ values ->
+ Es = pattern_list(cerl:values_es(E), Env, Ren),
+ cerl:update_c_values(E, Es);
+ cons ->
+ E1 = pattern(cerl:cons_hd(E), Env, Ren),
+ E2 = pattern(cerl:cons_tl(E), Env, Ren),
+ cerl:update_c_cons(E, E1, E2);
+ tuple ->
+ Es = pattern_list(cerl:tuple_es(E), Env, Ren),
+ cerl:update_c_tuple(E, Es);
+ binary ->
+ Es = pattern_list(cerl:binary_segments(E), Env, Ren),
+ cerl:update_c_binary(E, Es);
+ bitstr ->
+ E1 = pattern(cerl:bitstr_val(E), Env, Ren),
+ E2 = pattern(cerl:bitstr_size(E), Env, Ren),
+ E3 = cerl:bitstr_unit(E),
+ E4 = cerl:bitstr_type(E),
+ E5 = cerl:bitstr_flags(E),
+ cerl:update_c_bitstr(E, E1, E2, E3, E4, E5);
+ alias ->
+ V = pattern(cerl:alias_var(E), Env, Ren),
+ P = pattern(cerl:alias_pat(E), Env, Ren),
+ cerl:update_c_alias(E, V, P)
+ end.
+
+pattern_list([E | Es], Env, Ren) ->
+ [pattern(E, Env, Ren) | pattern_list(Es, Env, Ren)];
+pattern_list([], _, _) ->
+ [].
+
+%% First we set up the environment, binding the function names to the
+%% corresponding descriptors. (For the top level functions, we don't
+%% want to cause renaming.) After that, we can visit each function body
+%% and return the new function definitions and the final state.
+
+module_defs(Ds, Env, Ren, S) ->
+ {Env1, S1} = bind_module_defs(Ds, Env, S),
+ module_defs_1(Ds, [], Env1, Ren, S1).
+
+bind_module_defs([{V, _F} | Ds], Env, S) ->
+ Name = cerl:var_name(V),
+ check_function_name(Name, S),
+ S1 = s__add_function_name(Name, S),
+ Info = #function{name = Name, free = []},
+ Env1 = env__bind(Name, Info, Env),
+ bind_module_defs(Ds, Env1, S1);
+bind_module_defs([], Env, S) ->
+ {Env, S}.
+
+%% Checking that top-level function names are not reused
+
+check_function_name(Name, S) ->
+ case s__is_function_name(Name, S) of
+ true ->
+ error_msg("multiple definitions of function `~w'.", [Name]),
+ exit(error);
+ false ->
+ ok
+ end.
+
+%% We must track which top-level function we are in, for name generation
+%% purposes.
+
+module_defs_1([{V, F} | Ds], Ds1, Env, Ren, S) ->
+ S1 = s__enter_function(cerl:var_name(V), S),
+ %% The parameters should never need renaming, but this is easiest.
+ {Vs, Env1, Ren1} = bind_vars(cerl:fun_vars(F), Env, Ren),
+ {B, S2} = expr(cerl:fun_body(F), Env1, Ren1, S1),
+ F1 = cerl:update_c_fun(F, Vs, B),
+ module_defs_1(Ds, [{V, F1} | Ds1], Env, Ren, S2);
+module_defs_1([], Ds, _, _, S) ->
+ {Ds, S}.
+
+%% First we must create the new function names and set up the
+%% environment with descriptors for the letrec-bound functions.
+%%
+%% Since we never shadow variables, the free variables of any
+%% letrec-bound fun can always be referenced directly wherever the
+%% fun-variable itself is referenced - this is important when we create
+%% direct calls to lifted letrec-bound functions, and is the main reason
+%% why we do renaming. For example:
+%%
+%% 'f'/0 = fun () ->
+%% let X = 42 in
+%% letrec 'g'/1 = fun (Y) -> {X, Y} in
+%% let X = 17 in
+%% apply 'g'/1(X)
+%%
+%% will become something like
+%%
+%% 'f'/0 = fun () ->
+%% let X = 42 in
+%% let X1 = 17 in
+%% apply 'g'/2(X1, X)
+%% 'g'/2 = fun (Y, X) -> {X, Y}
+%%
+%% where the innermost X has been renamed so that the outermost X can be
+%% referenced in the call to the lifted function 'g'/2. (Renaming must
+%% of course also be applied also to letrec-bound function variables.)
+%%
+%% Furthermore, if some variable X occurs free in a fun 'f'/N, and 'f'/N
+%% it its turn occurs free in a fun 'g'/M, then we transitively count X
+%% as free in 'g'/M, even if it has no occurrence there. This allows us
+%% to rewrite code such as the following:
+%%
+%% 'f'/0 = fun () ->
+%% let X = 42 in
+%% letrec 'g'/1 = fun (Y) -> {X, Y}
+%% 'h'/1 = fun (Z) -> {'bar', apply 'g'/1(Z)}
+%% in let X = 17 in
+%% apply 'h'/1(X)
+%%
+%% into something like:
+%%
+%% 'f'/0 = fun () ->
+%% let X = 42 in
+%% let X1 = 17 in
+%% apply 'h'/2(X1, X)
+%% 'g'/2 = fun (Y, X) -> {X, Y}
+%% 'h'/2 = fun (Z, X) -> {'bar', apply 'g'/2(Z, X)}
+%%
+%% which uses only direct calls. The drawback is that if the occurrence
+%% of 'f'/N in 'g'/M instead would cause a closure to be created, then
+%% that closure could have been formed earlier (at the point where 'f'/N
+%% was defined), rather than passing on all the free variables of 'f'/N
+%% into 'g'/M. Since we must know the interface to 'g'/M (i.e., the
+%% total number of parameters) before we begin processing its body, and
+%% the interface depends on what we do to the body (and functions can be
+%% mutually recursive), this problem can only be solved by finding out
+%% _what_ we are going to do before we can even define the interfaces of
+%% the functions, by looking at _how_ variables are being referenced
+%% when we look for free variables. Currently, we don't do that.
+
+letrec_defs(Ds, Env, Ren, S) ->
+ {Env1, Ren1, S1} = bind_letrec_defs(Ds, Env, Ren, S),
+ {Env1, Ren1, lift_letrec_defs(Ds, Env1, Ren1, S1)}.
+
+%% Note: it is important that we store the *renamed* free variables for
+%% each function to be lifted.
+
+bind_letrec_defs(Ds, Env, Ren, S) ->
+ bind_letrec_defs(Ds, free_in_defs(Ds, Env, Ren), Env, Ren, S).
+
+bind_letrec_defs([{V, _F} | Ds], Free, Env, Ren, S) ->
+ Name = cerl:var_name(V),
+ {Env1, Ren1, S1} = bind_letrec_fun(Name, Free, Env, Ren, S),
+ bind_letrec_defs(Ds, Free, Env1, Ren1, S1);
+bind_letrec_defs([], _Free, Env, Ren, S) ->
+ {Env, Ren, S}.
+
+bind_letrec_fun(Name = {_,A}, Free, Env, Ren, S) ->
+ A1 = A + length(Free),
+ {Name1, Ren1, S1} = rename_letrec_fun(Name, A1, Env, Ren, S),
+ Info = #function{name = Name1, free = Free},
+ {env__bind(Name1, Info, Env), Ren1, S1}.
+
+%% Creating a new name for the lifted function that is informative, is
+%% not in the environment, and is not already used for some other lifted
+%% function.
+
+rename_letrec_fun(Name, NewArity, Env, Ren, S) ->
+ {New, S1} = new_letrec_fun_name(Name, NewArity, Env, S),
+ {New, ren__add(Name, New, Ren), s__add_function_name(New, S1)}.
+
+new_letrec_fun_name({N,_}, Arity, Env, S) ->
+ {FName, FArity} = s__get_function(S),
+ Base = fun_name_base(FName, FArity)
+ ++ "-letrec-" ++ atom_to_list(N) ++ "-",
+ %% We try the base as name first. This will usually work.
+ Name = {list_to_atom(Base), Arity},
+ case env__is_defined(Name, Env) of
+ true ->
+ new_fun_name(Base, Arity, Env, S);
+ false ->
+ case s__is_function_name(Name, S) of
+ true ->
+ new_fun_name(Base, Arity, Env, S);
+ false ->
+ {Name, S}
+ end
+ end.
+
+%% Processing the actual functions of a letrec
+
+lift_letrec_defs([{V, F} | Ds], Env, Ren, S) ->
+ Info = env__get(ren__map(cerl:var_name(V), Ren), Env),
+ S1 = lift_letrec_fun(F, Info, Env, Ren, S),
+ lift_letrec_defs(Ds, Env, Ren, S1);
+lift_letrec_defs([], _, _, S) ->
+ S.
+
+%% The direct calling convention for letrec-defined functions is to pass
+%% the free variables as additional parameters. Note that the free
+%% variables (if any) are already in the environment when we get here.
+%% We only have to append them to the parameter list so that they are in
+%% scope in the lifted function; they are already renamed.
+%%
+%% It should not be possible for the original parameters to clash with
+%% the free ones (in that case they cannot be free), but we do the full
+%% bind-and-rename anyway, since it's easiest.
+
+lift_letrec_fun(F, Info, Env, Ren, S) ->
+ {Vs, Env1, Ren1} = bind_vars(cerl:fun_vars(F), Env, Ren),
+ {B, S1} = expr(cerl:fun_body(F), Env1, Ren1, S),
+ Fs = [cerl:c_var(V) || V <- Info#function.free],
+ F1 = cerl:c_fun(Vs ++ Fs, B),
+ s__add_def(cerl:c_var(Info#function.name), F1, S1).
+
+%% This is a simple way of handling mutual recursion in a group of
+%% letrec-definitions: classify a variable as free in all the functions
+%% if it is free in any of them. (The preferred way would be to actually
+%% take the transitive closure for each function.)
+
+free_in_defs(Ds, Env, Ren) ->
+ {Vs, Fs} = free_in_defs(Ds, [], [], Ren),
+ closure_vars(ordsets:subtract(Fs, Vs), Env, Ren).
+
+free_in_defs([{V, F} | Ds], Vs, Free, Ren) ->
+ Fs = cerl_trees:free_variables(F),
+ free_in_defs(Ds, [ren__map(cerl:var_name(V), Ren) | Vs], Fs ++ Free,
+ Ren);
+free_in_defs([], Vs, Free, _Ren) ->
+ {ordsets:from_list(Vs), ordsets:from_list(Free)}.
+
+%% Replacing function variables with the free variables of the function
+
+closure_vars(Vs, Env, Ren) ->
+ closure_vars(Vs, [], Env, Ren).
+
+closure_vars([V = {_, _} | Vs], As, Env, Ren) ->
+ V1 = ren__map(V, Ren),
+ case env__lookup(V1, Env) of
+ {ok, #function{free = Vs1}} ->
+ closure_vars(Vs, Vs1 ++ As, Env, Ren);
+ _ ->
+ closure_vars(Vs, As, Env, Ren)
+ end;
+closure_vars([V | Vs], As, Env, Ren) ->
+ closure_vars(Vs, [V | As], Env, Ren);
+closure_vars([], As, _Env, _Ren) ->
+ ordsets:from_list(As).
+
+%% We use the no-shadowing strategy, renaming variables on the fly and
+%% only when necessary to uphold the invariant.
+
+bind_vars(Vs, Env, Ren) ->
+ bind_vars(Vs, [], Env, Ren).
+
+bind_vars([V | Vs], Vs1, Env, Ren) ->
+ Name = cerl:var_name(V),
+ {Name1, Ren1} = rename_var(Name, Env, Ren),
+ bind_vars(Vs, [cerl:update_c_var(V, Name1) | Vs1],
+ env__bind(Name1, variable, Env), Ren1);
+bind_vars([], Vs, Env, Ren) ->
+ {lists:reverse(Vs), Env, Ren}.
+
+rename_var(Name, Env, Ren) ->
+ case env__is_defined(Name, Env) of
+ false ->
+ {Name, Ren};
+ true ->
+ New = env__new_name(Env),
+ {New, ren__add(Name, New, Ren)}
+ end.
+
+%% This handles variable references *except* in function application
+%% operator positions (see apply_expr/4).
+%%
+%% The Beam compiler annotates function-variable references with 'id'
+%% info, eventually transforming a direct reference such as "fun f/2"
+%% into a new fun-expression "fun (X1,X2) -> apply f/2(X1,X2)" for which
+%% the info is used to create the lifted function as for any other fun.
+%% We do the same thing for function-bound variables.
+
+var(V, Env, Ren, S) ->
+ Name = ren__map(cerl:var_name(V), Ren),
+ case lookup_var(Name, Env) of
+ #function{name = F, free = Vs} ->
+ {_, Arity} = F,
+ Vs1 = make_vars(Arity),
+ C = cerl:c_apply(cerl:c_var(F), Vs1),
+ E = cerl:ann_c_fun(cerl:get_ann(V), Vs1, C),
+ fun_expr_1(E, Vs, Env, Ren, S);
+ variable ->
+ {cerl:update_c_var(V, Name), S}
+ end.
+
+lookup_var(V, Env) ->
+ case env__lookup(V, Env) of
+ {ok, X} ->
+ X;
+ error ->
+ error_msg("unbound variable `~P'.", [V, 5]),
+ exit(error)
+ end.
+
+make_vars(N) when N > 0 ->
+ [cerl:c_var(list_to_atom("X" ++ integer_to_list(N)))
+ | make_vars(N - 1)];
+make_vars(0) ->
+ [].
+
+%% All funs that are not bound by module or letrec definitions will be
+%% rewritten to create explicit closures using "make fun". We don't
+%% currently track ordinary let-bindings of funs, as in "let F = fun
+%% ... in ...apply F(...)...".
+%%
+%% Note that we (currently) follow the Beam naming convention, including
+%% the free variables in the arity of the name, even though the actual
+%% function typically expects a different number of parameters.
+
+fun_expr(F, Env, Ren, S) ->
+ Free = closure_vars(cerl_trees:free_variables(F), Env, Ren),
+ Vs = [cerl:c_var(V) || V <- Free],
+ fun_expr_1(F, Vs, Env, Ren, S).
+
+fun_expr_1(F, Vs, Env, Ren, S) ->
+ Arity = cerl:fun_arity(F) + length(Vs), % for the name only
+ {Info, S1} = fun_info(F, Env, S),
+ Name = {Info#fun_info.name, Arity},
+ S2 = lift_fun(Name, F, Vs, Env, Ren, S1),
+ {make_fun_primop(Name, Vs, Info, F, S2), S2}.
+
+make_fun_primop({Name, Arity}, Free, #fun_info{id = Id, hash = Hash},
+ F, S) ->
+ Module = s__get_module_name(S),
+ cerl:update_c_primop(F, cerl:c_atom(?PRIMOP_MAKE_FUN),
+ [cerl:c_atom(Module),
+ cerl:c_atom(Name),
+ cerl:c_int(Arity),
+ cerl:c_int(Hash),
+ cerl:c_int(Id),
+ cerl:make_list(Free)]).
+
+%% Getting attached fun-info, if present; otherwise making it up.
+
+fun_info(E, Env, S) ->
+ case lists:keyfind(id, 1, cerl:get_ann(E)) of
+ {id, {Id, H, Name}} ->
+ %% io:fwrite("Got fun-info: ~w: {~w,~w}.\n", [Name,Id,H]),
+ {#fun_info{name = Name, id = Id, hash = H}, S};
+ _ ->
+ io:fwrite("Warning - fun not annotated: "
+ "making up new name.\n"), % for now
+ {{Name,_Arity}, S1} = new_fun_name(E, Env, S),
+ {#fun_info{name = Name, id = 0, hash = 0}, S1}
+ end.
+
+fun_name_base(FName, FArity) ->
+ "-" ++ atom_to_list(FName) ++ "/" ++ integer_to_list(FArity).
+
+%% Generate a name for the new function, using a the same convention
+%% that is used by the Beam compiler.
+new_fun_name(F, Env, S) ->
+ {FName, FArity} = s__get_function(S),
+ Base = fun_name_base(FName, FArity) ++ "-fun-",
+ Arity = cerl:fun_arity(F),
+ new_fun_name(Base, Arity, Env, S).
+
+%% Creating a new function name that is not in the environment and is
+%% not already used for some other lifted function.
+
+new_fun_name(Base, Arity, Env, S) ->
+ F = fun (N) ->
+ {list_to_atom(Base ++ integer_to_list(N)), Arity}
+ end,
+ new_fun_name(Base, Arity, Env, S, F).
+
+new_fun_name(Base, Arity, Env, S, F) ->
+ %% Note that repeated calls to env__new_function_name/2 will yield
+ %% different names even though Env and F are the same.
+ Name = env__new_function_name(F, Env),
+ case s__is_function_name(Name, S) of
+ true ->
+ new_fun_name(Base, Arity, Env, S, F);
+ false ->
+ {Name, S}
+ end.
+
+%% This lifts the fun to a new top-level function which uses the calling
+%% convention for closures, with the closure itself as the final
+%% parameter. Note that the free variables (if any) are already in the
+%% environment.
+%%
+%% It should not be possible for the original parameters to clash with
+%% the free ones (in that case they cannot be free), but we do the full
+%% bind-and-rename anyway, since it's easiest.
+
+lift_fun(Name, F, Free, Env, Ren, S) ->
+ %% If the name is already in the list of top-level definitions, we
+ %% assume we have already generated this function, and do not need
+ %% to do it again (typically, this happens for 'fun f/n'-variables
+ %% that have been duplicated before being rewritten to actual
+ %% fun-expressions, and the name is taken from their annotations).
+ %% Otherwise, we add the name to the list.
+ case s__is_function_name(Name, S) of
+ true ->
+ S;
+ false ->
+ S1 = s__add_function_name(Name, S),
+ lift_fun_1(Name, F, Free, Env, Ren, S1)
+ end.
+
+lift_fun_1(Name, F, Free, Env, Ren, S) ->
+ %% (The original parameters must be added to the environment before
+ %% we generate the new variable for the closure parameter.)
+ {Vs, Env1, Ren1} = bind_vars(cerl:fun_vars(F), Env, Ren),
+ V = env__new_name(Env1),
+ Env2 = env__bind(V, variable, Env1),
+ {B, S1} = expr(cerl:fun_body(F), Env2, Ren1, S),
+ %% We unpack all free variables from the closure upon entering.
+ %% (Adding this to the body before we process it would introduce
+ %% unnecessary, although harmless, renaming of the free variables.)
+ Es = closure_elements(length(Free), cerl:c_var(V)),
+ B1 = cerl:c_let(Free, cerl:c_values(Es), B),
+ %% The closure itself is passed as the last argument. The new
+ %% function is annotated as being a closure-call entry point.
+ E = cerl:ann_c_fun([closure, {closure_orig_arity, cerl:fun_arity(F)}], Vs ++ [cerl:c_var(V)], B1),
+ s__add_def(cerl:c_var(Name), E, S1).
+
+closure_elements(N, V) ->
+ closure_elements(N, N + 1, V).
+
+closure_elements(0, _, _) -> [];
+closure_elements(N, M, V) ->
+ [cerl:c_primop(cerl:c_atom(?PRIMOP_FUN_ELEMENT),
+ [cerl:c_int(M - N), V])
+ | closure_elements(N - 1, M, V)].
+
+
+%% Function applications must be rewritten depending on the
+%% operator. For a call to a known top-level function or letrec-bound
+%% function, we make a direct call, passing the free variables as extra
+%% parameters (we know they are in scope, since variables may not be
+%% shadowed). Otherwise, we create an "apply fun" primop call that
+%% expects a closure.
+
+apply_expr(E, Env, Ren, S) ->
+ {As, S1} = expr_list(cerl:apply_args(E), Env, Ren, S),
+ Op = cerl:apply_op(E),
+ case cerl:is_c_var(Op) of
+ true ->
+ Name = ren__map(cerl:var_name(Op), Ren),
+ case lookup_var(Name, Env) of
+ #function{name = F, free = Vs} ->
+ Vs1 = As ++ [cerl:c_var(V) || V <- Vs],
+ {cerl:update_c_apply(E, cerl:c_var(F), Vs1), S1};
+ variable ->
+ apply_expr_1(E, Op, As, Env, Ren, S1)
+ end;
+ _ ->
+ apply_expr_1(E, Op, As, Env, Ren, S1)
+ end.
+
+%% Note that this primop call only communicates the necessary
+%% information to the core-to-icode stage, which rewrites it to use the
+%% real calling convention for funs.
+
+apply_expr_1(E, Op, As, Env, Ren, S) ->
+ {Op1, S1} = expr(Op, Env, Ren, S),
+ Call = cerl:update_c_primop(E, cerl:c_atom(?PRIMOP_APPLY_FUN),
+ [Op1, cerl:make_list(As)]),
+ {Call, S1}.
+
+
+%% ---------------------------------------------------------------------
+%% Environment
+
+env__new() ->
+ rec_env:empty().
+
+env__bind(Key, Value, Env) ->
+ rec_env:bind(Key, Value, Env).
+
+env__lookup(Key, Env) ->
+ rec_env:lookup(Key, Env).
+
+env__get(Key, Env) ->
+ rec_env:get(Key, Env).
+
+env__is_defined(Key, Env) ->
+ rec_env:is_defined(Key, Env).
+
+env__new_name(Env) ->
+ rec_env:new_key(Env).
+
+env__new_function_name(F, Env) ->
+ rec_env:new_key(F, Env).
+
+
+%% ---------------------------------------------------------------------
+%% Renaming
+
+ren__new() ->
+ dict:new().
+
+ren__add(Key, Value, Ren) ->
+ dict:store(Key, Value, Ren).
+
+ren__map(Key, Ren) ->
+ case dict:find(Key, Ren) of
+ {ok, Value} ->
+ Value;
+ error ->
+ Key
+ end.
+
+
+%% ---------------------------------------------------------------------
+%% State
+
+-record(state, {module :: module(), function :: {atom(), arity()},
+ names, refs, defs = []}).
+
+s__new(Module) ->
+ #state{module = Module, names = sets:new(), refs = dict:new()}.
+
+s__add_function_name(Name, S) ->
+ S#state{names = sets:add_element(Name, S#state.names)}.
+
+s__is_function_name(Name, S) ->
+ sets:is_element(Name, S#state.names).
+
+s__get_module_name(S) ->
+ S#state.module.
+
+s__enter_function(F, S) ->
+ S#state{function = F}.
+
+s__get_function(S) ->
+ S#state.function.
+
+s__add_def(V, F, S) ->
+ S#state{defs = [{V, F} | S#state.defs]}.
+
+s__get_defs(S) ->
+ S#state.defs.
+
+
+%% ---------------------------------------------------------------------
+%% Reporting
+
+%% internal_error_msg(S) ->
+%% internal_error_msg(S, []).
+
+%% internal_error_msg(S, Vs) ->
+%% error_msg(lists:concat(["Internal error: ", S]), Vs).
+
+%% error_msg(S) ->
+%% error_msg(S, []).
+
+error_msg(S, Vs) ->
+ error_logger:error_msg(lists:concat([?MODULE, ": ", S, "\n"]), Vs).
+
+%% warning_msg(S) ->
+%% warning_msg(S, []).
+
+%% warning_msg(S, Vs) ->
+%% info_msg(lists:concat(["warning: ", S]), Vs).
+
+%% info_msg(S) ->
+%% info_msg(S, []).
+
+%% info_msg(S, Vs) ->
+%% error_logger:info_msg(lists:concat([?MODULE, ": ", S, "\n"]), Vs).