aboutsummaryrefslogtreecommitdiffstats
path: root/lib/hipe/cerl/cerl_to_icode.erl
diff options
context:
space:
mode:
Diffstat (limited to 'lib/hipe/cerl/cerl_to_icode.erl')
-rw-r--r--lib/hipe/cerl/cerl_to_icode.erl2717
1 files changed, 2717 insertions, 0 deletions
diff --git a/lib/hipe/cerl/cerl_to_icode.erl b/lib/hipe/cerl/cerl_to_icode.erl
new file mode 100644
index 0000000000..362c427cbe
--- /dev/null
+++ b/lib/hipe/cerl/cerl_to_icode.erl
@@ -0,0 +1,2717 @@
+%% -*- erlang-indent-level: 4 -*-
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2003-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-2006 Richard Carlsson
+%% @doc Translation from Core Erlang to HiPE Icode.
+
+%% TODO: annotate Icode leaf functions as such.
+%% TODO: add a pass to remove unnecessary reduction tests
+%% TODO: generate branch prediction info?
+
+-module(cerl_to_icode).
+
+-define(NO_UNUSED, true).
+
+-export([module/2]).
+-ifndef(NO_UNUSED).
+-export([function/3, function/4, module/1]).
+-endif.
+
+%% Added in an attempt to suppress message by Dialyzer, but I run into
+%% an internal compiler error in the old inliner and commented it out.
+%% The inlining is performed manually instead :-( - Kostis
+%% -compile({inline, [{error_fun_value,1}]}).
+
+%% ---------------------------------------------------------------------
+%% Macros and records
+
+%% Icode primitive operation names
+
+-include("../icode/hipe_icode_primops.hrl").
+
+-define(OP_REDTEST, redtest).
+-define(OP_CONS, cons).
+-define(OP_TUPLE, mktuple).
+-define(OP_ELEMENT, {erlang,element,2}). %% This has an MFA name
+-define(OP_UNSAFE_HD, unsafe_hd).
+-define(OP_UNSAFE_TL, unsafe_tl).
+-define(OP_UNSAFE_ELEMENT(N), #unsafe_element{index=N}).
+-define(OP_UNSAFE_SETELEMENT(N), #unsafe_update_element{index=N}).
+-define(OP_CHECK_GET_MESSAGE, check_get_msg).
+-define(OP_NEXT_MESSAGE, next_msg).
+-define(OP_SELECT_MESSAGE, select_msg).
+-define(OP_SET_TIMEOUT, set_timeout).
+-define(OP_CLEAR_TIMEOUT, clear_timeout).
+-define(OP_WAIT_FOR_MESSAGE, suspend_msg).
+-define(OP_APPLY_FIXARITY(N), #apply_N{arity=N}).
+-define(OP_MAKE_FUN(M, F, A, U, I), #mkfun{mfa={M,F,A}, magic_num=U, index=I}).
+-define(OP_FUN_ELEMENT(N), #closure_element{n=N}).
+-define(OP_BS_CONTEXT_TO_BINARY, {hipe_bs_primop,bs_context_to_binary}).
+
+%% Icode conditional tests
+
+-define(TEST_EQ, '==').
+-define(TEST_NE, '/=').
+-define(TEST_EXACT_EQ, '=:=').
+-define(TEST_EXACT_NE, '=/=').
+-define(TEST_LT, '<').
+-define(TEST_GT, '>').
+-define(TEST_LE, '=<').
+-define(TEST_GE, '>=').
+-define(TEST_WAIT_FOR_MESSAGE_OR_TIMEOUT, suspend_msg_timeout).
+
+%% Icode type tests
+
+-define(TYPE_ATOM(X), {atom, X}).
+-define(TYPE_INTEGER(X), {integer, X}).
+-define(TYPE_FIXNUM(X), {integer, X}). % for now
+-define(TYPE_CONS, cons).
+-define(TYPE_NIL, nil).
+-define(TYPE_IS_N_TUPLE(N), {tuple, N}).
+-define(TYPE_IS_ATOM, atom).
+-define(TYPE_IS_BIGNUM, bignum).
+-define(TYPE_IS_BINARY, binary).
+-define(TYPE_IS_CONSTANT, constant).
+-define(TYPE_IS_FIXNUM, fixnum).
+-define(TYPE_IS_FLOAT, float).
+-define(TYPE_IS_FUNCTION, function).
+-define(TYPE_IS_INTEGER, integer).
+-define(TYPE_IS_LIST, list).
+-define(TYPE_IS_NUMBER, number).
+-define(TYPE_IS_PID, pid).
+-define(TYPE_IS_PORT, port).
+-define(TYPE_IS_RECORD(Atom_, Size_), {record, Atom_, Size_}).
+-define(TYPE_IS_REFERENCE, reference).
+-define(TYPE_IS_TUPLE, tuple).
+
+%% Record definitions
+
+-record(ctxt, {final = false :: boolean(),
+ effect = false,
+ fail = [], % [] or fail-to label
+ class = expr, % expr | guard
+ line = 0, % current line number
+ 'receive' % undefined | #receive{}
+ }).
+
+-record('receive', {loop}).
+-record(cerl_to_icode__var, {name}).
+-record('fun', {label, vars}).
+
+
+%% ---------------------------------------------------------------------
+%% Code
+
+
+%% @spec module(Module::cerl()) -> [icode()]
+%% @equiv module(Module, [])
+
+-ifndef(NO_UNUSED).
+module(E) ->
+ module(E, []).
+-endif.
+%% @clear
+
+
+%% @spec module(Module::cerl(), Options::[term()]) -> [icode()]
+%%
+%% cerl() = cerl:cerl()
+%% icode() = hipe_icode:icode()
+%%
+%% @doc Transforms a Core Erlang module to linear HiPE Icode. The result
+%% is a list of Icode function definitions. Currently, no options are
+%% available.
+%%
+%% <p>This function first calls the {@link cerl_hipeify:transform/2}
+%% function on the module.</p>
+%%
+%% <p>Note: Except for the module name, which is included in the header
+%% of each Icode function definition, the remaining information (exports
+%% and attributes) associated with the module definition is not included
+%% in the resulting Icode.</p>
+%%
+%% @see function/4
+%% @see cerl_hipeify:transform/1
+
+%% -spec module(cerl:c_module(), [term()]) -> [{mfa(), hipe_icode:icode()}].
+
+module(E, Options) ->
+ module_1(cerl_hipeify:transform(E, Options), Options).
+
+module_1(E, Options) ->
+ M = cerl:atom_val(cerl:module_name(E)),
+ if is_atom(M) ->
+ ok;
+ true ->
+ error_msg("bad module name: ~P.", [M, 5]),
+ throw(error)
+ end,
+ S0 = init(M),
+ S1 = s__set_pmatch(proplists:get_value(pmatch, Options), S0),
+ S2 = s__set_bitlevel_binaries(proplists:get_value(
+ bitlevel_binaries, Options), S1),
+ {Icode, _} = lists:mapfoldl(fun function_definition/2,
+ S2, cerl:module_defs(E)),
+ Icode.
+
+%% For now, we simply assume that all function bodies should have degree
+%% one (i.e., return exactly one value). We clear the code ackumulator
+%% before we start compiling each function.
+
+function_definition({V, F}, S) ->
+ S1 = s__set_code([], S),
+ {Icode, S2} = function_1(cerl:var_name(V), F, 1, S1),
+ {{icode_icode_name(Icode), Icode}, S2}.
+
+init(Module) ->
+ reset_label_counter(),
+ s__new(Module).
+
+%% @spec function(Module::atom(), Name::atom(), Function::cerl()) ->
+%% icode()
+%% @equiv function(Module, Name, Fun, 1)
+
+-ifndef(NO_UNUSED).
+function(Module, Name, Fun) ->
+ function(Module, Name, Fun, 1).
+-endif. % NO_UNUSED
+%% @clear
+
+%% @spec function(Module::atom(), Name::{atom(), integer()},
+%% Fun::cerl(), Degree::integer()) -> icode()
+%%
+%% @doc Transforms a Core Erlang function to a HiPE Icode function
+%% definition. `Fun' must represent a fun-expression, which may not
+%% contain free variables. `Module' and `Name' specify the module and
+%% function name of the resulting Icode function. Note that the arity
+%% part of `Name' is not necessarily equivalent to the number of
+%% parameters of `Fun' (this can happen e.g., for lifted closure
+%% functions).
+%%
+%% <p>`Degree' specifies the number of values the function is expected
+%% to return; this is typically 1 (one); cf. {@link function/3}.</p>
+%%
+%% <p>Notes:
+%% <ul>
+%% <li>This function assumes that the code has been transformed into a
+%% very simple and explicit form, using the {@link cerl_hipeify}
+%% module.</li>
+%%
+%% <li>Several primops (see "`cerl_hipe_primops.hrl'") are
+%% detected by the translation and handled specially.</li>
+%%
+%% <li>Tail call optimization is handled, even when the call is
+%% "hidden" by let-definitions.</li>
+%%
+%% <li>It is assumed that all `primop' calls in the code represent
+%% Icode primops or macro instructions, and that all inter-module
+%% calls (both calls to statically named functions, and dynamic
+%% meta-calls) represent <em>actual</em> inter-module calls - not
+%% primitive or built-in operations.</li>
+%%
+%% <li>The following special form:
+%% ```case Test of
+%% 'true' when 'true' -> True
+%% 'false' when 'true' -> False
+%% end'''
+%% is recognized as an if-then-else switch where `Test' is known
+%% to always yield 'true' or 'false'. Efficient jumping code is
+%% generated for such expressions, in particular if nested. Note that
+%% there must be exactly two clauses; order is not important.</li>
+%%
+%% <li>Compilation of clauses is simplistic. No pattern matching
+%% compilation or similar optimizations is done at this stage. Guards
+%% that are `true' or `false' are recognized as trivially true/false;
+%% for all other guards, code will be generated. Catch-all clauses
+%% (with `true' guard and variable-only patterns) are detected, and
+%% any following clauses are discarded.</li>
+%% </ul></p>
+%%
+%% <p><b>Important</b>: This function does not handle occurrences of
+%% fun-expressions in the body of `Fun', nor `apply'-expressions whose
+%% operators are not locally bound function variables. These must be
+%% transformed away before this function is called, by closure
+%% conversion ({@link cerl_cconv}) using the `make_fun' and `call_fun'
+%% primitive operations to create and apply functional values.</p>
+%%
+%% <p>`receive'-expressions are expected to have a particular
+%% form:
+%% <ul>
+%% <li>There must be exactly one clause, with the atom
+%% `true' as guard, and only a single variable as pattern.
+%% The variable will be bound to a message in the mailbox, and can be
+%% referred to in the clause body.</li>
+%%
+%% <li>In the body of that clause, all paths must execute one of the
+%% primitive operations `receive_select/0' or
+%% `receive_next/0' before another
+%% `receive'-statement might be executed.
+%% `receive_select/0' always returns, but without a value,
+%% while `receive_next/0' never returns, either causing
+%% the nearest surrounding receive-expression to be re-tried with the
+%% next message in the input queue, or timing out.</li>
+%% </ul></p>
+%%
+%% @see function/3
+
+-include("cerl_hipe_primops.hrl").
+
+%% Main translation function:
+
+-ifndef(NO_UNUSED).
+function(Module, Name, Fun, Degree) ->
+ S = init(Module),
+ {Icode, _} = function_1(Name, Fun, Degree, S),
+ Icode.
+-endif. % NO_UNUSED
+%% @clear
+
+function_1(Name, Fun, Degree, S) ->
+ reset_var_counter(),
+ LowV = max_var(),
+ LowL = max_label(),
+ %% Create input variables for the function parameters, and a list of
+ %% target variables for the result of the function.
+ Args = cerl:fun_vars(Fun),
+ IcodeArity = length(Args),
+ Vs = make_vars(IcodeArity),
+ Vs1 = make_vars(IcodeArity), % input variable temporaries
+ Ts = make_vars(Degree),
+
+ %% Initialise environment and context.
+ Env = bind_vars(Args, Vs, env__new()),
+ %% TODO: if the function returns no values, we can use effect mode
+ Ctxt = #ctxt{final = true, effect = false},
+ %% Each basic block must begin with a label. Note that we
+ %% immediately transfer the input parameters to local variables, for
+ %% our self-recursive calling convention.
+ Start = new_label(),
+ Local = new_label(),
+ S1 = add_code([icode_label(Start)]
+ ++ make_moves(Vs, Vs1)
+ ++ [icode_label(Local)],
+ s__set_function(Name, S)),
+ S2 = expr(cerl:fun_body(Fun), Ts, Ctxt, Env,
+ s__set_local_entry({Local, Vs}, S1)),
+
+ %% This creates an Icode function definition. The ranges of used
+ %% variables and labels below should be nonempty. Note that the
+ %% input variables for the Icode function are `Vs1', which will be
+ %% transferred to `Vs' (see above).
+ HighV = new_var(), % assure nonempty range
+ HighL = max_label(),
+ Closure = lists:member(closure, cerl:get_ann(Fun)),
+ Module = s__get_module(S2),
+ Code = s__get_code(S2),
+ Function = icode_icode(Module, Name, Vs1, Closure, Code,
+ {LowV, HighV}, {LowL, HighL}),
+ if Closure ->
+ {_, OrigArity} =
+ lists:keyfind(closure_orig_arity, 1, cerl:get_ann(Fun)),
+ {hipe_icode:icode_closure_arity_update(Function,
+ OrigArity),
+ S2};
+ true -> {Function, S2}
+ end.
+
+%% ---------------------------------------------------------------------
+%% Main expression handler
+
+expr(E, Ts, Ctxt, Env, S0) ->
+ %% Insert source code position information
+ case get_line(cerl:get_ann(E)) of
+ none ->
+ expr_1(E, Ts, Ctxt, Env, S0);
+ Line when Line > Ctxt#ctxt.line ->
+ Txt = "Line: " ++ integer_to_list(Line),
+ S1 = add_code([icode_comment(Txt)], S0),
+ expr_1(E, Ts, Ctxt#ctxt{line = Line}, Env, S1);
+ _ ->
+ expr_1(E, Ts, Ctxt, Env, S0)
+ end.
+
+expr_1(E, Ts, Ctxt, Env, S) ->
+ case cerl:type(E) of
+ var ->
+ expr_var(E, Ts, Ctxt, Env, S);
+ literal ->
+ expr_literal(E, Ts, Ctxt, S);
+ values ->
+ expr_values(E, Ts, Ctxt, Env, S);
+ tuple ->
+ %% (The unit tuple `{}' is a literal, handled above.)
+ expr_tuple(E, Ts, Ctxt, Env, S);
+ cons ->
+ expr_cons(E, Ts, Ctxt, Env, S);
+ 'let' ->
+ expr_let(E, Ts, Ctxt, Env, S);
+ seq ->
+ expr_seq(E, Ts, Ctxt, Env, S);
+ apply ->
+ expr_apply(E, Ts, Ctxt, Env, S);
+ call ->
+ expr_call(E, Ts, Ctxt, Env, S);
+ primop ->
+ expr_primop(E, Ts, Ctxt, Env, S);
+ 'case' ->
+ expr_case(E, Ts, Ctxt, Env, S);
+ 'receive' ->
+ expr_receive(E, Ts, Ctxt, Env, S);
+ 'try' ->
+ expr_try(E, Ts, Ctxt, Env, S);
+ binary ->
+ expr_binary(E, Ts, Ctxt, Env, S);
+ letrec ->
+ expr_letrec(E, Ts, Ctxt, Env, S);
+ 'fun' ->
+ error_msg("cannot handle fun-valued expressions; "
+ "must be closure converted."),
+ throw(error)
+ end.
+
+%% This is for when we need new target variables for all of the
+%% expressions in the list, and evaluate them for value in a
+%% non-tail-call context.
+
+expr_list(Es, Ctxt, Env, S) ->
+ Ctxt1 = Ctxt#ctxt{effect = false, final = false},
+ lists:mapfoldl(fun (E0, S0) ->
+ V = make_var(),
+ {V, expr(E0, [V], Ctxt1, Env, S0)}
+ end,
+ S, Es).
+
+%% This is for when we already have the target variables. It is expected
+%% that each expression in the list has degree one, so the result can be
+%% assigned to the corresponding variable.
+
+exprs([E | Es], [V | Vs], Ctxt, Env, S) ->
+ S1 = expr(E, [V], Ctxt, Env, S),
+ exprs(Es, Vs, Ctxt, Env, S1);
+exprs([], [], _Ctxt, _Env, S) ->
+ S;
+exprs([], _, _Ctxt, _Env, S) ->
+ warning_low_degree(),
+ S;
+exprs(_, [], _Ctxt, _Env, _S) ->
+ error_high_degree(),
+ throw(error).
+
+get_line([L | _As]) when is_integer(L) ->
+ L;
+get_line([_ | As]) ->
+ get_line(As);
+get_line([]) ->
+ none.
+
+
+%% ---------------------------------------------------------------------
+%% Variables
+
+expr_var(_E, _Ts, #ctxt{effect = true}, _Env, S) ->
+ S;
+expr_var(E, Ts, Ctxt, Env, S) ->
+ Name = cerl:var_name(E),
+ case env__lookup(Name, Env) of
+ error ->
+ %% Either an undefined variable or an attempt to use a local
+ %% function name as a value.
+ case Name of
+ {N,A} when is_atom(N), is_integer(A) ->
+ %% error_fun_value(Name);
+ error_msg("cannot handle fun-values outside call context; "
+ "must be closure converted: ~P.",
+ [Name, 5]),
+ throw(error);
+ _ ->
+ error_msg("undefined variable: ~P.", [Name, 5]),
+ throw(error)
+ end;
+ {ok, #cerl_to_icode__var{name = V}} ->
+ case Ctxt#ctxt.final of
+ false ->
+ glue([V], Ts, S);
+ true ->
+ add_return([V], S)
+ end;
+ {ok, #'fun'{}} ->
+ %% A letrec-defined function name, used as a value.
+ %% error_fun_value(Name)
+ error_msg("cannot handle fun-values outside call context; "
+ "must be closure converted: ~P.",
+ [Name, 5]),
+ throw(error)
+ end.
+
+%% The function has been inlined manually above to suppress message by Dialyzer
+%% error_fun_value(Name) ->
+%% error_msg("cannot handle fun-values outside call context; "
+%% "must be closure converted: ~P.",
+%% [Name, 5]),
+%% throw(error).
+
+%% ---------------------------------------------------------------------
+%% This handles all constants, both atomic and compound:
+
+expr_literal(_E, _Ts, #ctxt{effect = true}, S) ->
+ S;
+expr_literal(E, [V] = Ts, Ctxt, S) ->
+ Code = [icode_move(V, icode_const(cerl:concrete(E)))],
+ maybe_return(Ts, Ctxt, add_code(Code, S));
+expr_literal(E, Ts, _Ctxt, _S) ->
+ error_degree_mismatch(length(Ts), E),
+ throw(error).
+
+%% ---------------------------------------------------------------------
+%% Multiple value aggregate <X1,...,Xn>
+
+expr_values(E, Ts, #ctxt{effect = true} = Ctxt, Env, S) ->
+ {_, S1} = exprs(cerl:values_es(E), Ts, Ctxt#ctxt{final = false},
+ Env, S),
+ S1;
+expr_values(E, Ts, Ctxt, Env, S) ->
+ S1 = exprs(cerl:values_es(E), Ts, Ctxt#ctxt{final = false}, Env, S),
+ maybe_return(Ts, Ctxt, S1).
+
+%% ---------------------------------------------------------------------
+%% Nonconstant tuples
+
+expr_tuple(E, _Ts, #ctxt{effect = true} = Ctxt, Env, S) ->
+ {_Vs, S1} = expr_list(cerl:tuple_es(E), Ctxt, Env, S),
+ S1;
+expr_tuple(E, [_V] = Ts, Ctxt, Env, S) ->
+ {Vs, S1} = expr_list(cerl:tuple_es(E), Ctxt, Env, S),
+ add_code(make_op(?OP_TUPLE, Ts, Vs, Ctxt), S1);
+expr_tuple(E, Ts, _Ctxt, _Env, _S) ->
+ error_degree_mismatch(length(Ts), E),
+ throw(error).
+
+%% ---------------------------------------------------------------------
+%% Nonconstant cons cells
+
+expr_cons(E, _Ts, #ctxt{effect = true} = Ctxt, Env, S) ->
+ {_Vs, S1} = expr_list([cerl:cons_hd(E), cerl:cons_tl(E)], Ctxt, Env, S),
+ S1;
+expr_cons(E, [_V] = Ts, Ctxt, Env, S) ->
+ {Vs, S1} = expr_list([cerl:cons_hd(E), cerl:cons_tl(E)], Ctxt, Env, S),
+ add_code(make_op(?OP_CONS, Ts, Vs, Ctxt), S1);
+expr_cons(E, Ts, _Ctxt, _Env, _S) ->
+ error_degree_mismatch(length(Ts), E),
+ throw(error).
+
+%% ---------------------------------------------------------------------
+%% Let-expressions
+
+%% We want to make sure we are not easily tricked by expressions hidden
+%% in contexts like "let X = Expr in X"; this should not destroy tail
+%% call properties.
+
+expr_let(E, Ts, Ctxt, Env, S) ->
+ F = fun (BF, CtxtF, EnvF, SF) -> expr(BF, Ts, CtxtF, EnvF, SF) end,
+ expr_let_1(E, F, Ctxt, Env, S).
+
+expr_let_1(E, F, Ctxt, Env, S) ->
+ E1 = cerl_lib:reduce_expr(E),
+ case cerl:is_c_let(E1) of
+ true ->
+ expr_let_2(E1, F, Ctxt, Env, S);
+ false ->
+ %% Redispatch the new expression.
+ F(E1, Ctxt, Env, S)
+ end.
+
+expr_let_2(E, F, Ctxt, Env, S) ->
+ Vars = cerl:let_vars(E),
+ Vs = make_vars(length(Vars)),
+ S1 = expr(cerl:let_arg(E), Vs,
+ Ctxt#ctxt{effect = false, final = false}, Env, S),
+ Env1 = bind_vars(Vars, Vs, Env),
+ F(cerl:let_body(E), Ctxt, Env1, S1).
+
+%% ---------------------------------------------------------------------
+%% Sequencing
+
+%% To compile a sequencing operator, we generate code for effect only
+%% for the first expression (the "argument") and then use the
+%% surrounding context for the second expression (the "body"). Note that
+%% we always create a new dummy target variable; this is necessary for
+%% many ICode operations, even if the result is not used.
+
+expr_seq(E, Ts, Ctxt, Env, S) ->
+ F = fun (BF, CtxtF, EnvF, SF) -> expr(BF, Ts, CtxtF, EnvF, SF) end,
+ expr_seq_1(E, F, Ctxt, Env, S).
+
+expr_seq_1(E, F, Ctxt, Env, S) ->
+ Ctxt1 = Ctxt#ctxt{effect = true, final = false},
+ S1 = expr(cerl:seq_arg(E), [make_var()], Ctxt1, Env, S),
+ F(cerl:seq_body(E), Ctxt, Env, S1).
+
+%% ---------------------------------------------------------------------
+%% Binaries
+
+-record(sz_var, {code, sz}).
+-record(sz_const, {code, sz}).
+
+expr_binary(E, [V]=Ts, Ctxt, Env, S) ->
+ Offset = make_reg(),
+ Base = make_reg(),
+ Segs = cerl:binary_segments(E),
+ S1 = case do_size_code(Segs, S, Env, Ctxt) of
+ #sz_const{code = S0, sz = Size} ->
+ Primop = {hipe_bs_primop, {bs_init, Size, 0}},
+ add_code([icode_call_primop([V, Base, Offset], Primop, [])],
+ S0);
+ #sz_var{code = S0, sz = SizeVar} ->
+ Primop = {hipe_bs_primop, {bs_init, 0}},
+ add_code([icode_call_primop([V, Base, Offset],
+ Primop, [SizeVar])],
+ S0)
+ end,
+ Vars = make_vars(length(Segs)),
+ S2 = binary_segments(Segs, Vars, Ctxt, Env, S1, false, Base, Offset),
+ S3 = case s__get_bitlevel_binaries(S2) of
+ true ->
+ POp = {hipe_bs_primop, bs_final},
+ add_code([icode_call_primop([V], POp, [V, Offset])], S2);
+ false ->
+ S2
+ end,
+ maybe_return(Ts, Ctxt, S3).
+
+do_size_code(Segs, S, Env, Ctxt) ->
+ case do_size_code(Segs, S, Env, cerl:c_int(0), [], []) of
+ {[], [], Const, S1} ->
+ #sz_const{code = S1, sz = ((cerl:concrete(Const) + 7) div 8)};
+ {Pairs, Bins, Const, S1} ->
+ V1 = make_var(),
+ S2 = add_code([icode_move(V1, icode_const(cerl:int_val(Const)))], S1),
+ {S3, SizeVar} = create_size_code(Pairs, Bins, Ctxt, V1, S2),
+ #sz_var{code = S3, sz = SizeVar}
+ end.
+
+do_size_code([Seg|Rest], S, Env, Const, Pairs, Bins) ->
+ Size = cerl:bitstr_size(Seg),
+ Unit = cerl:bitstr_unit(Seg),
+ Val = cerl:bitstr_val(Seg),
+ case calculate_size(Unit, Size, false, Env, S) of
+ {all,_, _, S} ->
+ Binary = make_var(),
+ S1 = expr(Val, [Binary], #ctxt{final=false}, Env, S),
+ do_size_code(Rest, S1, Env, Const, Pairs, [{all,Binary}|Bins]);
+ {NewVal, [], S, _} ->
+ do_size_code(Rest, S, Env, add_val(NewVal, Const), Pairs, Bins);
+ {UnitVal, [Var], S1, _} ->
+ do_size_code(Rest, S1, Env, Const, [{UnitVal,Var}|Pairs], Bins)
+ end;
+do_size_code([], S, _Env, Const, Pairs, Bins) ->
+ {Pairs, Bins, Const, S}.
+
+add_val(NewVal, Const) ->
+ cerl:c_int(NewVal + cerl:concrete(Const)).
+
+create_size_code([{UnitVal, Var}|Rest], Bins, Ctxt, Old, S0) ->
+ Dst = make_var(),
+ S = make_bs_add(UnitVal, Old, Var, Dst, Ctxt, S0),
+ create_size_code(Rest, Bins, Ctxt, Dst, S);
+create_size_code([], Bins, Ctxt, Old, S0) ->
+ Dst = make_var(),
+ S = make_bs_bits_to_bytes(Old, Dst, Ctxt, S0),
+ create_size_code(Bins, Ctxt, Dst, S).
+
+create_size_code([{all,Bin}|Rest], Ctxt, Old, S0) ->
+ Dst = make_var(),
+ S = make_binary_size(Old, Bin, Dst, Ctxt, S0),
+ create_size_code(Rest, Ctxt, Dst, S);
+create_size_code([], _Ctxt, Dst, S) ->
+ {S, Dst}.
+
+make_bs_add(Unit, Old, Var, Dst, #ctxt{fail=FL, class=guard}, S0) ->
+ SL1 = new_label(),
+ SL2 = new_label(),
+ SL3 = new_label(),
+ Temp = make_var(),
+ add_code([icode_if('>=', [Var, icode_const(0)], SL1, FL),
+ icode_label(SL1),
+ icode_guardop([Temp], '*', [Var, icode_const(Unit)], SL2, FL),
+ icode_label(SL2),
+ icode_guardop([Dst], '+', [Temp, Old], SL3, FL),
+ icode_label(SL3)], S0);
+make_bs_add(Unit, Old, Var, Dst, _Ctxt, S0) ->
+ SL = new_label(),
+ FL = new_label(),
+ Temp = make_var(),
+ add_code([icode_if('>=', [Var, icode_const(0)], SL, FL),
+ icode_label(FL),
+ icode_fail([icode_const(badarg)], error),
+ icode_label(SL),
+ icode_call_primop([Temp], '*', [Var, icode_const(Unit)]),
+ icode_call_primop([Dst], '+', [Temp, Old])], S0).
+
+make_bs_bits_to_bytes(Old, Dst, #ctxt{fail=FL, class=guard}, S0) ->
+ SL = new_label(),
+ add_code([icode_guardop([Dst], 'bsl', [Old, icode_const(3)], SL, FL),
+ icode_label(SL)], S0);
+make_bs_bits_to_bytes(Old, Dst, _Ctxt, S0) ->
+ add_code([icode_call_primop([Dst], 'bsl', [Old, icode_const(3)])], S0).
+
+make_binary_size(Old, Bin, Dst, #ctxt{fail=FL, class=guard}, S0) ->
+ SL1 = new_label(),
+ SL2 = new_label(),
+ add_code([icode_guardop([Dst], {erlang, byte_size, 1}, [Bin], SL1, FL),
+ icode_label(SL1),
+ icode_guardop([Dst], '+', [Old, Dst], SL2, FL),
+ icode_label(SL2)], S0);
+make_binary_size(Old, Bin, Dst, _Ctxt, S0) ->
+ add_code([icode_call_primop([Dst], {erlang, byte_size, 1}, [Bin]),
+ icode_call_primop([Dst], '+', [Old, Dst])], S0).
+
+binary_segments(SegList, TList, Ctxt=#ctxt{}, Env, S, Align, Base,
+ Offset) ->
+ case do_const_segs(SegList, TList, S, Align, Base, Offset) of
+ {[Seg|Rest], [T|Ts], S1} ->
+ {S2, NewAlign} = bitstr(Seg, [T], Ctxt, Env, S1, Align,
+ Base, Offset),
+ binary_segments(Rest, Ts, Ctxt, Env, S2, NewAlign, Base, Offset);
+ {[], [], S1} ->
+ S1
+ end.
+
+do_const_segs(SegList, TList, S, _Align, Base, Offset) ->
+ case get_segs(SegList, TList, [], 0, {[], SegList, TList}) of
+ {[], SegList, TList} ->
+ {SegList, TList, S};
+ {ConstSegs, RestSegs, RestT} ->
+ String = create_string(ConstSegs, <<>>, 0),
+ Name = {bs_put_string, String, length(String)},
+ Primop = {hipe_bs_primop, Name},
+ {RestSegs, RestT,
+ add_code([icode_call_primop([Offset], Primop, [Base, Offset])],
+ S)}
+ end.
+
+get_segs([Seg|Rest], [_|RestT], Acc, AccSize, BestPresent) ->
+ Size = cerl:bitstr_size(Seg),
+ Unit = cerl:bitstr_unit(Seg),
+ Val = cerl:bitstr_val(Seg),
+ case allowed(Size, Unit, Val, AccSize) of
+ {true, NewAccSize} ->
+ case Acc of
+ [] ->
+ get_segs(Rest, RestT, [Seg|Acc], NewAccSize, BestPresent);
+ _ ->
+ get_segs(Rest, RestT, [Seg|Acc], NewAccSize,
+ {lists:reverse([Seg|Acc]), Rest, RestT})
+ end;
+ {possible, NewAccSize} ->
+ get_segs(Rest, RestT, [Seg|Acc], NewAccSize, BestPresent);
+ false ->
+ BestPresent
+ end;
+get_segs([], [], _Acc, _AccSize, Best) ->
+ Best.
+
+
+create_string([Seg|Rest], Bin, TotalSize) ->
+ Size = cerl:bitstr_size(Seg),
+ Unit = cerl:bitstr_unit(Seg),
+ NewSize = cerl:int_val(Size) * cerl:int_val(Unit),
+ LitVal = cerl:concrete(cerl:bitstr_val(Seg)),
+ LiteralFlags = cerl:bitstr_flags(Seg),
+ FlagVal = translate_flags(LiteralFlags, []),
+ NewTotalSize = NewSize + TotalSize,
+ Pad = (8 - NewTotalSize rem 8) rem 8,
+ NewBin = case cerl:concrete(cerl:bitstr_type(Seg)) of
+ integer ->
+ case {FlagVal band 2, FlagVal band 4} of
+ {2, 4} ->
+ <<Bin:TotalSize/binary-unit:1,
+ LitVal:NewSize/integer-little-signed, 0:Pad>>;
+ {0, 4} ->
+ <<Bin:TotalSize/binary-unit:1,
+ LitVal:NewSize/integer-signed, 0:Pad>>;
+ {2, 0} ->
+ <<Bin:TotalSize/binary-unit:1,
+ LitVal:NewSize/integer-little, 0:Pad>>;
+ {0, 0} ->
+ <<Bin:TotalSize/binary-unit:1,
+ LitVal:NewSize/integer, 0:Pad>>
+ end;
+ float ->
+ case FlagVal band 2 of
+ 2 ->
+ <<Bin:TotalSize/binary-unit:1,
+ LitVal:NewSize/float-little, 0:Pad>>;
+ 0 ->
+ <<Bin:TotalSize/binary-unit:1,
+ LitVal:NewSize/float, 0:Pad>>
+ end
+ end,
+ create_string(Rest, NewBin, NewTotalSize);
+
+create_string([], Bin, _Size) ->
+ binary_to_list(Bin).
+
+allowed(Size, Unit, Val, AccSize) ->
+ case {cerl:is_c_int(Size), cerl:is_literal(Val)} of
+ {true, true} ->
+ NewAccSize = cerl:int_val(Size) * cerl:int_val(Unit) + AccSize,
+ case NewAccSize rem 8 of
+ 0 ->
+ {true, NewAccSize};
+ _ ->
+ {possible, NewAccSize}
+ end;
+ _ ->
+ false
+ end.
+
+bitstr(E, Ts, Ctxt, Env, S, Align, Base, Offset) ->
+ Size = cerl:bitstr_size(E),
+ Unit = cerl:bitstr_unit(E),
+ LiteralFlags = cerl:bitstr_flags(E),
+ Val = cerl:bitstr_val(E),
+ Type = cerl:concrete(cerl:bitstr_type(E)),
+ S0 = expr(Val, Ts, Ctxt#ctxt{final = false, effect = false}, Env, S),
+ ConstInfo = get_const_info(Val, Type),
+ Flags = translate_flags(LiteralFlags, Align),
+ SizeInfo = calculate_size(Unit, Size, false, Env, S0),
+ bitstr_gen_op(Ts, Ctxt, SizeInfo, ConstInfo, Type, Flags, Base, Offset).
+
+bitstr_gen_op([V], #ctxt{fail=FL, class=guard}, SizeInfo, ConstInfo,
+ Type, Flags, Base, Offset) ->
+ SL = new_label(),
+ case SizeInfo of
+ {all,_NewUnit, NewAlign, S1} ->
+ Type = binary,
+ Name = {bs_put_binary_all, Flags},
+ Primop = {hipe_bs_primop, Name},
+ {add_code([icode_guardop([Offset], Primop,
+ [V, Base, Offset], SL, FL),
+ icode_label(SL)], S1), NewAlign};
+ {NewUnit, NewArgs, S1, NewAlign} ->
+ Args = [V|NewArgs] ++ [Base, Offset],
+ Name =
+ case Type of
+ integer ->
+ {bs_put_integer, NewUnit, Flags, ConstInfo};
+ float ->
+ {bs_put_float, NewUnit, Flags, ConstInfo};
+ binary ->
+ {bs_put_binary, NewUnit, Flags}
+ end,
+ Primop = {hipe_bs_primop, Name},
+ {add_code([icode_guardop([Offset], Primop, Args, SL, FL),
+ icode_label(SL)], S1), NewAlign}
+ end;
+bitstr_gen_op([V], _Ctxt, SizeInfo, ConstInfo, Type, Flags, Base,
+ Offset) ->
+ case SizeInfo of
+ {all, _NewUnit, NewAlign, S} ->
+ Type = binary,
+ Name = {bs_put_binary_all, Flags},
+ Primop = {hipe_bs_primop, Name},
+ {add_code([icode_call_primop([Offset], Primop,
+ [V, Base, Offset])], S),
+ NewAlign};
+ {NewUnit, NewArgs, S, NewAlign} ->
+ Args = [V|NewArgs] ++ [Base, Offset],
+ Name =
+ case Type of
+ integer ->
+ {bs_put_integer, NewUnit, Flags, ConstInfo};
+ float ->
+ {bs_put_float, NewUnit, Flags, ConstInfo};
+ binary ->
+ {bs_put_binary, NewUnit, Flags}
+ end,
+ Primop = {hipe_bs_primop, Name},
+ {add_code([icode_call_primop([Offset], Primop, Args)], S),
+ NewAlign}
+ end.
+
+%% ---------------------------------------------------------------------
+%% Apply-expressions
+
+%% Note that the arity of the called function only depends on the length
+%% of the argument list; the arity stated by the function name is
+%% ignored.
+
+expr_apply(E, Ts, Ctxt, Env, S) ->
+ Op = cerl_lib:reduce_expr(cerl:apply_op(E)),
+ {Vs, S1} = expr_list(cerl:apply_args(E), Ctxt, Env, S),
+ case cerl:is_c_var(Op) of
+ true ->
+ case cerl:var_name(Op) of
+ {N, A} = V when is_atom(N), is_integer(A) ->
+ case env__lookup(V, Env) of
+ error ->
+ %% Assumed to be a function in the
+ %% current module; we don't check.
+ add_local_call(V, Vs, Ts, Ctxt, S1);
+ {ok, #'fun'{label = L, vars = Vs1}} ->
+ %% Call to a local letrec-bound function.
+ add_letrec_call(L, Vs1, Vs, Ctxt, S1);
+ {ok, #cerl_to_icode__var{}} ->
+ error_msg("cannot call via variable; must "
+ "be closure converted: ~P.",
+ [V, 5]),
+ throw(error)
+ end;
+ _ ->
+ error_nonlocal_application(Op),
+ throw(error)
+ end;
+ false ->
+ error_nonlocal_application(Op),
+ throw(error)
+ end.
+
+%% ---------------------------------------------------------------------
+%% Call-expressions
+
+%% Unless we know the module and function names statically, we have to
+%% go through the meta-call operator for a static number of arguments.
+
+expr_call(E, Ts, Ctxt, Env, S) ->
+ Module = cerl_lib:reduce_expr(cerl:call_module(E)),
+ Name = cerl_lib:reduce_expr(cerl:call_name(E)),
+ case cerl:is_c_atom(Module) and cerl:is_c_atom(Name) of
+ true ->
+ M = cerl:atom_val(Module),
+ F = cerl:atom_val(Name),
+ {Vs, S1} = expr_list(cerl:call_args(E), Ctxt, Env, S),
+ add_code(make_call(M, F, Ts, Vs, Ctxt), S1);
+ false ->
+ Args = cerl:call_args(E),
+ N = length(Args),
+ {Vs, S1} = expr_list([Module, Name | Args], Ctxt, Env, S),
+ add_code(make_op(?OP_APPLY_FIXARITY(N), Ts, Vs, Ctxt), S1)
+ end.
+
+%% ---------------------------------------------------------------------
+%% Primop calls
+
+%% Core Erlang primop calls are generally mapped directly to Icode
+%% primop calls, with a few exceptions (listed above), which are
+%% expanded inline, sometimes depending on context. Note that primop
+%% calls do not have specialized tail-call forms.
+
+expr_primop(E, Ts, Ctxt, Env, S) ->
+ Name = cerl:atom_val(cerl:primop_name(E)),
+ As = cerl:primop_args(E),
+ Arity = length(As),
+ expr_primop_0(Name, Arity, As, E, Ts, Ctxt, Env, S).
+
+expr_primop_0(Name, Arity, As, E, Ts, #ctxt{effect = true} = Ctxt, Env,
+ S) ->
+ case is_safe_op(Name, Arity) of
+ true ->
+ %% Just drop the operation; cf. 'expr_values(...)'.
+ {_, S1} = expr_list(As, Ctxt, Env, S),
+ S1;
+ false ->
+ expr_primop_1(Name, Arity, As, E, Ts,
+ Ctxt#ctxt{effect = false}, Env, S)
+ end;
+expr_primop_0(Name, Arity, As, E, Ts, Ctxt, Env, S) ->
+ expr_primop_1(Name, Arity, As, E, Ts, Ctxt, Env, S).
+
+%% Some primops must be caught before their arguments are visited.
+
+expr_primop_1(?PRIMOP_MAKE_FUN, 6, As, _E, Ts, Ctxt, Env, S) ->
+ primop_make_fun(As, Ts, Ctxt, Env, S);
+expr_primop_1(?PRIMOP_APPLY_FUN, 2, As, _E, Ts, Ctxt, Env, S) ->
+ primop_apply_fun(As, Ts, Ctxt, Env, S);
+expr_primop_1(?PRIMOP_FUN_ELEMENT, 2, As, _E, Ts, Ctxt, Env, S) ->
+ primop_fun_element(As, Ts, Ctxt, Env, S);
+expr_primop_1(?PRIMOP_DSETELEMENT, 3, As, _E, Ts, Ctxt, Env, S) ->
+ primop_dsetelement(As, Ts, Ctxt, Env, S);
+expr_primop_1(?PRIMOP_RECEIVE_SELECT, 0, _As, _E, Ts, Ctxt, _Env, S) ->
+ primop_receive_select(Ts, Ctxt, S);
+expr_primop_1(?PRIMOP_RECEIVE_NEXT, 0, _As, _E, _Ts, Ctxt, _Env, S) ->
+ primop_receive_next(Ctxt, S);
+%%expr_primop_1(?PRIMOP_IDENTITY, 1, [A], _E, Ts, Ctxt, Env, S) ->
+%% expr(A, Ts, Ctxt, Env, S); % used for unary plus
+expr_primop_1(?PRIMOP_NEG, 1, [A], _, Ts, Ctxt, Env, S) ->
+ E = cerl:c_primop(cerl:c_atom('-'), [cerl:c_int(0), A]),
+ expr_primop(E, Ts, Ctxt, Env, S);
+expr_primop_1(?PRIMOP_GOTO_LABEL, 1, [A], _, _Ts, _Ctxt, _Env, S) ->
+ primop_goto_label(A, S);
+expr_primop_1(?PRIMOP_REDUCTION_TEST, 0, [], _, _Ts, Ctxt, _Env, S) ->
+ primop_reduction_test(Ctxt, S);
+expr_primop_1(Name, Arity, As, E, Ts, Ctxt, Env, S) ->
+ case is_pure_op_aux(Name, Arity) of
+ true ->
+ boolean_expr(E, Ts, Ctxt, Env, S);
+ false ->
+ {Vs, S1} = expr_list(As, Ctxt, Env, S),
+ expr_primop_2(Name, Arity, Vs, Ts, Ctxt, S1)
+ end.
+
+expr_primop_2(?PRIMOP_ELEMENT, 2, Vs, Ts, Ctxt, S) ->
+ add_code(make_op(?OP_ELEMENT, Ts, Vs, Ctxt), S);
+expr_primop_2(?PRIMOP_BS_CONTEXT_TO_BINARY, 1, Vs, Ts, Ctxt, S) ->
+ add_code(make_op(?OP_BS_CONTEXT_TO_BINARY, Ts, Vs, Ctxt), S);
+expr_primop_2(?PRIMOP_EXIT, 1, [V], _Ts, Ctxt, S) ->
+ add_exit(V, Ctxt, S);
+expr_primop_2(?PRIMOP_THROW, 1, [V], _Ts, Ctxt, S) ->
+ add_throw(V, Ctxt, S);
+expr_primop_2(?PRIMOP_ERROR, 1, [V], _Ts, Ctxt, S) ->
+ add_error(V, Ctxt, S);
+expr_primop_2(?PRIMOP_ERROR, 2, [V, F], _Ts, Ctxt, S) ->
+ add_error(V, F, Ctxt, S);
+expr_primop_2(?PRIMOP_RETHROW, 2, [E, V], _Ts, Ctxt, S) ->
+ add_rethrow(E, V, Ctxt, S);
+expr_primop_2(Name, _Arity, Vs, Ts, Ctxt, S) ->
+ %% Other ops are assumed to be recognized by the backend.
+ add_code(make_op(Name, Ts, Vs, Ctxt), S).
+
+%% All of M, F, and A must be literals with the right types.
+%% V must represent a proper list.
+
+primop_make_fun([M, F, A, H, I, V] = As, [_T] = Ts, Ctxt, Env, S) ->
+ case cerl:is_c_atom(M) and
+ cerl:is_c_atom(F) and
+ cerl:is_c_int(A) and
+ cerl:is_c_int(H) and
+ cerl:is_c_int(I) and
+ cerl:is_c_list(V) of
+ true ->
+ Module = cerl:atom_val(M),
+ Name = cerl:atom_val(F),
+ Arity = cerl:int_val(A),
+ Hash = cerl:int_val(H),
+ Index = cerl:int_val(I),
+ {Vs, S1} = expr_list(cerl:list_elements(V),
+ Ctxt, Env, S),
+ add_code(make_op(?OP_MAKE_FUN(Module, Name, Arity,
+ Hash, Index),
+ Ts, Vs, Ctxt),
+ S1);
+ false ->
+ error_primop_badargs(?PRIMOP_MAKE_FUN, As),
+ throw(error)
+ end.
+
+%% V must represent a proper list.
+
+primop_apply_fun([F, V] = As, [_T] = Ts, Ctxt, Env, S) ->
+ case cerl:is_c_list(V) of
+ true ->
+ %% Note that the closure itself is passed as the last value.
+ {Vs, S1} = expr_list(cerl:list_elements(V) ++ [F],
+ Ctxt, Env, S),
+ case Ctxt#ctxt.final of
+ false ->
+ add_code([icode_call_fun(Ts, Vs)], S1);
+ true ->
+ add_code([icode_enter_fun(Vs)], S1)
+ end;
+ false ->
+ error_primop_badargs(?PRIMOP_APPLY_FUN, As),
+ throw(error)
+ end.
+
+primop_fun_element([N, F] = As, Ts, Ctxt, Env, S) ->
+ case cerl:is_c_int(N) of
+ true ->
+ V = make_var(),
+ S1 = expr(F, [V], Ctxt#ctxt{final = false, effect = false},
+ Env, S),
+ add_code(make_op(?OP_FUN_ELEMENT(cerl:int_val(N)),
+ Ts, [V], Ctxt),
+ S1);
+ false ->
+ error_primop_badargs(?PRIMOP_FUN_ELEMENT, As),
+ throw(error)
+ end.
+
+primop_goto_label(A, S) ->
+ {Label,S1} = s__get_label(A, S),
+ add_code([icode_goto(Label)], S1).
+
+is_goto(E) ->
+ case cerl:type(E) of
+ primop ->
+ Name = cerl:atom_val(cerl:primop_name(E)),
+ As = cerl:primop_args(E),
+ Arity = length(As),
+ case {Name, Arity} of
+ {?PRIMOP_GOTO_LABEL, 1} ->
+ true;
+ _ ->
+ false
+ end;
+ _ ->
+ false
+ end.
+
+primop_reduction_test(Ctxt, S) ->
+ add_code(make_op(?OP_REDTEST, [], [], Ctxt), S).
+
+primop_dsetelement([N | As1] = As, Ts, Ctxt, Env, S) ->
+ case cerl:is_c_int(N) of
+ true ->
+ {Vs, S1} = expr_list(As1, Ctxt, Env, S),
+ add_code(make_op(?OP_UNSAFE_SETELEMENT(cerl:int_val(N)),
+ Ts, Vs, Ctxt),
+ S1);
+ false ->
+ error_primop_badargs(?PRIMOP_DSETELEMENT, As),
+ throw(error)
+ end.
+
+%% ---------------------------------------------------------------------
+%% Try-expressions:
+
+%% We want to rewrite trivial things like `try A of X -> B catch ...',
+%% where A is safe, into a simple let-binding `let X = A in B', avoiding
+%% unnecessary try-blocks. (The `let' might become further simplified.)
+
+expr_try(E, Ts, Ctxt, Env, S) ->
+ F = fun (BF, CtxtF, EnvF, SF) -> expr(BF, Ts, CtxtF, EnvF, SF) end,
+ expr_try_1(E, F, Ctxt, Env, S).
+
+expr_try_1(E, F, Ctxt, Env, S) ->
+ A = cerl:try_arg(E),
+ case is_safe_expr(A) of
+ true ->
+ E1 = cerl:c_let(cerl:try_vars(E), A, cerl:try_body(E)),
+ expr_let_1(E1, F, Ctxt, Env, S);
+ false ->
+ expr_try_2(E, F, Ctxt, Env, S)
+ end.
+
+%% TODO: maybe skip begin_try/end_try and just use fail-labels...
+
+expr_try_2(E, F, Ctxt, Env, S) ->
+ Cont = new_continuation_label(Ctxt),
+ Catch = new_label(),
+ Next = new_label(),
+ S1 = add_code([icode_begin_try(Catch,Next),icode_label(Next)], S),
+ Vars = cerl:try_vars(E),
+ Vs = make_vars(length(Vars)),
+ Ctxt1 = Ctxt#ctxt{final = false},
+ S2 = expr(cerl:try_arg(E), Vs, Ctxt1, Env, S1),
+ Env1 = bind_vars(Vars, Vs, Env),
+ S3 = add_code([icode_end_try()], S2),
+ S4 = F(cerl:try_body(E), Ctxt, Env1, S3),
+ S5 = add_continuation_jump(Cont, Ctxt, S4),
+ EVars = cerl:try_evars(E),
+ EVs = make_vars(length(EVars)),
+ Env2 = bind_vars(EVars, EVs, Env),
+ S6 = add_code([icode_label(Catch), icode_begin_handler(EVs)], S5),
+ S7 = F(cerl:try_handler(E), Ctxt, Env2, S6),
+ add_continuation_label(Cont, Ctxt, S7).
+
+%% ---------------------------------------------------------------------
+%% Letrec-expressions (local goto-labels)
+
+%% We only handle letrec-functions as continuations. The fun-bodies are
+%% always compiled in the same context as the main letrec-body. Note
+%% that we cannot propagate "advanced" contexts like boolean-compilation
+%% into the letrec body like we do for ordinary lets or seqs, since the
+%% context for an individual local function would be depending on the
+%% contexts of its call sites.
+
+expr_letrec(E, Ts, Ctxt, Env, S) ->
+ Ds = cerl:letrec_defs(E),
+ Env1 = add_defs(Ds, Env),
+ S1 = expr(cerl:letrec_body(E), Ts, Ctxt, Env1, S),
+ Next = new_continuation_label(Ctxt),
+ S2 = add_continuation_jump(Next, Ctxt, S1),
+ S3 = defs(Ds, Ts, Ctxt, Env1, S2),
+ add_continuation_label(Next, Ctxt, S3).
+
+add_defs([{V, _F} | Ds], Env) ->
+ {_, A} = cerl:var_name(V),
+ Vs = make_vars(A),
+ L = new_label(),
+ Env1 = bind_fun(V, L, Vs, Env),
+ add_defs(Ds, Env1);
+add_defs([], Env) ->
+ Env.
+
+defs([{V, F} | Ds], Ts, Ctxt, Env, S) ->
+ Name = cerl:var_name(V),
+ #'fun'{label = L, vars = Vs} = env__get(Name, Env),
+ S1 = add_code([icode_label(L)], S),
+ Env1 = bind_vars(cerl:fun_vars(F), Vs, Env),
+ S2 = expr(cerl:fun_body(F), Ts, Ctxt, Env1, S1),
+ defs(Ds, Ts, Ctxt, Env, S2);
+defs([], _Ts, _Ctxt, _Env, S) ->
+ S.
+
+%% ---------------------------------------------------------------------
+%% Receive-expressions
+
+%% There may only be exactly one clause, which must be a trivial
+%% catch-all with exactly one (variable) pattern. Each message will be
+%% read from the mailbox and bound to the pattern variable; the body of
+%% the clause must do the switching and call either of the primops
+%% `receive_select/0' or `receive_next/0'.
+
+expr_receive(E, Ts, Ctxt, Env, S) ->
+ F = fun (BF, CtxtF, EnvF, SF) -> expr(BF, Ts, CtxtF, EnvF, SF) end,
+ expr_receive_1(E, F, Ctxt, Env, S).
+
+expr_receive_1(E, F, Ctxt, Env, S) ->
+ case cerl:receive_clauses(E) of
+ [C] ->
+ case cerl:clause_pats(C) of
+ [_] ->
+ case cerl_clauses:is_catchall(C) of
+ true ->
+ expr_receive_2(C, E, F, Ctxt, Env, S);
+ false ->
+ error_msg("receive-expression clause "
+ "must be a catch-all."),
+ throw(error)
+ end;
+ _ ->
+ error_msg("receive-expression clause must "
+ "have exactly one pattern."),
+ throw(error)
+ end;
+ _ ->
+ error_msg("receive-expressions must have "
+ "exactly one clause."),
+ throw(error)
+ end.
+
+%% There are a number of primitives to do the work involved in receiving
+%% messages:
+%%
+%% if-tests: suspend_msg_timeout()
+%%
+%% primops: V = check_get_msg()
+%% select_msg()
+%% next_msg()
+%% set_timeout(T)
+%% clear_timeout()
+%% suspend_msg()
+%%
+%% `check_get_msg' tests if the mailbox is empty or not, and if not it
+%% reads the message currently pointed to by the implicit message pointer.
+%% `select_msg' removes the current message from the mailbox, resets the
+%% message pointer and clears any timeout. `next_msg' advances the
+%% message pointer but does nothing else. `set_timeout(T)' sets up the
+%% timeout mechanism *unless it is already set*. `suspend_msg' suspends
+%% until a message has arrived and does not check for timeout. The test
+%% `suspend_msg_timeout' suspends the process and upon resuming
+%% execution selects the `true' branch if a message has arrived and the
+%% `false' branch otherwise. `clear_timeout' resets the message pointer
+%% when a timeout has occurred (the name is somewhat misleading).
+%%
+%% Note: the receiving of a message must be performed so that the
+%% message pointer is always reset when the receive is done; thus, all
+%% paths must go through either `select_msg' or `clear_timeout'.
+
+%% Recall that the `final' and `effect' context flags distribute over
+%% the clauses *and* the timeout action (but not over the
+%% timeout-expression, which is always executed for its value).
+
+%% This is the code we generate for a full receive:
+%%
+%% Loop: check_get_msg(Match, Wait)
+%% Wait: set_timeout
+%% suspend_msg_timeout(Loop, Timeout)
+%% Timeout: clear_timeout
+%% TIMEOUT-ACTION
+%% goto Next
+%% Match: RECEIVE-CLAUSES(Loop, Next)
+%% Next: ...
+%%
+%% For a receive with infinity timout, we generate
+%%
+%% Wait: suspend_msg
+%% goto Loop
+%%
+%% For a receive with zero timout, we generate
+%%
+%% Wait: clear_timeout
+%% TIMEOUT-ACTION
+%% goto Next
+
+expr_receive_2(C, E, F, Ctxt, Env, S0) ->
+ Expiry = cerl_lib:reduce_expr(cerl:receive_timeout(E)),
+ After = case cerl:is_literal(Expiry) of
+ true ->
+ cerl:concrete(Expiry);
+ false ->
+ undefined
+ end,
+ T = make_var(), % T will hold the timeout value
+ %% It would be harmless to generate code for `infinity', but we
+ %% might as well avoid it if we can.
+ S1 = if After =:= 'infinity' -> S0;
+ true ->
+ expr(Expiry, [T],
+ Ctxt#ctxt{final = false, effect = false},
+ Env, S0)
+ end,
+
+ %% This is the top of the receive-loop, which checks if the
+ %% mailbox is empty, and otherwise reads the next message.
+ Loop = new_label(),
+ Wait = new_label(),
+ Match = new_label(),
+ V = make_var(),
+ S2 = add_code([icode_label(Loop),
+ icode_call_primop([V], ?OP_CHECK_GET_MESSAGE, [],
+ Match, Wait),
+ icode_label(Wait)], S1),
+
+ %% The wait-for-message section looks a bit different depending on
+ %% whether we actually need to set a timer or not.
+ Ctxt0 = #ctxt{},
+ S3 = case After of
+ 'infinity' ->
+ %% Only wake up when we get new messages, and never
+ %% execute the expiry body.
+ add_code(make_op(?OP_WAIT_FOR_MESSAGE, [], [], Ctxt0)
+ ++ [icode_goto(Loop)], S2);
+ 0 ->
+ %% Zero limit - reset the message pointer (this is what
+ %% "clear timeout" does) and execute the expiry body.
+ add_code(make_op(?OP_CLEAR_TIMEOUT, [], [], Ctxt0),
+ S2);
+ _ ->
+ %% Other value - set the timer (if it is already set,
+ %% nothing is changed) and wait for a message or
+ %% timeout. Reset the message pointer upon timeout.
+ Timeout = new_label(),
+ add_code(make_op(?OP_SET_TIMEOUT, [], [T], Ctxt0)
+ ++ [make_if(?TEST_WAIT_FOR_MESSAGE_OR_TIMEOUT,
+ [], Loop, Timeout),
+ icode_label(Timeout)]
+ ++ make_op(?OP_CLEAR_TIMEOUT, [], [], Ctxt0),
+ S2)
+ end,
+
+ %% We never generate code for the expiry body if the timeout value
+ %% is 'infinity' (and thus we know that it will not be used), mainly
+ %% because in this case it is possible (and legal) for the expiry
+ %% body to not have the expected degree. (Typically, it produces a
+ %% single constant value such as 'true', while the clauses may be
+ %% producing 2 or more values.)
+ Next = new_continuation_label(Ctxt),
+ S4 = if After =:= 'infinity' -> S3;
+ true ->
+ add_continuation_jump(Next, Ctxt,
+ F(cerl:receive_action(E), Ctxt,
+ Env, S3))
+ end,
+
+ %% When we compile the primitive operations that select the current
+ %% message or loop to try the next message (see the functions
+ %% 'primop_receive_next' and 'primop_receive_select'), we will use
+ %% the receive-loop label in the context (i.e., that of the nearest
+ %% enclosing receive expression).
+ Ctxt1 = Ctxt#ctxt{'receive' = #'receive'{loop = Loop}},
+
+ %% The pattern variable of the clause will be mapped to `V', which
+ %% holds the message, so it can be accessed in the clause body:
+ S5 = clauses([C], F, [V], Ctxt1, Env,
+ add_code([icode_label(Match)], S4)),
+ add_continuation_label(Next, Ctxt, S5).
+
+%% Primops supporting "expanded" receive-expressions on the Core level:
+
+primop_receive_next(#ctxt{'receive' = R} = Ctxt, S0) ->
+ case R of
+ #'receive'{loop = Loop} ->
+ %% Note that this has the same "problem" as the fail
+ %% instruction (see the 'add_fail' function), namely, that
+ %% it unexpectedly ends a basic block. The solution is the
+ %% same - add a dummy label if necessary.
+ S1 = add_code(make_op(?OP_NEXT_MESSAGE, [], [], #ctxt{})
+ ++ [icode_goto(Loop)], S0),
+ add_new_continuation_label(Ctxt, S1);
+ _ ->
+ error_not_in_receive(?PRIMOP_RECEIVE_NEXT),
+ throw(error)
+ end.
+
+primop_receive_select(Ts, #ctxt{'receive' = R} = Ctxt, S) ->
+ case R of
+ #'receive'{} ->
+ add_code(make_op(?OP_SELECT_MESSAGE, Ts, [], Ctxt), S);
+ _ ->
+ error_not_in_receive(?PRIMOP_RECEIVE_SELECT),
+ throw(error)
+ end.
+
+%% ---------------------------------------------------------------------
+%% Case expressions
+
+%% Typically, pattern matching compilation has split all switches into
+%% separate groups of tuples, integers, atoms, etc., where each such
+%% switch over a group of constructors is protected by a type test.
+%% Thus, it is straightforward to generate switch instructions. (If no
+%% pattern matching compilation has been done, we don't care about
+%% efficiency anyway, so we don't spend any extra effort here.)
+
+expr_case(E, Ts, Ctxt, Env, S) ->
+ F = fun (BF, CtxtF, EnvF, SF) -> expr(BF, Ts, CtxtF, EnvF, SF) end,
+ expr_case_1(E, F, Ctxt, Env, S).
+
+expr_case_1(E, F, Ctxt, Env, S) ->
+ Cs = cerl:case_clauses(E),
+ A = cerl:case_arg(E),
+ case cerl_lib:is_bool_switch(Cs) of
+ true ->
+ %% An if-then-else with a known boolean argument
+ {True, False} = cerl_lib:bool_switch_cases(Cs),
+ bool_switch(A, True, False, F, Ctxt, Env, S);
+ false ->
+ Vs = make_vars(cerl:clause_arity(hd(Cs))),
+ Ctxt1 = Ctxt#ctxt{final = false, effect = false},
+ S1 = expr(A, Vs, Ctxt1, Env, S),
+ expr_case_2(Vs, Cs, F, Ctxt, Env, S1)
+ end.
+
+%% Switching on a value
+
+expr_case_2(Vs, Cs, F, Ctxt, Env, S1) ->
+ case is_constant_switch(Cs) of
+ true ->
+ switch_val_clauses(Cs, F, Vs, Ctxt, Env, S1);
+ false ->
+ case is_tuple_switch(Cs) of
+ true ->
+ switch_tuple_clauses(Cs, F, Vs, Ctxt, Env, S1);
+ false ->
+ case is_binary_switch(Cs, S1) of
+ true ->
+ switch_binary_clauses(Cs, F, Vs, Ctxt, Env, S1);
+ false ->
+ clauses(Cs, F, Vs, Ctxt, Env, S1)
+ end
+ end
+ end.
+
+%% Check if a list of clauses represents a switch over a number (more
+%% than 1) of constants (integers or atoms), or tuples (whose elements
+%% are all variables)
+
+is_constant_switch(Cs) ->
+ is_switch(Cs, fun (P) -> (cerl:type(P) =:= literal) andalso
+ (is_integer(cerl:concrete(P))
+ orelse is_atom(cerl:concrete(P))) end).
+
+is_tuple_switch(Cs) ->
+ is_switch(Cs, fun (P) -> cerl:is_c_tuple(P) andalso
+ all_vars(cerl:tuple_es(P)) end).
+
+is_binary_switch(Cs, S) ->
+ case s__get_pmatch(S) of
+ False when False =:= false; False =:= undefined ->
+ false;
+ Other when Other =:= duplicate_all; Other =:= no_duplicates; Other =:= true->
+ is_binary_switch1(Cs, 0)
+ end.
+
+is_binary_switch1([C|Cs], N) ->
+ case cerl:clause_pats(C) of
+ [P] ->
+ case cerl:is_c_binary(P) of
+ true ->
+ is_binary_switch1(Cs, N + 1);
+ false ->
+ %% The final clause may be a catch-all.
+ Cs =:= [] andalso N > 0 andalso cerl:type(P) =:= var
+ end;
+ _ ->
+ false
+ end;
+is_binary_switch1([], N) ->
+ N > 0.
+
+all_vars([E | Es]) ->
+ case cerl:is_c_var(E) of
+ true -> all_vars(Es);
+ false -> false
+ end;
+all_vars([]) -> true.
+
+is_switch(Cs, F) ->
+ is_switch(Cs, F, 0).
+
+is_switch([C | Cs], F, N) ->
+ case cerl_lib:is_simple_clause(C) of
+ true ->
+ [P] = cerl:clause_pats(C),
+ case F(P) of
+ true ->
+ is_switch(Cs, F, N + 1);
+ false ->
+ %% The final clause may be a catch-all.
+ Cs =:= [] andalso N > 1 andalso cerl:type(P) =:= var
+ end;
+ false -> false
+ end;
+is_switch([], _F, N) ->
+ N > 1.
+
+switch_val_clauses(Cs, F, Vs, Ctxt, Env, S) ->
+ switch_clauses(Cs, F, Vs, Ctxt, Env,
+ fun (P) -> cerl:concrete(P) end,
+ fun icode_switch_val/4,
+ fun val_clause_body/9,
+ S).
+
+val_clause_body(_N, _V, C, F, Next, _Fail, Ctxt, Env, S) ->
+ clause_body(C, F, Next, Ctxt, Env, S).
+
+switch_tuple_clauses(Cs, F, Vs, Ctxt, Env, S) ->
+ switch_clauses(Cs, F, Vs, Ctxt, Env,
+ fun (P) -> cerl:tuple_arity(P) end,
+ fun icode_switch_tuple_arity/4,
+ fun tuple_clause_body/9,
+ S).
+
+tuple_clause_body(N, V, C, F, Next, Fail, Ctxt, Env, S0) ->
+ Vs = make_vars(N),
+ S1 = tuple_elements(Vs, V, S0),
+ Es = cerl:tuple_es(hd(cerl:clause_pats(C))),
+ {Env1, S2} = patterns(Es, Vs, Fail, Env, S1),
+ clause_body(C, F, Next, Ctxt, Env1, S2).
+
+switch_clauses(Cs, F, [V], Ctxt, Env, GetVal, Switch, Body, S0) ->
+ Cs1 = [switch_clause(C, GetVal) || C <- Cs],
+ Cases = [{Val, L} || {Val, L, _} <- Cs1],
+ Default = [C || {default, C} <- Cs1],
+ Fail = new_label(),
+ S1 = add_code([Switch(V, Fail, length(Cases), Cases)], S0),
+ Next = new_continuation_label(Ctxt),
+ S3 = case Default of
+ [] -> add_default_case(Fail, Ctxt, S1);
+ [C] ->
+ %% Bind the catch-all variable (this always succeeds)
+ {Env1, S2} = patterns(cerl:clause_pats(C), [V], Fail,
+ Env, S1),
+ clause_body(C, F, Next, Ctxt, Env1,
+ add_code([icode_label(Fail)], S2))
+ end,
+ S4 = switch_cases(Cs1, V, F, Next, Fail, Ctxt, Env, Body, S3),
+ add_continuation_label(Next, Ctxt, S4).
+
+switch_clause(C, F) ->
+ [P] = cerl:clause_pats(C),
+ L = new_label(),
+ case cerl:type(P) of
+ var -> {default, C};
+ _ -> {icode_const(F(P)), L, C}
+ end.
+
+switch_binary_clauses(Cs, F, Vs, Ctxt, Env, S) ->
+ {Bins, Default} = get_binary_clauses(Cs),
+ Fail = new_label(),
+ Next = new_continuation_label(Ctxt),
+ S1 = binary_match(Bins, F, Vs, Next, Fail, Ctxt, Env, S),
+ S2 = case Default of
+ [] -> add_default_case(Fail, Ctxt, S1);
+ [C] ->
+ clause_body(C, F, Next, Ctxt, Env,
+ add_code([icode_label(Fail)], S1))
+ end,
+ add_continuation_label(Next, Ctxt, S2).
+
+get_binary_clauses(Cs) ->
+ get_binary_clauses(Cs, []).
+
+get_binary_clauses([C|Cs], Acc) ->
+ [P] = cerl:clause_pats(C),
+ case cerl:is_c_binary(P) of
+ true ->
+ get_binary_clauses(Cs, [C|Acc]);
+ false ->
+ {lists:reverse(Acc),[C]}
+ end;
+get_binary_clauses([], Acc) ->
+ {lists:reverse(Acc),[]}.
+
+switch_cases([{N, L, C} | Cs], V, F, Next, Fail, Ctxt, Env, Body, S0) ->
+ S1 = add_code([icode_label(L)], S0),
+ S2 = Body(icode_const_val(N), V, C, F, Next, Fail, Ctxt, Env, S1),
+ switch_cases(Cs, V, F, Next, Fail, Ctxt, Env, Body, S2);
+switch_cases([_ | Cs], V, F, Next, Fail, Ctxt, Env, Body, S) ->
+ switch_cases(Cs, V, F, Next, Fail, Ctxt, Env, Body, S);
+switch_cases([], _V, _F, _Next, _Fail, _Ctxt, _Env, _Body, S) ->
+ S.
+
+%% Recall that the `final' and `effect' context flags distribute over
+%% the clause bodies.
+
+clauses(Cs, F, Vs, Ctxt, Env, S) ->
+ Next = new_continuation_label(Ctxt),
+ S1 = clauses_1(Cs, F, Vs, undefined, Next, Ctxt, Env, S),
+ add_continuation_label(Next, Ctxt, S1).
+
+clauses_1([C | Cs], F, Vs, Fail, Next, Ctxt, Env, S) ->
+ case cerl_clauses:is_catchall(C) of
+ true ->
+ %% The fail label will not actually be used in this case.
+ clause(C, F, Vs, Fail, Next, Ctxt, Env, S);
+ false ->
+ %% The previous `Fail' is not used here.
+ Fail1 = new_label(),
+ S1 = clause(C, F, Vs, Fail1, Next, Ctxt, Env, S),
+ S2 = add_code([icode_label(Fail1)], S1),
+ clauses_1(Cs, F, Vs, Fail1, Next, Ctxt, Env, S2)
+ end;
+clauses_1([], _F, _Vs, Fail, _Next, Ctxt, _Env, S) ->
+ if Fail =:= undefined ->
+ L = new_label(),
+ add_default_case(L, Ctxt, S);
+ true ->
+ add_code([icode_goto(Fail)], S) % use existing label
+ end.
+
+%% The exact behaviour if all clauses fail is undefined; we generate an
+%% 'internal_error' exception if this happens, which is safe and will
+%% not get in the way of later analyses. (Continuing execution after the
+%% `case', as in a C `switch' statement, would add a new possible path
+%% to the program, which could destroy program properties.) Note that
+%% this code is only generated if some previous stage has created a
+%% switch over clauses without a final catch-all; this could be both
+%% legal and non-redundant, e.g. if the last clause does pattern
+%% matching to extract components of a (known) constructor. The
+%% generated default-case code *should* be unreachable, but we need it
+%% in order to have a safe fail-label.
+
+add_default_case(L, Ctxt, S) ->
+ S1 = add_code([icode_label(L)], S),
+ add_error(icode_const(internal_error), Ctxt, S1).
+
+clause(C, F, Vs, Fail, Next, Ctxt, Env, S) ->
+ G = cerl:clause_guard(C),
+ case cerl_clauses:eval_guard(G) of
+ {value, true} ->
+ {Env1, S1} = patterns(cerl:clause_pats(C), Vs, Fail, Env,
+ S),
+ clause_body(C, F, Next, Ctxt, Env1, S1);
+ {value, false} ->
+ add_code([icode_goto(Fail)], S);
+ _ ->
+ {Env1, S1} = patterns(cerl:clause_pats(C), Vs, Fail, Env,
+ S),
+ Succ = new_label(),
+ Ctxt1 = Ctxt#ctxt{final = false,
+ fail = Fail,
+ class = guard},
+ S2 = boolean(G, Succ, Fail, Ctxt1, Env1, S1),
+ S3 = add_code([icode_label(Succ)], S2),
+ clause_body(C, F, Next, Ctxt, Env1, S3)
+ end.
+
+clause_body(C, F, Next, Ctxt, Env, S) ->
+ %% This check is inserted as a goto is always final
+ case is_goto(cerl:clause_body(C)) of
+ true ->
+ F(cerl:clause_body(C), Ctxt, Env, S);
+ false ->
+ S1 = F(cerl:clause_body(C), Ctxt, Env, S),
+ add_continuation_jump(Next, Ctxt, S1)
+ end.
+
+patterns([P | Ps], [V | Vs], Fail, Env, S) ->
+ {Env1, S1} = pattern(P, V, Fail, Env, S),
+ patterns(Ps, Vs, Fail, Env1, S1);
+patterns([], [], _, Env, S) ->
+ {Env, S}.
+
+pattern(P, V, Fail, Env, S) ->
+ case cerl:type(P) of
+ var ->
+ {bind_var(P, V, Env), S};
+ alias ->
+ {Env1, S1} = pattern(cerl:alias_pat(P), V,
+ Fail, Env, S),
+ {bind_var(cerl:alias_var(P), V, Env1), S1};
+ literal ->
+ {Env, literal_pattern(P, V, Fail, S)};
+ cons ->
+ cons_pattern(P, V, Fail, Env, S);
+ tuple ->
+ tuple_pattern(P, V, Fail, Env, S);
+ binary ->
+ binary_pattern(P, V, Fail, Env, S)
+ end.
+
+literal_pattern(P, V, Fail, S) ->
+ L = new_label(),
+ S1 = literal_pattern_1(P, V, Fail, L, S),
+ add_code([icode_label(L)], S1).
+
+literal_pattern_1(P, V, Fail, Next, S) ->
+ case cerl:concrete(P) of
+ X when is_atom(X) ->
+ add_code([make_type([V], ?TYPE_ATOM(X), Next, Fail)],
+ S);
+ X when is_integer(X) ->
+ add_code([make_type([V], ?TYPE_INTEGER(X), Next, Fail)],
+ S);
+ X when is_float(X) ->
+ V1 = make_var(),
+ L = new_label(),
+ %% First doing an "is float" test here might allow later
+ %% stages to use a specialized equality test.
+ add_code([make_type([V], ?TYPE_IS_FLOAT, L, Fail),
+ icode_label(L),
+ icode_move(V1, icode_const(X)),
+ make_if(?TEST_EQ, [V, V1], Next, Fail)],
+ S);
+ [] ->
+ add_code([make_type([V], ?TYPE_NIL, Next, Fail)], S);
+ X ->
+ %% Compound constants are compared with the generic exact
+ %% equality test.
+ V1 = make_var(),
+ add_code([icode_move(V1, icode_const(X)),
+ make_if(?TEST_EXACT_EQ, [V, V1], Next, Fail)],
+ S)
+ end.
+
+cons_pattern(P, V, Fail, Env, S) ->
+ V1 = make_var(),
+ V2 = make_var(),
+ Next = new_label(),
+ Ctxt = #ctxt{},
+ S1 = add_code([make_type([V], ?TYPE_CONS, Next, Fail),
+ icode_label(Next)]
+ ++ make_op(?OP_UNSAFE_HD, [V1], [V], Ctxt)
+ ++ make_op(?OP_UNSAFE_TL, [V2], [V], Ctxt),
+ S),
+ patterns([cerl:cons_hd(P), cerl:cons_tl(P)], [V1, V2],
+ Fail, Env, S1).
+
+tuple_pattern(P, V, Fail, Env, S) ->
+ Es = cerl:tuple_es(P),
+ N = length(Es),
+ Vs = make_vars(N),
+ Next = new_label(),
+ S1 = add_code([make_type([V], ?TYPE_IS_N_TUPLE(N), Next, Fail),
+ icode_label(Next)],
+ S),
+ S2 = tuple_elements(Vs, V, S1),
+ patterns(Es, Vs, Fail, Env, S2).
+
+tuple_elements(Vs, V, S) ->
+ tuple_elements(Vs, V, #ctxt{}, 1, S).
+
+tuple_elements([V1 | Vs], V0, Ctxt, N, S) ->
+ Code = make_op(?OP_UNSAFE_ELEMENT(N), [V1], [V0], Ctxt),
+ tuple_elements(Vs, V0, Ctxt, N + 1, add_code(Code, S));
+tuple_elements([], _, _, _, S) ->
+ S.
+
+binary_pattern(P, V, Fail, Env, S) ->
+ L1 = new_label(),
+ Segs = cerl:binary_segments(P),
+ Arity = length(Segs),
+ Vars = make_vars(Arity),
+ MS = make_var(),
+ Primop1 = {hipe_bs_primop, {bs_start_match,0}},
+ S1 = add_code([icode_guardop([MS], Primop1, [V], L1, Fail),
+ icode_label(L1)],S),
+ {Env1,S2} = bin_seg_patterns(Segs, Vars, MS, Fail, Env, S1, false),
+ L2 = new_label(),
+ Primop2 = {hipe_bs_primop, {bs_test_tail, 0}},
+ {Env1, add_code([icode_guardop([], Primop2, [MS], L2, Fail),
+ icode_label(L2)], S2)}.
+
+bin_seg_patterns([Seg|Rest], [T|Ts], MS, Fail, Env, S, Align) ->
+ {{NewEnv, S1}, NewAlign} = bin_seg_pattern(Seg, T, MS, Fail, Env, S, Align),
+ bin_seg_patterns(Rest, Ts, MS, Fail, NewEnv, S1, NewAlign);
+
+bin_seg_patterns([], [], _MS, _Fail, Env, S, _Align) ->
+ {Env, S}.
+
+bin_seg_pattern(P, V, MS, Fail, Env, S, Align) ->
+ L = new_label(),
+ Size = cerl:bitstr_size(P),
+ Unit = cerl:bitstr_unit(P),
+ Type = cerl:concrete(cerl:bitstr_type(P)),
+ LiteralFlags = cerl:bitstr_flags(P),
+ T = cerl:bitstr_val(P),
+ Flags = translate_flags(LiteralFlags, Align),
+ case calculate_size(Unit, Size, false, Env, S) of
+ {all, NewUnit, NewAlign, S0} ->
+ Type = binary,
+ Name = {bs_get_binary_all_2, NewUnit, Flags},
+ Primop = {hipe_bs_primop, Name},
+ S1 = add_code([icode_guardop([V,MS], Primop, [MS], L, Fail),
+ icode_label(L)], S0),
+ {pattern(T, V, Fail, Env, S1), NewAlign};
+ {NewUnit, Args, S0, NewAlign} ->
+ Name =
+ case Type of
+ integer ->
+ {bs_get_integer, NewUnit, Flags};
+ float ->
+ {bs_get_float, NewUnit, Flags};
+ binary ->
+ {bs_get_binary, NewUnit, Flags}
+ end,
+ Primop = {hipe_bs_primop, Name},
+ S1 = add_code([icode_guardop([V,MS], Primop, [MS|Args], L, Fail),
+ icode_label(L)], S0),
+ {pattern(T, V, Fail, Env, S1), NewAlign}
+ end.
+
+%% ---------------------------------------------------------------------
+%% Boolean expressions
+
+%% This generates code for a boolean expression (such as "primop
+%% 'and'(X, Y)") in a normal expression context, when an actual `true'
+%% or `false' value is to be computed. We set up a default fail-label
+%% for generating a `badarg' error, unless we are in a guard.
+
+boolean_expr(E, [V], Ctxt=#ctxt{class = guard}, Env, S) ->
+ {Code, True, False} = make_bool_glue(V),
+ S1 = boolean(E, True, False, Ctxt, Env, S),
+ add_code(Code, S1);
+boolean_expr(E, [V] = Ts, Ctxt, Env, S) ->
+ {Code, True, False} = make_bool_glue(V),
+ Fail = new_label(),
+ Cont = new_continuation_label(Ctxt),
+ Ctxt1 = Ctxt#ctxt{final = false, effect = false, fail = Fail},
+ S1 = boolean(E, True, False, Ctxt1, Env, S),
+ S2 = maybe_return(Ts, Ctxt, add_code(Code, S1)),
+ S3 = add_continuation_jump(Cont, Ctxt, S2),
+ S4 = add_code([icode_label(Fail)], S3),
+ S5 = add_error(icode_const(badarg), Ctxt, S4), % can add dummy label
+ S6 = add_continuation_jump(Cont, Ctxt, S5), % avoid empty basic block
+ add_continuation_label(Cont, Ctxt, S6);
+boolean_expr(_, [], _Ctxt, _Env, _S) ->
+ error_high_degree(),
+ throw(error);
+boolean_expr(_, _, _Ctxt, _Env, _S) ->
+ error_low_degree(),
+ throw(error).
+
+%% This is for when we expect a boolean result in jumping code context,
+%% but are not sure what the expression will produce, or we know that
+%% the result is not a boolean and we just want error handling.
+
+expect_boolean_value(E, True, False, Ctxt, Env, S) ->
+ V = make_var(),
+ S1 = expr(E, [V], Ctxt#ctxt{final = false}, Env, S),
+ case Ctxt#ctxt.fail of
+ [] ->
+ %% No fail-label set - this means we are *sure* that the
+ %% result can only be 'true' or 'false'.
+ add_code([make_type([V], ?TYPE_ATOM(true), True, False)],
+ S1);
+ Fail ->
+ Next = new_label(),
+ add_code([make_type([V], ?TYPE_ATOM(true), True, Next),
+ icode_label(Next),
+ make_type([V], ?TYPE_ATOM(false), False, Fail)],
+ S1)
+ end.
+
+%% This generates code for a case-switch with exactly one 'true' branch
+%% and one 'false' branch, and no other branches (not even a catch-all).
+%% Note that E must be guaranteed to produce a boolean value for such a
+%% switch to have been generated.
+
+bool_switch(E, TrueExpr, FalseExpr, F, Ctxt, Env, S) ->
+ Cont = new_continuation_label(Ctxt),
+ True = new_label(),
+ False = new_label(),
+ Ctxt1 = Ctxt#ctxt{final = false, effect = false},
+ S1 = boolean(E, True, False, Ctxt1, Env, S),
+ S2 = add_code([icode_label(True)], S1),
+ S3 = F(TrueExpr, Ctxt, Env, S2),
+ S4 = add_continuation_jump(Cont, Ctxt, S3),
+ S5 = add_code([icode_label(False)], S4),
+ S6 = F(FalseExpr, Ctxt, Env, S5),
+ add_continuation_label(Cont, Ctxt, S6).
+
+%% This generates jumping code for booleans. If the fail-label is set,
+%% it tells where to go in case a value turns out not to be a boolean.
+
+%% In strict boolean expressions, we set a flag to be checked if
+%% necessary after both branches have been evaluated. An alternative
+%% would be to duplicate the code for the second argument, for each
+%% value ('true' or 'false') of the first argument.
+
+%% (Note that subexpressions are checked repeatedly to see if they are
+%% safe - this is quadratic, but I don't expect booleans to be very
+%% deeply nested.)
+
+%% Note that 'and', 'or' and 'xor' are strict (like all primops)!
+
+boolean(E0, True, False, Ctxt, Env, S) ->
+ E = cerl_lib:reduce_expr(E0),
+ case cerl:type(E) of
+ literal ->
+ case cerl:concrete(E) of
+ true ->
+ add_code([icode_goto(True)], S);
+ false ->
+ add_code([icode_goto(False)], S);
+ _ ->
+ expect_boolean_value(E, True, False, Ctxt, Env, S)
+ end;
+ values ->
+ case cerl:values_es(E) of
+ [E1] ->
+ boolean(E1, True, False, Ctxt, Env, S);
+ _ ->
+ error_msg("degree mismatch - expected boolean: ~P",
+ [E, 10]),
+ throw(error)
+ end;
+ primop ->
+ Name = cerl:atom_val(cerl:primop_name(E)),
+ As = cerl:primop_args(E),
+ Arity = length(As),
+ case {Name, Arity} of
+ {?PRIMOP_NOT, 1} ->
+ %% `not' simply switches true and false labels.
+ [A] = As,
+ boolean(A, False, True, Ctxt, Env, S);
+ {?PRIMOP_AND, 2} ->
+ strict_and(As, True, False, Ctxt, Env, S);
+ {?PRIMOP_OR, 2} ->
+ strict_or(As, True, False, Ctxt, Env, S);
+ {?PRIMOP_XOR, 2} ->
+ %% `xor' always needs to evaluate both arguments
+ strict_xor(As, True, False, Ctxt, Env, S);
+ _ ->
+ case is_comp_op(Name, Arity) of
+ true ->
+ comparison(Name, As, True, False, Ctxt, Env,
+ S);
+ false ->
+ case is_type_test(Name, Arity) of
+ true ->
+ type_test(Name, As, True, False,
+ Ctxt, Env, S);
+ false ->
+ expect_boolean_value(E, True, False,
+ Ctxt, Env, S)
+ end
+ end
+ end;
+ 'case' ->
+ %% Propagate boolean handling into clause bodies.
+ %% (Note that case switches assume fallthrough code in the
+ %% clause bodies, so we must add a dummy label as needed.)
+ F = fun (BF, CtxtF, EnvF, SF) ->
+ SF1 = boolean(BF, True, False, CtxtF, EnvF, SF),
+ add_new_continuation_label(CtxtF, SF1)
+ end,
+ S1 = expr_case_1(E, F, Ctxt, Env, S),
+ %% Add a final goto if necessary, to compensate for the
+ %% final continuation label of the case-expression. This
+ %% should be unreachable, so the value does not matter.
+ add_continuation_jump(False, Ctxt, S1);
+ seq ->
+ %% Propagate boolean handling into body.
+ F = fun (BF, CtxtF, EnvF, SF) ->
+ boolean(BF, True, False, CtxtF, EnvF, SF)
+ end,
+ expr_seq_1(E, F, Ctxt, Env, S);
+ 'let' ->
+ %% Propagate boolean handling into body. Note that we have
+ %% called 'cerl_lib:reduce_expr/1' above.
+ F = fun (BF, CtxtF, EnvF, SF) ->
+ boolean(BF, True, False, CtxtF, EnvF, SF)
+ end,
+ expr_let_1(E, F, Ctxt, Env, S);
+ 'try' ->
+ case Ctxt#ctxt.class of
+ guard ->
+ %% This *must* be a "protected" guard expression on
+ %% the form "try E of X -> X catch <...> -> 'false'"
+ %% (we could of course test if the handler body is
+ %% the atom 'false', etc.).
+ Ctxt1 = Ctxt#ctxt{fail = False},
+ boolean(cerl:try_arg(E), True, False, Ctxt1, Env, S);
+ _ ->
+ %% Propagate boolean handling into the handler and body
+ %% (see propagation into case switches for comparison)
+ F = fun (BF, CtxtF, EnvF, SF) ->
+ boolean(BF, True, False, CtxtF, EnvF, SF)
+ end,
+ S1 = expr_try_1(E, F, Ctxt, Env, S),
+ add_continuation_jump(False, Ctxt, S1)
+ end;
+ _ ->
+ %% This handles everything else, including cases that are
+ %% known to not return a boolean.
+ expect_boolean_value(E, True, False, Ctxt, Env, S)
+ end.
+
+strict_and([A, B], True, False, Ctxt, Env, S) ->
+ V = make_var(),
+ {Glue, True1, False1} = make_bool_glue(V),
+ S1 = boolean(A, True1, False1, Ctxt, Env, S),
+ S2 = add_code(Glue, S1),
+ Test = new_label(),
+ S3 = boolean(B, Test, False, Ctxt, Env, S2),
+ add_code([icode_label(Test),
+ make_bool_test(V, True, False)],
+ S3).
+
+strict_or([A, B], True, False, Ctxt, Env, S) ->
+ V = make_var(),
+ {Glue, True1, False1} = make_bool_glue(V),
+ S1 = boolean(A, True1, False1, Ctxt, Env, S),
+ S2 = add_code(Glue, S1),
+ Test = new_label(),
+ S3 = boolean(B, True, Test, Ctxt, Env, S2),
+ add_code([icode_label(Test),
+ make_bool_test(V, True, False)],
+ S3).
+
+strict_xor([A, B], True, False, Ctxt, Env, S) ->
+ V = make_var(),
+ {Glue, True1, False1} = make_bool_glue(V),
+ S1 = boolean(A, True1, False1, Ctxt, Env, S),
+ S2 = add_code(Glue, S1),
+ Test1 = new_label(),
+ Test2 = new_label(),
+ S3 = boolean(B, Test1, Test2, Ctxt, Env, S2),
+ add_code([icode_label(Test1),
+ make_bool_test(V, False, True),
+ icode_label(Test2),
+ make_bool_test(V, True, False)],
+ S3).
+
+%% Primitive comparison operations are inline expanded as conditional
+%% branches when part of a boolean expression, rather than made into
+%% primop or guardop calls. Note that Without type information, we
+%% cannot reduce equality tests like `Expr == true' to simply `Expr'
+%% (and `Expr == false' to `not Expr'), because we are not sure that
+%% Expr will yield a boolean - if it does not, the result of the
+%% comparison should be `false'.
+
+comparison(Name, As, True, False, Ctxt, Env, S) ->
+ {Vs, S1} = expr_list(As, Ctxt, Env, S),
+ Test = comp_test(Name),
+ add_code([make_if(Test, Vs, True, False)], S1).
+
+comp_test(?PRIMOP_EQ) -> ?TEST_EQ;
+comp_test(?PRIMOP_NE) -> ?TEST_NE;
+comp_test(?PRIMOP_EXACT_EQ) -> ?TEST_EXACT_EQ;
+comp_test(?PRIMOP_EXACT_NE) -> ?TEST_EXACT_NE;
+comp_test(?PRIMOP_LT) -> ?TEST_LT;
+comp_test(?PRIMOP_GT) -> ?TEST_GT;
+comp_test(?PRIMOP_LE) -> ?TEST_LE;
+comp_test(?PRIMOP_GE) -> ?TEST_GE.
+
+type_test(?PRIMOP_IS_RECORD, [T, A, N], True, False, Ctxt, Env, S) ->
+ is_record_test(T, A, N, True, False, Ctxt, Env, S);
+type_test(Name, [A], True, False, Ctxt, Env, S) ->
+ V = make_var(),
+ S1 = expr(A, [V], Ctxt#ctxt{final = false, effect = false}, Env, S),
+ Test = type_test(Name),
+ add_code([make_type([V], Test, True, False)], S1).
+
+%% It turned out to be easiest to generate Icode directly for this.
+is_record_test(T, A, N, True, False, Ctxt, Env, S) ->
+ case cerl:is_c_atom(A) andalso cerl:is_c_int(N)
+ andalso (cerl:concrete(N) > 0) of
+ true ->
+ V = make_var(),
+ Ctxt1 = Ctxt#ctxt{final = false, effect = false},
+ S1 = expr(T, [V], Ctxt1, Env, S),
+ Atom = cerl:concrete(A),
+ Size = cerl:concrete(N),
+ add_code([make_type([V], ?TYPE_IS_RECORD(Atom, Size), True, False)],
+ S1);
+ false ->
+ error_primop_badargs(?PRIMOP_IS_RECORD, [T, A, N]),
+ throw(error)
+ end.
+
+type_test(?PRIMOP_IS_ATOM) -> ?TYPE_IS_ATOM;
+type_test(?PRIMOP_IS_BIGNUM) -> ?TYPE_IS_BIGNUM;
+type_test(?PRIMOP_IS_BINARY) -> ?TYPE_IS_BINARY;
+type_test(?PRIMOP_IS_CONSTANT) -> ?TYPE_IS_CONSTANT;
+type_test(?PRIMOP_IS_FIXNUM) -> ?TYPE_IS_FIXNUM;
+type_test(?PRIMOP_IS_FLOAT) -> ?TYPE_IS_FLOAT;
+type_test(?PRIMOP_IS_FUNCTION) -> ?TYPE_IS_FUNCTION;
+type_test(?PRIMOP_IS_INTEGER) -> ?TYPE_IS_INTEGER;
+type_test(?PRIMOP_IS_LIST) -> ?TYPE_IS_LIST;
+type_test(?PRIMOP_IS_NUMBER) -> ?TYPE_IS_NUMBER;
+type_test(?PRIMOP_IS_PID) -> ?TYPE_IS_PID;
+type_test(?PRIMOP_IS_PORT) -> ?TYPE_IS_PORT;
+type_test(?PRIMOP_IS_REFERENCE) -> ?TYPE_IS_REFERENCE;
+type_test(?PRIMOP_IS_TUPLE) -> ?TYPE_IS_TUPLE.
+
+is_comp_op(?PRIMOP_EQ, 2) -> true;
+is_comp_op(?PRIMOP_NE, 2) -> true;
+is_comp_op(?PRIMOP_EXACT_EQ, 2) -> true;
+is_comp_op(?PRIMOP_EXACT_NE, 2) -> true;
+is_comp_op(?PRIMOP_LT, 2) -> true;
+is_comp_op(?PRIMOP_GT, 2) -> true;
+is_comp_op(?PRIMOP_LE, 2) -> true;
+is_comp_op(?PRIMOP_GE, 2) -> true;
+is_comp_op(Op, A) when is_atom(Op), is_integer(A) -> false.
+
+is_bool_op(?PRIMOP_AND, 2) -> true;
+is_bool_op(?PRIMOP_OR, 2) -> true;
+is_bool_op(?PRIMOP_XOR, 2) -> true;
+is_bool_op(?PRIMOP_NOT, 1) -> true;
+is_bool_op(Op, A) when is_atom(Op), is_integer(A) -> false.
+
+is_type_test(?PRIMOP_IS_ATOM, 1) -> true;
+is_type_test(?PRIMOP_IS_BIGNUM, 1) -> true;
+is_type_test(?PRIMOP_IS_BINARY, 1) -> true;
+is_type_test(?PRIMOP_IS_CONSTANT, 1) -> true;
+is_type_test(?PRIMOP_IS_FIXNUM, 1) -> true;
+is_type_test(?PRIMOP_IS_FLOAT, 1) -> true;
+is_type_test(?PRIMOP_IS_FUNCTION, 1) -> true;
+is_type_test(?PRIMOP_IS_INTEGER, 1) -> true;
+is_type_test(?PRIMOP_IS_LIST, 1) -> true;
+is_type_test(?PRIMOP_IS_NUMBER, 1) -> true;
+is_type_test(?PRIMOP_IS_PID, 1) -> true;
+is_type_test(?PRIMOP_IS_PORT, 1) -> true;
+is_type_test(?PRIMOP_IS_REFERENCE, 1) -> true;
+is_type_test(?PRIMOP_IS_TUPLE, 1) -> true;
+is_type_test(?PRIMOP_IS_RECORD, 3) -> true;
+is_type_test(Op, A) when is_atom(Op), is_integer(A) -> false.
+
+
+%% ---------------------------------------------------------------------
+%% Utility functions
+
+bind_var(V, Name, Env) ->
+ env__bind(cerl:var_name(V), #cerl_to_icode__var{name = Name}, Env).
+
+bind_vars([V | Vs], [X | Xs], Env) ->
+ bind_vars(Vs, Xs, bind_var(V, X, Env));
+bind_vars([], [], Env) ->
+ Env.
+
+bind_fun(V, L, Vs, Env) ->
+ env__bind(cerl:var_name(V), #'fun'{label = L, vars = Vs}, Env).
+
+add_code(Code, S) ->
+ s__add_code(Code, S).
+
+%% This inserts code when necessary for assigning the targets in the
+%% first list to those in the second.
+
+glue([V1 | Vs1], [V2 | Vs2], S) ->
+ if V1 =:= V2 ->
+ S;
+ true ->
+ glue(Vs1, Vs2, add_code([icode_move(V2, V1)], S))
+ end;
+glue([], [], S) ->
+ S;
+glue([], _, S) ->
+ warning_low_degree(),
+ S;
+glue(_, [], _) ->
+ error_high_degree(),
+ throw(error).
+
+make_moves([V1 | Vs1], [V2 | Vs2]) ->
+ [icode_move(V1, V2) | make_moves(Vs1, Vs2)];
+make_moves([], []) ->
+ [].
+
+%% If the context signals `final', we generate a return instruction,
+%% otherwise nothing happens.
+
+maybe_return(Ts, Ctxt, S) ->
+ case Ctxt#ctxt.final of
+ false ->
+ S;
+ true ->
+ add_return(Ts, S)
+ end.
+
+add_return(Ts, S) ->
+ add_code([icode_return(Ts)], S).
+
+new_continuation_label(Ctxt) ->
+ case Ctxt#ctxt.final of
+ false ->
+ new_label();
+ true ->
+ undefined
+ end.
+
+add_continuation_label(Label, Ctxt, S) ->
+ case Ctxt#ctxt.final of
+ false ->
+ add_code([icode_label(Label)], S);
+ true ->
+ S
+ end.
+
+add_continuation_jump(Label, Ctxt, S) ->
+ case Ctxt#ctxt.final of
+ false ->
+ add_code([icode_goto(Label)], S);
+ true ->
+ S
+ end.
+
+%% This is used to insert a new dummy label (if necessary) when
+%% a block is ended suddenly; cf. add_fail.
+add_new_continuation_label(Ctxt, S) ->
+ add_continuation_label(new_continuation_label(Ctxt), Ctxt, S).
+
+add_local_call({Name, _Arity} = V, Vs, Ts, Ctxt, S) ->
+ Module = s__get_module(S),
+ case Ctxt#ctxt.final of
+ false ->
+ add_code([icode_call_local(Ts, Module, Name, Vs)], S);
+ true ->
+ Self = s__get_function(S),
+ if V =:= Self ->
+ %% Self-recursive tail call:
+ {Label, Vs1} = s__get_local_entry(S),
+ add_code(make_moves(Vs1, Vs) ++ [icode_goto(Label)],
+ S);
+ true ->
+ add_code([icode_enter_local(Module, Name, Vs)], S)
+ end
+ end.
+
+%% Note that this has the same "problem" as the fail instruction (see
+%% the 'add_fail' function), namely, that it unexpectedly ends a basic
+%% block. The solution is the same - add a dummy label if necessary.
+
+add_letrec_call(Label, Vs1, Vs, Ctxt, S) ->
+ S1 = add_code(make_moves(Vs1, Vs) ++ [icode_goto(Label)], S),
+ add_new_continuation_label(Ctxt, S1).
+
+add_exit(V, Ctxt, S) ->
+ add_fail([V], exit, Ctxt, S).
+
+add_throw(V, Ctxt, S) ->
+ add_fail([V], throw, Ctxt, S).
+
+add_error(V, Ctxt, S) ->
+ add_fail([V], error, Ctxt, S).
+
+add_error(V, F, Ctxt, S) ->
+ add_fail([V, F], error, Ctxt, S).
+
+add_rethrow(E, V, Ctxt, S) ->
+ add_fail([E, V], rethrow, Ctxt, S).
+
+%% Failing is special, because it can "suddenly" end the basic block,
+%% even though the context was expecting the code to fall through, for
+%% instance when you have a call to 'exit(X)' that is not in a tail call
+%% context. In those cases a dummy label must therefore be added after
+%% the fail instruction, to start a new (but unreachable) basic block.
+
+add_fail(Vs, Class, Ctxt, S0) ->
+ S1 = add_code([icode_fail(Vs, Class)], S0),
+ add_new_continuation_label(Ctxt, S1).
+
+%% We must add continuation- and fail-labels if we are in a guard context.
+
+make_op(Name, Ts, As, Ctxt) ->
+ case Ctxt#ctxt.final of
+ false ->
+ case Ctxt#ctxt.class of
+ guard ->
+ Next = new_label(),
+ [icode_guardop(Ts, Name, As, Next, Ctxt#ctxt.fail),
+ icode_label(Next)];
+ _ ->
+ [icode_call_primop(Ts, Name, As)]
+ end;
+ true ->
+ [icode_enter_primop(Name, As)]
+ end.
+
+make_call(M, F, Ts, As, Ctxt) ->
+ case Ctxt#ctxt.final of
+ false ->
+ case Ctxt#ctxt.class of
+ guard ->
+ Next = new_label(),
+ [icode_call_remote(Ts, M, F, As, Next,
+ Ctxt#ctxt.fail, true),
+ icode_label(Next)];
+ _ ->
+ [icode_call_remote(Ts, M, F, As)]
+ end;
+ true ->
+ %% A final call can't be in a guard anyway
+ [icode_enter_remote(M, F, As)]
+ end.
+
+%% Recognize useless tests that always go to the same label. This often
+%% happens as an artefact of the translation.
+
+make_if(_, _, Label, Label) ->
+ icode_goto(Label);
+make_if(Test, As, True, False) ->
+ icode_if(Test, As, True, False).
+
+make_type(_, _, Label, Label) ->
+ icode_goto(Label);
+make_type(Vs, Test, True, False) ->
+ icode_type(Vs, Test, True, False).
+
+%% Creating glue code with true/false target labels for assigning a
+%% corresponding 'true'/'false' value to a specific variable. Used as
+%% glue between boolean jumping code and boolean values.
+
+make_bool_glue(V) ->
+ make_bool_glue(V, true, false).
+
+make_bool_glue(V, T, F) ->
+ False = new_label(),
+ True = new_label(),
+ Next = new_label(),
+ Code = [icode_label(False),
+ icode_move(V, icode_const(F)),
+ icode_goto(Next),
+ icode_label(True),
+ icode_move(V, icode_const(T)),
+ icode_label(Next)],
+ {Code, True, False}.
+
+make_bool_test(V, True, False) ->
+ make_type([V], ?TYPE_ATOM(true), True, False).
+
+%% Checking if an expression is safe
+
+is_safe_expr(E) ->
+ cerl_lib:is_safe_expr(E, fun function_check/2).
+
+function_check(safe, {Name, Arity}) ->
+ is_safe_op(Name, Arity);
+function_check(safe, {Module, Name, Arity}) ->
+ erl_bifs:is_safe(Module, Name, Arity);
+function_check(pure, {Name, Arity}) ->
+ is_pure_op(Name, Arity);
+function_check(pure, {Module, Name, Arity}) ->
+ erl_bifs:is_pure(Module, Name, Arity);
+function_check(_, _) ->
+ false.
+
+%% There are very few really safe operations (sigh!). If we have type
+%% information, several operations could be rewritten into specialized
+%% safe versions, such as '+'/2 -> add_integer/2.
+
+is_safe_op(N, A) ->
+ is_comp_op(N, A) orelse is_type_test(N, A).
+
+is_pure_op(?PRIMOP_ELEMENT, 2) -> true;
+is_pure_op(?PRIMOP_MAKE_FUN, 6) -> true;
+is_pure_op(?PRIMOP_FUN_ELEMENT, 2) -> true;
+is_pure_op(?PRIMOP_ADD, 2) -> true;
+is_pure_op(?PRIMOP_SUB, 2) -> true;
+is_pure_op(?PRIMOP_NEG, 1) -> true;
+is_pure_op(?PRIMOP_MUL, 2) -> true;
+is_pure_op(?PRIMOP_DIV, 2) -> true;
+is_pure_op(?PRIMOP_INTDIV, 2) -> true;
+is_pure_op(?PRIMOP_REM, 2) -> true;
+is_pure_op(?PRIMOP_BAND, 2) -> true;
+is_pure_op(?PRIMOP_BOR, 2) -> true;
+is_pure_op(?PRIMOP_BXOR, 2) -> true;
+is_pure_op(?PRIMOP_BNOT, 1) -> true;
+is_pure_op(?PRIMOP_BSL, 2) -> true;
+is_pure_op(?PRIMOP_BSR, 2) -> true;
+is_pure_op(?PRIMOP_EXIT, 1) -> true;
+is_pure_op(?PRIMOP_THROW, 1) -> true;
+is_pure_op(?PRIMOP_ERROR, 1) -> true;
+is_pure_op(?PRIMOP_ERROR, 2) -> true;
+is_pure_op(?PRIMOP_RETHROW, 2) -> true;
+is_pure_op(N, A) -> is_pure_op_aux(N, A).
+
+is_pure_op_aux(N, A) ->
+ is_bool_op(N, A) orelse is_comp_op(N, A) orelse is_type_test(N, A).
+
+translate_flags(Flags, Align) ->
+ translate_flags1(cerl:concrete(Flags), Align).
+
+translate_flags1([A|Rest], Align) ->
+ case A of
+ signed ->
+ 4 + translate_flags1(Rest, Align);
+ little ->
+ 2 + translate_flags1(Rest, Align);
+ native ->
+ case hipe_rtl_arch:endianess() of
+ little ->
+ 2 + translate_flags1(Rest, Align);
+ big ->
+ translate_flags1(Rest, Align)
+ end;
+ _ ->
+ translate_flags1(Rest, Align)
+ end;
+translate_flags1([], Align) ->
+ case Align of
+ 0 ->
+ 1;
+ _ ->
+ 0
+ end.
+
+get_const_info(Val, integer) ->
+ case {cerl:is_c_var(Val), cerl:is_c_int(Val)} of
+ {true, _} ->
+ var;
+ {_, true} ->
+ pass;
+ _ ->
+ fail
+ end;
+get_const_info(Val, float) ->
+ case {cerl:is_c_var(Val), cerl:is_c_float(Val)} of
+ {true, _} ->
+ var;
+ {_, true} ->
+ pass;
+ _ ->
+ fail
+ end;
+get_const_info(_Val, _Type) ->
+ [].
+
+calculate_size(Unit, Var, Align, Env, S) ->
+ case cerl:is_c_atom(Var) of
+ true ->
+ {cerl:atom_val(Var), cerl:concrete(Unit), Align, S};
+ false ->
+ case cerl:is_c_int(Var) of
+ true ->
+ NewVal = cerl:concrete(Var) * cerl:concrete(Unit),
+ NewAlign =
+ case Align of
+ false ->
+ false
+ %% Currently, all uses of the function are
+ %% with "Aligned == false", and this case
+ %% is commented out to shut up Dialyzer.
+ %% _ ->
+ %% (NewVal+Align) band 7
+ end,
+ {NewVal, [], S, NewAlign};
+ false ->
+ NewSize = make_var(),
+ S1 = expr(Var, [NewSize], #ctxt{final=false}, Env, S),
+ NewAlign =
+ case cerl:concrete(Unit) band 7 of
+ 0 ->
+ Align;
+ _ ->
+ false
+ end,
+ {cerl:concrete(Unit), [NewSize], S1, NewAlign}
+ end
+ end.
+
+
+%% ---------------------------------------------------------------------
+%% Environment (abstract datatype)
+
+env__new() ->
+ rec_env:empty().
+
+env__bind(Key, Val, Env) ->
+ rec_env:bind(Key, Val, Env).
+
+env__lookup(Key, Env) ->
+ rec_env:lookup(Key, Env).
+
+env__get(Key, Env) ->
+ rec_env:get(Key, Env).
+
+%% env__new_integer_keys(N, Env) ->
+%% rec_env:new_keys(N, Env).
+
+
+%% ---------------------------------------------------------------------
+%% State (abstract datatype)
+
+-record(state, {module, function, local, labels=gb_trees:empty(),
+ code = [], pmatch=true, bitlevel_binaries=false}).
+
+s__new(Module) ->
+ #state{module = Module}.
+
+s__get_module(S) ->
+ S#state.module.
+
+s__set_function(Name, S) ->
+ S#state{function = Name}.
+
+s__get_function(S) ->
+ S#state.function.
+
+s__set_local_entry(Info, S) ->
+ S#state{local = Info}.
+
+s__get_local_entry(S) ->
+ S#state.local.
+
+%% Generated code is kept in reverse order, to make adding fast.
+
+s__set_code(Code, S) ->
+ S#state{code = lists:reverse(Code)}.
+
+s__get_code(S) ->
+ lists:reverse(S#state.code).
+
+s__add_code(Code, S) ->
+ S#state{code = lists:reverse(Code, S#state.code)}.
+
+s__get_label(Ref, S) ->
+ Labels = S#state.labels,
+ case gb_trees:lookup(Ref, Labels) of
+ none ->
+ Label = new_label(),
+ S1 = S#state{labels=gb_trees:enter(Ref, Label, Labels)},
+ {Label, S1};
+ {value, Label} ->
+ {Label,S}
+ end.
+
+s__set_pmatch(V, S) ->
+ S#state{pmatch = V}.
+
+s__get_pmatch(S) ->
+ S#state.pmatch.
+
+s__set_bitlevel_binaries(true, S) ->
+ S#state{bitlevel_binaries = true};
+s__set_bitlevel_binaries(_, S) ->
+ S#state{bitlevel_binaries = false}.
+
+s__get_bitlevel_binaries(S) ->
+ S#state.bitlevel_binaries.
+%% ---------------------------------------------------------------------
+%%% Match label State
+
+%-record(mstate,{labels=gb_trees:empty()}).
+
+%get_correct_label(Alias, MState=#mstate{labels=Labels}) ->
+% case gb_trees:lookup(Alias, Labels) of
+% none ->
+% LabelName=new_label(),
+% {LabelName, MState#mstate{labels=gb_trees:insert(Alias, LabelName, Labels)}};
+% {value, LabelName} ->
+% {LabelName, MState}
+% end.
+
+
+%% ---------------------------------------------------------------------
+%% General utilities
+
+reset_var_counter() ->
+ hipe_gensym:set_var(0).
+
+reset_label_counter() ->
+ hipe_gensym:set_label(0).
+
+new_var() ->
+ hipe_gensym:get_next_var().
+
+new_label() ->
+ hipe_gensym:get_next_label().
+
+max_var() ->
+ hipe_gensym:get_var().
+
+max_label() ->
+ hipe_gensym:get_label().
+
+make_var() ->
+ icode_var(new_var()).
+
+make_vars(N) when N > 0 ->
+ [make_var() | make_vars(N - 1)];
+make_vars(0) ->
+ [].
+
+make_reg() ->
+ icode_reg(new_var()).
+
+
+%% ---------------------------------------------------------------------
+%% ICode interface
+
+icode_icode(M, {F, A}, Vs, Closure, C, V, L) ->
+ MFA = {M, F, A},
+ hipe_icode:mk_icode(MFA, Vs, Closure, false, C, V, L).
+
+icode_icode_name(Icode) ->
+ hipe_icode:icode_fun(Icode).
+
+icode_comment(S) -> hipe_icode:mk_comment(S).
+
+icode_var(V) -> hipe_icode:mk_var(V).
+
+icode_reg(V) -> hipe_icode:mk_reg(V).
+
+icode_label(L) -> hipe_icode:mk_label(L).
+
+icode_move(V, D) -> hipe_icode:mk_move(V, D).
+
+icode_const(X) -> hipe_icode:mk_const(X).
+
+icode_const_val(X) -> hipe_icode:const_value(X).
+
+icode_call_local(Ts, M, N, Vs) ->
+ hipe_icode:mk_call(Ts, M, N, Vs, local).
+
+icode_call_remote(Ts, M, N, Vs) ->
+ hipe_icode:mk_call(Ts, M, N, Vs, remote).
+
+icode_call_remote(Ts, M, N, Vs, Cont, Fail, Guard) ->
+ hipe_icode:mk_call(Ts, M, N, Vs, remote, Cont, Fail, Guard).
+
+icode_enter_local(M, N, Vs) ->
+ hipe_icode:mk_enter(M, N, Vs, local).
+
+icode_enter_remote(M, N, Vs) ->
+ hipe_icode:mk_enter(M, N, Vs, remote).
+
+icode_call_fun(Ts, Vs) ->
+ icode_call_primop(Ts, call_fun, Vs).
+
+icode_enter_fun(Vs) ->
+ icode_enter_primop(enter_fun, Vs).
+
+icode_begin_try(L,Cont) -> hipe_icode:mk_begin_try(L,Cont).
+
+icode_end_try() -> hipe_icode:mk_end_try().
+
+icode_begin_handler(Ts) -> hipe_icode:mk_begin_handler(Ts).
+
+icode_goto(L) -> hipe_icode:mk_goto(L).
+
+icode_return(Ts) -> hipe_icode:mk_return(Ts).
+
+icode_fail(Vs, C) -> hipe_icode:mk_fail(Vs, C).
+
+icode_guardop(Ts, Name, As, Succ, Fail) ->
+ hipe_icode:mk_guardop(Ts, Name, As, Succ, Fail).
+
+icode_call_primop(Ts, Name, As) -> hipe_icode:mk_primop(Ts, Name, As).
+
+icode_call_primop(Ts, Name, As, Succ, Fail) ->
+ hipe_icode:mk_primop(Ts, Name, As, Succ, Fail).
+
+icode_enter_primop(Name, As) -> hipe_icode:mk_enter_primop(Name, As).
+
+icode_if(Test, As, True, False) ->
+ hipe_icode:mk_if(Test, As, True, False).
+
+icode_type(Test, As, True, False) ->
+ hipe_icode:mk_type(Test, As, True, False).
+
+icode_switch_val(Arg, Fail, Length, Cases) ->
+ hipe_icode:mk_switch_val(Arg, Fail, Length, Cases).
+
+icode_switch_tuple_arity(Arg, Fail, Length, Cases) ->
+ SortedCases = lists:keysort(1, Cases), %% immitate BEAM compiler - Kostis
+ hipe_icode:mk_switch_tuple_arity(Arg, Fail, Length, SortedCases).
+
+
+%% ---------------------------------------------------------------------
+%% Error reporting
+
+error_not_in_receive(Name) ->
+ error_msg("primitive operation `~w' missing receive-context.",
+ [Name]).
+
+low_degree() ->
+ "degree of expression less than expected.".
+
+warning_low_degree() ->
+ warning_msg(low_degree()).
+
+error_low_degree() ->
+ error_msg(low_degree()).
+
+error_high_degree() ->
+ error_msg("degree of expression greater than expected.").
+
+error_degree_mismatch(N, E) ->
+ error_msg("expression does not have expected degree (~w): ~P.",
+ [N, E, 10]).
+
+error_nonlocal_application(Op) ->
+ error_msg("application operator not a local function: ~P.",
+ [Op, 10]).
+
+error_primop_badargs(Op, As) ->
+ error_msg("bad arguments to `~w' operation: ~P.",
+ [Op, As, 15]).
+
+%% 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).
+
+
+%% --------------------------------------------------------------------------
+%% Binary stuff
+
+binary_match([Clause|Clauses], F, [V], Next, Fail, Ctxt, Env, S) ->
+ Guard = cerl:clause_guard(Clause),
+ Body = cerl:clause_body(Clause),
+ [Pat] = cerl:clause_pats(Clause),
+ {FL,S1} = s__get_label(translate_label_primop(Guard),S),
+ {Env1,S2} = binary_pattern(Pat,V,FL,Env,S1),
+ S3 = F(Body, Ctxt, Env1, S2),
+ S4 = add_continuation_jump(Next, Ctxt, S3),
+ S5 = add_code([icode_label(FL)], S4),
+ binary_match(Clauses, F, [V], Next, Fail, Ctxt, Env, S5);
+binary_match([], _F, _, _Next, Fail, _Ctxt, _Env, S) ->
+ add_code([icode_goto(Fail)], S).
+
+translate_label_primop(LabelPrimop) ->
+ ?PRIMOP_SET_LABEL = cerl:atom_val(cerl:primop_name(LabelPrimop)),
+ [Ref] = cerl:primop_args(LabelPrimop),
+ Ref.
+
+