The R13B03 release.OTP_R13B03

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).