diff options
Diffstat (limited to 'lib/hipe/cerl/cerl_cconv.erl')
| -rw-r--r-- | lib/hipe/cerl/cerl_cconv.erl | 777 |
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). |