diff options
| author | Erlang/OTP <[email protected]> | 2009-11-20 14:54:40 +0000 |
|---|---|---|
| committer | Erlang/OTP <[email protected]> | 2009-11-20 14:54:40 +0000 |
| commit | 84adefa331c4159d432d22840663c38f155cd4c1 (patch) | |
| tree | bff9a9c66adda4df2106dfd0e5c053ab182a12bd /lib/hipe/cerl/cerl_to_icode.erl | |
| download | otp-84adefa331c4159d432d22840663c38f155cd4c1.tar.gz otp-84adefa331c4159d432d22840663c38f155cd4c1.tar.bz2 otp-84adefa331c4159d432d22840663c38f155cd4c1.zip | |
The R13B03 release.OTP_R13B03
Diffstat (limited to 'lib/hipe/cerl/cerl_to_icode.erl')
| -rw-r--r-- | lib/hipe/cerl/cerl_to_icode.erl | 2717 |
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. + + |