%% -*- erlang-indent-level: 4 -*-
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
%% You may obtain a copy of the License at
%%
%% http://www.apache.org/licenses/LICENSE-2.0
%%
%% Unless required by applicable law or agreed to in writing, software
%% distributed under the License is distributed on an "AS IS" BASIS,
%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
%% See the License for the specific language governing permissions and
%% limitations under the License.
%%
%% @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/1, module/2]).
-ifndef(NO_UNUSED).
-export([function/3, function/4]).
-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_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('receive', {loop}).
-record(cerl_to_icode__var, {name}).
-record('fun', {label, vars}).
-record(ctxt, {final = false :: boolean(),
effect = false :: boolean(),
fail = [], % [] or fail-to label
class = expr :: 'expr' | 'guard',
line = 0 :: erl_anno:line(), % current line number
'receive' :: 'undefined' | #'receive'{}
}).
%% ---------------------------------------------------------------------
%% Code
%% @spec module(Module::cerl()) -> [{mfa(), icode()}]
%% @equiv module(Module, [])
-spec module(cerl:c_module()) -> [{mfa(), hipe_icode:icode()}].
module(E) ->
module(E, []).
%% @spec module(Module::cerl(), Options::[term()]) -> [{mfa(), icode()}]
%%
%% cerl() = cerl:c_module()
%% 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, NewUnit, 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, NewUnit, 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_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_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.
