aboutsummaryrefslogtreecommitdiffstats
path: root/lib/hipe/cerl
diff options
context:
space:
mode:
Diffstat (limited to 'lib/hipe/cerl')
-rw-r--r--lib/hipe/cerl/Makefile107
-rw-r--r--lib/hipe/cerl/cerl_cconv.erl777
-rw-r--r--lib/hipe/cerl/cerl_closurean.erl862
-rw-r--r--lib/hipe/cerl/cerl_hipe_primops.hrl88
-rw-r--r--lib/hipe/cerl/cerl_hipeify.erl655
-rw-r--r--lib/hipe/cerl/cerl_hybrid_transform.erl153
-rw-r--r--lib/hipe/cerl/cerl_lib.erl462
-rw-r--r--lib/hipe/cerl/cerl_messagean.erl1105
-rw-r--r--lib/hipe/cerl/cerl_pmatch.erl624
-rw-r--r--lib/hipe/cerl/cerl_prettypr.erl883
-rw-r--r--lib/hipe/cerl/cerl_to_icode.erl2717
-rw-r--r--lib/hipe/cerl/cerl_typean.erl1003
-rw-r--r--lib/hipe/cerl/erl_bif_types.erl5021
-rw-r--r--lib/hipe/cerl/erl_types.erl3847
14 files changed, 18304 insertions, 0 deletions
diff --git a/lib/hipe/cerl/Makefile b/lib/hipe/cerl/Makefile
new file mode 100644
index 0000000000..fb7ca1153b
--- /dev/null
+++ b/lib/hipe/cerl/Makefile
@@ -0,0 +1,107 @@
+#
+# %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%
+#
+
+ifndef EBIN
+EBIN = ../ebin
+endif
+
+ifndef DOCS
+DOCS = ../doc
+endif
+
+include $(ERL_TOP)/make/target.mk
+include $(ERL_TOP)/make/$(TARGET)/otp.mk
+
+# ----------------------------------------------------
+# Application version
+# ----------------------------------------------------
+include ../vsn.mk
+VSN=$(HIPE_VSN)
+
+# ----------------------------------------------------
+# Release directory specification
+# ----------------------------------------------------
+RELSYSDIR = $(RELEASE_PATH)/lib/hipe-$(VSN)
+
+# ----------------------------------------------------
+# Target Specs
+# ----------------------------------------------------
+MODULES = cerl_cconv cerl_closurean cerl_hipeify cerl_hybrid_transform \
+ cerl_lib cerl_messagean cerl_pmatch cerl_prettypr cerl_to_icode \
+ cerl_typean erl_bif_types erl_types
+
+HRL_FILES= cerl_hipe_primops.hrl
+ERL_FILES= $(MODULES:%=%.erl)
+TARGET_FILES= $(MODULES:%=$(EBIN)/%.$(EMULATOR))
+DOC_FILES= $(MODULES:%=$(DOCS)/%.html)
+
+# APP_FILE=
+# APP_SRC= $(APP_FILE).src
+# APP_TARGET= $(EBIN)/$(APP_FILE)
+#
+# APPUP_FILE=
+# APPUP_SRC= $(APPUP_FILE).src
+# APPUP_TARGET= $(EBIN)/$(APPUP_FILE)
+
+# ----------------------------------------------------
+# FLAGS
+# ----------------------------------------------------
+
+include ../native.mk
+
+ERL_COMPILE_FLAGS += +inline +warn_exported_vars +warn_unused_import +warn_missing_spec# +warn_untyped_record
+
+# ----------------------------------------------------
+# Targets
+# ----------------------------------------------------
+
+debug opt: $(TARGET_FILES)
+
+docs: $(DOC_FILES)
+
+clean:
+ rm -f $(TARGET_FILES)
+ rm -f core
+
+$(DOCS)/%.html:%.erl
+ erl -noshell -run edoc_run file '"$<"' '[{dir, "$(DOCS)"}]' -s init stop
+
+# ----------------------------------------------------
+# Special Build Targets
+# ----------------------------------------------------
+
+
+
+# ----------------------------------------------------
+# Release Target
+# ----------------------------------------------------
+include $(ERL_TOP)/make/otp_release_targets.mk
+
+release_spec: opt
+ $(INSTALL_DIR) $(RELSYSDIR)/cerl
+ $(INSTALL_DATA) $(ERL_FILES) $(HRL_FILES) $(RELSYSDIR)/cerl
+ $(INSTALL_DIR) $(RELSYSDIR)/ebin
+ $(INSTALL_DATA) $(TARGET_FILES) $(RELSYSDIR)/ebin
+
+release_docs_spec:
+
+$(EBIN)/cerl_to_icode.beam: cerl_hipe_primops.hrl ../icode/hipe_icode_primops.hrl
+$(EBIN)/cerl_hipeify.beam: cerl_hipe_primops.hrl
+$(EBIN)/cerl_lambdalift.beam: cerl_hipe_primops.hrl
+$(EBIN)/erl_bif_types.beam: ../icode/hipe_icode_primops.hrl
diff --git a/lib/hipe/cerl/cerl_cconv.erl b/lib/hipe/cerl/cerl_cconv.erl
new file mode 100644
index 0000000000..cf4d317b0d
--- /dev/null
+++ b/lib/hipe/cerl/cerl_cconv.erl
@@ -0,0 +1,777 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2004-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+%%
+%% @author Richard Carlsson <[email protected]>
+%% @copyright 2000-2004 Richard Carlsson
+%% @doc Closure conversion of Core Erlang modules. This is done as a
+%% step in the translation from Core Erlang down to HiPE Icode, and is
+%% very much tied to the calling conventions used in HiPE native code.
+%% @see cerl_to_icode
+
+%% Some information about function closures in Beam and HiPE:
+%%
+%% - In Beam, each fun-expression is lifted to a top-level function such
+%% that the arity of the new function is equal to the arity of the fun
+%% *plus* the number of free variables. The original fun-expression is
+%% replaced by a call to 'make_fun' which takes the *label* of the new
+%% function and the number of free variables as arguments (the arity
+%% of the fun can be found via the label). When a call is made through
+%% the closure, the free variables are extracted from the closure by
+%% the 'call_fun' operation and are placed in the X registers
+%% following the ones used for the normal parameters; then the call is
+%% made to the function label.
+%%
+%% - In HiPE (when compiling from Beam bytecode), the Beam-to-Icode
+%% translation rewrites the fun-functions (those referenced by
+%% 'make_fun' operations) so that the code expects only the normal
+%% parameters, plus *one* extra parameter containing the closure
+%% itself, and then immediately extracts the free variables from the
+%% closure - the code knows how many free variables it expects.
+%% However, the arity part of the function name is *not* changed;
+%% thus, the native code and the Beam code still use the same
+%% fun-table entry. The arity value used in native-code 'make_fun'
+%% operations should therefore be the same as in Beam, i.e., the sum
+%% of the number of parameters and the number of free variables.
+
+-module(cerl_cconv).
+
+-export([transform/2]).
+-export([core_transform/2]).
+
+-include("cerl_hipe_primops.hrl").
+
+%% A descriptor for top-level and letrec-bound functions. (Top-level
+%% functions always have an empty list of free variables.) The 'name'
+%% field is the name of the lifted function, and is thus unique over the
+%% whole module.
+
+-record(function, {name :: {atom(), arity()}, free}).
+
+%% A record for holding fun-information (if such information is attached
+%% as an annotation on a fun, it should preferably be preserved).
+
+-record(fun_info, {name :: atom(),
+ id = 0 :: integer(),
+ hash = 0 :: integer()}).
+
+%% @spec core_transform(Module::cerl_records(), Options::[term()]) ->
+%% cerl_records()
+%%
+%% @doc Transforms a module represented by records. See
+%% <code>transform/2</code> for details.
+%%
+%% <p>Use the compiler option <code>{core_transform, cerl_cconv}</code>
+%% to insert this function as a compilation pass.</p>
+%%
+%% @see transform/2
+
+-spec core_transform(cerl:cerl(), [term()]) -> cerl:cerl().
+
+core_transform(M, Opts) ->
+ cerl:to_records(transform(cerl:from_records(M), Opts)).
+
+
+%% @spec transform(Module::cerl(), Options::[term()]) -> cerl()
+%%
+%% cerl() = cerl:cerl()
+%%
+%% @doc Rewrites a Core Erlang module so that all fun-expressions
+%% (lambda expressions) in the code are in top level function
+%% definitions, and the operators of all `apply'-expressions are names
+%% of such top-level functions. The primitive operations `make_fun' and
+%% `call_fun' are inserted in the code to create and apply functional
+%% values; this transformation is known as "Closure Conversion"
+%%
+%% <p>See the module {@link cerl_to_icode} for details.</p>
+
+-spec transform(cerl:c_module(), [term()]) -> cerl:c_module().
+
+transform(E, _Options) ->
+ M = cerl:module_name(E),
+ S0 = s__new(cerl:atom_val(M)),
+ {Defs1, S1} = module_defs(cerl:module_defs(E), env__new(),
+ ren__new(), S0),
+ Defs2 = lists:reverse(s__get_defs(S1) ++ Defs1),
+ cerl:update_c_module(E, M, cerl:module_exports(E),
+ cerl:module_attrs(E), Defs2).
+
+%% Note that the environment is defined on the renamed variables.
+
+expr(E, Env, Ren, S0) ->
+ case cerl:type(E) of
+ literal ->
+ {E, S0};
+ var ->
+ var(E, Env, Ren, S0);
+ values ->
+ {Es, S1} = expr_list(cerl:values_es(E), Env, Ren, S0),
+ {cerl:update_c_values(E, Es), S1};
+ cons ->
+ {E1, S1} = expr(cerl:cons_hd(E), Env, Ren, S0),
+ {E2, S2} = expr(cerl:cons_tl(E), Env, Ren, S1),
+ {cerl:update_c_cons(E, E1, E2), S2};
+ tuple ->
+ {Es, S1} = expr_list(cerl:tuple_es(E), Env, Ren, S0),
+ {cerl:update_c_tuple(E, Es), S1};
+ 'let' ->
+ {A, S1} = expr(cerl:let_arg(E), Env, Ren, S0),
+ Vs = cerl:let_vars(E),
+ {Vs1, Env1, Ren1} = bind_vars(Vs, Env, Ren),
+ {B, S2} = expr(cerl:let_body(E), Env1, Ren1, S1),
+ {cerl:update_c_let(E, Vs1, A, B), S2};
+ seq ->
+ {A, S1} = expr(cerl:seq_arg(E), Env, Ren, S0),
+ {B, S2} = expr(cerl:seq_body(E), Env, Ren, S1),
+ {cerl:update_c_seq(E, A, B), S2};
+ apply ->
+ apply_expr(E, Env, Ren, S0);
+ call ->
+ {M, S1} = expr(cerl:call_module(E), Env, Ren, S0),
+ {N, S2} = expr(cerl:call_name(E), Env, Ren, S1),
+ {As, S3} = expr_list(cerl:call_args(E), Env, Ren, S2),
+ {cerl:update_c_call(E, M, N, As), S3};
+ primop ->
+ {As, S1} = expr_list(cerl:primop_args(E), Env, Ren, S0),
+ N = cerl:primop_name(E),
+ {cerl:update_c_primop(E, N, As), S1};
+ 'case' ->
+ {A, S1} = expr(cerl:case_arg(E), Env, Ren, S0),
+ {Cs, S2} = expr_list(cerl:case_clauses(E), Env, Ren, S1),
+ {cerl:update_c_case(E, A, Cs), S2};
+ clause ->
+ Vs = cerl:clause_vars(E),
+ {_, Env1, Ren1} = bind_vars(Vs, Env, Ren),
+ %% Visit patterns to rename variables.
+ Ps = pattern_list(cerl:clause_pats(E), Env1, Ren1),
+ {G, S1} = expr(cerl:clause_guard(E), Env1, Ren1, S0),
+ {B, S2} = expr(cerl:clause_body(E), Env1, Ren1, S1),
+ {cerl:update_c_clause(E, Ps, G, B), S2};
+ 'fun' ->
+ fun_expr(E, Env, Ren, S0);
+ 'receive' ->
+ {Cs, S1} = expr_list(cerl:receive_clauses(E), Env, Ren, S0),
+ {T, S2} = expr(cerl:receive_timeout(E), Env, Ren, S1),
+ {A, S3} = expr(cerl:receive_action(E), Env, Ren, S2),
+ {cerl:update_c_receive(E, Cs, T, A), S3};
+ 'try' ->
+ {A, S1} = expr(cerl:try_arg(E), Env, Ren, S0),
+ Vs = cerl:try_vars(E),
+ {Vs1, Env1, Ren1} = bind_vars(Vs, Env, Ren),
+ {B, S2} = expr(cerl:try_body(E), Env1, Ren1, S1),
+ Evs = cerl:try_evars(E),
+ {Evs1, Env2, Ren2} = bind_vars(Evs, Env, Ren),
+ {H, S3} = expr(cerl:try_handler(E), Env2, Ren2, S2),
+ {cerl:update_c_try(E, A, Vs1, B, Evs1, H), S3};
+ 'catch' ->
+ {B, S1} = expr(cerl:catch_body(E), Env, Ren, S0),
+ {cerl:update_c_catch(E, B), S1};
+ letrec ->
+ {Env1, Ren1, S1} = letrec_defs(cerl:letrec_defs(E), Env,
+ Ren, S0),
+ expr(cerl:letrec_body(E), Env1, Ren1, S1);
+ binary ->
+ {Segs, S1} = expr_list(cerl:binary_segments(E), Env, Ren, S0),
+ {cerl:update_c_binary(E, Segs),S1};
+ bitstr ->
+ {E1,S1} = expr(cerl:bitstr_val(E), Env, Ren, S0),
+ {E2,S2} = expr(cerl:bitstr_size(E), Env, Ren, S1),
+ E3 = cerl:bitstr_unit(E),
+ E4 = cerl:bitstr_type(E),
+ E5 = cerl:bitstr_flags(E),
+ {cerl:update_c_bitstr(E, E1, E2, E3, E4, E5), S2}
+ end.
+
+expr_list([E | Es], Env, Ren, S0) ->
+ {E1, S1} = expr(E, Env, Ren, S0),
+ {Es1, S2} = expr_list(Es, Env, Ren, S1),
+ {[E1 | Es1], S2};
+expr_list([], _, _, S) ->
+ {[], S}.
+
+pattern(E, Env, Ren) ->
+ case cerl:type(E) of
+ literal ->
+ E;
+ var ->
+ cerl:update_c_var(E, ren__map(cerl:var_name(E), Ren));
+ values ->
+ Es = pattern_list(cerl:values_es(E), Env, Ren),
+ cerl:update_c_values(E, Es);
+ cons ->
+ E1 = pattern(cerl:cons_hd(E), Env, Ren),
+ E2 = pattern(cerl:cons_tl(E), Env, Ren),
+ cerl:update_c_cons(E, E1, E2);
+ tuple ->
+ Es = pattern_list(cerl:tuple_es(E), Env, Ren),
+ cerl:update_c_tuple(E, Es);
+ binary ->
+ Es = pattern_list(cerl:binary_segments(E), Env, Ren),
+ cerl:update_c_binary(E, Es);
+ bitstr ->
+ E1 = pattern(cerl:bitstr_val(E), Env, Ren),
+ E2 = pattern(cerl:bitstr_size(E), Env, Ren),
+ E3 = cerl:bitstr_unit(E),
+ E4 = cerl:bitstr_type(E),
+ E5 = cerl:bitstr_flags(E),
+ cerl:update_c_bitstr(E, E1, E2, E3, E4, E5);
+ alias ->
+ V = pattern(cerl:alias_var(E), Env, Ren),
+ P = pattern(cerl:alias_pat(E), Env, Ren),
+ cerl:update_c_alias(E, V, P)
+ end.
+
+pattern_list([E | Es], Env, Ren) ->
+ [pattern(E, Env, Ren) | pattern_list(Es, Env, Ren)];
+pattern_list([], _, _) ->
+ [].
+
+%% First we set up the environment, binding the function names to the
+%% corresponding descriptors. (For the top level functions, we don't
+%% want to cause renaming.) After that, we can visit each function body
+%% and return the new function definitions and the final state.
+
+module_defs(Ds, Env, Ren, S) ->
+ {Env1, S1} = bind_module_defs(Ds, Env, S),
+ module_defs_1(Ds, [], Env1, Ren, S1).
+
+bind_module_defs([{V, _F} | Ds], Env, S) ->
+ Name = cerl:var_name(V),
+ check_function_name(Name, S),
+ S1 = s__add_function_name(Name, S),
+ Info = #function{name = Name, free = []},
+ Env1 = env__bind(Name, Info, Env),
+ bind_module_defs(Ds, Env1, S1);
+bind_module_defs([], Env, S) ->
+ {Env, S}.
+
+%% Checking that top-level function names are not reused
+
+check_function_name(Name, S) ->
+ case s__is_function_name(Name, S) of
+ true ->
+ error_msg("multiple definitions of function `~w'.", [Name]),
+ exit(error);
+ false ->
+ ok
+ end.
+
+%% We must track which top-level function we are in, for name generation
+%% purposes.
+
+module_defs_1([{V, F} | Ds], Ds1, Env, Ren, S) ->
+ S1 = s__enter_function(cerl:var_name(V), S),
+ %% The parameters should never need renaming, but this is easiest.
+ {Vs, Env1, Ren1} = bind_vars(cerl:fun_vars(F), Env, Ren),
+ {B, S2} = expr(cerl:fun_body(F), Env1, Ren1, S1),
+ F1 = cerl:update_c_fun(F, Vs, B),
+ module_defs_1(Ds, [{V, F1} | Ds1], Env, Ren, S2);
+module_defs_1([], Ds, _, _, S) ->
+ {Ds, S}.
+
+%% First we must create the new function names and set up the
+%% environment with descriptors for the letrec-bound functions.
+%%
+%% Since we never shadow variables, the free variables of any
+%% letrec-bound fun can always be referenced directly wherever the
+%% fun-variable itself is referenced - this is important when we create
+%% direct calls to lifted letrec-bound functions, and is the main reason
+%% why we do renaming. For example:
+%%
+%% 'f'/0 = fun () ->
+%% let X = 42 in
+%% letrec 'g'/1 = fun (Y) -> {X, Y} in
+%% let X = 17 in
+%% apply 'g'/1(X)
+%%
+%% will become something like
+%%
+%% 'f'/0 = fun () ->
+%% let X = 42 in
+%% let X1 = 17 in
+%% apply 'g'/2(X1, X)
+%% 'g'/2 = fun (Y, X) -> {X, Y}
+%%
+%% where the innermost X has been renamed so that the outermost X can be
+%% referenced in the call to the lifted function 'g'/2. (Renaming must
+%% of course also be applied also to letrec-bound function variables.)
+%%
+%% Furthermore, if some variable X occurs free in a fun 'f'/N, and 'f'/N
+%% it its turn occurs free in a fun 'g'/M, then we transitively count X
+%% as free in 'g'/M, even if it has no occurrence there. This allows us
+%% to rewrite code such as the following:
+%%
+%% 'f'/0 = fun () ->
+%% let X = 42 in
+%% letrec 'g'/1 = fun (Y) -> {X, Y}
+%% 'h'/1 = fun (Z) -> {'bar', apply 'g'/1(Z)}
+%% in let X = 17 in
+%% apply 'h'/1(X)
+%%
+%% into something like:
+%%
+%% 'f'/0 = fun () ->
+%% let X = 42 in
+%% let X1 = 17 in
+%% apply 'h'/2(X1, X)
+%% 'g'/2 = fun (Y, X) -> {X, Y}
+%% 'h'/2 = fun (Z, X) -> {'bar', apply 'g'/2(Z, X)}
+%%
+%% which uses only direct calls. The drawback is that if the occurrence
+%% of 'f'/N in 'g'/M instead would cause a closure to be created, then
+%% that closure could have been formed earlier (at the point where 'f'/N
+%% was defined), rather than passing on all the free variables of 'f'/N
+%% into 'g'/M. Since we must know the interface to 'g'/M (i.e., the
+%% total number of parameters) before we begin processing its body, and
+%% the interface depends on what we do to the body (and functions can be
+%% mutually recursive), this problem can only be solved by finding out
+%% _what_ we are going to do before we can even define the interfaces of
+%% the functions, by looking at _how_ variables are being referenced
+%% when we look for free variables. Currently, we don't do that.
+
+letrec_defs(Ds, Env, Ren, S) ->
+ {Env1, Ren1, S1} = bind_letrec_defs(Ds, Env, Ren, S),
+ {Env1, Ren1, lift_letrec_defs(Ds, Env1, Ren1, S1)}.
+
+%% Note: it is important that we store the *renamed* free variables for
+%% each function to be lifted.
+
+bind_letrec_defs(Ds, Env, Ren, S) ->
+ bind_letrec_defs(Ds, free_in_defs(Ds, Env, Ren), Env, Ren, S).
+
+bind_letrec_defs([{V, _F} | Ds], Free, Env, Ren, S) ->
+ Name = cerl:var_name(V),
+ {Env1, Ren1, S1} = bind_letrec_fun(Name, Free, Env, Ren, S),
+ bind_letrec_defs(Ds, Free, Env1, Ren1, S1);
+bind_letrec_defs([], _Free, Env, Ren, S) ->
+ {Env, Ren, S}.
+
+bind_letrec_fun(Name = {_,A}, Free, Env, Ren, S) ->
+ A1 = A + length(Free),
+ {Name1, Ren1, S1} = rename_letrec_fun(Name, A1, Env, Ren, S),
+ Info = #function{name = Name1, free = Free},
+ {env__bind(Name1, Info, Env), Ren1, S1}.
+
+%% Creating a new name for the lifted function that is informative, is
+%% not in the environment, and is not already used for some other lifted
+%% function.
+
+rename_letrec_fun(Name, NewArity, Env, Ren, S) ->
+ {New, S1} = new_letrec_fun_name(Name, NewArity, Env, S),
+ {New, ren__add(Name, New, Ren), s__add_function_name(New, S1)}.
+
+new_letrec_fun_name({N,_}, Arity, Env, S) ->
+ {FName, FArity} = s__get_function(S),
+ Base = fun_name_base(FName, FArity)
+ ++ "-letrec-" ++ atom_to_list(N) ++ "-",
+ %% We try the base as name first. This will usually work.
+ Name = {list_to_atom(Base), Arity},
+ case env__is_defined(Name, Env) of
+ true ->
+ new_fun_name(Base, Arity, Env, S);
+ false ->
+ case s__is_function_name(Name, S) of
+ true ->
+ new_fun_name(Base, Arity, Env, S);
+ false ->
+ {Name, S}
+ end
+ end.
+
+%% Processing the actual functions of a letrec
+
+lift_letrec_defs([{V, F} | Ds], Env, Ren, S) ->
+ Info = env__get(ren__map(cerl:var_name(V), Ren), Env),
+ S1 = lift_letrec_fun(F, Info, Env, Ren, S),
+ lift_letrec_defs(Ds, Env, Ren, S1);
+lift_letrec_defs([], _, _, S) ->
+ S.
+
+%% The direct calling convention for letrec-defined functions is to pass
+%% the free variables as additional parameters. Note that the free
+%% variables (if any) are already in the environment when we get here.
+%% We only have to append them to the parameter list so that they are in
+%% scope in the lifted function; they are already renamed.
+%%
+%% It should not be possible for the original parameters to clash with
+%% the free ones (in that case they cannot be free), but we do the full
+%% bind-and-rename anyway, since it's easiest.
+
+lift_letrec_fun(F, Info, Env, Ren, S) ->
+ {Vs, Env1, Ren1} = bind_vars(cerl:fun_vars(F), Env, Ren),
+ {B, S1} = expr(cerl:fun_body(F), Env1, Ren1, S),
+ Fs = [cerl:c_var(V) || V <- Info#function.free],
+ F1 = cerl:c_fun(Vs ++ Fs, B),
+ s__add_def(cerl:c_var(Info#function.name), F1, S1).
+
+%% This is a simple way of handling mutual recursion in a group of
+%% letrec-definitions: classify a variable as free in all the functions
+%% if it is free in any of them. (The preferred way would be to actually
+%% take the transitive closure for each function.)
+
+free_in_defs(Ds, Env, Ren) ->
+ {Vs, Fs} = free_in_defs(Ds, [], [], Ren),
+ closure_vars(ordsets:subtract(Fs, Vs), Env, Ren).
+
+free_in_defs([{V, F} | Ds], Vs, Free, Ren) ->
+ Fs = cerl_trees:free_variables(F),
+ free_in_defs(Ds, [ren__map(cerl:var_name(V), Ren) | Vs], Fs ++ Free,
+ Ren);
+free_in_defs([], Vs, Free, _Ren) ->
+ {ordsets:from_list(Vs), ordsets:from_list(Free)}.
+
+%% Replacing function variables with the free variables of the function
+
+closure_vars(Vs, Env, Ren) ->
+ closure_vars(Vs, [], Env, Ren).
+
+closure_vars([V = {_, _} | Vs], As, Env, Ren) ->
+ V1 = ren__map(V, Ren),
+ case env__lookup(V1, Env) of
+ {ok, #function{free = Vs1}} ->
+ closure_vars(Vs, Vs1 ++ As, Env, Ren);
+ _ ->
+ closure_vars(Vs, As, Env, Ren)
+ end;
+closure_vars([V | Vs], As, Env, Ren) ->
+ closure_vars(Vs, [V | As], Env, Ren);
+closure_vars([], As, _Env, _Ren) ->
+ ordsets:from_list(As).
+
+%% We use the no-shadowing strategy, renaming variables on the fly and
+%% only when necessary to uphold the invariant.
+
+bind_vars(Vs, Env, Ren) ->
+ bind_vars(Vs, [], Env, Ren).
+
+bind_vars([V | Vs], Vs1, Env, Ren) ->
+ Name = cerl:var_name(V),
+ {Name1, Ren1} = rename_var(Name, Env, Ren),
+ bind_vars(Vs, [cerl:update_c_var(V, Name1) | Vs1],
+ env__bind(Name1, variable, Env), Ren1);
+bind_vars([], Vs, Env, Ren) ->
+ {lists:reverse(Vs), Env, Ren}.
+
+rename_var(Name, Env, Ren) ->
+ case env__is_defined(Name, Env) of
+ false ->
+ {Name, Ren};
+ true ->
+ New = env__new_name(Env),
+ {New, ren__add(Name, New, Ren)}
+ end.
+
+%% This handles variable references *except* in function application
+%% operator positions (see apply_expr/4).
+%%
+%% The Beam compiler annotates function-variable references with 'id'
+%% info, eventually transforming a direct reference such as "fun f/2"
+%% into a new fun-expression "fun (X1,X2) -> apply f/2(X1,X2)" for which
+%% the info is used to create the lifted function as for any other fun.
+%% We do the same thing for function-bound variables.
+
+var(V, Env, Ren, S) ->
+ Name = ren__map(cerl:var_name(V), Ren),
+ case lookup_var(Name, Env) of
+ #function{name = F, free = Vs} ->
+ {_, Arity} = F,
+ Vs1 = make_vars(Arity),
+ C = cerl:c_apply(cerl:c_var(F), Vs1),
+ E = cerl:ann_c_fun(cerl:get_ann(V), Vs1, C),
+ fun_expr_1(E, Vs, Env, Ren, S);
+ variable ->
+ {cerl:update_c_var(V, Name), S}
+ end.
+
+lookup_var(V, Env) ->
+ case env__lookup(V, Env) of
+ {ok, X} ->
+ X;
+ error ->
+ error_msg("unbound variable `~P'.", [V, 5]),
+ exit(error)
+ end.
+
+make_vars(N) when N > 0 ->
+ [cerl:c_var(list_to_atom("X" ++ integer_to_list(N)))
+ | make_vars(N - 1)];
+make_vars(0) ->
+ [].
+
+%% All funs that are not bound by module or letrec definitions will be
+%% rewritten to create explicit closures using "make fun". We don't
+%% currently track ordinary let-bindings of funs, as in "let F = fun
+%% ... in ...apply F(...)...".
+%%
+%% Note that we (currently) follow the Beam naming convention, including
+%% the free variables in the arity of the name, even though the actual
+%% function typically expects a different number of parameters.
+
+fun_expr(F, Env, Ren, S) ->
+ Free = closure_vars(cerl_trees:free_variables(F), Env, Ren),
+ Vs = [cerl:c_var(V) || V <- Free],
+ fun_expr_1(F, Vs, Env, Ren, S).
+
+fun_expr_1(F, Vs, Env, Ren, S) ->
+ Arity = cerl:fun_arity(F) + length(Vs), % for the name only
+ {Info, S1} = fun_info(F, Env, S),
+ Name = {Info#fun_info.name, Arity},
+ S2 = lift_fun(Name, F, Vs, Env, Ren, S1),
+ {make_fun_primop(Name, Vs, Info, F, S2), S2}.
+
+make_fun_primop({Name, Arity}, Free, #fun_info{id = Id, hash = Hash},
+ F, S) ->
+ Module = s__get_module_name(S),
+ cerl:update_c_primop(F, cerl:c_atom(?PRIMOP_MAKE_FUN),
+ [cerl:c_atom(Module),
+ cerl:c_atom(Name),
+ cerl:c_int(Arity),
+ cerl:c_int(Hash),
+ cerl:c_int(Id),
+ cerl:make_list(Free)]).
+
+%% Getting attached fun-info, if present; otherwise making it up.
+
+fun_info(E, Env, S) ->
+ case lists:keyfind(id, 1, cerl:get_ann(E)) of
+ {id, {Id, H, Name}} ->
+ %% io:fwrite("Got fun-info: ~w: {~w,~w}.\n", [Name,Id,H]),
+ {#fun_info{name = Name, id = Id, hash = H}, S};
+ _ ->
+ io:fwrite("Warning - fun not annotated: "
+ "making up new name.\n"), % for now
+ {{Name,_Arity}, S1} = new_fun_name(E, Env, S),
+ {#fun_info{name = Name, id = 0, hash = 0}, S1}
+ end.
+
+fun_name_base(FName, FArity) ->
+ "-" ++ atom_to_list(FName) ++ "/" ++ integer_to_list(FArity).
+
+%% Generate a name for the new function, using a the same convention
+%% that is used by the Beam compiler.
+new_fun_name(F, Env, S) ->
+ {FName, FArity} = s__get_function(S),
+ Base = fun_name_base(FName, FArity) ++ "-fun-",
+ Arity = cerl:fun_arity(F),
+ new_fun_name(Base, Arity, Env, S).
+
+%% Creating a new function name that is not in the environment and is
+%% not already used for some other lifted function.
+
+new_fun_name(Base, Arity, Env, S) ->
+ F = fun (N) ->
+ {list_to_atom(Base ++ integer_to_list(N)), Arity}
+ end,
+ new_fun_name(Base, Arity, Env, S, F).
+
+new_fun_name(Base, Arity, Env, S, F) ->
+ %% Note that repeated calls to env__new_function_name/2 will yield
+ %% different names even though Env and F are the same.
+ Name = env__new_function_name(F, Env),
+ case s__is_function_name(Name, S) of
+ true ->
+ new_fun_name(Base, Arity, Env, S, F);
+ false ->
+ {Name, S}
+ end.
+
+%% This lifts the fun to a new top-level function which uses the calling
+%% convention for closures, with the closure itself as the final
+%% parameter. Note that the free variables (if any) are already in the
+%% environment.
+%%
+%% It should not be possible for the original parameters to clash with
+%% the free ones (in that case they cannot be free), but we do the full
+%% bind-and-rename anyway, since it's easiest.
+
+lift_fun(Name, F, Free, Env, Ren, S) ->
+ %% If the name is already in the list of top-level definitions, we
+ %% assume we have already generated this function, and do not need
+ %% to do it again (typically, this happens for 'fun f/n'-variables
+ %% that have been duplicated before being rewritten to actual
+ %% fun-expressions, and the name is taken from their annotations).
+ %% Otherwise, we add the name to the list.
+ case s__is_function_name(Name, S) of
+ true ->
+ S;
+ false ->
+ S1 = s__add_function_name(Name, S),
+ lift_fun_1(Name, F, Free, Env, Ren, S1)
+ end.
+
+lift_fun_1(Name, F, Free, Env, Ren, S) ->
+ %% (The original parameters must be added to the environment before
+ %% we generate the new variable for the closure parameter.)
+ {Vs, Env1, Ren1} = bind_vars(cerl:fun_vars(F), Env, Ren),
+ V = env__new_name(Env1),
+ Env2 = env__bind(V, variable, Env1),
+ {B, S1} = expr(cerl:fun_body(F), Env2, Ren1, S),
+ %% We unpack all free variables from the closure upon entering.
+ %% (Adding this to the body before we process it would introduce
+ %% unnecessary, although harmless, renaming of the free variables.)
+ Es = closure_elements(length(Free), cerl:c_var(V)),
+ B1 = cerl:c_let(Free, cerl:c_values(Es), B),
+ %% The closure itself is passed as the last argument. The new
+ %% function is annotated as being a closure-call entry point.
+ E = cerl:ann_c_fun([closure, {closure_orig_arity, cerl:fun_arity(F)}], Vs ++ [cerl:c_var(V)], B1),
+ s__add_def(cerl:c_var(Name), E, S1).
+
+closure_elements(N, V) ->
+ closure_elements(N, N + 1, V).
+
+closure_elements(0, _, _) -> [];
+closure_elements(N, M, V) ->
+ [cerl:c_primop(cerl:c_atom(?PRIMOP_FUN_ELEMENT),
+ [cerl:c_int(M - N), V])
+ | closure_elements(N - 1, M, V)].
+
+
+%% Function applications must be rewritten depending on the
+%% operator. For a call to a known top-level function or letrec-bound
+%% function, we make a direct call, passing the free variables as extra
+%% parameters (we know they are in scope, since variables may not be
+%% shadowed). Otherwise, we create an "apply fun" primop call that
+%% expects a closure.
+
+apply_expr(E, Env, Ren, S) ->
+ {As, S1} = expr_list(cerl:apply_args(E), Env, Ren, S),
+ Op = cerl:apply_op(E),
+ case cerl:is_c_var(Op) of
+ true ->
+ Name = ren__map(cerl:var_name(Op), Ren),
+ case lookup_var(Name, Env) of
+ #function{name = F, free = Vs} ->
+ Vs1 = As ++ [cerl:c_var(V) || V <- Vs],
+ {cerl:update_c_apply(E, cerl:c_var(F), Vs1), S1};
+ variable ->
+ apply_expr_1(E, Op, As, Env, Ren, S1)
+ end;
+ _ ->
+ apply_expr_1(E, Op, As, Env, Ren, S1)
+ end.
+
+%% Note that this primop call only communicates the necessary
+%% information to the core-to-icode stage, which rewrites it to use the
+%% real calling convention for funs.
+
+apply_expr_1(E, Op, As, Env, Ren, S) ->
+ {Op1, S1} = expr(Op, Env, Ren, S),
+ Call = cerl:update_c_primop(E, cerl:c_atom(?PRIMOP_APPLY_FUN),
+ [Op1, cerl:make_list(As)]),
+ {Call, S1}.
+
+
+%% ---------------------------------------------------------------------
+%% Environment
+
+env__new() ->
+ rec_env:empty().
+
+env__bind(Key, Value, Env) ->
+ rec_env:bind(Key, Value, Env).
+
+env__lookup(Key, Env) ->
+ rec_env:lookup(Key, Env).
+
+env__get(Key, Env) ->
+ rec_env:get(Key, Env).
+
+env__is_defined(Key, Env) ->
+ rec_env:is_defined(Key, Env).
+
+env__new_name(Env) ->
+ rec_env:new_key(Env).
+
+env__new_function_name(F, Env) ->
+ rec_env:new_key(F, Env).
+
+
+%% ---------------------------------------------------------------------
+%% Renaming
+
+ren__new() ->
+ dict:new().
+
+ren__add(Key, Value, Ren) ->
+ dict:store(Key, Value, Ren).
+
+ren__map(Key, Ren) ->
+ case dict:find(Key, Ren) of
+ {ok, Value} ->
+ Value;
+ error ->
+ Key
+ end.
+
+
+%% ---------------------------------------------------------------------
+%% State
+
+-record(state, {module :: module(), function :: {atom(), arity()},
+ names, refs, defs = []}).
+
+s__new(Module) ->
+ #state{module = Module, names = sets:new(), refs = dict:new()}.
+
+s__add_function_name(Name, S) ->
+ S#state{names = sets:add_element(Name, S#state.names)}.
+
+s__is_function_name(Name, S) ->
+ sets:is_element(Name, S#state.names).
+
+s__get_module_name(S) ->
+ S#state.module.
+
+s__enter_function(F, S) ->
+ S#state{function = F}.
+
+s__get_function(S) ->
+ S#state.function.
+
+s__add_def(V, F, S) ->
+ S#state{defs = [{V, F} | S#state.defs]}.
+
+s__get_defs(S) ->
+ S#state.defs.
+
+
+%% ---------------------------------------------------------------------
+%% Reporting
+
+%% internal_error_msg(S) ->
+%% internal_error_msg(S, []).
+
+%% internal_error_msg(S, Vs) ->
+%% error_msg(lists:concat(["Internal error: ", S]), Vs).
+
+%% error_msg(S) ->
+%% error_msg(S, []).
+
+error_msg(S, Vs) ->
+ error_logger:error_msg(lists:concat([?MODULE, ": ", S, "\n"]), Vs).
+
+%% warning_msg(S) ->
+%% warning_msg(S, []).
+
+%% warning_msg(S, Vs) ->
+%% info_msg(lists:concat(["warning: ", S]), Vs).
+
+%% info_msg(S) ->
+%% info_msg(S, []).
+
+%% info_msg(S, Vs) ->
+%% error_logger:info_msg(lists:concat([?MODULE, ": ", S, "\n"]), Vs).
diff --git a/lib/hipe/cerl/cerl_closurean.erl b/lib/hipe/cerl/cerl_closurean.erl
new file mode 100644
index 0000000000..12771668ac
--- /dev/null
+++ b/lib/hipe/cerl/cerl_closurean.erl
@@ -0,0 +1,862 @@
+%%
+%% %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%
+%%
+%% =====================================================================
+%% Closure analysis of Core Erlang programs.
+%%
+%% Copyright (C) 2001-2002 Richard Carlsson
+%%
+%% Author contact: [email protected]
+%% =====================================================================
+
+%% TODO: might need a "top" (`any') element for any-length value lists.
+
+-module(cerl_closurean).
+
+-export([analyze/1, annotate/1]).
+%% The following functions are exported from this module since they
+%% are also used by Dialyzer (file dialyzer/src/dialyzer_dep.erl)
+-export([is_escape_op/2, is_escape_op/3, is_literal_op/2, is_literal_op/3]).
+
+-import(cerl, [ann_c_apply/3, ann_c_fun/3, ann_c_var/2, apply_args/1,
+ apply_op/1, atom_val/1, bitstr_size/1, bitstr_val/1,
+ binary_segments/1, c_letrec/2, c_seq/2, c_tuple/1,
+ c_nil/0, call_args/1, call_module/1, call_name/1,
+ case_arg/1, case_clauses/1, catch_body/1, clause_body/1,
+ clause_guard/1, clause_pats/1, cons_hd/1, cons_tl/1,
+ fun_body/1, fun_vars/1, get_ann/1, is_c_atom/1,
+ let_arg/1, let_body/1, let_vars/1, letrec_body/1,
+ letrec_defs/1, module_defs/1, module_defs/1,
+ module_exports/1, pat_vars/1, primop_args/1,
+ primop_name/1, receive_action/1, receive_clauses/1,
+ receive_timeout/1, seq_arg/1, seq_body/1, set_ann/2,
+ try_arg/1, try_body/1, try_vars/1, try_evars/1,
+ try_handler/1, tuple_es/1, type/1, values_es/1]).
+
+-import(cerl_trees, [get_label/1]).
+
+%% ===========================================================================
+
+-type label() :: integer() | 'top' | 'external' | 'external_call'.
+-type ordset(X) :: [X]. % XXX: TAKE ME OUT
+-type labelset() :: ordset(label()).
+-type outlist() :: [labelset()] | 'none'.
+-type escapes() :: labelset().
+
+%% ===========================================================================
+%% annotate(Tree) -> {Tree1, OutList, Outputs, Escapes, Dependencies, Parents}
+%%
+%% Tree = cerl:cerl()
+%%
+%% Analyzes `Tree' (see `analyze') and appends terms `{callers,
+%% Labels}' and `{calls, Labels}' to the annotation list of each
+%% fun-expression node and apply-expression node of `Tree',
+%% respectively, where `Labels' is an ordered-set list of labels of
+%% fun-expressions in `Tree', possibly also containing the atom
+%% `external', corresponding to the dependency information derived
+%% by the analysis. Any previous such annotations are removed from
+%% `Tree'. `Tree1' is the modified tree; for details on `OutList',
+%% `Outputs' , `Dependencies', `Escapes' and `Parents', see
+%% `analyze'.
+%%
+%% Note: `Tree' must be annotated with labels in order to use this
+%% function; see `analyze' for details.
+
+-spec annotate(cerl:cerl()) ->
+ {cerl:cerl(), outlist(), dict(), escapes(), dict(), dict()}.
+
+annotate(Tree) ->
+ {Xs, Out, Esc, Deps, Par} = analyze(Tree),
+ F = fun (T) ->
+ case type(T) of
+ 'fun' ->
+ L = get_label(T),
+ X = case dict:find(L, Deps) of
+ {ok, X1} -> X1;
+ error -> set__new()
+ end,
+ set_ann(T, append_ann(callers,
+ set__to_list(X),
+ get_ann(T)));
+ apply ->
+ L = get_label(T),
+ X = case dict:find(L, Deps) of
+ {ok, X1} -> X1;
+ error -> set__new()
+ end,
+ set_ann(T, append_ann(calls,
+ set__to_list(X),
+ get_ann(T)));
+ _ ->
+%%% set_ann(T, []) % debug
+ T
+ end
+ end,
+ {cerl_trees:map(F, Tree), Xs, Out, Esc, Deps, Par}.
+
+append_ann(Tag, Val, [X | Xs]) ->
+ if tuple_size(X) >= 1, element(1, X) =:= Tag ->
+ append_ann(Tag, Val, Xs);
+ true ->
+ [X | append_ann(Tag, Val, Xs)]
+ end;
+append_ann(Tag, Val, []) ->
+ [{Tag, Val}].
+
+%% =====================================================================
+%% analyze(Tree) -> {OutList, Outputs, Escapes, Dependencies, Parents}
+%%
+%% Tree = cerl()
+%% OutList = [LabelSet] | none
+%% Outputs = dict(Label, OutList)
+%% Escapes = LabelSet
+%% Dependencies = dict(Label, LabelSet)
+%% LabelSet = ordset(Label)
+%% Label = integer() | top | external | external_call
+%% Parents = dict(Label, Label)
+%%
+%% Analyzes a module or an expression represented by `Tree'.
+%%
+%% The returned `OutList' is a list of sets of labels of
+%% fun-expressions which correspond to the possible closures in the
+%% value list produced by `Tree' (viewed as an expression; the
+%% "value" of a module contains its exported functions). The atom
+%% `none' denotes missing or conflicting information.
+%%
+%% The atom `external' in any label set denotes any possible
+%% function outside `Tree', including those in `Escapes'. The atom
+%% `top' denotes the top-level expression `Tree'.
+%%
+%% `Outputs' is a mapping from the labels of fun-expressions in
+%% `Tree' to corresponding lists of sets of labels of
+%% fun-expressions (or the atom `none'), representing the possible
+%% closures in the value lists returned by the respective
+%% functions.
+%%
+%% `Dependencies' is a similar mapping from the labels of
+%% fun-expressions and apply-expressions in `Tree' to sets of
+%% labels of corresponding fun-expressions which may contain call
+%% sites of the functions or be called from the call sites,
+%% respectively. Any such label not defined in `Dependencies'
+%% represents an unreachable function or a dead or faulty
+%% application.
+%%
+%% `Escapes' is the set of labels of fun-expressions in `Tree' such
+%% that corresponding closures may be accessed from outside `Tree'.
+%%
+%% `Parents' is a mapping from labels of fun-expressions in `Tree'
+%% to the corresponding label of the nearest containing
+%% fun-expression or top-level expression. This can be used to
+%% extend the dependency graph, for certain analyses.
+%%
+%% Note: `Tree' must be annotated with labels (as done by the
+%% function `cerl_trees:label/1') in order to use this function.
+%% The label annotation `{label, L}' (where L should be an integer)
+%% must be the first element of the annotation list of each node in
+%% the tree. Instances of variables bound in `Tree' which denote
+%% the same variable must have the same label; apart from this,
+%% labels should be unique. Constant literals do not need to be
+%% labeled.
+
+-record(state, {vars, out, dep, work, funs, par}).
+
+%% Note: In order to keep our domain simple, we assume that all remote
+%% calls and primops return a single value, if any.
+
+%% We use the terms `closure', `label', `lambda' and `fun-expression'
+%% interchangeably. The exact meaning in each case can be grasped from
+%% the context.
+%%
+%% Rules:
+%% 1) The implicit top level lambda escapes.
+%% 2) A lambda returned by an escaped lambda also escapes.
+%% 3) An escaped lambda can be passed an external lambda as argument.
+%% 4) A lambda passed as argument to an external lambda also escapes.
+%% 5) An argument passed to an unknown operation escapes.
+%% 6) A call to an unknown operation can return an external lambda.
+%%
+%% Escaped lambdas become part of the set of external lambdas, but this
+%% does not need to be represented explicitly.
+
+%% We wrap the given syntax tree T in a fun-expression labeled `top',
+%% which is initially in the set of escaped labels. `top' will be
+%% visited at least once.
+%%
+%% We create a separate function labeled `external', defined as:
+%% "'external'/1 = fun (Escape) -> do apply 'external'/1(apply Escape())
+%% 'external'/1", which will represent any and all functions outside T,
+%% and which returns itself, and contains a recursive call; this models
+%% rules 2 and 4 above. It will be revisited if the set of escaped
+%% labels changes, or at least once. Its parameter `Escape' is a
+%% variable labeled `escape', which will hold the set of escaped labels.
+%% initially it contains `top' and `external'.
+
+-spec analyze(cerl:cerl()) -> {outlist(), dict(), escapes(), dict(), dict()}.
+
+analyze(Tree) ->
+ %% Note that we use different name spaces for variable labels and
+ %% function/call site labels, so we can reuse some names here. We
+ %% assume that the labeling of Tree only uses integers, not atoms.
+ External = ann_c_var([{label, external}], {external, 1}),
+ Escape = ann_c_var([{label, escape}], 'Escape'),
+ ExtBody = c_seq(ann_c_apply([{label, loop}], External,
+ [ann_c_apply([{label, external_call}],
+ Escape, [])]),
+ External),
+ ExtFun = ann_c_fun([{label, external}], [Escape], ExtBody),
+%%% io:fwrite("external fun:\n~s.\n",
+%%% [cerl_prettypr:format(ExtFun, [noann])]),
+ Top = ann_c_var([{label, top}], {top, 0}),
+ TopFun = ann_c_fun([{label, top}], [], Tree),
+
+ %% The "start fun" just makes the initialisation easier. It will not
+ %% be marked as escaped, and thus cannot be called.
+ StartFun = ann_c_fun([{label, start}], [],
+ c_letrec([{External, ExtFun}, {Top, TopFun}],
+ c_nil())),
+%%% io:fwrite("start fun:\n~s.\n",
+%%% [cerl_prettypr:format(StartFun, [noann])]),
+
+ %% Gather a database of all fun-expressions in Tree and initialise
+ %% all their outputs and parameter variables. Bind all module- and
+ %% letrec-defined variables to their corresponding labels.
+ Funs0 = dict:new(),
+ Vars0 = dict:new(),
+ Out0 = dict:new(),
+ Empty = empty(),
+ F = fun (T, S = {Fs, Vs, Os}) ->
+ case type(T) of
+ 'fun' ->
+ L = get_label(T),
+ As = fun_vars(T),
+ {dict:store(L, T, Fs),
+ bind_vars_single(As, Empty, Vs),
+ dict:store(L, none, Os)};
+ letrec ->
+ {Fs, bind_defs(letrec_defs(T), Vs), Os};
+ module ->
+ {Fs, bind_defs(module_defs(T), Vs), Os};
+ _ ->
+ S
+ end
+ end,
+ {Funs, Vars, Out} = cerl_trees:fold(F, {Funs0, Vars0, Out0},
+ StartFun),
+
+ %% Initialise Escape to the minimal set of escaped labels.
+ Vars1 = dict:store(escape, from_label_list([top, external]), Vars),
+
+ %% Enter the fixpoint iteration at the StartFun.
+ St = loop(StartFun, start, #state{vars = Vars1,
+ out = Out,
+ dep = dict:new(),
+ work = init_work(),
+ funs = Funs,
+ par = dict:new()}),
+%%% io:fwrite("dependencies: ~p.\n",
+%%% [[{X, set__to_list(Y)}
+%%% || {X, Y} <- dict:to_list(St#state.dep)]]),
+ {dict:fetch(top, St#state.out),
+ tidy_dict([start, top, external], St#state.out),
+ dict:fetch(escape, St#state.vars),
+ tidy_dict([loop], St#state.dep),
+ St#state.par}.
+
+tidy_dict([X | Xs], D) ->
+ tidy_dict(Xs, dict:erase(X, D));
+tidy_dict([], D) ->
+ D.
+
+loop(T, L, St0) ->
+%%% io:fwrite("analyzing: ~w.\n", [L]),
+%%% io:fwrite("work: ~w.\n", [St0#state.work]),
+ Xs0 = dict:fetch(L, St0#state.out),
+ {Xs, St1} = visit(fun_body(T), L, St0),
+ {W, M} = case equal(Xs0, Xs) of
+ true ->
+ {St1#state.work, St1#state.out};
+ false ->
+%%% io:fwrite("out (~w) changed: ~w <- ~w.\n",
+%%% [L, Xs, Xs0]),
+ M1 = dict:store(L, Xs, St1#state.out),
+ case dict:find(L, St1#state.dep) of
+ {ok, S} ->
+ {add_work(set__to_list(S), St1#state.work),
+ M1};
+ error ->
+ {St1#state.work, M1}
+ end
+ end,
+ St2 = St1#state{out = M},
+ case take_work(W) of
+ {ok, L1, W1} ->
+ T1 = dict:fetch(L1, St2#state.funs),
+ loop(T1, L1, St2#state{work = W1});
+ none ->
+ St2
+ end.
+
+visit(T, L, St) ->
+ case type(T) of
+ literal ->
+ {[empty()], St};
+ var ->
+ %% If a variable is not already in the store here, we
+ %% initialize it to empty().
+ L1 = get_label(T),
+ Vars = St#state.vars,
+ case dict:find(L1, Vars) of
+ {ok, X} ->
+ {[X], St};
+ error ->
+ X = empty(),
+ St1 = St#state{vars = dict:store(L1, X, Vars)},
+ {[X], St1}
+ end;
+ 'fun' ->
+ %% Must revisit the fun also, because its environment might
+ %% have changed. (We don't keep track of such dependencies.)
+ L1 = get_label(T),
+ St1 = St#state{work = add_work([L1], St#state.work),
+ par = set_parent([L1], L, St#state.par)},
+ {[singleton(L1)], St1};
+ values ->
+ visit_list(values_es(T), L, St);
+ cons ->
+ {Xs, St1} = visit_list([cons_hd(T), cons_tl(T)], L, St),
+ {[join_single_list(Xs)], St1};
+ tuple ->
+ {Xs, St1} = visit_list(tuple_es(T), L, St),
+ {[join_single_list(Xs)], St1};
+ 'let' ->
+ {Xs, St1} = visit(let_arg(T), L, St),
+ Vars = bind_vars(let_vars(T), Xs, St1#state.vars),
+ visit(let_body(T), L, St1#state{vars = Vars});
+ seq ->
+ {_, St1} = visit(seq_arg(T), L, St),
+ visit(seq_body(T), L, St1);
+ apply ->
+ {Xs, St1} = visit(apply_op(T), L, St),
+ {As, St2} = visit_list(apply_args(T), L, St1),
+ case Xs of
+ [X] ->
+ %% We store the dependency from the call site to the
+ %% called functions
+ Ls = set__to_list(X),
+ Out = St2#state.out,
+ Xs1 = join_list([dict:fetch(Lx, Out) || Lx <- Ls]),
+ St3 = call_site(Ls, L, As, St2),
+ L1 = get_label(T),
+ D = dict:store(L1, X, St3#state.dep),
+ {Xs1, St3#state{dep = D}};
+ none ->
+ {none, St2}
+ end;
+ call ->
+ M = call_module(T),
+ F = call_name(T),
+ {_, St1} = visit(M, L, St),
+ {_, St2} = visit(F, L, St1),
+ {Xs, St3} = visit_list(call_args(T), L, St2),
+ remote_call(M, F, Xs, St3);
+ primop ->
+ As = primop_args(T),
+ {Xs, St1} = visit_list(As, L, St),
+ primop_call(atom_val(primop_name(T)), length(Xs), Xs, St1);
+ 'case' ->
+ {Xs, St1} = visit(case_arg(T), L, St),
+ visit_clauses(Xs, case_clauses(T), L, St1);
+ 'receive' ->
+ X = singleton(external),
+ {Xs1, St1} = visit_clauses([X], receive_clauses(T), L, St),
+ {_, St2} = visit(receive_timeout(T), L, St1),
+ {Xs2, St3} = visit(receive_action(T), L, St2),
+ {join(Xs1, Xs2), St3};
+ 'try' ->
+ {Xs1, St1} = visit(try_arg(T), L, St),
+ X = singleton(external),
+ Vars = bind_vars(try_vars(T), [X], St1#state.vars),
+ {Xs2, St2} = visit(try_body(T), L, St1#state{vars = Vars}),
+ Evars = bind_vars(try_evars(T), [X, X, X], St2#state.vars),
+ {Xs3, St3} = visit(try_handler(T), L, St2#state{vars = Evars}),
+ {join(join(Xs1, Xs2), Xs3), St3};
+ 'catch' ->
+ {_, St1} = visit(catch_body(T), L, St),
+ {[singleton(external)], St1};
+ binary ->
+ {_, St1} = visit_list(binary_segments(T), L, St),
+ {[empty()], St1};
+ bitstr ->
+ %% The other fields are constant literals.
+ {_, St1} = visit(bitstr_val(T), L, St),
+ {_, St2} = visit(bitstr_size(T), L, St1),
+ {none, St2};
+ letrec ->
+ %% All the bound funs should be revisited, because the
+ %% environment might have changed.
+ Ls = [get_label(F) || {_, F} <- letrec_defs(T)],
+ St1 = St#state{work = add_work(Ls, St#state.work),
+ par = set_parent(Ls, L, St#state.par)},
+ visit(letrec_body(T), L, St1);
+ module ->
+ %% All the exported functions escape, and can thus be passed
+ %% any external closures as arguments. We regard a module as
+ %% a tuple of function variables in the body of a `letrec'.
+ visit(c_letrec(module_defs(T), c_tuple(module_exports(T))),
+ L, St)
+ end.
+
+visit_clause(T, Xs, L, St) ->
+ Vars = bind_pats(clause_pats(T), Xs, St#state.vars),
+ {_, St1} = visit(clause_guard(T), L, St#state{vars = Vars}),
+ visit(clause_body(T), L, St1).
+
+%% We assume correct value-list typing.
+
+visit_list([T | Ts], L, St) ->
+ {Xs, St1} = visit(T, L, St),
+ {Xs1, St2} = visit_list(Ts, L, St1),
+ X = case Xs of
+ [X1] -> X1;
+ none -> none
+ end,
+ {[X | Xs1], St2};
+visit_list([], _L, St) ->
+ {[], St}.
+
+visit_clauses(Xs, [T | Ts], L, St) ->
+ {Xs1, St1} = visit_clause(T, Xs, L, St),
+ {Xs2, St2} = visit_clauses(Xs, Ts, L, St1),
+ {join(Xs1, Xs2), St2};
+visit_clauses(_, [], _L, St) ->
+ {none, St}.
+
+bind_defs([{V, F} | Ds], Vars) ->
+ bind_defs(Ds, dict:store(get_label(V), singleton(get_label(F)),
+ Vars));
+bind_defs([], Vars) ->
+ Vars.
+
+bind_pats(Ps, none, Vars) ->
+ bind_pats_single(Ps, empty(), Vars);
+bind_pats(Ps, Xs, Vars) ->
+ if length(Xs) =:= length(Ps) ->
+ bind_pats_list(Ps, Xs, Vars);
+ true ->
+ bind_pats_single(Ps, empty(), Vars)
+ end.
+
+bind_pats_list([P | Ps], [X | Xs], Vars) ->
+ bind_pats_list(Ps, Xs, bind_vars_single(pat_vars(P), X, Vars));
+bind_pats_list([], [], Vars) ->
+ Vars.
+
+bind_pats_single([P | Ps], X, Vars) ->
+ bind_pats_single(Ps, X, bind_vars_single(pat_vars(P), X, Vars));
+bind_pats_single([], _X, Vars) ->
+ Vars.
+
+bind_vars(Vs, none, Vars) ->
+ bind_vars_single(Vs, empty(), Vars);
+bind_vars(Vs, Xs, Vars) ->
+ if length(Vs) =:= length(Xs) ->
+ bind_vars_list(Vs, Xs, Vars);
+ true ->
+ bind_vars_single(Vs, empty(), Vars)
+ end.
+
+bind_vars_list([V | Vs], [X | Xs], Vars) ->
+ bind_vars_list(Vs, Xs, dict:store(get_label(V), X, Vars));
+bind_vars_list([], [], Vars) ->
+ Vars.
+
+bind_vars_single([V | Vs], X, Vars) ->
+ bind_vars_single(Vs, X, dict:store(get_label(V), X, Vars));
+bind_vars_single([], _X, Vars) ->
+ Vars.
+
+%% This handles a call site - adding dependencies and updating parameter
+%% variables with respect to the actual parameters. The 'external'
+%% function is handled specially, since it can get an arbitrary number
+%% of arguments, which must be unified into a single argument.
+
+call_site(Ls, L, Xs, St) ->
+%%% io:fwrite("call site: ~w -> ~w (~w).\n", [L, Ls, Xs]),
+ {D, W, V} = call_site(Ls, L, Xs, St#state.dep, St#state.work,
+ St#state.vars, St#state.funs),
+ St#state{dep = D, work = W, vars = V}.
+
+call_site([external | Ls], T, Xs, D, W, V, Fs) ->
+ D1 = add_dep(external, T, D),
+ X = join_single_list(Xs),
+ case bind_arg(escape, X, V) of
+ {V1, true} ->
+%%% io:fwrite("escape changed: ~w <- ~w + ~w.\n",
+%%% [dict:fetch(escape, V1), dict:fetch(escape, V),
+%%% X]),
+ {W1, V2} = update_esc(set__to_list(X), W, V1, Fs),
+ call_site(Ls, T, Xs, D1, add_work([external], W1), V2, Fs);
+ {V1, false} ->
+ call_site(Ls, T, Xs, D1, W, V1, Fs)
+ end;
+call_site([L | Ls], T, Xs, D, W, V, Fs) ->
+ D1 = add_dep(L, T, D),
+ Vs = fun_vars(dict:fetch(L, Fs)),
+ case bind_args(Vs, Xs, V) of
+ {V1, true} ->
+ call_site(Ls, T, Xs, D1, add_work([L], W), V1, Fs);
+ {V1, false} ->
+ call_site(Ls, T, Xs, D1, W, V1, Fs)
+ end;
+call_site([], _, _, D, W, V, _) ->
+ {D, W, V}.
+
+%% Note that `visit' makes sure all lambdas are visited at least once.
+%% For every called function, we add a dependency from the *called*
+%% function to the function containing the call site.
+
+add_dep(Source, Target, Deps) ->
+ case dict:find(Source, Deps) of
+ {ok, X} ->
+ case set__is_member(Target, X) of
+ true ->
+ Deps;
+ false ->
+%%% io:fwrite("new dep: ~w <- ~w.\n", [Target, Source]),
+ dict:store(Source, set__add(Target, X), Deps)
+ end;
+ error ->
+%%% io:fwrite("new dep: ~w <- ~w.\n", [Target, Source]),
+ dict:store(Source, set__singleton(Target), Deps)
+ end.
+
+%% If the arity does not match the call, nothing is done here.
+
+bind_args(Vs, Xs, Vars) ->
+ if length(Vs) =:= length(Xs) ->
+ bind_args(Vs, Xs, Vars, false);
+ true ->
+ {Vars, false}
+ end.
+
+bind_args([V | Vs], [X | Xs], Vars, Ch) ->
+ L = get_label(V),
+ {Vars1, Ch1} = bind_arg(L, X, Vars, Ch),
+ bind_args(Vs, Xs, Vars1, Ch1);
+bind_args([], [], Vars, Ch) ->
+ {Vars, Ch}.
+
+bind_args_single(Vs, X, Vars) ->
+ bind_args_single(Vs, X, Vars, false).
+
+bind_args_single([V | Vs], X, Vars, Ch) ->
+ L = get_label(V),
+ {Vars1, Ch1} = bind_arg(L, X, Vars, Ch),
+ bind_args_single(Vs, X, Vars1, Ch1);
+bind_args_single([], _, Vars, Ch) ->
+ {Vars, Ch}.
+
+bind_arg(L, X, Vars) ->
+ bind_arg(L, X, Vars, false).
+
+bind_arg(L, X, Vars, Ch) ->
+ X0 = dict:fetch(L, Vars),
+ X1 = join_single(X, X0),
+ case equal_single(X0, X1) of
+ true ->
+ {Vars, Ch};
+ false ->
+%%% io:fwrite("arg (~w) changed: ~w <- ~w + ~w.\n",
+%%% [L, X1, X0, X]),
+ {dict:store(L, X1, Vars), true}
+ end.
+
+%% This handles escapes from things like primops and remote calls.
+
+%% escape(none, St) ->
+%% St;
+escape([X], St) ->
+ Vars = St#state.vars,
+ X0 = dict:fetch(escape, Vars),
+ X1 = join_single(X, X0),
+ case equal_single(X0, X1) of
+ true ->
+ St;
+ false ->
+%%% io:fwrite("escape changed: ~w <- ~w + ~w.\n", [X1, X0, X]),
+%%% io:fwrite("updating escaping funs: ~w.\n", [set__to_list(X)]),
+ Vars1 = dict:store(escape, X1, Vars),
+ {W, Vars2} = update_esc(set__to_list(set__subtract(X, X0)),
+ St#state.work, Vars1,
+ St#state.funs),
+ St#state{work = add_work([external], W), vars = Vars2}
+ end.
+
+%% For all escaping lambdas, since they might be called from outside the
+%% program, all their arguments may be an external lambda. (Note that we
+%% only have to include the `external' label once per escaping lambda.)
+%% If the escape set has changed, we need to revisit the `external' fun.
+
+update_esc(Ls, W, V, Fs) ->
+ update_esc(Ls, singleton(external), W, V, Fs).
+
+%% The external lambda is skipped here - the Escape variable is known to
+%% contain `external' from the start.
+
+update_esc([external | Ls], X, W, V, Fs) ->
+ update_esc(Ls, X, W, V, Fs);
+update_esc([L | Ls], X, W, V, Fs) ->
+ Vs = fun_vars(dict:fetch(L, Fs)),
+ case bind_args_single(Vs, X, V) of
+ {V1, true} ->
+ update_esc(Ls, X, add_work([L], W), V1, Fs);
+ {V1, false} ->
+ update_esc(Ls, X, W, V1, Fs)
+ end;
+update_esc([], _, W, V, _) ->
+ {W, V}.
+
+set_parent([L | Ls], L1, D) ->
+ set_parent(Ls, L1, dict:store(L, L1, D));
+set_parent([], _L1, D) ->
+ D.
+
+%% Handle primop calls: (At present, we assume that all unknown primops
+%% yield exactly one value. This might have to be changed.)
+
+primop_call(F, A, Xs, St0) ->
+ case is_pure_op(F, A) of
+ %% XXX: this case is currently not possible -- commented out.
+ %% true ->
+ %% case is_literal_op(F, A) of
+ %% true -> {[empty()], St0};
+ %% false -> {[join_single_list(Xs)], St0}
+ %% end;
+ false ->
+ St1 = case is_escape_op(F, A) of
+ true -> escape([join_single_list(Xs)], St0);
+ false -> St0
+ end,
+ case is_literal_op(F, A) of
+ true -> {none, St1};
+ false -> {[singleton(external)], St1}
+ end
+ end.
+
+%% Handle remote-calls: (At present, we assume that all unknown calls
+%% yield exactly one value. This might have to be changed.)
+
+remote_call(M, F, Xs, St) ->
+ case is_c_atom(M) andalso is_c_atom(F) of
+ true ->
+ remote_call_1(atom_val(M), atom_val(F), length(Xs), Xs, St);
+ false ->
+ %% Unknown function
+ {[singleton(external)], escape([join_single_list(Xs)], St)}
+ end.
+
+remote_call_1(M, F, A, Xs, St0) ->
+ case is_pure_op(M, F, A) of
+ true ->
+ case is_literal_op(M, F, A) of
+ true -> {[empty()], St0};
+ false -> {[join_single_list(Xs)], St0}
+ end;
+ false ->
+ St1 = case is_escape_op(M, F, A) of
+ true -> escape([join_single_list(Xs)], St0);
+ false -> St0
+ end,
+ case is_literal_op(M, F, A) of
+ true -> {[empty()], St1};
+ false -> {[singleton(external)], St1}
+ end
+ end.
+
+%% Domain: none | [Vs], where Vs = set(integer()).
+
+join(none, Xs2) -> Xs2;
+join(Xs1, none) -> Xs1;
+join(Xs1, Xs2) ->
+ if length(Xs1) =:= length(Xs2) ->
+ join_1(Xs1, Xs2);
+ true ->
+ none
+ end.
+
+join_1([X1 | Xs1], [X2 | Xs2]) ->
+ [join_single(X1, X2) | join_1(Xs1, Xs2)];
+join_1([], []) ->
+ [].
+
+empty() -> set__new().
+
+singleton(X) -> set__singleton(X).
+
+from_label_list(X) -> set__from_list(X).
+
+join_single(none, Y) -> Y;
+join_single(X, none) -> X;
+join_single(X, Y) -> set__union(X, Y).
+
+join_list([Xs | Xss]) ->
+ join(Xs, join_list(Xss));
+join_list([]) ->
+ none.
+
+join_single_list([X | Xs]) ->
+ join_single(X, join_single_list(Xs));
+join_single_list([]) ->
+ empty().
+
+equal(none, none) -> true;
+equal(none, _) -> false;
+equal(_, none) -> false;
+equal(X1, X2) -> equal_1(X1, X2).
+
+equal_1([X1 | Xs1], [X2 | Xs2]) ->
+ equal_single(X1, X2) andalso equal_1(Xs1, Xs2);
+equal_1([], []) -> true;
+equal_1(_, _) -> false.
+
+equal_single(X, Y) -> set__equal(X, Y).
+
+%% Set abstraction for label sets in the domain.
+
+set__new() -> [].
+
+set__singleton(X) -> [X].
+
+set__to_list(S) -> S.
+
+set__from_list(S) -> ordsets:from_list(S).
+
+set__union(X, Y) -> ordsets:union(X, Y).
+
+set__add(X, S) -> ordsets:add_element(X, S).
+
+set__is_member(X, S) -> ordsets:is_element(X, S).
+
+set__subtract(X, Y) -> ordsets:subtract(X, Y).
+
+set__equal(X, Y) -> X =:= Y.
+
+%% A simple but efficient functional queue.
+
+queue__new() -> {[], []}.
+
+queue__put(X, {In, Out}) -> {[X | In], Out}.
+
+queue__get({In, [X | Out]}) -> {ok, X, {In, Out}};
+queue__get({[], _}) -> empty;
+queue__get({In, _}) ->
+ [X | In1] = lists:reverse(In),
+ {ok, X, {[], In1}}.
+
+%% The work list - a queue without repeated elements.
+
+init_work() ->
+ {queue__new(), sets:new()}.
+
+add_work(Ls, {Q, Set}) ->
+ add_work(Ls, Q, Set).
+
+%% Note that the elements are enqueued in order.
+
+add_work([L | Ls], Q, Set) ->
+ case sets:is_element(L, Set) of
+ true ->
+ add_work(Ls, Q, Set);
+ false ->
+ add_work(Ls, queue__put(L, Q), sets:add_element(L, Set))
+ end;
+add_work([], Q, Set) ->
+ {Q, Set}.
+
+take_work({Queue0, Set0}) ->
+ case queue__get(Queue0) of
+ {ok, L, Queue1} ->
+ Set1 = sets:del_element(L, Set0),
+ {ok, L, {Queue1, Set1}};
+ empty ->
+ none
+ end.
+
+%% Escape operators may let their arguments escape. Unless we know
+%% otherwise, and the function is not pure, we assume this is the case.
+%% Error-raising functions (fault/match_fail) are not considered as
+%% escapes (but throw/exit are). Zero-argument functions need not be
+%% listed.
+
+-spec is_escape_op(atom(), arity()) -> boolean().
+
+is_escape_op(match_fail, 1) -> false;
+is_escape_op(F, A) when is_atom(F), is_integer(A) -> true.
+
+-spec is_escape_op(module(), atom(), arity()) -> boolean().
+
+is_escape_op(erlang, error, 1) -> false;
+is_escape_op(erlang, error, 2) -> false;
+is_escape_op(M, F, A) when is_atom(M), is_atom(F), is_integer(A) -> true.
+
+%% "Literal" operators will never return functional values even when
+%% found in their arguments. Unless we know otherwise, we assume this is
+%% not the case. (More functions can be added to this list, if needed
+%% for better precision. Note that the result of `term_to_binary' still
+%% contains an encoding of the closure.)
+
+-spec is_literal_op(atom(), arity()) -> boolean().
+
+is_literal_op(match_fail, 1) -> true;
+is_literal_op(F, A) when is_atom(F), is_integer(A) -> false.
+
+-spec is_literal_op(module(), atom(), arity()) -> boolean().
+
+is_literal_op(erlang, '+', 2) -> true;
+is_literal_op(erlang, '-', 2) -> true;
+is_literal_op(erlang, '*', 2) -> true;
+is_literal_op(erlang, '/', 2) -> true;
+is_literal_op(erlang, '=:=', 2) -> true;
+is_literal_op(erlang, '==', 2) -> true;
+is_literal_op(erlang, '=/=', 2) -> true;
+is_literal_op(erlang, '/=', 2) -> true;
+is_literal_op(erlang, '<', 2) -> true;
+is_literal_op(erlang, '=<', 2) -> true;
+is_literal_op(erlang, '>', 2) -> true;
+is_literal_op(erlang, '>=', 2) -> true;
+is_literal_op(erlang, 'and', 2) -> true;
+is_literal_op(erlang, 'or', 2) -> true;
+is_literal_op(erlang, 'not', 1) -> true;
+is_literal_op(erlang, length, 1) -> true;
+is_literal_op(erlang, size, 1) -> true;
+is_literal_op(erlang, fun_info, 1) -> true;
+is_literal_op(erlang, fun_info, 2) -> true;
+is_literal_op(erlang, fun_to_list, 1) -> true;
+is_literal_op(erlang, throw, 1) -> true;
+is_literal_op(erlang, exit, 1) -> true;
+is_literal_op(erlang, error, 1) -> true;
+is_literal_op(erlang, error, 2) -> true;
+is_literal_op(M, F, A) when is_atom(M), is_atom(F), is_integer(A) -> false.
+
+%% Pure functions neither affect the state, nor depend on it.
+
+is_pure_op(F, A) when is_atom(F), is_integer(A) -> false.
+
+is_pure_op(M, F, A) -> erl_bifs:is_pure(M, F, A).
+
+%% =====================================================================
diff --git a/lib/hipe/cerl/cerl_hipe_primops.hrl b/lib/hipe/cerl/cerl_hipe_primops.hrl
new file mode 100644
index 0000000000..36b1b62901
--- /dev/null
+++ b/lib/hipe/cerl/cerl_hipe_primops.hrl
@@ -0,0 +1,88 @@
+%% ========================-*-erlang-*-=================================
+%%
+%% %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%
+%%
+%% Predefined Core Erlang primitive operations used by HiPE
+%%
+%% Copyright (C) 2000 Richard Carlsson
+%%
+%% Author contact: [email protected]
+%% =====================================================================
+
+%% These definitions give the names of Core Erlang primops recognized by
+%% HiPE. Many of them (e.g., 'not'/'and'/'or', and the type tests), are
+%% not primops on the Icode level, but are inline-expanded by the
+%% translation from Core Erlang to Icode, or are renamed/rewritten to a
+%% corresponding ICode primop; they only exist to help the translation.
+
+%%-define(PRIMOP_IDENTITY, identity). % arity 1
+-define(PRIMOP_NOT, 'not'). % arity 1
+-define(PRIMOP_AND, 'and'). % arity 2
+-define(PRIMOP_OR, 'or'). % arity 2
+-define(PRIMOP_XOR, 'xor'). % arity 2
+-define(PRIMOP_ADD, '+'). % arity 2
+-define(PRIMOP_SUB, '-'). % arity 2
+-define(PRIMOP_NEG, neg). % arity 1
+-define(PRIMOP_MUL, '*'). % arity 2
+-define(PRIMOP_DIV, '/'). % arity 2
+-define(PRIMOP_INTDIV, 'div'). % arity 2
+-define(PRIMOP_REM, 'rem'). % arity 2
+-define(PRIMOP_BAND, 'band'). % arity 2
+-define(PRIMOP_BOR, 'bor'). % arity 2
+-define(PRIMOP_BXOR, 'bxor'). % arity 2
+-define(PRIMOP_BNOT, 'bnot'). % arity 1
+-define(PRIMOP_BSL, 'bsl'). % arity 2
+-define(PRIMOP_BSR, 'bsr'). % arity 2
+-define(PRIMOP_EQ, '=='). % arity 2
+-define(PRIMOP_NE, '/='). % arity 2
+-define(PRIMOP_EXACT_EQ, '=:='). % arity 2
+-define(PRIMOP_EXACT_NE, '=/='). % arity 2
+-define(PRIMOP_LT, '<'). % arity 2
+-define(PRIMOP_GT, '>'). % arity 2
+-define(PRIMOP_LE, '=<'). % arity 2
+-define(PRIMOP_GE, '>='). % arity 2
+-define(PRIMOP_IS_ATOM, 'is_atom'). % arity 1
+-define(PRIMOP_IS_BIGNUM, 'is_bignum'). % arity 1
+-define(PRIMOP_IS_BINARY, 'is_binary'). % arity 1
+-define(PRIMOP_IS_CONSTANT, 'is_constant'). % arity 1
+-define(PRIMOP_IS_FIXNUM, 'is_fixnum'). % arity 1
+-define(PRIMOP_IS_FLOAT, 'is_float'). % arity 1
+-define(PRIMOP_IS_FUNCTION, 'is_function'). % arity 1
+-define(PRIMOP_IS_INTEGER, 'is_integer'). % arity 1
+-define(PRIMOP_IS_LIST, 'is_list'). % arity 1
+-define(PRIMOP_IS_NUMBER, 'is_number'). % arity 1
+-define(PRIMOP_IS_PID, 'is_pid'). % arity 1
+-define(PRIMOP_IS_PORT, 'is_port'). % arity 1
+-define(PRIMOP_IS_REFERENCE, 'is_reference'). % arity 1
+-define(PRIMOP_IS_TUPLE, 'is_tuple'). % arity 1
+-define(PRIMOP_IS_RECORD, 'is_record'). % arity 3
+-define(PRIMOP_EXIT, exit). % arity 1
+-define(PRIMOP_THROW, throw). % arity 1
+-define(PRIMOP_ERROR, error). % arity 1,2
+-define(PRIMOP_RETHROW, raise). % arity 2
+-define(PRIMOP_RECEIVE_SELECT, receive_select). % arity 0
+-define(PRIMOP_RECEIVE_NEXT, receive_next). % arity 0
+-define(PRIMOP_ELEMENT, element). % arity 2
+-define(PRIMOP_DSETELEMENT, dsetelement). % arity 3
+-define(PRIMOP_MAKE_FUN, make_fun). % arity 6
+-define(PRIMOP_APPLY_FUN, apply_fun). % arity 2
+-define(PRIMOP_FUN_ELEMENT, closure_element). % arity 2
+-define(PRIMOP_SET_LABEL, set_label). % arity 1
+-define(PRIMOP_GOTO_LABEL, goto_label). % arity 1
+-define(PRIMOP_REDUCTION_TEST, reduction_test). % arity 0
+-define(PRIMOP_BS_CONTEXT_TO_BINARY, bs_context_to_binary). % arity 1
diff --git a/lib/hipe/cerl/cerl_hipeify.erl b/lib/hipe/cerl/cerl_hipeify.erl
new file mode 100644
index 0000000000..8f6c3561c9
--- /dev/null
+++ b/lib/hipe/cerl/cerl_hipeify.erl
@@ -0,0 +1,655 @@
+%%
+%% %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-2004 Richard Carlsson
+%% @doc HiPE-ification of Core Erlang code. Prepares Core Erlang code
+%% for translation to ICode.
+%% @see cerl_to_icode
+
+-module(cerl_hipeify).
+
+-define(NO_UNUSED, true).
+
+-export([transform/2]).
+-ifndef(NO_UNUSED).
+-export([core_transform/2]).
+-endif.
+
+-include("cerl_hipe_primops.hrl").
+
+-record(ctxt, {class = expr}).
+
+
+%% @spec core_transform(Module::cerl_records(), Options::[term()]) ->
+%% cerl_records()
+%%
+%% @doc Transforms a module represented by records. See
+%% <code>transform/2</code> for details.
+%%
+%% <p>Use the compiler option <code>{core_transform,
+%% cerl_hipeify}</code> to insert this function as a compilation
+%% pass.</p>
+%%
+%% @see transform/2
+
+-ifndef(NO_UNUSED).
+core_transform(M, Opts) ->
+ cerl:to_records(transform(cerl:from_records(M), Opts)).
+-endif. % NO_UNUSED
+%% @clear
+
+
+%% @spec transform(Module::cerl(), Options::[term()]) -> cerl()
+%%
+%% cerl() = cerl:cerl()
+%%
+%% @doc Rewrites a Core Erlang module to a form suitable for further
+%% translation to HiPE Icode. See module <code>cerl_to_icode</code> for
+%% details.
+%%
+%% @see cerl_to_icode
+%% @see cerl_cconv
+
+-spec transform(cerl:c_module(), [term()]) -> cerl:c_module().
+
+transform(E, Opts) ->
+ %% Start by closure converting the code
+ module(cerl_cconv:transform(E, Opts), Opts).
+
+module(E, Opts) ->
+ {Ds, Env, Ren} = add_defs(cerl:module_defs(E), env__new(),
+ ren__new()),
+ M = cerl:module_name(E),
+ S0 = s__new(cerl:atom_val(M)),
+ S = s__set_pmatch(proplists:get_value(pmatch, Opts, true), S0),
+ {Ds1, _} = defs(Ds, true, Env, Ren, S),
+ cerl:update_c_module(E, M, cerl:module_exports(E),
+ cerl:module_attrs(E), Ds1).
+
+%% Note that the environment is defined on the renamed variables.
+
+expr(E0, Env, Ren, Ctxt, S0) ->
+ %% Do peephole optimizations as we traverse the code.
+ E = cerl_lib:reduce_expr(E0),
+ case cerl:type(E) of
+ literal ->
+ {E, S0};
+ var ->
+ variable(E, Env, Ren, Ctxt, S0);
+ values ->
+ {Es, S1} = expr_list(cerl:values_es(E), Env, Ren, Ctxt, S0),
+ {cerl:update_c_values(E, Es), S1};
+ cons ->
+ {E1, S1} = expr(cerl:cons_hd(E), Env, Ren, Ctxt, S0),
+ {E2, S2} = expr(cerl:cons_tl(E), Env, Ren, Ctxt, S1),
+ {cerl:update_c_cons(E, E1, E2), S2};
+ tuple ->
+ {Es, S1} = expr_list(cerl:tuple_es(E), Env, Ren, Ctxt, S0),
+ {cerl:update_c_tuple(E, Es), S1};
+ 'let' ->
+ let_expr(E, Env, Ren, Ctxt, S0);
+ seq ->
+ {A, S1} = expr(cerl:seq_arg(E), Env, Ren, Ctxt, S0),
+ {B, S2} = expr(cerl:seq_body(E), Env, Ren, Ctxt, S1),
+ {cerl:update_c_seq(E, A, B), S2};
+ apply ->
+ {Op, S1} = expr(cerl:apply_op(E), Env, Ren, Ctxt, S0),
+ {As, S2} = expr_list(cerl:apply_args(E), Env, Ren, Ctxt, S1),
+ {cerl:update_c_apply(E, Op, As), S2};
+ call ->
+ {M, S1} = expr(cerl:call_module(E), Env, Ren, Ctxt, S0),
+ {N, S2} = expr(cerl:call_name(E), Env, Ren, Ctxt, S1),
+ {As, S3} = expr_list(cerl:call_args(E), Env, Ren, Ctxt, S2),
+ {rewrite_call(E, M, N, As, S3), S3};
+ primop ->
+ {As, S1} = expr_list(cerl:primop_args(E), Env, Ren, Ctxt, S0),
+ N = cerl:primop_name(E),
+ {rewrite_primop(E, N, As, S1), S1};
+ 'case' ->
+ case_expr(E, Env, Ren, Ctxt, S0);
+ 'fun' ->
+ Vs = cerl:fun_vars(E),
+ {Vs1, Env1, Ren1} = add_vars(Vs, Env, Ren),
+ {B, S1} = expr(cerl:fun_body(E), Env1, Ren1, Ctxt, S0),
+ {cerl:update_c_fun(E, Vs1, B), S1};
+ 'receive' ->
+ receive_expr(E, Env, Ren, Ctxt, S0);
+ 'try' ->
+ {A, S1} = expr(cerl:try_arg(E), Env, Ren, Ctxt, S0),
+ Vs = cerl:try_vars(E),
+ {Vs1, Env1, Ren1} = add_vars(Vs, Env, Ren),
+ {B, S2} = expr(cerl:try_body(E), Env1, Ren1, Ctxt, S1),
+ Evs = cerl:try_evars(E),
+ {Evs1, Env2, Ren2} = add_vars(Evs, Env, Ren),
+ {H, S3} = expr(cerl:try_handler(E), Env2, Ren2, Ctxt, S2),
+ {cerl:update_c_try(E, A, Vs1, B, Evs1, H), S3};
+ 'catch' ->
+ catch_expr(E, Env, Ren, Ctxt, S0);
+ letrec ->
+ {Ds, Env1, Ren1} = add_defs(cerl:letrec_defs(E), Env, Ren),
+ {Ds1, S1} = defs(Ds, false, Env1, Ren1, S0),
+ {B, S2} = expr(cerl:letrec_body(E), Env1, Ren1, Ctxt, S1),
+ {cerl:update_c_letrec(E, Ds1, B), S2};
+ binary ->
+ {Segs, S1} = expr_list(cerl:binary_segments(E), Env, Ren,
+ Ctxt, S0),
+ {cerl:update_c_binary(E, Segs), S1};
+ bitstr ->
+ {E1,S1} = expr(cerl:bitstr_val(E), Env, Ren, Ctxt, S0),
+ {E2,S2} = expr(cerl:bitstr_size(E), Env, Ren, Ctxt, S1),
+ E3 = cerl:bitstr_unit(E),
+ E4 = cerl:bitstr_type(E),
+ E5 = cerl:bitstr_flags(E),
+ {cerl:update_c_bitstr(E, E1, E2, E3, E4, E5), S2}
+ end.
+
+guard_expr(E, Env, Ren, Ctxt, S) ->
+ expr(E, Env, Ren, Ctxt#ctxt{class = guard}, S).
+
+expr_list(Es, Env, Ren, Ctxt, S0) ->
+ list(Es, Env, Ren, Ctxt, S0, fun expr/5).
+
+list([E | Es], Env, Ren, Ctxt, S0, F) ->
+ {E1, S1} = F(E, Env, Ren, Ctxt, S0),
+ {Es1, S2} = list(Es, Env, Ren, Ctxt, S1, F),
+ {[E1 | Es1], S2};
+list([], _, _, _, S, _) ->
+ {[], S}.
+
+pattern(E, Env, Ren) ->
+ case cerl:type(E) of
+ literal ->
+ E;
+ var ->
+ cerl:update_c_var(E, ren__map(cerl:var_name(E), Ren));
+ values ->
+ Es = pattern_list(cerl:values_es(E), Env, Ren),
+ cerl:update_c_values(E, Es);
+ cons ->
+ E1 = pattern(cerl:cons_hd(E), Env, Ren),
+ E2 = pattern(cerl:cons_tl(E), Env, Ren),
+ cerl:update_c_cons(E, E1, E2);
+ tuple ->
+ Es = pattern_list(cerl:tuple_es(E), Env, Ren),
+ cerl:update_c_tuple(E, Es);
+ alias ->
+ V = pattern(cerl:alias_var(E), Env, Ren),
+ P = pattern(cerl:alias_pat(E), Env, Ren),
+ cerl:update_c_alias(E, V, P);
+ binary ->
+ Segs = pattern_list(cerl:binary_segments(E), Env, Ren),
+ cerl:update_c_binary(E, Segs);
+ bitstr ->
+ E1 = pattern(cerl:bitstr_val(E), Env, Ren),
+ E2 = pattern(cerl:bitstr_size(E), Env, Ren),
+ E3 = cerl:bitstr_unit(E),
+ E4 = cerl:bitstr_type(E),
+ E5 = cerl:bitstr_flags(E),
+ cerl:update_c_bitstr(E, E1, E2, E3, E4, E5)
+ end.
+
+pattern_list(ExprList, Env, Ren) ->
+ [pattern(E, Env, Ren) || E <- ExprList].
+
+%% Visit the function body of each definition. We insert an explicit
+%% reduction test at the start of each function.
+
+defs(Ds, Top, Env, Ren, S) ->
+ defs(Ds, [], Top, Env, Ren, S).
+
+defs([{V, F} | Ds], Ds1, Top, Env, Ren, S0) ->
+ S1 = case Top of
+ true -> s__enter_function(cerl:var_name(V), S0);
+ false -> S0
+ end,
+ {B, S2} = expr(cerl:fun_body(F), Env, Ren, #ctxt{}, S1),
+ B1 = cerl:c_seq(cerl:c_primop(cerl:c_atom(?PRIMOP_REDUCTION_TEST), []),
+ B),
+ F1 = cerl:update_c_fun(F, cerl:fun_vars(F), B1),
+ defs(Ds, [{V, F1} | Ds1], Top, Env, Ren, S2);
+defs([], Ds, _Top, _Env, _Ren, S) ->
+ {lists:reverse(Ds), S}.
+
+case_expr(E, Env, Ren, Ctxt, S0) ->
+ {A, S1} = expr(cerl:case_arg(E), Env, Ren, Ctxt, S0),
+ {Cs, S2} = clause_list(cerl:case_clauses(E), Env, Ren, Ctxt, S1),
+ case s__get_revisit(S2) of
+ false ->
+ {E1, Vs, S3} = pmatch(Cs, Env, Ren, Ctxt, S2),
+ {cerl:c_let(Vs, A, E1), S3};
+ true ->
+ {cerl:c_case(A, Cs), S2}
+ end.
+
+%% Note: There is an ordering problem with switch-clauses and pattern
+%% matching compilation. We must process any receive-clauses first,
+%% making the message queue operations explicit, before we can do
+%% pattern matching compilation. However, the latter can introduce new
+%% expressions - in particular new guards - which also need processing.
+%% Hence, we must process the clauses, then do pattern matching
+%% compilation, and then re-visit the resulting expression with pattern
+%% matching compilation disabled.
+
+pmatch(Cs, Env, _Ren, Ctxt, S0) ->
+ {E, Vs} = case s__get_pmatch(S0) of
+ true ->
+ cerl_pmatch:clauses(Cs, Env);
+ no_duplicates ->
+ put('cerl_pmatch_duplicate_code', never),
+ cerl_pmatch:clauses(Cs, Env);
+ duplicate_all ->
+ put('cerl_pmatch_duplicate_code', always),
+ cerl_pmatch:clauses(Cs, Env);
+ false ->
+ Vs0 = new_vars(cerl:clause_arity(hd(Cs)), Env),
+ {cerl:c_case(cerl:c_values(Vs0), Cs), Vs0}
+ end,
+ %% Revisit the resulting expression. Pass an empty renaming, since
+ %% all variables in E have already been properly renamed and must
+ %% not be renamed again by accident.
+ {E1, S1} = expr(E, Env, ren__new(), Ctxt, s__set_revisit(true, S0)),
+ {E1, Vs, s__set_revisit(false, S1)}.
+
+clause_list(Cs, Env, Ren, Ctxt, S) ->
+ list(Cs, Env, Ren, Ctxt, S, fun clause/5).
+
+clause(E, Env, Ren, Ctxt, S0) ->
+ Vs = cerl:clause_vars(E),
+ {_, Env1, Ren1} = add_vars(Vs, Env, Ren),
+ %% Visit patterns to rename variables.
+ Ps = pattern_list(cerl:clause_pats(E), Env1, Ren1),
+ {G, S1} = guard_expr(cerl:clause_guard(E), Env1, Ren1, Ctxt, S0),
+ {B, S2} = expr(cerl:clause_body(E), Env1, Ren1, Ctxt, S1),
+ {cerl:update_c_clause(E, Ps, G, B), S2}.
+
+%% We use the no-shadowing strategy, renaming variables on the fly and
+%% only when necessary to uphold the invariant.
+
+add_vars(Vs, Env, Ren) ->
+ add_vars(Vs, [], Env, Ren).
+
+add_vars([V | Vs], Vs1, Env, Ren) ->
+ Name = cerl:var_name(V),
+ {Name1, Ren1} = rename(Name, Env, Ren),
+ add_vars(Vs, [cerl:update_c_var(V, Name1) | Vs1],
+ env__bind(Name1, variable, Env), Ren1);
+add_vars([], Vs, Env, Ren) ->
+ {lists:reverse(Vs), Env, Ren}.
+
+rename(Name, Env, Ren) ->
+ case env__is_defined(Name, Env) of
+ false ->
+ {Name, Ren};
+ true ->
+ New = env__new_name(Env),
+ {New, ren__add(Name, New, Ren)}
+ end.
+
+%% Setting up the environment for a list of letrec-bound definitions.
+
+add_defs(Ds, Env, Ren) ->
+ add_defs(Ds, [], Env, Ren).
+
+add_defs([{V, F} | Ds], Ds1, Env, Ren) ->
+ Name = cerl:var_name(V),
+ {Name1, Ren1} =
+ case env__is_defined(Name, Env) of
+ false ->
+ {Name, Ren};
+ true ->
+ {N, A} = Name,
+ S = atom_to_list(N) ++ "_",
+ F1 = fun (Num) ->
+ {list_to_atom(S ++ integer_to_list(Num)), A}
+ end,
+ New = env__new_function_name(F1, Env),
+ {New, ren__add(Name, New, Ren)}
+ end,
+ add_defs(Ds, [{cerl:update_c_var(V, Name1), F} | Ds1],
+ env__bind(Name1, function, Env), Ren1);
+add_defs([], Ds, Env, Ren) ->
+ {lists:reverse(Ds), Env, Ren}.
+
+%% We change remote calls to important built-in functions into primop
+%% calls. In some cases (e.g., for the boolean operators), this is
+%% mainly to allow the cerl_to_icode module to handle them more
+%% straightforwardly. In most cases however, it is simply because they
+%% are supposed to be represented as primop calls on the Icode level.
+
+rewrite_call(E, M, F, As, S) ->
+ case cerl:is_c_atom(M) andalso cerl:is_c_atom(F) of
+ true ->
+ case call_to_primop(cerl:atom_val(M),
+ cerl:atom_val(F),
+ length(As))
+ of
+ {yes, ?PRIMOP_IS_RECORD} ->
+ %% Needs additional testing
+ [_, Tag, Arity] = As,
+ case (cerl:is_c_atom(Tag) andalso
+ cerl:is_c_int(Arity)) of
+ true ->
+ %% The primop might need further handling
+ N1 = cerl:c_atom(?PRIMOP_IS_RECORD),
+ E1 = cerl:update_c_primop(E, N1, As),
+ rewrite_primop(E1, N1, As, S);
+ false ->
+ cerl:update_c_call(E, M, F, As)
+ end;
+ {yes, N} ->
+ %% The primop might need further handling
+ N1 = cerl:c_atom(N),
+ E1 = cerl:update_c_primop(E, N1, As),
+ rewrite_primop(E1, N1, As, S);
+ no ->
+ cerl:update_c_call(E, M, F, As)
+ end;
+ false ->
+ cerl:update_c_call(E, M, F, As)
+ end.
+
+call_to_primop(erlang, 'not', 1) -> {yes, ?PRIMOP_NOT};
+call_to_primop(erlang, 'and', 2) -> {yes, ?PRIMOP_AND};
+call_to_primop(erlang, 'or', 2) -> {yes, ?PRIMOP_OR};
+call_to_primop(erlang, 'xor', 2) -> {yes, ?PRIMOP_XOR};
+call_to_primop(erlang, '+', 2) -> {yes, ?PRIMOP_ADD};
+%%call_to_primop(erlang, '+', 1) -> {yes, ?PRIMOP_IDENTITY};
+call_to_primop(erlang, '-', 2) -> {yes, ?PRIMOP_SUB};
+call_to_primop(erlang, '-', 1) -> {yes, ?PRIMOP_NEG};
+call_to_primop(erlang, '*', 2) -> {yes, ?PRIMOP_MUL};
+call_to_primop(erlang, '/', 2) -> {yes, ?PRIMOP_DIV};
+call_to_primop(erlang, 'div', 2) -> {yes, ?PRIMOP_INTDIV};
+call_to_primop(erlang, 'rem', 2) -> {yes, ?PRIMOP_REM};
+call_to_primop(erlang, 'band', 2) -> {yes, ?PRIMOP_BAND};
+call_to_primop(erlang, 'bor', 2) -> {yes, ?PRIMOP_BOR};
+call_to_primop(erlang, 'bxor', 2) -> {yes, ?PRIMOP_BXOR};
+call_to_primop(erlang, 'bnot', 1) -> {yes, ?PRIMOP_BNOT};
+call_to_primop(erlang, 'bsl', 2) -> {yes, ?PRIMOP_BSL};
+call_to_primop(erlang, 'bsr', 2) -> {yes, ?PRIMOP_BSR};
+call_to_primop(erlang, '==', 2) -> {yes, ?PRIMOP_EQ};
+call_to_primop(erlang, '/=', 2) -> {yes, ?PRIMOP_NE};
+call_to_primop(erlang, '=:=', 2) -> {yes, ?PRIMOP_EXACT_EQ};
+call_to_primop(erlang, '=/=', 2) -> {yes, ?PRIMOP_EXACT_NE};
+call_to_primop(erlang, '<', 2) -> {yes, ?PRIMOP_LT};
+call_to_primop(erlang, '>', 2) -> {yes, ?PRIMOP_GT};
+call_to_primop(erlang, '=<', 2) -> {yes, ?PRIMOP_LE};
+call_to_primop(erlang, '>=', 2) -> {yes, ?PRIMOP_GE};
+call_to_primop(erlang, is_atom, 1) -> {yes, ?PRIMOP_IS_ATOM};
+call_to_primop(erlang, is_binary, 1) -> {yes, ?PRIMOP_IS_BINARY};
+call_to_primop(erlang, is_constant, 1) -> {yes, ?PRIMOP_IS_CONSTANT};
+call_to_primop(erlang, is_float, 1) -> {yes, ?PRIMOP_IS_FLOAT};
+call_to_primop(erlang, is_function, 1) -> {yes, ?PRIMOP_IS_FUNCTION};
+call_to_primop(erlang, is_integer, 1) -> {yes, ?PRIMOP_IS_INTEGER};
+call_to_primop(erlang, is_list, 1) -> {yes, ?PRIMOP_IS_LIST};
+call_to_primop(erlang, is_number, 1) -> {yes, ?PRIMOP_IS_NUMBER};
+call_to_primop(erlang, is_pid, 1) -> {yes, ?PRIMOP_IS_PID};
+call_to_primop(erlang, is_port, 1) -> {yes, ?PRIMOP_IS_PORT};
+call_to_primop(erlang, is_reference, 1) -> {yes, ?PRIMOP_IS_REFERENCE};
+call_to_primop(erlang, is_tuple, 1) -> {yes, ?PRIMOP_IS_TUPLE};
+call_to_primop(erlang, internal_is_record, 3) -> {yes, ?PRIMOP_IS_RECORD};
+call_to_primop(erlang, is_record, 3) -> {yes, ?PRIMOP_IS_RECORD};
+call_to_primop(erlang, element, 2) -> {yes, ?PRIMOP_ELEMENT};
+call_to_primop(erlang, exit, 1) -> {yes, ?PRIMOP_EXIT};
+call_to_primop(erlang, throw, 1) -> {yes, ?PRIMOP_THROW};
+call_to_primop(erlang, error, 1) -> {yes, ?PRIMOP_ERROR};
+call_to_primop(erlang, error, 2) -> {yes, ?PRIMOP_ERROR};
+call_to_primop(M, F, A) when is_atom(M), is_atom(F), is_integer(A) -> no.
+
+%% Also, some primops (introduced by Erlang to Core Erlang translation
+%% and possibly other stages) must be recognized and rewritten.
+
+rewrite_primop(E, N, As, S) ->
+ case {cerl:atom_val(N), As} of
+ {match_fail, [R]} ->
+ M = s__get_module_name(S),
+ {F, A} = s__get_function_name(S),
+ Stack = cerl:abstract([{M, F, A}]),
+ case cerl:type(R) of
+ tuple ->
+ %% Function clause failures have a special encoding
+ %% as '{function_clause, Arg1, ..., ArgN}'.
+ case cerl:tuple_es(R) of
+ [X | Xs] ->
+ case cerl:is_c_atom(X) of
+ true ->
+ case cerl:atom_val(X) of
+ function_clause ->
+ FStack = cerl:make_list(
+ [cerl:c_tuple(
+ [cerl:c_atom(M),
+ cerl:c_atom(F),
+ cerl:make_list(Xs)])]),
+ match_fail(E, X, FStack);
+ _ ->
+ match_fail(E, R, Stack)
+ end;
+ false ->
+ match_fail(E, R, Stack)
+ end;
+ _ ->
+ match_fail(E, R, Stack)
+ end;
+ _ ->
+ match_fail(E, R, Stack)
+ end;
+ _ ->
+ cerl:update_c_primop(E, N, As)
+ end.
+
+match_fail(E, R, Stack) ->
+ cerl:update_c_primop(E, cerl:c_atom(?PRIMOP_ERROR), [R, Stack]).
+
+%% Simple let-definitions (of degree 1) in guard context are always
+%% inline expanded. This is allowable, since they cannot have side
+%% effects, and it makes it easy to generate good code for boolean
+%% expressions. It could cause repeated evaluations, but typically,
+%% local definitions within guards are used exactly once.
+
+let_expr(E, Env, Ren, Ctxt, S) ->
+ if Ctxt#ctxt.class =:= guard ->
+ case cerl:let_vars(E) of
+ [V] ->
+ {Name, Ren1} = rename(cerl:var_name(V), Env, Ren),
+ Env1 = env__bind(Name, {expr, cerl:let_arg(E)}, Env),
+ expr(cerl:let_body(E), Env1, Ren1, Ctxt, S);
+ _ ->
+ let_expr_1(E, Env, Ren, Ctxt, S)
+ end;
+ true ->
+ let_expr_1(E, Env, Ren, Ctxt, S)
+ end.
+
+let_expr_1(E, Env, Ren, Ctxt, S0) ->
+ {A, S1} = expr(cerl:let_arg(E), Env, Ren, Ctxt, S0),
+ Vs = cerl:let_vars(E),
+ {Vs1, Env1, Ren1} = add_vars(Vs, Env, Ren),
+ {B, S2} = expr(cerl:let_body(E), Env1, Ren1, Ctxt, S1),
+ {cerl:update_c_let(E, Vs1, A, B), S2}.
+
+variable(E, Env, Ren, Ctxt, S) ->
+ V = ren__map(cerl:var_name(E), Ren),
+ if Ctxt#ctxt.class =:= guard ->
+ case env__lookup(V, Env) of
+ {ok, {expr, E1}} ->
+ expr(E1, Env, Ren, Ctxt, S); % inline
+ _ ->
+ %% Since we don't track all bindings when we revisit
+ %% guards, some names will not be in the environment.
+ variable_1(E, V, S)
+ end;
+ true ->
+ variable_1(E, V, S)
+ end.
+
+variable_1(E, V, S) ->
+ {cerl:update_c_var(E, V), S}.
+
+%% A catch-expression 'catch Expr' is rewritten as:
+%%
+%% try Expr
+%% of (V) -> V
+%% catch (T, V, E) ->
+%% letrec 'wrap'/1 = fun (V) -> {'EXIT', V}
+%% in case T of
+%% 'throw' when 'true' -> V
+%% 'exit' when 'true' -> 'wrap'/1(V)
+%% V when 'true' ->
+%% 'wrap'/1({V, erlang:get_stacktrace()})
+%% end
+
+catch_expr(E, Env, Ren, Ctxt, S) ->
+ T = cerl:c_var('T'),
+ V = cerl:c_var('V'),
+ X = cerl:c_var('X'),
+ W = cerl:c_var({wrap,1}),
+ G = cerl:c_call(cerl:c_atom('erlang'),cerl:c_atom('get_stacktrace'),[]),
+ Cs = [cerl:c_clause([cerl:c_atom('throw')], V),
+ cerl:c_clause([cerl:c_atom('exit')], cerl:c_apply(W, [V])),
+ cerl:c_clause([T], cerl:c_apply(W, [cerl:c_tuple([V,G])]))
+ ],
+ C = cerl:c_case(T, Cs),
+ F = cerl:c_fun([V], cerl:c_tuple([cerl:c_atom('EXIT'), V])),
+ H = cerl:c_letrec([{W,F}], C),
+ As = cerl:get_ann(E),
+ {B, S1} = expr(cerl:catch_body(E),Env, Ren, Ctxt, S),
+ {cerl:ann_c_try(As, B, [V], V, [T,V,X], H), S1}.
+
+%% Receive-expressions are rewritten as follows:
+%%
+%% receive
+%% P1 when G1 -> B1
+%% ...
+%% Pn when Gn -> Bn
+%% after T -> A end
+%% becomes:
+%% receive
+%% M when 'true' ->
+%% case M of
+%% P1 when G1 -> do primop RECEIVE_SELECT B1
+%% ...
+%% Pn when Gn -> do primop RECEIVE_SELECT Bn
+%% Pn+1 when 'true' -> primop RECEIVE_NEXT()
+%% end
+%% after T -> A end
+
+receive_expr(E, Env, Ren, Ctxt, S0) ->
+ case s__get_revisit(S0) of
+ false ->
+ Cs = receive_clauses(cerl:receive_clauses(E)),
+ {Cs1, S1} = clause_list(Cs, Env, Ren, Ctxt, S0),
+ {B, Vs, S2} = pmatch(Cs1, Env, Ren, Ctxt, S1),
+ {T, S3} = expr(cerl:receive_timeout(E), Env, Ren, Ctxt, S2),
+ {A, S4} = expr(cerl:receive_action(E), Env, Ren, Ctxt, S3),
+ {cerl:update_c_receive(E, [cerl:c_clause(Vs, B)], T, A), S4};
+ true ->
+ %% we should never enter a receive-expression twice
+ {E, S0}
+ end.
+
+receive_clauses([C | Cs]) ->
+ Call = cerl:c_primop(cerl:c_atom(?PRIMOP_RECEIVE_SELECT), []),
+ B = cerl:c_seq(Call, cerl:clause_body(C)),
+ C1 = cerl:update_c_clause(C, cerl:clause_pats(C),
+ cerl:clause_guard(C), B),
+ [C1 | receive_clauses(Cs)];
+receive_clauses([]) ->
+ Call = cerl:c_primop(cerl:c_atom(?PRIMOP_RECEIVE_NEXT), []),
+ V = cerl:c_var('X'), % any name is ok
+ [cerl:c_clause([V], Call)].
+
+new_vars(N, Env) ->
+ [cerl:c_var(V) || V <- env__new_names(N, Env)].
+
+%% ---------------------------------------------------------------------
+%% Environment
+
+env__new() ->
+ rec_env:empty().
+
+env__bind(Key, Value, Env) ->
+ rec_env:bind(Key, Value, Env).
+
+%% env__get(Key, Env) ->
+%% rec_env:get(Key, Env).
+
+env__lookup(Key, Env) ->
+ rec_env:lookup(Key, Env).
+
+env__is_defined(Key, Env) ->
+ rec_env:is_defined(Key, Env).
+
+env__new_name(Env) ->
+ rec_env:new_key(Env).
+
+env__new_names(N, Env) ->
+ rec_env:new_keys(N, Env).
+
+env__new_function_name(F, Env) ->
+ rec_env:new_key(F, Env).
+
+%% ---------------------------------------------------------------------
+%% Renaming
+
+ren__new() ->
+ dict:new().
+
+ren__add(Key, Value, Ren) ->
+ dict:store(Key, Value, Ren).
+
+ren__map(Key, Ren) ->
+ case dict:find(Key, Ren) of
+ {ok, Value} ->
+ Value;
+ error ->
+ Key
+ end.
+
+%% ---------------------------------------------------------------------
+%% State
+
+%% pmatch = 'true' | 'false' | 'no_duplicates' | 'duplicate_all'
+
+-record(state, {module::atom(),
+ function::{atom(), 0..256},
+ pmatch=true,
+ revisit = false}).
+
+s__new(Module) ->
+ #state{module = Module}.
+
+s__get_module_name(S) ->
+ S#state.module.
+
+s__enter_function(F, S) ->
+ S#state{function = F}.
+
+s__get_function_name(S) ->
+ S#state.function.
+
+s__set_pmatch(V, S) ->
+ S#state{pmatch = V}.
+
+s__get_pmatch(S) ->
+ S#state.pmatch.
+
+s__set_revisit(V, S) ->
+ S#state{revisit = V}.
+
+s__get_revisit(S) ->
+ S#state.revisit.
diff --git a/lib/hipe/cerl/cerl_hybrid_transform.erl b/lib/hipe/cerl/cerl_hybrid_transform.erl
new file mode 100644
index 0000000000..b248b0ccd0
--- /dev/null
+++ b/lib/hipe/cerl/cerl_hybrid_transform.erl
@@ -0,0 +1,153 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2004-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+%%
+
+-module(cerl_hybrid_transform).
+
+%% Use compile option `{core_transform, cerl_hybrid_transform}' to
+%% insert this as a compilation pass.
+
+-export([transform/2, core_transform/2]).
+
+-spec core_transform(cerl:cerl(), [term()]) -> cerl:cerl().
+
+core_transform(Code, Opts) ->
+ cerl:to_records(transform(cerl:from_records(Code), Opts)).
+
+-spec transform(cerl:cerl(), [term()]) -> cerl:cerl().
+
+transform(Code, _Opts) ->
+ Code0 = cerl_trees:map(fun unfold_literal/1, Code),
+ {Code1, _} = cerl_trees:label(Code0),
+ io:fwrite("Running hybrid heap analysis..."),
+ {T1,_} = statistics(runtime),
+ {Code2, _, Vars} = cerl_messagean:annotate(Code1),
+ {T2,_} = statistics(runtime),
+ io:fwrite("(~w ms), transform...", [T2 - T1]),
+ Code3 = rewrite(Code2, Vars),
+ io:fwrite("done.\n"),
+ cerl_trees:map(fun fold_literal/1, Code3).
+
+unfold_literal(T) ->
+ cerl:unfold_literal(T).
+
+fold_literal(T) ->
+ cerl:fold_literal(T).
+
+%% If escape-annotated:
+%% {...} => hybrid:tuple([...])
+%% [H | T] => hybrid:cons(H, T)
+%%
+%% Wrapper for args to hybrid:cons/hybrid:tuple that may need copying:
+%% hybrid:copy(A)
+
+rewrite(Node, Vars) ->
+ case cerl:type(Node) of
+ tuple ->
+ Es = rewrite_list(cerl:tuple_es(Node), Vars),
+ case is_escaping(Node) of
+ false ->
+ cerl:update_c_tuple(Node, Es);
+ true ->
+ Es1 = wrap(Es, Node, Vars),
+ cerl:update_c_call(Node,
+ cerl:abstract(hybrid),
+ cerl:abstract(tuple),
+ [cerl:make_list(Es1)])
+%%% cerl:update_c_call(Node, cerl:abstract(hybrid),
+%%% cerl:abstract(tuple), Es1)
+ end;
+ cons ->
+ H = rewrite(cerl:cons_hd(Node), Vars),
+ T = rewrite(cerl:cons_tl(Node), Vars),
+ case is_escaping(Node) of
+ false ->
+ cerl:update_c_cons(Node, H, T);
+ true ->
+ Es = wrap([H, T], Node, Vars),
+ cerl:update_c_call(Node,
+ cerl:abstract(hybrid),
+ cerl:abstract(cons),
+ Es)
+ end;
+%%% call ->
+%%% M = rewrite(cerl:call_module(Node)),
+%%% F = rewrite(cerl:call_name(Node)),
+%%% As = rewrite_list(cerl:call_args(Node)),
+%%% case cerl:is_c_atom(M) andalso cerl:is_c_atom(F) of
+%%% true ->
+%%% case {cerl:atom_val(M), cerl:atom_val(F), length(As)} of
+%%% {erlang, '!', 2} ->
+%%% cerl:update_c_call(Node,
+%%% cerl:abstract(hipe_bifs),
+%%% cerl:abstract(send),
+%%% [cerl:make_list(As)]);
+%%% _ ->
+%%% cerl:update_c_call(Node, M, F, As)
+%%% end;
+%%% false ->
+%%% cerl:update_c_call(Node, M, F, As)
+%%% end;
+ clause ->
+ B = rewrite(cerl:clause_body(Node), Vars),
+ cerl:update_c_clause(Node, cerl:clause_pats(Node),
+ cerl:clause_guard(Node), B);
+ primop ->
+ case cerl:atom_val(cerl:primop_name(Node)) of
+ match_fail ->
+ Node;
+ _ ->
+ As = rewrite_list(cerl:primop_args(Node), Vars),
+ cerl:update_c_primop(Node, cerl:primop_name(Node), As)
+ end;
+ _T ->
+ case cerl:subtrees(Node) of
+ [] ->
+ Node;
+ Gs ->
+ cerl:update_tree(Node, [rewrite_list(Ns, Vars)
+ || Ns <- Gs])
+ end
+ end.
+
+rewrite_list([N | Ns], Vars) ->
+ [rewrite(N, Vars) | rewrite_list(Ns, Vars)];
+rewrite_list([], _) ->
+ [].
+
+is_escaping(T) ->
+ lists:member(escapes, cerl:get_ann(T)).
+
+wrap(Es, Node, Vars) ->
+ L = cerl_trees:get_label(Node),
+ Xs = dict:fetch(L, Vars),
+ wrap(Es, Xs).
+
+wrap([E | Es], [{S, _} | Xs]) ->
+ case ordsets:is_element(unsafe, S) of
+%% case cerl:type(E) =/= literal of
+ true ->
+ [cerl:c_call(cerl:abstract(hybrid),
+ cerl:abstract(copy),
+ [E])
+ | wrap(Es, Xs)];
+ false ->
+ [E | wrap(Es, Xs)]
+ end;
+wrap([], _) ->
+ [].
diff --git a/lib/hipe/cerl/cerl_lib.erl b/lib/hipe/cerl/cerl_lib.erl
new file mode 100644
index 0000000000..83bb20e047
--- /dev/null
+++ b/lib/hipe/cerl/cerl_lib.erl
@@ -0,0 +1,462 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2004-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+%%
+
+%% @doc Utility functions for Core Erlang abstract syntax trees.
+%%
+%% <p>Syntax trees are defined in the module <a
+%% href=""><code>cerl</code></a>.</p>
+%%
+%% @type cerl() = cerl:cerl()
+
+-module(cerl_lib).
+
+-define(NO_UNUSED, true).
+
+-export([is_safe_expr/2, reduce_expr/1, is_simple_clause/1,
+ is_bool_switch/1, bool_switch_cases/1]).
+-ifndef(NO_UNUSED).
+-export([is_safe_expr/1, is_pure_expr/1, is_pure_expr/2,
+ make_bool_switch/3]).
+-endif.
+
+
+%% Test if a clause has a single pattern and an always-true guard.
+
+-spec is_simple_clause(cerl:c_clause()) -> boolean().
+
+is_simple_clause(C) ->
+ case cerl:clause_pats(C) of
+ [_P] ->
+ G = cerl:clause_guard(C),
+ case cerl_clauses:eval_guard(G) of
+ {value, true} -> true;
+ _ -> false
+ end;
+ _ -> false
+ end.
+
+%% Creating an if-then-else construct that can be recognized as such.
+%% `Test' *must* be guaranteed to return a boolean.
+
+-ifndef(NO_UNUSED).
+make_bool_switch(Test, True, False) ->
+ Cs = [cerl:c_clause([cerl:c_atom(true)], True),
+ cerl:c_clause([cerl:c_atom(false)], False)],
+ cerl:c_case(Test, Cs).
+-endif.
+
+%% A boolean switch cannot have a catch-all; only true/false branches.
+
+-spec is_bool_switch([cerl:c_clause()]) -> boolean().
+
+is_bool_switch([C1, C2]) ->
+ case is_simple_clause(C1) andalso is_simple_clause(C2) of
+ true ->
+ [P1] = cerl:clause_pats(C1),
+ [P2] = cerl:clause_pats(C2),
+ case cerl:is_c_atom(P1) andalso cerl:is_c_atom(P2) of
+ true ->
+ A1 = cerl:concrete(P1),
+ A2 = cerl:concrete(P2),
+ is_boolean(A1) andalso is_boolean(A2)
+ andalso A1 =/= A2;
+ false ->
+ false
+ end;
+ false ->
+ false
+ end;
+is_bool_switch(_) ->
+ false.
+
+%% Returns the true-body and the false-body for boolean switch clauses.
+
+-spec bool_switch_cases([cerl:c_clause()]) -> {cerl:cerl(), cerl:cerl()}.
+
+bool_switch_cases([C1, C2]) ->
+ B1 = cerl:clause_body(C1),
+ B2 = cerl:clause_body(C2),
+ [P1] = cerl:clause_pats(C1),
+ case cerl:concrete(P1) of
+ true ->
+ {B1, B2};
+ false ->
+ {B2, B1}
+ end.
+
+%%
+%% The type of the check functions like the default check below - XXX: refine
+%%
+-type check_fun() :: fun((_, _) -> boolean()).
+
+%% The default function property check always returns `false':
+
+default_check(_Property, _Function) -> false.
+
+
+%% @spec is_safe_expr(Expr::cerl()) -> boolean()
+%%
+%% @doc Returns `true' if `Expr' represents a "safe" Core Erlang
+%% expression, otherwise `false'. An expression is safe if it always
+%% completes normally and does not modify the state (although the return
+%% value may depend on the state).
+%%
+%% Expressions of type `apply', `case', `receive' and `binary' are
+%% always considered unsafe by this function.
+
+%% TODO: update cerl_inline to use these functions instead.
+
+-ifndef(NO_UNUSED).
+is_safe_expr(E) ->
+ Check = fun default_check/2,
+ is_safe_expr(E, Check).
+-endif.
+%% @clear
+
+-spec is_safe_expr(cerl:cerl(), check_fun()) -> boolean().
+
+is_safe_expr(E, Check) ->
+ case cerl:type(E) of
+ literal ->
+ true;
+ var ->
+ true;
+ 'fun' ->
+ true;
+ values ->
+ is_safe_expr_list(cerl:values_es(E), Check);
+ tuple ->
+ is_safe_expr_list(cerl:tuple_es(E), Check);
+ cons ->
+ case is_safe_expr(cerl:cons_hd(E), Check) of
+ true ->
+ is_safe_expr(cerl:cons_tl(E), Check);
+ false ->
+ false
+ end;
+ 'let' ->
+ case is_safe_expr(cerl:let_arg(E), Check) of
+ true ->
+ is_safe_expr(cerl:let_body(E), Check);
+ false ->
+ false
+ end;
+ letrec ->
+ is_safe_expr(cerl:letrec_body(E), Check);
+ seq ->
+ case is_safe_expr(cerl:seq_arg(E), Check) of
+ true ->
+ is_safe_expr(cerl:seq_body(E), Check);
+ false ->
+ false
+ end;
+ 'catch' ->
+ is_safe_expr(cerl:catch_body(E), Check);
+ 'try' ->
+ %% If the guarded expression is safe, the try-handler will
+ %% never be evaluated, so we need only check the body. If
+ %% the guarded expression is pure, but could fail, we also
+ %% have to check the handler.
+ case is_safe_expr(cerl:try_arg(E), Check) of
+ true ->
+ is_safe_expr(cerl:try_body(E), Check);
+ false ->
+ case is_pure_expr(cerl:try_arg(E), Check) of
+ true ->
+ case is_safe_expr(cerl:try_body(E), Check) of
+ true ->
+ is_safe_expr(cerl:try_handler(E), Check);
+ false ->
+ false
+ end;
+ false ->
+ false
+ end
+ end;
+ primop ->
+ Name = cerl:atom_val(cerl:primop_name(E)),
+ As = cerl:primop_args(E),
+ case Check(safe, {Name, length(As)}) of
+ true ->
+ is_safe_expr_list(As, Check);
+ false ->
+ false
+ end;
+ call ->
+ Module = cerl:call_module(E),
+ Name = 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),
+ As = cerl:call_args(E),
+ case Check(safe, {M, F, length(As)}) of
+ true ->
+ is_safe_expr_list(As, Check);
+ false ->
+ false
+ end;
+ false ->
+ false % Call to unknown function
+ end;
+ _ ->
+ false
+ end.
+
+is_safe_expr_list([E | Es], Check) ->
+ case is_safe_expr(E, Check) of
+ true ->
+ is_safe_expr_list(Es, Check);
+ false ->
+ false
+ end;
+is_safe_expr_list([], _Check) ->
+ true.
+
+
+%% @spec (Expr::cerl()) -> bool()
+%%
+%% @doc Returns `true' if `Expr' represents a "pure" Core Erlang
+%% expression, otherwise `false'. An expression is pure if it does not
+%% affect the state, nor depend on the state, although its evaluation is
+%% not guaranteed to complete normally for all input.
+%%
+%% Expressions of type `apply', `case', `receive' and `binary' are
+%% always considered impure by this function.
+
+-ifndef(NO_UNUSED).
+is_pure_expr(E) ->
+ Check = fun default_check/2,
+ is_pure_expr(E, Check).
+-endif.
+%% @clear
+
+is_pure_expr(E, Check) ->
+ case cerl:type(E) of
+ literal ->
+ true;
+ var ->
+ true;
+ 'fun' ->
+ true;
+ values ->
+ is_pure_expr_list(cerl:values_es(E), Check);
+ tuple ->
+ is_pure_expr_list(cerl:tuple_es(E), Check);
+ cons ->
+ case is_pure_expr(cerl:cons_hd(E), Check) of
+ true ->
+ is_pure_expr(cerl:cons_tl(E), Check);
+ false ->
+ false
+ end;
+ 'let' ->
+ case is_pure_expr(cerl:let_arg(E), Check) of
+ true ->
+ is_pure_expr(cerl:let_body(E), Check);
+ false ->
+ false
+ end;
+ letrec ->
+ is_pure_expr(cerl:letrec_body(E), Check);
+ seq ->
+ case is_pure_expr(cerl:seq_arg(E), Check) of
+ true ->
+ is_pure_expr(cerl:seq_body(E), Check);
+ false ->
+ false
+ end;
+ 'catch' ->
+ is_pure_expr(cerl:catch_body(E), Check);
+ 'try' ->
+ case is_pure_expr(cerl:try_arg(E), Check) of
+ true ->
+ case is_pure_expr(cerl:try_body(E), Check) of
+ true ->
+ is_pure_expr(cerl:try_handler(E), Check);
+ false ->
+ false
+ end;
+ false ->
+ false
+ end;
+ primop ->
+ Name = cerl:atom_val(cerl:primop_name(E)),
+ As = cerl:primop_args(E),
+ case Check(pure, {Name, length(As)}) of
+ true ->
+ is_pure_expr_list(As, Check);
+ false ->
+ false
+ end;
+ call ->
+ Module = cerl:call_module(E),
+ Name = 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),
+ As = cerl:call_args(E),
+ case Check(pure, {M, F, length(As)}) of
+ true ->
+ is_pure_expr_list(As, Check);
+ false ->
+ false
+ end;
+ false ->
+ false % Call to unknown function
+ end;
+ _ ->
+ false
+ end.
+
+is_pure_expr_list([E | Es], Check) ->
+ case is_pure_expr(E, Check) of
+ true ->
+ is_pure_expr_list(Es, Check);
+ false ->
+ false
+ end;
+is_pure_expr_list([], _Check) ->
+ true.
+
+
+%% Peephole optimizations
+%%
+%% This is only intended to be a light-weight cleanup optimizer,
+%% removing small things that may e.g. have been generated by other
+%% optimization passes or in the translation from higher-level code.
+%% It is not recursive in general - it only descends until it can do no
+%% more work in the current context.
+%%
+%% To expose hidden cases of final expressions (enabling last call
+%% optimization), we try to remove all trivial let-bindings (`let X = Y
+%% in X', `let X = Y in Y', `let X = Y in let ... in ...', `let X = let
+%% ... in ... in ...', etc.). We do not, however, try to recognize any
+%% other similar cases, even for simple `case'-expressions like `case E
+%% of X -> X end', or simultaneous multiple-value bindings.
+
+-spec reduce_expr(cerl:cerl()) -> cerl:cerl().
+
+reduce_expr(E) ->
+ Check = fun default_check/2,
+ reduce_expr(E, Check).
+
+-spec reduce_expr(cerl:cerl(), check_fun()) -> cerl:cerl().
+
+reduce_expr(E, Check) ->
+ case cerl:type(E) of
+ values ->
+ case cerl:values_es(E) of
+ [E1] ->
+ %% Not really an "optimization" in itself, but
+ %% enables other rewritings by removing the wrapper.
+ reduce_expr(E1, Check);
+ _ ->
+ E
+ end;
+ 'seq' ->
+ A = reduce_expr(cerl:seq_arg(E), Check),
+ B = reduce_expr(cerl:seq_body(E), Check),
+ %% `do <E1> <E2>' is equivalent to `<E2>' if `<E1>' is
+ %% "safe" (cannot effect the behaviour in any way).
+ case is_safe_expr(A, Check) of
+ true ->
+ B;
+ false ->
+ case cerl:is_c_seq(B) of
+ true ->
+ %% Rewrite `do <E1> do <E2> <E3>' to `do do
+ %% <E1> <E2> <E3>' so that the "body" of the
+ %% outermost seq-operator is the expression
+ %% which produces the final result (i.e.,
+ %% E3). This can make other optimizations
+ %% easier; see `let'.
+ B1 = cerl:seq_arg(B),
+ B2 = cerl:seq_body(B),
+ cerl:c_seq(cerl:c_seq(A, B1), B2);
+ false ->
+ cerl:c_seq(A, B)
+ end
+ end;
+ 'let' ->
+ A = reduce_expr(cerl:let_arg(E), Check),
+ case cerl:is_c_seq(A) of
+ true ->
+ %% `let X = do <E1> <E2> in Y' is equivalent to `do
+ %% <E1> let X = <E2> in Y'. Note that `<E2>' cannot
+ %% be a seq-operator, due to the `seq' optimization.
+ A1 = cerl:seq_arg(A),
+ A2 = cerl:seq_body(A),
+ E1 = cerl:update_c_let(E, cerl:let_vars(E),
+ A2, cerl:let_body(E)),
+ cerl:c_seq(A1, reduce_expr(E1, Check));
+ false ->
+ B = reduce_expr(cerl:let_body(E), Check),
+ Vs = cerl:let_vars(E),
+ %% We give up if the body does not reduce to a
+ %% single variable. This is not a generic copy
+ %% propagation.
+ case cerl:type(B) of
+ var when length(Vs) =:= 1 ->
+ %% We have `let <V1> = <E> in <V2>':
+ [V] = Vs,
+ N1 = cerl:var_name(V),
+ N2 = cerl:var_name(B),
+ if N1 =:= N2 ->
+ %% `let X = <E> in X' equals `<E>'
+ A;
+ true ->
+ %% `let X = <E> in Y' when X and Y
+ %% are different variables is
+ %% equivalent to `do <E> Y'.
+ reduce_expr(cerl:c_seq(A, B), Check)
+ end;
+ literal ->
+ %% `let X = <E> in T' when T is a literal
+ %% term is equivalent to `do <E> T'.
+ reduce_expr(cerl:c_seq(A, B), Check);
+ _ ->
+ cerl:update_c_let(E, Vs, A, B)
+ end
+ end;
+ 'try' ->
+ %% Get rid of unnecessary try-expressions.
+ A = reduce_expr(cerl:try_arg(E), Check),
+ B = reduce_expr(cerl:try_body(E), Check),
+ case is_safe_expr(A, Check) of
+ true ->
+ B;
+ false ->
+ cerl:update_c_try(E, A, cerl:try_vars(E), B,
+ cerl:try_evars(E),
+ cerl:try_handler(E))
+ end;
+ 'catch' ->
+ %% Just a simpler form of try-expressions.
+ B = reduce_expr(cerl:catch_body(E), Check),
+ case is_safe_expr(B, Check) of
+ true ->
+ B;
+ false ->
+ cerl:update_c_catch(E, B)
+ end;
+ _ ->
+ E
+ end.
diff --git a/lib/hipe/cerl/cerl_messagean.erl b/lib/hipe/cerl/cerl_messagean.erl
new file mode 100644
index 0000000000..0753376e7d
--- /dev/null
+++ b/lib/hipe/cerl/cerl_messagean.erl
@@ -0,0 +1,1105 @@
+%% =====================================================================
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2004-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+%%
+%% Message analysis of Core Erlang programs.
+%%
+%% Copyright (C) 2002 Richard Carlsson
+%%
+%% Author contact: [email protected]
+%% =====================================================================
+
+%% TODO: might need a "top" (`any') element for any-length value lists.
+
+-module(cerl_messagean).
+
+-export([annotate/1]).
+
+-import(cerl, [alias_pat/1, alias_var/1, ann_c_var/2, ann_c_fun/3,
+ apply_args/1, apply_op/1, atom_val/1, bitstr_size/1,
+ bitstr_val/1, binary_segments/1, c_letrec/2,
+ ann_c_tuple/2, c_nil/0, call_args/1, call_module/1,
+ call_name/1, case_arg/1, case_clauses/1, catch_body/1,
+ clause_body/1, clause_guard/1, clause_pats/1, cons_hd/1,
+ cons_tl/1, fun_body/1, fun_vars/1, get_ann/1, int_val/1,
+ is_c_atom/1, is_c_int/1, let_arg/1, let_body/1,
+ let_vars/1, letrec_body/1, letrec_defs/1, module_defs/1,
+ module_defs/1, module_exports/1, pat_vars/1,
+ primop_args/1, primop_name/1, receive_action/1,
+ receive_clauses/1, receive_timeout/1, seq_arg/1,
+ seq_body/1, set_ann/2, try_arg/1, try_body/1, try_vars/1,
+ try_evars/1, try_handler/1, tuple_es/1, type/1,
+ values_es/1]).
+
+-import(cerl_trees, [get_label/1]).
+
+-define(DEF_LIMIT, 4).
+
+%% -export([test/1, test1/1, ttest/1]).
+
+%% ttest(F) ->
+%% {T, _} = cerl_trees:label(user_default:read(F)),
+%% {Time0, _} = erlang:statistics(runtime),
+%% analyze(T),
+%% {Time1, _} = erlang:statistics(runtime),
+%% Time1 - Time0.
+
+%% test(F) ->
+%% {T, _} = cerl_trees:label(user_default:read(F)),
+%% {Time0, _} = erlang:statistics(runtime),
+%% {Esc, _Vars} = analyze(T),
+%% {Time1, _} = erlang:statistics(runtime),
+%% io:fwrite("messages: ~p.\n", [Esc]),
+%% Set = sets:from_list(Esc),
+%% H = fun (Node, Ctxt, Cont) ->
+%% Doc = case get_ann(Node) of
+%% [{label, L} | _] ->
+%% B = sets:is_element(L, Set),
+%% bf(Node, Ctxt, Cont, B);
+%% _ ->
+%% bf(Node, Ctxt, Cont, false)
+%% end,
+%% case type(Node) of
+%% cons -> color(Doc);
+%% tuple -> color(Doc);
+%% _ -> Doc
+%% end
+%% end,
+%% {ok, FD} = file:open("out.html",[write]),
+%% Txt = cerl_prettypr:format(T, [{hook, H},{user,false}]),
+%% io:put_chars(FD, "<pre>\n"),
+%% io:put_chars(FD, html(Txt)),
+%% io:put_chars(FD, "</pre>\n"),
+%% file:close(FD),
+%% {ok, Time1 - Time0}.
+
+%% test1(F) ->
+%% {T, _} = cerl_trees:label(user_default:read(F)),
+%% {Time0, _} = erlang:statistics(runtime),
+%% {T1, Esc, Vars} = annotate(T),
+%% {Time1, _} = erlang:statistics(runtime),
+%% io:fwrite("messages: ~p.\n", [Esc]),
+%% %%% io:fwrite("vars: ~p.\n", [[X || X <- dict:to_list(Vars)]]),
+%% T2 = hhl_transform:transform(T1, Vars),
+%% Set = sets:from_list(Esc),
+%% H = fun (Node, Ctxt, Cont) ->
+%% case get_ann(Node) of
+%% [{label, L} | _] ->
+%% B = sets:is_element(L, Set),
+%% bf(Node, Ctxt, Cont, B);
+%% _ ->
+%% bf(Node, Ctxt, Cont, false)
+%% end
+%% end,
+%% {ok, FD} = file:open("out.html",[write]),
+%% Txt = cerl_prettypr:format(T2, [{hook, H},{user,false}]),
+%% io:put_chars(FD, "<pre>\n"),
+%% io:put_chars(FD, html(Txt)),
+%% io:put_chars(FD, "</pre>\n"),
+%% file:close(FD),
+%% {ok, Time1 - Time0}.
+
+%% html(Cs) ->
+%% html(Cs, []).
+
+%% html([$#, $< | Cs], As) ->
+%% html_1(Cs, [$< | As]);
+%% html([$< | Cs], As) ->
+%% html(Cs, ";tl&" ++ As);
+%% html([$> | Cs], As) ->
+%% html(Cs, ";tg&" ++ As);
+%% html([$& | Cs], As) ->
+%% html(Cs, ";pma&" ++ As);
+%% html([C | Cs], As) ->
+%% html(Cs, [C | As]);
+%% html([], As) ->
+%% lists:reverse(As).
+
+%% html_1([$> | Cs], As) ->
+%% html(Cs, [$> | As]);
+%% html_1([C | Cs], As) ->
+%% html_1(Cs, [C | As]).
+
+%% bf(Node, Ctxt, Cont, B) ->
+%% B0 = cerl_prettypr:get_ctxt_user(Ctxt),
+%% if B /= B0 ->
+%% Ctxt1 = cerl_prettypr:set_ctxt_user(Ctxt, B),
+%% Doc = Cont(Node, Ctxt1),
+%% case B of
+%% true ->
+%% Start = "<b>",
+%% End = "</b>";
+%% false ->
+%% Start = "</b>",
+%% End = "<b>"
+%% end,
+%% markup(Doc, Start, End);
+%% true ->
+%% Cont(Node, Ctxt)
+%% end.
+
+%% color(Doc) ->
+%% % Doc.
+%% markup(Doc, "<font color=blue>", "</font>").
+
+%% markup(Doc, Start, End) ->
+%% prettypr:beside(
+%% prettypr:null_text([$# | Start]),
+%% prettypr:beside(Doc,
+%% prettypr:null_text([$# | End]))).
+
+
+%% =====================================================================
+%% annotate(Tree) -> {Tree1, Escapes, Vars}
+%%
+%% Tree = cerl:cerl()
+%%
+%% Analyzes `Tree' (see `analyze') and appends a term 'escapes', to
+%% the annotation list of each constructor expression node and of
+%% `Tree', corresponding to the escape information derived by the
+%% analysis. Any previous such annotations are removed from `Tree'.
+%% `Tree1' is the modified tree; for details on `OutList',
+%% `Outputs' , `Dependencies', `Escapes' and `Parents', see
+%% `analyze'.
+%%
+%% Note: `Tree' must be annotated with labels in order to use this
+%% function; see `analyze' for details.
+
+-type label() :: integer() | 'external' | 'top'.
+-type ordset(X) :: [X]. % XXX: TAKE ME OUT
+
+-spec annotate(cerl:cerl()) -> {cerl:cerl(), ordset(label()), dict()}.
+
+annotate(Tree) ->
+ {Esc0, Vars} = analyze(Tree),
+ Esc = sets:from_list(Esc0),
+ F = fun (T) ->
+ case type(T) of
+ literal -> T;
+%%% var ->
+%%% L = get_label(T),
+%%% T1 = ann_escape(T, L, Esc),
+%%% X = dict:fetch(L, Vars),
+%%% set_ann(T1, append_ann({s,X}, get_ann(T1)));
+ _ ->
+ L = get_label(T),
+ ann_escape(T, L, Esc)
+ end
+ end,
+ {cerl_trees:map(F, Tree), Esc0, Vars}.
+
+ann_escape(T, L, Esc) ->
+ case sets:is_element(L, Esc) of
+ true ->
+ set_ann(T, append_ann(escapes, get_ann(T)));
+ false ->
+ T
+ end.
+
+append_ann(Tag, [X | Xs]) ->
+ if tuple_size(X) >= 1, element(1, X) =:= Tag ->
+ append_ann(Tag, Xs);
+ true ->
+ [X | append_ann(Tag, Xs)]
+ end;
+append_ann(Tag, []) ->
+ [Tag].
+
+
+%% =====================================================================
+%% analyze(Tree) -> Escapes
+%%
+%% Tree = cerl:cerl()
+%% Escapes = ordset(Label)
+%% Label = integer() | external | top
+%%
+%% Analyzes a module or an expression represented by `Tree'.
+%%
+%% `Escapes' is the set of labels of constructor expressions in
+%% `Tree' such that the created values may be accessed from outside
+%% `Tree'.
+%%
+%% Note: `Tree' must be annotated with labels (as done by the
+%% function `cerl_trees:label/1') in order to use this function.
+%% The label annotation `{label, L}' (where L should be an integer)
+%% must be the first element of the annotation list of each node in
+%% the tree. Instances of variables bound in `Tree' which denote
+%% the same variable must have the same label; apart from this,
+%% labels should be unique. Constant literals do not need to be
+%% labeled.
+
+-record(state, {vars, out, dep, work, funs, k}).
+
+%% Note: We assume that all remote calls and primops return a single
+%% value.
+
+%% The analysis determines which objects (identified by the
+%% corresponding "cons-point" labels in the code) are likely to be
+%% passed in a message. (If so, we say that they "escape".) It is always
+%% safe to assume either case, because the send operation will assure
+%% that things are copied if necessary. This analysis tries to
+%% anticipate that copying will be done.
+%%
+%% Rules:
+%% 1) An object passed as message argument (or part of such an
+%% argument) to a known send-operation, will probably be a message.
+%% 2) A received value is always a message (safe).
+%% 3) The external function can return any object (unsafe).
+%% 4) A function called from the external function can receive any
+%% object (unsafe) as argument.
+%% 5) Unknown functions/operations can return any object (unsafe).
+
+%% We wrap the given syntax tree T in a fun-expression labeled `top',
+%% which is initially in the set of escaped labels. `top' will be
+%% visited at least once.
+%%
+%% We create a separate function labeled `external', defined as:
+%% "'external'/1 = fun () -> Any", which will represent any and all
+%% functions outside T, and which returns the 'unsafe' value.
+
+analyze(Tree) ->
+ analyze(Tree, ?DEF_LIMIT).
+
+analyze(Tree, Limit) ->
+ {_, _, Esc, Dep, _Par} = cerl_closurean:analyze(Tree),
+%%% io:fwrite("dependencies: ~w.\n", [dict:to_list(Dep)]),
+ analyze(Tree, Limit, Dep, Esc).
+
+analyze(Tree, Limit, Dep0, Esc0) ->
+ %% Note that we use different name spaces for variable labels and
+ %% function/call site labels, so we can reuse some names here. We
+ %% assume that the labeling of Tree only uses integers, not atoms.
+ Any = ann_c_var([{label, any}], 'Any'),
+ External = ann_c_var([{label, external}], {external, 1}),
+ ExtFun = ann_c_fun([{label, external}], [], Any),
+%%% io:fwrite("external fun:\n~s.\n",
+%%% [cerl_prettypr:format(ExtFun, [noann, {paper, 80}])]),
+ Top = ann_c_var([{label, top}], {top, 0}),
+ TopFun = ann_c_fun([{label, top}], [], Tree),
+
+ %% The "start fun" just makes the initialisation easier. It is not
+ %% itself in the call graph.
+ StartFun = ann_c_fun([{label, start}], [],
+ c_letrec([{External, ExtFun}, {Top, TopFun}],
+ c_nil())),
+%%% io:fwrite("start fun:\n~s.\n",
+%%% [cerl_prettypr:format(StartFun, [{paper, 80}])]),
+
+ %% Initialise the Any and Escape variables. Gather a database of all
+ %% fun-expressions in Tree and initialise their outputs and parameter
+ %% variables. All escaping functions can receive any values as
+ %% inputs. Bind all module- and letrec-defined variables to their
+ %% corresponding labels.
+ Esc = sets:from_list(Esc0),
+ Unsafe = unsafe(),
+ Empty = empty(),
+ Funs0 = dict:new(),
+ Vars0 = dict:store(escape, empty(),
+ dict:store(any, Unsafe, dict:new())),
+ Out0 = dict:new(),
+ F = fun (T, S = {Fs, Vs, Os}) ->
+ case type(T) of
+ 'fun' ->
+ L = get_label(T),
+ As = fun_vars(T),
+ X = case sets:is_element(L, Esc) of
+ true -> Unsafe;
+ false -> Empty
+ end,
+ {dict:store(L, T, Fs),
+ bind_vars_single(As, X, Vs),
+ dict:store(L, none, Os)};
+ letrec ->
+ {Fs, bind_defs(letrec_defs(T), Vs), Os};
+ module ->
+ {Fs, bind_defs(module_defs(T), Vs), Os};
+ _ ->
+ S
+ end
+ end,
+ {Funs, Vars, Out} = cerl_trees:fold(F, {Funs0, Vars0, Out0}, StartFun),
+
+ %% Add the dependency for the loop in 'external':
+ Dep = add_dep(loop, external, Dep0),
+
+ %% Enter the fixpoint iteration at the StartFun.
+ St = loop(StartFun, start, #state{vars = Vars,
+ out = Out,
+ dep = Dep,
+ work = init_work(),
+ funs = Funs,
+ k = Limit}),
+ Ms = labels(dict:fetch(escape, St#state.vars)),
+ {Ms, St#state.vars}.
+
+loop(T, L, St0) ->
+%%% io:fwrite("analyzing: ~w.\n",[L]),
+%%% io:fwrite("work: ~w.\n", [St0#state.work]),
+ Xs0 = dict:fetch(L, St0#state.out),
+ {Xs1, St1} = visit(fun_body(T), L, St0),
+ Xs = limit(Xs1, St1#state.k),
+ {W, M} = case equal(Xs0, Xs) of
+ true ->
+ {St1#state.work, St1#state.out};
+ false ->
+%%% io:fwrite("out (~w) changed: ~w <- ~w.\n",
+%%% [L, Xs, Xs0]),
+ M1 = dict:store(L, Xs, St1#state.out),
+ case dict:find(L, St1#state.dep) of
+ {ok, S} ->
+ {add_work(set__to_list(S), St1#state.work),
+ M1};
+ error ->
+ {St1#state.work, M1}
+ end
+ end,
+ St2 = St1#state{out = M},
+ case take_work(W) of
+ {ok, L1, W1} ->
+ T1 = dict:fetch(L1, St2#state.funs),
+ loop(T1, L1, St2#state{work = W1});
+ none ->
+ St2
+ end.
+
+visit(T, L, St) ->
+%%% io:fwrite("visiting: ~w.\n",[type(T)]),
+ case type(T) of
+ literal ->
+ %% This is (or should be) a constant, even if it's compound,
+ %% so it's bugger all whether it is sent or not.
+ case cerl:concrete(T) of
+ [] -> {[empty()], St};
+ X when is_atom(X) -> {[empty()], St};
+ X when is_integer(X) -> {[empty()], St};
+ X when is_float(X) -> {[empty()], St};
+ _ ->
+ exit({not_literal, T})
+ end;
+ var ->
+ %% If a variable is not already in the store here, it must
+ %% be free in the program.
+ L1 = get_label(T),
+ Vars = St#state.vars,
+ case dict:find(L1, Vars) of
+ {ok, X} ->
+ {[X], St};
+ error ->
+%%% io:fwrite("free var: ~w.\n",[L1]),
+ X = unsafe(),
+ St1 = St#state{vars = dict:store(L1, X, Vars)},
+ {[X], St1}
+ end;
+ 'fun' ->
+ %% Must revisit the fun also, because its environment might
+ %% have changed. (We don't keep track of such dependencies.)
+ L1 = get_label(T),
+ St1 = St#state{work = add_work([L1], St#state.work)},
+ %% Currently, lambda expressions can only be locally
+ %% allocated, and therefore we have to force copying by
+ %% treating them as "unsafe" for now.
+ {[unsafe()], St1};
+ %% {[singleton(L1)], St1};
+ values ->
+ visit_list(values_es(T), L, St);
+ cons ->
+ {[X1, X2], St1} = visit_list([cons_hd(T), cons_tl(T)], L, St),
+ L1 = get_label(T),
+ X = make_cons(L1, X1, X2),
+ %% Also store the values of the elements.
+ Hd = get_hd(X),
+ Tl = get_tl(X),
+ St2 = St1#state{vars = dict:store(L1, [Hd, Tl], St1#state.vars)},
+ {[X], St2};
+ tuple ->
+ {Xs, St1} = visit_list(tuple_es(T), L, St),
+ L1 = get_label(T),
+ %% Also store the values of the elements.
+ St2 = St1#state{vars = dict:store(L1, Xs, St1#state.vars)},
+ {[struct(L1, Xs)], St2};
+ 'let' ->
+ {Xs, St1} = visit(let_arg(T), L, St),
+ Vars = bind_vars(let_vars(T), Xs, St1#state.vars),
+ visit(let_body(T), L, St1#state{vars = Vars});
+ seq ->
+ {_, St1} = visit(seq_arg(T), L, St),
+ visit(seq_body(T), L, St1);
+ apply ->
+ {_F, St1} = visit(apply_op(T), L, St),
+ {As, St2} = visit_list(apply_args(T), L, St1),
+ L1 = get_label(T),
+ Ls = get_deps(L1, St#state.dep),
+ Out = St2#state.out,
+ Xs1 = join_list([dict:fetch(X, Out) || X <- Ls]),
+ {Xs1, call_site(Ls, As, St2)};
+ call ->
+ M = call_module(T),
+ F = call_name(T),
+ As = call_args(T),
+ {_, St1} = visit(M, L, St),
+ {_, St2} = visit(F, L, St1),
+ {Xs, St3} = visit_list(As, L, St2),
+ L1 = get_label(T),
+ remote_call(M, F, Xs, As, L1, St3);
+ primop ->
+ As = primop_args(T),
+ {Xs, St1} = visit_list(As, L, St),
+ F = atom_val(primop_name(T)),
+ primop_call(F, length(Xs), Xs, As, St1);
+ 'case' ->
+ {Xs, St1} = visit(case_arg(T), L, St),
+ visit_clauses(Xs, case_clauses(T), L, St1);
+ 'receive' ->
+ %% The received value is of course a message, so it
+ %% is 'empty()', not 'unsafe()'.
+ X = empty(),
+ {Xs1, St1} = visit_clauses([X], receive_clauses(T), L, St),
+ {_, St2} = visit(receive_timeout(T), L, St1),
+ {Xs2, St3} = visit(receive_action(T), L, St2),
+ {join(Xs1, Xs2), St3};
+ 'try' ->
+ {Xs1, St1} = visit(try_arg(T), L, St),
+ X = unsafe(),
+ Vars = bind_vars(try_vars(T), Xs1, St1#state.vars),
+ {Xs2, St2} = visit(try_body(T), L, St1#state{vars = Vars}),
+ EVars = bind_vars(try_evars(T), [X, X, X], St2#state.vars),
+ {Xs3, St3} = visit(try_handler(T), L, St2#state{vars = EVars}),
+ {join(Xs2, Xs3), St3};
+ 'catch' ->
+ %% If we catch an exception, we can get unsafe data.
+ {Xs, St1} = visit(catch_body(T), L, St),
+ {join([unsafe()], Xs), St1};
+ binary ->
+ %% Binaries are heap objects, but we don't have special
+ %% shared-heap allocation operators for them at the moment.
+ %% They must therefore be treated as unsafe.
+ {_, St1} = visit_list(binary_segments(T), L, St),
+ {[unsafe()], St1};
+ bitstr ->
+ %% The other fields are constant literals.
+ {_, St1} = visit(bitstr_val(T), L, St),
+ {_, St2} = visit(bitstr_size(T), L, St1),
+ {none, St2};
+ letrec ->
+ %% All the bound funs should be revisited, because the
+ %% environment might have changed.
+ Ls = [get_label(F) || {_, F} <- letrec_defs(T)],
+ St1 = St#state{work = add_work(Ls, St#state.work)},
+ visit(letrec_body(T), L, St1);
+ module ->
+ %% We regard a module as a tuple of function variables in
+ %% the body of a `letrec'.
+ visit(c_letrec(module_defs(T),
+ ann_c_tuple([{label, get_label(T)}],
+ module_exports(T))),
+ L, St)
+ end.
+
+visit_clause(T, Xs, L, St) ->
+ Vars = bind_pats(clause_pats(T), Xs, St#state.vars),
+ {_, St1} = visit(clause_guard(T), L, St#state{vars = Vars}),
+ visit(clause_body(T), L, St1).
+
+%% We assume correct value-list typing.
+
+visit_list([T | Ts], L, St) ->
+ {Xs, St1} = visit(T, L, St),
+ {Xs1, St2} = visit_list(Ts, L, St1),
+ X = case Xs of
+ [X1] -> X1;
+ _ -> empty()
+ end,
+ {[X | Xs1], St2};
+visit_list([], _L, St) ->
+ {[], St}.
+
+visit_clauses(Xs, [T | Ts], L, St) ->
+ {Xs1, St1} = visit_clause(T, Xs, L, St),
+ {Xs2, St2} = visit_clauses(Xs, Ts, L, St1),
+ {join(Xs1, Xs2), St2};
+visit_clauses(_, [], _L, St) ->
+ {none, St}.
+
+bind_defs([{V, F} | Ds], Vars) ->
+ bind_defs(Ds, dict:store(get_label(V), singleton(get_label(F)), Vars));
+bind_defs([], Vars) ->
+ Vars.
+
+bind_pats(Ps, none, Vars) ->
+ bind_pats_single(Ps, empty(), Vars);
+bind_pats(Ps, Xs, Vars) ->
+ if length(Xs) =:= length(Ps) ->
+ bind_pats_list(Ps, Xs, Vars);
+ true ->
+ bind_pats_single(Ps, empty(), Vars)
+ end.
+
+%% The lists might not be of the same length.
+
+bind_pats_list([P | Ps], [X | Xs], Vars) ->
+ bind_pats_list(Ps, Xs, bind_pat_vars(P, X, Vars));
+bind_pats_list(Ps, [], Vars) ->
+ bind_pats_single(Ps, empty(), Vars);
+bind_pats_list([], _, Vars) ->
+ Vars.
+
+bind_pats_single([P | Ps], X, Vars) ->
+ bind_pats_single(Ps, X, bind_pat_vars(P, X, Vars));
+bind_pats_single([], _X, Vars) ->
+ Vars.
+
+bind_pat_vars(P, X, Vars) ->
+ case type(P) of
+ var ->
+ dict:store(get_label(P), X, Vars);
+ literal ->
+ Vars;
+ cons ->
+ bind_pats_list([cons_hd(P), cons_tl(P)],
+ [get_hd(X), get_tl(X)], Vars);
+ tuple ->
+ case elements(X) of
+ none ->
+ bind_vars_single(pat_vars(P), X, Vars);
+ Xs ->
+ bind_pats_list(tuple_es(P), Xs, Vars)
+ end;
+ binary ->
+ %% See the handling of binary-expressions.
+ bind_pats_single(binary_segments(P), unsafe(), Vars);
+ bitstr ->
+ %% See the handling of binary-expressions.
+ bind_pats_single([bitstr_val(P), bitstr_size(P)],
+ unsafe(), Vars);
+ alias ->
+ P1 = alias_pat(P),
+ Vars1 = bind_pat_vars(P1, X, Vars),
+ dict:store(get_label(alias_var(P)), X, Vars1)
+ end.
+
+%%% %% This is the "exact" version of list representation, which simply
+%%% %% mimics the actual cons, head and tail operations.
+%%% make_cons(L, X1, X2) ->
+%%% struct(L1, [X1, X2]).
+%%% get_hd(X) ->
+%%% case elements(X) of
+%%% none -> X;
+%%% [X1 | _] -> X1;
+%%% _ -> empty()
+%%% end.
+%%% get_tl(X) ->
+%%% case elements(X) of
+%%% none -> X;
+%%% [_, X2 | _] -> X2;
+%%% _ -> empty()
+%%% end.
+
+%% This version does not unnecessarily confuse spine labels with element
+%% labels, and is safe. However, it loses precision if cons cells are
+%% used for other things than proper lists.
+
+make_cons(L, X1, X2) ->
+ %% join subtypes and cons locations
+ join_single(struct(L, [X1]), X2).
+
+get_hd(X) ->
+ case elements(X) of
+ none -> X;
+ [X1 | _] -> X1; % First element represents list subtype.
+ _ -> empty()
+ end.
+
+get_tl(X) -> X. % Tail of X has same type as X.
+
+bind_vars(Vs, none, Vars) ->
+ bind_vars_single(Vs, empty(), Vars);
+bind_vars(Vs, Xs, Vars) ->
+ if length(Vs) =:= length(Xs) ->
+ bind_vars_list(Vs, Xs, Vars);
+ true ->
+ bind_vars_single(Vs, empty(), Vars)
+ end.
+
+bind_vars_list([V | Vs], [X | Xs], Vars) ->
+ bind_vars_list(Vs, Xs, dict:store(get_label(V), X, Vars));
+bind_vars_list([], [], Vars) ->
+ Vars.
+
+bind_vars_single([V | Vs], X, Vars) ->
+ bind_vars_single(Vs, X, dict:store(get_label(V), X, Vars));
+bind_vars_single([], _X, Vars) ->
+ Vars.
+
+%% This handles a call site, updating parameter variables with respect
+%% to the actual parameters. The 'external' function is handled
+%% specially, since it can get an arbitrary number of arguments. For our
+%% purposes here, calls to the external function can be ignored.
+
+call_site(Ls, Xs, St) ->
+%%% io:fwrite("call site: ~w -> ~w (~w).\n", [L, Ls, Xs]),
+ {W, V} = call_site(Ls, Xs, St#state.work, St#state.vars,
+ St#state.funs, St#state.k),
+ St#state{work = W, vars = V}.
+
+call_site([external | Ls], Xs, W, V, Fs, Limit) ->
+ call_site(Ls, Xs, W, V, Fs, Limit);
+call_site([L | Ls], Xs, W, V, Fs, Limit) ->
+ Vs = fun_vars(dict:fetch(L, Fs)),
+ case bind_args(Vs, Xs, V, Limit) of
+ {V1, true} ->
+ call_site(Ls, Xs, add_work([L], W), V1, Fs, Limit);
+ {V1, false} ->
+ call_site(Ls, Xs, W, V1, Fs, Limit)
+ end;
+call_site([], _, W, V, _, _) ->
+ {W, V}.
+
+add_dep(Source, Target, Deps) ->
+ case dict:find(Source, Deps) of
+ {ok, X} ->
+ case set__is_member(Target, X) of
+ true ->
+ Deps;
+ false ->
+%%% io:fwrite("new dep: ~w <- ~w.\n", [Target, Source]),
+ dict:store(Source, set__add(Target, X), Deps)
+ end;
+ error ->
+%%% io:fwrite("new dep: ~w <- ~w.\n", [Target, Source]),
+ dict:store(Source, set__singleton(Target), Deps)
+ end.
+
+%% If the arity does not match the call, nothing is done here.
+
+bind_args(Vs, Xs, Vars, Limit) ->
+ if length(Vs) =:= length(Xs) ->
+ bind_args(Vs, Xs, Vars, Limit, false);
+ true ->
+ {Vars, false}
+ end.
+
+bind_args([V | Vs], [X | Xs], Vars, Limit, Ch) ->
+ L = get_label(V),
+ {Vars1, Ch1} = bind_arg(L, X, Vars, Limit, Ch),
+ bind_args(Vs, Xs, Vars1, Limit, Ch1);
+bind_args([], [], Vars, _Limit, Ch) ->
+ {Vars, Ch}.
+
+%% bind_arg(L, X, Vars, Limit) ->
+%% bind_arg(L, X, Vars, Limit, false).
+
+bind_arg(L, X, Vars, Limit, Ch) ->
+ X0 = dict:fetch(L, Vars),
+ X1 = limit_single(join_single(X, X0), Limit),
+ case equal_single(X0, X1) of
+ true ->
+ {Vars, Ch};
+ false ->
+%%% io:fwrite("arg (~w) changed: ~w <- ~w + ~w.\n",
+%%% [L, X1, X0, X]),
+ {dict:store(L, X1, Vars), true}
+ end.
+
+%% This handles escapes from things like primops and remote calls.
+
+escape(Xs, Ns, St) ->
+ escape(Xs, Ns, 1, St).
+
+escape([_ | Xs], Ns=[N1 | _], N, St) when is_integer(N1), N1 > N ->
+ escape(Xs, Ns, N + 1, St);
+escape([X | Xs], [N | Ns], N, St) ->
+ Vars = St#state.vars,
+ X0 = dict:fetch(escape, Vars),
+ X1 = join_single(X, X0),
+ case equal_single(X0, X1) of
+ true ->
+ escape(Xs, Ns, N + 1, St);
+ false ->
+%%% io:fwrite("escape changed: ~w <- ~w + ~w.\n", [X1, X0, X]),
+ Vars1 = dict:store(escape, X1, Vars),
+ escape(Xs, Ns, N + 1, St#state{vars = Vars1})
+ end;
+escape(Xs, [_ | Ns], N, St) ->
+ escape(Xs, Ns, N + 1, St);
+escape(_, _, _, St) ->
+ St.
+
+%% Handle primop calls: (At present, we assume that all unknown calls
+%% yield exactly one value. This might have to be changed.)
+
+primop_call(F, A, Xs, _As, St0) ->
+ %% St1 = case is_escape_op(F, A) of
+ %% [] -> St0;
+ %% Ns -> escape(Xs, Ns, St0)
+ %% end,
+ St1 = St0,
+ case is_imm_op(F, A) of
+ true ->
+ {[empty()], St1};
+ false ->
+ call_unknown(Xs, St1)
+ end.
+
+%% Handle remote-calls: (At present, we assume that all unknown calls
+%% yield exactly one value. This might have to be changed.)
+
+remote_call(M, F, Xs, As, L, St) ->
+ case is_c_atom(M) andalso is_c_atom(F) of
+ true ->
+ remote_call_1(atom_val(M), atom_val(F), length(Xs),
+ Xs, As, L, St);
+ false ->
+ %% Unknown function
+ call_unknown(Xs, St)
+ end.
+
+%% When calling an unknown function, we assume that the result does
+%% *not* contain any of the constructors in its arguments (but it could
+%% return locally allocated data that we don't know about). Note that
+%% even a "pure" function can still cons up new data.
+
+call_unknown(_Xs, St) ->
+ {[unsafe()], St}.
+
+%% We need to handle some important standard functions in order to get
+%% decent precision.
+%% TODO: foldl, map, mapfoldl
+
+remote_call_1(erlang, hd, 1, [X], _As, _L, St) ->
+ {[get_hd(X)], St};
+remote_call_1(erlang, tl, 1, [X], _As, _L, St) ->
+ {[get_tl(X)], St};
+remote_call_1(erlang, element, 2, [_,X], [N|_], _L, St) ->
+ case elements(X) of
+ none -> {[X], St};
+ Xs ->
+ case is_c_int(N) of
+ true ->
+ N1 = int_val(N),
+ if is_integer(N1), 1 =< N1, N1 =< length(Xs) ->
+ {[nth(N1, Xs)], St};
+ true ->
+ {none, St}
+ end;
+ false ->
+ %% Even if we don't know which element is selected,
+ %% we know that the top level is never part of the
+ %% returned value.
+ {[join_single_list(Xs)], St}
+ end
+ end;
+remote_call_1(erlang, setelement, 3, [_,X, Y], [N|_], L, St) ->
+ %% The constructor gets the label of the call operation.
+ case elements(X) of
+ none -> {[join_single(singleton(L), join_single(X, Y))], St};
+ Xs ->
+ case is_c_int(N) of
+ true ->
+ N1 = int_val(N),
+ if is_integer(N1), 1 =< N1, N1 =< length(Xs) ->
+ Xs1 = set_nth(N1, Y, Xs),
+ {[struct(L, Xs1)], St};
+ true ->
+ {none, St}
+ end;
+ false ->
+ %% Even if we don't know which element is selected,
+ %% we know that the top level is never part of the
+ %% returned value (a new tuple is always created).
+ Xs1 = [join_single(Y, X1) || X1 <- Xs],
+ {[struct(L, Xs1)], St}
+ end
+ end;
+remote_call_1(erlang, '++', 2, [X1,X2], _As, _L, St) ->
+ %% Note: this is unsafe for non-proper lists! (See make_cons/3).
+ %% No safe version is implemented.
+ {[join_single(X1, X2)], St};
+remote_call_1(erlang, '--', 2, [X1,_X2], _As, _L, St) ->
+ {[X1], St};
+remote_call_1(lists, append, 2, Xs, As, L, St) ->
+ remote_call_1(erlang, '++', 2, Xs, As, L, St);
+remote_call_1(lists, subtract, 2, Xs, As, L, St) ->
+ remote_call_1(erlang, '--', 2, Xs, As, L, St);
+remote_call_1(M, F, A, Xs, _As, _L, St0) ->
+ St1 = case is_escape_op(M, F, A) of
+ [] -> St0;
+ Ns -> escape(Xs, Ns, St0)
+ end,
+ case is_imm_op(M, F, A) of
+ true ->
+ {[empty()], St1};
+ false ->
+ call_unknown(Xs, St1)
+ end.
+
+%% 1-based n:th-element list selector and update function.
+
+nth(1, [X | _Xs]) -> X;
+nth(N, [_X | Xs]) when N > 1 -> nth(N - 1, Xs).
+
+set_nth(1, Y, [_X | Xs]) -> [Y | Xs];
+set_nth(N, Y, [X | Xs]) when N > 1 -> [X | set_nth(N - 1, Y, Xs)].
+
+%% Domain: none | [V], where V = {S, none} | {S, [V]}, S = set(integer()).
+
+join(none, Xs2) -> Xs2;
+join(Xs1, none) -> Xs1;
+join(Xs1, Xs2) ->
+ if length(Xs1) =:= length(Xs2) ->
+ join_1(Xs1, Xs2);
+ true ->
+ none
+ end.
+
+join_1([X1 | Xs1], [X2 | Xs2]) ->
+ [join_single(X1, X2) | join_1(Xs1, Xs2)];
+join_1([], []) ->
+ [].
+
+join_list([Xs | Xss]) ->
+ join(Xs, join_list(Xss));
+join_list([]) ->
+ none.
+
+empty() -> {set__new(), []}.
+
+singleton(X) -> {set__singleton(X), []}.
+
+struct(X, Xs) -> {set__singleton(X), Xs}.
+
+elements({_, Xs}) -> Xs.
+
+unsafe() -> {set__singleton(unsafe), none}.
+
+equal(none, none) -> true;
+equal(none, _) -> false;
+equal(_, none) -> false;
+equal(X1, X2) -> equal_1(X1, X2).
+
+equal_1([X1 | Xs1], [X2 | Xs2]) ->
+ equal_single(X1, X2) andalso equal_1(Xs1, Xs2);
+equal_1([], []) -> true;
+equal_1(_, _) -> false.
+
+equal_single({S1, none}, {S2, none}) ->
+ set__equal(S1, S2);
+equal_single({_, none}, _) ->
+ false;
+equal_single(_, {_, none}) ->
+ false;
+equal_single({S1, Vs1}, {S2, Vs2}) ->
+ set__equal(S1, S2) andalso equal_single_lists(Vs1, Vs2).
+
+equal_single_lists([X1 | Xs1], [X2 | Xs2]) ->
+ equal_single(X1, X2) andalso equal_single_lists(Xs1, Xs2);
+equal_single_lists([], []) ->
+ true;
+equal_single_lists(_, _) ->
+ false.
+
+join_single({S, none}, V) ->
+ {set__union(S, labels(V)), none};
+join_single(V, {S, none}) ->
+ {set__union(S, labels(V)), none};
+join_single({S1, Vs1}, {S2, Vs2}) ->
+ {set__union(S1, S2), join_single_lists(Vs1, Vs2)}.
+
+join_single_list([V | Vs]) ->
+ join_single(V, join_single_list(Vs));
+join_single_list([]) ->
+ empty().
+
+%% If one list has more elements that the other, and N is the length of
+%% the longer list, then the result has N elements.
+
+join_single_lists([V1], [V2]) ->
+ [join_single(V1, V2)];
+join_single_lists([V1 | Vs1], [V2 | Vs2]) ->
+ [join_single(V1, V2) | join_single_lists(Vs1, Vs2)];
+join_single_lists([], Vs) -> Vs;
+join_single_lists(Vs, []) -> Vs.
+
+collapse(V) ->
+ {labels(V), none}.
+
+%% collapse_list([]) ->
+%% empty();
+%% collapse_list(Vs) ->
+%% {labels_list(Vs), none}.
+
+labels({S, none}) -> S;
+labels({S, []}) -> S;
+labels({S, Vs}) -> set__union(S, labels_list(Vs)).
+
+labels_list([V]) ->
+ labels(V);
+labels_list([V | Vs]) ->
+ set__union(labels(V), labels_list(Vs)).
+
+limit(none, _K) -> none;
+limit(X, K) -> limit_list(X, K).
+
+limit_list([X | Xs], K) ->
+ [limit_single(X, K) | limit_list(Xs, K)];
+limit_list([], _) ->
+ [].
+
+limit_single({_, none} = V, _K) ->
+ V;
+limit_single({_, []} = V, _K) ->
+ V;
+limit_single({S, Vs}, K) when K > 0 ->
+ {S, limit_list(Vs, K - 1)};
+limit_single(V, _K) ->
+ collapse(V).
+
+%% Set abstraction for label sets in the domain.
+
+%% set__is_empty([]) -> true;
+%% set__is_empty(_) -> false.
+
+set__new() -> [].
+
+set__singleton(X) -> [X].
+
+set__to_list(S) -> S.
+
+%% set__from_list(S) -> ordsets:from_list(S).
+
+set__union(X, Y) -> ordsets:union(X, Y).
+
+set__add(X, S) -> ordsets:add_element(X, S).
+
+set__is_member(X, S) -> ordsets:is_element(X, S).
+
+%% set__subtract(X, Y) -> ordsets:subtract(X, Y).
+
+set__equal(X, Y) -> X =:= Y.
+
+%% A simple but efficient functional queue.
+
+queue__new() -> {[], []}.
+
+queue__put(X, {In, Out}) -> {[X | In], Out}.
+
+queue__get({In, [X | Out]}) -> {ok, X, {In, Out}};
+queue__get({[], _}) -> empty;
+queue__get({In, _}) ->
+ [X | In1] = lists:reverse(In),
+ {ok, X, {[], In1}}.
+
+%% The work list - a queue without repeated elements.
+
+init_work() ->
+ {queue__new(), sets:new()}.
+
+add_work(Ls, {Q, Set}) ->
+ add_work(Ls, Q, Set).
+
+%% Note that the elements are enqueued in order.
+
+add_work([L | Ls], Q, Set) ->
+ case sets:is_element(L, Set) of
+ true ->
+ add_work(Ls, Q, Set);
+ false ->
+ add_work(Ls, queue__put(L, Q), sets:add_element(L, Set))
+ end;
+add_work([], Q, Set) ->
+ {Q, Set}.
+
+take_work({Queue0, Set0}) ->
+ case queue__get(Queue0) of
+ {ok, L, Queue1} ->
+ Set1 = sets:del_element(L, Set0),
+ {ok, L, {Queue1, Set1}};
+ empty ->
+ none
+ end.
+
+get_deps(L, Dep) ->
+ case dict:find(L, Dep) of
+ {ok, Ls} -> Ls;
+ error -> []
+ end.
+
+%% Escape operators may let their arguments escape. For this analysis,
+%% only send-operations are considered as causing escapement, and only
+%% in specific arguments.
+
+%% is_escape_op(_F, _A) -> [].
+
+-spec is_escape_op(module(), atom(), arity()) -> [arity()].
+
+is_escape_op(erlang, '!', 2) -> [2];
+is_escape_op(erlang, send, 2) -> [2];
+is_escape_op(erlang, spawn, 1) -> [1];
+is_escape_op(erlang, spawn, 3) -> [3];
+is_escape_op(erlang, spawn, 4) -> [4];
+is_escape_op(erlang, spawn_link, 3) -> [3];
+is_escape_op(erlang, spawn_link, 4) -> [4];
+is_escape_op(_M, _F, _A) -> [].
+
+%% "Immediate" operators will never return heap allocated data. This is
+%% of course true for operators that never return, like 'exit/1'. (Note
+%% that floats are always heap allocated objects, and that most integer
+%% arithmetic can return a bignum on the heap.)
+
+-spec is_imm_op(atom(), arity()) -> boolean().
+
+is_imm_op(match_fail, 1) -> true;
+is_imm_op(_, _) -> false.
+
+-spec is_imm_op(module(), atom(), arity()) -> boolean().
+
+is_imm_op(erlang, self, 0) -> true;
+is_imm_op(erlang, '=:=', 2) -> true;
+is_imm_op(erlang, '==', 2) -> true;
+is_imm_op(erlang, '=/=', 2) -> true;
+is_imm_op(erlang, '/=', 2) -> true;
+is_imm_op(erlang, '<', 2) -> true;
+is_imm_op(erlang, '=<', 2) -> true;
+is_imm_op(erlang, '>', 2) -> true;
+is_imm_op(erlang, '>=', 2) -> true;
+is_imm_op(erlang, 'and', 2) -> true;
+is_imm_op(erlang, 'or', 2) -> true;
+is_imm_op(erlang, 'xor', 2) -> true;
+is_imm_op(erlang, 'not', 1) -> true;
+is_imm_op(erlang, is_alive, 0) -> true;
+is_imm_op(erlang, is_atom, 1) -> true;
+is_imm_op(erlang, is_binary, 1) -> true;
+is_imm_op(erlang, is_builtin, 3) -> true;
+is_imm_op(erlang, is_constant, 1) -> true;
+is_imm_op(erlang, is_float, 1) -> true;
+is_imm_op(erlang, is_function, 1) -> true;
+is_imm_op(erlang, is_integer, 1) -> true;
+is_imm_op(erlang, is_list, 1) -> true;
+is_imm_op(erlang, is_number, 1) -> true;
+is_imm_op(erlang, is_pid, 1) -> true;
+is_imm_op(erlang, is_port, 1) -> true;
+is_imm_op(erlang, is_process_alive, 1) -> true;
+is_imm_op(erlang, is_reference, 1) -> true;
+is_imm_op(erlang, is_tuple, 1) -> true;
+is_imm_op(erlang, length, 1) -> true; % never a bignum
+is_imm_op(erlang, list_to_atom, 1) -> true;
+is_imm_op(erlang, node, 0) -> true;
+is_imm_op(erlang, node, 1) -> true;
+is_imm_op(erlang, throw, 1) -> true;
+is_imm_op(erlang, exit, 1) -> true;
+is_imm_op(erlang, error, 1) -> true;
+is_imm_op(erlang, error, 2) -> true;
+is_imm_op(_, _, _) -> false.
diff --git a/lib/hipe/cerl/cerl_pmatch.erl b/lib/hipe/cerl/cerl_pmatch.erl
new file mode 100644
index 0000000000..3bc93e80dd
--- /dev/null
+++ b/lib/hipe/cerl/cerl_pmatch.erl
@@ -0,0 +1,624 @@
+%%
+%% %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 Core Erlang pattern matching compiler.
+%%
+%% <p>For reference, see Simon L. Peyton Jones "The Implementation of
+%% Functional Programming Languages", chapter 5 (by Phil Wadler).</p>
+%%
+%% @type cerl() = cerl:cerl().
+%% Abstract Core Erlang syntax trees.
+%% @type cerl_records() = cerl:cerl_records().
+%% An explicit record representation of Core Erlang syntax trees.
+
+-module(cerl_pmatch).
+
+-define(NO_UNUSED, true).
+
+-export([clauses/2]).
+-ifndef(NO_UNUSED).
+-export([transform/2, core_transform/2, expr/2]).
+-endif.
+
+-import(lists, [all/2, splitwith/2, foldr/3, keysort/2, foldl/3,
+ mapfoldl/3]).
+
+-define(binary_id, {binary}).
+-define(cons_id, {cons}).
+-define(tuple_id, {tuple}).
+-define(literal_id(V), V).
+
+
+%% @spec core_transform(Module::cerl_records(), Options::[term()]) ->
+%% cerl_records()
+%%
+%% @doc Transforms a module represented by records. See
+%% <code>transform/2</code> for details.
+%%
+%% <p>Use the compiler option <code>{core_transform, cerl_pmatch}</code>
+%% to insert this function as a compilation pass.</p>
+%%
+%% @see transform/2
+
+-ifndef(NO_UNUSED).
+core_transform(M, Opts) ->
+ cerl:to_records(transform(cerl:from_records(M), Opts)).
+-endif. % NO_UNUSED
+%% @clear
+
+
+%% @spec transform(Module::cerl(), Options::[term()]) -> cerl()
+%%
+%% @doc Rewrites all <code>case</code>-clauses in <code>Module</code>.
+%% <code>receive</code>-clauses are not affected. Currently, no options
+%% are available.
+%%
+%% @see clauses/2
+%% @see expr/2
+%% @see core_transform/2
+
+-ifndef(NO_UNUSED).
+transform(M, _Opts) ->
+ expr(M, env__empty()).
+-endif. % NO_UNUSED
+%% @clear
+
+
+%% @spec clauses(Clauses::[Clause], Env) -> {Expr, Vars}
+%% Clause = cerl()
+%% Expr = cerl()
+%% Vars = [cerl()]
+%% Env = rec_env:environment()
+%%
+%% @doc Rewrites a sequence of clauses to an equivalent expression,
+%% removing as much repeated testing as possible. Returns a pair
+%% <code>{Expr, Vars}</code>, where <code>Expr</code> is the resulting
+%% expression, and <code>Vars</code> is a list of new variables (i.e.,
+%% not already in the given environment) to be bound to the arguments to
+%% the switch. The following is a typical example (assuming
+%% <code>E</code> is a Core Erlang case expression):
+%% <pre>
+%% handle_case(E, Env) ->
+%% Cs = case_clauses(E),
+%% {E1, Vs} = cerl_pmatch(Cs, Env),
+%% c_let(Vs, case_arg(E), E1).
+%% </pre>
+%%
+%% <p>The environment is used for generating new variables which do not
+%% shadow existing bindings.</p>
+%%
+%% @see rec_env
+%% @see expr/2
+%% @see transform/2
+
+-spec clauses([cerl:cerl()], rec_env:environment()) ->
+ {cerl:cerl(), [cerl:cerl()]}.
+
+clauses(Cs, Env) ->
+ clauses(Cs, none, Env).
+
+clauses([C | _] = Cs, Else, Env) ->
+ Vs = new_vars(cerl:clause_arity(C), Env),
+ E = match(Vs, Cs, Else, add_vars(Vs, Env)),
+ {E, Vs}.
+
+%% The implementation very closely follows that described in the book.
+
+match([], Cs, Else, _Env) ->
+ %% If the "default action" is the atom 'none', it is simply not
+ %% added; otherwise it is put in the body of a final catch-all
+ %% clause (which is often removed by the below optimization).
+ Cs1 = if Else =:= none -> Cs;
+ true -> Cs ++ [cerl:c_clause([], Else)]
+ end,
+ %% This clause reduction is an important optimization. It selects a
+ %% clause body if possible, and otherwise just removes dead clauses.
+ case cerl_clauses:reduce(Cs1) of
+ {true, {C, []}} -> % if we get bindings, something is wrong!
+ cerl:clause_body(C);
+ {false, Cs2} ->
+ %% This happens when guards are nontrivial.
+ cerl:c_case(cerl:c_values([]), Cs2)
+ end;
+match([V | _] = Vs, Cs, Else, Env) ->
+ foldr(fun (CsF, ElseF) ->
+ match_var_con(Vs, CsF, ElseF, Env)
+ end,
+ Else,
+ group([unalias(C, V) || C <- Cs], fun is_var_clause/1)).
+
+group([], _F) ->
+ [];
+group([X | _] = Xs, F) ->
+ group(Xs, F, F(X)).
+
+group(Xs, F, P) ->
+ {First, Rest} = splitwith(fun (X) -> F(X) =:= P end, Xs),
+ [First | group(Rest, F)].
+
+is_var_clause(C) ->
+ cerl:is_c_var(hd(cerl:clause_pats(C))).
+
+%% To avoid code duplication, if the 'Else' expression is too big, we
+%% put it in a local function definition instead, and replace it with a
+%% call. (Note that it is important that 'is_lightweight' does not yield
+%% 'true' for a simple function application, or we will create a lot of
+%% unnecessary extra functions.)
+
+match_var_con(Vs, Cs, none = Else, Env) ->
+ match_var_con_1(Vs, Cs, Else, Env);
+match_var_con(Vs, Cs, Else, Env) ->
+ case is_lightweight(Else) of
+ true ->
+ match_var_con_1(Vs, Cs, Else, Env);
+ false ->
+ F = new_fvar("match_", 0, Env),
+ Else1 = cerl:c_apply(F, []),
+ Env1 = add_vars([F], Env),
+ cerl:c_letrec([{F, cerl:c_fun([], Else)}],
+ match_var_con_1(Vs, Cs, Else1, Env1))
+ end.
+
+match_var_con_1(Vs, Cs, Else, Env) ->
+ case is_var_clause(hd(Cs)) of
+ true ->
+ match_var(Vs, Cs, Else, Env);
+ false ->
+ match_con(Vs, Cs, Else, Env)
+ end.
+
+match_var([V | Vs], Cs, Else, Env) ->
+ Cs1 = [begin
+ [P | Ps] = cerl:clause_pats(C),
+ G = make_let([P], V, cerl:clause_guard(C)),
+ B = make_let([P], V, cerl:clause_body(C)),
+ cerl:update_c_clause(C, Ps, G, B)
+ end
+ || C <- Cs],
+ match(Vs, Cs1, Else, Env).
+
+%% Since Erlang is dynamically typed, we must include the possibility
+%% that none of the constructors in the group will match, and in that
+%% case the "Else" code will be executed (unless it is 'none'), in the
+%% body of a final catch-all clause.
+
+match_con([V | Vs], Cs, Else, Env) ->
+ case group_con(Cs) of
+ [{_, _, Gs}] ->
+ %% Don't create a group type switch if there is only one
+ %% such group
+ make_switch(V, [match_congroup(DG, Vs, CsG, Else, Env)
+ || {DG, _, CsG} <- Gs],
+ Else, Env);
+ Ts ->
+ Cs1 = [match_typegroup(T, V, Vs, Gs, Else, Env)
+ || {T, _, Gs} <- Ts],
+ make_switch(V, Cs1, Else, Env)
+ end.
+
+
+match_typegroup(_T, _V, Vs, [{D, _, Cs}], Else, Env) when element(1, D) /= ?binary_id ->
+ %% Don't create a group type switch if there is only one constructor
+ %% in the group. (Note that this always happens for '[]'.)
+ %% Special case for binaries which always get a group switch
+ match_congroup(D, Vs, Cs, Else, Env);
+match_typegroup(T, V, Vs, Gs, Else, Env) ->
+ Body = make_switch(V, [match_congroup(D, Vs, Cs, Else, Env)
+ || {D, _, Cs} <- Gs],
+ Else, Env),
+ typetest_clause(T, V, Body, Env).
+
+match_congroup({?binary_id, Segs}, Vs, Cs, _Else, Env) ->
+ Ref = get_unique(),
+ Guard = cerl:c_primop(cerl:c_atom(set_label), [cerl:c_int(Ref)]),
+ NewElse = cerl:c_primop(cerl:c_atom(goto_label), [cerl:c_int(Ref)]),
+ Body = match(Vs, Cs, NewElse, Env),
+ cerl:c_clause([make_pat(?binary_id, Segs)], Guard, Body);
+
+match_congroup({D, A}, Vs, Cs, Else, Env) ->
+ Vs1 = new_vars(A, Env),
+ Body = match(Vs1 ++ Vs, Cs, Else, add_vars(Vs1, Env)),
+ cerl:c_clause([make_pat(D, Vs1)], Body).
+
+make_switch(V, Cs, Else, Env) ->
+ cerl:c_case(V, if Else =:= none -> Cs;
+ true -> Cs ++ [cerl:c_clause([new_var(Env)],
+ Else)]
+ end).
+
+%% We preserve the relative order of different-type constructors as they
+%% were originally listed. This is done by tracking the clause numbers.
+
+group_con(Cs) ->
+ {Cs1, _} = mapfoldl(fun (C, N) ->
+ [P | Ps] = cerl:clause_pats(C),
+ Ps1 = sub_pats(P) ++ Ps,
+ G = cerl:clause_guard(C),
+ B = cerl:clause_body(C),
+ C1 = cerl:update_c_clause(C, Ps1, G, B),
+ D = con_desc(P),
+ {{D, N, C1}, N + 1}
+ end,
+ 0, Cs),
+ %% Sort and group constructors.
+ Css = group(keysort(1, Cs1), fun ({D,_,_}) -> D end),
+ %% Sort each group "back" by line number, and move the descriptor
+ %% and line number to the wrapper for the group.
+ Gs = [finalize_congroup(C) || C <- Css],
+ %% Group by type only (put e.g. different-arity tuples together).
+ Gss = group(Gs, fun ({D,_,_}) -> con_desc_type(D) end),
+ %% Sort and wrap the type groups.
+ Ts = [finalize_typegroup(G) || G <- Gss],
+ %% Sort type-groups by first clause order
+ keysort(2, Ts).
+
+finalize_congroup(Cs) ->
+ [{D,N,_}|_] = Cs1 = keysort(2, Cs),
+ {D, N, [C || {_,_,C} <- Cs1]}.
+
+finalize_typegroup(Gs) ->
+ [{D,N,_}|_] = Gs1 = keysort(2, Gs),
+ {con_desc_type(D), N, Gs1}.
+
+%% Since Erlang clause patterns can contain "alias patterns", we must
+%% eliminate these, by turning them into let-definitions in the guards
+%% and bodies of the clauses.
+
+unalias(C, V) ->
+ [P | Ps] = cerl:clause_pats(C),
+ B = cerl:clause_body(C),
+ G = cerl:clause_guard(C),
+ unalias(P, V, Ps, B, G, C).
+
+unalias(P, V, Ps, B, G, C) ->
+ case cerl:type(P) of
+ alias ->
+ V1 = cerl:alias_var(P),
+ B1 = make_let([V1], V, B),
+ G1 = make_let([V1], V, G),
+ unalias(cerl:alias_pat(P), V, Ps, B1, G1, C);
+ _ ->
+ cerl:update_c_clause(C, [P | Ps], G, B)
+ end.
+
+%% Generating a type-switch clause
+
+typetest_clause([], _V, E, _Env) ->
+ cerl:c_clause([cerl:c_nil()], E);
+typetest_clause(atom, V, E, _Env) ->
+ typetest_clause_1(is_atom, V, E);
+typetest_clause(integer, V, E, _Env) ->
+ typetest_clause_1(is_integer, V, E);
+typetest_clause(float, V, E, _Env) ->
+ typetest_clause_1(is_float, V, E);
+typetest_clause(cons, _V, E, Env) ->
+ [V1, V2] = new_vars(2, Env),
+ cerl:c_clause([cerl:c_cons(V1, V2)], E); % there is no 'is cons'
+typetest_clause(tuple, V, E, _Env) ->
+ typetest_clause_1(is_tuple, V, E);
+typetest_clause(binary, V, E, _Env) ->
+ typetest_clause_1(is_binary, V, E).
+
+typetest_clause_1(T, V, E) ->
+ cerl:c_clause([V], cerl:c_call(cerl:c_atom('erlang'),
+ cerl:c_atom(T), [V]), E).
+
+%% This returns a constructor descriptor, to be used for grouping and
+%% pattern generation. It consists of an identifier term and the arity.
+
+con_desc(E) ->
+ case cerl:type(E) of
+ cons -> {?cons_id, 2};
+ tuple -> {?tuple_id, cerl:tuple_arity(E)};
+ binary -> {?binary_id, cerl:binary_segments(E)};
+ literal ->
+ case cerl:concrete(E) of
+ [_|_] -> {?cons_id, 2};
+ T when is_tuple(T) -> {?tuple_id, tuple_size(T)};
+ V -> {?literal_id(V), 0}
+ end;
+ _ ->
+ throw({bad_constructor, E})
+ end.
+
+%% This returns the type class for a constructor descriptor, for
+%% grouping of clauses. It does not distinguish between tuples of
+%% different arity, nor between different values of atoms, integers and
+%% floats.
+
+con_desc_type({?literal_id([]), _}) -> [];
+con_desc_type({?literal_id(V), _}) when is_atom(V) -> atom;
+con_desc_type({?literal_id(V), _}) when is_integer(V) -> integer;
+con_desc_type({?literal_id(V), _}) when is_float(V) -> float;
+con_desc_type({?cons_id, 2}) -> cons;
+con_desc_type({?tuple_id, _}) -> tuple;
+con_desc_type({?binary_id, _}) -> binary.
+
+%% This creates a new constructor pattern from a type descriptor and a
+%% list of variables.
+
+make_pat(?cons_id, [V1, V2]) -> cerl:c_cons(V1, V2);
+make_pat(?tuple_id, Vs) -> cerl:c_tuple(Vs);
+make_pat(?binary_id, Segs) -> cerl:c_binary(Segs);
+make_pat(?literal_id(Val), []) -> cerl:abstract(Val).
+
+%% This returns the list of subpatterns of a constructor pattern.
+
+sub_pats(E) ->
+ case cerl:type(E) of
+ cons ->
+ [cerl:cons_hd(E), cerl:cons_tl(E)];
+ tuple ->
+ cerl:tuple_es(E);
+ binary ->
+ [];
+ literal ->
+ case cerl:concrete(E) of
+ [H|T] -> [cerl:abstract(H), cerl:abstract(T)];
+ T when is_tuple(T) -> [cerl:abstract(X)
+ || X <- tuple_to_list(T)];
+ _ -> []
+ end;
+ _ ->
+ throw({bad_constructor_pattern, E})
+ end.
+
+%% This avoids generating stupid things like "let X = ... in 'true'",
+%% and "let X = Y in X", keeping the generated code cleaner. It also
+%% prevents expressions from being considered "non-lightweight" when
+%% code duplication is disallowed (see is_lightweight for details).
+
+make_let(Vs, A, B) ->
+ cerl_lib:reduce_expr(cerl:c_let(Vs, A, B)).
+
+%% ---------------------------------------------------------------------
+%% Rewriting a module or other expression:
+
+%% @spec expr(Expression::cerl(), Env) -> cerl()
+%% Env = rec_env:environment()
+%%
+%% @doc Rewrites all <code>case</code>-clauses in
+%% <code>Expression</code>. <code>receive</code>-clauses are not
+%% affected.
+%%
+%% <p>The environment is used for generating new variables which do not
+%% shadow existing bindings.</p>
+%%
+%% @see clauses/2
+%% @see rec_env
+
+-ifndef(NO_UNUSED).
+expr(E, Env) ->
+ case cerl:type(E) of
+ literal ->
+ E;
+ var ->
+ E;
+ values ->
+ Es = expr_list(cerl:values_es(E), Env),
+ cerl:update_c_values(E, Es);
+ cons ->
+ H = expr(cerl:cons_hd(E), Env),
+ T = expr(cerl:cons_tl(E), Env),
+ cerl:update_c_cons(E, H, T);
+ tuple ->
+ Es = expr_list(cerl:tuple_es(E), Env),
+ cerl:update_c_tuple(E, Es);
+ 'let' ->
+ A = expr(cerl:let_arg(E), Env),
+ Vs = cerl:let_vars(E),
+ Env1 = add_vars(Vs, Env),
+ B = expr(cerl:let_body(E), Env1),
+ cerl:update_c_let(E, Vs, A, B);
+ seq ->
+ A = expr(cerl:seq_arg(E), Env),
+ B = expr(cerl:seq_body(E), Env),
+ cerl:update_c_seq(E, A, B);
+ apply ->
+ Op = expr(cerl:apply_op(E), Env),
+ As = expr_list(cerl:apply_args(E), Env),
+ cerl:update_c_apply(E, Op, As);
+ call ->
+ M = expr(cerl:call_module(E), Env),
+ N = expr(cerl:call_name(E), Env),
+ As = expr_list(cerl:call_args(E), Env),
+ cerl:update_c_call(E, M, N, As);
+ primop ->
+ As = expr_list(cerl:primop_args(E), Env),
+ cerl:update_c_primop(E, cerl:primop_name(E), As);
+ 'case' ->
+ A = expr(cerl:case_arg(E), Env),
+ Cs = expr_list(cerl:case_clauses(E), Env),
+ {E1, Vs} = clauses(Cs, Env),
+ make_let(Vs, A, E1);
+ clause ->
+ Vs = cerl:clause_vars(E),
+ Env1 = add_vars(Vs, Env),
+ G = expr(cerl:clause_guard(E), Env1),
+ B = expr(cerl:clause_body(E), Env1),
+ cerl:update_c_clause(E, cerl:clause_pats(E), G, B);
+ 'fun' ->
+ Vs = cerl:fun_vars(E),
+ Env1 = add_vars(Vs, Env),
+ B = expr(cerl:fun_body(E), Env1),
+ cerl:update_c_fun(E, Vs, B);
+ 'receive' ->
+ %% NOTE: No pattern matching compilation is done here! The
+ %% receive-clauses and patterns cannot be staged as long as
+ %% we are working with "normal" Core Erlang.
+ Cs = expr_list(cerl:receive_clauses(E), Env),
+ T = expr(cerl:receive_timeout(E), Env),
+ A = expr(cerl:receive_action(E), Env),
+ cerl:update_c_receive(E, Cs, T, A);
+ 'try' ->
+ A = expr(cerl:try_arg(E), Env),
+ Vs = cerl:try_vars(E),
+ B = expr(cerl:try_body(E), add_vars(Vs, Env)),
+ Evs = cerl:try_evars(E),
+ H = expr(cerl:try_handler(E), add_vars(Evs, Env)),
+ cerl:update_c_try(E, A, Vs, B, Evs, H);
+ 'catch' ->
+ B = expr(cerl:catch_body(E), Env),
+ cerl:update_c_catch(E, B);
+ letrec ->
+ Ds = cerl:letrec_defs(E),
+ Env1 = add_defs(Ds, Env),
+ Ds1 = defs(Ds, Env1),
+ B = expr(cerl:letrec_body(E), Env1),
+ cerl:update_c_letrec(E, Ds1, B);
+ module ->
+ Ds = cerl:module_defs(E),
+ Env1 = add_defs(Ds, Env),
+ Ds1 = defs(Ds, Env1),
+ cerl:update_c_module(E, cerl:module_name(E),
+ cerl:module_exports(E),
+ cerl:module_attrs(E), Ds1)
+ end.
+
+expr_list(Es, Env) ->
+ [expr(E, Env) || E <- Es].
+
+defs(Ds, Env) ->
+ [{V, expr(F, Env)} || {V, F} <- Ds].
+-endif. % NO_UNUSED
+%% @clear
+
+%% ---------------------------------------------------------------------
+%% Support functions
+
+new_var(Env) ->
+ Name = env__new_vname(Env),
+ cerl:c_var(Name).
+
+new_vars(N, Env) ->
+ [cerl:c_var(V) || V <- env__new_vnames(N, Env)].
+
+new_fvar(A, N, Env) ->
+ Name = env__new_fname(A, N, Env),
+ cerl:c_var(Name).
+
+add_vars(Vs, Env) ->
+ foldl(fun (V, E) -> env__bind(cerl:var_name(V), [], E) end, Env, Vs).
+
+-ifndef(NO_UNUSED).
+add_defs(Ds, Env) ->
+ foldl(fun ({V, _F}, E) ->
+ env__bind(cerl:var_name(V), [], E)
+ end, Env, Ds).
+-endif. % NO_UNUSED
+
+%% This decides whether an expression is worth lifting out to a separate
+%% function instead of duplicating the code. In other words, whether its
+%% cost is about the same or smaller than that of a local function call.
+%% Note that variables must always be "lightweight"; otherwise, they may
+%% get lifted out of the case switch that introduces them.
+
+is_lightweight(E) ->
+ case get('cerl_pmatch_duplicate_code') of
+ never -> cerl:type(E) =:= var; % Avoids all code duplication
+ always -> true; % Does not lift code to new functions
+ _ -> is_lightweight_1(E)
+ end.
+
+is_lightweight_1(E) ->
+ case cerl:type(E) of
+ var -> true;
+ literal -> true;
+ 'fun' -> true;
+ values -> all(fun is_simple/1, cerl:values_es(E));
+ cons -> is_simple(cerl:cons_hd(E))
+ andalso is_simple(cerl:cons_tl(E));
+ tuple -> all(fun is_simple/1, cerl:tuple_es(E));
+ 'let' -> (is_simple(cerl:let_arg(E)) andalso
+ is_lightweight_1(cerl:let_body(E)));
+ seq -> (is_simple(cerl:seq_arg(E)) andalso
+ is_lightweight_1(cerl:seq_body(E)));
+ primop ->
+ all(fun is_simple/1, cerl:primop_args(E));
+ apply ->
+ is_simple(cerl:apply_op(E))
+ andalso all(fun is_simple/1, cerl:apply_args(E));
+ call ->
+ is_simple(cerl:call_module(E))
+ andalso is_simple(cerl:call_name(E))
+ andalso all(fun is_simple/1, cerl:call_args(E));
+ _ ->
+ %% The default is to lift the code to a new function.
+ false
+ end.
+
+%% "Simple" things have no (or negligible) runtime cost and are free
+%% from side effects.
+
+is_simple(E) ->
+ case cerl:type(E) of
+ var -> true;
+ literal -> true;
+ values -> all(fun is_simple/1, cerl:values_es(E));
+ _ -> false
+ end.
+
+
+get_unique() ->
+ case get(unique_label) of
+ undefined ->
+ put(unique_label, 1),
+ 0;
+ N ->
+ put(unique_label, N+1),
+ N
+ end.
+
+%% ---------------------------------------------------------------------
+%% Abstract datatype: environment()
+
+env__bind(Key, Val, Env) ->
+ rec_env:bind(Key, Val, Env).
+
+-ifndef(NO_UNUSED).
+%% env__bind_recursive(Ks, Vs, F, Env) ->
+%% rec_env:bind_recursive(Ks, Vs, F, Env).
+
+%% env__lookup(Key, Env) ->
+%% rec_env:lookup(Key, Env).
+
+%% env__get(Key, Env) ->
+%% rec_env:get(Key, Env).
+
+%% env__is_defined(Key, Env) ->
+%% rec_env:is_defined(Key, Env).
+
+env__empty() ->
+ rec_env:empty().
+-endif. % NO_UNUSED
+
+env__new_vname(Env) ->
+ rec_env:new_key(Env).
+
+env__new_vnames(N, Env) ->
+ rec_env:new_keys(N, Env).
+
+env__new_fname(F, A, Env) ->
+ rec_env:new_key(fun (X) ->
+ S = integer_to_list(X),
+ {list_to_atom(F ++ S), A}
+ end,
+ Env).
diff --git a/lib/hipe/cerl/cerl_prettypr.erl b/lib/hipe/cerl/cerl_prettypr.erl
new file mode 100644
index 0000000000..fba9a48cda
--- /dev/null
+++ b/lib/hipe/cerl/cerl_prettypr.erl
@@ -0,0 +1,883 @@
+%% =====================================================================
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2004-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+%%
+%% Core Erlang prettyprinter, using the 'prettypr' module.
+%%
+%% Copyright (C) 1999-2002 Richard Carlsson
+%%
+%% Author contact: [email protected]
+%% =====================================================================
+%%
+%% @doc Core Erlang prettyprinter.
+%%
+%% <p>This module is a front end to the pretty-printing library module
+%% <code>prettypr</code>, for text formatting of Core Erlang abstract
+%% syntax trees defined by the module <code>cerl</code>.</p>
+
+%% TODO: add printing of comments for `comment'-annotations?
+
+-module(cerl_prettypr).
+
+-define(NO_UNUSED, true).
+
+-export([format/1, format/2, annotate/3]).
+-ifndef(NO_UNUSED).
+-export([best/1, best/2, layout/1, layout/2, get_ctxt_paperwidth/1,
+ set_ctxt_paperwidth/2, get_ctxt_linewidth/1,
+ set_ctxt_linewidth/2, get_ctxt_hook/1, set_ctxt_hook/2,
+ get_ctxt_user/1, set_ctxt_user/2]).
+-endif.
+
+-import(prettypr, [text/1, nest/2, above/2, beside/2, sep/1, par/1,
+ par/2, follow/3, follow/2, floating/1, empty/0]).
+
+-import(cerl, [abstract/1, alias_pat/1, alias_var/1, apply_args/1,
+ apply_op/1, atom_lit/1, binary_segments/1, bitstr_val/1,
+ bitstr_size/1, bitstr_unit/1, bitstr_type/1,
+ bitstr_flags/1, call_args/1, call_module/1, call_name/1,
+ case_arg/1, case_clauses/1, catch_body/1, c_atom/1,
+ c_binary/1, c_bitstr/5, c_int/1, clause_body/1,
+ clause_guard/1, clause_pats/1, concrete/1, cons_hd/1,
+ cons_tl/1, float_lit/1, fun_body/1, fun_vars/1,
+ get_ann/1, int_lit/1, is_c_cons/1, is_c_let/1,
+ is_c_nil/1, is_c_seq/1, is_print_string/1, let_arg/1,
+ let_body/1, let_vars/1, letrec_body/1, letrec_defs/1,
+ module_attrs/1, module_defs/1, module_exports/1,
+ module_name/1, primop_args/1, primop_name/1,
+ receive_action/1, receive_clauses/1, receive_timeout/1,
+ seq_arg/1, seq_body/1, string_lit/1, try_arg/1,
+ try_body/1, try_vars/1, try_evars/1, try_handler/1,
+ tuple_es/1, type/1, values_es/1, var_name/1]).
+
+-define(PAPER, 76).
+-define(RIBBON, 45).
+-define(NOUSER, undefined).
+-define(NOHOOK, none).
+
+-type hook() :: 'none' | fun((cerl:cerl(), _, _) -> prettypr:document()).
+
+-record(ctxt, {line = 0 :: integer(),
+ body_indent = 4 :: non_neg_integer(),
+ sub_indent = 2 :: non_neg_integer(),
+ hook = ?NOHOOK :: hook(),
+ noann = false :: boolean(),
+ paper = ?PAPER :: integer(),
+ ribbon = ?RIBBON :: integer(),
+ user = ?NOUSER :: term()}).
+-type context() :: #ctxt{}.
+
+%% =====================================================================
+%% The following functions examine and modify contexts:
+
+%% @spec (context()) -> integer()
+%% @doc Returns the paper widh field of the prettyprinter context.
+%% @see set_ctxt_paperwidth/2
+
+-ifndef(NO_UNUSED).
+get_ctxt_paperwidth(Ctxt) ->
+ Ctxt#ctxt.paper.
+-endif. % NO_UNUSED
+%% @clear
+
+%% @spec (context(), integer()) -> context()
+%%
+%% @doc Updates the paper widh field of the prettyprinter context.
+%%
+%% <p> Note: changing this value (and passing the resulting context to a
+%% continuation function) does not affect the normal formatting, but may
+%% affect user-defined behaviour in hook functions.</p>
+%%
+%% @see get_ctxt_paperwidth/1
+
+-ifndef(NO_UNUSED).
+set_ctxt_paperwidth(Ctxt, W) ->
+ Ctxt#ctxt{paper = W}.
+-endif. % NO_UNUSED
+%% @clear
+
+%% @spec (context()) -> integer()
+%% @doc Returns the line widh field of the prettyprinter context.
+%% @see set_ctxt_linewidth/2
+
+-ifndef(NO_UNUSED).
+get_ctxt_linewidth(Ctxt) ->
+ Ctxt#ctxt.ribbon.
+-endif. % NO_UNUSED
+%% @clear
+
+%% @spec (context(), integer()) -> context()
+%%
+%% @doc Updates the line widh field of the prettyprinter context.
+%%
+%% <p> Note: changing this value (and passing the resulting context to a
+%% continuation function) does not affect the normal formatting, but may
+%% affect user-defined behaviour in hook functions.</p>
+%%
+%% @see get_ctxt_linewidth/1
+
+-ifndef(NO_UNUSED).
+set_ctxt_linewidth(Ctxt, W) ->
+ Ctxt#ctxt{ribbon = W}.
+-endif. % NO_UNUSED
+%% @clear
+
+%% @spec (context()) -> hook()
+%% @doc Returns the hook function field of the prettyprinter context.
+%% @see set_ctxt_hook/2
+
+-ifndef(NO_UNUSED).
+get_ctxt_hook(Ctxt) ->
+ Ctxt#ctxt.hook.
+-endif. % NO_UNUSED
+%% @clear
+
+%% @spec (context(), hook()) -> context()
+%% @doc Updates the hook function field of the prettyprinter context.
+%% @see get_ctxt_hook/1
+
+-ifndef(NO_UNUSED).
+set_ctxt_hook(Ctxt, Hook) ->
+ Ctxt#ctxt{hook = Hook}.
+-endif. % NO_UNUSED
+%% @clear
+
+%% @spec (context()) -> term()
+%% @doc Returns the user data field of the prettyprinter context.
+%% @see set_ctxt_user/2
+
+-ifndef(NO_UNUSED).
+get_ctxt_user(Ctxt) ->
+ Ctxt#ctxt.user.
+-endif. % NO_UNUSED
+%% @clear
+
+%% @spec (context(), term()) -> context()
+%% @doc Updates the user data field of the prettyprinter context.
+%% @see get_ctxt_user/1
+
+-ifndef(NO_UNUSED).
+set_ctxt_user(Ctxt, X) ->
+ Ctxt#ctxt{user = X}.
+-endif. % NO_UNUSED
+%% @clear
+
+
+%% =====================================================================
+%% @spec format(Tree::cerl()) -> string()
+%% @equiv format(Tree, [])
+
+-spec format(cerl:cerl()) -> string().
+
+format(Node) ->
+ format(Node, []).
+
+
+%% =====================================================================
+%% @spec format(Tree::cerl(), Options::[term()]) -> string()
+%% cerl() = cerl:cerl()
+%%
+%% @type hook() = (cerl(), context(), Continuation) -> document()
+%% Continuation = (cerl(), context()) -> document().
+%%
+%% A call-back function for user-controlled formatting. See <a
+%% href="#format-2"><code>format/2</code></a>.
+%%
+%% @type context(). A representation of the current context of the
+%% pretty-printer. Can be accessed in hook functions.
+%%
+%% @doc Prettyprint-formats a Core Erlang syntax tree as text.
+%%
+%% <p>Available options:
+%% <dl>
+%% <dt>{hook, none | <a href="#type-hook">hook()</a>}</dt>
+%% <dd>Unless the value is <code>none</code>, the given function
+%% is called for every node; see below for details. The default
+%% value is <code>none</code>.</dd>
+%%
+%% <dt>{noann, boolean()}</dt>
+%% <dd>If the value is <code>true</code>, annotations on the code
+%% are not printed. The default value is <code>false</code>.</dd>
+%%
+%% <dt>{paper, integer()}</dt>
+%% <dd>Specifies the preferred maximum number of characters on any
+%% line, including indentation. The default value is 76.</dd>
+%%
+%% <dt>{ribbon, integer()}</dt>
+%% <dd>Specifies the preferred maximum number of characters on any
+%% line, not counting indentation. The default value is 45.</dd>
+%%
+%% <dt>{user, term()}</dt>
+%% <dd>User-specific data for use in hook functions. The default
+%% value is <code>undefined</code>.</dd>
+%% </dl></p>
+%%
+%% <p>A hook function (cf. the <a
+%% href="#type-hook"><code>hook()</code></a> type) is passed the current
+%% syntax tree node, the context, and a continuation. The context can be
+%% examined and manipulated by functions such as
+%% <code>get_ctxt_user/1</code> and <code>set_ctxt_user/2</code>. The
+%% hook must return a "document" data structure (see
+%% <code>layout/2</code> and <code>best/2</code>); this may be
+%% constructed in part or in whole by applying the continuation
+%% function. For example, the following is a trivial hook:
+%% <pre>
+%% fun (Node, Ctxt, Cont) -> Cont(Node, Ctxt) end
+%% </pre>
+%% which yields the same result as if no hook was given.
+%% The following, however:
+%% <pre>
+%% fun (Node, Ctxt, Cont) ->
+%% Doc = Cont(Node, Ctxt),
+%% prettypr:beside(prettypr:text("&lt;b>"),
+%% prettypr:beside(Doc,
+%% prettypr:text("&lt;/b>")))
+%% end
+%% </pre>
+%% will place the text of any annotated node (regardless of the
+%% annotation data) between HTML "boldface begin" and "boldface end"
+%% tags. The function <code>annotate/3</code> is exported for use in
+%% hook functions.</p>
+%%
+%% @see cerl
+%% @see format/1
+%% @see layout/2
+%% @see best/2
+%% @see annotate/3
+%% @see get_ctxt_user/1
+%% @see set_ctxt_user/2
+
+-spec format(cerl:cerl(), [term()]) -> string().
+
+format(Node, Options) ->
+ W = proplists:get_value(paper, Options, ?PAPER),
+ L = proplists:get_value(ribbon, Options, ?RIBBON),
+ prettypr:format(layout(Node, Options), W, L).
+
+
+%% =====================================================================
+%% @spec best(Tree::cerl()) -> empty | document()
+%% @equiv best(Node, [])
+
+-ifndef(NO_UNUSED).
+best(Node) ->
+ best(Node, []).
+-endif. % NO_UNUSED
+%% @clear
+
+
+%% =====================================================================
+%% @spec best(Tree::cerl(), Options::[term()]) ->
+%% empty | document()
+%%
+%% @doc Creates a fixed "best" abstract layout for a Core Erlang syntax
+%% tree. This is similar to the <code>layout/2</code> function, except
+%% that here, the final layout has been selected with respect to the
+%% given options. The atom <code>empty</code> is returned if no such
+%% layout could be produced. For information on the options, see the
+%% <code>format/2</code> function.
+%%
+%% @see best/1
+%% @see layout/2
+%% @see format/2
+%% @see prettypr:best/2
+
+-ifndef(NO_UNUSED).
+best(Node, Options) ->
+ W = proplists:get_value(paper, Options, ?PAPER),
+ L = proplists:get_value(ribbon, Options, ?RIBBON),
+ prettypr:best(layout(Node, Options), W, L).
+-endif. % NO_UNUSED
+%% @clear
+
+
+%% =====================================================================
+%% @spec layout(Tree::cerl()) -> document()
+%% @equiv layout(Tree, [])
+
+-ifndef(NO_UNUSED).
+layout(Node) ->
+ layout(Node, []).
+-endif. % NO_UNUSED
+%% @clear
+
+
+%% =====================================================================
+%% @spec annotate(document(), Terms::[term()], context()) -> document()
+%%
+%% @doc Adds an annotation containing <code>Terms</code> around the
+%% given abstract document. This function is exported mainly for use in
+%% hook functions; see <code>format/2</code>.
+%%
+%% @see format/2
+
+-spec annotate(prettypr:document(), [term()], context()) -> prettypr:document().
+
+annotate(Doc, As0, Ctxt) ->
+ case strip_line(As0) of
+ [] ->
+ Doc;
+ As ->
+ case Ctxt#ctxt.noann of
+ false ->
+ Es = seq(As, floating(text(",")), Ctxt,
+ fun lay_concrete/2),
+ follow(beside(floating(text("(")), Doc),
+ beside(text("-| ["),
+ beside(par(Es), floating(text("])")))),
+ Ctxt#ctxt.sub_indent);
+ true ->
+ Doc
+ end
+ end.
+
+
+%% =====================================================================
+%% @spec layout(Tree::cerl(), Options::[term()]) -> document()
+%% document() = prettypr:document()
+%%
+%% @doc Creates an abstract document layout for a syntax tree. The
+%% result represents a set of possible layouts (cf. module
+%% <code>prettypr</code>). For information on the options, see
+%% <code>format/2</code>; note, however, that the <code>paper</code> and
+%% <code>ribbon</code> options are ignored by this function.
+%%
+%% <p>This function provides a low-level interface to the pretty
+%% printer, returning a flexible representation of possible layouts,
+%% independent of the paper width eventually to be used for formatting.
+%% This can be included as part of another document and/or further
+%% processed directly by the functions in the <code>prettypr</code>
+%% module, or used in a hook function (see <code>format/2</code> for
+%% details).</p>
+%%
+%% @see prettypr
+%% @see format/2
+%% @see layout/1
+
+-spec layout(cerl:cerl(), [term()]) -> prettypr:document().
+
+layout(Node, Options) ->
+ lay(Node,
+ #ctxt{hook = proplists:get_value(hook, Options, ?NOHOOK),
+ noann = proplists:get_bool(noann, Options),
+ paper = proplists:get_value(paper, Options, ?PAPER),
+ ribbon = proplists:get_value(ribbon, Options, ?RIBBON),
+ user = proplists:get_value(user, Options)}).
+
+lay(Node, Ctxt) ->
+ case get_line(get_ann(Node)) of
+ none ->
+ lay_0(Node, Ctxt);
+ Line ->
+ if Line > Ctxt#ctxt.line ->
+ Ctxt1 = Ctxt#ctxt{line = Line},
+ Txt = io_lib:format("% Line ~w",[Line]),
+% beside(lay_0(Node, Ctxt1), floating(text(Txt)));
+ above(floating(text(Txt)), lay_0(Node, Ctxt1));
+ true ->
+ lay_0(Node, Ctxt)
+ end
+ end.
+
+lay_0(Node, Ctxt) ->
+ case Ctxt#ctxt.hook of
+ ?NOHOOK ->
+ lay_ann(Node, Ctxt);
+ Hook ->
+ %% If there is a hook, we apply it.
+ Hook(Node, Ctxt, fun lay_ann/2)
+ end.
+
+%% This adds an annotation list (if nonempty) around a document, unless
+%% the `noann' option is enabled.
+
+lay_ann(Node, Ctxt) ->
+ Doc = lay_1(Node, Ctxt),
+ As = get_ann(Node),
+ annotate(Doc, As, Ctxt).
+
+%% This part ignores annotations:
+
+lay_1(Node, Ctxt) ->
+ case type(Node) of
+ literal ->
+ lay_literal(Node, Ctxt);
+ var ->
+ lay_var(Node, Ctxt);
+ values ->
+ lay_values(Node, Ctxt);
+ cons ->
+ lay_cons(Node, Ctxt);
+ tuple ->
+ lay_tuple(Node, Ctxt);
+ 'let' ->
+ lay_let(Node, Ctxt);
+ seq ->
+ lay_seq(Node, Ctxt);
+ apply ->
+ lay_apply(Node, Ctxt);
+ call ->
+ lay_call(Node, Ctxt);
+ primop ->
+ lay_primop(Node, Ctxt);
+ 'case' ->
+ lay_case(Node, Ctxt);
+ clause ->
+ lay_clause(Node, Ctxt);
+ alias ->
+ lay_alias(Node, Ctxt);
+ 'fun' ->
+ lay_fun(Node, Ctxt);
+ 'receive' ->
+ lay_receive(Node, Ctxt);
+ 'try' ->
+ lay_try(Node, Ctxt);
+ 'catch' ->
+ lay_catch(Node, Ctxt);
+ letrec ->
+ lay_letrec(Node, Ctxt);
+ module ->
+ lay_module(Node, Ctxt);
+ binary ->
+ lay_binary(Node, Ctxt);
+ bitstr ->
+ lay_bitstr(Node, Ctxt)
+ end.
+
+lay_literal(Node, Ctxt) ->
+ case concrete(Node) of
+ V when is_atom(V) ->
+ text(atom_lit(Node));
+ V when is_float(V) ->
+ text(tidy_float(float_lit(Node)));
+ V when is_integer(V) ->
+ %% Note that we do not even try to recognize values
+ %% that could represent printable characters - we
+ %% always print an integer.
+ text(int_lit(Node));
+ V when is_binary(V) ->
+ lay_binary(c_binary([c_bitstr(abstract(B),
+ abstract(8),
+ abstract(1),
+ abstract(integer),
+ abstract([unsigned, big]))
+ || B <- binary_to_list(V)]),
+ Ctxt);
+ [] ->
+ text("[]");
+ [_ | _] ->
+ %% `lay_cons' will check for strings.
+ lay_cons(Node, Ctxt);
+ V when is_tuple(V) ->
+ lay_tuple(Node, Ctxt)
+ end.
+
+lay_var(Node, Ctxt) ->
+ %% When formatting variable names, no two names should ever map to
+ %% the same string. We assume below that an atom representing a
+ %% variable name either has the character sequence of a proper
+ %% variable, or otherwise does not need single-quoting.
+ case var_name(Node) of
+ V when is_atom(V) ->
+ S = atom_to_list(V),
+ case S of
+ [C | _] when C >= $A, C =< $Z ->
+ %% Ordinary uppercase-prefixed names are printed
+ %% just as they are.
+ text(S);
+ [C | _] when C >= $\300, C =< $\336, C /= $\327 ->
+ %% These are also uppercase (ISO 8859-1).
+ text(S);
+ [$_| _] ->
+ %% If the name starts with '_' we keep the name as is.
+ text(S);
+ _ ->
+ %% Plain atom names are prefixed with a single "_".
+ %% E.g. 'foo' => "_foo".
+ text([$_ | S])
+ end;
+ V when is_integer(V) ->
+ %% Integers are always simply prefixed with "_";
+ %% e.g. 4711 => "_4711".
+ text([$_ | integer_to_list(V)]);
+ {N, A} when is_atom(N), is_integer(A) ->
+ %% Function names have no overlap problem.
+ beside(lay_noann(c_atom(atom_to_list(N)), Ctxt),
+ beside(text("/"), lay_noann(c_int(A), Ctxt)))
+ end.
+
+lay_values(Node, Ctxt) ->
+ lay_value_list(values_es(Node), Ctxt).
+
+lay_cons(Node, Ctxt) ->
+ case is_print_string(Node) of
+ true ->
+ lay_string(string_lit(Node), Ctxt);
+ false ->
+ beside(floating(text("[")),
+ beside(par(lay_list_elements(Node, Ctxt)),
+ floating(text("]"))))
+ end.
+
+lay_string(S, Ctxt) ->
+ %% S includes leading/trailing double-quote characters. The segment
+ %% width is 2/3 of the ribbon width - this seems to work well.
+ W = (Ctxt#ctxt.ribbon) * 2 div 3,
+ lay_string_1(S, length(S), W).
+
+lay_string_1(S, L, W) when L > W, W > 0 ->
+ %% Note that L is the minimum, not the exact, printed length.
+ case split_string(S, W - 1, L) of
+ {_, ""} ->
+ text(S);
+ {S1, S2} ->
+ above(text(S1 ++ "\""),
+ lay_string_1([$" | S2], L - W + 1, W))
+ end;
+lay_string_1(S, _L, _W) ->
+ text(S).
+
+split_string(Xs, N, L) ->
+ split_string_1(Xs, N, L, []).
+
+%% We only split strings at whitespace, if possible. We must make sure
+%% we do not split an escape sequence.
+
+split_string_1([$\s | Xs], N, L, As) when N =< 0, L >= 5 ->
+ {lists:reverse([$\s | As]), Xs};
+split_string_1([$\t | Xs], N, L, As) when N =< 0, L >= 5 ->
+ {lists:reverse([$t, $\\ | As]), Xs};
+split_string_1([$\n | Xs], N, L, As) when N =< 0, L >= 5 ->
+ {lists:reverse([$n, $\\ | As]), Xs};
+split_string_1([$\\ | Xs], N, L, As) ->
+ split_string_2(Xs, N - 1, L - 1, [$\\ | As]);
+split_string_1(Xs, N, L, As) when N =< -10, L >= 5 ->
+ {lists:reverse(As), Xs};
+split_string_1([X | Xs], N, L, As) ->
+ split_string_1(Xs, N - 1, L - 1, [X | As]);
+split_string_1([], _N, _L, As) ->
+ {lists:reverse(As), ""}.
+
+split_string_2([$^, X | Xs], N, L, As) ->
+ split_string_1(Xs, N - 2, L - 2, [X, $^ | As]);
+split_string_2([X1, X2, X3 | Xs], N, L, As) when
+ X1 >= $0, X1 =< $7, X2 >= $0, X2 =< $7, X3 >= $0, X3 =< $7 ->
+ split_string_1(Xs, N - 3, L - 3, [X3, X2, X1 | As]);
+split_string_2([X1, X2 | Xs], N, L, As) when
+ X1 >= $0, X1 =< $7, X2 >= $0, X2 =< $7 ->
+ split_string_1(Xs, N - 2, L - 2, [X2, X1 | As]);
+split_string_2([X | Xs], N, L, As) ->
+ split_string_1(Xs, N - 1, L - 1, [X | As]).
+
+lay_tuple(Node, Ctxt) ->
+ beside(floating(text("{")),
+ beside(par(seq(tuple_es(Node), floating(text(",")),
+ Ctxt, fun lay/2)),
+ floating(text("}")))).
+
+lay_let(Node, Ctxt) ->
+ V = lay_value_list(let_vars(Node), Ctxt),
+ D1 = par([follow(text("let"),
+ beside(V, floating(text(" ="))),
+ Ctxt#ctxt.sub_indent),
+ lay(let_arg(Node), Ctxt)],
+ Ctxt#ctxt.body_indent),
+ B = let_body(Node),
+ D2 = lay(B, Ctxt),
+ case is_c_let(B) of
+ true ->
+ sep([beside(D1, floating(text(" in"))), D2]);
+ false ->
+ sep([D1, beside(text("in "), D2)])
+ end.
+
+lay_seq(Node, Ctxt) ->
+ D1 = beside(text("do "), lay(seq_arg(Node), Ctxt)),
+ B = seq_body(Node),
+ D2 = lay(B, Ctxt),
+ case is_c_seq(B) of
+ true ->
+ sep([D1, D2]);
+ false ->
+ sep([D1, nest(3, D2)])
+ end.
+
+lay_apply(Node, Ctxt) ->
+ As = seq(apply_args(Node), floating(text(",")), Ctxt,
+ fun lay/2),
+ beside(follow(text("apply"), lay(apply_op(Node), Ctxt)),
+ beside(text("("),
+ beside(par(As), floating(text(")"))))).
+
+lay_call(Node, Ctxt) ->
+ As = seq(call_args(Node), floating(text(",")), Ctxt,
+ fun lay/2),
+ beside(follow(text("call"),
+ beside(beside(lay(call_module(Node), Ctxt),
+ floating(text(":"))),
+ lay(call_name(Node), Ctxt)),
+ Ctxt#ctxt.sub_indent),
+ beside(text("("), beside(par(As),
+ floating(text(")"))))).
+
+lay_primop(Node, Ctxt) ->
+ As = seq(primop_args(Node), floating(text(",")), Ctxt,
+ fun lay/2),
+ beside(follow(text("primop"),
+ lay(primop_name(Node), Ctxt),
+ Ctxt#ctxt.sub_indent),
+ beside(text("("), beside(par(As),
+ floating(text(")"))))).
+
+lay_case(Node, Ctxt) ->
+ Cs = seq(case_clauses(Node), none, Ctxt, fun lay/2),
+ sep([par([follow(text("case"),
+ lay(case_arg(Node), Ctxt),
+ Ctxt#ctxt.sub_indent),
+ text("of")],
+ Ctxt#ctxt.sub_indent),
+ nest(Ctxt#ctxt.sub_indent,
+ vertical(Cs)),
+ text("end")]).
+
+lay_clause(Node, Ctxt) ->
+ P = lay_value_list(clause_pats(Node), Ctxt),
+ G = lay(clause_guard(Node), Ctxt),
+ H = par([P, follow(follow(text("when"), G,
+ Ctxt#ctxt.sub_indent),
+ floating(text("->")))],
+ Ctxt#ctxt.sub_indent),
+ par([H, lay(clause_body(Node), Ctxt)],
+ Ctxt#ctxt.body_indent).
+
+lay_alias(Node, Ctxt) ->
+ follow(beside(lay(alias_var(Node), Ctxt),
+ text(" =")),
+ lay(alias_pat(Node), Ctxt),
+ Ctxt#ctxt.body_indent).
+
+lay_fun(Node, Ctxt) ->
+ Vs = seq(fun_vars(Node), floating(text(",")),
+ Ctxt, fun lay/2),
+ par([follow(text("fun"),
+ beside(text("("),
+ beside(par(Vs),
+ floating(text(") ->")))),
+ Ctxt#ctxt.sub_indent),
+ lay(fun_body(Node), Ctxt)],
+ Ctxt#ctxt.body_indent).
+
+lay_receive(Node, Ctxt) ->
+ Cs = seq(receive_clauses(Node), none, Ctxt, fun lay/2),
+ sep([text("receive"),
+ nest(Ctxt#ctxt.sub_indent, vertical(Cs)),
+ sep([follow(text("after"),
+ beside(lay(receive_timeout(Node), Ctxt),
+ floating(text(" ->"))),
+ Ctxt#ctxt.sub_indent),
+ nest(Ctxt#ctxt.sub_indent,
+ lay(receive_action(Node), Ctxt))])]).
+
+lay_try(Node, Ctxt) ->
+ Vs = lay_value_list(try_vars(Node), Ctxt),
+ Evs = lay_value_list(try_evars(Node), Ctxt),
+ sep([follow(text("try"),
+ lay(try_arg(Node), Ctxt),
+ Ctxt#ctxt.body_indent),
+ follow(beside(beside(text("of "), Vs),
+ floating(text(" ->"))),
+ lay(try_body(Node), Ctxt),
+ Ctxt#ctxt.body_indent),
+ follow(beside(beside(text("catch "), Evs),
+ floating(text(" ->"))),
+ lay(try_handler(Node), Ctxt),
+ Ctxt#ctxt.body_indent)]).
+
+lay_catch(Node, Ctxt) ->
+ follow(text("catch"),
+ lay(catch_body(Node), Ctxt),
+ Ctxt#ctxt.sub_indent).
+
+lay_letrec(Node, Ctxt) ->
+ Es = seq(letrec_defs(Node), none, Ctxt, fun lay_fdef/2),
+ sep([text("letrec"),
+ nest(Ctxt#ctxt.sub_indent, vertical(Es)),
+ beside(text("in "), lay(letrec_body(Node), Ctxt))]).
+
+lay_module(Node, Ctxt) ->
+ %% Note that the module name, exports and attributes may not
+ %% be annotated in the printed format.
+ Xs = seq(module_exports(Node), floating(text(",")), Ctxt,
+ fun lay_noann/2),
+ As = seq(module_attrs(Node), floating(text(",")), Ctxt,
+ fun lay_attrdef/2),
+ Es = seq(module_defs(Node), none, Ctxt, fun lay_fdef/2),
+ sep([follow(text("module"),
+ follow(lay_noann(module_name(Node), Ctxt),
+ beside(beside(text("["), par(Xs)),
+ floating(text("]")))),
+ Ctxt#ctxt.sub_indent),
+ nest(Ctxt#ctxt.sub_indent,
+ follow(text("attributes"),
+ beside(beside(text("["), par(As)),
+ floating(text("]"))),
+ Ctxt#ctxt.sub_indent)),
+ nest(Ctxt#ctxt.sub_indent, vertical(Es)),
+ text("end")]).
+
+lay_binary(Node, Ctxt) ->
+ beside(floating(text("#{")),
+ beside(sep(seq(binary_segments(Node), floating(text(",")),
+ Ctxt, fun lay_bitstr/2)),
+ floating(text("}#")))).
+
+lay_bitstr(Node, Ctxt) ->
+ Head = beside(floating(text("#<")),
+ beside(lay(bitstr_val(Node), Ctxt),
+ floating(text(">")))),
+ As = [bitstr_size(Node),
+ bitstr_unit(Node),
+ bitstr_type(Node),
+ bitstr_flags(Node)],
+ beside(Head, beside(floating(text("(")),
+ beside(sep(seq(As, floating(text(",")),
+ Ctxt, fun lay/2)),
+ floating(text(")"))))).
+
+%% In all places where "<...>"-sequences can occur, it is OK to
+%% write 1-element sequences without the "<" and ">".
+
+lay_value_list([E], Ctxt) ->
+ lay(E, Ctxt);
+lay_value_list(Es, Ctxt) ->
+ beside(floating(text("<")),
+ beside(par(seq(Es, floating(text(",")),
+ Ctxt, fun lay/2)),
+ floating(text(">")))).
+
+lay_noann(Node, Ctxt) ->
+ lay(Node, Ctxt#ctxt{noann = true}).
+
+lay_concrete(T, Ctxt) ->
+ lay(abstract(T), Ctxt).
+
+lay_attrdef({K, V}, Ctxt) ->
+ follow(beside(lay_noann(K, Ctxt), floating(text(" ="))),
+ lay_noann(V, Ctxt),
+ Ctxt#ctxt.body_indent).
+
+lay_fdef({N, F}, Ctxt) ->
+ par([beside(lay(N, Ctxt), floating(text(" ="))),
+ lay(F, Ctxt)],
+ Ctxt#ctxt.body_indent).
+
+lay_list_elements(Node, Ctxt) ->
+ T = cons_tl(Node),
+ A = case Ctxt#ctxt.noann of
+ false ->
+ get_ann(T);
+ true ->
+ []
+ end,
+ H = lay(cons_hd(Node), Ctxt),
+ case is_c_cons(T) of
+ true when A =:= [] ->
+ [beside(H, floating(text(",")))
+ | lay_list_elements(T, Ctxt)];
+ _ ->
+ case is_c_nil(T) of
+ true when A =:= [] ->
+ [H];
+ _ ->
+ [H, beside(floating(text("| ")),
+ lay(T, Ctxt))]
+ end
+ end.
+
+seq([H | T], Separator, Ctxt, Fun) ->
+ case T of
+ [] ->
+ [Fun(H, Ctxt)];
+ _ ->
+ [maybe_append(Separator, Fun(H, Ctxt))
+ | seq(T, Separator, Ctxt, Fun)]
+ end;
+seq([], _, _, _) ->
+ [empty()].
+
+maybe_append(none, D) ->
+ D;
+maybe_append(Suffix, D) ->
+ beside(D, Suffix).
+
+vertical([D]) ->
+ D;
+vertical([D | Ds]) ->
+ above(D, vertical(Ds));
+vertical([]) ->
+ [].
+
+% horizontal([D]) ->
+% D;
+% horizontal([D | Ds]) ->
+% beside(D, horizontal(Ds));
+% horizontal([]) ->
+% [].
+
+tidy_float([$., C | Cs]) ->
+ [$., C | tidy_float_1(Cs)]; % preserve first decimal digit
+tidy_float([$e | _] = Cs) ->
+ tidy_float_2(Cs);
+tidy_float([C | Cs]) ->
+ [C | tidy_float(Cs)];
+tidy_float([]) ->
+ [].
+
+tidy_float_1([$0, $0, $0 | Cs]) ->
+ tidy_float_2(Cs); % cut mantissa at three consecutive zeros.
+tidy_float_1([$e | _] = Cs) ->
+ tidy_float_2(Cs);
+tidy_float_1([C | Cs]) ->
+ [C | tidy_float_1(Cs)];
+tidy_float_1([]) ->
+ [].
+
+tidy_float_2([$e, $+, $0]) -> [];
+tidy_float_2([$e, $+, $0 | Cs]) -> tidy_float_2([$e, $+ | Cs]);
+tidy_float_2([$e, $+ | _] = Cs) -> Cs;
+tidy_float_2([$e, $-, $0]) -> [];
+tidy_float_2([$e, $-, $0 | Cs]) -> tidy_float_2([$e, $- | Cs]);
+tidy_float_2([$e, $- | _] = Cs) -> Cs;
+tidy_float_2([$e | Cs]) -> tidy_float_2([$e, $+ | Cs]);
+tidy_float_2([_ | Cs]) -> tidy_float_2(Cs);
+tidy_float_2([]) -> [].
+
+get_line([L | _As]) when is_integer(L) ->
+ L;
+get_line([_ | As]) ->
+ get_line(As);
+get_line([]) ->
+ none.
+
+strip_line([A | As]) when is_integer(A) ->
+ strip_line(As);
+strip_line([A | As]) ->
+ [A | strip_line(As)];
+strip_line([]) ->
+ [].
+
+%% =====================================================================
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.
+
+
diff --git a/lib/hipe/cerl/cerl_typean.erl b/lib/hipe/cerl/cerl_typean.erl
new file mode 100644
index 0000000000..ccd8903658
--- /dev/null
+++ b/lib/hipe/cerl/cerl_typean.erl
@@ -0,0 +1,1003 @@
+%% -*- 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%
+%%
+%% Type analysis of Core Erlang programs.
+%%
+%% Copyright (C) 2001-2002 Richard Carlsson
+%%
+%% Author contact: [email protected]
+%%
+%% @doc Type analysis of Core Erlang programs.
+
+%% TODO: filters must handle conjunctions for better precision!
+%% TODO: should get filters from patterns as well as guards.
+%% TODO: unused functions are being included in the analysis.
+
+-module(cerl_typean).
+
+-export([core_transform/2, analyze/1, pp_hook/0]).
+%%-export([analyze/2, analyze/5, annotate/1, annotate/2, annotate/5]).
+
+-import(erl_types, [t_any/0, t_atom/0, t_atom_vals/1, t_binary/0,
+ t_cons/2, t_cons_hd/1, t_cons_tl/1, t_float/0,
+ t_fun/0, t_fun/2, t_from_range/2, t_from_term/1,
+ t_inf/2, t_integer/0,
+ t_is_any/1, t_is_atom/1, t_is_cons/1, t_is_list/1,
+ t_is_maybe_improper_list/1, t_is_none/1, t_is_tuple/1,
+ t_limit/2, t_list_elements/1, t_maybe_improper_list/0,
+ t_none/0, t_number/0, t_pid/0, t_port/0, t_product/1,
+ t_reference/0, t_sup/2, t_to_tlist/1, t_tuple/0, t_tuple/1,
+ t_tuple_args/1, t_tuple_size/1, t_tuple_subtypes/1]).
+
+-import(cerl, [ann_c_fun/3, ann_c_var/2, alias_pat/1, alias_var/1,
+ apply_args/1, apply_op/1, atom_val/1, bitstr_size/1,
+ bitstr_val/1, bitstr_type/1, bitstr_flags/1, binary_segments/1,
+ c_letrec/2, c_nil/0,
+ c_values/1, call_args/1, call_module/1, call_name/1,
+ case_arg/1, case_clauses/1, catch_body/1, clause_body/1,
+ clause_guard/1, clause_pats/1, concrete/1, cons_hd/1,
+ cons_tl/1, fun_body/1, fun_vars/1, get_ann/1, int_val/1,
+ is_c_atom/1, is_c_int/1, let_arg/1, let_body/1, let_vars/1,
+ letrec_body/1, letrec_defs/1, module_defs/1,
+ module_defs/1, module_exports/1, pat_vars/1,
+ primop_args/1, primop_name/1, receive_action/1,
+ receive_clauses/1, receive_timeout/1, seq_arg/1,
+ seq_body/1, set_ann/2, try_arg/1, try_body/1,
+ try_evars/1, try_handler/1, try_vars/1, tuple_arity/1,
+ tuple_es/1, type/1, values_es/1, var_name/1]).
+
+-import(cerl_trees, [get_label/1]).
+
+-ifdef(DEBUG).
+-define(ANNOTATE(X), case erl_types:t_to_string(X) of Q when length(Q) < 255 -> list_to_atom(Q); Q -> Q end).
+-else.
+-define(ANNOTATE(X), X).
+-endif.
+
+%% Limit for type representation depth.
+-define(DEF_LIMIT, 3).
+
+
+%% @spec core_transform(Module::cerl_records(), Options::[term()]) ->
+%% cerl_records()
+%%
+%% @doc Annotates a module represented by records with type
+%% information. See <code>annotate/1</code> for details.
+%%
+%% <p>Use the compiler option <code>{core_transform, cerl_typean}</code>
+%% to insert this function as a compilation pass.</p>
+%%
+%% @see module/2
+
+-spec core_transform(cerl:cerl(), [term()]) -> cerl:cerl().
+
+core_transform(Code, _Opts) ->
+ {Code1, _} = cerl_trees:label(cerl:from_records(Code)),
+ %% io:fwrite("Running type analysis..."),
+ %% {T1,_} = statistics(runtime),
+ {Code2, _, _} = annotate(Code1),
+ %% {T2,_} = statistics(runtime),
+ %% io:fwrite("(~w ms).\n", [T2 - T1]),
+ cerl:to_records(Code2).
+
+
+%% =====================================================================
+%% annotate(Tree) -> {Tree1, Type, Vars}
+%%
+%% Tree = cerl:cerl()
+%%
+%% Analyzes `Tree' (see `analyze') and appends terms `{type, Type}'
+%% to the annotation list of each fun-expression node and
+%% apply-expression node of `Tree', respectively, where `Labels' is
+%% an ordered-set list of labels of fun-expressions in `Tree',
+%% possibly also containing the atom `external', corresponding to
+%% the dependency information derived by the analysis. Any previous
+%% such annotations are removed from `Tree'. `Tree1' is the
+%% modified tree; for details on `OutList', `Outputs' ,
+%% `Dependencies' and `Escapes', see `analyze'.
+%%
+%% Note: `Tree' must be annotated with labels in order to use this
+%% function; see `analyze' for details.
+
+annotate(Tree) ->
+ annotate(Tree, ?DEF_LIMIT).
+
+annotate(Tree, Limit) ->
+ {_, _, Esc, Dep, Par} = cerl_closurean:analyze(Tree),
+ annotate(Tree, Limit, Esc, Dep, Par).
+
+annotate(Tree, Limit, Esc, Dep, Par) ->
+ {Type, Out, Vars} = analyze(Tree, Limit, Esc, Dep, Par),
+ DelAnn = fun (T) -> set_ann(T, delete_ann(type, get_ann(T))) end,
+ SetType = fun (T, Dict) ->
+ case dict:find(get_label(T), Dict) of
+ {ok, X} ->
+ case t_is_any(X) of
+ true ->
+ DelAnn(T);
+ false ->
+ set_ann(T, append_ann(type,
+ ?ANNOTATE(X),
+ get_ann(T)))
+ end;
+ error ->
+ DelAnn(T)
+ end
+ end,
+ F = fun (T) ->
+ case type(T) of
+ var ->
+ SetType(T, Vars);
+ apply ->
+ SetType(T, Out);
+ call ->
+ SetType(T, Out);
+ primop ->
+ SetType(T, Out);
+ 'fun' ->
+ SetType(T, Out);
+ _ ->
+ DelAnn(T)
+ end
+ end,
+ {cerl_trees:map(F, Tree), Type, Vars}.
+
+append_ann(Tag, Val, [X | Xs]) ->
+ if tuple_size(X) >= 1, element(1, X) =:= Tag ->
+ append_ann(Tag, Val, Xs);
+ true ->
+ [X | append_ann(Tag, Val, Xs)]
+ end;
+append_ann(Tag, Val, []) ->
+ [{Tag, Val}].
+
+delete_ann(Tag, [X | Xs]) ->
+ if tuple_size(X) >= 1, element(1, X) =:= Tag ->
+ delete_ann(Tag, Xs);
+ true ->
+ [X | delete_ann(Tag, Xs)]
+ end;
+delete_ann(_, []) ->
+ [].
+
+
+%% =====================================================================
+%% analyze(Tree) -> {OutList, Outputs, Dependencies}
+%%
+%% Tree = cerl:cerl()
+%% OutList = [LabelSet] | none
+%% Outputs = dict(integer(), OutList)
+%% Dependencies = dict(integer(), LabelSet)
+%% LabelSet = ordset(Label)
+%% Label = integer() | external
+%%
+%% Analyzes a module or an expression represented by `Tree'.
+%%
+%% The returned `OutList' is a list of sets of labels of
+%% fun-expressions which correspond to the possible closures in the
+%% value list produced by `Tree' (viewed as an expression; the
+%% "value" of a module contains its exported functions). The atom
+%% `none' denotes missing or conflicting information.
+%%
+%% The atom `external' in any label set denotes any possible
+%% function outside `Tree', including those in `Escapes'.
+%%
+%% `Outputs' is a mapping from the labels of fun-expressions in
+%% `Tree' to corresponding lists of sets of labels of
+%% fun-expressions (or the atom `none'), representing the possible
+%% closures in the value lists returned by the respective
+%% functions.
+%%
+%% `Dependencies' is a similar mapping from the labels of
+%% fun-expressions and apply-expressions in `Tree' to sets of
+%% labels of corresponding fun-expressions which may contain call
+%% sites of the functions or be called from the call sites,
+%% respectively. Any such label not defined in `Dependencies'
+%% represents an unreachable function or a dead or faulty
+%% application.
+%%
+%% `Escapes' is the set of labels of fun-expressions in `Tree' such
+%% that corresponding closures may be accessed from outside `Tree'.
+%%
+%% Note: `Tree' must be annotated with labels (as done by the
+%% function `cerl_trees:label/1') in order to use this function.
+%% The label annotation `{label, L}' (where L should be an integer)
+%% must be the first element of the annotation list of each node in
+%% the tree. Instances of variables bound in `Tree' which denote
+%% the same variable must have the same label; apart from this,
+%% labels should be unique. Constant literals do not need to be
+%% labeled.
+
+-record(state, {k, vars, out, dep, work, funs, envs}).
+
+%% Note: In order to keep our domain simple, we assume that all remote
+%% calls and primops return a single value, if any.
+
+%% We wrap the given syntax tree T in a fun-expression labeled `top',
+%% which is initially in the set of escaped labels. `top' will be
+%% visited at least once.
+%%
+%% We create a separate function labeled `external', defined as:
+%% "External = fun () -> Any", which will represent any and all
+%% functions outside T, and whose return value has unknown type.
+
+-type label() :: integer() | 'external' | 'top'.
+-type ordset(X) :: [X]. % XXX: TAKE ME OUT
+-type labelset() :: ordset(label()).
+-type outlist() :: [labelset()] | 'none'.
+
+-spec analyze(cerl:cerl()) -> {outlist(), dict(), dict()}.
+
+analyze(Tree) ->
+ analyze(Tree, ?DEF_LIMIT).
+
+analyze(Tree, Limit) ->
+ {_, _, Esc, Dep, Par} = cerl_closurean:analyze(Tree),
+ analyze(Tree, Limit, Esc, Dep, Par).
+
+analyze(Tree, Limit, Esc0, Dep0, Par) ->
+ %% Note that we use different name spaces for variable labels and
+ %% function/call site labels. We assume that the labeling of Tree
+ %% only uses integers, not atoms.
+ LabelExtL = [{label, external}],
+ External = ann_c_var(LabelExtL, {external, 1}),
+ ExtFun = ann_c_fun(LabelExtL, [], ann_c_var([{label, any}], 'Any')),
+%%% io:fwrite("external fun:\n~s.\n",
+%%% [cerl_prettypr:format(ExtFun, [noann, {paper, 80}])]),
+ LabelTopL = [{label, top}],
+ Top = ann_c_var(LabelTopL, {top, 0}),
+ TopFun = ann_c_fun(LabelTopL, [], Tree),
+
+ %% The "start fun" just makes the initialisation easier. It is not
+ %% itself in the call graph.
+ StartFun = ann_c_fun([{label, start}], [],
+ c_letrec([{External, ExtFun}, {Top, TopFun}],
+ c_nil())),
+%%% io:fwrite("start fun:\n~s.\n",
+%%% [cerl_prettypr:format(StartFun, [{paper, 80}])]),
+
+ %% Gather a database of all fun-expressions in Tree and initialise
+ %% their outputs and parameter variables. All escaping functions can
+ %% receive any values as inputs. Also add an extra dependency edge
+ %% from each fun-expression label to its parent fun-expression.
+%%% io:fwrite("Escape: ~p.\n",[Esc0]),
+ Esc = sets:from_list(Esc0),
+ Any = t_any(),
+ None = t_none(),
+ Funs0 = dict:new(),
+ Vars0 = dict:store(any, Any, dict:new()),
+ Out0 = dict:store(top, None,
+ dict:store(external, None, dict:new())),
+ Envs0 = dict:store(top, dict:new(),
+ dict:store(external, dict:new(), dict:new())),
+ F = fun (T, S = {Fs, Vs, Os, Es}) ->
+ case type(T) of
+ 'fun' ->
+ L = get_label(T),
+ As = fun_vars(T),
+ X = case sets:is_element(L, Esc) of
+ true -> Any;
+ false -> None
+ end,
+ {dict:store(L, T, Fs),
+ bind_vars_single(As, X, Vs),
+ dict:store(L, None, Os),
+ dict:store(L, dict:new(), Es)};
+ _ ->
+ S
+ end
+ end,
+ {Funs, Vars, Out, Envs} = cerl_trees:fold(F, {Funs0, Vars0, Out0,
+ Envs0}, StartFun),
+
+ %% Add dependencies from funs to their parent funs.
+ Dep = lists:foldl(fun ({L, L1}, D) -> add_dep(L, L1, D) end,
+ Dep0, dict:to_list(Par)),
+
+ %% Enter the fixpoint iteration at the StartFun.
+ St = loop(TopFun, top, #state{vars = Vars,
+ out = Out,
+ dep = Dep,
+ work = init_work(),
+ funs = Funs,
+ envs = Envs,
+ k = Limit}),
+ {dict:fetch(top, St#state.out),
+ tidy_dict([top, external], St#state.out),
+ tidy_dict([any], St#state.vars)}.
+
+tidy_dict([X | Xs], D) ->
+ tidy_dict(Xs, dict:erase(X, D));
+tidy_dict([], D) ->
+ D.
+
+loop(T, L, St0) ->
+%%% io:fwrite("analyzing: ~w.\n",[L]),
+%%% io:fwrite("work: ~w.\n", [Queue0]),
+ Env = dict:fetch(L, St0#state.envs),
+ X0 = dict:fetch(L, St0#state.out),
+ {X1, St1} = visit(fun_body(T), Env, St0),
+ X = limit(X1, St1#state.k),
+ {W, M} = case equal(X0, X) of
+ true ->
+ {St1#state.work, St1#state.out};
+ false ->
+%%% io:fwrite("out (~w) changed: ~s <- ~s.\n",
+%%% [L, erl_types:t_to_string(X),
+%%% erl_types:t_to_string(X0)]),
+ M1 = dict:store(L, X, St1#state.out),
+ case dict:find(L, St1#state.dep) of
+ {ok, S} ->
+%%% io:fwrite("adding work: ~w.\n", [S]),
+ {add_work(S, St1#state.work), M1};
+ error ->
+ {St1#state.work, M1}
+ end
+ end,
+ St2 = St1#state{out = M},
+ case take_work(W) of
+ {ok, L1, W1} ->
+ T1 = dict:fetch(L1, St2#state.funs),
+ loop(T1, L1, St2#state{work = W1});
+ none ->
+ St2
+ end.
+
+visit(T, Env, St) ->
+ case type(T) of
+ literal ->
+ {t_from_term(concrete(T)), St};
+ var ->
+ %% If a variable is not already in the store at this point,
+ %% we initialize it to 'none()'.
+ L = get_label(T),
+ Vars = St#state.vars,
+ case dict:find(L, Vars) of
+ {ok, X} ->
+ case dict:find(var_name(T), Env) of
+ {ok, X1} ->
+%%% io:fwrite("filtered variable reference: ~w:~s.\n",
+%%% [var_name(T), erl_types:t_to_string(X1)]),
+ {meet(X, X1), St};
+ error ->
+ {X, St}
+ end;
+ error ->
+ X = t_none(),
+ Vars1 = dict:store(L, X, Vars),
+ St1 = St#state{vars = Vars1},
+ {X, St1}
+ end;
+ 'fun' ->
+ %% Must revisit the fun also, because its environment might
+ %% have changed. (We don't keep track of such dependencies.)
+ L = get_label(T),
+ Xs = [dict:fetch(get_label(V), St#state.vars)
+ || V <- fun_vars(T)],
+ X = dict:fetch(L, St#state.out),
+ St1 = St#state{work = add_work([L], St#state.work),
+ envs = dict:store(L, Env, St#state.envs)},
+ {t_fun(Xs, X), St1};
+ values ->
+ {Xs, St1} = visit_list(values_es(T), Env, St),
+ {t_product(Xs), St1};
+ cons ->
+ {[X1, X2], St1} = visit_list([cons_hd(T), cons_tl(T)], Env, St),
+ {t_cons(X1, X2), St1};
+ tuple ->
+ {Xs, St1} = visit_list(tuple_es(T), Env, St),
+ {t_tuple(Xs), St1};
+ 'let' ->
+ {X, St1} = visit(let_arg(T), Env, St),
+ LetVars = let_vars(T),
+ St1Vars = St1#state.vars,
+ Vars = case t_is_any(X) orelse t_is_none(X) of
+ true ->
+ bind_vars_single(LetVars, X, St1Vars);
+ false ->
+ bind_vars(LetVars, t_to_tlist(X), St1Vars)
+ end,
+ visit(let_body(T), Env, St1#state{vars = Vars});
+ seq ->
+ {_, St1} = visit(seq_arg(T), Env, St),
+ visit(seq_body(T), Env, St1);
+ apply ->
+ {_F, St1} = visit(apply_op(T), Env, St),
+ {As, St2} = visit_list(apply_args(T), Env, St1),
+ L = get_label(T),
+ Ls = get_deps(L, St#state.dep),
+ Out = St2#state.out,
+ X = join_list([dict:fetch(L1, Out) || L1 <- Ls]),
+ Out1 = dict:store(L, X, Out),
+ {X, call_site(Ls, As, St2#state{out = Out1})};
+ call ->
+ M = call_module(T),
+ F = call_name(T),
+ As = call_args(T),
+ {[X1, X2], St1} = visit_list([M, F], Env, St),
+ {Xs, St2} = visit_list(As, Env, St1),
+%%% io:fwrite("call: ~w:~w(~w).\n",[X1,X2,Xs]),
+ X = case {t_atom_vals(X1), t_atom_vals(X2)} of
+ {[M1], [F1]} ->
+ A = length(As),
+%%% io:fwrite("known call: ~w:~w/~w.\n",
+%%% [M1, F1, A]),
+ call_type(M1, F1, A, Xs);
+ _ ->
+ t_any()
+ end,
+ L = get_label(T),
+ {X, St2#state{out = dict:store(L, X, St2#state.out)}};
+ primop ->
+ As = primop_args(T),
+ {Xs, St1} = visit_list(As, Env, St),
+ F = atom_val(primop_name(T)),
+ A = length(As),
+ L = get_label(T),
+ X = primop_type(F, A, Xs),
+ {X, St1#state{out = dict:store(L, X, St1#state.out)}};
+ 'case' ->
+ {X, St1} = visit(case_arg(T), Env, St),
+ Xs = case t_is_any(X) orelse t_is_none(X) of
+ true ->
+ [X || _ <- cerl:case_clauses(T)];
+ false ->
+ t_to_tlist(X)
+ end,
+ join_visit_clauses(Xs, case_clauses(T), Env, St1);
+ 'receive' ->
+ Any = t_any(),
+ {X1, St1} = join_visit_clauses([Any], receive_clauses(T),
+ Env, St),
+ {X2, St2} = visit(receive_timeout(T), Env, St1),
+ case t_is_atom(X2) andalso (t_atom_vals(X2) =:= [infinity]) of
+ true ->
+ {X1, St2};
+ false ->
+ {X3, St3} = visit(receive_action(T), Env, St2),
+ {join(X1, X3), St3}
+ end;
+ 'try' ->
+ {X, St1} = visit(try_arg(T), Env, St),
+ Any = t_any(),
+ Atom = t_atom(),
+ TryVars = try_vars(T),
+ St1Vars = St1#state.vars,
+ Vars = case t_is_any(X) orelse t_is_none(X) of
+ true ->
+ bind_vars_single(TryVars, X, St1Vars);
+ false ->
+ bind_vars(TryVars, t_to_tlist(X), St1Vars)
+ end,
+ {X1, St2} = visit(try_body(T), Env, St1#state{vars = Vars}),
+ EVars = bind_vars(try_evars(T), [Atom, Any, Any], St2#state.vars),
+ {X2, St3} = visit(try_handler(T), Env, St2#state{vars = EVars}),
+ {join(X1, X2), St3};
+ 'catch' ->
+ {_, St1} = visit(catch_body(T), Env, St),
+ {t_any(), St1};
+ binary ->
+ {_, St1} = visit_list(binary_segments(T), Env, St),
+ {t_binary(), St1};
+ bitstr ->
+ %% The other fields are constant literals.
+ {_, St1} = visit(bitstr_val(T), Env, St),
+ {_, St2} = visit(bitstr_size(T), Env, St1),
+ {t_none(), St2};
+ letrec ->
+ %% All the bound funs should be revisited, because the
+ %% environment might have changed.
+ Vars = bind_defs(letrec_defs(T), St#state.vars,
+ St#state.out),
+ Ls = [get_label(F) || {_, F} <- letrec_defs(T)],
+ St1 = St#state{work = add_work(Ls, St#state.work),
+ vars = Vars},
+ visit(letrec_body(T), Env, St1);
+ module ->
+ %% We handle a module as a sequence of function variables in
+ %% the body of a `letrec'.
+ {_, St1} = visit(c_letrec(module_defs(T),
+ c_values(module_exports(T))),
+ Env, St),
+ {t_none(), St1}
+ end.
+
+visit_clause(T, Xs, Env, St) ->
+ Env1 = Env,
+ Vars = bind_pats(clause_pats(T), Xs, St#state.vars),
+ G = clause_guard(T),
+ {_, St1} = visit(G, Env1, St#state{vars = Vars}),
+ Env2 = guard_filters(G, Env1),
+ visit(clause_body(T), Env2, St1).
+
+%% We assume correct value-list typing.
+
+visit_list([T | Ts], Env, St) ->
+ {X, St1} = visit(T, Env, St),
+ {Xs, St2} = visit_list(Ts, Env, St1),
+ {[X | Xs], St2};
+visit_list([], _Env, St) ->
+ {[], St}.
+
+join_visit_clauses(Xs, [T | Ts], Env, St) ->
+ {X1, St1} = visit_clause(T, Xs, Env, St),
+ {X2, St2} = join_visit_clauses(Xs, Ts, Env, St1),
+ {join(X1, X2), St2};
+join_visit_clauses(_, [], _Env, St) ->
+ {t_none(), St}.
+
+bind_defs([{V, F} | Ds], Vars, Out) ->
+ Xs = [dict:fetch(get_label(V1), Vars) || V1 <- fun_vars(F)],
+ X = dict:fetch(get_label(F), Out),
+ bind_defs(Ds, dict:store(get_label(V), t_fun(Xs, X), Vars), Out);
+bind_defs([], Vars, _Out) ->
+ Vars.
+
+bind_pats(Ps, Xs, Vars) ->
+ if length(Xs) =:= length(Ps) ->
+ bind_pats_list(Ps, Xs, Vars);
+ true ->
+ bind_pats_single(Ps, t_none(), Vars)
+ end.
+
+bind_pats_list([P | Ps], [X | Xs], Vars) ->
+ Vars1 = bind_pat_vars(P, X, Vars),
+ bind_pats_list(Ps, Xs, Vars1);
+bind_pats_list([], [], Vars) ->
+ Vars.
+
+bind_pats_single([P | Ps], X, Vars) ->
+ bind_pats_single(Ps, X, bind_pat_vars(P, X, Vars));
+bind_pats_single([], _X, Vars) ->
+ Vars.
+
+bind_pat_vars(P, X, Vars) ->
+ case type(P) of
+ var ->
+ dict:store(get_label(P), X, Vars);
+ literal ->
+ Vars;
+ cons ->
+ case t_is_cons(X) of
+ true ->
+ %% If X is "nonempty proper list of X1", then the
+ %% head has type X1 and the tail has type "proper
+ %% list of X1". (If X is just "cons cell of X1",
+ %% then both head and tail have type X1.)
+ Vars1 = bind_pat_vars(cons_hd(P), t_cons_hd(X),
+ Vars),
+ bind_pat_vars(cons_tl(P), t_cons_tl(X), Vars1);
+ false ->
+ case t_is_list(X) of
+ true ->
+ %% If X is "proper list of X1", then the
+ %% head has type X1 and the tail has type
+ %% "proper list of X1", i.e., type X.
+ Vars1 = bind_pat_vars(cons_hd(P),
+ t_list_elements(X),
+ Vars),
+ bind_pat_vars(cons_tl(P), X, Vars1);
+ false ->
+ case t_is_maybe_improper_list(X) of
+ true ->
+ %% If X is "cons cell of X1", both
+ %% the head and tail have type X1.
+ X1 = t_list_elements(X),
+ Vars1 = bind_pat_vars(cons_hd(P),
+ X1, Vars),
+ bind_pat_vars(cons_tl(P), X1,
+ Vars1);
+ false ->
+ bind_vars_single(pat_vars(P),
+ top_or_bottom(X),
+ Vars)
+ end
+ end
+ end;
+ tuple ->
+ case t_is_tuple(X) of
+ true ->
+ case t_tuple_subtypes(X) of
+ unknown ->
+ bind_vars_single(pat_vars(P), top_or_bottom(X),
+ Vars);
+ [Tuple] ->
+ case t_tuple_size(Tuple) =:= tuple_arity(P) of
+ true ->
+ bind_pats_list(tuple_es(P),
+ t_tuple_args(Tuple), Vars);
+
+ false ->
+ bind_vars_single(pat_vars(P),
+ top_or_bottom(X), Vars)
+ end;
+ List when is_list(List) ->
+ bind_vars_single(pat_vars(P), top_or_bottom(X),
+ Vars)
+ end;
+ false ->
+ bind_vars_single(pat_vars(P), top_or_bottom(X), Vars)
+ end;
+ binary ->
+ bind_pats_single(binary_segments(P), t_none(), Vars);
+ bitstr ->
+ %% Only the Value field is a new binding. Size is already
+ %% bound, and the other fields are constant literals.
+ %% We could create a filter for Size being an integer().
+ Size = bitstr_size(P),
+ ValType =
+ case concrete(bitstr_type(P)) of
+ float -> t_float();
+ binary -> t_binary();
+ integer ->
+ case is_c_int(Size) of
+ false -> t_integer();
+ true ->
+ SizeVal = int_val(Size),
+ Flags = concrete(bitstr_flags(P)),
+ case lists:member(signed, Flags) of
+ true ->
+ t_from_range(-(1 bsl (SizeVal - 1)),
+ 1 bsl (SizeVal - 1) - 1);
+ false ->
+ t_from_range(0,1 bsl SizeVal - 1)
+ end
+ end
+ end,
+ bind_pat_vars(bitstr_val(P), ValType, Vars);
+ alias ->
+ P1 = alias_pat(P),
+ Vars1 = bind_pat_vars(P1, X, Vars),
+ dict:store(get_label(alias_var(P)), pat_type(P1, Vars1),
+ Vars1)
+ end.
+
+pat_type(P, Vars) ->
+ case type(P) of
+ var ->
+ dict:fetch(get_label(P), Vars);
+ literal ->
+ t_from_term(concrete(P));
+ cons ->
+ t_cons(pat_type(cons_hd(P), Vars),
+ pat_type(cons_tl(P), Vars));
+ tuple ->
+ t_tuple([pat_type(E, Vars) || E <- tuple_es(P)]);
+ binary ->
+ t_binary();
+ alias ->
+ pat_type(alias_pat(P), Vars)
+ end.
+
+bind_vars(Vs, Xs, Vars) ->
+ if length(Vs) =:= length(Xs) ->
+ bind_vars_list(Vs, Xs, Vars);
+ true ->
+ bind_vars_single(Vs, t_none(), Vars)
+ end.
+
+bind_vars_list([V | Vs], [X | Xs], Vars) ->
+ bind_vars_list(Vs, Xs, dict:store(get_label(V), X, Vars));
+bind_vars_list([], [], Vars) ->
+ Vars.
+
+bind_vars_single([V | Vs], X, Vars) ->
+ bind_vars_single(Vs, X, dict:store(get_label(V), X, Vars));
+bind_vars_single([], _X, Vars) ->
+ Vars.
+
+add_dep(Source, Target, Deps) ->
+ case dict:find(Source, Deps) of
+ {ok, X} ->
+ case set__is_member(Target, X) of
+ true ->
+ Deps;
+ false ->
+%%% io:fwrite("new dep: ~w <- ~w.\n", [Target, Source]),
+ dict:store(Source, set__add(Target, X), Deps)
+ end;
+ error ->
+%%% io:fwrite("new dep: ~w <- ~w.\n", [Target, Source]),
+ dict:store(Source, set__singleton(Target), Deps)
+ end.
+
+%% This handles a call site, updating parameter variables with respect
+%% to the actual parameters.
+
+call_site(Ls, Xs, St) ->
+%% io:fwrite("call site: ~w ~s.\n",
+%% [Ls, erl_types:t_to_string(erl_types:t_product(Xs))]),
+ {W, V} = call_site(Ls, Xs, St#state.work, St#state.vars,
+ St#state.funs, St#state.k),
+ St#state{work = W, vars = V}.
+
+call_site([L | Ls], Xs, W, V, Fs, Limit) ->
+ Vs = fun_vars(dict:fetch(L, Fs)),
+ case bind_args(Vs, Xs, V, Limit) of
+ {V1, true} ->
+ call_site(Ls, Xs, add_work([L], W), V1, Fs, Limit);
+ {V1, false} ->
+ call_site(Ls, Xs, W, V1, Fs, Limit)
+ end;
+call_site([], _, W, V, _, _) ->
+ {W, V}.
+
+%% If the arity does not match the call, nothing is done here.
+
+bind_args(Vs, Xs, Vars, Limit) ->
+ if length(Vs) =:= length(Xs) ->
+ bind_args(Vs, Xs, Vars, Limit, false);
+ true ->
+ {Vars, false}
+ end.
+
+bind_args([V | Vs], [X | Xs], Vars, Limit, Ch) ->
+ L = get_label(V),
+ {Vars1, Ch1} = bind_arg(L, X, Vars, Limit, Ch),
+ bind_args(Vs, Xs, Vars1, Limit, Ch1);
+bind_args([], [], Vars, _Limit, Ch) ->
+ {Vars, Ch}.
+
+%% bind_arg(L, X, Vars, Limit) ->
+%% bind_arg(L, X, Vars, Limit, false).
+
+bind_arg(L, X, Vars, Limit, Ch) ->
+ X0 = dict:fetch(L, Vars),
+ X1 = limit(join(X, X0), Limit),
+ case equal(X0, X1) of
+ true ->
+ {Vars, Ch};
+ false ->
+%%% io:fwrite("arg (~w) changed: ~s <- ~s + ~s.\n",
+%%% [L, erl_types:t_to_string(X1),
+%%% erl_types:t_to_string(X0),
+%%% erl_types:t_to_string(X)]),
+ {dict:store(L, X1, Vars), true}
+ end.
+
+%% Domain: type(), defined in module `erl_types'.
+
+meet(X, Y) -> t_inf(X, Y).
+
+join(X, Y) -> t_sup(X, Y).
+
+join_list([Xs | Xss]) ->
+ join(Xs, join_list(Xss));
+join_list([]) ->
+ t_none().
+
+equal(X, Y) -> X =:= Y.
+
+limit(X, K) -> t_limit(X, K).
+
+top_or_bottom(T) ->
+ case t_is_none(T) of
+ true ->
+ T;
+ false ->
+ t_any()
+ end.
+
+strict(Xs, T) ->
+ case erl_types:any_none(Xs) of
+ true ->
+ t_none();
+ false ->
+ T
+ end.
+
+%% Set abstraction for label sets.
+
+%% set__new() -> [].
+
+set__singleton(X) -> [X].
+
+%% set__to_list(S) -> S.
+
+%% set__from_list(S) -> ordsets:from_list(S).
+
+%% set__union(X, Y) -> ordsets:union(X, Y).
+
+set__add(X, S) -> ordsets:add_element(X, S).
+
+set__is_member(X, S) -> ordsets:is_element(X, S).
+
+%% set__subtract(X, Y) -> ordsets:subtract(X, Y).
+
+%% set__equal(X, Y) -> X =:= Y.
+
+%% A simple but efficient functional queue.
+
+queue__new() -> {[], []}.
+
+queue__put(X, {In, Out}) -> {[X | In], Out}.
+
+queue__get({In, [X | Out]}) -> {ok, X, {In, Out}};
+queue__get({[], _}) -> empty;
+queue__get({In, _}) ->
+ [X | In1] = lists:reverse(In),
+ {ok, X, {[], In1}}.
+
+%% The work list - a queue without repeated elements.
+
+init_work() ->
+ {queue__put(external, queue__new()), sets:new()}.
+
+add_work(Ls, {Q, Set}) ->
+ add_work(Ls, Q, Set).
+
+%% Note that the elements are enqueued in order.
+
+add_work([L | Ls], Q, Set) ->
+ case sets:is_element(L, Set) of
+ true ->
+ add_work(Ls, Q, Set);
+ false ->
+ add_work(Ls, queue__put(L, Q), sets:add_element(L, Set))
+ end;
+add_work([], Q, Set) ->
+ {Q, Set}.
+
+take_work({Queue0, Set0}) ->
+ case queue__get(Queue0) of
+ {ok, L, Queue1} ->
+ Set1 = sets:del_element(L, Set0),
+ {ok, L, {Queue1, Set1}};
+ empty ->
+ none
+ end.
+
+get_deps(L, Dep) ->
+ case dict:find(L, Dep) of
+ {ok, Ls} -> Ls;
+ error -> []
+ end.
+
+%% Type information for built-in functions. We do not check that the
+%% arguments have the correct type; if the call would actually fail,
+%% rather than return a value, this is a safe overapproximation.
+
+primop_type(match_fail, 1, _) -> t_none();
+primop_type(_, _, Xs) -> strict(Xs, t_any()).
+
+call_type(M, F, A, Xs) ->
+ erl_bif_types:type(M, F, A, Xs).
+
+guard_filters(T, Env) ->
+ guard_filters(T, Env, dict:new()).
+
+guard_filters(T, Env, Vars) ->
+ case type(T) of
+ call ->
+ M = call_module(T),
+ F = call_name(T),
+ case is_c_atom(M) andalso is_c_atom(F) of
+ true ->
+ As = call_args(T),
+ case {atom_val(M), atom_val(F), length(As)} of
+ {erlang, 'and', 2} ->
+ [A1, A2] = As,
+ guard_filters(A1, guard_filters(A2, Env));
+ {erlang, is_atom, 1} ->
+ filter(As, t_atom(), Env);
+ {erlang, is_binary, 1} ->
+ filter(As, t_binary(), Env);
+ {erlang, is_float, 1} ->
+ filter(As, t_float(), Env);
+ {erlang, is_function, 1} ->
+ filter(As, t_fun(), Env);
+ {erlang, is_integer, 1} ->
+ filter(As, t_integer(), Env);
+ {erlang, is_list, 1} ->
+ filter(As, t_maybe_improper_list(), Env);
+ {erlang, is_number, 1} ->
+ filter(As, t_number(), Env);
+ {erlang, is_pid, 1} ->
+ filter(As, t_pid(), Env);
+ {erlang, is_port, 1} ->
+ filter(As, t_port(), Env);
+ {erlang, is_reference, 1} ->
+ filter(As, t_reference(), Env);
+ {erlang, is_tuple, 1} ->
+ filter(As, t_tuple(), Env);
+ _ ->
+ Env
+ end;
+ false ->
+ Env
+ end;
+ var ->
+ case dict:find(var_name(T), Vars) of
+ {ok, T1} ->
+ guard_filters(T1, Env, Vars);
+ error ->
+ Env
+ end;
+ 'let' ->
+ case let_vars(T) of
+ [V] ->
+ guard_filters(let_body(T), Env,
+ dict:store(var_name(V), let_arg(T),
+ Vars));
+ _ ->
+ Env
+ end;
+ values ->
+ case values_es(T) of
+ [T1] ->
+ guard_filters(T1, Env, Vars);
+ _ ->
+ Env
+ end;
+ _ ->
+ Env
+ end.
+
+filter(As, X, Env) ->
+ [A] = As,
+ case type(A) of
+ var ->
+ V = var_name(A),
+ case dict:find(V, Env) of
+ {ok, X1} ->
+ dict:store(V, meet(X, X1), Env);
+ error ->
+ dict:store(V, X, Env)
+ end;
+ _ ->
+ Env
+ end.
+
+%% Callback hook for cerl_prettypr:
+
+-spec pp_hook() -> fun((cerl:cerl(), _, fun((_,_) -> any())) -> any()).
+
+pp_hook() ->
+ fun pp_hook/3.
+
+pp_hook(Node, Ctxt, Cont) ->
+ As = cerl:get_ann(Node),
+ As1 = proplists:delete(type, proplists:delete(label, As)),
+ As2 = proplists:delete(typesig, proplists:delete(file, As1)),
+ D = Cont(cerl:set_ann(Node, []), Ctxt),
+ T = case proplists:lookup(type, As) of
+ {type, T0} -> T0;
+ none ->
+ case proplists:lookup(typesig, As) of
+ {typesig, T0} -> T0;
+ none -> t_any()
+ end
+ end,
+ D1 = case erl_types:t_is_any(T) of
+ true ->
+ D;
+ false ->
+ case cerl:is_literal(Node) of
+ true ->
+ D;
+ false ->
+ S = erl_types:t_to_string(T),
+ Q = prettypr:beside(prettypr:text("::"),
+ prettypr:text(S)),
+ prettypr:beside(D, Q)
+ end
+ end,
+ cerl_prettypr:annotate(D1, As2, Ctxt).
+
+%% =====================================================================
diff --git a/lib/hipe/cerl/erl_bif_types.erl b/lib/hipe/cerl/erl_bif_types.erl
new file mode 100644
index 0000000000..0f57a93a7c
--- /dev/null
+++ b/lib/hipe/cerl/erl_bif_types.erl
@@ -0,0 +1,5021 @@
+%% -*- erlang-indent-level: 2 -*-
+%%
+%% %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%
+%%
+%% =====================================================================
+%% Type information for Erlang Built-in functions (implemented in C)
+%%
+%% Copyright (C) 2002 Richard Carlsson
+%% Copyright (C) 2006 Richard Carlsson, Tobias Lindahl and Kostis Sagonas
+%%
+%% Author contact: [email protected], [email protected], [email protected]
+%% =====================================================================
+
+-module(erl_bif_types).
+
+%-define(BITS, (hipe_rtl_arch:word_size() * 8) - ?TAG_IMMED1_SIZE).
+-define(BITS, 128). %This is only in bsl to convert answer to pos_inf/neg_inf.
+-define(TAG_IMMED1_SIZE, 4).
+
+-export([type/3, type/4, arg_types/3,
+ is_known/3, structure_inspecting_args/3, infinity_add/2]).
+
+-import(erl_types, [number_max/1,
+ number_min/1,
+ t_any/0,
+ t_arity/0,
+ t_atom/0,
+ t_atom/1,
+ t_atoms/1,
+ t_atom_vals/1,
+ t_binary/0,
+ t_bitstr/0,
+ t_boolean/0,
+ t_byte/0,
+ t_char/0,
+ t_cons/0,
+ t_cons/2,
+ t_cons_hd/1,
+ t_cons_tl/1,
+ t_constant/0,
+ t_fixnum/0,
+ t_non_neg_fixnum/0,
+ t_pos_fixnum/0,
+ t_float/0,
+ t_from_range/2,
+ t_from_term/1,
+ t_fun/0,
+ t_fun/2,
+ t_fun_args/1,
+ t_fun_range/1,
+ t_identifier/0,
+ t_inf/2,
+ t_integer/0,
+ t_integer/1,
+ t_non_neg_fixnum/0,
+ t_non_neg_integer/0,
+ t_pos_integer/0,
+ t_integers/1,
+ t_iodata/0,
+ t_iolist/0,
+ t_is_any/1,
+ t_is_atom/1,
+ t_is_binary/1,
+ t_is_bitstr/1,
+ t_is_boolean/1,
+ t_is_cons/1,
+ t_is_constant/1,
+ t_is_float/1,
+ t_is_float/1,
+ t_is_fun/1,
+ t_is_integer/1,
+ t_is_integer/1,
+ t_is_list/1,
+ t_is_nil/1,
+ t_is_none/1,
+ t_is_none_or_unit/1,
+ t_is_number/1,
+ t_is_pid/1,
+ t_is_port/1,
+ t_is_maybe_improper_list/1,
+ t_is_reference/1,
+ t_is_string/1,
+ t_is_subtype/2,
+ t_is_tuple/1,
+ t_list/0,
+ t_list/1,
+ t_list_elements/1,
+ t_list_termination/1,
+ t_mfa/0,
+ t_nil/0,
+ t_node/0,
+ t_none/0,
+ t_nonempty_list/0,
+ t_nonempty_list/1,
+ t_number/0,
+ t_number_vals/1,
+ t_pid/0,
+ t_port/0,
+ t_maybe_improper_list/0,
+ t_reference/0,
+ t_string/0,
+ t_subtract/2,
+ t_sup/1,
+ t_sup/2,
+ t_tid/0,
+ t_timeout/0,
+ t_tuple/0,
+ t_tuple/1,
+ t_tuple_args/1,
+ t_tuple_size/1,
+ t_tuple_subtypes/1
+ ]).
+
+-ifdef(DO_ERL_BIF_TYPES_TEST).
+-export([test/0]).
+-endif.
+
+%%=============================================================================
+
+-spec type(atom(), atom(), arity()) -> erl_types:erl_type().
+
+type(M, F, A) ->
+ type(M, F, A, any_list(A)).
+
+%% Arguments should be checked for undefinedness, so we do not make
+%% unnecessary overapproximations.
+
+-spec type(atom(), atom(), arity(), [erl_types:erl_type()]) -> erl_types:erl_type().
+
+%%-- code ---------------------------------------------------------------------
+type(code, add_path, 1, Xs) ->
+ strict(arg_types(code, add_path, 1), Xs,
+ fun (_) ->
+ t_sup(t_boolean(),
+ t_tuple([t_atom('error'), t_atom('bad_directory')]))
+ end);
+type(code, add_patha, 1, Xs) ->
+ type(code, add_path, 1, Xs);
+type(code, add_paths, 1, Xs) ->
+ strict(arg_types(code, add_paths, 1), Xs, fun(_) -> t_atom('ok') end);
+type(code, add_pathsa, 1, Xs) ->
+ type(code, add_paths, 1, Xs);
+type(code, add_pathsz, 1, Xs) ->
+ type(code, add_paths, 1, Xs);
+type(code, add_pathz, 1, Xs) ->
+ type(code, add_path, 1, Xs);
+type(code, all_loaded, 0, _) ->
+ t_list(t_tuple([t_atom(), t_code_loaded_fname_or_status()]));
+type(code, compiler_dir, 0, _) ->
+ t_string();
+type(code, del_path, 1, Xs) ->
+ strict(arg_types(code, del_path, 1), Xs,
+ fun (_) ->
+ t_sup(t_boolean(),
+ t_tuple([t_atom('error'), t_atom('bad_name')]))
+ end);
+type(code, delete, 1, Xs) ->
+ strict(arg_types(code, delete, 1), Xs, fun (_) -> t_boolean() end);
+type(code, ensure_loaded, 1, Xs) ->
+ type(code, load_file, 1, Xs);
+type(code, get_chunk, 2, Xs) ->
+ strict(arg_types(code, get_chunk, 2), Xs,
+ fun (_) -> t_sup(t_binary(), t_atom('undefined')) end);
+type(code, get_object_code, 1, Xs) ->
+ strict(arg_types(code, get_object_code, 1), Xs,
+ fun (_) ->
+ t_sup(t_tuple([t_atom(), t_binary(), t_string()]),
+ t_atom('error'))
+ end);
+type(code, get_path, 0, _) ->
+ t_list(t_string());
+type(code, is_loaded, 1, Xs) ->
+ strict(arg_types(code, is_loaded, 1), Xs,
+ fun (_) ->
+ t_sup([t_tuple([t_atom('file'), t_code_loaded_fname_or_status()]),
+ t_atom('false')])
+ end);
+type(code, is_sticky, 1, Xs) ->
+ strict(arg_types(code, is_sticky, 1), Xs, fun (_) -> t_boolean() end);
+type(code, is_module_native, 1, Xs) ->
+ strict(arg_types(code, is_module_native, 1), Xs,
+ fun (_) -> t_sup(t_boolean(), t_atom('undefined')) end);
+type(code, lib_dir, 0, _) ->
+ t_string();
+type(code, lib_dir, 1, Xs) ->
+ strict(arg_types(code, lib_dir, 1), Xs,
+ fun (_) ->
+ t_sup(t_string(),
+ t_tuple([t_atom('error'), t_atom('bad_name')]))
+ end);
+type(code, load_abs, 1, Xs) ->
+ strict(arg_types(code, load_abs, 1), Xs,
+ fun ([_File]) -> t_code_load_return(t_atom()) end); % XXX: cheating
+type(code, load_abs, 2, Xs) ->
+ strict(arg_types(code, load_abs, 2), Xs,
+ fun ([_File,Mod]) -> t_code_load_return(Mod) end);
+type(code, load_binary, 3, Xs) ->
+ strict(arg_types(code, load_binary, 3), Xs,
+ fun ([Mod,_File,_Bin]) -> t_code_load_return(Mod) end);
+type(code, load_file, 1, Xs) ->
+ strict(arg_types(code, load_file, 1), Xs,
+ fun ([Mod]) -> t_code_load_return(Mod) end);
+type(code, load_native_partial, 2, Xs) ->
+ strict(arg_types(code, load_native_partial, 2), Xs,
+ fun ([Mod,_Bin]) -> t_code_load_return(Mod) end);
+type(code, load_native_sticky, 3, Xs) ->
+ strict(arg_types(code, load_native_sticky, 3), Xs,
+ fun ([Mod,_Bin,_]) -> t_code_load_return(Mod) end);
+type(code, module_md5, 1, Xs) ->
+ strict(arg_types(code, module_md5, 1), Xs,
+ fun (_) -> t_sup(t_binary(), t_atom('undefined')) end);
+type(code, make_stub_module, 3, Xs) ->
+ strict(arg_types(code, make_stub_module, 3), Xs, fun ([Mod,_,_]) -> Mod end);
+type(code, priv_dir, 1, Xs) ->
+ strict(arg_types(code, priv_dir, 1), Xs,
+ fun (_) ->
+ t_sup(t_string(), t_tuple([t_atom('error'), t_atom('bad_name')]))
+ end);
+type(code, purge, 1, Xs) ->
+ type(code, delete, 1, Xs);
+type(code, rehash, 0, _) -> t_atom('ok');
+type(code, replace_path, 2, Xs) ->
+ strict(arg_types(code, replace_path, 2), Xs,
+ fun (_) ->
+ t_sup([t_atom('true'),
+ t_tuple([t_atom('error'), t_atom('bad_name')]),
+ t_tuple([t_atom('error'), t_atom('bad_directory')]),
+ t_tuple([t_atom('error'),
+ t_tuple([t_atom('badarg'), t_any()])])])
+ end);
+type(code, root_dir, 0, _) ->
+ t_string();
+type(code, set_path, 1, Xs) ->
+ strict(arg_types(code, set_path, 1), Xs,
+ fun (_) ->
+ t_sup([t_atom('true'),
+ t_tuple([t_atom('error'), t_atom('bad_path')]),
+ t_tuple([t_atom('error'), t_atom('bad_directory')])])
+ end);
+type(code, soft_purge, 1, Xs) ->
+ type(code, delete, 1, Xs);
+type(code, stick_mod, 1, Xs) ->
+ strict(arg_types(code, stick_mod, 1), Xs, fun (_) -> t_atom('true') end);
+type(code, unstick_mod, 1, Xs) ->
+ type(code, stick_mod, 1, Xs);
+type(code, which, 1, Xs) ->
+ strict(arg_types(code, which, 1), Xs,
+ fun (_) ->
+ t_sup([t_code_loaded_fname_or_status(),
+ t_atom('non_existing')])
+ end);
+%%-- erl_ddll -----------------------------------------------------------------
+type(erl_ddll, demonitor, 1, Xs) ->
+ type(erlang, demonitor, 1, Xs);
+type(erl_ddll, format_error_int, 1, Xs) ->
+ strict(arg_types(erl_ddll, format_error_int, 1), Xs,
+ fun (_) -> t_string() end);
+type(erl_ddll, info, 2, Xs) ->
+ strict(arg_types(erl_ddll, info, 2), Xs, fun (_) -> t_atom() end);
+type(erl_ddll, loaded_drivers, 0, _) ->
+ t_tuple([t_atom('ok'), t_list(t_string())]);
+type(erl_ddll, monitor, 2, Xs) -> % return type is the same, though args are not
+ type(erlang, monitor, 2, Xs);
+type(erl_ddll, try_load, 3, Xs) ->
+ strict(arg_types(erl_ddll, try_load, 3), Xs,
+ fun (_) ->
+ t_sup([t_tuple([t_atom('ok'), t_atom('already_loaded')]),
+ t_tuple([t_atom('ok'), t_atom('loaded')]),
+ t_tuple([t_atom('ok'),
+ t_atom('pending_driver'), t_reference()]),
+ t_tuple([t_atom('error'), t_atom('inconsistent')]),
+ t_tuple([t_atom('error'), t_atom('permanent')])])
+ end);
+type(erl_ddll, try_unload, 2, Xs) ->
+ strict(arg_types(erl_ddll, try_unload, 2), Xs,
+ fun (_) ->
+ t_sup([t_tuple([t_atom('ok'), t_atom('pending_process')]),
+ t_tuple([t_atom('ok'), t_atom('unloaded')]),
+ t_tuple([t_atom('ok'), t_atom('pending_driver')]),
+ t_tuple([t_atom('ok'),
+ t_atom('pending_driver'), t_reference()]),
+ t_tuple([t_atom('error'), t_atom('permanent')]),
+ t_tuple([t_atom('error'), t_atom('not_loaded')]),
+ t_tuple([t_atom('error'),
+ t_atom('not_loaded_by_this_process')])])
+ end);
+%%-- erlang -------------------------------------------------------------------
+type(erlang, halt, 0, _) -> t_none();
+type(erlang, halt, 1, _) -> t_none();
+type(erlang, exit, 1, _) -> t_none();
+%% Note that exit/2 sends an exit signal to another process.
+type(erlang, exit, 2, _) -> t_atom('true');
+type(erlang, error, 1, _) -> t_none();
+type(erlang, error, 2, _) -> t_none();
+type(erlang, throw, 1, _) -> t_none();
+type(erlang, hibernate, 3, _) -> t_none();
+type(erlang, '==', 2, Xs = [X1, X2]) ->
+ case t_is_atom(X1) andalso t_is_atom(X2) of
+ true -> type(erlang, '=:=', 2, Xs);
+ false ->
+ case t_is_integer(X1) andalso t_is_integer(X2) of
+ true -> type(erlang, '=:=', 2, Xs);
+ false -> strict(Xs, t_boolean())
+ end
+ end;
+type(erlang, '/=', 2, Xs = [X1, X2]) ->
+ case t_is_atom(X1) andalso t_is_atom(X2) of
+ true -> type(erlang, '=/=', 2, Xs);
+ false ->
+ case t_is_integer(X1) andalso t_is_integer(X2) of
+ true -> type(erlang, '=/=', 2, Xs);
+ false -> strict(Xs, t_boolean())
+ end
+ end;
+type(erlang, '=:=', 2, Xs = [Lhs, Rhs]) ->
+ Ans =
+ case t_is_none(t_inf(Lhs, Rhs)) of
+ true -> t_atom('false');
+ false ->
+ case t_is_atom(Lhs) andalso t_is_atom(Rhs) of
+ true ->
+ case {t_atom_vals(Lhs), t_atom_vals(Rhs)} of
+ {unknown, _} -> t_boolean();
+ {_, unknown} -> t_boolean();
+ {[X], [X]} -> t_atom('true');
+ {LhsVals, RhsVals} ->
+ case lists:all(fun({X, Y}) -> X =/= Y end,
+ [{X, Y} || X <- LhsVals, Y <- RhsVals]) of
+ true -> t_atom('false');
+ false -> t_boolean()
+ end
+ end;
+ false ->
+ case t_is_integer(Lhs) andalso t_is_integer(Rhs) of
+ false -> t_boolean();
+ true ->
+ case {t_number_vals(Lhs), t_number_vals(Rhs)} of
+ {[X], [X]} when is_integer(X) -> t_atom('true');
+ _ ->
+ LhsMax = number_max(Lhs),
+ LhsMin = number_min(Lhs),
+ RhsMax = number_max(Rhs),
+ RhsMin = number_min(Rhs),
+ Ans1 = (is_integer(LhsMin)
+ andalso is_integer(RhsMax)
+ andalso (LhsMin > RhsMax)),
+ Ans2 = (is_integer(LhsMax)
+ andalso is_integer(RhsMin)
+ andalso (RhsMin > LhsMax)),
+ case Ans1 orelse Ans2 of
+ true -> t_atom('false');
+ false -> t_boolean()
+ end
+ end
+ end
+ end
+ end,
+ strict(Xs, Ans);
+type(erlang, '=/=', 2, Xs = [Lhs, Rhs]) ->
+ Ans =
+ case t_is_none(t_inf(Lhs, Rhs)) of
+ true -> t_atom('true');
+ false ->
+ case t_is_atom(Lhs) andalso t_is_atom(Rhs) of
+ true ->
+ case {t_atom_vals(Lhs), t_atom_vals(Rhs)} of
+ {unknown, _} -> t_boolean();
+ {_, unknown} -> t_boolean();
+ {[Val], [Val]} -> t_atom('false');
+ {LhsVals, RhsVals} ->
+ t_sup([t_from_term(X =/= Y) || X <- LhsVals, Y <- RhsVals])
+ end;
+ false ->
+ case t_is_integer(Lhs) andalso t_is_integer(Rhs) of
+ false -> t_boolean();
+ true ->
+ LhsMax = number_max(Lhs),
+ LhsMin = number_min(Lhs),
+ RhsMax = number_max(Rhs),
+ RhsMin = number_min(Rhs),
+ Ans1 = (is_integer(LhsMin) andalso is_integer(RhsMax)
+ andalso (LhsMin > RhsMax)),
+ Ans2 = (is_integer(LhsMax) andalso is_integer(RhsMin)
+ andalso (RhsMin > LhsMax)),
+ case Ans1 orelse Ans2 of
+ true -> t_atom('true');
+ false ->
+ if LhsMax =:= LhsMin,
+ RhsMin =:= RhsMax,
+ RhsMax =:= LhsMax -> t_atom('false');
+ true -> t_boolean()
+ end
+ end
+ end
+ end
+ end,
+ strict(Xs, Ans);
+type(erlang, '>', 2, Xs = [Lhs, Rhs]) ->
+ Ans =
+ case t_is_integer(Lhs) andalso t_is_integer(Rhs) of
+ true ->
+ LhsMax = number_max(Lhs),
+ LhsMin = number_min(Lhs),
+ RhsMax = number_max(Rhs),
+ RhsMin = number_min(Rhs),
+ T = t_atom('true'),
+ F = t_atom('false'),
+ if
+ is_integer(LhsMin), is_integer(RhsMax), LhsMin > RhsMax -> T;
+ is_integer(LhsMax), is_integer(RhsMin), RhsMin >= LhsMax -> F;
+ true -> t_boolean()
+ end;
+ false -> t_boolean()
+ end,
+ strict(Xs, Ans);
+type(erlang, '>=', 2, Xs = [Lhs, Rhs]) ->
+ Ans =
+ case t_is_integer(Lhs) andalso t_is_integer(Rhs) of
+ true ->
+ LhsMax = number_max(Lhs),
+ LhsMin = number_min(Lhs),
+ RhsMax = number_max(Rhs),
+ RhsMin = number_min(Rhs),
+ T = t_atom('true'),
+ F = t_atom('false'),
+ if
+ is_integer(LhsMin), is_integer(RhsMax), LhsMin >= RhsMax -> T;
+ is_integer(LhsMax), is_integer(RhsMin), RhsMin > LhsMax -> F;
+ true -> t_boolean()
+ end;
+ false -> t_boolean()
+ end,
+ strict(Xs, Ans);
+type(erlang, '<', 2, Xs = [Lhs, Rhs]) ->
+ Ans =
+ case t_is_integer(Lhs) andalso t_is_integer(Rhs) of
+ true ->
+ LhsMax = number_max(Lhs),
+ LhsMin = number_min(Lhs),
+ RhsMax = number_max(Rhs),
+ RhsMin = number_min(Rhs),
+ T = t_atom('true'),
+ F = t_atom('false'),
+ if
+ is_integer(LhsMax), is_integer(RhsMin), LhsMax < RhsMin -> T;
+ is_integer(LhsMin), is_integer(RhsMax), RhsMax =< LhsMin -> F;
+ true -> t_boolean()
+ end;
+ false -> t_boolean()
+ end,
+ strict(Xs, Ans);
+type(erlang, '=<', 2, Xs = [Lhs, Rhs]) ->
+ Ans =
+ case t_is_integer(Lhs) andalso t_is_integer(Rhs) of
+ true ->
+ LhsMax = number_max(Lhs),
+ LhsMin = number_min(Lhs),
+ RhsMax = number_max(Rhs),
+ RhsMin = number_min(Rhs),
+ T = t_atom('true'),
+ F = t_atom('false'),
+ if
+ is_integer(LhsMax), is_integer(RhsMin), LhsMax =< RhsMin -> T;
+ is_integer(LhsMin), is_integer(RhsMax), RhsMax < LhsMin -> F;
+ true -> t_boolean()
+ end;
+ false -> t_boolean()
+ end,
+ strict(Xs, Ans);
+type(erlang, '+', 1, Xs) ->
+ strict(arg_types(erlang, '+', 1), Xs,
+ fun ([X]) -> X end);
+type(erlang, '-', 1, Xs) ->
+ strict(arg_types(erlang, '-', 1), Xs,
+ fun ([X]) ->
+ case t_is_integer(X) of
+ true -> type(erlang, '-', 2, [t_integer(0), X]);
+ false -> X
+ end
+ end);
+type(erlang, '!', 2, Xs) ->
+ strict(arg_types(erlang, '!', 2), Xs, fun ([_, X2]) -> X2 end);
+type(erlang, '+', 2, Xs) ->
+ strict(arg_types(erlang, '+', 2), Xs,
+ fun ([X1, X2]) ->
+ case arith('+', X1, X2) of
+ {ok, T} -> T;
+ error ->
+ case t_is_float(X1) orelse t_is_float(X2) of
+ true -> t_float();
+ false -> t_number()
+ end
+ end
+ end);
+type(erlang, '-', 2, Xs) ->
+ strict(arg_types(erlang, '-', 2), Xs,
+ fun ([X1, X2]) ->
+ case arith('-', X1, X2) of
+ {ok, T} -> T;
+ error ->
+ case t_is_float(X1) orelse t_is_float(X2) of
+ true -> t_float();
+ false -> t_number()
+ end
+ end
+ end);
+type(erlang, '*', 2, Xs) ->
+ strict(arg_types(erlang, '*', 2), Xs,
+ fun ([X1, X2]) ->
+ case arith('*', X1, X2) of
+ {ok, T} -> T;
+ error ->
+ case t_is_float(X1) orelse t_is_float(X2) of
+ true -> t_float();
+ false -> t_number()
+ end
+ end
+ end);
+type(erlang, '/', 2, Xs) ->
+ strict(arg_types(erlang, '/', 2), Xs,
+ fun (_) -> t_float() end);
+type(erlang, 'div', 2, Xs) ->
+ strict(arg_types(erlang, 'div', 2), Xs,
+ fun ([X1, X2]) ->
+ case arith('div', X1, X2) of
+ error -> t_integer();
+ {ok, T} -> T
+ end
+ end);
+type(erlang, 'rem', 2, Xs) ->
+ strict(arg_types(erlang, 'rem', 2), Xs,
+ fun ([X1, X2]) ->
+ case arith('rem', X1, X2) of
+ error -> t_non_neg_integer();
+ {ok, T} -> T
+ end
+ end);
+type(erlang, '++', 2, Xs) ->
+ strict(arg_types(erlang, '++', 2), Xs,
+ fun ([X1, X2]) ->
+ case t_is_nil(X1) of
+ true -> X2; % even if X2 is not a list
+ false ->
+ case t_is_nil(X2) of
+ true -> X1;
+ false ->
+ E1 = t_list_elements(X1),
+ case t_is_cons(X1) of
+ true -> t_cons(E1, X2);
+ false ->
+ t_sup(X2, t_cons(E1, X2))
+ end
+ end
+ end
+ end);
+type(erlang, '--', 2, Xs) ->
+ %% We don't know which elements (if any) in X2 will be found and
+ %% removed from X1, even if they would have the same type. Thus, we
+ %% must assume that X1 can remain unchanged. However, if we succeed,
+ %% we know that X1 must be a proper list, but the result could
+ %% possibly be empty even if X1 is nonempty.
+ strict(arg_types(erlang, '--', 2), Xs,
+ fun ([X1, X2]) ->
+ case t_is_nil(X1) of
+ true -> t_nil();
+ false ->
+ case t_is_nil(X2) of
+ true -> X1;
+ false -> t_list(t_list_elements(X1))
+ end
+ end
+ end);
+type(erlang, 'and', 2, Xs) ->
+ strict(arg_types(erlang, 'and', 2), Xs, fun (_) -> t_boolean() end);
+type(erlang, 'or', 2, Xs) ->
+ strict(arg_types(erlang, 'or', 2), Xs, fun (_) -> t_boolean() end);
+type(erlang, 'xor', 2, Xs) ->
+ strict(arg_types(erlang, 'xor', 2), Xs, fun (_) -> t_boolean() end);
+type(erlang, 'not', 1, Xs) ->
+ strict(arg_types(erlang, 'not', 1), Xs, fun (_) -> t_boolean() end);
+type(erlang, 'band', 2, Xs) ->
+ strict(arg_types(erlang, 'band', 2), Xs,
+ fun ([X1, X2]) ->
+ case arith('band', X1, X2) of
+ error -> t_integer();
+ {ok, T} -> T
+ end
+ end);
+%% The result is not wider than the smallest argument. We need to
+%% kill any value-sets in the result.
+%% strict(arg_types(erlang, 'band', 2), Xs,
+%% fun ([X1, X2]) -> t_sup(t_inf(X1, X2), t_byte()) end);
+type(erlang, 'bor', 2, Xs) ->
+ strict(arg_types(erlang, 'bor', 2), Xs,
+ fun ([X1, X2]) ->
+ case arith('bor', X1, X2) of
+ error -> t_integer();
+ {ok, T} -> T
+ end
+ end);
+%% The result is not wider than the largest argument. We need to
+%% kill any value-sets in the result.
+%% strict(arg_types(erlang, 'bor', 2), Xs,
+%% fun ([X1, X2]) -> t_sup(t_sup(X1, X2), t_byte()) end);
+type(erlang, 'bxor', 2, Xs) ->
+ strict(arg_types(erlang, 'bxor', 2), Xs,
+ fun ([X1, X2]) ->
+ case arith('bxor', X1, X2) of
+ error -> t_integer();
+ {ok, T} -> T
+ end
+ end);
+%% The result is not wider than the largest argument. We need to
+%% kill any value-sets in the result.
+%% strict(arg_types(erlang, 'bxor', 2), Xs,
+%% fun ([X1, X2]) -> t_sup(t_sup(X1, X2), t_byte()) end);
+type(erlang, 'bsr', 2, Xs) ->
+ strict(arg_types(erlang, 'bsr', 2), Xs,
+ fun ([X1, X2]) ->
+ case arith('bsr', X1, X2) of
+ error -> t_integer();
+ {ok, T} -> T
+ end
+ end);
+%% If the first argument is unsigned (which is the case for
+%% characters and bytes), the result is never wider. We need to kill
+%% any value-sets in the result.
+%% strict(arg_types(erlang, 'bsr', 2), Xs,
+%% fun ([X, _]) -> t_sup(X, t_byte()) end);
+type(erlang, 'bsl', 2, Xs) ->
+ strict(arg_types(erlang, 'bsl', 2), Xs,
+ fun ([X1, X2]) ->
+ case arith('bsl', X1, X2) of
+ error -> t_integer();
+ {ok, T} -> T
+ end
+ end);
+%% Not worth doing anything special here.
+%% strict(arg_types(erlang, 'bsl', 2), Xs, fun (_) -> t_integer() end);
+type(erlang, 'bnot', 1, Xs) ->
+ strict(arg_types(erlang, 'bnot', 1), Xs,
+ fun ([X1]) ->
+ case arith('bnot', X1) of
+ error -> t_integer();
+ {ok, T} -> T
+ end
+ end);
+%% This returns (-X)-1, so it often gives a negative result.
+%% strict(arg_types(erlang, 'bnot', 1), Xs, fun (_) -> t_integer() end);
+type(erlang, abs, 1, Xs) ->
+ strict(arg_types(erlang, abs, 1), Xs, fun ([X]) -> X end);
+type(erlang, append_element, 2, Xs) ->
+ strict(arg_types(erlang, append_element, 2), Xs, fun (_) -> t_tuple() end);
+type(erlang, apply, 2, Xs) ->
+ Fun = fun ([X, _Y]) ->
+ case t_is_fun(X) of
+ true ->
+ t_fun_range(X);
+ false ->
+ t_any()
+ end
+ end,
+ strict(arg_types(erlang, apply, 2), Xs, Fun);
+type(erlang, apply, 3, Xs) ->
+ strict(arg_types(erlang, apply, 3), Xs, fun (_) -> t_any() end);
+type(erlang, atom_to_binary, 2, Xs) ->
+ strict(arg_types(erlang, atom_to_binary, 2), Xs, fun (_) -> t_binary() end);
+type(erlang, atom_to_list, 1, Xs) ->
+ strict(arg_types(erlang, atom_to_list, 1), Xs, fun (_) -> t_string() end);
+type(erlang, binary_to_atom, 2, Xs) ->
+ strict(arg_types(erlang, binary_to_atom, 2), Xs, fun (_) -> t_atom() end);
+type(erlang, binary_to_existing_atom, 2, Xs) ->
+ type(erlang, binary_to_atom, 2, Xs);
+type(erlang, binary_to_list, 1, Xs) ->
+ strict(arg_types(erlang, binary_to_list, 1), Xs,
+ fun (_) -> t_list(t_byte()) end);
+type(erlang, binary_to_list, 3, Xs) ->
+ strict(arg_types(erlang, binary_to_list, 3), Xs,
+ fun (_) -> t_list(t_byte()) end);
+type(erlang, binary_to_term, 1, Xs) ->
+ strict(arg_types(erlang, binary_to_term, 1), Xs, fun (_) -> t_any() end);
+type(erlang, bitsize, 1, Xs) -> % XXX: TAKE OUT
+ type(erlang, bit_size, 1, Xs);
+type(erlang, bit_size, 1, Xs) ->
+ strict(arg_types(erlang, bit_size, 1), Xs,
+ fun (_) -> t_non_neg_integer() end);
+type(erlang, bitstr_to_list, 1, Xs) -> % XXX: TAKE OUT
+ type(erlang, bitstring_to_list, 1, Xs);
+type(erlang, bitstring_to_list, 1, Xs) ->
+ strict(arg_types(erlang, bitstring_to_list, 1), Xs,
+ fun (_) -> t_list(t_sup(t_byte(), t_bitstr())) end);
+type(erlang, bump_reductions, 1, Xs) ->
+ strict(arg_types(erlang, bump_reductions, 1), Xs,
+ fun (_) -> t_atom('true') end);
+type(erlang, byte_size, 1, Xs) ->
+ strict(arg_types(erlang, byte_size, 1), Xs,
+ fun (_) -> t_non_neg_integer() end);
+type(erlang, cancel_timer, 1, Xs) ->
+ strict(arg_types(erlang, cancel_timer, 1), Xs,
+ fun (_) -> t_sup(t_integer(), t_atom('false')) end);
+type(erlang, check_process_code, 2, Xs) ->
+ strict(arg_types(erlang, check_process_code, 2), Xs,
+ fun (_) -> t_boolean() end);
+type(erlang, concat_binary, 1, Xs) ->
+ strict(arg_types(erlang, concat_binary, 1), Xs, fun (_) -> t_binary() end);
+type(erlang, crc32, 1, Xs) ->
+ strict(arg_types(erlang, crc32, 1), Xs, fun (_) -> t_integer() end);
+type(erlang, crc32, 2, Xs) ->
+ strict(arg_types(erlang, crc32, 2), Xs, fun (_) -> t_integer() end);
+type(erlang, crc32_combine, 3, Xs) ->
+ strict(arg_types(erlang, crc32_combine, 3), Xs, fun (_) -> t_integer() end);
+type(erlang, date, 0, _) ->
+ t_date();
+type(erlang, decode_packet, 3, Xs) ->
+ strict(arg_types(erlang, decode_packet, 3), Xs,
+ fun (_) ->
+ t_sup([t_tuple([t_atom('ok'), t_packet(), t_binary()]),
+ t_tuple([t_atom('more'), t_sup([t_non_neg_integer(),
+ t_atom('undefined')])]),
+ t_tuple([t_atom('error'), t_any()])])
+ end);
+type(erlang, delete_module, 1, Xs) ->
+ strict(arg_types(erlang, delete_module, 1), Xs,
+ fun (_) -> t_sup(t_atom('true'), t_atom('undefined')) end);
+type(erlang, demonitor, 1, Xs) ->
+ strict(arg_types(erlang, demonitor, 1), Xs, fun (_) -> t_atom('true') end);
+%% TODO: overapproximation -- boolean only if 'info' is part of arg2 otherwise 'true'
+type(erlang, demonitor, 2, Xs) ->
+ strict(arg_types(erlang, demonitor, 2), Xs, fun (_) -> t_boolean() end);
+type(erlang, disconnect_node, 1, Xs) ->
+ strict(arg_types(erlang, disconnect_node, 1), Xs, fun (_) -> t_boolean() end);
+type(erlang, display, 1, _) -> t_atom('true');
+type(erlang, dist_exit, 3, Xs) ->
+ strict(arg_types(erlang, dist_exit, 3), Xs, fun (_) -> t_atom('true') end);
+type(erlang, element, 2, Xs) ->
+ strict(arg_types(erlang, element, 2), Xs,
+ fun ([X1, X2]) ->
+ case t_tuple_subtypes(X2) of
+ unknown -> t_any();
+ [_] ->
+ Sz = t_tuple_size(X2),
+ As = t_tuple_args(X2),
+ case t_number_vals(X1) of
+ unknown -> t_sup(As);
+ Ns when is_list(Ns) ->
+ Fun = fun
+ (N, X) when is_integer(N), 1 =< N, N =< Sz ->
+ t_sup(X, lists:nth(N, As));
+ (_, X) ->
+ X
+ end,
+ lists:foldl(Fun, t_none(), Ns)
+ end;
+ Ts when is_list(Ts) ->
+ t_sup([type(erlang, element, 2, [X1, Y]) || Y <- Ts])
+ end
+ end);
+type(erlang, erase, 0, _) -> t_any();
+type(erlang, erase, 1, _) -> t_any();
+type(erlang, external_size, 1, _) -> t_integer();
+type(erlang, float, 1, Xs) ->
+ strict(arg_types(erlang, float, 1), Xs, fun (_) -> t_float() end);
+type(erlang, float_to_list, 1, Xs) ->
+ strict(arg_types(erlang, float_to_list, 1), Xs, fun (_) -> t_string() end);
+type(erlang, function_exported, 3, Xs) ->
+ strict(arg_types(erlang, function_exported, 3), Xs,
+ fun (_) -> t_boolean() end);
+type(erlang, fun_info, 1, Xs) ->
+ strict(arg_types(erlang, fun_info, 1), Xs,
+ fun (_) -> t_list(t_tuple([t_atom(), t_any()])) end);
+type(erlang, fun_info, 2, Xs) ->
+ strict(arg_types(erlang, fun_info, 2), Xs,
+ fun (_) -> t_tuple([t_atom(), t_any()]) end);
+type(erlang, fun_to_list, 1, Xs) ->
+ strict(arg_types(erlang, fun_to_list, 1), Xs, fun (_) -> t_string() end);
+type(erlang, garbage_collect, 0, _) -> t_atom('true');
+type(erlang, garbage_collect, 1, Xs) ->
+ strict(arg_types(erlang, garbage_collect, 1), Xs, fun (_) -> t_boolean() end);
+type(erlang, get, 0, _) -> t_list(t_tuple(2));
+type(erlang, get, 1, _) -> t_any(); % | t_atom('undefined')
+type(erlang, get_cookie, 0, _) -> t_atom(); % | t_atom('nocookie')
+type(erlang, get_keys, 1, _) -> t_list();
+type(erlang, get_module_info, 1, Xs) ->
+ strict(arg_types(erlang, get_module_info, 1), Xs,
+ fun (_) ->
+ t_list(t_tuple([t_atom(), t_list(t_tuple([t_atom(), t_any()]))]))
+ end);
+type(erlang, get_module_info, 2, Xs) ->
+ T_module_info_2_returns =
+ t_sup([t_atom(),
+ t_list(t_tuple([t_atom(), t_any()])),
+ t_list(t_tuple([t_atom(), t_arity(), t_integer()]))]),
+ strict(arg_types(erlang, get_module_info, 2), Xs,
+ fun ([Module, Item]) ->
+ case t_is_atom(Item) of
+ true ->
+ case t_atom_vals(Item) of
+ ['module'] -> t_inf(t_atom(), Module);
+ ['imports'] -> t_nil();
+ ['exports'] -> t_list(t_tuple([t_atom(), t_arity()]));
+ ['functions'] -> t_list(t_tuple([t_atom(), t_arity()]));
+ ['attributes'] -> t_list(t_tuple([t_atom(), t_any()]));
+ ['compile'] -> t_list(t_tuple([t_atom(), t_any()]));
+ ['native_addresses'] -> % [{FunName, Arity, Address}]
+ t_list(t_tuple([t_atom(), t_arity(), t_integer()]));
+ List when is_list(List) ->
+ T_module_info_2_returns;
+ unknown ->
+ T_module_info_2_returns
+ end;
+ false ->
+ T_module_info_2_returns
+ end
+ end);
+type(erlang, get_stacktrace, 0, _) ->
+ t_list(t_tuple([t_atom(), t_atom(), t_sup([t_arity(), t_list()])]));
+type(erlang, group_leader, 0, _) -> t_pid();
+type(erlang, group_leader, 2, Xs) ->
+ strict(arg_types(erlang, group_leader, 2), Xs,
+ fun (_) -> t_atom('true') end);
+type(erlang, hash, 2, Xs) ->
+ strict(arg_types(erlang, hash, 2), Xs, fun (_) -> t_integer() end);
+type(erlang, hd, 1, Xs) ->
+ strict(arg_types(erlang, hd, 1), Xs, fun ([X]) -> t_cons_hd(X) end);
+type(erlang, integer_to_list, 1, Xs) ->
+ strict(arg_types(erlang, integer_to_list, 1), Xs,
+ fun (_) -> t_string() end);
+type(erlang, info, 1, Xs) -> type(erlang, system_info, 1, Xs); % alias
+type(erlang, iolist_size, 1, Xs) ->
+ strict(arg_types(erlang, iolist_size, 1), Xs,
+ fun (_) -> t_non_neg_integer() end);
+type(erlang, iolist_to_binary, 1, Xs) ->
+ strict(arg_types(erlang, iolist_to_binary, 1), Xs,
+ fun (_) -> t_binary() end);
+type(erlang, is_alive, 0, _) -> t_boolean();
+type(erlang, is_atom, 1, Xs) ->
+ Fun = fun (X) -> check_guard(X, fun (Y) -> t_is_atom(Y) end, t_atom()) end,
+ strict(arg_types(erlang, is_atom, 1), Xs, Fun);
+type(erlang, is_binary, 1, Xs) ->
+ Fun = fun (X) ->
+ check_guard(X, fun (Y) -> t_is_binary(Y) end, t_binary())
+ end,
+ strict(arg_types(erlang, is_binary, 1), Xs, Fun);
+type(erlang, is_bitstr, 1, Xs) -> % XXX: TAKE OUT
+ type(erlang, is_bitstring, 1, Xs);
+type(erlang, is_bitstring, 1, Xs) ->
+ Fun = fun (X) ->
+ check_guard(X, fun (Y) -> t_is_bitstr(Y) end, t_bitstr())
+ end,
+ strict(arg_types(erlang, is_bitstring, 1), Xs, Fun);
+type(erlang, is_boolean, 1, Xs) ->
+ Fun = fun (X) ->
+ check_guard(X, fun (Y) -> t_is_boolean(Y) end, t_boolean())
+ end,
+ strict(arg_types(erlang, is_boolean, 1), Xs, Fun);
+type(erlang, is_builtin, 3, Xs) ->
+ strict(arg_types(erlang, is_builtin, 3), Xs, fun (_) -> t_boolean() end);
+type(erlang, is_constant, 1, Xs) ->
+ Fun = fun (X) ->
+ check_guard(X, fun (Y) -> t_is_constant(Y) end, t_constant())
+ end,
+ strict(arg_types(erlang, is_constant, 1), Xs, Fun);
+type(erlang, is_float, 1, Xs) ->
+ Fun = fun (X) ->
+ check_guard(X, fun (Y) -> t_is_float(Y) end, t_float())
+ end,
+ strict(arg_types(erlang, is_float, 1), Xs, Fun);
+type(erlang, is_function, 1, Xs) ->
+ Fun = fun (X) -> check_guard(X, fun (Y) -> t_is_fun(Y) end, t_fun()) end,
+ strict(arg_types(erlang, is_function, 1), Xs, Fun);
+type(erlang, is_function, 2, Xs) ->
+ Fun = fun ([FunType, ArityType]) ->
+ case t_number_vals(ArityType) of
+ unknown -> t_boolean();
+ [Val] ->
+ FunConstr = t_fun(any_list(Val), t_any()),
+ Fun2 = fun (X) ->
+ t_is_subtype(X, FunConstr) andalso (not t_is_none(X))
+ end,
+ check_guard_single(FunType, Fun2, FunConstr);
+ IntList when is_list(IntList) -> t_boolean() %% true?
+ end
+ end,
+ strict(arg_types(erlang, is_function, 2), Xs, Fun);
+type(erlang, is_integer, 1, Xs) ->
+ Fun = fun (X) ->
+ check_guard(X, fun (Y) -> t_is_integer(Y) end, t_integer())
+ end,
+ strict(arg_types(erlang, is_integer, 1), Xs, Fun);
+type(erlang, is_list, 1, Xs) ->
+ Fun = fun (X) ->
+ Fun2 = fun (Y) -> t_is_maybe_improper_list(Y) end,
+ check_guard(X, Fun2, t_maybe_improper_list())
+ end,
+ strict(arg_types(erlang, is_list, 1), Xs, Fun);
+type(erlang, is_number, 1, Xs) ->
+ Fun = fun (X) ->
+ check_guard(X, fun (Y) -> t_is_number(Y) end, t_number())
+ end,
+ strict(arg_types(erlang, is_number, 1), Xs, Fun);
+type(erlang, is_pid, 1, Xs) ->
+ Fun = fun (X) -> check_guard(X, fun (Y) -> t_is_pid(Y) end, t_pid()) end,
+ strict(arg_types(erlang, is_pid, 1), Xs, Fun);
+type(erlang, is_port, 1, Xs) ->
+ Fun = fun (X) -> check_guard(X, fun (Y) -> t_is_port(Y) end, t_port()) end,
+ strict(arg_types(erlang, is_port, 1), Xs, Fun);
+type(erlang, is_process_alive, 1, Xs) ->
+ strict(arg_types(erlang, is_process_alive, 1), Xs,
+ fun (_) -> t_boolean() end);
+type(erlang, is_record, 2, Xs) ->
+ Fun = fun ([X, Y]) ->
+ case t_is_tuple(X) of
+ false ->
+ case t_is_none(t_inf(t_tuple(), X)) of
+ true -> t_atom('false');
+ false -> t_boolean()
+ end;
+ true ->
+ case t_tuple_subtypes(X) of
+ unknown -> t_boolean();
+ [Tuple] ->
+ case t_tuple_args(Tuple) of
+ %% any -> t_boolean();
+ [Tag|_] ->
+ case t_is_atom(Tag) of
+ false ->
+ TagAtom = t_inf(Tag, t_atom()),
+ case t_is_none(TagAtom) of
+ true -> t_atom('false');
+ false -> t_boolean()
+ end;
+ true ->
+ case t_atom_vals(Tag) of
+ [RealTag] ->
+ case t_atom_vals(Y) of
+ [RealTag] -> t_atom('true');
+ _ -> t_boolean()
+ end;
+ _ -> t_boolean()
+ end
+ end
+ end;
+ List when length(List) >= 2 ->
+ t_sup([type(erlang, is_record, 2, [T, Y]) || T <- List])
+ end
+ end
+ end,
+ strict(arg_types(erlang, is_record, 2), Xs, Fun);
+type(erlang, is_record, 3, Xs) ->
+ Fun = fun ([X, Y, Z]) ->
+ Arity = t_number_vals(Z),
+ case t_is_tuple(X) of
+ false when length(Arity) =:= 1 ->
+ [RealArity] = Arity,
+ case t_is_none(t_inf(t_tuple(RealArity), X)) of
+ true -> t_atom('false');
+ false -> t_boolean()
+ end;
+ false ->
+ case t_is_none(t_inf(t_tuple(), X)) of
+ true -> t_atom('false');
+ false -> t_boolean()
+ end;
+ true when length(Arity) =:= 1 ->
+ [RealArity] = Arity,
+ case t_tuple_subtypes(X) of
+ unknown -> t_boolean();
+ [Tuple] ->
+ case t_tuple_args(Tuple) of
+ %% any -> t_boolean();
+ Args when length(Args) =:= RealArity ->
+ Tag = hd(Args),
+ case t_is_atom(Tag) of
+ false ->
+ TagAtom = t_inf(Tag, t_atom()),
+ case t_is_none(TagAtom) of
+ true -> t_atom('false');
+ false -> t_boolean()
+ end;
+ true ->
+ case t_atom_vals(Tag) of
+ [RealTag] ->
+ case t_atom_vals(Y) of
+ [RealTag] -> t_atom('true');
+ _ -> t_boolean()
+ end;
+ _ -> t_boolean()
+ end
+ end;
+ Args when length(Args) =/= RealArity ->
+ t_atom('false')
+ end;
+ [_, _|_] ->
+ t_boolean()
+ end;
+ true ->
+ t_boolean()
+ end
+ end,
+ strict(arg_types(erlang, is_record, 3), Xs, Fun);
+type(erlang, is_reference, 1, Xs) ->
+ Fun = fun (X) ->
+ check_guard(X, fun (Y) -> t_is_reference(Y) end, t_reference())
+ end,
+ strict(arg_types(erlang, is_reference, 1), Xs, Fun);
+type(erlang, is_tuple, 1, Xs) ->
+ Fun = fun (X) ->
+ check_guard(X, fun (Y) -> t_is_tuple(Y) end, t_tuple())
+ end,
+ strict(arg_types(erlang, is_tuple, 1), Xs, Fun);
+type(erlang, length, 1, Xs) ->
+ strict(arg_types(erlang, length, 1), Xs, fun (_) -> t_non_neg_fixnum() end);
+type(erlang, link, 1, Xs) ->
+ strict(arg_types(erlang, link, 1), Xs, fun (_) -> t_atom('true') end);
+type(erlang, list_to_atom, 1, Xs) ->
+ strict(arg_types(erlang, list_to_atom, 1), Xs, fun (_) -> t_atom() end);
+type(erlang, list_to_binary, 1, Xs) ->
+ strict(arg_types(erlang, list_to_binary, 1), Xs,
+ fun (_) -> t_binary() end);
+type(erlang, list_to_bitstr, 1, Xs) ->
+ type(erlang, list_to_bitstring, 1, Xs);
+type(erlang, list_to_bitstring, 1, Xs) ->
+ strict(arg_types(erlang, list_to_bitstring, 1), Xs,
+ fun (_) -> t_bitstr() end);
+type(erlang, list_to_existing_atom, 1, Xs) ->
+ strict(arg_types(erlang, list_to_existing_atom, 1), Xs,
+ fun (_) -> t_atom() end);
+type(erlang, list_to_float, 1, Xs) ->
+ strict(arg_types(erlang, list_to_float, 1), Xs, fun (_) -> t_float() end);
+type(erlang, list_to_integer, 1, Xs) ->
+ strict(arg_types(erlang, list_to_integer, 1), Xs,
+ fun (_) -> t_integer() end);
+type(erlang, list_to_pid, 1, Xs) ->
+ strict(arg_types(erlang, list_to_pid, 1), Xs, fun (_) -> t_pid() end);
+type(erlang, list_to_tuple, 1, Xs) ->
+ strict(arg_types(erlang, list_to_tuple, 1), Xs, fun (_) -> t_tuple() end);
+type(erlang, loaded, 0, _) ->
+ t_list(t_atom());
+type(erlang, load_module, 2, Xs) ->
+ strict(arg_types(erlang, load_module, 2), Xs,
+ fun ([Mod,_Bin]) -> t_code_load_return(Mod) end);
+type(erlang, localtime, 0, Xs) ->
+ type(erlang, universaltime, 0, Xs); % same
+type(erlang, localtime_to_universaltime, 1, Xs) ->
+ type(erlang, universaltime_to_localtime, 1, Xs); % same
+type(erlang, localtime_to_universaltime, 2, Xs) ->
+ strict(arg_types(erlang, localtime_to_universaltime, 2), Xs, % typecheck
+ fun ([X,_]) -> type(erlang, localtime_to_universaltime, 1, [X]) end);
+type(erlang, make_fun, 3, Xs) ->
+ strict(arg_types(erlang, make_fun, 3), Xs,
+ fun ([_, _, Arity]) ->
+ case t_number_vals(Arity) of
+ [N] ->
+ case is_integer(N) andalso 0 =< N andalso N =< 255 of
+ true -> t_fun(N, t_any());
+ false -> t_none()
+ end;
+ _Other -> t_fun()
+ end
+ end);
+type(erlang, make_ref, 0, _) -> t_reference();
+type(erlang, make_tuple, 2, Xs) ->
+ strict(arg_types(erlang, make_tuple, 2), Xs,
+ fun ([Int, _]) ->
+ case t_number_vals(Int) of
+ [N] when is_integer(N), N >= 0 -> t_tuple(N);
+ _Other -> t_tuple()
+ end
+ end);
+type(erlang, make_tuple, 3, Xs) ->
+ strict(arg_types(erlang, make_tuple, 3), Xs,
+ fun ([Int, _, _]) ->
+ case t_number_vals(Int) of
+ [N] when is_integer(N), N >= 0 -> t_tuple(N);
+ _Other -> t_tuple()
+ end
+ end);
+type(erlang, match_spec_test, 3, Xs) ->
+ strict(arg_types(erlang, match_spec_test, 3), Xs,
+ fun (_) -> t_sup(t_tuple([t_atom('ok'),
+ t_any(), % it can be any term
+ t_list(t_atom('return_trace')),
+ t_match_spec_test_errors()]),
+ t_tuple([t_atom('error'),
+ t_match_spec_test_errors()])) end);
+type(erlang, md5, 1, Xs) ->
+ strict(arg_types(erlang, md5, 1), Xs, fun (_) -> t_binary() end);
+type(erlang, md5_final, 1, Xs) ->
+ strict(arg_types(erlang, md5_final, 1), Xs, fun (_) -> t_binary() end);
+type(erlang, md5_init, 0, _) -> t_binary();
+type(erlang, md5_update, 2, Xs) ->
+ strict(arg_types(erlang, md5_update, 2), Xs, fun (_) -> t_binary() end);
+type(erlang, memory, 0, _) -> t_list(t_tuple([t_atom(), t_non_neg_fixnum()]));
+type(erlang, memory, 1, Xs) ->
+ strict(arg_types(erlang, memory, 1), Xs,
+ fun ([Type]) ->
+ case t_is_atom(Type) of
+ true -> t_non_neg_fixnum();
+ false ->
+ case t_is_list(Type) of
+ true -> t_list(t_tuple([t_atom(), t_non_neg_fixnum()]));
+ false ->
+ t_sup(t_non_neg_fixnum(),
+ t_list(t_tuple([t_atom(), t_non_neg_fixnum()])))
+ end
+ end
+ end);
+type(erlang, module_loaded, 1, Xs) ->
+ strict(arg_types(erlang, module_loaded, 1), Xs, fun (_) -> t_boolean() end);
+type(erlang, monitor, 2, Xs) ->
+ strict(arg_types(erlang, monitor, 2), Xs, fun (_) -> t_reference() end);
+type(erlang, monitor_node, 2, Xs) ->
+ strict(arg_types(erlang, monitor_node, 2), Xs,
+ fun (_) -> t_atom('true') end);
+type(erlang, monitor_node, 3, Xs) ->
+ strict(arg_types(erlang, monitor_node, 3), Xs,
+ fun (_) -> t_atom('true') end);
+type(erlang, node, 0, _) -> t_node();
+type(erlang, node, 1, Xs) ->
+ strict(arg_types(erlang, node, 1), Xs, fun (_) -> t_node() end);
+type(erlang, nodes, 0, _) -> t_list(t_node());
+type(erlang, nodes, 1, Xs) ->
+ strict(arg_types(erlang, nodes, 1), Xs, fun (_) -> t_list(t_node()) end);
+type(erlang, now, 0, _) ->
+ t_time();
+type(erlang, open_port, 2, Xs) ->
+ strict(arg_types(erlang, open_port, 2), Xs, fun (_) -> t_port() end);
+type(erlang, phash, 2, Xs) ->
+ strict(arg_types(erlang, phash, 2), Xs, fun (_) -> t_pos_integer() end);
+type(erlang, phash2, 1, Xs) ->
+ strict(arg_types(erlang, phash2, 1), Xs, fun (_) -> t_non_neg_integer() end);
+type(erlang, phash2, 2, Xs) ->
+ strict(arg_types(erlang, phash2, 2), Xs, fun (_) -> t_non_neg_integer() end);
+type(erlang, pid_to_list, 1, Xs) ->
+ strict(arg_types(erlang, pid_to_list, 1), Xs, fun (_) -> t_string() end);
+type(erlang, port_call, 3, Xs) ->
+ strict(arg_types(erlang, port_call, 3), Xs, fun (_) -> t_any() end);
+type(erlang, port_close, 1, Xs) ->
+ strict(arg_types(erlang, port_close, 1), Xs,
+ fun (_) -> t_atom('true') end);
+type(erlang, port_command, 2, Xs) ->
+ strict(arg_types(erlang, port_command, 2), Xs,
+ fun (_) -> t_atom('true') end);
+type(erlang, port_command, 3, Xs) ->
+ strict(arg_types(erlang, port_command, 3), Xs,
+ fun (_) -> t_boolean() end);
+type(erlang, port_connect, 2, Xs) ->
+ strict(arg_types(erlang, port_connect, 2), Xs,
+ fun (_) -> t_atom('true') end);
+type(erlang, port_control, 3, Xs) ->
+ strict(arg_types(erlang, port_control, 3), Xs,
+ fun (_) -> t_sup(t_string(), t_binary()) end);
+type(erlang, port_get_data, 1, Xs) ->
+ strict(arg_types(erlang, port_get_data, 1), Xs, fun (_) -> t_any() end);
+type(erlang, port_info, 1, Xs) ->
+ strict(arg_types(erlang, port_info, 1), Xs,
+ fun (_) -> t_sup(t_atom('undefined'), t_list()) end);
+type(erlang, port_info, 2, Xs) ->
+ strict(arg_types(erlang, port_info, 2), Xs,
+ fun ([_Port, Item]) ->
+ t_sup(t_atom('undefined'),
+ case t_atom_vals(Item) of
+ ['connected'] -> t_tuple([Item, t_pid()]);
+ ['id'] -> t_tuple([Item, t_integer()]);
+ ['input'] -> t_tuple([Item, t_integer()]);
+ ['links'] -> t_tuple([Item, t_list(t_pid())]);
+ ['name'] -> t_tuple([Item, t_string()]);
+ ['output'] -> t_tuple([Item, t_integer()]);
+ ['registered_name'] -> t_tuple([Item, t_atom()]);
+ List when is_list(List) ->
+ t_tuple([t_sup([t_atom(A) || A <- List]),
+ t_sup([t_atom(), t_integer(),
+ t_pid(), t_list(t_pid()),
+ t_string()])]);
+ unknown ->
+ [_, PosItem] = arg_types(erlang, port_info, 2),
+ t_tuple([PosItem,
+ t_sup([t_atom(), t_integer(),
+ t_pid(), t_list(t_pid()),
+ t_string()])])
+ end)
+ end);
+type(erlang, port_to_list, 1, Xs) ->
+ strict(arg_types(erlang, port_to_list, 1), Xs, fun (_) -> t_string() end);
+type(erlang, ports, 0, _) -> t_list(t_port());
+type(erlang, port_set_data, 2, Xs) ->
+ strict(arg_types(erlang, port_set_data, 2), Xs,
+ fun (_) -> t_atom('true') end);
+type(erlang, pre_loaded, 0, _) -> t_list(t_atom());
+type(erlang, process_display, 2, _) -> t_atom('true');
+type(erlang, process_flag, 2, Xs) ->
+ T_process_flag_returns = t_sup([t_boolean(), t_atom(), t_non_neg_integer()]),
+ strict(arg_types(erlang, process_flag, 2), Xs,
+ fun ([Flag, _Option]) ->
+ case t_is_atom(Flag) of
+ true ->
+ case t_atom_vals(Flag) of
+ ['error_handler'] -> t_atom();
+ ['min_heap_size'] -> t_non_neg_integer();
+ ['monitor_nodes'] -> t_boolean();
+ ['priority'] -> t_process_priority_level();
+ ['save_calls'] -> t_non_neg_integer();
+ ['trap_exit'] -> t_boolean();
+ List when is_list(List) ->
+ T_process_flag_returns;
+ unknown ->
+ T_process_flag_returns
+ end;
+ false -> % XXX: over-approximation if Flag is tuple
+ T_process_flag_returns
+ end
+ end);
+type(erlang, process_flag, 3, Xs) ->
+ strict(arg_types(erlang, process_flag, 3), Xs,
+ fun (_) -> t_non_neg_integer() end);
+type(erlang, process_info, 1, Xs) ->
+ strict(arg_types(erlang, process_info, 1), Xs,
+ fun (_) ->
+ t_sup(t_list(t_tuple([t_pinfo(), t_any()])),
+ t_atom('undefined'))
+ end);
+type(erlang, process_info, 2, Xs) ->
+ %% we define all normal return values: the return when the process exists
+ %% t_nil() is the return for 'registered_name'; perhaps for more
+ T_process_info_2_normal_returns =
+ t_sup([t_tuple([t_pinfo_item(), t_any()]), t_nil()]),
+ strict(arg_types(erlang, process_info, 2), Xs,
+ fun ([_Pid, InfoItem]) ->
+ Ret = case t_is_atom(InfoItem) of
+ true ->
+ case t_atom_vals(InfoItem) of
+ ['backtrace'] -> t_tuple([InfoItem, t_binary()]);
+ ['current_function'] -> t_tuple([InfoItem, t_mfa()]);
+ ['dictionary'] -> t_tuple([InfoItem, t_list()]);
+ ['error_handler'] -> t_tuple([InfoItem, t_atom()]);
+ ['garbage_collection'] ->
+ t_tuple([InfoItem, t_list()]);
+ ['group_leader'] -> t_tuple([InfoItem, t_pid()]);
+ ['heap_size'] ->
+ t_tuple([InfoItem, t_non_neg_integer()]);
+ ['initial_call'] -> t_tuple([InfoItem, t_mfa()]);
+ ['last_calls'] ->
+ t_tuple([InfoItem,
+ t_sup(t_atom('false'), t_list())]);
+ ['links'] -> t_tuple([InfoItem, t_list(t_pid())]);
+ ['memory'] ->
+ t_tuple([InfoItem, t_non_neg_integer()]);
+ ['message_binary'] -> t_tuple([InfoItem, t_list()]);
+ ['message_queue_len'] ->
+ t_tuple([InfoItem, t_non_neg_integer()]);
+ ['messages'] -> t_tuple([InfoItem, t_list()]);
+ ['monitored_by'] ->
+ t_tuple([InfoItem, t_list(t_pid())]);
+ ['monitors'] ->
+ t_tuple([InfoItem,
+ t_list(t_sup(t_tuple([t_atom('process'),
+ t_pid()]),
+ t_tuple([t_atom('process'),
+ t_tuple([t_atom(),
+ t_atom()])])))]);
+ ['priority'] ->
+ t_tuple([InfoItem, t_process_priority_level()]);
+ ['reductions'] ->
+ t_tuple([InfoItem, t_non_neg_integer()]);
+ ['registered_name'] ->
+ t_sup(t_tuple([InfoItem, t_atom()]), t_nil());
+ ['sequential_trace_token'] ->
+ t_tuple([InfoItem, t_any()]); %% Underspecified
+ ['stack_size'] ->
+ t_tuple([InfoItem, t_non_neg_integer()]);
+ ['status'] ->
+ t_tuple([InfoItem, t_process_status()]);
+ ['suspending'] ->
+ t_tuple([InfoItem,
+ t_list(t_tuple([t_pid(),
+ t_non_neg_integer(),
+ t_non_neg_integer()]))]);
+ ['total_heap_size'] ->
+ t_tuple([InfoItem, t_non_neg_integer()]);
+ ['trap_exit'] ->
+ t_tuple([InfoItem, t_boolean()]);
+ List when is_list(List) ->
+ T_process_info_2_normal_returns;
+ unknown ->
+ T_process_info_2_normal_returns
+ end;
+ false ->
+ case t_is_list(InfoItem) of
+ true ->
+ t_list(t_tuple([t_pinfo_item(), t_any()]));
+ false ->
+ t_sup(T_process_info_2_normal_returns,
+ t_list(t_tuple([t_pinfo_item(), t_any()])))
+ end
+ end,
+ t_sup([Ret, t_atom('undefined')])
+ end);
+type(erlang, processes, 0, _) -> t_list(t_pid());
+type(erlang, purge_module, 1, Xs) ->
+ strict(arg_types(erlang, purge_module, 1), Xs,
+ fun (_) -> t_atom('true') end);
+type(erlang, put, 2, Xs) ->
+ strict(arg_types(erlang, put, 2), Xs, fun (_) -> t_any() end);
+type(erlang, raise, 3, _) -> t_none();
+type(erlang, read_timer, 1, Xs) ->
+ strict(arg_types(erlang, read_timer, 1), Xs,
+ fun (_) -> t_sup(t_non_neg_integer(), t_atom('false')) end);
+type(erlang, ref_to_list, 1, Xs) ->
+ strict(arg_types(erlang, ref_to_list, 1), Xs, fun (_) -> t_string() end);
+type(erlang, register, 2, Xs) ->
+ strict(arg_types(erlang, register, 2), Xs, fun (_) -> t_atom('true') end);
+type(erlang, registered, 0, _) -> t_list(t_atom());
+type(erlang, resume_process, 1, Xs) ->
+ strict(arg_types(erlang, resume_process, 1), Xs,
+ fun (_) -> t_any() end); %% TODO: overapproximation -- fix this
+type(erlang, round, 1, Xs) ->
+ strict(arg_types(erlang, round, 1), Xs, fun (_) -> t_integer() end);
+type(erlang, self, 0, _) -> t_pid();
+type(erlang, send, 2, Xs) -> type(erlang, '!', 2, Xs); % alias
+type(erlang, send, 3, Xs) ->
+ strict(arg_types(erlang, send, 3), Xs,
+ fun (_) -> t_sup(t_atom('ok'), t_sendoptions()) end);
+type(erlang, send_after, 3, Xs) ->
+ strict(arg_types(erlang, send_after, 3), Xs, fun (_) -> t_reference() end);
+type(erlang, seq_trace, 2, Xs) ->
+ strict(arg_types(erlang, seq_trace, 2), Xs,
+ fun (_) -> t_sup(t_seq_trace_info_returns(), t_tuple(5)) end);
+type(erlang, seq_trace_info, 1, Xs) ->
+ strict(arg_types(erlang, seq_trace_info, 1), Xs,
+ fun ([Item]) ->
+ case t_atom_vals(Item) of
+ ['label'] ->
+ t_sup(t_tuple([Item, t_non_neg_integer()]), t_nil());
+ ['serial'] ->
+ t_sup(t_tuple([Item, t_tuple([t_non_neg_integer(),
+ t_non_neg_integer()])]),
+ t_nil());
+ ['send'] -> t_tuple([Item, t_boolean()]);
+ ['receive'] -> t_tuple([Item, t_boolean()]);
+ ['print'] -> t_tuple([Item, t_boolean()]);
+ ['timestamp'] -> t_tuple([Item, t_boolean()]);
+ List when is_list(List) ->
+ t_seq_trace_info_returns();
+ unknown ->
+ t_seq_trace_info_returns()
+ end
+ end);
+type(erlang, seq_trace_print, 1, Xs) ->
+ strict(arg_types(erlang, seq_trace_print, 1), Xs, fun (_) -> t_boolean() end);
+type(erlang, seq_trace_print, 2, Xs) ->
+ strict(arg_types(erlang, seq_trace_print, 2), Xs, fun (_) -> t_boolean() end);
+type(erlang, set_cookie, 2, Xs) ->
+ strict(arg_types(erlang, set_cookie, 2), Xs, fun (_) -> t_atom('true') end);
+type(erlang, setelement, 3, Xs) ->
+ strict(arg_types(erlang, setelement, 3), Xs,
+ fun ([X1, X2, X3]) ->
+ case t_tuple_subtypes(X2) of
+ unknown -> t_tuple();
+ [_] ->
+ Sz = t_tuple_size(X2),
+ As = t_tuple_args(X2),
+ case t_number_vals(X1) of
+ unknown ->
+ t_tuple([t_sup(X, X3) || X <- As]);
+ [N] when is_integer(N), 1 =< N, N =< Sz ->
+ t_tuple(list_replace(N, X3, As));
+ [N] when is_integer(N), N < 1 ->
+ t_none();
+ [N] when is_integer(N), N > Sz ->
+ t_none();
+ Ns ->
+ Fun = fun (N, XL) when is_integer(N), 1 =< N, N =< Sz ->
+ X = lists:nth(N, XL),
+ Y = t_sup(X, X3),
+ list_replace(N, Y, XL);
+ (_, XL) ->
+ XL
+ end,
+ t_tuple(lists:foldl(Fun, As, Ns))
+ end;
+ Ts when is_list(Ts) ->
+ t_sup([type(erlang, setelement, 3, [X1, Y, X3]) || Y <- Ts])
+ end
+ end);
+type(erlang, setnode, 2, Xs) ->
+ strict(arg_types(erlang, setnode, 2), Xs, fun (_) -> t_atom('true') end);
+type(erlang, setnode, 3, Xs) ->
+ strict(arg_types(erlang, setnode, 3), Xs, fun (_) -> t_atom('true') end);
+type(erlang, size, 1, Xs) ->
+ strict(arg_types(erlang, size, 1), Xs, fun (_) -> t_non_neg_integer() end);
+type(erlang, spawn, 1, Xs) ->
+ strict(arg_types(erlang, spawn, 1), Xs, fun (_) -> t_pid() end);
+type(erlang, spawn, 2, Xs) ->
+ strict(arg_types(erlang, spawn, 2), Xs, fun (_) -> t_pid() end);
+type(erlang, spawn, 3, Xs) ->
+ strict(arg_types(erlang, spawn, 3), Xs, fun (_) -> t_pid() end);
+type(erlang, spawn, 4, Xs) ->
+ strict(arg_types(erlang, spawn, 4), Xs, fun (_) -> t_pid() end);
+type(erlang, spawn_link, 1, Xs) -> type(erlang, spawn, 1, Xs); % same
+type(erlang, spawn_link, 2, Xs) -> type(erlang, spawn, 2, Xs); % same
+type(erlang, spawn_link, 3, Xs) -> type(erlang, spawn, 3, Xs); % same
+type(erlang, spawn_link, 4, Xs) -> type(erlang, spawn, 4, Xs); % same
+type(erlang, spawn_opt, 1, Xs) ->
+ strict(arg_types(erlang, spawn_opt, 1), Xs,
+ fun ([Tuple]) ->
+ Fun = fun (TS) ->
+ [_, _, _, List] = t_tuple_args(TS),
+ t_spawn_opt_return(List)
+ end,
+ t_sup([Fun(TS) || TS <- t_tuple_subtypes(Tuple)])
+ end);
+type(erlang, spawn_opt, 2, Xs) ->
+ strict(arg_types(erlang, spawn_opt, 2), Xs,
+ fun ([_, List]) -> t_spawn_opt_return(List) end);
+type(erlang, spawn_opt, 3, Xs) ->
+ strict(arg_types(erlang, spawn_opt, 3), Xs,
+ fun ([_, _, List]) -> t_spawn_opt_return(List) end);
+type(erlang, spawn_opt, 4, Xs) ->
+ strict(arg_types(erlang, spawn_opt, 4), Xs,
+ fun ([_, _, _, List]) -> t_spawn_opt_return(List) end);
+type(erlang, split_binary, 2, Xs) ->
+ strict(arg_types(erlang, split_binary, 2), Xs,
+ fun (_) -> t_tuple([t_binary(), t_binary()]) end);
+type(erlang, start_timer, 3, Xs) ->
+ strict(arg_types(erlang, start_timer, 3), Xs, fun (_) -> t_reference() end);
+type(erlang, statistics, 1, Xs) ->
+ strict(arg_types(erlang, statistics, 1), Xs,
+ fun ([Type]) ->
+ T_statistics_1 = t_sup([t_non_neg_integer(),
+ t_tuple([t_non_neg_integer(),
+ t_non_neg_integer()]),
+ %% When called with the argument 'io'.
+ t_tuple([t_tuple([t_atom('input'),
+ t_non_neg_integer()]),
+ t_tuple([t_atom('output'),
+ t_non_neg_integer()])]),
+ t_tuple([t_non_neg_integer(),
+ t_non_neg_integer(),
+ t_non_neg_integer()])]),
+ case t_atom_vals(Type) of
+ ['context_switches'] ->
+ t_tuple([t_non_neg_integer(), t_integer(0)]);
+ ['exact_reductions'] ->
+ t_tuple([t_non_neg_integer(), t_non_neg_integer()]);
+ ['garbage_collection'] ->
+ t_tuple([t_non_neg_integer(),
+ t_non_neg_integer(),
+ t_integer(0)]);
+ ['io'] ->
+ t_tuple([t_tuple([t_atom('input'), t_non_neg_integer()]),
+ t_tuple([t_atom('output'), t_non_neg_integer()])]);
+ ['reductions'] ->
+ t_tuple([t_non_neg_integer(), t_non_neg_integer()]);
+ ['run_queue'] ->
+ t_non_neg_integer();
+ ['runtime'] ->
+ t_tuple([t_non_neg_integer(), t_integer(0)]);
+ ['wall_clock'] ->
+ t_tuple([t_non_neg_integer(), t_integer(0)]);
+ List when is_list(List) ->
+ T_statistics_1;
+ unknown ->
+ T_statistics_1
+ end
+ end);
+type(erlang, suspend_process, 1, Xs) ->
+ strict(arg_types(erlang, suspend_process, 1), Xs,
+ fun (_) -> t_atom('true') end);
+type(erlang, suspend_process, 2, Xs) ->
+ strict(arg_types(erlang, suspend_process, 2), Xs,
+ fun (_) -> t_boolean() end);
+type(erlang, system_flag, 2, Xs) ->
+ strict(arg_types(erlang, system_flag, 2), Xs,
+ fun ([Flag,_Value]) ->
+ %% this provides an overapproximation of all return values
+ T_system_flag_2 = t_sup([t_boolean(),
+ t_integer(),
+ t_sequential_tracer(),
+ t_system_cpu_topology(),
+ t_system_multi_scheduling()]),
+ case t_is_atom(Flag) of
+ true ->
+ case t_atom_vals(Flag) of
+ ['backtrace_depth'] ->
+ t_non_neg_fixnum();
+ ['cpu_topology'] ->
+ t_system_cpu_topology();
+ ['debug_flags'] ->
+ t_atom('true');
+ ['display_items'] ->
+ t_non_neg_fixnum();
+ ['fullsweep_after'] ->
+ t_non_neg_fixnum();
+ ['min_heap_size'] ->
+ t_non_neg_fixnum();
+ ['multi_scheduling'] ->
+ t_system_multi_scheduling();
+ ['schedulers_online'] ->
+ t_pos_fixnum();
+ ['scheduler_bind_type'] ->
+ t_scheduler_bind_type_results();
+ ['sequential_tracer'] ->
+ t_sequential_tracer();
+ ['trace_control_word'] ->
+ t_integer();
+ List when is_list(List) ->
+ T_system_flag_2;
+ unknown ->
+ T_system_flag_2
+ end;
+ false ->
+ case t_is_integer(Flag) of % SHOULD BE: t_is_fixnum
+ true ->
+ t_atom('true');
+ false ->
+ T_system_flag_2
+ end
+ end
+ end);
+type(erlang, system_info, 1, Xs) ->
+ strict(arg_types(erlang, system_info, 1), Xs,
+ fun ([Type]) ->
+ case t_is_atom(Type) of
+ true ->
+ case t_atom_vals(Type) of
+ ['allocated_areas'] ->
+ t_list(t_sup([t_tuple([t_atom(),t_non_neg_integer()]),
+ t_tuple([t_atom(),
+ t_non_neg_integer(),
+ t_non_neg_integer()])]));
+ ['allocator'] ->
+ t_tuple([t_sup([t_atom('undefined'),
+ t_atom('elib_malloc'),
+ t_atom('glibc')]),
+ t_list(t_integer()),
+ t_list(t_atom()),
+ t_list(t_tuple([t_atom(),
+ t_list(t_tuple([t_atom(),
+ t_any()]))]))]);
+ ['break_ignored'] ->
+ t_boolean();
+ ['cpu_topology'] ->
+ t_system_cpu_topology();
+ ['compat_rel'] ->
+ t_non_neg_fixnum();
+ ['creation'] ->
+ t_fixnum();
+ ['debug_compiled'] ->
+ t_boolean();
+ ['dist'] ->
+ t_binary();
+ ['dist_ctrl'] ->
+ t_list(t_tuple([t_atom(), t_sup([t_pid(), t_port])]));
+ ['elib_malloc'] ->
+ t_sup([t_atom('false'),
+ t_list(t_tuple([t_atom(), t_any()]))]);
+ ['endian'] ->
+ t_sup([t_atom('big'), t_atom('little')]);
+ ['fullsweep_after'] ->
+ t_tuple([t_atom('fullsweep_after'), t_non_neg_integer()]);
+ ['garbage_collection'] ->
+ t_list();
+ ['global_heaps_size'] ->
+ t_non_neg_integer();
+ ['heap_sizes'] ->
+ t_list(t_integer());
+ ['heap_type'] ->
+ t_sup([t_atom('private'), t_atom('hybrid')]);
+ ['hipe_architecture'] ->
+ t_sup([t_atom('amd64'), t_atom('arm'),
+ t_atom('powerpc'), t_atom('undefined'),
+ t_atom('ultrasparc'), t_atom('x86')]);
+ ['info'] ->
+ t_binary();
+ ['internal_cpu_topology'] -> %% Undocumented internal feature
+ t_internal_cpu_topology();
+ ['loaded'] ->
+ t_binary();
+ ['logical_processors'] ->
+ t_non_neg_fixnum();
+ ['machine'] ->
+ t_string();
+ ['multi_scheduling'] ->
+ t_system_multi_scheduling();
+ ['multi_scheduling_blockers'] ->
+ t_list(t_pid());
+ ['os_type'] ->
+ t_tuple([t_sup([t_atom('ose'), % XXX: undocumented
+ t_atom('unix'),
+ t_atom('vxworks'),
+ t_atom('win32')]),
+ t_atom()]);
+ ['os_version'] ->
+ t_sup(t_tuple([t_non_neg_fixnum(),
+ t_non_neg_fixnum(),
+ t_non_neg_fixnum()]),
+ t_string());
+ ['process_count'] ->
+ t_non_neg_fixnum();
+ ['process_limit'] ->
+ t_non_neg_fixnum();
+ ['procs'] ->
+ t_binary();
+ ['scheduler_bindings'] ->
+ t_tuple();
+ ['scheduler_bind_type'] ->
+ t_scheduler_bind_type_results();
+ ['schedulers'] ->
+ t_pos_fixnum();
+ ['schedulers_online'] ->
+ t_pos_fixnum();
+ ['sequential_tracer'] ->
+ t_tuple([t_atom('sequential_tracer'),
+ t_sequential_tracer()]);
+ ['smp_support'] ->
+ t_boolean();
+ ['system_architecture'] ->
+ t_string();
+ ['system_version'] ->
+ t_string();
+ ['threads'] ->
+ t_boolean();
+ ['thread_pool_size'] ->
+ t_non_neg_fixnum();
+ ['trace_control_word'] ->
+ t_integer();
+ ['version'] ->
+ t_string();
+ ['wordsize'] ->
+ t_integers([4,8]);
+ List when is_list(List) ->
+ t_any(); %% gross overapproximation
+ unknown ->
+ t_any()
+ end;
+ false -> %% This currently handles only {allocator, Alloc}
+ t_any() %% overapproximation as the return value might change
+ end
+ end);
+type(erlang, system_monitor, 0, Xs) ->
+ strict(arg_types(erlang, system_monitor, 0), Xs,
+ fun (_) -> t_system_monitor_settings() end);
+type(erlang, system_monitor, 1, Xs) ->
+ strict(arg_types(erlang, system_monitor, 1), Xs,
+ fun (_) -> t_system_monitor_settings() end);
+type(erlang, system_monitor, 2, Xs) ->
+ strict(arg_types(erlang, system_monitor, 2), Xs,
+ fun (_) -> t_system_monitor_settings() end);
+type(erlang, system_profile, 0, _) ->
+ t_system_profile_return();
+type(erlang, system_profile, 2, Xs) ->
+ strict(arg_types(erlang, system_profile, 2), Xs,
+ fun (_) -> t_system_profile_return() end);
+type(erlang, term_to_binary, 1, Xs) ->
+ strict(arg_types(erlang, term_to_binary, 1), Xs, fun (_) -> t_binary() end);
+type(erlang, term_to_binary, 2, Xs) ->
+ strict(arg_types(erlang, term_to_binary, 2), Xs, fun (_) -> t_binary() end);
+type(erlang, time, 0, _) ->
+ t_tuple([t_non_neg_integer(), t_non_neg_integer(), t_non_neg_integer()]);
+type(erlang, tl, 1, Xs) ->
+ strict(arg_types(erlang, tl, 1), Xs, fun ([X]) -> t_cons_tl(X) end);
+type(erlang, trace, 3, Xs) ->
+ strict(arg_types(erlang, trace, 3), Xs, fun (_) -> t_integer() end);
+type(erlang, trace_delivered, 1, Xs) ->
+ strict(arg_types(erlang, trace_delivered, 1), Xs,
+ fun (_) -> t_reference() end);
+type(erlang, trace_info, 2, Xs) ->
+ strict(arg_types(erlang, trace_info, 2), Xs,
+ fun (_) ->
+ t_tuple([t_atom(),
+ t_sup([%% the following is info about a PID
+ t_list(t_atom()), t_pid(), t_port(),
+ %% the following is info about a func
+ t_atom('global'), t_atom('local'),
+ t_atom('false'), t_atom('true'),
+ t_list(), t_pid(), t_port(),
+ t_integer(),
+ t_list(t_tuple([t_atom(), t_any()])),
+ %% and this is the 'not found' value
+ t_atom('undefined')])])
+ end);
+type(erlang, trace_pattern, 2, Xs) ->
+ strict(arg_types(erlang, trace_pattern, 2), Xs,
+ fun (_) -> t_non_neg_fixnum() end); %% num of MFAs that match pattern
+type(erlang, trace_pattern, 3, Xs) ->
+ strict(arg_types(erlang, trace_pattern, 3), Xs,
+ fun (_) -> t_non_neg_fixnum() end); %% num of MFAs that match pattern
+type(erlang, trunc, 1, Xs) ->
+ strict(arg_types(erlang, trunc, 1), Xs, fun (_) -> t_integer() end);
+type(erlang, tuple_size, 1, Xs) ->
+ strict(arg_types(erlang, tuple_size, 1), Xs, fun (_) -> t_non_neg_integer() end);
+type(erlang, tuple_to_list, 1, Xs) ->
+ strict(arg_types(erlang, tuple_to_list, 1), Xs,
+ fun ([X]) ->
+ case t_tuple_subtypes(X) of
+ unknown -> t_list();
+ SubTypes ->
+ Args = lists:flatten([t_tuple_args(ST) || ST <- SubTypes]),
+ %% Can be nil if the tuple can be {}
+ case lists:any(fun (T) ->
+ t_tuple_size(T) =:= 0
+ end, SubTypes) of
+ true ->
+ %% Be careful here. If we had only {} we need to
+ %% keep the nil.
+ t_sup(t_nonempty_list(t_sup(Args)), t_nil());
+ false ->
+ t_nonempty_list(t_sup(Args))
+ end
+ end
+ end);
+type(erlang, universaltime, 0, _) ->
+ t_tuple([t_date(), t_time()]);
+type(erlang, universaltime_to_localtime, 1, Xs) ->
+ strict(arg_types(erlang, universaltime_to_localtime, 1), Xs,
+ fun ([T]) -> T end);
+type(erlang, unlink, 1, Xs) ->
+ strict(arg_types(erlang, unlink, 1), Xs, fun (_) -> t_atom('true') end);
+type(erlang, unregister, 1, Xs) ->
+ strict(arg_types(erlang, unregister, 1), Xs, fun (_) -> t_atom('true') end);
+type(erlang, whereis, 1, Xs) ->
+ strict(arg_types(erlang, whereis, 1), Xs,
+ fun (_) -> t_sup([t_pid(), t_port(), t_atom('undefined')]) end);
+type(erlang, yield, 0, _) -> t_atom('true');
+%%-- erl_prim_loader ----------------------------------------------------------
+type(erl_prim_loader, get_file, 1, Xs) ->
+ strict(arg_types(erl_prim_loader, get_file, 1), Xs,
+ fun (_) ->
+ t_sup(t_tuple([t_atom('ok'), t_binary(), t_string()]),
+ t_atom('error'))
+ end);
+type(erl_prim_loader, get_path, 0, _) ->
+ t_tuple([t_atom('ok'), t_list(t_string())]);
+type(erl_prim_loader, set_path, 1, Xs) ->
+ strict(arg_types(erl_prim_loader, set_path, 1), Xs,
+ fun (_) -> t_atom('ok') end);
+%%-- error_logger -------------------------------------------------------------
+type(error_logger, warning_map, 0, _) ->
+ t_sup([t_atom('info'), t_atom('warning'), t_atom('error')]);
+%%-- erts_debug ---------------------------------------------------------------
+type(erts_debug, breakpoint, 2, Xs) ->
+ strict(arg_types(erts_debug, breakpoint, 2), Xs, fun (_) -> t_fixnum() end);
+type(erts_debug, disassemble, 1, Xs) ->
+ strict(arg_types(erts_debug, disassemble, 1), Xs,
+ fun (_) -> t_sup([t_atom('false'),
+ t_atom('undef'),
+ t_tuple([t_integer(), t_binary(), t_mfa()])]) end);
+type(erts_debug, flat_size, 1, Xs) ->
+ strict(arg_types(erts_debug, flat_size, 1), Xs, fun (_) -> t_integer() end);
+type(erts_debug, same, 2, Xs) ->
+ strict(arg_types(erts_debug, same, 2), Xs, fun (_) -> t_boolean() end);
+%%-- ets ----------------------------------------------------------------------
+type(ets, all, 0, _) ->
+ t_list(t_tab());
+type(ets, delete, 1, Xs) ->
+ strict(arg_types(ets, delete, 1), Xs, fun (_) -> t_atom('true') end);
+type(ets, delete, 2, Xs) ->
+ strict(arg_types(ets, delete, 2), Xs, fun (_) -> t_atom('true') end);
+type(ets, delete_all_objects, 1, Xs) ->
+ strict(arg_types(ets, delete_all_objects, 1), Xs,
+ fun (_) -> t_atom('true') end);
+type(ets, delete_object, 2, Xs) ->
+ strict(arg_types(ets, delete_object, 2), Xs, fun (_) -> t_atom('true') end);
+type(ets, first, 1, Xs) ->
+ strict(arg_types(ets, first, 1), Xs, fun (_) -> t_any() end);
+type(ets, give_away, 3, Xs) ->
+ strict(arg_types(ets, give_away, 3), Xs, fun (_) -> t_atom('true') end);
+type(ets, info, 1, Xs) ->
+ strict(arg_types(ets, info, 1), Xs,
+ fun (_) ->
+ t_sup(t_list(t_tuple([t_ets_info_items(), t_any()])),
+ t_atom('undefined'))
+ end);
+type(ets, info, 2, Xs) ->
+ strict(arg_types(ets, info, 2), Xs, fun (_) -> t_any() end);
+type(ets, insert, 2, Xs) ->
+ strict(arg_types(ets, insert, 2), Xs, fun (_) -> t_atom('true') end);
+type(ets, insert_new, 2, Xs) ->
+ strict(arg_types(ets, insert_new, 2), Xs, fun (_) -> t_boolean() end);
+type(ets, is_compiled_ms, 1, Xs) ->
+ strict(arg_types(ets, is_compiled_ms, 1), Xs, fun (_) -> t_boolean() end);
+type(ets, last, 1, Xs) ->
+ type(ets, first, 1, Xs);
+type(ets, lookup, 2, Xs) ->
+ strict(arg_types(ets, lookup, 2), Xs, fun (_) -> t_list(t_tuple()) end);
+type(ets, lookup_element, 3, Xs) ->
+ strict(arg_types(ets, lookup_element, 3), Xs, fun (_) -> t_any() end);
+type(ets, match, 1, Xs) ->
+ strict(arg_types(ets, match, 1), Xs, fun (_) -> t_matchres() end);
+type(ets, match, 2, Xs) ->
+ strict(arg_types(ets, match, 2), Xs, fun (_) -> t_list() end);
+type(ets, match, 3, Xs) ->
+ strict(arg_types(ets, match, 3), Xs, fun (_) -> t_matchres() end);
+type(ets, match_object, 1, Xs) -> type(ets, match, 1, Xs);
+type(ets, match_object, 2, Xs) -> type(ets, match, 2, Xs);
+type(ets, match_object, 3, Xs) -> type(ets, match, 3, Xs);
+type(ets, match_spec_compile, 1, Xs) ->
+ strict(arg_types(ets, match_spec_compile, 1), Xs, fun (_) -> t_any() end);
+type(ets, match_spec_run_r, 3, Xs) ->
+ strict(arg_types(ets, match_spec_run_r, 3), Xs, fun (_) -> t_list() end);
+type(ets, member, 2, Xs) ->
+ strict(arg_types(ets, member, 2), Xs, fun (_) -> t_boolean() end);
+type(ets, new, 2, Xs) ->
+ strict(arg_types(ets, new, 2), Xs, fun (_) -> t_tab() end);
+type(ets, next, 2, Xs) ->
+ strict(arg_types(ets, next, 2), Xs,
+ %% t_any below stands for: term() | '$end_of_table'
+ fun (_) -> t_any() end);
+type(ets, prev, 2, Xs) -> type(ets, next, 2, Xs);
+type(ets, rename, 2, Xs) ->
+ strict(arg_types(ets, rename, 2), Xs, fun ([_, Name]) -> Name end);
+type(ets, safe_fixtable, 2, Xs) ->
+ strict(arg_types(ets, safe_fixtable, 2), Xs, fun (_) -> t_atom('true') end);
+type(ets, select, 1, Xs) ->
+ strict(arg_types(ets, select, 1), Xs, fun (_) -> t_matchres() end);
+type(ets, select, 2, Xs) ->
+ strict(arg_types(ets, select, 2), Xs, fun (_) -> t_list() end);
+type(ets, select, 3, Xs) ->
+ strict(arg_types(ets, select, 3), Xs, fun (_) -> t_matchres() end);
+type(ets, select_count, 2, Xs) ->
+ strict(arg_types(ets, select_count, 2), Xs,
+ fun (_) -> t_non_neg_fixnum() end);
+type(ets, select_delete, 2, Xs) ->
+ strict(arg_types(ets, select_delete, 2), Xs,
+ fun (_) -> t_non_neg_fixnum() end);
+type(ets, select_reverse, 1, Xs) -> type(ets, select, 1, Xs);
+type(ets, select_reverse, 2, Xs) -> type(ets, select, 2, Xs);
+type(ets, select_reverse, 3, Xs) -> type(ets, select, 3, Xs);
+type(ets, setopts, 2, Xs) ->
+ strict(arg_types(ets, setopts, 2), Xs, fun (_) -> t_atom('true') end);
+type(ets, slot, 2, Xs) ->
+ strict(arg_types(ets, slot, 2), Xs,
+ fun (_) -> t_sup(t_list(t_tuple()), t_atom('$end_of_table')) end);
+type(ets, update_counter, 3, Xs) ->
+ strict(arg_types(ets, update_counter, 3), Xs, fun (_) -> t_integer() end);
+type(ets, update_element, 3, Xs) ->
+ strict(arg_types(ets, update_element, 3), Xs, fun (_) -> t_boolean() end);
+%%-- file ---------------------------------------------------------------------
+type(file, close, 1, Xs) ->
+ strict(arg_types(file, close, 1), Xs, fun (_) -> t_file_return() end);
+type(file, delete, 1, Xs) ->
+ strict(arg_types(file, delete, 1), Xs, fun (_) -> t_file_return() end);
+type(file, get_cwd, 0, _) ->
+ t_sup(t_tuple([t_atom('ok'), t_string()]),
+ t_tuple([t_atom('error'), t_file_posix_error()]));
+type(file, make_dir, 1, Xs) ->
+ strict(arg_types(file, make_dir, 1), Xs, fun (_) -> t_file_return() end);
+type(file, open, 2, Xs) ->
+ strict(arg_types(file, open, 2), Xs,
+ fun (_) ->
+ t_sup([t_tuple([t_atom('ok'), t_file_io_device()]),
+ t_tuple([t_atom('error'), t_file_posix_error()])])
+ end);
+type(file, read_file, 1, Xs) ->
+ strict(arg_types(file, read_file, 1), Xs,
+ fun (_) ->
+ t_sup([t_tuple([t_atom('ok'), t_binary()]),
+ t_tuple([t_atom('error'), t_file_posix_error()])])
+ end);
+type(file, set_cwd, 1, Xs) ->
+ strict(arg_types(file, set_cwd, 1), Xs,
+ fun (_) -> t_sup(t_atom('ok'),
+ t_tuple([t_atom('error'), t_file_posix_error()]))
+ end);
+type(file, write_file, 2, Xs) ->
+ strict(arg_types(file, write_file, 2), Xs, fun (_) -> t_file_return() end);
+%%-- gen_tcp ------------------------------------------------------------------
+%% NOTE: All type information for this module added to avoid loss of precision
+type(gen_tcp, accept, 1, Xs) ->
+ strict(arg_types(gen_tcp, accept, 1), Xs, fun (_) -> t_gen_tcp_accept() end);
+type(gen_tcp, accept, 2, Xs) ->
+ strict(arg_types(gen_tcp, accept, 2), Xs, fun (_) -> t_gen_tcp_accept() end);
+type(gen_tcp, connect, 3, Xs) ->
+ strict(arg_types(gen_tcp, connect, 3), Xs,
+ fun (_) ->
+ t_sup(t_tuple([t_atom('ok'), t_socket()]),
+ t_tuple([t_atom('error'), t_inet_posix_error()]))
+ end);
+type(gen_tcp, connect, 4, Xs) ->
+ strict(arg_types(gen_tcp, connect, 4), Xs,
+ fun (_) ->
+ t_sup(t_tuple([t_atom('ok'), t_socket()]),
+ t_tuple([t_atom('error'), t_inet_posix_error()]))
+ end);
+type(gen_tcp, listen, 2, Xs) ->
+ strict(arg_types(gen_tcp, listen, 2), Xs,
+ fun (_) ->
+ t_sup(t_tuple([t_atom('ok'), t_socket()]),
+ t_tuple([t_atom('error'), t_inet_posix_error()]))
+ end);
+type(gen_tcp, recv, 2, Xs) ->
+ strict(arg_types(gen_tcp, recv, 2), Xs, fun (_) -> t_gen_tcp_recv() end);
+type(gen_tcp, recv, 3, Xs) ->
+ strict(arg_types(gen_tcp, recv, 3), Xs, fun (_) -> t_gen_tcp_recv() end);
+type(gen_tcp, send, 2, Xs) ->
+ strict(arg_types(gen_tcp, send, 2), Xs,
+ fun (_) ->
+ t_sup(t_atom('ok'),
+ t_tuple([t_atom('error'), t_inet_posix_error()]))
+ end);
+type(gen_tcp, shutdown, 2, Xs) ->
+ strict(arg_types(gen_tcp, shutdown, 2), Xs,
+ fun (_) ->
+ t_sup(t_atom('ok'),
+ t_tuple([t_atom('error'), t_inet_posix_error()]))
+ end);
+%%-- gen_udp ------------------------------------------------------------------
+%% NOTE: All type information for this module added to avoid loss of precision
+type(gen_udp, open, 1, Xs) ->
+ strict(arg_types(gen_udp, open, 1), Xs,
+ fun (_) ->
+ t_sup(t_tuple([t_atom('ok'), t_socket()]),
+ t_tuple([t_atom('error'), t_inet_posix_error()]))
+ end);
+type(gen_udp, open, 2, Xs) ->
+ strict(arg_types(gen_udp, open, 2), Xs,
+ fun (_) ->
+ t_sup(t_tuple([t_atom('ok'), t_socket()]),
+ t_tuple([t_atom('error'), t_inet_posix_error()]))
+ end);
+type(gen_udp, recv, 2, Xs) ->
+ strict(arg_types(gen_udp, recv, 2), Xs, fun (_) -> t_gen_udp_recv() end);
+type(gen_udp, recv, 3, Xs) ->
+ strict(arg_types(gen_udp, recv, 3), Xs, fun (_) -> t_gen_udp_recv() end);
+type(gen_udp, send, 4, Xs) ->
+ strict(arg_types(gen_udp, send, 4), Xs,
+ fun (_) ->
+ t_sup(t_atom('ok'),
+ t_tuple([t_atom('error'), t_sup(t_atom('not_owner'),
+ t_inet_posix_error())]))
+ end);
+%%-- hipe_bifs ----------------------------------------------------------------
+type(hipe_bifs, add_ref, 2, Xs) ->
+ strict(arg_types(hipe_bifs, add_ref, 2), Xs, fun (_) -> t_nil() end);
+type(hipe_bifs, alloc_data, 2, Xs) ->
+ strict(arg_types(hipe_bifs, alloc_data, 2), Xs,
+ fun (_) -> t_integer() end); % address
+type(hipe_bifs, array, 2, Xs) ->
+ strict(arg_types(hipe_bifs, array, 2), Xs, fun (_) -> t_immarray() end);
+type(hipe_bifs, array_length, 1, Xs) ->
+ strict(arg_types(hipe_bifs, array_length, 1), Xs,
+ fun (_) -> t_non_neg_fixnum() end);
+type(hipe_bifs, array_sub, 2, Xs) ->
+ strict(arg_types(hipe_bifs, array_sub, 2), Xs, fun (_) -> t_immediate() end);
+type(hipe_bifs, array_update, 3, Xs) ->
+ strict(arg_types(hipe_bifs, array_update, 3), Xs,
+ fun (_) -> t_immarray() end);
+type(hipe_bifs, atom_to_word, 1, Xs) ->
+ strict(arg_types(hipe_bifs, atom_to_word, 1), Xs,
+ fun (_) -> t_integer() end);
+type(hipe_bifs, bif_address, 3, Xs) ->
+ strict(arg_types(hipe_bifs, bif_address, 3), Xs,
+ fun (_) -> t_sup(t_integer(), t_atom('false')) end);
+type(hipe_bifs, bitarray, 2, Xs) ->
+ strict(arg_types(hipe_bifs, bitarray, 2), Xs, fun (_) -> t_bitarray() end);
+type(hipe_bifs, bitarray_sub, 2, Xs) ->
+ strict(arg_types(hipe_bifs, bitarray_sub, 2), Xs, fun (_) -> t_boolean() end);
+type(hipe_bifs, bitarray_update, 3, Xs) ->
+ strict(arg_types(hipe_bifs, bitarray_update, 3), Xs,
+ fun (_) -> t_bitarray() end);
+type(hipe_bifs, bytearray, 2, Xs) ->
+ strict(arg_types(hipe_bifs, bytearray, 2), Xs, fun (_) -> t_bytearray() end);
+type(hipe_bifs, bytearray_sub, 2, Xs) ->
+ strict(arg_types(hipe_bifs, bytearray_sub, 2), Xs, fun (_) -> t_byte() end);
+type(hipe_bifs, bytearray_update, 3, Xs) ->
+ strict(arg_types(hipe_bifs, bytearray_update, 3), Xs,
+ fun (_) -> t_bytearray() end);
+type(hipe_bifs, call_count_clear, 1, Xs) ->
+ strict(arg_types(hipe_bifs, call_count_clear, 1), Xs,
+ fun (_) -> t_sup(t_non_neg_integer(), t_atom('false')) end);
+type(hipe_bifs, call_count_get, 1, Xs) ->
+ strict(arg_types(hipe_bifs, call_count_get, 1), Xs,
+ fun (_) -> t_sup(t_non_neg_integer(), t_atom('false')) end);
+type(hipe_bifs, call_count_off, 1, Xs) ->
+ strict(arg_types(hipe_bifs, call_count_off, 1), Xs,
+ fun (_) -> t_sup(t_non_neg_integer(), t_atom('false')) end);
+type(hipe_bifs, call_count_on, 1, Xs) ->
+ strict(arg_types(hipe_bifs, call_count_on, 1), Xs,
+ fun (_) -> t_sup(t_atom('true'), t_nil()) end);
+type(hipe_bifs, check_crc, 1, Xs) ->
+ strict(arg_types(hipe_bifs, check_crc, 1), Xs, fun (_) -> t_boolean() end);
+type(hipe_bifs, enter_code, 2, Xs) ->
+ strict(arg_types(hipe_bifs, enter_code, 2), Xs,
+ fun (_) -> t_tuple([t_integer(),
+ %% XXX: The tuple below contains integers and
+ %% is of size same as the length of the MFA list
+ t_sup(t_nil(), t_binary())]) end);
+type(hipe_bifs, enter_sdesc, 1, Xs) ->
+ strict(arg_types(hipe_bifs, enter_sdesc, 1), Xs, fun (_) -> t_nil() end);
+type(hipe_bifs, find_na_or_make_stub, 2, Xs) ->
+ strict(arg_types(hipe_bifs, find_na_or_make_stub, 2), Xs,
+ fun (_) -> t_integer() end); % address
+type(hipe_bifs, fun_to_address, 1, Xs) ->
+ strict(arg_types(hipe_bifs, fun_to_address, 1), Xs,
+ fun (_) -> t_integer() end);
+%% type(hipe_bifs, get_emu_address, 1, Xs) ->
+%% strict(arg_types(hipe_bifs, get_emu_address, 1), Xs,
+%% fun (_) -> t_integer() end); % address
+type(hipe_bifs, get_rts_param, 1, Xs) ->
+ strict(arg_types(hipe_bifs, get_rts_param, 1), Xs,
+ fun (_) -> t_sup(t_integer(), t_nil()) end);
+type(hipe_bifs, invalidate_funinfo_native_addresses, 1, Xs) ->
+ strict(arg_types(hipe_bifs, invalidate_funinfo_native_addresses, 1), Xs,
+ fun (_) -> t_nil() end);
+type(hipe_bifs, make_fe, 3, Xs) ->
+ strict(arg_types(hipe_bifs, make_fe, 3), Xs, fun (_) -> t_integer() end);
+%% type(hipe_bifs, make_native_stub, 2, Xs) ->
+%% strict(arg_types(hipe_bifs, make_native_stub, 2), Xs,
+%% fun (_) -> t_integer() end); % address
+type(hipe_bifs, mark_referred_from, 1, Xs) ->
+ strict(arg_types(hipe_bifs, mark_referred_from, 1), Xs,
+ fun (_) -> t_nil() end);
+type(hipe_bifs, merge_term, 1, Xs) ->
+ strict(arg_types(hipe_bifs, merge_term, 1), Xs, fun ([X]) -> X end);
+type(hipe_bifs, patch_call, 3, Xs) ->
+ strict(arg_types(hipe_bifs, patch_call, 3), Xs, fun (_) -> t_nil() end);
+type(hipe_bifs, patch_insn, 3, Xs) ->
+ strict(arg_types(hipe_bifs, patch_insn, 3), Xs, fun (_) -> t_nil() end);
+type(hipe_bifs, primop_address, 1, Xs) ->
+ strict(arg_types(hipe_bifs, primop_address, 1), Xs,
+ fun (_) -> t_sup(t_integer(), t_atom('false')) end);
+type(hipe_bifs, redirect_referred_from, 1, Xs) ->
+ strict(arg_types(hipe_bifs, redirect_referred_from, 1), Xs,
+ fun (_) -> t_nil() end);
+type(hipe_bifs, ref, 1, Xs) ->
+ strict(arg_types(hipe_bifs, ref, 1), Xs, fun (_) -> t_immarray() end);
+type(hipe_bifs, ref_get, 1, Xs) ->
+ strict(arg_types(hipe_bifs, ref_get, 1), Xs, fun (_) -> t_immediate() end);
+type(hipe_bifs, ref_set, 2, Xs) ->
+ strict(arg_types(hipe_bifs, ref_set, 2), Xs, fun (_) -> t_nil() end);
+type(hipe_bifs, remove_refs_from, 1, Xs) ->
+ strict(arg_types(hipe_bifs, remove_refs_from, 1), Xs,
+ fun (_) -> t_nil() end);
+type(hipe_bifs, set_funinfo_native_address, 3, Xs) ->
+ strict(arg_types(hipe_bifs, set_funinfo_native_address, 3), Xs,
+ fun (_) -> t_nil() end);
+type(hipe_bifs, set_native_address, 3, Xs) ->
+ strict(arg_types(hipe_bifs, set_native_address, 3), Xs,
+ fun (_) -> t_nil() end);
+type(hipe_bifs, system_crc, 1, Xs) ->
+ strict(arg_types(hipe_bifs, system_crc, 1), Xs, fun (_) -> t_integer() end);
+type(hipe_bifs, term_to_word, 1, Xs) ->
+ strict(arg_types(hipe_bifs, term_to_word, 1), Xs,
+ fun (_) -> t_integer() end);
+type(hipe_bifs, update_code_size, 3, Xs) ->
+ strict(arg_types(hipe_bifs, update_code_size, 3), Xs,
+ fun (_) -> t_nil() end);
+type(hipe_bifs, write_u8, 2, Xs) ->
+ strict(arg_types(hipe_bifs, write_u8, 2), Xs, fun (_) -> t_nil() end);
+type(hipe_bifs, write_u32, 2, Xs) ->
+ strict(arg_types(hipe_bifs, write_u32, 2), Xs, fun (_) -> t_nil() end);
+type(hipe_bifs, write_u64, 2, Xs) ->
+ strict(arg_types(hipe_bifs, write_u64, 2), Xs, fun (_) -> t_nil() end);
+%%-- io -----------------------------------------------------------------------
+type(io, format, 1, Xs) ->
+ strict(arg_types(io, format, 1), Xs, fun (_) -> t_atom('ok') end);
+type(io, format, 2, Xs) ->
+ strict(arg_types(io, format, 2), Xs, fun (_) -> t_atom('ok') end);
+type(io, format, 3, Xs) ->
+ strict(arg_types(io, format, 3), Xs, fun (_) -> t_atom('ok') end);
+type(io, fwrite, 1, Xs) -> type(io, format, 1, Xs); % same
+type(io, fwrite, 2, Xs) -> type(io, format, 2, Xs); % same
+type(io, fwrite, 3, Xs) -> type(io, format, 3, Xs); % same
+type(io, put_chars, 1, Xs) ->
+ strict(arg_types(io, put_chars, 1), Xs, fun (_) -> t_atom('ok') end);
+type(io, put_chars, 2, Xs) ->
+ strict(arg_types(io, put_chars, 2), Xs, fun (_) -> t_atom('ok') end);
+%%-- io_lib -------------------------------------------------------------------
+type(io_lib, format, 2, Xs) ->
+ strict(arg_types(io_lib, format, 2), Xs,
+ %% t_list() because the character list might be arbitrarily nested
+ fun (_) -> t_list(t_sup(t_char(), t_list())) end);
+type(io_lib, fwrite, 2, Xs) -> type(io_lib, format, 2, Xs); % same
+%%-- lists --------------------------------------------------------------------
+type(lists, all, 2, Xs) ->
+ strict(arg_types(lists, all, 2), Xs,
+ fun ([F, L]) ->
+ case t_is_nil(L) of
+ true -> t_atom('true');
+ false ->
+ El = t_list_elements(L),
+ case check_fun_application(F, [El]) of
+ ok ->
+ case t_is_cons(L) of
+ true -> t_fun_range(F);
+ false ->
+ %% The list can be empty.
+ t_sup(t_atom('true'), t_fun_range(F))
+ end;
+ error ->
+ case t_is_cons(L) of
+ true -> t_none();
+ false -> t_fun_range(F)
+ end
+ end
+ end
+ end);
+type(lists, any, 2, Xs) ->
+ strict(arg_types(lists, any, 2), Xs,
+ fun ([F, L]) ->
+ case t_is_nil(L) of
+ true -> t_atom('false');
+ false ->
+ El = t_list_elements(L),
+ case check_fun_application(F, [El]) of
+ ok ->
+ case t_is_cons(L) of
+ true -> t_fun_range(F);
+ false ->
+ %% The list can be empty
+ t_sup(t_atom('false'), t_fun_range(F))
+ end;
+ error ->
+ case t_is_cons(L) of
+ true -> t_none();
+ false -> t_fun_range(F)
+ end
+ end
+ end
+ end);
+type(lists, append, 2, Xs) -> type(erlang, '++', 2, Xs); % alias
+type(lists, delete, 2, Xs) ->
+ strict(arg_types(lists, delete, 2), Xs,
+ fun ([_, List]) ->
+ case t_is_cons(List) of
+ true -> t_cons_tl(List);
+ false -> List
+ end
+ end);
+type(lists, dropwhile, 2, Xs) ->
+ strict(arg_types(lists, dropwhile, 2), Xs,
+ fun ([F, X]) ->
+ case t_is_nil(X) of
+ true -> t_nil();
+ false ->
+ X1 = t_list_elements(X),
+ case check_fun_application(F, [X1]) of
+ ok ->
+ case t_atom_vals(t_fun_range(F)) of
+ ['true'] ->
+ case t_is_none(t_inf(t_list(), X)) of
+ true -> t_none();
+ false -> t_nil()
+ end;
+ ['false'] ->
+ case t_is_none(t_inf(t_list(), X)) of
+ true -> t_none();
+ false -> X
+ end;
+ _ ->
+ t_inf(t_cons_tl(t_inf(X, t_cons())),
+ t_maybe_improper_list())
+ end;
+ error ->
+ case t_is_cons(X) of
+ true -> t_none();
+ false -> t_nil()
+ end
+ end
+ end
+ end);
+type(lists, filter, 2, Xs) ->
+ strict(arg_types(lists, filter, 2), Xs,
+ fun ([F, L]) ->
+ case t_is_nil(L) of
+ true -> t_nil();
+ false ->
+ T = t_list_elements(L),
+ case check_fun_application(F, [T]) of
+ ok ->
+ case t_atom_vals(t_fun_range(F)) =:= ['false'] of
+ true -> t_nil();
+ false ->
+ case t_atom_vals(t_fun_range(F)) =:= ['true'] of
+ true -> L;
+ false -> t_list(T)
+ end
+ end;
+ error ->
+ case t_is_cons(L) of
+ true -> t_none();
+ false -> t_nil()
+ end
+ end
+ end
+ end);
+type(lists, flatten, 1, Xs) ->
+ strict(arg_types(lists, flatten, 1), Xs,
+ fun ([L]) ->
+ case t_is_nil(L) of
+ true -> L; % (nil has undefined elements)
+ false ->
+ %% Avoiding infinite recursion is tricky
+ X1 = t_list_elements(L),
+ case t_is_any(X1) of
+ true ->
+ t_list();
+ false ->
+ X2 = type(lists, flatten, 1, [t_inf(X1, t_list())]),
+ t_sup(t_list(t_subtract(X1, t_list())),
+ X2)
+ end
+ end
+ end);
+type(lists, flatmap, 2, Xs) ->
+ strict(arg_types(lists, flatmap, 2), Xs,
+ fun ([F, List]) ->
+ case t_is_nil(List) of
+ true -> t_nil();
+ false ->
+ case check_fun_application(F, [t_list_elements(List)]) of
+ ok ->
+ case t_is_cons(List) of
+ true -> t_nonempty_list(t_list_elements(t_fun_range(F)));
+ false -> t_list(t_list_elements(t_fun_range(F)))
+ end;
+ error ->
+ case t_is_cons(List) of
+ true -> t_none();
+ false -> t_nil()
+ end
+ end
+ end
+ end);
+type(lists, foreach, 2, Xs) ->
+ strict(arg_types(lists, foreach, 2), Xs,
+ fun ([F, List]) ->
+ case t_is_cons(List) of
+ true ->
+ case check_fun_application(F, [t_list_elements(List)]) of
+ ok -> t_atom('ok');
+ error -> t_none()
+ end;
+ false ->
+ t_atom('ok')
+ end
+ end);
+type(lists, foldl, 3, Xs) ->
+ strict(arg_types(lists, foldl, 3), Xs,
+ fun ([F, Acc, List]) ->
+ case t_is_nil(List) of
+ true -> Acc;
+ false ->
+ case check_fun_application(F, [t_list_elements(List), Acc]) of
+ ok ->
+ case t_is_cons(List) of
+ true -> t_fun_range(F);
+ false -> t_sup(t_fun_range(F), Acc)
+ end;
+ error ->
+ case t_is_cons(List) of
+ true -> t_none();
+ false -> Acc
+ end
+ end
+ end
+ end);
+type(lists, foldr, 3, Xs) -> type(lists, foldl, 3, Xs); % same
+type(lists, keydelete, 3, Xs) ->
+ strict(arg_types(lists, keydelete, 3), Xs,
+ fun ([_, _, L]) ->
+ Term = t_list_termination(L),
+ t_sup(Term, erl_types:lift_list_to_pos_empty(L))
+ end);
+type(lists, keyfind, 3, Xs) ->
+ strict(arg_types(lists, keyfind, 3), Xs,
+ fun ([X, Y, Z]) ->
+ ListEs = t_list_elements(Z),
+ Tuple = t_inf(t_tuple(), ListEs),
+ case t_is_none(Tuple) of
+ true -> t_atom('false');
+ false ->
+ %% this BIF, contrary to lists:keysearch/3 does not
+ %% wrap its result in a 'value'-tagged tuple
+ Ret = t_sup(Tuple, t_atom('false')),
+ case t_is_any(X) of
+ true -> Ret;
+ false ->
+ case t_tuple_subtypes(Tuple) of
+ unknown -> Ret;
+ List ->
+ Keys = [type(erlang, element, 2, [Y, S])
+ || S <- List],
+ Infs = [t_inf(Key, X) || Key <- Keys],
+ case all_is_none(Infs) of
+ true -> t_atom('false');
+ false -> Ret
+ end
+ end
+ end
+ end
+ end);
+type(lists, keymap, 3, Xs) ->
+ strict(arg_types(lists, keymap, 3), Xs,
+ fun ([F, _I, L]) ->
+ case t_is_nil(L) of
+ true -> L;
+ false -> t_list(t_sup(t_fun_range(F), t_list_elements(L)))
+ end
+ end);
+type(lists, keymember, 3, Xs) ->
+ strict(arg_types(lists, keymember, 3), Xs,
+ fun ([X, Y, Z]) ->
+ ListEs = t_list_elements(Z),
+ Tuple = t_inf(t_tuple(), ListEs),
+ case t_is_none(Tuple) of
+ true -> t_atom('false');
+ false ->
+ case t_is_any(X) of
+ true -> t_boolean();
+ false ->
+ case t_tuple_subtypes(Tuple) of
+ unknown -> t_boolean();
+ List ->
+ Keys = [type(erlang, element, 2, [Y,S]) || S <- List],
+ Infs = [t_inf(Key, X) || Key <- Keys],
+ case all_is_none(Infs) of
+ true -> t_atom('false');
+ false -> t_boolean()
+ end
+ end
+ end
+ end
+ end);
+type(lists, keymerge, 3, Xs) ->
+ strict(arg_types(lists, keymerge, 3), Xs,
+ fun ([_I, L1, L2]) -> type(lists, merge, 2, [L1, L2]) end);
+type(lists, keyreplace, 4, Xs) ->
+ strict(arg_types(lists, keyreplace, 4), Xs,
+ fun ([_K, _I, L, T]) -> t_list(t_sup(t_list_elements(L), T)) end);
+type(lists, keysearch, 3, Xs) ->
+ strict(arg_types(lists, keysearch, 3), Xs,
+ fun ([X, Y, Z]) ->
+ ListEs = t_list_elements(Z),
+ Tuple = t_inf(t_tuple(), ListEs),
+ case t_is_none(Tuple) of
+ true -> t_atom('false');
+ false ->
+ Ret = t_sup(t_tuple([t_atom('value'), Tuple]),
+ t_atom('false')),
+ case t_is_any(X) of
+ true -> Ret;
+ false ->
+ case t_tuple_subtypes(Tuple) of
+ unknown -> Ret;
+ List ->
+ Keys = [type(erlang, element, 2, [Y, S])
+ || S <- List],
+ Infs = [t_inf(Key, X) || Key <- Keys],
+ case all_is_none(Infs) of
+ true -> t_atom('false');
+ false -> Ret
+ end
+ end
+ end
+ end
+ end);
+type(lists, keysort, 2, Xs) ->
+ strict(arg_types(lists, keysort, 2), Xs, fun ([_, L]) -> L end);
+type(lists, last, 1, Xs) ->
+ strict(arg_types(lists, last, 1), Xs, fun ([L]) -> t_list_elements(L) end);
+type(lists, map, 2, Xs) ->
+ strict(arg_types(lists, map, 2), Xs,
+ fun ([F, L]) ->
+ case t_is_nil(L) of
+ true -> L;
+ false ->
+ El = t_list_elements(L),
+ case t_is_cons(L) of
+ true ->
+ case check_fun_application(F, [El]) of
+ ok -> t_nonempty_list(t_fun_range(F));
+ error -> t_none()
+ end;
+ false ->
+ case check_fun_application(F, [El]) of
+ ok -> t_list(t_fun_range(F));
+ error -> t_nil()
+ end
+ end
+ end
+ end);
+type(lists, mapfoldl, 3, Xs) ->
+ strict(arg_types(lists, mapfoldl, 3), Xs,
+ fun ([F, Acc, List]) ->
+ case t_is_nil(List) of
+ true -> t_tuple([List, Acc]);
+ false ->
+ El = t_list_elements(List),
+ R = t_fun_range(F),
+ case t_is_cons(List) of
+ true ->
+ case check_fun_application(F, [El, Acc]) of
+ ok ->
+ Fun = fun (RangeTuple) ->
+ [T1, T2] = t_tuple_args(RangeTuple),
+ t_tuple([t_nonempty_list(T1), T2])
+ end,
+ t_sup([Fun(ST) || ST <- t_tuple_subtypes(R)]);
+ error ->
+ t_none()
+ end;
+ false ->
+ case check_fun_application(F, [El, Acc]) of
+ ok ->
+ Fun = fun (RangeTuple) ->
+ [T1, T2] = t_tuple_args(RangeTuple),
+ t_tuple([t_list(T1), t_sup(Acc, T2)])
+ end,
+ t_sup([Fun(ST) || ST <- t_tuple_subtypes(R)]);
+ error ->
+ t_tuple([t_nil(), Acc])
+ end
+ end
+ end
+ end);
+type(lists, mapfoldr, 3, Xs) -> type(lists, mapfoldl, 3, Xs); % same
+type(lists, max, 1, Xs) ->
+ strict(arg_types(lists, max, 1), Xs, fun ([L]) -> t_list_elements(L) end);
+type(lists, member, 2, Xs) ->
+ strict(arg_types(lists, member, 2), Xs,
+ fun ([X, Y]) ->
+ Y1 = t_list_elements(Y),
+ case t_is_none(t_inf(Y1, X)) of
+ true -> t_atom('false');
+ false -> t_boolean()
+ end
+ end);
+%% type(lists, merge, 1, Xs) ->
+type(lists, merge, 2, Xs) ->
+ strict(arg_types(lists, merge, 2), Xs,
+ fun ([L1, L2]) ->
+ case t_is_none(L1) of
+ true -> L2;
+ false ->
+ case t_is_none(L2) of
+ true -> L1;
+ false -> t_sup(L1, L2)
+ end
+ end
+ end);
+%% type(lists, merge, 3, Xs) ->
+%% type(lists, merge3, 3, Xs) ->
+type(lists, min, 1, Xs) ->
+ strict(arg_types(lists, min, 1), Xs, fun ([L]) -> t_list_elements(L) end);
+type(lists, nth, 2, Xs) ->
+ strict(arg_types(lists, nth, 2), Xs,
+ fun ([_, Y]) -> t_list_elements(Y) end);
+type(lists, nthtail, 2, Xs) ->
+ strict(arg_types(lists, nthtail, 2), Xs,
+ fun ([_, Y]) -> t_sup(Y, t_list()) end);
+type(lists, partition, 2, Xs) ->
+ strict(arg_types(lists, partition, 2), Xs,
+ fun ([F, L]) ->
+ case t_is_nil(L) of
+ true -> t_tuple([L,L]);
+ false ->
+ El = t_list_elements(L),
+ case check_fun_application(F, [El]) of
+ error ->
+ case t_is_cons(L) of
+ true -> t_none();
+ false -> t_tuple([t_nil(), t_nil()])
+ end;
+ ok ->
+ case t_atom_vals(t_fun_range(F)) of
+ ['true'] -> t_tuple([L, t_nil()]);
+ ['false'] -> t_tuple([t_nil(), L]);
+ [_, _] ->
+ L2 = t_list(El),
+ t_tuple([L2, L2])
+ end
+ end
+ end
+ end);
+type(lists, reverse, 1, Xs) ->
+ strict(arg_types(lists, reverse, 1), Xs, fun ([X]) -> X end);
+type(lists, reverse, 2, Xs) ->
+ type(erlang, '++', 2, Xs); % reverse-onto is just like append
+type(lists, seq, 2, Xs) ->
+ strict(arg_types(lists, seq, 2), Xs, fun (_) -> t_list(t_integer()) end);
+type(lists, seq, 3, Xs) ->
+ strict(arg_types(lists, seq, 3), Xs, fun (_) -> t_list(t_integer()) end);
+type(lists, sort, 1, Xs) ->
+ strict(arg_types(lists, sort, 1), Xs, fun ([X]) -> X end);
+type(lists, sort, 2, Xs) ->
+ strict(arg_types(lists, sort, 2), Xs,
+ fun ([F, L]) ->
+ R = t_fun_range(F),
+ case t_is_boolean(R) of
+ true -> L;
+ false ->
+ case t_is_nil(L) of
+ true -> t_nil();
+ false -> t_none()
+ end
+ end
+ end);
+type(lists, split, 2, Xs) ->
+ strict(arg_types(lists, split, 2), Xs,
+ fun ([_, L]) ->
+ case t_is_nil(L) of
+ true -> t_tuple([L, L]);
+ false ->
+ T = t_list_elements(L),
+ t_tuple([t_list(T), t_list(T)])
+ end
+ end);
+type(lists, splitwith, 2, Xs) ->
+ T1 = type(lists, takewhile, 2, Xs),
+ T2 = type(lists, dropwhile, 2, Xs),
+ case t_is_none(T1) orelse t_is_none(T2) of
+ true -> t_none();
+ false -> t_tuple([T1, T2])
+ end;
+type(lists, subtract, 2, Xs) -> type(erlang, '--', 2, Xs); % alias
+type(lists, takewhile, 2, Xs) ->
+ strict(arg_types(lists, takewhile, 2), Xs,
+ fun([F, L]) ->
+ case t_is_none(t_inf(t_list(), L)) of
+ false -> type(lists, filter, 2, Xs);
+ true ->
+ %% This works for non-proper lists as well.
+ El = t_list_elements(L),
+ type(lists, filter, 2, [F, t_list(El)])
+ end
+ end);
+type(lists, usort, 1, Xs) -> type(lists, sort, 1, Xs); % same
+type(lists, usort, 2, Xs) -> type(lists, sort, 2, Xs); % same
+type(lists, unzip, 1, Xs) ->
+ strict(arg_types(lists, unzip, 1), Xs,
+ fun ([Ps]) ->
+ case t_is_nil(Ps) of
+ true ->
+ t_tuple([t_nil(), t_nil()]);
+ false -> % Ps is a proper list of pairs
+ TupleTypes = t_tuple_subtypes(t_list_elements(Ps)),
+ lists:foldl(fun(Tuple, Acc) ->
+ [A, B] = t_tuple_args(Tuple),
+ t_sup(t_tuple([t_list(A), t_list(B)]), Acc)
+ end, t_none(), TupleTypes)
+ end
+ end);
+type(lists, unzip3, 1, Xs) ->
+ strict(arg_types(lists, unzip3, 1), Xs,
+ fun ([Ts]) ->
+ case t_is_nil(Ts) of
+ true ->
+ t_tuple([t_nil(), t_nil(), t_nil()]);
+ false -> % Ps is a proper list of triples
+ TupleTypes = t_tuple_subtypes(t_list_elements(Ts)),
+ lists:foldl(fun(T, Acc) ->
+ [A, B, C] = t_tuple_args(T),
+ t_sup(t_tuple([t_list(A),
+ t_list(B),
+ t_list(C)]),
+ Acc)
+ end, t_none(), TupleTypes)
+ end
+ end);
+type(lists, zip, 2, Xs) ->
+ strict(arg_types(lists, zip, 2), Xs,
+ fun ([As, Bs]) ->
+ case (t_is_nil(As) orelse t_is_nil(Bs)) of
+ true -> t_nil();
+ false ->
+ A = t_list_elements(As),
+ B = t_list_elements(Bs),
+ t_list(t_tuple([A, B]))
+ end
+ end);
+type(lists, zip3, 3, Xs) ->
+ strict(arg_types(lists, zip3, 3), Xs,
+ fun ([As, Bs, Cs]) ->
+ case (t_is_nil(As) orelse t_is_nil(Bs) orelse t_is_nil(Cs)) of
+ true -> t_nil();
+ false ->
+ A = t_list_elements(As),
+ B = t_list_elements(Bs),
+ C = t_list_elements(Cs),
+ t_list(t_tuple([A, B, C]))
+ end
+ end);
+type(lists, zipwith, 3, Xs) ->
+ strict(arg_types(lists, zipwith, 3), Xs,
+ fun ([F, _As, _Bs]) -> t_sup(t_list(t_fun_range(F)), t_nil()) end);
+type(lists, zipwith3, 4, Xs) ->
+ strict(arg_types(lists, zipwith3, 4), Xs,
+ fun ([F,_As,_Bs,_Cs]) -> t_sup(t_list(t_fun_range(F)), t_nil()) end);
+%%-- math ---------------------------------------------------------------------
+type(math, acos, 1, Xs) ->
+ strict(arg_types(math, acos, 1), Xs, fun (_) -> t_float() end);
+type(math, acosh, 1, Xs) ->
+ strict(arg_types(math, acosh, 1), Xs, fun (_) -> t_float() end);
+type(math, asin, 1, Xs) ->
+ strict(arg_types(math, asin, 1), Xs, fun (_) -> t_float() end);
+type(math, asinh, 1, Xs) ->
+ strict(arg_types(math, asinh, 1), Xs, fun (_) -> t_float() end);
+type(math, atan, 1, Xs) ->
+ strict(arg_types(math, atan, 1), Xs, fun (_) -> t_float() end);
+type(math, atan2, 2, Xs) ->
+ strict(arg_types(math, atan2, 2), Xs, fun (_) -> t_float() end);
+type(math, atanh, 1, Xs) ->
+ strict(arg_types(math, atanh, 1), Xs, fun (_) -> t_float() end);
+type(math, cos, 1, Xs) ->
+ strict(arg_types(math, cos, 1), Xs, fun (_) -> t_float() end);
+type(math, cosh, 1, Xs) ->
+ strict(arg_types(math, cosh, 1), Xs, fun (_) -> t_float() end);
+type(math, erf, 1, Xs) ->
+ strict(arg_types(math, erf, 1), Xs, fun (_) -> t_float() end);
+type(math, erfc, 1, Xs) ->
+ strict(arg_types(math, erfc, 1), Xs, fun (_) -> t_float() end);
+type(math, exp, 1, Xs) ->
+ strict(arg_types(math, exp, 1), Xs, fun (_) -> t_float() end);
+type(math, log, 1, Xs) ->
+ strict(arg_types(math, log, 1), Xs, fun (_) -> t_float() end);
+type(math, log10, 1, Xs) ->
+ strict(arg_types(math, log10, 1), Xs, fun (_) -> t_float() end);
+type(math, pi, 0, _) -> t_float();
+type(math, pow, 2, Xs) ->
+ strict(arg_types(math, pow, 2), Xs, fun (_) -> t_float() end);
+type(math, sin, 1, Xs) ->
+ strict(arg_types(math, sin, 1), Xs, fun (_) -> t_float() end);
+type(math, sinh, 1, Xs) ->
+ strict(arg_types(math, sinh, 1), Xs, fun (_) -> t_float() end);
+type(math, sqrt, 1, Xs) ->
+ strict(arg_types(math, sqrt, 1), Xs, fun (_) -> t_float() end);
+type(math, tan, 1, Xs) ->
+ strict(arg_types(math, tan, 1), Xs, fun (_) -> t_float() end);
+type(math, tanh, 1, Xs) ->
+ strict(arg_types(math, tanh, 1), Xs, fun (_) -> t_float() end);
+%%-- net_kernel ---------------------------------------------------------------
+type(net_kernel, dflag_unicode_io, 1, Xs) ->
+ strict(arg_types(net_kernel, dflag_unicode_io, 1), Xs,
+ fun (_) -> t_boolean() end);
+%%-- ordsets ------------------------------------------------------------------
+type(ordsets, filter, 2, Xs) ->
+ type(lists, filter, 2, Xs);
+type(ordsets, fold, 3, Xs) ->
+ type(lists, foldl, 3, Xs);
+%%-- os -----------------------------------------------------------------------
+type(os, getenv, 0, _) -> t_list(t_string());
+type(os, getenv, 1, Xs) ->
+ strict(arg_types(os, getenv, 1), Xs,
+ fun (_) -> t_sup(t_string(), t_atom('false')) end);
+type(os, getpid, 0, _) -> t_string();
+type(os, putenv, 2, Xs) ->
+ strict(arg_types(os, putenv, 2), Xs, fun (_) -> t_atom('true') end);
+%%-- re -----------------------------------------------------------------------
+type(re, compile, 1, Xs) ->
+ strict(arg_types(re, compile, 1), Xs,
+ fun (_) ->
+ t_sup(t_tuple([t_atom('ok'), t_re_MP()]),
+ t_tuple([t_atom('error'), t_re_ErrorSpec()]))
+ end);
+type(re, compile, 2, Xs) ->
+ strict(arg_types(re, compile, 2), Xs,
+ fun (_) ->
+ t_sup(t_tuple([t_atom('ok'), t_re_MP()]),
+ t_tuple([t_atom('error'), t_re_ErrorSpec()]))
+ end);
+type(re, run, 2, Xs) ->
+ strict(arg_types(re, run, 2), Xs,
+ fun (_) ->
+ t_sup([t_tuple([t_atom('match'), t_re_Captured()]),
+ t_atom('nomatch'),
+ t_tuple([t_atom('error'), t_re_ErrorSpec()])])
+ end);
+type(re, run, 3, Xs) ->
+ strict(arg_types(re, run, 3), Xs,
+ fun (_) ->
+ t_sup([t_tuple([t_atom('match'), t_re_Captured()]),
+ t_atom('match'),
+ t_atom('nomatch'),
+ t_tuple([t_atom('error'), t_re_ErrorSpec()])])
+ end);
+%%-- string -------------------------------------------------------------------
+type(string, chars, 2, Xs) -> % NOTE: added to avoid loss of information
+ strict(arg_types(string, chars, 2), Xs, fun (_) -> t_string() end);
+type(string, chars, 3, Xs) -> % NOTE: added to avoid loss of information
+ strict(arg_types(string, chars, 3), Xs,
+ fun ([Char, N, Tail]) ->
+ case t_is_nil(Tail) of
+ true ->
+ type(string, chars, 2, [Char, N]);
+ false ->
+ case t_is_string(Tail) of
+ true ->
+ t_string();
+ false ->
+ t_sup(t_sup(t_string(), Tail), t_cons(Char, Tail))
+ end
+ end
+ end);
+type(string, concat, 2, Xs) -> % NOTE: added to avoid loss of information
+ strict(arg_types(string, concat, 2), Xs, fun (_) -> t_string() end);
+type(string, equal, 2, Xs) -> % NOTE: added to avoid loss of information
+ strict(arg_types(string, equal, 2), Xs, fun (_) -> t_boolean() end);
+type(string, to_float, 1, Xs) ->
+ strict(arg_types(string, to_float, 1), Xs,
+ fun (_) -> t_sup(t_tuple([t_float(), t_string()]),
+ t_tuple([t_atom('error'),
+ t_sup(t_atom('no_float'),
+ t_atom('not_a_list'))]))
+ end);
+type(string, to_integer, 1, Xs) ->
+ strict(arg_types(string, to_integer, 1), Xs,
+ fun (_) -> t_sup(t_tuple([t_integer(), t_string()]),
+ t_tuple([t_atom('error'),
+ t_sup(t_atom('no_integer'),
+ t_atom('not_a_list'))]))
+ end);
+%%-- unicode ------------------------------------------------------------------
+type(unicode, characters_to_binary, 2, Xs) ->
+ strict(arg_types(unicode, characters_to_binary, 2), Xs,
+ fun (_) ->
+ t_sup([t_binary(),
+ t_tuple([t_atom('error'), t_binary(), t_ML()]),
+ t_tuple([t_atom('incomplete'), t_binary(), t_ML()])])
+ end);
+type(unicode, characters_to_list, 2, Xs) ->
+ strict(arg_types(unicode, characters_to_list, 2), Xs,
+ fun (_) ->
+ t_sup([t_string(),
+ t_tuple([t_atom('error'), t_string(), t_ML()]),
+ t_tuple([t_atom('incomplete'), t_string(), t_ML()])])
+ end);
+type(unicode, bin_is_7bit, 1, Xs) ->
+ strict(arg_types(unicode, bin_is_7bit, 1), Xs, fun (_) -> t_boolean() end);
+
+%%-----------------------------------------------------------------------------
+type(M, F, A, Xs) when is_atom(M), is_atom(F),
+ is_integer(A), 0 =< A, A =< 255 ->
+ strict(Xs, t_any()). % safe approximation for all functions.
+
+
+%%-----------------------------------------------------------------------------
+%% Auxiliary functions
+%%-----------------------------------------------------------------------------
+
+strict(Xs, Ts, F) ->
+ %% io:format("inf lists arg~n1:~p~n2:~p ~n", [Xs, Ts]),
+ Xs1 = inf_lists(Xs, Ts),
+ %% io:format("inf lists return ~p ~n", [Xs1]),
+ case any_is_none_or_unit(Xs1) of
+ true -> t_none();
+ false -> F(Xs1)
+ end.
+
+strict(Xs, X) ->
+ case any_is_none_or_unit(Xs) of
+ true -> t_none();
+ false -> X
+ end.
+
+inf_lists([X | Xs], [T | Ts]) ->
+ [t_inf(X, T) | inf_lists(Xs, Ts)];
+inf_lists([], []) ->
+ [].
+
+any_list(N) -> any_list(N, t_any()).
+
+any_list(N, A) when N > 0 ->
+ [A | any_list(N - 1, A)];
+any_list(0, _) ->
+ [].
+
+list_replace(N, E, [X | Xs]) when N > 1 ->
+ [X | list_replace(N - 1, E, Xs)];
+list_replace(1, E, [_X | Xs]) ->
+ [E | Xs].
+
+any_is_none_or_unit(Ts) ->
+ lists:any(fun erl_types:t_is_none_or_unit/1, Ts).
+
+all_is_none(Ts) ->
+ lists:all(fun erl_types:t_is_none/1, Ts).
+
+check_guard([X], Test, Type) ->
+ check_guard_single(X, Test, Type).
+
+check_guard_single(X, Test, Type) ->
+ case Test(X) of
+ true -> t_atom('true');
+ false ->
+ case erl_types:t_is_opaque(X) of
+ true -> t_none();
+ false ->
+ case t_is_none(t_inf(Type, X)) of
+ true -> t_atom('false');
+ false -> t_boolean()
+ end
+ end
+ end.
+
+%%-----------------------------------------------------------------------------
+%% Functions for range analysis
+%%-----------------------------------------------------------------------------
+
+infinity_max([]) -> empty;
+infinity_max([H|T]) ->
+ if H =:= empty ->
+ infinity_max(T);
+ true ->
+ lists:foldl(
+ fun (Elem, Max) ->
+ Geq = infinity_geq(Elem, Max),
+ if not Geq orelse (Elem =:= empty) ->
+ Max;
+ true ->
+ Elem
+ end
+ end,
+ H,
+ T)
+ end.
+
+infinity_min([]) -> empty;
+infinity_min([H|T]) ->
+ if H =:= empty ->
+ infinity_min(T);
+ true ->
+ lists:foldl(fun (Elem, Min) ->
+ Geq = infinity_geq(Elem, Min),
+ if Geq orelse (Elem =:= empty) ->
+ Min;
+ true ->
+ Elem
+ end
+ end,
+ H,
+ T)
+ end.
+
+-type inf_integer() :: 'neg_inf' | 'pos_inf' | integer().
+
+-spec infinity_abs('pos_inf' | 'neg_inf') -> 'pos_inf'
+ ; (integer()) -> non_neg_integer().
+
+infinity_abs(pos_inf) -> pos_inf;
+infinity_abs(neg_inf) -> pos_inf;
+infinity_abs(Number) when is_integer(Number) -> abs(Number).
+
+%% span_zero(Range) ->
+%% infinity_geq(0, number_min(Range)) and infinity_geq(number_max(Range), 0).
+
+infinity_inv(pos_inf) -> neg_inf;
+infinity_inv(neg_inf) -> pos_inf;
+infinity_inv(Number) when is_integer(Number) -> -Number.
+
+infinity_band(neg_inf, Type2) -> Type2;
+%% infinity_band(Type1, neg_inf) -> Type1;
+infinity_band(pos_inf, Type2) -> Type2;
+%% infinity_band(Type1, pos_inf) -> Type1;
+infinity_band(Type1, Type2) when is_integer(Type1), is_integer(Type2) ->
+ Type1 band Type2.
+
+infinity_bor(neg_inf, _Type2) -> neg_inf;
+%% infinity_bor(_Type1, neg_inf) -> neg_inf;
+infinity_bor(pos_inf, _Type2) -> pos_inf;
+%% infinity_bor(_Type1, pos_inf) -> pos_inf;
+infinity_bor(Type1, Type2) when is_integer(Type1), is_integer(Type2) ->
+ Type1 bor Type2.
+
+infinity_div(pos_inf, pos_inf) -> [0, pos_inf];
+infinity_div(pos_inf, neg_inf) -> [neg_inf, 0];
+infinity_div(neg_inf, neg_inf) -> [0, pos_inf];
+infinity_div(neg_inf, pos_inf) -> [neg_inf, 0];
+infinity_div(pos_inf, Number) when is_integer(Number), Number > 0 -> pos_inf;
+infinity_div(pos_inf, Number) when is_integer(Number), Number < 0 -> neg_inf;
+infinity_div(neg_inf, Number) when is_integer(Number), Number > 0 -> neg_inf;
+infinity_div(neg_inf, Number) when is_integer(Number), Number < 0 -> pos_inf;
+infinity_div(Number, pos_inf) when is_integer(Number), Number >= 0 -> pos_inf;
+infinity_div(Number, pos_inf) when is_integer(Number), Number < 0 -> neg_inf;
+infinity_div(Number, neg_inf) when is_integer(Number), Number >= 0 -> neg_inf;
+infinity_div(Number, neg_inf) when is_integer(Number), Number < 0 -> pos_inf;
+infinity_div(Number1, Number2) when is_integer(Number1), is_integer(Number2) ->
+ Number1 div Number2.
+
+infinity_bsl(pos_inf, _) -> pos_inf;
+infinity_bsl(neg_inf, _) -> neg_inf;
+infinity_bsl(Number, pos_inf) when is_integer(Number), Number >= 0 -> pos_inf;
+infinity_bsl(Number, pos_inf) when is_integer(Number) -> neg_inf;
+infinity_bsl(Number, neg_inf) when is_integer(Number), Number >= 0 -> 0;
+infinity_bsl(Number, neg_inf) when is_integer(Number) -> -1;
+infinity_bsl(Number1, Number2) when is_integer(Number1), is_integer(Number2) ->
+ Bits = ?BITS,
+ if Number2 > (Bits * 2) -> infinity_bsl(Number1, pos_inf);
+ Number2 < (-Bits * 2) -> infinity_bsl(Number1, neg_inf);
+ true -> Number1 bsl Number2
+ end.
+
+infinity_geq(pos_inf, _) -> true;
+infinity_geq(_, pos_inf) -> false;
+infinity_geq(_, neg_inf) -> true;
+infinity_geq(neg_inf, _) -> false;
+infinity_geq(A, B) when is_integer(A), is_integer(B) -> A >= B.
+
+-spec infinity_add(inf_integer(), inf_integer()) -> inf_integer().
+
+infinity_add(pos_inf, _Number) -> pos_inf;
+infinity_add(neg_inf, _Number) -> neg_inf;
+infinity_add(_Number, pos_inf) -> pos_inf;
+infinity_add(_Number, neg_inf) -> neg_inf;
+infinity_add(Number1, Number2) when is_integer(Number1), is_integer(Number2) ->
+ Number1 + Number2.
+
+infinity_mult(neg_inf, Number) ->
+ Greater = infinity_geq(Number, 0),
+ if Greater -> neg_inf;
+ true -> pos_inf
+ end;
+infinity_mult(pos_inf, Number) -> infinity_inv(infinity_mult(neg_inf, Number));
+infinity_mult(Number, pos_inf) -> infinity_inv(infinity_mult(neg_inf, Number));
+infinity_mult(Number, neg_inf) -> infinity_mult(neg_inf, Number);
+infinity_mult(Number1, Number2) when is_integer(Number1), is_integer(Number2)->
+ Number1 * Number2.
+
+width({Min, Max}) -> infinity_max([width(Min), width(Max)]);
+width(pos_inf) -> pos_inf;
+width(neg_inf) -> pos_inf;
+width(X) when is_integer(X), X >= 0 -> poswidth(X, 0);
+width(X) when is_integer(X), X < 0 -> negwidth(X, 0).
+
+poswidth(X, N) ->
+ case X < (1 bsl N) of
+ true -> N;
+ false -> poswidth(X, N+1)
+ end.
+
+negwidth(X, N) ->
+ case X >= (-1 bsl N) of
+ true -> N;
+ false -> negwidth(X, N+1)
+ end.
+
+arith('bnot', X1) ->
+ case t_is_integer(X1) of
+ false -> error;
+ true ->
+ Min1 = number_min(X1),
+ Max1 = number_max(X1),
+ {ok, t_from_range(infinity_add(infinity_inv(Max1), -1),
+ infinity_add(infinity_inv(Min1), -1))}
+ end.
+
+arith_mult(Min1, Max1, Min2, Max2) ->
+ Tmp_list = [infinity_mult(Min1, Min2), infinity_mult(Min1, Max2),
+ infinity_mult(Max1, Min2), infinity_mult(Max1, Max2)],
+ {infinity_min(Tmp_list), infinity_max(Tmp_list)}.
+
+arith_div(_Min1, _Max1, 0, 0) ->
+ %% Signal failure.
+ {pos_inf, neg_inf};
+arith_div(Min1, Max1, Min2, Max2) ->
+ %% 0 is not an accepted divisor.
+ NewMin2 = if Min2 =:= 0 -> 1;
+ true -> Min2
+ end,
+ NewMax2 = if Max2 =:= 0 -> -1;
+ true -> Max2
+ end,
+ Tmp_list = lists:flatten([infinity_div(Min1, NewMin2),
+ infinity_div(Min1, NewMax2),
+ infinity_div(Max1, NewMin2),
+ infinity_div(Max1, NewMax2)]),
+ {infinity_min(Tmp_list), infinity_max(Tmp_list)}.
+
+arith_rem(Min1, Max1, Min2, Max2) ->
+ Min1_geq_zero = infinity_geq(Min1, 0),
+ Max1_leq_zero = infinity_geq(0, Max1),
+ Max_range2 = infinity_max([infinity_abs(Min2), infinity_abs(Max2)]),
+ Max_range2_leq_zero = infinity_geq(0, Max_range2),
+ New_min =
+ if Min1_geq_zero -> 0;
+ Max_range2 =:= 0 -> 0;
+ Max_range2_leq_zero -> infinity_add(Max_range2, 1);
+ true -> infinity_add(infinity_inv(Max_range2), 1)
+ end,
+ New_max =
+ if Max1_leq_zero -> 0;
+ Max_range2 =:= 0 -> 0;
+ Max_range2_leq_zero -> infinity_add(infinity_inv(Max_range2), -1);
+ true -> infinity_add(Max_range2, -1)
+ end,
+ {New_min, New_max}.
+
+arith_bsl(Min1, Max1, Min2, Max2) ->
+ case infinity_geq(Min1, 0) of
+ true -> {infinity_bsl(Min1, Min2), infinity_bsl(Max1, Max2)};
+ false ->
+ case infinity_geq(Max1, 0) of
+ true -> {infinity_bsl(Min1, Max2), infinity_bsl(Max1, Max2)};
+ false -> {infinity_bsl(Min1, Max2), infinity_bsl(Max2, Min2)}
+ end
+ end.
+
+arith_band_range_set({Min, Max}, [Int|IntList]) ->
+ SafeAnd = lists:foldl(
+ fun (IntFromSet, SafeAndAcc) ->
+ IntFromSet bor SafeAndAcc
+ end,
+ Int,
+ IntList),
+ {infinity_band(Min, SafeAnd), infinity_band(Max, SafeAnd)}.
+
+arith_bor_range_set({Min, Max}, [Int|IntList]) ->
+ SafeAnd = lists:foldl(
+ fun (IntFromSet, SafeAndAcc) ->
+ IntFromSet band SafeAndAcc
+ end,
+ Int,
+ IntList),
+ {infinity_bor(Min, SafeAnd), infinity_bor(Max, SafeAnd)}.
+
+arith_band(X1, X2) ->
+ L1 = t_number_vals(X1),
+ L2 = t_number_vals(X2),
+ Min1 = number_min(X1),
+ Max1 = number_max(X1),
+ Min2 = number_min(X2),
+ Max2 = number_max(X2),
+ case {L1 =:= unknown, L2 =:= unknown} of
+ {true, false} ->
+ arith_band_range_set(arith_band_ranges(Min1, Max1, Min2, Max2), L2);
+ {false, true} ->
+ arith_band_range_set(arith_band_ranges(Min1, Max1, Min2, Max2), L1);
+ {true, true} ->
+ arith_band_ranges(Min1, Max1, Min2, Max2)
+ end.
+
+arith_bor(X1, X2) ->
+ L1 = t_number_vals(X1),
+ L2 = t_number_vals(X2),
+ Min1 = number_min(X1),
+ Max1 = number_max(X1),
+ Min2 = number_min(X2),
+ Max2 = number_max(X2),
+ case {L1 =:= unknown, L2 =:= unknown} of
+ {true, false} ->
+ arith_bor_range_set(arith_bor_ranges(Min1, Max1, Min2, Max2), L2);
+ {false, true} ->
+ arith_bor_range_set(arith_bor_ranges(Min1, Max1, Min2, Max2), L1);
+ {true, true} ->
+ arith_bor_ranges(Min1, Max1, Min2, Max2)
+ end.
+
+arith_band_ranges(Min1, Max1, Min2, Max2) ->
+ Width = infinity_min([width({Min1, Max1}), width({Min2, Max2})]),
+ Min =
+ case infinity_geq(Min1, 0) orelse infinity_geq(Min2, 0) of
+ true -> 0;
+ false -> infinity_bsl(-1, Width)
+ end,
+ Max =
+ case infinity_geq(Max1, 0) orelse infinity_geq(Max2, 0) of
+ true -> infinity_add(infinity_bsl(1, Width), -1);
+ false -> 0
+ end,
+ {Min, Max}.
+
+arith_bor_ranges(Min1, Max1, Min2, Max2) ->
+ Width = infinity_max([width({Min1, Max1}), width({Min2, Max2})]),
+ Min =
+ case infinity_geq(Min1, 0) andalso infinity_geq(Min2, 0) of
+ true -> 0;
+ false -> infinity_bsl(-1, Width)
+ end,
+ Max =
+ case infinity_geq(Max1, 0) andalso infinity_geq(Max2, 0) of
+ true -> infinity_add(infinity_bsl(1, Width), -1);
+ false -> -1
+ end,
+ {Min, Max}.
+
+arith(Op, X1, X2) ->
+ %% io:format("arith ~p ~p ~p~n", [Op, X1, X2]),
+ case t_is_integer(X1) andalso t_is_integer(X2) of
+ false -> error;
+ true ->
+ L1 = t_number_vals(X1),
+ L2 = t_number_vals(X2),
+ case (L1 =:= unknown) orelse (L2 =:= unknown) of
+ true ->
+ Min1 = number_min(X1),
+ Max1 = number_max(X1),
+ Min2 = number_min(X2),
+ Max2 = number_max(X2),
+ {NewMin, NewMax} =
+ case Op of
+ '+' -> {infinity_add(Min1, Min2), infinity_add(Max1, Max2)};
+ '-' -> {infinity_add(Min1, infinity_inv(Max2)),
+ infinity_add(Max1, infinity_inv(Min2))};
+ '*' -> arith_mult(Min1, Max1, Min2, Max2);
+ 'div' -> arith_div(Min1, Max1, Min2, Max2);
+ 'rem' -> arith_rem(Min1, Max1, Min2, Max2);
+ 'bsl' -> arith_bsl(Min1, Max1, Min2, Max2);
+ 'bsr' -> NewMin2 = infinity_inv(Max2),
+ NewMax2 = infinity_inv(Min2),
+ arith_bsl(Min1, Max1, NewMin2, NewMax2);
+ 'band' -> arith_band(X1, X2);
+ 'bor' -> arith_bor(X1, X2);
+ 'bxor' -> arith_bor_ranges(Min1, Max1, Min2, Max2) %% overaprox.
+ end,
+ %% io:format("done arith ~p = ~p~n", [Op, {NewMin, NewMax}]),
+ {ok, t_from_range(NewMin, NewMax)};
+ false ->
+ AllVals =
+ case Op of
+ '+' -> [X + Y || X <- L1, Y <- L2];
+ '-' -> [X - Y || X <- L1, Y <- L2];
+ '*' -> [X * Y || X <- L1, Y <- L2];
+ 'div' -> [X div Y || X <- L1, Y <- L2,Y =/= 0];
+ 'rem' -> [X rem Y || X <- L1, Y <- L2,Y =/= 0];
+ 'bsl' -> [X bsl Y || X <- L1, Y <- L2];
+ 'bsr' -> [X bsr Y || X <- L1, Y <- L2];
+ 'band' -> [X band Y || X <- L1, Y <- L2];
+ 'bor' -> [X bor Y || X <- L1, Y <- L2];
+ 'bxor' -> [X bxor Y || X <- L1, Y <- L2]
+ end,
+ {ok, t_integers(ordsets:from_list(AllVals))}
+ end
+ end.
+
+%%=============================================================================
+
+-spec arg_types(atom(), atom(), arity()) -> [erl_types:erl_type()] | 'unknown'.
+
+%%------- code ----------------------------------------------------------------
+arg_types(code, add_path, 1) ->
+ [t_string()];
+arg_types(code, add_patha, 1) ->
+ arg_types(code, add_path, 1);
+arg_types(code, add_paths, 1) ->
+ [t_list(t_string())];
+arg_types(code, add_pathsa, 1) ->
+ arg_types(code, add_paths, 1);
+arg_types(code, add_pathsz, 1) ->
+ arg_types(code, add_paths, 1);
+arg_types(code, add_pathz, 1) ->
+ arg_types(code, add_path, 1);
+arg_types(code, all_loaded, 0) ->
+ [];
+arg_types(code, compiler_dir, 0) ->
+ [];
+arg_types(code, del_path, 1) ->
+ [t_sup(t_string(), t_atom())]; % OBS: doc differs from add_path/1 - why?
+arg_types(code, delete, 1) ->
+ [t_atom()];
+arg_types(code, ensure_loaded, 1) ->
+ arg_types(code, load_file, 1);
+arg_types(code, get_chunk, 2) ->
+ [t_binary(), t_string()];
+arg_types(code, get_object_code, 1) ->
+ [t_atom()];
+arg_types(code, get_path, 0) ->
+ [];
+arg_types(code, is_loaded, 1) ->
+ [t_atom()];
+arg_types(code, is_sticky, 1) ->
+ [t_atom()];
+arg_types(code, is_module_native, 1) ->
+ [t_atom()];
+arg_types(code, lib_dir, 0) ->
+ [];
+arg_types(code, lib_dir, 1) ->
+ [t_atom()];
+arg_types(code, load_abs, 1) ->
+ [t_string()];
+arg_types(code, load_abs, 2) ->
+ [t_code_loaded_fname_or_status(), t_atom()];
+arg_types(code, load_binary, 3) ->
+ [t_atom(), t_code_loaded_fname_or_status(), t_binary()];
+arg_types(code, load_file, 1) ->
+ [t_atom()];
+arg_types(code, load_native_partial, 2) ->
+ [t_atom(), t_binary()];
+arg_types(code, load_native_sticky, 3) ->
+ [t_atom(), t_binary(), t_sup(t_binary(), t_atom('false'))];
+arg_types(code, module_md5, 1) ->
+ [t_binary()];
+arg_types(code, make_stub_module, 3) ->
+ [t_atom(), t_binary(), t_tuple([t_list(), t_list()])];
+arg_types(code, priv_dir, 1) ->
+ [t_atom()];
+arg_types(code, purge, 1) ->
+ arg_types(code, delete, 1);
+arg_types(code, rehash, 0) ->
+ [];
+arg_types(code, replace_path, 2) ->
+ [t_atom(), t_string()];
+arg_types(code, root_dir, 0) ->
+ [];
+arg_types(code, set_path, 1) ->
+ [t_string()];
+arg_types(code, soft_purge, 1) ->
+ arg_types(code, delete, 1);
+arg_types(code, stick_mod, 1) ->
+ [t_atom()];
+arg_types(code, unstick_mod, 1) ->
+ arg_types(code, stick_mod, 1);
+arg_types(code, which, 1) ->
+ [t_atom()];
+%%------- erl_ddll ------------------------------------------------------------
+arg_types(erl_ddll, demonitor, 1) ->
+ arg_types(erlang, demonitor, 1);
+arg_types(erl_ddll, format_error_int, 1) ->
+ [t_sup([t_atom('inconsistent'),
+ t_atom('linked_in_driver'),
+ t_atom('permanent'),
+ t_atom('not_loaded'),
+ t_atom('not_loaded_by_this_process'),
+ t_atom('not_pending'),
+ t_atom('already_loaded'),
+ t_atom('unloading')])];
+arg_types(erl_ddll, info, 2) ->
+ [t_sup([t_atom(), t_string()]),
+ t_sup([t_atom('awaiting_load'),
+ t_atom('awaiting_unload'),
+ t_atom('driver_options'),
+ t_atom('linked_in_driver'),
+ t_atom('permanent'),
+ t_atom('port_count'),
+ t_atom('processes')])];
+arg_types(erl_ddll, loaded_drivers, 0) ->
+ [];
+arg_types(erl_ddll, monitor, 2) ->
+ [t_atom('driver'),
+ t_tuple([t_atom(), t_sup([t_atom('loaded'), t_atom('unloaded')])])];
+arg_types(erl_ddll, try_load, 3) ->
+ [t_sup([t_atom(), t_string(), t_nonempty_list(t_sup([t_atom(), t_string()]))]),
+ t_sup([t_atom(), t_string()]),
+ t_list(t_sup([t_tuple([t_atom('driver_options'),
+ t_list(t_atom('kill_ports'))]),
+ t_tuple([t_atom('monitor'),
+ t_sup([t_atom('pending_driver'),
+ t_atom('pending')])]),
+ t_tuple([t_atom('reload'),
+ t_sup([t_atom('pending_driver'),
+ t_atom('pending')])])]))];
+arg_types(erl_ddll, try_unload, 2) ->
+ [t_sup([t_atom(), t_string(), t_nonempty_list(t_sup([t_atom(), t_string()]))]),
+ t_list(t_sup([t_atom('kill_ports'),
+ t_tuple([t_atom('monitor'),
+ t_sup([t_atom('pending_driver'),
+ t_atom('pending')])])]))];
+%%------- erlang --------------------------------------------------------------
+arg_types(erlang, '!', 2) ->
+ Pid = t_sup([t_pid(), t_port(), t_atom(),
+ t_tuple([t_atom(), t_node()])]),
+ [Pid, t_any()];
+arg_types(erlang, '==', 2) ->
+ [t_any(), t_any()];
+arg_types(erlang, '/=', 2) ->
+ [t_any(), t_any()];
+arg_types(erlang, '=:=', 2) ->
+ [t_any(), t_any()];
+arg_types(erlang, '=/=', 2) ->
+ [t_any(), t_any()];
+arg_types(erlang, '>', 2) ->
+ [t_any(), t_any()];
+arg_types(erlang, '>=', 2) ->
+ [t_any(), t_any()];
+arg_types(erlang, '<', 2) ->
+ [t_any(), t_any()];
+arg_types(erlang, '=<', 2) ->
+ [t_any(), t_any()];
+arg_types(erlang, '+', 1) ->
+ [t_number()];
+arg_types(erlang, '+', 2) ->
+ [t_number(), t_number()];
+arg_types(erlang, '++', 2) ->
+ [t_list(), t_any()];
+arg_types(erlang, '-', 1) ->
+ [t_number()];
+arg_types(erlang, '-', 2) ->
+ [t_number(), t_number()];
+arg_types(erlang, '--', 2) ->
+ [t_list(), t_list()];
+arg_types(erlang, '*', 2) ->
+ [t_number(), t_number()];
+arg_types(erlang, '/', 2) ->
+ [t_number(), t_number()];
+arg_types(erlang, 'div', 2) ->
+ [t_integer(), t_integer()];
+arg_types(erlang, 'rem', 2) ->
+ [t_integer(), t_integer()];
+arg_types(erlang, 'and', 2) ->
+ [t_boolean(), t_boolean()];
+arg_types(erlang, 'or', 2) ->
+ [t_boolean(), t_boolean()];
+arg_types(erlang, 'xor', 2) ->
+ [t_boolean(), t_boolean()];
+arg_types(erlang, 'not', 1) ->
+ [t_boolean()];
+arg_types(erlang, 'band', 2) ->
+ [t_integer(), t_integer()];
+arg_types(erlang, 'bor', 2) ->
+ [t_integer(), t_integer()];
+arg_types(erlang, 'bxor', 2) ->
+ [t_integer(), t_integer()];
+arg_types(erlang, 'bsr', 2) ->
+ [t_integer(), t_integer()];
+arg_types(erlang, 'bsl', 2) ->
+ [t_integer(), t_integer()];
+arg_types(erlang, 'bnot', 1) ->
+ [t_integer()];
+arg_types(erlang, abs, 1) ->
+ [t_number()];
+arg_types(erlang, append_element, 2) ->
+ [t_tuple(), t_any()];
+arg_types(erlang, apply, 2) ->
+ [t_sup(t_tuple([t_sup(t_atom(), % module name
+ t_tuple()), % parameterized module
+ t_atom()]),
+ t_fun()),
+ t_list()];
+arg_types(erlang, apply, 3) ->
+ [t_sup(t_atom(), t_tuple()), t_atom(), t_list()];
+arg_types(erlang, atom_to_binary, 2) ->
+ [t_atom(), t_encoding_a2b()];
+arg_types(erlang, atom_to_list, 1) ->
+ [t_atom()];
+arg_types(erlang, binary_to_atom, 2) ->
+ [t_binary(), t_encoding_a2b()];
+arg_types(erlang, binary_to_existing_atom, 2) ->
+ arg_types(erlang, binary_to_atom, 2);
+arg_types(erlang, binary_to_list, 1) ->
+ [t_binary()];
+arg_types(erlang, binary_to_list, 3) ->
+ [t_binary(), t_pos_integer(), t_pos_integer()]; % I want fixnum, but cannot
+arg_types(erlang, binary_to_term, 1) ->
+ [t_binary()];
+arg_types(erlang, bitsize, 1) -> % XXX: TAKE OUT
+ arg_types(erlang, bit_size, 1);
+arg_types(erlang, bit_size, 1) ->
+ [t_bitstr()];
+arg_types(erlang, bitstr_to_list, 1) -> % XXX: TAKE OUT
+ arg_types(erlang, bitstring_to_list, 1);
+arg_types(erlang, bitstring_to_list, 1) ->
+ [t_bitstr()];
+arg_types(erlang, bump_reductions, 1) ->
+ [t_pos_fixnum()];
+arg_types(erlang, byte_size, 1) ->
+ [t_binary()];
+arg_types(erlang, cancel_timer, 1) ->
+ [t_reference()];
+arg_types(erlang, check_process_code, 2) ->
+ [t_pid(), t_atom()];
+arg_types(erlang, concat_binary, 1) ->
+ [t_list(t_binary())];
+arg_types(erlang, crc32, 1) ->
+ [t_iodata()];
+arg_types(erlang, crc32, 2) ->
+ [t_integer(), t_iodata()];
+arg_types(erlang, crc32_combine, 3) ->
+ [t_integer(), t_integer(), t_integer()];
+arg_types(erlang, date, 0) ->
+ [];
+arg_types(erlang, decode_packet, 3) ->
+ [t_decode_packet_type(), t_binary(), t_list(t_decode_packet_option())];
+arg_types(erlang, delete_module, 1) ->
+ [t_atom()];
+arg_types(erlang, demonitor, 1) ->
+ [t_reference()];
+arg_types(erlang, demonitor, 2) ->
+ [t_reference(), t_list(t_atoms(['flush', 'info']))];
+arg_types(erlang, disconnect_node, 1) ->
+ [t_node()];
+arg_types(erlang, display, 1) ->
+ [t_any()];
+arg_types(erlang, dist_exit, 3) ->
+ [t_pid(), t_dist_exit(), t_sup(t_pid(), t_port())];
+arg_types(erlang, element, 2) ->
+ [t_pos_fixnum(), t_tuple()];
+arg_types(erlang, erase, 0) ->
+ [];
+arg_types(erlang, erase, 1) ->
+ [t_any()];
+arg_types(erlang, error, 1) ->
+ [t_any()];
+arg_types(erlang, error, 2) ->
+ [t_any(), t_list()];
+arg_types(erlang, exit, 1) ->
+ [t_any()];
+arg_types(erlang, exit, 2) ->
+ [t_sup(t_pid(), t_port()), t_any()];
+arg_types(erlang, external_size, 1) ->
+ [t_any()]; % takes any term as input
+arg_types(erlang, float, 1) ->
+ [t_number()];
+arg_types(erlang, float_to_list, 1) ->
+ [t_float()];
+arg_types(erlang, function_exported, 3) ->
+ [t_atom(), t_atom(), t_arity()];
+arg_types(erlang, fun_info, 1) ->
+ [t_fun()];
+arg_types(erlang, fun_info, 2) ->
+ [t_fun(), t_atom()];
+arg_types(erlang, fun_to_list, 1) ->
+ [t_fun()];
+arg_types(erlang, garbage_collect, 0) ->
+ [];
+arg_types(erlang, garbage_collect, 1) ->
+ [t_pid()];
+arg_types(erlang, get, 0) ->
+ [];
+arg_types(erlang, get, 1) ->
+ [t_any()];
+arg_types(erlang, get_cookie, 0) ->
+ [];
+arg_types(erlang, get_keys, 1) ->
+ [t_any()];
+arg_types(erlang, get_stacktrace, 0) ->
+ [];
+arg_types(erlang, get_module_info, 1) ->
+ [t_atom()];
+arg_types(erlang, get_module_info, 2) ->
+ [t_atom(), t_module_info_2()];
+arg_types(erlang, group_leader, 0) ->
+ [];
+arg_types(erlang, group_leader, 2) ->
+ [t_pid(), t_pid()];
+arg_types(erlang, halt, 0) ->
+ [];
+arg_types(erlang, halt, 1) ->
+ [t_sup(t_non_neg_fixnum(), t_string())];
+arg_types(erlang, hash, 2) ->
+ [t_any(), t_integer()];
+arg_types(erlang, hd, 1) ->
+ [t_cons()];
+arg_types(erlang, hibernate, 3) ->
+ [t_atom(), t_atom(), t_list()];
+arg_types(erlang, info, 1) ->
+ arg_types(erlang, system_info, 1); % alias
+arg_types(erlang, iolist_to_binary, 1) ->
+ [t_sup(t_iolist(), t_binary())];
+arg_types(erlang, iolist_size, 1) ->
+ [t_sup(t_iolist(), t_binary())];
+arg_types(erlang, integer_to_list, 1) ->
+ [t_integer()];
+arg_types(erlang, is_alive, 0) ->
+ [];
+arg_types(erlang, is_atom, 1) ->
+ [t_any()];
+arg_types(erlang, is_binary, 1) ->
+ [t_any()];
+arg_types(erlang, is_bitstr, 1) -> % XXX: TAKE OUT
+ arg_types(erlang, is_bitstring, 1);
+arg_types(erlang, is_bitstring, 1) ->
+ [t_any()];
+arg_types(erlang, is_boolean, 1) ->
+ [t_any()];
+arg_types(erlang, is_builtin, 3) ->
+ [t_atom(), t_atom(), t_arity()];
+arg_types(erlang, is_constant, 1) ->
+ [t_any()];
+arg_types(erlang, is_float, 1) ->
+ [t_any()];
+arg_types(erlang, is_function, 1) ->
+ [t_any()];
+arg_types(erlang, is_function, 2) ->
+ [t_any(), t_arity()];
+arg_types(erlang, is_integer, 1) ->
+ [t_any()];
+arg_types(erlang, is_list, 1) ->
+ [t_any()];
+arg_types(erlang, is_number, 1) ->
+ [t_any()];
+arg_types(erlang, is_pid, 1) ->
+ [t_any()];
+arg_types(erlang, is_port, 1) ->
+ [t_any()];
+arg_types(erlang, is_process_alive, 1) ->
+ [t_pid()];
+arg_types(erlang, is_record, 2) ->
+ [t_any(), t_atom()];
+arg_types(erlang, is_record, 3) ->
+ [t_any(), t_atom(), t_pos_fixnum()];
+arg_types(erlang, is_reference, 1) ->
+ [t_any()];
+arg_types(erlang, is_tuple, 1) ->
+ [t_any()];
+arg_types(erlang, length, 1) ->
+ [t_list()];
+arg_types(erlang, link, 1) ->
+ [t_sup(t_pid(), t_port())];
+arg_types(erlang, list_to_atom, 1) ->
+ [t_string()];
+arg_types(erlang, list_to_binary, 1) ->
+ [t_iolist()];
+arg_types(erlang, list_to_bitstr, 1) -> % XXX: TAKE OUT
+ arg_types(erlang, list_to_bitstring, 1);
+arg_types(erlang, list_to_bitstring, 1) ->
+ [t_iolist()];
+arg_types(erlang, list_to_existing_atom, 1) ->
+ [t_string()];
+arg_types(erlang, list_to_float, 1) ->
+ [t_list(t_byte())];
+arg_types(erlang, list_to_integer, 1) ->
+ [t_list(t_byte())];
+arg_types(erlang, list_to_pid, 1) ->
+ [t_string()];
+arg_types(erlang, list_to_tuple, 1) ->
+ [t_list()];
+arg_types(erlang, loaded, 0) ->
+ [];
+arg_types(erlang, load_module, 2) ->
+ [t_atom(), t_binary()];
+arg_types(erlang, localtime, 0) ->
+ [];
+arg_types(erlang, localtime_to_universaltime, 1) ->
+ [t_tuple([t_date(), t_time()])];
+arg_types(erlang, localtime_to_universaltime, 2) ->
+ arg_types(erlang, localtime_to_universaltime, 1) ++
+ [t_sup(t_boolean(), t_atom('undefined'))];
+arg_types(erlang, make_fun, 3) ->
+ [t_atom(), t_atom(), t_arity()];
+arg_types(erlang, make_ref, 0) ->
+ [];
+arg_types(erlang, make_tuple, 2) ->
+ [t_non_neg_fixnum(), t_any()]; % the value 0 is OK as first argument
+arg_types(erlang, make_tuple, 3) ->
+ [t_non_neg_fixnum(), t_any(), t_list(t_tuple([t_pos_integer(), t_any()]))];
+arg_types(erlang, match_spec_test, 3) ->
+ [t_sup(t_list(), t_tuple()),
+ t_any(),
+ t_sup(t_atom('table'), t_atom('trace'))];
+arg_types(erlang, md5, 1) ->
+ [t_sup(t_iolist(), t_binary())];
+arg_types(erlang, md5_final, 1) ->
+ [t_binary()];
+arg_types(erlang, md5_init, 0) ->
+ [];
+arg_types(erlang, md5_update, 2) ->
+ [t_binary(), t_sup(t_iolist(), t_binary())];
+arg_types(erlang, memory, 0) ->
+ [];
+arg_types(erlang, memory, 1) ->
+ Arg = t_atoms(['total', 'processes', 'processes_used', 'system',
+ 'atom', 'atom_used', 'binary', 'code', 'ets',
+ 'maximum']),
+ [t_sup(Arg, t_list(Arg))];
+arg_types(erlang, module_loaded, 1) ->
+ [t_atom()];
+arg_types(erlang, monitor, 2) ->
+ [t_atom(), t_sup([t_pid(), t_atom(), t_tuple([t_atom(), t_node()])])];
+arg_types(erlang, monitor_node, 2) ->
+ [t_node(), t_boolean()];
+arg_types(erlang, monitor_node, 3) ->
+ [t_node(), t_boolean(), t_list(t_atom('allow_passive_connect'))];
+arg_types(erlang, node, 0) ->
+ [];
+arg_types(erlang, node, 1) ->
+ [t_identifier()];
+arg_types(erlang, nodes, 0) ->
+ [];
+arg_types(erlang, nodes, 1) ->
+ NodesArg = t_atoms(['visible', 'hidden', 'connected', 'this', 'known']),
+ [t_sup(NodesArg, t_list(NodesArg))];
+arg_types(erlang, now, 0) ->
+ [];
+arg_types(erlang, open_port, 2) ->
+ [t_sup(t_atom(), t_sup([t_tuple([t_atom('spawn'), t_string()]),
+ t_tuple([t_atom('spawn_driver'), t_string()]),
+ t_tuple([t_atom('spawn_executable'), t_string()]),
+ t_tuple([t_atom('fd'), t_integer(), t_integer()])])),
+ t_list(t_sup(t_sup([t_atom('stream'),
+ t_atom('exit_status'),
+ t_atom('use_stdio'),
+ t_atom('nouse_stdio'),
+ t_atom('stderr_to_stdout'),
+ t_atom('in'),
+ t_atom('out'),
+ t_atom('binary'),
+ t_atom('eof'),
+ t_atom('hide')]),
+ t_sup([t_tuple([t_atom('packet'), t_integer()]),
+ t_tuple([t_atom('line'), t_integer()]),
+ t_tuple([t_atom('cd'), t_string()]),
+ t_tuple([t_atom('env'), t_list(t_tuple(2))]), % XXX: More
+ t_tuple([t_atom('args'), t_list(t_string())]),
+ t_tuple([t_atom('arg0'), t_string()])])))];
+arg_types(erlang, phash, 2) ->
+ [t_any(), t_pos_integer()];
+arg_types(erlang, phash2, 1) ->
+ [t_any()];
+arg_types(erlang, phash2, 2) ->
+ [t_any(), t_pos_integer()];
+arg_types(erlang, pid_to_list, 1) ->
+ [t_pid()];
+arg_types(erlang, port_call, 3) ->
+ [t_sup(t_port(), t_atom()), t_integer(), t_any()];
+arg_types(erlang, port_close, 1) ->
+ [t_sup(t_port(), t_atom())];
+arg_types(erlang, port_command, 2) ->
+ [t_sup(t_port(), t_atom()), t_sup(t_iolist(), t_binary())];
+arg_types(erlang, port_command, 3) ->
+ [t_sup(t_port(), t_atom()),
+ t_sup(t_iolist(), t_binary()),
+ t_list(t_atoms(['force', 'nosuspend']))];
+arg_types(erlang, port_connect, 2) ->
+ [t_sup(t_port(), t_atom()), t_pid()];
+arg_types(erlang, port_control, 3) ->
+ [t_sup(t_port(), t_atom()), t_integer(), t_sup(t_iolist(), t_binary())];
+arg_types(erlang, port_get_data, 1) ->
+ [t_sup(t_port(), t_atom())];
+arg_types(erlang, port_info, 1) ->
+ [t_sup(t_port(), t_atom())];
+arg_types(erlang, port_info, 2) ->
+ [t_sup(t_port(), t_atom()),
+ t_atoms(['registered_name', 'id', 'connected',
+ 'links', 'name', 'input', 'output'])];
+arg_types(erlang, port_to_list, 1) ->
+ [t_port()];
+arg_types(erlang, ports, 0) ->
+ [];
+arg_types(erlang, port_set_data, 2) ->
+ [t_sup(t_port(), t_atom()), t_any()];
+arg_types(erlang, pre_loaded, 0) ->
+ [];
+arg_types(erlang, process_display, 2) ->
+ [t_pid(), t_atom('backtrace')];
+arg_types(erlang, process_flag, 2) ->
+ [t_sup([t_atom('trap_exit'), t_atom('error_handler'),
+ t_atom('min_heap_size'), t_atom('priority'), t_atom('save_calls'),
+ t_atom('monitor_nodes'), % undocumented
+ t_tuple([t_atom('monitor_nodes'), t_list()])]), % undocumented
+ t_sup([t_boolean(), t_atom(), t_non_neg_integer()])];
+arg_types(erlang, process_flag, 3) ->
+ [t_pid(), t_atom('save_calls'), t_non_neg_integer()];
+arg_types(erlang, process_info, 1) ->
+ [t_pid()];
+arg_types(erlang, process_info, 2) ->
+ [t_pid(), t_pinfo()];
+arg_types(erlang, processes, 0) ->
+ [];
+arg_types(erlang, purge_module, 1) ->
+ [t_atom()];
+arg_types(erlang, put, 2) ->
+ [t_any(), t_any()];
+arg_types(erlang, raise, 3) ->
+ [t_raise_errorclass(), t_any(), type(erlang, get_stacktrace, 0, [])];
+arg_types(erlang, read_timer, 1) ->
+ [t_reference()];
+arg_types(erlang, ref_to_list, 1) ->
+ [t_reference()];
+arg_types(erlang, register, 2) ->
+ [t_atom(), t_sup(t_port(), t_pid())];
+arg_types(erlang, registered, 0) ->
+ [];
+arg_types(erlang, resume_process, 1) ->
+ [t_pid()]; % intended for debugging only
+arg_types(erlang, round, 1) ->
+ [t_number()];
+arg_types(erlang, self, 0) ->
+ [];
+arg_types(erlang, send, 2) ->
+ arg_types(erlang, '!', 2); % alias
+arg_types(erlang, send, 3) ->
+ arg_types(erlang, send, 2) ++ [t_list(t_sendoptions())];
+arg_types(erlang, send_after, 3) ->
+ [t_non_neg_integer(), t_sup(t_pid(), t_atom()), t_any()];
+arg_types(erlang, seq_trace, 2) ->
+ [t_atom(), t_sup([t_boolean(), t_tuple([t_fixnum(), t_fixnum()]), t_nil()])];
+arg_types(erlang, seq_trace_info, 1) ->
+ [t_seq_trace_info()];
+arg_types(erlang, seq_trace_print, 1) ->
+ [t_any()];
+arg_types(erlang, seq_trace_print, 2) ->
+ [t_sup(t_atom(), t_fixnum()), t_any()];
+arg_types(erlang, set_cookie, 2) ->
+ [t_node(), t_atom()];
+arg_types(erlang, setelement, 3) ->
+ [t_pos_integer(), t_tuple(), t_any()];
+arg_types(erlang, setnode, 2) ->
+ [t_atom(), t_integer()];
+arg_types(erlang, setnode, 3) ->
+ [t_atom(), t_port(), t_tuple(4)];
+arg_types(erlang, size, 1) ->
+ [t_sup(t_tuple(), t_binary())];
+arg_types(erlang, spawn, 1) -> %% TODO: Tuple?
+ [t_fun()];
+arg_types(erlang, spawn, 2) -> %% TODO: Tuple?
+ [t_node(), t_fun()];
+arg_types(erlang, spawn, 3) -> %% TODO: Tuple?
+ [t_atom(), t_atom(), t_list()];
+arg_types(erlang, spawn, 4) -> %% TODO: Tuple?
+ [t_node(), t_atom(), t_atom(), t_list()];
+arg_types(erlang, spawn_link, 1) ->
+ arg_types(erlang, spawn, 1); % same
+arg_types(erlang, spawn_link, 2) ->
+ arg_types(erlang, spawn, 2); % same
+arg_types(erlang, spawn_link, 3) ->
+ arg_types(erlang, spawn, 3); % same
+arg_types(erlang, spawn_link, 4) ->
+ arg_types(erlang, spawn, 4); % same
+arg_types(erlang, spawn_opt, 1) ->
+ [t_tuple([t_atom(), t_atom(), t_list(), t_list(t_spawn_options())])];
+arg_types(erlang, spawn_opt, 2) ->
+ [t_fun(), t_list(t_spawn_options())];
+arg_types(erlang, spawn_opt, 3) ->
+ [t_atom(), t_fun(), t_list(t_spawn_options())];
+arg_types(erlang, spawn_opt, 4) ->
+ [t_node(), t_atom(), t_list(), t_list(t_spawn_options())];
+arg_types(erlang, split_binary, 2) ->
+ [t_binary(), t_non_neg_integer()];
+arg_types(erlang, start_timer, 3) ->
+ [t_non_neg_integer(), t_sup(t_pid(), t_atom()), t_any()];
+arg_types(erlang, statistics, 1) ->
+ [t_sup([t_atom('context_switches'),
+ t_atom('exact_reductions'),
+ t_atom('garbage_collection'),
+ t_atom('io'),
+ t_atom('reductions'),
+ t_atom('run_queue'),
+ t_atom('runtime'),
+ t_atom('wall_clock')])];
+arg_types(erlang, suspend_process, 1) ->
+ [t_pid()];
+arg_types(erlang, suspend_process, 2) ->
+ [t_pid(), t_list(t_sup([t_atom('unless_suspending'),
+ t_atom('asynchronous')]))];
+arg_types(erlang, system_flag, 2) ->
+ [t_sup([t_atom('backtrace_depth'),
+ t_atom('cpu_topology'),
+ t_atom('debug_flags'), % undocumented
+ t_atom('display_items'), % undocumented
+ t_atom('fullsweep_after'),
+ t_atom('min_heap_size'),
+ t_atom('multi_scheduling'),
+ t_atom('schedulers_online'),
+ t_atom('scheduler_bind_type'),
+ %% Undocumented; used to implement (the documented) seq_trace module.
+ t_atom('sequential_tracer'),
+ t_atom('trace_control_word'),
+ %% 'internal_cpu_topology' is an undocumented internal feature.
+ t_atom('internal_cpu_topology'),
+ t_integer()]),
+ t_sup([t_integer(),
+ %% 'cpu_topology'
+ t_system_cpu_topology(),
+ %% 'scheduler_bind_type'
+ t_scheduler_bind_type_args(),
+ %% Undocumented: the following is for 'debug_flags' that
+ %% takes any erlang term as flags and currently ignores it.
+ %% t_any(), % commented out since it destroys the type signature
+ %%
+ %% Again undocumented; the following are for 'sequential_tracer'
+ t_sequential_tracer(),
+ %% The following two are for 'multi_scheduling'
+ t_atom('block'),
+ t_atom('unblock'),
+ %% The following is for 'internal_cpu_topology'
+ t_internal_cpu_topology()])];
+arg_types(erlang, system_info, 1) ->
+ [t_sup([t_atom(), % documented
+ t_tuple([t_atom(), t_any()]), % documented
+ t_tuple([t_atom(), t_atom(), t_any()])])];
+arg_types(erlang, system_monitor, 0) ->
+ [];
+arg_types(erlang, system_monitor, 1) ->
+ [t_system_monitor_settings()];
+arg_types(erlang, system_monitor, 2) ->
+ [t_pid(), t_system_monitor_options()];
+arg_types(erlang, system_profile, 0) ->
+ [];
+arg_types(erlang, system_profile, 2) ->
+ [t_sup([t_pid(), t_port(), t_atom('undefined')]),
+ t_system_profile_options()];
+arg_types(erlang, term_to_binary, 1) ->
+ [t_any()];
+arg_types(erlang, term_to_binary, 2) ->
+ [t_any(), t_list(t_sup([t_atom('compressed'),
+ t_tuple([t_atom('compressed'), t_from_range(0, 9)]),
+ t_tuple([t_atom('minor_version'), t_integers([0, 1])])]))];
+arg_types(erlang, throw, 1) ->
+ [t_any()];
+arg_types(erlang, time, 0) ->
+ [];
+arg_types(erlang, tl, 1) ->
+ [t_cons()];
+arg_types(erlang, trace, 3) ->
+ [t_sup(t_pid(), t_sup([t_atom('existing'), t_atom('new'), t_atom('all')])),
+ t_boolean(),
+ t_list(t_sup(t_atom(), t_tuple(2)))];
+arg_types(erlang, trace_delivered, 1) ->
+ [t_sup(t_pid(), t_atom('all'))];
+arg_types(erlang, trace_info, 2) ->
+ [t_sup([%% the following two get info about a PID
+ t_pid(), t_atom('new'),
+ %% while the following two get info about a func
+ t_mfa(), t_atom('on_load')]),
+ t_sup([%% the following are items about a PID
+ t_atom('flags'), t_atom('tracer'),
+ %% while the following are items about a func
+ t_atom('traced'), t_atom('match_spec'), t_atom('meta'),
+ t_atom('meta_match_spec'), t_atom('call_count'), t_atom('all')])];
+arg_types(erlang, trace_pattern, 2) ->
+ [t_sup(t_tuple([t_atom(), t_atom(), t_sup(t_arity(), t_atom('_'))]),
+ t_atom('on_load')),
+ t_sup([t_boolean(), t_list(), t_atom('restart'), t_atom('pause')])];
+arg_types(erlang, trace_pattern, 3) ->
+ arg_types(erlang, trace_pattern, 2) ++
+ [t_list(t_sup([t_atom('global'), t_atom('local'),
+ t_atom('meta'), t_tuple([t_atom('meta'), t_pid()]),
+ t_atom('call_count')]))];
+arg_types(erlang, trunc, 1) ->
+ [t_number()];
+arg_types(erlang, tuple_size, 1) ->
+ [t_tuple()];
+arg_types(erlang, tuple_to_list, 1) ->
+ [t_tuple()];
+arg_types(erlang, universaltime, 0) ->
+ [];
+arg_types(erlang, universaltime_to_localtime, 1) ->
+ [t_tuple([t_date(), t_time()])];
+arg_types(erlang, unlink, 1) ->
+ [t_sup(t_pid(), t_port())];
+arg_types(erlang, unregister, 1) ->
+ [t_atom()];
+arg_types(erlang, whereis, 1) ->
+ [t_atom()];
+arg_types(erlang, yield, 0) ->
+ [];
+%%------- erl_prim_loader -----------------------------------------------------
+arg_types(erl_prim_loader, get_file, 1) ->
+ [t_sup(t_atom(), t_string())];
+arg_types(erl_prim_loader, get_path, 0) ->
+ [];
+arg_types(erl_prim_loader, set_path, 1) ->
+ [t_list(t_string())];
+%%------- error_logger --------------------------------------------------------
+arg_types(error_logger, warning_map, 0) ->
+ [];
+%%------- erts_debug ----------------------------------------------------------
+arg_types(erts_debug, breakpoint, 2) ->
+ [t_tuple([t_atom(), t_atom(), t_sup(t_integer(), t_atom('_'))]), t_boolean()];
+arg_types(erts_debug, disassemble, 1) ->
+ [t_sup(t_mfa(), t_integer())];
+arg_types(erts_debug, flat_size, 1) ->
+ [t_any()];
+arg_types(erts_debug, same, 2) ->
+ [t_any(), t_any()];
+%%------- ets -----------------------------------------------------------------
+arg_types(ets, all, 0) ->
+ [];
+arg_types(ets, delete, 1) ->
+ [t_tab()];
+arg_types(ets, delete, 2) ->
+ [t_tab(), t_any()];
+arg_types(ets, delete_all_objects, 1) ->
+ [t_tab()];
+arg_types(ets, delete_object, 2) ->
+ [t_tab(), t_tuple()];
+arg_types(ets, first, 1) ->
+ [t_tab()];
+arg_types(ets, give_away, 3) ->
+ [t_tab(), t_pid(), t_any()];
+arg_types(ets, info, 1) ->
+ [t_tab()];
+arg_types(ets, info, 2) ->
+ [t_tab(), t_ets_info_items()];
+arg_types(ets, insert, 2) ->
+ [t_tab(), t_sup(t_tuple(), t_list(t_tuple()))];
+arg_types(ets, insert_new, 2) ->
+ [t_tab(), t_sup(t_tuple(), t_list(t_tuple()))];
+arg_types(ets, is_compiled_ms, 1) ->
+ [t_any()];
+arg_types(ets, last, 1) ->
+ arg_types(ets, first, 1);
+arg_types(ets, lookup, 2) ->
+ [t_tab(), t_any()];
+arg_types(ets, lookup_element, 3) ->
+ [t_tab(), t_any(), t_pos_fixnum()];
+arg_types(ets, match, 1) ->
+ [t_any()];
+arg_types(ets, match, 2) ->
+ [t_tab(), t_match_pattern()];
+arg_types(ets, match, 3) ->
+ [t_tab(), t_match_pattern(), t_pos_fixnum()];
+arg_types(ets, match_object, 1) ->
+ arg_types(ets, match, 1);
+arg_types(ets, match_object, 2) ->
+ arg_types(ets, match, 2);
+arg_types(ets, match_object, 3) ->
+ arg_types(ets, match, 3);
+arg_types(ets, match_spec_compile, 1) ->
+ [t_matchspecs()];
+arg_types(ets, match_spec_run_r, 3) ->
+ [t_matchspecs(), t_any(), t_list()];
+arg_types(ets, member, 2) ->
+ [t_tab(), t_any()];
+arg_types(ets, new, 2) ->
+ [t_atom(), t_ets_new_options()];
+arg_types(ets, next, 2) ->
+ [t_tab(), t_any()];
+arg_types(ets, prev, 2) ->
+ [t_tab(), t_any()];
+arg_types(ets, rename, 2) ->
+ [t_atom(), t_atom()];
+arg_types(ets, safe_fixtable, 2) ->
+ [t_tab(), t_boolean()];
+arg_types(ets, select, 1) ->
+ [t_any()];
+arg_types(ets, select, 2) ->
+ [t_tab(), t_matchspecs()];
+arg_types(ets, select, 3) ->
+ [t_tab(), t_matchspecs(), t_pos_fixnum()];
+arg_types(ets, select_count, 2) ->
+ [t_tab(), t_matchspecs()];
+arg_types(ets, select_delete, 2) ->
+ [t_tab(), t_matchspecs()];
+arg_types(ets, select_reverse, 1) ->
+ arg_types(ets, select, 1);
+arg_types(ets, select_reverse, 2) ->
+ arg_types(ets, select, 2);
+arg_types(ets, select_reverse, 3) ->
+ arg_types(ets, select, 3);
+arg_types(ets, slot, 2) ->
+ [t_tab(), t_non_neg_fixnum()]; % 2nd arg can be 0
+arg_types(ets, setopts, 2) ->
+ Opt = t_sup(t_tuple([t_atom('heir'), t_pid(), t_any()]),
+ t_tuple([t_atom('heir'), t_atom('none')])),
+ [t_tab(), t_sup(Opt, t_list(Opt))];
+arg_types(ets, update_counter, 3) ->
+ [t_tab(), t_any(), t_sup(t_integer(),
+ t_sup(t_tuple([t_integer(), t_integer()]),
+ t_tuple([t_integer(), t_integer(),
+ t_integer(), t_integer()])))];
+arg_types(ets, update_element, 3) ->
+ PosValue = t_tuple([t_integer(), t_any()]),
+ [t_tab(), t_any(), t_sup(PosValue, t_list(PosValue))];
+%%------- file ----------------------------------------------------------------
+arg_types(file, close, 1) ->
+ [t_file_io_device()];
+arg_types(file, delete, 1) ->
+ [t_file_name()];
+arg_types(file, get_cwd, 0) ->
+ [];
+arg_types(file, make_dir, 1) ->
+ [t_file_name()];
+arg_types(file, open, 2) ->
+ [t_file_name(), t_list(t_file_open_option())];
+arg_types(file, read_file, 1) ->
+ [t_file_name()];
+arg_types(file, set_cwd, 1) ->
+ [t_file_name()];
+arg_types(file, write, 2) ->
+ [t_file_io_device(), t_iodata()];
+arg_types(file, write_file, 2) ->
+ [t_file_name(), t_sup(t_binary(), t_list())];
+%%------- gen_tcp -------------------------------------------------------------
+arg_types(gen_tcp, accept, 1) ->
+ [t_socket()];
+arg_types(gen_tcp, accept, 2) ->
+ [t_socket(), t_timeout()];
+arg_types(gen_tcp, connect, 3) ->
+ [t_gen_tcp_address(), t_gen_tcp_port(), t_list(t_gen_tcp_connect_option())];
+arg_types(gen_tcp, connect, 4) ->
+ arg_types(gen_tcp, connect, 3) ++ [t_timeout()];
+arg_types(gen_tcp, listen, 2) ->
+ [t_gen_tcp_port(), t_list(t_gen_tcp_listen_option())];
+arg_types(gen_tcp, recv, 2) ->
+ [t_socket(), t_non_neg_integer()];
+arg_types(gen_tcp, recv, 3) ->
+ arg_types(gen_tcp, recv, 2) ++ [t_timeout()];
+arg_types(gen_tcp, send, 2) ->
+ [t_socket(), t_packet()];
+arg_types(gen_tcp, shutdown, 2) ->
+ [t_socket(), t_sup([t_atom('read'), t_atom('write'), t_atom('read_write')])];
+%%------- gen_udp -------------------------------------------------------------
+arg_types(gen_udp, open, 1) ->
+ [t_gen_tcp_port()];
+arg_types(gen_udp, open, 2) ->
+ [t_gen_tcp_port(), t_list(t_gen_udp_connect_option())];
+arg_types(gen_udp, recv, 2) ->
+ arg_types(gen_tcp, recv, 2);
+arg_types(gen_udp, recv, 3) ->
+ arg_types(gen_tcp, recv, 3);
+arg_types(gen_udp, send, 4) ->
+ [t_socket(), t_gen_tcp_address(), t_gen_tcp_port(), t_packet()];
+%%------- hipe_bifs -----------------------------------------------------------
+arg_types(hipe_bifs, add_ref, 2) ->
+ [t_mfa(), t_tuple([t_mfa(),
+ t_integer(),
+ t_sup(t_atom('call'), t_atom('load_mfa')),
+ t_trampoline(),
+ t_sup(t_atom('remote'), t_atom('local'))])];
+arg_types(hipe_bifs, alloc_data, 2) ->
+ [t_integer(), t_integer()];
+arg_types(hipe_bifs, array, 2) ->
+ [t_non_neg_fixnum(), t_immediate()];
+arg_types(hipe_bifs, array_length, 1) ->
+ [t_immarray()];
+arg_types(hipe_bifs, array_sub, 2) ->
+ [t_immarray(), t_non_neg_fixnum()];
+arg_types(hipe_bifs, array_update, 3) ->
+ [t_immarray(), t_non_neg_fixnum(), t_immediate()];
+arg_types(hipe_bifs, atom_to_word, 1) ->
+ [t_atom()];
+arg_types(hipe_bifs, bif_address, 3) ->
+ [t_atom(), t_atom(), t_arity()];
+arg_types(hipe_bifs, bitarray, 2) ->
+ [t_non_neg_fixnum(), t_boolean()];
+arg_types(hipe_bifs, bitarray_sub, 2) ->
+ [t_bitarray(), t_non_neg_fixnum()];
+arg_types(hipe_bifs, bitarray_update, 3) ->
+ [t_bytearray(), t_non_neg_fixnum(), t_boolean()];
+arg_types(hipe_bifs, bytearray, 2) ->
+ [t_non_neg_fixnum(), t_byte()];
+arg_types(hipe_bifs, bytearray_sub, 2) ->
+ [t_bytearray(), t_non_neg_fixnum()];
+arg_types(hipe_bifs, bytearray_update, 3) ->
+ [t_bytearray(), t_non_neg_fixnum(), t_byte()];
+arg_types(hipe_bifs, call_count_clear, 1) ->
+ [t_mfa()];
+arg_types(hipe_bifs, call_count_get, 1) ->
+ [t_mfa()];
+arg_types(hipe_bifs, call_count_off, 1) ->
+ [t_mfa()];
+arg_types(hipe_bifs, call_count_on, 1) ->
+ [t_mfa()];
+arg_types(hipe_bifs, check_crc, 1) ->
+ [t_integer()];
+arg_types(hipe_bifs, enter_code, 2) ->
+ [t_binary(), t_sup(t_nil(), t_tuple())];
+arg_types(hipe_bifs, enter_sdesc, 1) ->
+ [t_tuple([t_integer(), t_integer(), t_integer(), t_integer(), t_integer()])];
+arg_types(hipe_bifs, find_na_or_make_stub, 2) ->
+ [t_mfa(), t_boolean()];
+arg_types(hipe_bifs, fun_to_address, 1) ->
+ [t_mfa()];
+%% arg_types(hipe_bifs, get_emu_address, 1) ->
+%% [t_mfa()];
+arg_types(hipe_bifs, get_rts_param, 1) ->
+ [t_fixnum()];
+arg_types(hipe_bifs, invalidate_funinfo_native_addresses, 1) ->
+ [t_list(t_mfa())];
+arg_types(hipe_bifs, make_fe, 3) ->
+ [t_integer(), t_atom(), t_tuple([t_integer(), t_integer(), t_integer()])];
+%% arg_types(hipe_bifs, make_native_stub, 2) ->
+%% [t_integer(), t_arity()];
+arg_types(hipe_bifs, mark_referred_from, 1) ->
+ [t_mfa()];
+arg_types(hipe_bifs, merge_term, 1) ->
+ [t_any()];
+arg_types(hipe_bifs, patch_call, 3) ->
+ [t_integer(), t_integer(), t_trampoline()];
+arg_types(hipe_bifs, patch_insn, 3) ->
+ [t_integer(), t_integer(), t_insn_type()];
+arg_types(hipe_bifs, primop_address, 1) ->
+ [t_atom()];
+arg_types(hipe_bifs, redirect_referred_from, 1) ->
+ [t_mfa()];
+arg_types(hipe_bifs, ref, 1) ->
+ [t_immediate()];
+arg_types(hipe_bifs, ref_get, 1) ->
+ [t_hiperef()];
+arg_types(hipe_bifs, ref_set, 2) ->
+ [t_hiperef(), t_immediate()];
+arg_types(hipe_bifs, remove_refs_from, 1) ->
+ [t_mfa()];
+arg_types(hipe_bifs, set_funinfo_native_address, 3) ->
+ arg_types(hipe_bifs, set_native_address, 3);
+arg_types(hipe_bifs, set_native_address, 3) ->
+ [t_mfa(), t_integer(), t_boolean()];
+arg_types(hipe_bifs, system_crc, 1) ->
+ [t_integer()];
+arg_types(hipe_bifs, term_to_word, 1) ->
+ [t_any()];
+arg_types(hipe_bifs, update_code_size, 3) ->
+ [t_atom(), t_sup(t_nil(), t_binary()), t_integer()];
+arg_types(hipe_bifs, write_u8, 2) ->
+ [t_integer(), t_byte()];
+arg_types(hipe_bifs, write_u32, 2) ->
+ [t_integer(), t_integer()];
+arg_types(hipe_bifs, write_u64, 2) ->
+ [t_integer(), t_integer()];
+%%------- io ------------------------------------------------------------------
+arg_types(io, format, 1) ->
+ [t_io_format_string()];
+arg_types(io, format, 2) ->
+ [t_io_format_string(), t_list()];
+arg_types(io, format, 3) ->
+ [t_io_device(), t_io_format_string(), t_list()];
+arg_types(io, fwrite, 1) ->
+ arg_types(io, format, 1);
+arg_types(io, fwrite, 2) ->
+ arg_types(io, format, 2);
+arg_types(io, fwrite, 3) ->
+ arg_types(io, format, 3);
+arg_types(io, put_chars, 1) ->
+ [t_iodata()];
+arg_types(io, put_chars, 2) ->
+ [t_io_device(), t_iodata()];
+%%------- io_lib --------------------------------------------------------------
+arg_types(io_lib, format, 2) ->
+ arg_types(io, format, 2);
+arg_types(io_lib, fwrite, 2) ->
+ arg_types(io_lib, format, 2);
+%%------- lists ---------------------------------------------------------------
+arg_types(lists, all, 2) ->
+ [t_fun([t_any()], t_boolean()), t_list()];
+arg_types(lists, any, 2) ->
+ [t_fun([t_any()], t_boolean()), t_list()];
+arg_types(lists, append, 2) ->
+ arg_types(erlang, '++', 2); % alias
+arg_types(lists, delete, 2) ->
+ [t_any(), t_maybe_improper_list()];
+arg_types(lists, dropwhile, 2) ->
+ [t_fun([t_any()], t_boolean()), t_maybe_improper_list()];
+arg_types(lists, filter, 2) ->
+ [t_fun([t_any()], t_boolean()), t_list()];
+arg_types(lists, flatten, 1) ->
+ [t_list()];
+arg_types(lists, flatmap, 2) ->
+ [t_fun([t_any()], t_list()), t_list()];
+arg_types(lists, foreach, 2) ->
+ [t_fun([t_any()], t_any()), t_list()];
+arg_types(lists, foldl, 3) ->
+ [t_fun([t_any(), t_any()], t_any()), t_any(), t_list()];
+arg_types(lists, foldr, 3) ->
+ arg_types(lists, foldl, 3); % same
+arg_types(lists, keydelete, 3) ->
+ [t_any(), t_pos_fixnum(), t_maybe_improper_list()]; % t_list(t_tuple())];
+arg_types(lists, keyfind, 3) ->
+ arg_types(lists, keysearch, 3);
+arg_types(lists, keymap, 3) ->
+ [t_fun([t_any()], t_any()), t_pos_fixnum(), t_list(t_tuple())];
+arg_types(lists, keymember, 3) ->
+ [t_any(), t_pos_fixnum(), t_maybe_improper_list()]; % t_list(t_tuple());
+arg_types(lists, keymerge, 3) ->
+ [t_pos_fixnum(), t_list(t_tuple()), t_list(t_tuple())];
+arg_types(lists, keyreplace, 4) ->
+ [t_any(), t_pos_fixnum(), t_maybe_improper_list(), t_tuple()]; % t_list(t_tuple())];
+arg_types(lists, keysearch, 3) ->
+ [t_any(), t_pos_fixnum(), t_maybe_improper_list()]; % t_list(t_tuple())];
+arg_types(lists, keysort, 2) ->
+ [t_pos_fixnum(), t_list(t_tuple())];
+arg_types(lists, last, 1) ->
+ [t_nonempty_list()];
+arg_types(lists, map, 2) ->
+ [t_fun([t_any()], t_any()), t_list()];
+arg_types(lists, mapfoldl, 3) ->
+ [t_fun([t_any(), t_any()], t_tuple([t_any(), t_any()])), t_any(), t_list()];
+arg_types(lists, mapfoldr, 3) ->
+ arg_types(lists, mapfoldl, 3); % same
+arg_types(lists, max, 1) ->
+ [t_nonempty_list()];
+arg_types(lists, member, 2) ->
+ [t_any(), t_list()];
+%% arg_types(lists, merge, 1) ->
+%% [t_list(t_list())];
+arg_types(lists, merge, 2) ->
+ [t_list(), t_list()];
+%% arg_types(lists, merge, 3) ->
+%% [t_fun([t_any(), t_any()], t_boolean()), t_list(), t_list()];
+%% arg_types(lists, merge3, 3) ->
+%% [t_list(), t_list(), t_list()];
+arg_types(lists, min, 1) ->
+ [t_nonempty_list()];
+arg_types(lists, nth, 2) ->
+ [t_pos_fixnum(), t_nonempty_list()];
+arg_types(lists, nthtail, 2) ->
+ [t_non_neg_fixnum(), t_nonempty_list()];
+arg_types(lists, partition, 2) ->
+ arg_types(lists, filter, 2); % same
+arg_types(lists, reverse, 1) ->
+ [t_list()];
+arg_types(lists, reverse, 2) ->
+ [t_list(), t_any()];
+arg_types(lists, seq, 2) ->
+ [t_integer(), t_integer()];
+arg_types(lists, seq, 3) ->
+ [t_integer(), t_integer(), t_integer()];
+arg_types(lists, sort, 1) ->
+ [t_list()];
+arg_types(lists, sort, 2) ->
+ [t_fun([t_any(), t_any()], t_boolean()), t_list()];
+arg_types(lists, split, 2) ->
+ [t_non_neg_fixnum(), t_maybe_improper_list()]; % do not lie in 2nd arg
+arg_types(lists, splitwith, 2) ->
+ [t_fun([t_any()], t_boolean()), t_maybe_improper_list()];
+arg_types(lists, subtract, 2) ->
+ arg_types(erlang, '--', 2); % alias
+arg_types(lists, takewhile, 2) ->
+ [t_fun([t_any()], t_boolean()), t_maybe_improper_list()];
+arg_types(lists, usort, 1) ->
+ arg_types(lists, sort, 1); % same
+arg_types(lists, usort, 2) ->
+ arg_types(lists, sort, 2);
+arg_types(lists, unzip, 1) ->
+ [t_list(t_tuple(2))];
+arg_types(lists, unzip3, 1) ->
+ [t_list(t_tuple(3))];
+arg_types(lists, zip, 2) ->
+ [t_list(), t_list()];
+arg_types(lists, zip3, 3) ->
+ [t_list(), t_list(), t_list()];
+arg_types(lists, zipwith, 3) ->
+ [t_fun([t_any(), t_any()], t_any()), t_list(), t_list()];
+arg_types(lists, zipwith3, 4) ->
+ [t_fun([t_any(), t_any(), t_any()], t_any()), t_list(), t_list(), t_list()];
+%%------- math ----------------------------------------------------------------
+arg_types(math, acos, 1) ->
+ [t_number()];
+arg_types(math, acosh, 1) ->
+ [t_number()];
+arg_types(math, asin, 1) ->
+ [t_number()];
+arg_types(math, asinh, 1) ->
+ [t_number()];
+arg_types(math, atan, 1) ->
+ [t_number()];
+arg_types(math, atan2, 2) ->
+ [t_number(), t_number()];
+arg_types(math, atanh, 1) ->
+ [t_number()];
+arg_types(math, cos, 1) ->
+ [t_number()];
+arg_types(math, cosh, 1) ->
+ [t_number()];
+arg_types(math, erf, 1) ->
+ [t_number()];
+arg_types(math, erfc, 1) ->
+ [t_number()];
+arg_types(math, exp, 1) ->
+ [t_number()];
+arg_types(math, log, 1) ->
+ [t_number()];
+arg_types(math, log10, 1) ->
+ [t_number()];
+arg_types(math, pi, 0) ->
+ [];
+arg_types(math, pow, 2) ->
+ [t_number(), t_number()];
+arg_types(math, sin, 1) ->
+ [t_number()];
+arg_types(math, sinh, 1) ->
+ [t_number()];
+arg_types(math, sqrt, 1) ->
+ [t_number()];
+arg_types(math, tan, 1) ->
+ [t_number()];
+arg_types(math, tanh, 1) ->
+ [t_number()];
+%%-- net_kernel ---------------------------------------------------------------
+arg_types(net_kernel, dflag_unicode_io, 1) ->
+ [t_pid()];
+%%------- ordsets -------------------------------------------------------------
+arg_types(ordsets, filter, 2) ->
+ arg_types(lists, filter, 2);
+arg_types(ordsets, fold, 3) ->
+ arg_types(lists, foldl, 3);
+%%------- os ------------------------------------------------------------------
+arg_types(os, getenv, 0) ->
+ [];
+arg_types(os, getenv, 1) ->
+ [t_string()];
+arg_types(os, getpid, 0) ->
+ [];
+arg_types(os, putenv, 2) ->
+ [t_string(), t_string()];
+%%-- re -----------------------------------------------------------------------
+arg_types(re, compile, 1) ->
+ [t_iodata()];
+arg_types(re, compile, 2) ->
+ [t_iodata(), t_list(t_re_compile_option())];
+arg_types(re, run, 2) ->
+ [t_iodata(), t_re_RE()];
+arg_types(re, run, 3) ->
+ [t_iodata(), t_re_RE(), t_list(t_re_run_option())];
+%%------- string --------------------------------------------------------------
+arg_types(string, chars, 2) ->
+ [t_char(), t_non_neg_integer()];
+arg_types(string, chars, 3) ->
+ [t_char(), t_non_neg_integer(), t_any()];
+arg_types(string, concat, 2) ->
+ [t_string(), t_string()];
+arg_types(string, equal, 2) ->
+ [t_string(), t_string()];
+arg_types(string, to_float, 1) ->
+ [t_string()];
+arg_types(string, to_integer, 1) ->
+ [t_string()];
+%%------- unicode -------------------------------------------------------------
+arg_types(unicode, characters_to_binary, 2) ->
+ [t_ML(), t_encoding()];
+arg_types(unicode, characters_to_list, 2) ->
+ [t_ML(), t_encoding()];
+arg_types(unicode, bin_is_7bit, 1) ->
+ [t_binary()];
+%%-----------------------------------------------------------------------------
+arg_types(M, F, A) when is_atom(M), is_atom(F),
+ is_integer(A), 0 =< A, A =< 255 ->
+ unknown. % safe approximation for all functions.
+
+
+-spec is_known(atom(), atom(), arity()) -> boolean().
+
+is_known(M, F, A) ->
+ arg_types(M, F, A) =/= unknown.
+
+
+-spec structure_inspecting_args(atom(), atom(), arity()) -> [1..255].
+
+structure_inspecting_args(erlang, element, 2) -> [2];
+structure_inspecting_args(erlang, is_atom, 1) -> [1];
+structure_inspecting_args(erlang, is_boolean, 1) -> [1];
+structure_inspecting_args(erlang, is_binary, 1) -> [1];
+structure_inspecting_args(erlang, is_bitstring, 1) -> [1];
+structure_inspecting_args(erlang, is_float, 1) -> [1];
+structure_inspecting_args(erlang, is_function, 1) -> [1];
+structure_inspecting_args(erlang, is_integer, 1) -> [1];
+structure_inspecting_args(erlang, is_list, 1) -> [1];
+structure_inspecting_args(erlang, is_number, 1) -> [1];
+structure_inspecting_args(erlang, is_pid, 1) -> [1];
+structure_inspecting_args(erlang, is_port, 1) -> [1];
+structure_inspecting_args(erlang, is_reference, 1) -> [1];
+structure_inspecting_args(erlang, is_tuple, 1) -> [1];
+%%structure_inspecting_args(erlang, setelement, 3) -> [2].
+structure_inspecting_args(_, _, _) -> []. % XXX: assume no arg needs inspection
+
+
+check_fun_application(Fun, Args) ->
+ case t_is_fun(Fun) of
+ true ->
+ case t_fun_args(Fun) of
+ unknown ->
+ case t_is_none_or_unit(t_fun_range(Fun)) of
+ true -> error;
+ false -> ok
+ end;
+ FunDom when length(FunDom) =:= length(Args) ->
+ case any_is_none_or_unit(inf_lists(FunDom, Args)) of
+ true -> error;
+ false ->
+ case t_is_none_or_unit(t_fun_range(Fun)) of
+ true -> error;
+ false -> ok
+ end
+ end;
+ _ -> error
+ end;
+ false ->
+ error
+ end.
+
+
+%% =====================================================================
+%% These are basic types that should probably be moved to erl_types
+%% =====================================================================
+
+t_socket() -> t_port(). % alias
+
+t_ip_address() ->
+ T_int16 = t_from_range(0, 16#FFFF),
+ t_sup(t_tuple([t_byte(), t_byte(), t_byte(), t_byte()]),
+ t_tuple([T_int16, T_int16, T_int16, T_int16,
+ T_int16, T_int16, T_int16, T_int16])).
+
+%% =====================================================================
+%% Some basic types used in various parts of the system
+%% =====================================================================
+
+t_date() ->
+ t_tuple([t_pos_fixnum(), t_pos_fixnum(), t_pos_fixnum()]).
+
+t_time() ->
+ t_tuple([t_non_neg_fixnum(), t_non_neg_fixnum(), t_non_neg_fixnum()]).
+
+t_packet() ->
+ t_sup([t_binary(), t_iolist(), t_httppacket()]).
+
+t_httppacket() ->
+ t_sup([t_HttpRequest(), t_HttpResponse(),
+ t_HttpHeader(), t_atom('http_eoh'), t_HttpError()]).
+
+%% =====================================================================
+%% HTTP types documented in R12B-4
+%% =====================================================================
+
+t_HttpRequest() ->
+ t_tuple([t_atom('http_request'), t_HttpMethod(), t_HttpUri(), t_HttpVersion()]).
+
+t_HttpResponse() ->
+ t_tuple([t_atom('http_response'), t_HttpVersion(), t_integer(), t_string()]).
+
+t_HttpHeader() ->
+ t_tuple([t_atom('http_header'), t_integer(), t_HttpField(), t_any(), t_string()]).
+
+t_HttpError() ->
+ t_tuple([t_atom('http_error'), t_string()]).
+
+t_HttpMethod() ->
+ t_sup(t_HttpMethodAtom(), t_string()).
+
+t_HttpMethodAtom() ->
+ t_atoms(['OPTIONS', 'GET', 'HEAD', 'POST', 'PUT', 'DELETE', 'TRACE']).
+
+t_HttpUri() ->
+ t_sup([t_atom('*'),
+ t_tuple([t_atom('absoluteURI'),
+ t_sup(t_atom('http'), t_atom('https')),
+ t_string(),
+ t_sup(t_non_neg_integer(), t_atom('undefined')),
+ t_string()]),
+ t_tuple([t_atom('scheme'), t_string(), t_string()]),
+ t_tuple([t_atom('abs_path'), t_string()]),
+ t_string()]).
+
+t_HttpVersion() ->
+ t_tuple([t_non_neg_integer(), t_non_neg_integer()]).
+
+t_HttpField() ->
+ t_sup(t_HttpFieldAtom(), t_string()).
+
+t_HttpFieldAtom() ->
+ t_atoms(['Cache-Control', 'Connection', 'Date', 'Pragma', 'Transfer-Encoding',
+ 'Upgrade', 'Via', 'Accept', 'Accept-Charset', 'Accept-Encoding',
+ 'Accept-Language', 'Authorization', 'From', 'Host',
+ 'If-Modified-Since', 'If-Match', 'If-None-Match', 'If-Range',
+ 'If-Unmodified-Since', 'Max-Forwards', 'Proxy-Authorization',
+ 'Range', 'Referer', 'User-Agent', 'Age', 'Location',
+ 'Proxy-Authenticate', 'Public', 'Retry-After', 'Server', 'Vary',
+ 'Warning', 'Www-Authenticate', 'Allow', 'Content-Base',
+ 'Content-Encoding', 'Content-Language', 'Content-Length',
+ 'Content-Location', 'Content-Md5', 'Content-Range', 'Content-Type',
+ 'Etag', 'Expires', 'Last-Modified', 'Accept-Ranges',
+ 'Set-Cookie', 'Set-Cookie2', 'X-Forwarded-For', 'Cookie',
+ 'Keep-Alive', 'Proxy-Connection']).
+
+%% =====================================================================
+%% These are used for the built-in functions of 'code'
+%% =====================================================================
+
+t_code_load_return(Mod) ->
+ t_sup(t_tuple([t_atom('module'), case t_is_atom(Mod) of
+ true -> Mod;
+ false -> t_atom()
+ end]),
+ t_tuple([t_atom('error'), t_code_load_error_rsn()])).
+
+t_code_load_error_rsn() -> % also used in erlang:load_module/2
+ t_sup([t_atom('badfile'),
+ t_atom('nofile'),
+ t_atom('not_purged'),
+ t_atom('native_code'),
+ t_atom('sticky_directory')]). % only for the 'code' functions
+
+t_code_loaded_fname_or_status() ->
+ t_sup([t_string(), % filename
+ t_atom('preloaded'),
+ t_atom('cover_compiled')]).
+
+%% =====================================================================
+%% These are used for the built-in functions of 'erlang'
+%% =====================================================================
+
+t_decode_packet_option() ->
+ t_sup([t_tuple([t_atom('packet_size'), t_non_neg_integer()]),
+ t_tuple([t_atom('line_length'), t_non_neg_integer()])]).
+
+t_decode_packet_type() ->
+ t_sup(t_inet_setoption_packettype(), t_atom('httph')).
+
+t_dist_exit() ->
+ t_sup([t_atom('kill'), t_atom('noconnection'), t_atom('normal')]).
+
+t_match_spec_test_errors() ->
+ t_list(t_sup(t_tuple([t_atom('error'), t_string()]),
+ t_tuple([t_atom('warning'), t_string()]))).
+
+t_module_info_2() ->
+ t_sup([t_atom('module'),
+ t_atom('imports'),
+ t_atom('exports'),
+ t_atom('functions'),
+ t_atom('attributes'),
+ t_atom('compile'),
+ t_atom('native_addresses')]).
+
+t_pinfo() ->
+ t_sup([t_pinfo_item(), t_list(t_pinfo_item())]).
+
+t_pinfo_item() ->
+ t_sup([t_atom('backtrace'),
+ t_atom('current_function'),
+ t_atom('dictionary'),
+ t_atom('error_handler'),
+ t_atom('garbage_collection'),
+ t_atom('group_leader'),
+ t_atom('heap_size'),
+ t_atom('initial_call'),
+ t_atom('last_calls'),
+ t_atom('links'),
+ t_atom('memory'),
+ t_atom('message_binary'), % for hybrid heap only
+ t_atom('message_queue_len'),
+ t_atom('messages'),
+ t_atom('monitored_by'),
+ t_atom('monitors'),
+ t_atom('priority'),
+ t_atom('reductions'),
+ t_atom('registered_name'),
+ t_atom('sequential_trace_token'),
+ t_atom('stack_size'),
+ t_atom('status'),
+ t_atom('suspending'),
+ t_atom('total_heap_size'),
+ t_atom('trap_exit')]).
+
+t_process_priority_level() ->
+ t_sup([t_atom('max'), t_atom('high'), t_atom('normal'), t_atom('low')]).
+
+t_process_status() ->
+ t_sup([t_atom('runnable'), t_atom('running'),
+ t_atom('suspended'), t_atom('waiting')]).
+
+t_raise_errorclass() ->
+ t_sup([t_atom('error'), t_atom('exit'), t_atom('throw')]).
+
+t_sendoptions() ->
+ t_sup(t_atom('noconnect'), t_atom('nosuspend')).
+
+t_seq_trace_info() ->
+ t_sup([t_atom('send'),
+ t_atom('receive'),
+ t_atom('print'),
+ t_atom('timestamp'),
+ t_atom('label'),
+ t_atom('serial')]).
+
+%% XXX: Better if we also maintain correspondencies between infos and values
+t_seq_trace_info_returns() ->
+ Values = t_sup([t_non_neg_integer(), t_boolean(),
+ t_tuple([t_non_neg_integer(), t_non_neg_integer()])]),
+ t_sup(t_tuple([t_seq_trace_info(), Values]), t_nil()).
+
+t_sequential_tracer() ->
+ t_sup([t_atom('false'), t_pid(), t_port()]).
+
+t_spawn_options() ->
+ t_sup([t_atom('link'),
+ t_atom('monitor'),
+ t_tuple([t_atom('priority'), t_process_priority_level()]),
+ t_tuple([t_atom('min_heap_size'), t_fixnum()]),
+ t_tuple([t_atom('fullsweep_after'), t_fixnum()])]).
+
+t_spawn_opt_return(List) ->
+ case t_is_none(t_inf(t_list(t_atom('monitor')), List)) of
+ true -> t_pid();
+ false -> t_sup(t_pid(), t_tuple([t_pid(), t_reference()]))
+ end.
+
+t_system_cpu_topology() ->
+ t_sup(t_atom('undefined'), t_system_cpu_topology_level_entry_list()).
+
+t_system_cpu_topology_level_entry_list() ->
+ t_list(t_system_cpu_topology_level_entry()).
+
+t_system_cpu_topology_level_entry() ->
+ t_sup(t_tuple([t_system_cpu_topology_level_tag(),
+ t_system_cpu_topology_sublevel_entry()]),
+ t_tuple([t_system_cpu_topology_level_tag(),
+ t_system_cpu_topology_info_list(),
+ t_system_cpu_topology_sublevel_entry()])).
+
+t_system_cpu_topology_sublevel_entry() ->
+ t_sup(t_system_cpu_topology_logical_cpu_id(),
+ t_list(t_tuple())). % approximation
+
+t_system_cpu_topology_level_tag() ->
+ t_atoms(['core', 'node', 'processor', 'thread']).
+
+t_system_cpu_topology_logical_cpu_id() ->
+ t_tuple([t_atom('logical'), t_non_neg_fixnum()]).
+
+t_system_cpu_topology_info_list() ->
+ t_nil(). % it may be extended in the future
+
+t_internal_cpu_topology() -> %% Internal undocumented type
+ t_sup(t_list(t_tuple([t_atom('cpu'),
+ t_non_neg_fixnum(),
+ t_non_neg_fixnum(),
+ t_non_neg_fixnum(),
+ t_non_neg_fixnum(),
+ t_non_neg_fixnum(),
+ t_non_neg_fixnum()])),
+ t_atom('undefined')).
+
+t_scheduler_bind_type_args() ->
+ t_sup([t_atom('default_bind'),
+ t_atom('no_node_processor_spread'),
+ t_atom('no_node_thread_spread'),
+ t_atom('no_spread'),
+ t_atom('processor_spread'),
+ t_atom('spread'),
+ t_atom('thread_spread'),
+ t_atom('thread_no_node_processor_spread'),
+ t_atom('unbound')]).
+
+t_scheduler_bind_type_results() ->
+ t_sup([t_atom('no_node_processor_spread'),
+ t_atom('no_node_thread_spread'),
+ t_atom('no_spread'),
+ t_atom('processor_spread'),
+ t_atom('spread'),
+ t_atom('thread_spread'),
+ t_atom('thread_no_node_processor_spread'),
+ t_atom('unbound')]).
+
+
+t_system_monitor_settings() ->
+ t_sup([t_atom('undefined'),
+ t_tuple([t_pid(), t_system_monitor_options()])]).
+
+t_system_monitor_options() ->
+ t_list(t_sup([t_atom('busy_port'),
+ t_atom('busy_dist_port'),
+ t_tuple([t_atom('long_gc'), t_integer()]),
+ t_tuple([t_atom('large_heap'), t_integer()])])).
+
+t_system_multi_scheduling() ->
+ t_sup([t_atom('blocked'), t_atom('disabled'), t_atom('enabled')]).
+
+t_system_profile_options() ->
+ t_list(t_sup([t_atom('exclusive'),
+ t_atom('runnable_ports'),
+ t_atom('runnable_procs'),
+ t_atom('scheduler')])).
+
+t_system_profile_return() ->
+ t_sup(t_atom('undefined'),
+ t_tuple([t_sup(t_pid(), t_port()), t_system_profile_options()])).
+
+%% =====================================================================
+%% These are used for the built-in functions of 'ets'
+%% =====================================================================
+
+t_tab() ->
+ t_sup(t_tid(), t_atom()).
+
+t_match_pattern() ->
+ t_sup(t_atom(), t_tuple()).
+
+t_matchspecs() ->
+ t_list(t_tuple([t_match_pattern(), t_list(), t_list()])).
+
+t_matchres() ->
+ t_sup(t_tuple([t_list(), t_any()]), t_atom('$end_of_table')).
+
+%% From the 'ets' documentation
+%%-----------------------------
+%% Option = Type | Access | named_table | {keypos,Pos}
+%% | {heir,pid(),HeirData} | {heir,none}
+%% | {write_concurrency,boolean()}
+%% Type = set | ordered_set | bag | duplicate_bag
+%% Access = public | protected | private
+%% Pos = integer()
+%% HeirData = term()
+t_ets_new_options() ->
+ t_list(t_sup([t_atom('set'),
+ t_atom('ordered_set'),
+ t_atom('bag'),
+ t_atom('duplicate_bag'),
+ t_atom('public'),
+ t_atom('protected'),
+ t_atom('private'),
+ t_atom('named_table'),
+ t_tuple([t_atom('heir'), t_pid(), t_any()]),
+ t_tuple([t_atom('heir'), t_atom('none')]),
+ t_tuple([t_atom('keypos'), t_integer()]),
+ t_tuple([t_atom('write_concurrency'), t_boolean()])])).
+
+t_ets_info_items() ->
+ t_sup([t_atom('fixed'),
+ t_atom('safe_fixed'),
+ t_atom('keypos'),
+ t_atom('memory'),
+ t_atom('name'),
+ t_atom('named_table'),
+ t_atom('node'),
+ t_atom('owner'),
+ t_atom('protection'),
+ t_atom('size'),
+ t_atom('type')]).
+
+%% =====================================================================
+%% These are used for the built-in functions of 'file'
+%% =====================================================================
+
+t_file_io_device() ->
+ t_sup(t_pid(), t_tuple([t_atom('file_descriptor'), t_atom(), t_any()])).
+
+t_file_name() ->
+ t_sup([t_atom(),
+ t_string(),
+ %% DeepList = [char() | atom() | DeepList] -- approximation below
+ t_list(t_sup([t_atom(), t_string(), t_list()]))]).
+
+t_file_open_option() ->
+ t_sup([t_atom('read'),
+ t_atom('write'),
+ t_atom('append'),
+ t_atom('raw'),
+ t_atom('binary'),
+ t_atom('delayed_write'),
+ t_atom('read_ahead'),
+ t_atom('compressed'),
+ t_tuple([t_atom('delayed_write'),
+ t_pos_integer(), t_non_neg_integer()]),
+ t_tuple([t_atom('read_ahead'), t_pos_integer()])]).
+
+%% This lists all Posix errors that can occur in file:*/* functions
+t_file_posix_error() ->
+ t_sup([t_atom('eacces'),
+ t_atom('eagain'),
+ t_atom('ebadf'),
+ t_atom('ebusy'),
+ t_atom('edquot'),
+ t_atom('eexist'),
+ t_atom('efault'),
+ t_atom('efbig'),
+ t_atom('eintr'),
+ t_atom('einval'),
+ t_atom('eio'),
+ t_atom('eisdir'),
+ t_atom('eloop'),
+ t_atom('emfile'),
+ t_atom('emlink'),
+ t_atom('enametoolong'),
+ t_atom('enfile'),
+ t_atom('enodev'),
+ t_atom('enoent'),
+ t_atom('enomem'),
+ t_atom('enospc'),
+ t_atom('enotblk'),
+ t_atom('enotdir'),
+ t_atom('enotsup'),
+ t_atom('enxio'),
+ t_atom('eperm'),
+ t_atom('epipe'),
+ t_atom('erofs'),
+ t_atom('espipe'),
+ t_atom('esrch'),
+ t_atom('estale'),
+ t_atom('exdev')]).
+
+t_file_return() ->
+ t_sup(t_atom('ok'), t_tuple([t_atom('error'), t_file_posix_error()])).
+
+%% =====================================================================
+%% These are used for the built-in functions of 'gen_tcp'
+%% =====================================================================
+
+t_gen_tcp_accept() ->
+ t_sup(t_tuple([t_atom('ok'), t_socket()]),
+ t_tuple([t_atom('error'), t_sup([t_atom('closed'),
+ t_atom('timeout'),
+ t_inet_posix_error()])])).
+
+t_gen_tcp_address() ->
+ t_sup([t_string(), t_atom(), t_ip_address()]).
+
+t_gen_tcp_port() ->
+ t_from_range(0, 16#FFFF).
+
+t_gen_tcp_connect_option() ->
+ t_sup([t_atom('list'),
+ t_atom('binary'),
+ t_tuple([t_atom('ip'), t_ip_address()]),
+ t_tuple([t_atom('port'), t_gen_tcp_port()]),
+ t_tuple([t_atom('fd'), t_integer()]),
+ t_atom('inet6'),
+ t_atom('inet'),
+ t_inet_setoption()]).
+
+t_gen_tcp_listen_option() ->
+ t_sup([t_atom('list'),
+ t_atom('binary'),
+ t_tuple([t_atom('backlog'), t_non_neg_integer()]),
+ t_tuple([t_atom('ip'), t_ip_address()]),
+ t_tuple([t_atom('fd'), t_integer()]),
+ t_atom('inet6'),
+ t_atom('inet'),
+ t_inet_setoption()]).
+
+t_gen_tcp_recv() ->
+ t_sup(t_tuple([t_atom('ok'), t_packet()]),
+ t_tuple([t_atom('error'), t_sup([t_atom('closed'),
+ t_inet_posix_error()])])).
+
+%% =====================================================================
+%% These are used for the built-in functions of 'gen_udp'
+%% =====================================================================
+
+t_gen_udp_connect_option() ->
+ t_sup([t_atom('list'),
+ t_atom('binary'),
+ t_tuple([t_atom('ip'), t_ip_address()]),
+ t_tuple([t_atom('fd'), t_integer()]),
+ t_atom('inet6'),
+ t_atom('inet'),
+ t_inet_setoption()]).
+
+t_gen_udp_recv() ->
+ t_sup(t_tuple([t_atom('ok'),
+ t_tuple([t_ip_address(),
+ t_gen_tcp_port(),
+ t_packet()])]),
+ t_tuple([t_atom('error'),
+ t_sup(t_atom('not_owner'), t_inet_posix_error())])).
+
+%% =====================================================================
+%% These are used for the built-in functions of 'hipe_bifs'
+%% =====================================================================
+
+t_trampoline() ->
+ t_sup(t_nil(), t_integer()).
+
+t_immediate() ->
+ t_sup([t_nil(), t_atom(), t_fixnum()]).
+
+t_immarray() ->
+ t_integer(). %% abstract data type
+
+t_hiperef() ->
+ t_immarray().
+
+t_bitarray() ->
+ t_bitstr().
+
+t_bytearray() ->
+ t_binary().
+
+t_insn_type() ->
+ t_sup([% t_atom('call'),
+ t_atom('load_mfa'),
+ t_atom('x86_abs_pcrel'),
+ t_atom('atom'),
+ t_atom('constant'),
+ t_atom('c_const'),
+ t_atom('closure')]).
+
+%% =====================================================================
+%% These are used for the built-in functions of 'inet'
+%% =====================================================================
+
+t_inet_setoption() ->
+ t_sup([%% first the 2-tuple options
+ t_tuple([t_atom('active'), t_sup(t_boolean(), t_atom('once'))]),
+ t_tuple([t_atom('broadcast'), t_boolean()]),
+ t_tuple([t_atom('delay_send'), t_boolean()]),
+ t_tuple([t_atom('dontroute'), t_boolean()]),
+ t_tuple([t_atom('exit_on_close'), t_boolean()]),
+ t_tuple([t_atom('header'), t_non_neg_integer()]),
+ t_tuple([t_atom('keepalive'), t_boolean()]),
+ t_tuple([t_atom('nodelay'), t_boolean()]),
+ t_tuple([t_atom('packet'), t_inet_setoption_packettype()]),
+ t_tuple([t_atom('packet_size'), t_non_neg_integer()]),
+ t_tuple([t_atom('read_packets'), t_non_neg_integer()]),
+ t_tuple([t_atom('recbuf'), t_non_neg_integer()]),
+ t_tuple([t_atom('reuseaddr'), t_boolean()]),
+ t_tuple([t_atom('send_timeout'), t_non_neg_integer()]),
+ t_tuple([t_atom('sndbuf'), t_non_neg_integer()]),
+ t_tuple([t_atom('priority'), t_non_neg_integer()]),
+ t_tuple([t_atom('tos'), t_non_neg_integer()]),
+ %% and a 4-tuple option
+ t_tuple([t_atom('raw'),
+ t_non_neg_integer(), % protocol level
+ t_non_neg_integer(), % option number
+ t_binary()])]). % actual option value
+
+t_inet_setoption_packettype() ->
+ t_sup([t_atom('raw'),
+ t_integers([0,1,2,4]),
+ t_atom('asn1'), t_atom('cdr'), t_atom('sunrm'),
+ t_atom('fcgi'), t_atom('tpkt'), t_atom('line'),
+ t_atom('http')]). %% but t_atom('httph') is not needed
+
+t_inet_posix_error() ->
+ t_atom(). %% XXX: Very underspecified
+
+%% =====================================================================
+%% These are used for the built-in functions of 'io'
+%% =====================================================================
+
+t_io_device() ->
+ t_sup(t_atom(), t_pid()).
+
+%% The documentation in R11B-4 reads
+%% Format ::= atom() | string() | binary()
+%% but the Format can also be a (deep) list, hence the type below
+t_io_format_string() ->
+ t_sup([t_atom(), t_list(), t_binary()]).
+
+%% =====================================================================
+%% These are used for the built-in functions of 're'; the functions
+%% whose last name component starts with a capital letter are types
+%% =====================================================================
+
+t_re_MP() -> %% it's supposed to be an opaque data type
+ t_tuple([t_atom('re_pattern'), t_integer(), t_integer(), t_binary()]).
+
+t_re_RE() ->
+ t_sup(t_re_MP(), t_iodata()).
+
+t_re_compile_option() ->
+ t_sup([t_atoms(['anchored', 'caseless', 'dollar_endonly', 'dotall',
+ 'extended', 'firstline', 'multiline', 'no_auto_capture',
+ 'dupnames', 'ungreedy']),
+ t_tuple([t_atom('newline'), t_re_NLSpec()])]).
+
+t_re_run_option() ->
+ t_sup([t_atoms(['anchored', 'global', 'notbol', 'noteol', 'notempty']),
+ t_tuple([t_atom('offset'), t_integer()]),
+ t_tuple([t_atom('newline'), t_re_NLSpec()]),
+ t_tuple([t_atom('capture'), t_re_ValueSpec()]),
+ t_tuple([t_atom('capture'), t_re_ValueSpec(), t_re_Type()]),
+ t_re_compile_option()]).
+
+t_re_ErrorSpec() ->
+ t_tuple([t_string(), t_non_neg_integer()]).
+
+t_re_Type() ->
+ t_atoms(['index', 'list', 'binary']).
+
+t_re_NLSpec() ->
+ t_atoms(['cr', 'crlf', 'lf', 'anycrlf']).
+
+t_re_ValueSpec() ->
+ t_sup(t_atoms(['all', 'all_but_first', 'first', 'none']), t_re_ValueList()).
+
+t_re_ValueList() ->
+ t_list(t_sup([t_integer(), t_string(), t_atom()])).
+
+t_re_Captured() ->
+ t_list(t_sup(t_re_CapturedData(), t_list(t_re_CapturedData()))).
+
+t_re_CapturedData() ->
+ t_sup([t_tuple([t_integer(), t_integer()]), t_string(), t_binary()]).
+
+%% =====================================================================
+%% These are used for the built-in functions of 'unicode'
+%% =====================================================================
+
+t_ML() -> % a binary or a possibly deep list of integers or binaries
+ t_sup(t_list(t_sup([t_integer(), t_binary(), t_list()])), t_binary()).
+
+t_encoding() ->
+ t_atoms(['latin1', 'unicode', 'utf8', 'utf16', 'utf32']).
+
+t_encoding_a2b() -> % for the 2nd arg of atom_to_binary/2 and binary_to_atom/2
+ t_atoms(['latin1', 'unicode', 'utf8']).
+
+%% =====================================================================
+%% Some testing code for ranges below
+%% =====================================================================
+
+-ifdef(DO_ERL_BIF_TYPES_TEST).
+
+test() ->
+ put(hipe_target_arch, amd64),
+
+ Bsl1 = type(erlang, 'bsl', 2, [t_from_range(1, 299), t_from_range(-4, 22)]),
+ Bsl2 = type(erlang, 'bsl', 2),
+ Bsl3 = type(erlang, 'bsl', 2, [t_from_range(1, 299), t_atom('pelle')]),
+ io:format("Bsl ~p ~p ~p~n", [Bsl1, Bsl2, Bsl3]),
+
+ Add1 = type(erlang, '+', 2, [t_from_range(1, 299), t_from_range(-4, 22)]),
+ Add2 = type(erlang, '+', 2),
+ Add3 = type(erlang, '+', 2, [t_from_range(1, 299), t_atom('pelle')]),
+ io:format("Add ~p ~p ~p~n", [Add1, Add2, Add3]),
+
+ Band1 = type(erlang, 'band', 2, [t_from_range(1, 29), t_from_range(34, 36)]),
+ Band2 = type(erlang, 'band', 2),
+ Band3 = type(erlang, 'band', 2, [t_from_range(1, 299), t_atom('pelle')]),
+ io:format("band ~p ~p ~p~n", [Band1, Band2, Band3]),
+
+ Bor1 = type(erlang, 'bor', 2, [t_from_range(1, 29), t_from_range(8, 11)]),
+ Bor2 = type(erlang, 'bor', 2),
+ Bor3 = type(erlang, 'bor', 2, [t_from_range(1, 299), t_atom('pelle')]),
+ io:format("bor ~p ~p ~p~n", [Bor1, Bor2, Bor3]),
+
+ io:format("inf_?"),
+ pos_inf = infinity_max([1, 4, 51, pos_inf]),
+ -12 = infinity_min([1, 142, -4, -12]),
+ neg_inf = infinity_max([neg_inf]),
+
+ io:format("width"),
+ 4 = width({7, 9}),
+ pos_inf = width({neg_inf, 100}),
+ pos_inf = width({1, pos_inf}),
+ 3 = width({-8, 7}),
+ 0 = width({-1, 0}),
+
+ io:format("arith * "),
+ Mult1 = t_from_range(0, 12),
+ Mult2 = t_from_range(-21, 7),
+ Mult1 = type(erlang, '*', 2, [t_from_range(2,3), t_from_range(0,4)]),
+ Mult2 = type(erlang, '*', 2, [t_from_range(-7,-1), t_from_range(-1,3)]),
+ ok.
+
+-endif.
diff --git a/lib/hipe/cerl/erl_types.erl b/lib/hipe/cerl/erl_types.erl
new file mode 100644
index 0000000000..fac308d0c6
--- /dev/null
+++ b/lib/hipe/cerl/erl_types.erl
@@ -0,0 +1,3847 @@
+%% -*- erlang-indent-level: 2 -*-
+%%
+%% %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%
+%%
+%% ======================================================================
+%% Copyright (C) 2000-2003 Richard Carlsson
+%%
+%% ======================================================================
+%% Provides a representation of Erlang types.
+%%
+%% The initial author of this file is Richard Carlsson (2000-2004).
+%% In July 2006, the type representation was totally re-designed by
+%% Tobias Lindahl. This is the representation which is used currently.
+%% In late 2008, Manouk Manoukian and Kostis Sagonas added support for
+%% opaque types to the structure-based representation of types.
+%% During February and March 2009, Kostis Sagonas significantly
+%% cleaned up the type representation added spec declarations.
+%%
+%% Author contact: [email protected], [email protected], [email protected]
+%% ======================================================================
+
+-module(erl_types).
+
+-export([any_none/1,
+ any_none_or_unit/1,
+ lookup_record/3,
+ max/2,
+ module_builtin_opaques/1,
+ min/2,
+ number_max/1,
+ number_min/1,
+ t_abstract_records/2,
+ t_any/0,
+ t_arity/0,
+ t_atom/0,
+ t_atom/1,
+ t_atoms/1,
+ t_atom_vals/1,
+ t_binary/0,
+ t_bitstr/0,
+ t_bitstr/2,
+ t_bitstr_base/1,
+ t_bitstr_concat/1,
+ t_bitstr_concat/2,
+ t_bitstr_match/2,
+ t_bitstr_unit/1,
+ t_boolean/0,
+ t_byte/0,
+ t_char/0,
+ t_collect_vars/1,
+ t_cons/0,
+ t_cons/2,
+ t_cons_hd/1,
+ t_cons_tl/1,
+ t_constant/0,
+ t_contains_opaque/1,
+ t_elements/1,
+ t_find_opaque_mismatch/2,
+ t_fixnum/0,
+ t_map/2,
+ t_non_neg_fixnum/0,
+ t_pos_fixnum/0,
+ t_float/0,
+ t_form_to_string/1,
+ t_from_form/1,
+ t_from_form/2,
+ t_from_form/3,
+ t_from_range/2,
+ t_from_range_unsafe/2,
+ t_from_term/1,
+ t_fun/0,
+ t_fun/1,
+ t_fun/2,
+ t_fun_args/1,
+ t_fun_arity/1,
+ t_fun_range/1,
+ t_has_opaque_subtype/1,
+ t_has_var/1,
+ t_identifier/0,
+ %% t_improper_list/2,
+ t_inf/2,
+ t_inf/3,
+ t_inf_lists/2,
+ t_inf_lists/3,
+ t_integer/0,
+ t_integer/1,
+ t_non_neg_integer/0,
+ t_pos_integer/0,
+ t_integers/1,
+ t_iodata/0,
+ t_iolist/0,
+ t_is_any/1,
+ t_is_atom/1,
+ t_is_atom/2,
+ t_is_binary/1,
+ t_is_bitstr/1,
+ t_is_bitwidth/1,
+ t_is_boolean/1,
+ %% t_is_byte/1,
+ %% t_is_char/1,
+ t_is_cons/1,
+ t_is_constant/1,
+ t_is_equal/2,
+ t_is_fixnum/1,
+ t_is_float/1,
+ t_is_fun/1,
+ t_is_instance/2,
+ t_is_integer/1,
+ t_is_list/1,
+ t_is_matchstate/1,
+ t_is_nil/1,
+ t_is_non_neg_integer/1,
+ t_is_none/1,
+ t_is_none_or_unit/1,
+ t_is_number/1,
+ t_is_opaque/1,
+ t_is_pid/1,
+ t_is_port/1,
+ t_is_maybe_improper_list/1,
+ t_is_reference/1,
+ t_is_remote/1,
+ t_is_string/1,
+ t_is_subtype/2,
+ t_is_tuple/1,
+ t_is_unit/1,
+ t_is_var/1,
+ t_limit/2,
+ t_list/0,
+ t_list/1,
+ t_list_elements/1,
+ t_list_termination/1,
+ t_matchstate/0,
+ t_matchstate/2,
+ t_matchstate_present/1,
+ t_matchstate_slot/2,
+ t_matchstate_slots/1,
+ t_matchstate_update_present/2,
+ t_matchstate_update_slot/3,
+ t_mfa/0,
+ t_module/0,
+ t_nil/0,
+ t_node/0,
+ t_none/0,
+ t_nonempty_list/0,
+ t_nonempty_list/1,
+ t_nonempty_string/0,
+ t_number/0,
+ t_number/1,
+ t_number_vals/1,
+ t_opaque_from_records/1,
+ t_opaque_match_atom/2,
+ t_opaque_match_record/2,
+ t_opaque_matching_structure/2,
+ t_opaque_structure/1,
+ t_pid/0,
+ t_port/0,
+ t_maybe_improper_list/0,
+ %% t_maybe_improper_list/2,
+ t_product/1,
+ t_reference/0,
+ t_remote/3,
+ t_string/0,
+ t_struct_from_opaque/2,
+ t_solve_remote/2,
+ t_subst/2,
+ t_subtract/2,
+ t_subtract_list/2,
+ t_sup/1,
+ t_sup/2,
+ t_tid/0,
+ t_timeout/0,
+ t_to_string/1,
+ t_to_string/2,
+ t_to_tlist/1,
+ t_tuple/0,
+ t_tuple/1,
+ t_tuple_args/1,
+ t_tuple_size/1,
+ t_tuple_sizes/1,
+ t_tuple_subtypes/1,
+ t_unify/2,
+ t_unit/0,
+ t_unopaque/1,
+ t_unopaque/2,
+ t_var/1,
+ t_var_name/1,
+ %% t_assign_variables_to_subtype/2,
+ type_is_defined/3,
+ subst_all_vars_to_any/1,
+ lift_list_to_pos_empty/1
+ ]).
+
+%%-define(DO_ERL_TYPES_TEST, true).
+
+-ifdef(DO_ERL_TYPES_TEST).
+-export([test/0]).
+-else.
+-define(NO_UNUSED, true).
+-endif.
+
+-ifndef(NO_UNUSED).
+-export([t_is_identifier/1]).
+-endif.
+
+%%=============================================================================
+%%
+%% Definition of the type structure
+%%
+%%=============================================================================
+
+%%-----------------------------------------------------------------------------
+%% Limits
+%%
+
+-define(TUPLE_TAG_LIMIT, 5).
+-define(TUPLE_ARITY_LIMIT, 10).
+-define(SET_LIMIT, 13).
+-define(MAX_BYTE, 255).
+-define(MAX_CHAR, 16#10ffff).
+
+-define(WIDENING_LIMIT, 7).
+-define(UNIT_MULTIPLIER, 8).
+
+-define(TAG_IMMED1_SIZE, 4).
+-define(BITS, (erlang:system_info(wordsize) * 8) - ?TAG_IMMED1_SIZE).
+
+%%-----------------------------------------------------------------------------
+%% Type tags and qualifiers
+%%
+
+-define(atom_tag, atom).
+-define(binary_tag, binary).
+-define(function_tag, function).
+-define(identifier_tag, identifier).
+-define(list_tag, list).
+-define(matchstate_tag, matchstate).
+-define(nil_tag, nil).
+-define(number_tag, number).
+-define(opaque_tag, opaque).
+-define(product_tag, product).
+-define(remote_tag, remote).
+-define(tuple_set_tag, tuple_set).
+-define(tuple_tag, tuple).
+-define(union_tag, union).
+-define(var_tag, var).
+
+-type tag() :: ?atom_tag | ?binary_tag | ?function_tag | ?identifier_tag
+ | ?list_tag | ?matchstate_tag | ?nil_tag | ?number_tag
+ | ?opaque_tag | ?product_tag | ?tuple_tag | ?tuple_set_tag
+ | ?union_tag | ?var_tag.
+
+-define(float_qual, float).
+-define(integer_qual, integer).
+-define(nonempty_qual, nonempty).
+-define(pid_qual, pid).
+-define(port_qual, port).
+-define(reference_qual, reference).
+-define(unknown_qual, unknown).
+
+-type qual() :: ?float_qual | ?integer_qual | ?nonempty_qual | ?pid_qual
+ | ?port_qual | ?reference_qual | ?unknown_qual | {_, _}.
+
+%%-----------------------------------------------------------------------------
+%% The type representation
+%%
+
+-define(any, any).
+-define(none, none).
+-define(unit, unit).
+%% Generic constructor - elements can be many things depending on the tag.
+-record(c, {tag :: tag(),
+ elements = [] :: term(),
+ qualifier = ?unknown_qual :: qual()}).
+
+-opaque erl_type() :: ?any | ?none | ?unit | #c{}.
+
+%%-----------------------------------------------------------------------------
+%% Auxiliary types and convenient macros
+%%
+
+-type parse_form() :: {atom(), _, _} | {atom(), _, _, _}. %% XXX: Temporarily
+-type rng_elem() :: 'pos_inf' | 'neg_inf' | integer().
+
+-record(int_set, {set :: [integer()]}).
+-record(int_rng, {from :: rng_elem(), to :: rng_elem()}).
+-record(opaque, {mod :: module(), name :: atom(),
+ args = [] :: [erl_type()], struct :: erl_type()}).
+-record(remote, {mod:: module(), name :: atom(), args = [] :: [erl_type()]}).
+
+-define(atom(Set), #c{tag=?atom_tag, elements=Set}).
+-define(bitstr(Unit, Base), #c{tag=?binary_tag, elements=[Unit,Base]}).
+-define(float, ?number(?any, ?float_qual)).
+-define(function(Domain, Range), #c{tag=?function_tag,
+ elements=[Domain, Range]}).
+-define(identifier(Types), #c{tag=?identifier_tag, elements=Types}).
+-define(integer(Types), ?number(Types, ?integer_qual)).
+-define(int_range(From, To), ?integer(#int_rng{from=From, to=To})).
+-define(int_set(Set), ?integer(#int_set{set=Set})).
+-define(list(Types, Term, Size), #c{tag=?list_tag, elements=[Types,Term],
+ qualifier=Size}).
+-define(nil, #c{tag=?nil_tag}).
+-define(nonempty_list(Types, Term),?list(Types, Term, ?nonempty_qual)).
+-define(number(Set, Qualifier), #c{tag=?number_tag, elements=Set,
+ qualifier=Qualifier}.
+-define(opaque(Optypes), #c{tag=?opaque_tag, elements=Optypes}).
+-define(product(Types), #c{tag=?product_tag, elements=Types}).
+-define(remote(RemTypes), #c{tag=?remote_tag, elements=RemTypes}).
+-define(tuple(Types, Arity, Qual), #c{tag=?tuple_tag, elements=Types,
+ qualifier={Arity, Qual}}).
+-define(tuple_set(Tuples), #c{tag=?tuple_set_tag, elements=Tuples}).
+-define(var(Id), #c{tag=?var_tag, elements=Id}).
+
+-define(matchstate(P, Slots), #c{tag=?matchstate_tag, elements=[P,Slots]}).
+-define(any_matchstate, ?matchstate(t_bitstr(), ?any)).
+
+-define(byte, ?int_range(0, ?MAX_BYTE)).
+-define(char, ?int_range(0, ?MAX_CHAR)).
+-define(integer_pos, ?int_range(1, pos_inf)).
+-define(integer_non_neg, ?int_range(0, pos_inf)).
+-define(integer_neg, ?int_range(neg_inf, -1)).
+
+%%-----------------------------------------------------------------------------
+%% Unions
+%%
+
+-define(union(List), #c{tag=?union_tag, elements=[_,_,_,_,_,_,_,_,_,_]=List}).
+
+-define(atom_union(T), ?union([T,?none,?none,?none,?none,?none,?none,?none,?none,?none])).
+-define(bitstr_union(T), ?union([?none,T,?none,?none,?none,?none,?none,?none,?none,?none])).
+-define(function_union(T), ?union([?none,?none,T,?none,?none,?none,?none,?none,?none,?none])).
+-define(identifier_union(T), ?union([?none,?none,?none,T,?none,?none,?none,?none,?none,?none])).
+-define(list_union(T), ?union([?none,?none,?none,?none,T,?none,?none,?none,?none,?none])).
+-define(number_union(T), ?union([?none,?none,?none,?none,?none,T,?none,?none,?none,?none])).
+-define(tuple_union(T), ?union([?none,?none,?none,?none,?none,?none,T,?none,?none,?none])).
+-define(matchstate_union(T), ?union([?none,?none,?none,?none,?none,?none,?none,T,?none,?none])).
+-define(opaque_union(T), ?union([?none,?none,?none,?none,?none,?none,?none,?none,T,?none])).
+-define(remote_union(T), ?union([?none,?none,?none,?none,?none,?none,?none,?none,?none,T])).
+-define(integer_union(T), ?number_union(T)).
+-define(float_union(T), ?number_union(T)).
+-define(nil_union(T), ?list_union(T)).
+
+
+%%=============================================================================
+%%
+%% Primitive operations such as type construction and type tests
+%%
+%%=============================================================================
+
+%%-----------------------------------------------------------------------------
+%% Top and bottom
+%%
+
+-spec t_any() -> erl_type().
+
+t_any() ->
+ ?any.
+
+-spec t_is_any(erl_type()) -> boolean().
+
+t_is_any(?any) -> true;
+t_is_any(_) -> false.
+
+-spec t_none() -> erl_type().
+
+t_none() ->
+ ?none.
+
+-spec t_is_none(erl_type()) -> boolean().
+
+t_is_none(?none) -> true;
+t_is_none(_) -> false.
+
+%%-----------------------------------------------------------------------------
+%% Opaque types
+%%
+
+-spec t_opaque(module(), atom(), [_], erl_type()) -> erl_type().
+
+t_opaque(Mod, Name, Args, Struct) ->
+ ?opaque(set_singleton(#opaque{mod=Mod, name=Name, args=Args, struct=Struct})).
+
+-spec t_is_opaque(erl_type()) -> boolean().
+
+t_is_opaque(?opaque(_)) -> true;
+t_is_opaque(_) -> false.
+
+-spec t_has_opaque_subtype(erl_type()) -> boolean().
+
+t_has_opaque_subtype(?union(Ts)) ->
+ lists:any(fun t_is_opaque/1, Ts);
+t_has_opaque_subtype(T) ->
+ t_is_opaque(T).
+
+-spec t_opaque_structure(erl_type()) -> erl_type().
+
+t_opaque_structure(?opaque(Elements)) ->
+ case ordsets:size(Elements) of
+ 1 ->
+ [#opaque{struct = Struct}] = ordsets:to_list(Elements),
+ Struct;
+ _ -> throw({error, "Unexpected multiple opaque types"})
+ end.
+
+-spec t_opaque_module(erl_type()) -> module().
+
+t_opaque_module(?opaque(Elements)) ->
+ case ordsets:size(Elements) of
+ 1 ->
+ [#opaque{mod=Module}] = ordsets:to_list(Elements),
+ Module;
+ _ -> throw({error, "Unexpected multiple opaque types"})
+ end.
+
+%% This only makes sense if we know that Type matches Opaque
+-spec t_opaque_matching_structure(erl_type(), erl_type()) -> erl_type().
+
+t_opaque_matching_structure(Type, Opaque) ->
+ OpaqueStruct = t_opaque_structure(Opaque),
+ case OpaqueStruct of
+ ?union(L1) ->
+ case Type of
+ ?union(_L2) -> OpaqueStruct;
+ _OtherType -> t_opaque_matching_structure_list(Type, L1)
+ end;
+ ?tuple_set(_Set1) = TupleSet ->
+ case Type of
+ ?tuple_set(_Set2) -> OpaqueStruct;
+ _ -> t_opaque_matching_structure_list(Type, t_tuple_subtypes(TupleSet))
+ end;
+ _Other -> OpaqueStruct
+ end.
+
+t_opaque_matching_structure_list(Type, List) ->
+ NewList = [t_inf(Element, Type) || Element <- List],
+ Results = [NotNone || NotNone <- NewList, NotNone =/= ?none],
+ case Results of
+ [] -> ?none;
+ [First|_] -> First
+ end.
+
+-spec t_contains_opaque(erl_type()) -> boolean().
+
+t_contains_opaque(?any) -> false;
+t_contains_opaque(?none) -> false;
+t_contains_opaque(?unit) -> false;
+t_contains_opaque(?atom(_Set)) -> false;
+t_contains_opaque(?bitstr(_Unit, _Base)) -> false;
+t_contains_opaque(?float) -> false;
+t_contains_opaque(?function(Domain, Range)) ->
+ t_contains_opaque(Domain) orelse t_contains_opaque(Range);
+t_contains_opaque(?identifier(_Types)) -> false;
+t_contains_opaque(?integer(_Types)) -> false;
+t_contains_opaque(?int_range(_From, _To)) -> false;
+t_contains_opaque(?int_set(_Set)) -> false;
+t_contains_opaque(?list(Type, _, _)) -> t_contains_opaque(Type);
+t_contains_opaque(?matchstate(_P, _Slots)) -> false;
+t_contains_opaque(?nil) -> false;
+t_contains_opaque(?number(_Set, _Tag)) -> false;
+t_contains_opaque(?opaque(_)) -> true;
+t_contains_opaque(?product(Types)) -> list_contains_opaque(Types);
+t_contains_opaque(?tuple(?any, _, _)) -> false;
+t_contains_opaque(?tuple(Types, _, _)) -> list_contains_opaque(Types);
+t_contains_opaque(?tuple_set(_Set) = T) ->
+ list_contains_opaque(t_tuple_subtypes(T));
+t_contains_opaque(?union(List)) -> list_contains_opaque(List);
+t_contains_opaque(?var(_Id)) -> false.
+
+-spec list_contains_opaque([erl_type()]) -> boolean().
+
+list_contains_opaque(List) ->
+ lists:any(fun t_contains_opaque/1, List).
+
+%% t_find_opaque_mismatch/2 of two types should only be used if their
+%% t_inf is t_none() due to some opaque type violation.
+%%
+%% The first argument of the function is the pattern and its second
+%% argument the type we are matching against the pattern.
+
+-spec t_find_opaque_mismatch(erl_type(), erl_type()) -> 'error' | {'ok', erl_type(), erl_type()}.
+
+t_find_opaque_mismatch(T1, T2) ->
+ t_find_opaque_mismatch(T1, T2, T2).
+
+t_find_opaque_mismatch(?any, _Type, _TopType) -> error;
+t_find_opaque_mismatch(?none, _Type, _TopType) -> error;
+t_find_opaque_mismatch(?list(T1, _, _), ?list(T2, _, _), TopType) ->
+ t_find_opaque_mismatch(T1, T2, TopType);
+t_find_opaque_mismatch(_T1, ?opaque(_) = T2, TopType) -> {ok, TopType, T2};
+t_find_opaque_mismatch(?product(T1), ?product(T2), TopType) ->
+ t_find_opaque_mismatch_ordlists(T1, T2, TopType);
+t_find_opaque_mismatch(?tuple(T1, Arity, _), ?tuple(T2, Arity, _), TopType) ->
+ t_find_opaque_mismatch_ordlists(T1, T2, TopType);
+t_find_opaque_mismatch(?tuple(_, _, _) = T1, ?tuple_set(_) = T2, TopType) ->
+ Tuples1 = t_tuple_subtypes(T1),
+ Tuples2 = t_tuple_subtypes(T2),
+ t_find_opaque_mismatch_lists(Tuples1, Tuples2, TopType);
+t_find_opaque_mismatch(T1, ?union(U2), TopType) ->
+ t_find_opaque_mismatch_lists([T1], U2, TopType);
+t_find_opaque_mismatch(_T1, _T2, _TopType) -> error.
+
+t_find_opaque_mismatch_ordlists(L1, L2, TopType) ->
+ List = lists:zipwith(fun(T1, T2) ->
+ t_find_opaque_mismatch(T1, T2, TopType)
+ end, L1, L2),
+ t_find_opaque_mismatch_list(List).
+
+t_find_opaque_mismatch_lists(L1, L2, _TopType) ->
+ List = [t_find_opaque_mismatch(T1, T2, T2) || T1 <- L1, T2 <- L2],
+ t_find_opaque_mismatch_list(List).
+
+t_find_opaque_mismatch_list([]) -> error;
+t_find_opaque_mismatch_list([H|T]) ->
+ case H of
+ {ok, _T1, _T2} -> H;
+ error -> t_find_opaque_mismatch_list(T)
+ end.
+
+-spec t_opaque_from_records(dict()) -> [erl_type()].
+
+t_opaque_from_records(RecDict) ->
+ OpaqueRecDict =
+ dict:filter(fun(Key, _Value) ->
+ case Key of
+ {opaque, _Name} -> true;
+ _ -> false
+ end
+ end, RecDict),
+ OpaqueTypeDict =
+ dict:map(fun({opaque, Name}, {Module, Type, ArgNames}) ->
+ case ArgNames of
+ [] ->
+ t_opaque(Module, Name, [], t_from_form(Type, RecDict));
+ _ ->
+ throw({error,"Polymorphic opaque types not supported yet"})
+ end
+ end, OpaqueRecDict),
+ [OpaqueType || {_Key, OpaqueType} <- dict:to_list(OpaqueTypeDict)].
+
+-spec t_opaque_match_atom(erl_type(), [erl_type()]) -> [erl_type()].
+
+t_opaque_match_atom(?atom(_) = Atom, Opaques) ->
+ case t_atom_vals(Atom) of
+ unknown -> [];
+ _ -> [O || O <- Opaques, t_inf(Atom, O, opaque) =/= ?none,
+ t_opaque_atom_vals(t_opaque_structure(O)) =/= unknown]
+ end;
+t_opaque_match_atom(_, _) -> [].
+
+-spec t_opaque_atom_vals(erl_type()) -> 'unknown' | [atom(),...].
+
+t_opaque_atom_vals(OpaqueStruct) ->
+ case OpaqueStruct of
+ ?atom(_) -> t_atom_vals(OpaqueStruct);
+ ?union([Atom,_,_,_,_,_,_,_,_,_]) -> t_atom_vals(Atom);
+ _ -> unknown
+ end.
+
+-spec t_opaque_match_record(erl_type(), [erl_type()]) -> [erl_type()].
+
+t_opaque_match_record(?tuple([?atom(_) = Tag|_Fields], _, _) = Rec, Opaques) ->
+ [O || O <- Opaques, t_inf(Rec, O, opaque) =/= ?none,
+ lists:member(Tag, t_opaque_tuple_tags(t_opaque_structure(O)))];
+t_opaque_match_record(_, _) -> [].
+
+-spec t_opaque_tuple_tags(erl_type()) -> [erl_type()].
+
+t_opaque_tuple_tags(OpaqueStruct) ->
+ case OpaqueStruct of
+ ?tuple([?atom(_) = Tag|_Fields], _, _) -> [Tag];
+ ?tuple_set(_) = TupleSet ->
+ Tuples = t_tuple_subtypes(TupleSet),
+ lists:flatten([t_opaque_tuple_tags(T) || T <- Tuples]);
+ ?union([_,_,_,_,_,_,Tuples,_,_,_]) -> t_opaque_tuple_tags(Tuples);
+ _ -> []
+ end.
+
+%% Decompose opaque instances of type arg2 to structured types, in arg1
+-spec t_struct_from_opaque(erl_type(), erl_type()) -> erl_type().
+
+t_struct_from_opaque(?function(Domain, Range), Opaque) ->
+ ?function(t_struct_from_opaque(Domain, Opaque),
+ t_struct_from_opaque(Range, Opaque));
+t_struct_from_opaque(?list(Types, Term, Size), Opaque) ->
+ ?list(t_struct_from_opaque(Types, Opaque), Term, Size);
+t_struct_from_opaque(?opaque(_) = T, Opaque) ->
+ case T =:= Opaque of
+ true -> t_opaque_structure(T);
+ false -> T
+ end;
+t_struct_from_opaque(?product(Types), Opaque) ->
+ ?product(list_struct_from_opaque(Types, Opaque));
+t_struct_from_opaque(?tuple(?any, _, _) = T, _Opaque) -> T;
+t_struct_from_opaque(?tuple(Types, Arity, Tag), Opaque) ->
+ ?tuple(list_struct_from_opaque(Types, Opaque), Arity, Tag);
+t_struct_from_opaque(?tuple_set(Set), Opaque) ->
+ NewSet = [{Sz, [t_struct_from_opaque(T, Opaque) || T <- Tuples]}
+ || {Sz, Tuples} <- Set],
+ ?tuple_set(NewSet);
+t_struct_from_opaque(?union(List), Opaque) ->
+ t_sup(list_struct_from_opaque(List, Opaque));
+t_struct_from_opaque(Type, _Opaque) -> Type.
+
+list_struct_from_opaque(Types, Opaque) ->
+ [t_struct_from_opaque(Type, Opaque) || Type <- Types].
+
+-spec module_builtin_opaques(module()) -> [erl_type()].
+
+module_builtin_opaques(Module) ->
+ [O || O <- all_opaque_builtins(), t_opaque_module(O) =:= Module].
+
+%%-----------------------------------------------------------------------------
+%% Remote types
+%% These types are used for preprocessing they should never reach the analysis stage
+
+-spec t_remote(module(), atom(), [_]) -> erl_type().
+
+t_remote(Mod, Name, Args) ->
+ ?remote(set_singleton(#remote{mod=Mod, name=Name, args=Args})).
+
+-spec t_is_remote(erl_type()) -> boolean().
+
+t_is_remote(?remote(_)) -> true;
+t_is_remote(_) -> false.
+
+-spec t_solve_remote(erl_type(), dict()) -> erl_type().
+
+t_solve_remote(Type , Records) ->
+ t_solve_remote(Type, Records, ordsets:new()).
+
+t_solve_remote(?function(Domain, Range), R, C) ->
+ ?function(t_solve_remote(Domain, R, C), t_solve_remote(Range, R, C));
+t_solve_remote(?list(Types, Term, Size), R, C) ->
+ ?list(t_solve_remote(Types, R, C), Term, Size);
+t_solve_remote(?product(Types), R, C) ->
+ ?product(list_solve_remote(Types, R, C));
+t_solve_remote(?opaque(Set), R, C) ->
+ List = ordsets:to_list(Set),
+ NewList = [Remote#opaque{struct = t_solve_remote(Struct, R, C)}
+ || Remote = #opaque{struct = Struct} <- List],
+ ?opaque(ordsets:from_list(NewList));
+t_solve_remote(?tuple(?any, _, _) = T, _R, _C) -> T;
+t_solve_remote(?tuple(Types, Arity, Tag), R, C) ->
+ ?tuple(list_solve_remote(Types, R, C), Arity, Tag);
+t_solve_remote(?tuple_set(Set), R, C) ->
+ NewSet = [{Sz, [t_solve_remote(T, R, C) || T <- Tuples]} || {Sz, Tuples} <- Set],
+ ?tuple_set(NewSet);
+t_solve_remote(?remote(Set), R, C) ->
+ Cycle = ordsets:intersection(Set, C),
+ case ordsets:size(Cycle) of
+ 0 -> ok;
+ _ ->
+ CycleMsg = "Cycle detected while processing remote types: " ++
+ t_to_string(?remote(C), dict:new()),
+ throw({error, CycleMsg})
+ end,
+ NewCycle = ordsets:union(C, Set),
+ TypeFun =
+ fun(#remote{mod = RemoteModule, name = Name, args = Args}) ->
+ case dict:find(RemoteModule, R) of
+ error ->
+ Msg = io_lib:format("Cannot locate module ~w to "
+ "resolve the remote type: ~w:~w()~n",
+ [RemoteModule, RemoteModule, Name]),
+ throw({error, Msg});
+ {ok, RemoteDict} ->
+ case lookup_type(Name, RemoteDict) of
+ {type, {_TypeMod, Type, ArgNames}} when length(Args) =:= length(ArgNames) ->
+ List = lists:zip(ArgNames, Args),
+ TmpVardict = dict:from_list(List),
+ NewType = t_from_form(Type, RemoteDict, TmpVardict),
+ t_solve_remote(NewType, R, NewCycle);
+ {opaque, {OpModule, Type, ArgNames}} when length(Args) =:= length(ArgNames) ->
+ List = lists:zip(ArgNames, Args),
+ TmpVardict = dict:from_list(List),
+ Rep = t_from_form(Type, RemoteDict, TmpVardict),
+ NewRep = t_solve_remote(Rep, R, NewCycle),
+ t_from_form({opaque, -1, Name, {OpModule, Args, NewRep}},
+ RemoteDict, TmpVardict);
+ {type, _} ->
+ Msg = io_lib:format("Unknown remote type ~w\n", [Name]),
+ throw({error, Msg});
+ {opaque, _} ->
+ Msg = io_lib:format("Unknown remote opaque type ~w\n", [Name]),
+ throw({error, Msg});
+ error ->
+ Msg = io_lib:format("Unable to find remote type ~w:~w()\n",
+ [RemoteModule, Name]),
+ throw({error, Msg})
+ end
+ end
+ end,
+ RemoteList = ordsets:to_list(Set),
+ t_sup([TypeFun(RemoteType) || RemoteType <- RemoteList]);
+t_solve_remote(?union(List), R, C) ->
+ t_sup(list_solve_remote(List, R, C));
+t_solve_remote(T, _R, _C) -> T.
+
+list_solve_remote(Types, R, C) ->
+ [t_solve_remote(Type, R, C) || Type <- Types].
+
+%%-----------------------------------------------------------------------------
+%% Unit type. Signals non termination.
+%%
+
+-spec t_unit() -> erl_type().
+
+t_unit() ->
+ ?unit.
+
+-spec t_is_unit(erl_type()) -> boolean().
+
+t_is_unit(?unit) -> true;
+t_is_unit(_) -> false.
+
+-spec t_is_none_or_unit(erl_type()) -> boolean().
+
+t_is_none_or_unit(?none) -> true;
+t_is_none_or_unit(?unit) -> true;
+t_is_none_or_unit(_) -> false.
+
+%%-----------------------------------------------------------------------------
+%% Atoms and the derived type bool
+%%
+
+-spec t_atom() -> erl_type().
+
+t_atom() ->
+ ?atom(?any).
+
+-spec t_atom(atom()) -> erl_type().
+
+t_atom(A) when is_atom(A) ->
+ ?atom(set_singleton(A)).
+
+-spec t_atoms([atom()]) -> erl_type().
+
+t_atoms(List) when is_list(List) ->
+ t_sup([t_atom(A) || A <- List]).
+
+-spec t_atom_vals(erl_type()) -> 'unknown' | [atom(),...].
+
+t_atom_vals(?atom(?any)) -> unknown;
+t_atom_vals(?atom(Set)) -> set_to_list(Set);
+t_atom_vals(Other) ->
+ ?atom(_) = Atm = t_inf(t_atom(), Other),
+ t_atom_vals(Atm).
+
+-spec t_is_atom(erl_type()) -> boolean().
+
+t_is_atom(?atom(_)) -> true;
+t_is_atom(_) -> false.
+
+-spec t_is_atom(atom(), erl_type()) -> boolean().
+
+t_is_atom(Atom, ?atom(?any)) when is_atom(Atom) -> false;
+t_is_atom(Atom, ?atom(Set)) when is_atom(Atom) -> set_is_singleton(Atom, Set);
+t_is_atom(Atom, _) when is_atom(Atom) -> false.
+
+%%------------------------------------
+
+-spec t_boolean() -> erl_type().
+
+t_boolean() ->
+ ?atom(set_from_list([false, true])).
+
+-spec t_is_boolean(erl_type()) -> boolean().
+
+t_is_boolean(?atom(?any)) -> false;
+t_is_boolean(?atom(Set)) ->
+ case set_size(Set) of
+ 1 -> set_is_element(true, Set) orelse set_is_element(false, Set);
+ 2 -> set_is_element(true, Set) andalso set_is_element(false, Set);
+ N when is_integer(N), N > 2 -> false
+ end;
+t_is_boolean(_) -> false.
+
+%%-----------------------------------------------------------------------------
+%% Binaries
+%%
+
+-spec t_binary() -> erl_type().
+
+t_binary() ->
+ ?bitstr(8, 0).
+
+-spec t_is_binary(erl_type()) -> boolean().
+
+t_is_binary(?bitstr(U, B)) ->
+ ((U rem 8) =:= 0) andalso ((B rem 8) =:= 0);
+t_is_binary(_) -> false.
+
+%%-----------------------------------------------------------------------------
+%% Bitstrings
+%%
+
+-spec t_bitstr() -> erl_type().
+
+t_bitstr() ->
+ ?bitstr(1, 0).
+
+-spec t_bitstr(non_neg_integer(), non_neg_integer()) -> erl_type().
+
+t_bitstr(U, B) ->
+ NewB =
+ if
+ U =:= 0 -> B;
+ B >= (U * (?UNIT_MULTIPLIER + 1)) ->
+ (B rem U) + U * ?UNIT_MULTIPLIER;
+ true ->
+ B
+ end,
+ ?bitstr(U, NewB).
+
+-spec t_bitstr_unit(erl_type()) -> non_neg_integer().
+
+t_bitstr_unit(?bitstr(U, _)) -> U.
+
+-spec t_bitstr_base(erl_type()) -> non_neg_integer().
+
+t_bitstr_base(?bitstr(_, B)) -> B.
+
+-spec t_bitstr_concat([erl_type()]) -> erl_type().
+
+t_bitstr_concat(List) ->
+ t_bitstr_concat_1(List, t_bitstr(0, 0)).
+
+t_bitstr_concat_1([T|Left], Acc) ->
+ t_bitstr_concat_1(Left, t_bitstr_concat(Acc, T));
+t_bitstr_concat_1([], Acc) ->
+ Acc.
+
+-spec t_bitstr_concat(erl_type(), erl_type()) -> erl_type().
+
+t_bitstr_concat(T1, T2) ->
+ T1p = t_inf(t_bitstr(), T1),
+ T2p = t_inf(t_bitstr(), T2),
+ bitstr_concat(T1p, T2p).
+
+-spec t_bitstr_match(erl_type(), erl_type()) -> erl_type().
+
+t_bitstr_match(T1, T2) ->
+ T1p = t_inf(t_bitstr(), T1),
+ T2p = t_inf(t_bitstr(), T2),
+ bitstr_match(T1p, T2p).
+
+-spec t_is_bitstr(erl_type()) -> boolean().
+
+t_is_bitstr(?bitstr(_, _)) -> true;
+t_is_bitstr(_) -> false.
+
+%%-----------------------------------------------------------------------------
+%% Matchstates
+%%
+
+-spec t_matchstate() -> erl_type().
+
+t_matchstate() ->
+ ?any_matchstate.
+
+-spec t_matchstate(erl_type(), non_neg_integer()) -> erl_type().
+
+t_matchstate(Init, 0) ->
+ ?matchstate(Init, Init);
+t_matchstate(Init, Max) when is_integer(Max) ->
+ Slots = [Init|[?none || _ <- lists:seq(1, Max)]],
+ ?matchstate(Init, t_product(Slots)).
+
+-spec t_is_matchstate(erl_type()) -> boolean().
+
+t_is_matchstate(?matchstate(_, _)) -> true;
+t_is_matchstate(_) -> false.
+
+-spec t_matchstate_present(erl_type()) -> erl_type().
+
+t_matchstate_present(Type) ->
+ case t_inf(t_matchstate(), Type) of
+ ?matchstate(P, _) -> P;
+ _ -> ?none
+ end.
+
+-spec t_matchstate_slot(erl_type(), non_neg_integer()) -> erl_type().
+
+t_matchstate_slot(Type, Slot) ->
+ RealSlot = Slot + 1,
+ case t_inf(t_matchstate(), Type) of
+ ?matchstate(_, ?any) -> ?any;
+ ?matchstate(_, ?product(Vals)) when length(Vals) >= RealSlot ->
+ lists:nth(RealSlot, Vals);
+ ?matchstate(_, ?product(_)) ->
+ ?none;
+ ?matchstate(_, SlotType) when RealSlot =:= 1 ->
+ SlotType;
+ _ ->
+ ?none
+ end.
+
+-spec t_matchstate_slots(erl_type()) -> erl_type().
+
+t_matchstate_slots(?matchstate(_, Slots)) ->
+ Slots.
+
+-spec t_matchstate_update_present(erl_type(), erl_type()) -> erl_type().
+
+t_matchstate_update_present(New, Type) ->
+ case t_inf(t_matchstate(), Type) of
+ ?matchstate(_, Slots) ->
+ ?matchstate(New, Slots);
+ _ -> ?none
+ end.
+
+-spec t_matchstate_update_slot(erl_type(), erl_type(), non_neg_integer()) -> erl_type().
+
+t_matchstate_update_slot(New, Type, Slot) ->
+ RealSlot = Slot + 1,
+ case t_inf(t_matchstate(), Type) of
+ ?matchstate(Pres, Slots) ->
+ NewSlots =
+ case Slots of
+ ?any ->
+ ?any;
+ ?product(Vals) when length(Vals) >= RealSlot ->
+ NewTuple = setelement(RealSlot, list_to_tuple(Vals), New),
+ NewVals = tuple_to_list(NewTuple),
+ ?product(NewVals);
+ ?product(_) ->
+ ?none;
+ _ when RealSlot =:= 1 ->
+ New;
+ _ ->
+ ?none
+ end,
+ ?matchstate(Pres, NewSlots);
+ _ ->
+ ?none
+ end.
+
+%%-----------------------------------------------------------------------------
+%% Functions
+%%
+
+-spec t_fun() -> erl_type().
+
+t_fun() ->
+ ?function(?any, ?any).
+
+-spec t_fun(erl_type()) -> erl_type().
+
+t_fun(Range) ->
+ ?function(?any, Range).
+
+-spec t_fun([erl_type()] | arity(), erl_type()) -> erl_type().
+
+t_fun(Domain, Range) when is_list(Domain) ->
+ ?function(?product(Domain), Range);
+t_fun(Arity, Range) when is_integer(Arity), 0 =< Arity, Arity =< 255 ->
+ ?function(?product(lists:duplicate(Arity, ?any)), Range).
+
+-spec t_fun_args(erl_type()) -> 'unknown' | [erl_type()].
+
+t_fun_args(?function(?any, _)) ->
+ unknown;
+t_fun_args(?function(?product(Domain), _)) when is_list(Domain) ->
+ Domain.
+
+-spec t_fun_arity(erl_type()) -> 'unknown' | non_neg_integer().
+
+t_fun_arity(?function(?any, _)) ->
+ unknown;
+t_fun_arity(?function(?product(Domain), _)) ->
+ length(Domain).
+
+-spec t_fun_range(erl_type()) -> erl_type().
+
+t_fun_range(?function(_, Range)) ->
+ Range.
+
+-spec t_is_fun(erl_type()) -> boolean().
+
+t_is_fun(?function(_, _)) -> true;
+t_is_fun(_) -> false.
+
+%%-----------------------------------------------------------------------------
+%% Identifiers. Includes ports, pids and refs.
+%%
+
+-spec t_identifier() -> erl_type().
+
+t_identifier() ->
+ ?identifier(?any).
+
+-ifdef(DO_ERL_TYPES_TEST).
+-spec t_is_identifier(erl_type()) -> erl_type().
+
+t_is_identifier(?identifier(_)) -> true;
+t_is_identifier(_) -> false.
+-endif.
+
+%%------------------------------------
+
+-spec t_port() -> erl_type().
+
+t_port() ->
+ ?identifier(set_singleton(?port_qual)).
+
+-spec t_is_port(erl_type()) -> boolean().
+
+t_is_port(?identifier(?any)) -> false;
+t_is_port(?identifier(Set)) -> set_is_singleton(?port_qual, Set);
+t_is_port(_) -> false.
+
+%%------------------------------------
+
+-spec t_pid() -> erl_type().
+
+t_pid() ->
+ ?identifier(set_singleton(?pid_qual)).
+
+-spec t_is_pid(erl_type()) -> boolean().
+
+t_is_pid(?identifier(?any)) -> false;
+t_is_pid(?identifier(Set)) -> set_is_singleton(?pid_qual, Set);
+t_is_pid(_) -> false.
+
+%%------------------------------------
+
+-spec t_reference() -> erl_type().
+
+t_reference() ->
+ ?identifier(set_singleton(?reference_qual)).
+
+-spec t_is_reference(erl_type()) -> boolean().
+
+t_is_reference(?identifier(?any)) -> false;
+t_is_reference(?identifier(Set)) -> set_is_singleton(?reference_qual, Set);
+t_is_reference(_) -> false.
+
+%%-----------------------------------------------------------------------------
+%% Numbers are divided into floats, integers, chars and bytes.
+%%
+
+-spec t_number() -> erl_type().
+
+t_number() ->
+ ?number(?any, ?unknown_qual).
+
+-spec t_number(integer()) -> erl_type().
+
+t_number(X) when is_integer(X) ->
+ t_integer(X).
+
+-spec t_is_number(erl_type()) -> boolean().
+
+t_is_number(?number(_, _)) -> true;
+t_is_number(_) -> false.
+
+%% Currently, the type system collapses all floats to ?float and does
+%% not keep any information about their values. As a result, the list
+%% that this function returns contains only integers.
+-spec t_number_vals(erl_type()) -> 'unknown' | [integer(),...].
+
+t_number_vals(?int_set(?any)) -> unknown;
+t_number_vals(?int_set(Set)) -> set_to_list(Set);
+t_number_vals(?number(_, _)) -> unknown;
+t_number_vals(Other) ->
+ Inf = t_inf(Other, t_number()),
+ false = t_is_none(Inf), % sanity check
+ t_number_vals(Inf).
+
+%%------------------------------------
+
+-spec t_float() -> erl_type().
+
+t_float() ->
+ ?float.
+
+-spec t_is_float(erl_type()) -> boolean().
+
+t_is_float(?float) -> true;
+t_is_float(_) -> false.
+
+%%------------------------------------
+
+-spec t_integer() -> erl_type().
+
+t_integer() ->
+ ?integer(?any).
+
+-spec t_integer(integer()) -> erl_type().
+
+t_integer(I) when is_integer(I) ->
+ ?int_set(set_singleton(I)).
+
+-spec t_integers([integer()]) -> erl_type().
+
+t_integers(List) when is_list(List) ->
+ t_sup([t_integer(I) || I <- List]).
+
+-spec t_is_integer(erl_type()) -> boolean().
+
+t_is_integer(?integer(_)) -> true;
+t_is_integer(_) -> false.
+
+%%------------------------------------
+
+-spec t_byte() -> erl_type().
+
+t_byte() ->
+ ?byte.
+
+-ifdef(DO_ERL_TYPES_TEST).
+-spec t_is_byte(erl_type()) -> boolean().
+
+t_is_byte(?int_range(neg_inf, _)) -> false;
+t_is_byte(?int_range(_, pos_inf)) -> false;
+t_is_byte(?int_range(From, To))
+ when is_integer(From), From >= 0, is_integer(To), To =< ?MAX_BYTE -> true;
+t_is_byte(?int_set(Set)) ->
+ (set_min(Set) >= 0) andalso (set_max(Set) =< ?MAX_BYTE);
+t_is_byte(_) -> false.
+-endif.
+
+%%------------------------------------
+
+-spec t_char() -> erl_type().
+
+t_char() ->
+ ?char.
+
+-spec t_is_char(erl_type()) -> boolean().
+
+t_is_char(?int_range(neg_inf, _)) -> false;
+t_is_char(?int_range(_, pos_inf)) -> false;
+t_is_char(?int_range(From, To))
+ when is_integer(From), From >= 0, is_integer(To), To =< ?MAX_CHAR -> true;
+t_is_char(?int_set(Set)) ->
+ (set_min(Set) >= 0) andalso (set_max(Set) =< ?MAX_CHAR);
+t_is_char(_) -> false.
+
+%%-----------------------------------------------------------------------------
+%% Lists
+%%
+
+-spec t_cons() -> erl_type().
+
+t_cons() ->
+ ?nonempty_list(?any, ?any).
+
+%% Note that if the tail argument can be a list, we must collapse the
+%% content of the list to include both the content of the tail list
+%% and the head of the cons. If for example the tail argument is any()
+%% then there can be any list in the tail and the content of the
+%% returned list must be any().
+
+-spec t_cons(erl_type(), erl_type()) -> erl_type().
+
+t_cons(?none, _) -> ?none;
+t_cons(_, ?none) -> ?none;
+t_cons(?unit, _) -> ?none;
+t_cons(_, ?unit) -> ?none;
+t_cons(Hd, ?nil) ->
+ ?nonempty_list(Hd, ?nil);
+t_cons(Hd, ?list(Contents, Termination, _)) ->
+ ?nonempty_list(t_sup(Contents, Hd), Termination);
+t_cons(Hd, Tail) ->
+ case t_inf(Tail, t_maybe_improper_list()) of
+ ?list(Contents, Termination, _Size) ->
+ %% Collapse the list part of the termination but keep the
+ %% non-list part intact.
+ NewTermination = t_sup(t_subtract(Tail, t_maybe_improper_list()),
+ Termination),
+ ?nonempty_list(t_sup(Hd, Contents), NewTermination);
+ ?nil -> ?nonempty_list(Hd, Tail);
+ ?none -> ?nonempty_list(Hd, Tail);
+ ?unit -> ?none
+ end.
+
+-spec t_is_cons(erl_type()) -> boolean().
+
+t_is_cons(?nonempty_list(_, _)) -> true;
+t_is_cons(_) -> false.
+
+-spec t_cons_hd(erl_type()) -> erl_type().
+
+t_cons_hd(?nonempty_list(Contents, _Termination)) -> Contents.
+
+-spec t_cons_tl(erl_type()) -> erl_type().
+
+t_cons_tl(?nonempty_list(_Contents, Termination) = T) ->
+ t_sup(Termination, T).
+
+-spec t_nil() -> erl_type().
+
+t_nil() ->
+ ?nil.
+
+-spec t_is_nil(erl_type()) -> boolean().
+
+t_is_nil(?nil) -> true;
+t_is_nil(_) -> false.
+
+-spec t_list() -> erl_type().
+
+t_list() ->
+ ?list(?any, ?nil, ?unknown_qual).
+
+-spec t_list(erl_type()) -> erl_type().
+
+t_list(?none) -> ?none;
+t_list(?unit) -> ?none;
+t_list(Contents) ->
+ ?list(Contents, ?nil, ?unknown_qual).
+
+-spec t_list_elements(erl_type()) -> erl_type().
+
+t_list_elements(?list(Contents, _, _)) -> Contents;
+t_list_elements(?nil) -> ?none.
+
+-spec t_list_termination(erl_type()) -> erl_type().
+
+t_list_termination(?nil) -> ?nil;
+t_list_termination(?list(_, Term, _)) -> Term.
+
+-spec t_is_list(erl_type()) -> boolean().
+
+t_is_list(?list(_Contents, ?nil, _)) -> true;
+t_is_list(?nil) -> true;
+t_is_list(_) -> false.
+
+-spec t_nonempty_list() -> erl_type().
+
+t_nonempty_list() ->
+ t_cons(?any, ?nil).
+
+-spec t_nonempty_list(erl_type()) -> erl_type().
+
+t_nonempty_list(Type) ->
+ t_cons(Type, ?nil).
+
+-spec t_nonempty_string() -> erl_type().
+
+t_nonempty_string() ->
+ t_nonempty_list(t_char()).
+
+-spec t_string() -> erl_type().
+
+t_string() ->
+ t_list(t_char()).
+
+-spec t_is_string(erl_type()) -> boolean().
+
+t_is_string(X) ->
+ t_is_list(X) andalso t_is_char(t_list_elements(X)).
+
+-spec t_maybe_improper_list() -> erl_type().
+
+t_maybe_improper_list() ->
+ ?list(?any, ?any, ?unknown_qual).
+
+%% Should only be used if you know what you are doing. See t_cons/2
+-spec t_maybe_improper_list(erl_type(), erl_type()) -> erl_type().
+
+t_maybe_improper_list(_Content, ?unit) -> ?none;
+t_maybe_improper_list(?unit, _Termination) -> ?none;
+t_maybe_improper_list(Content, Termination) ->
+ %% Safety check
+ true = t_is_subtype(t_nil(), Termination),
+ ?list(Content, Termination, ?unknown_qual).
+
+-spec t_is_maybe_improper_list(erl_type()) -> boolean().
+
+t_is_maybe_improper_list(?list(_, _, _)) -> true;
+t_is_maybe_improper_list(?nil) -> true;
+t_is_maybe_improper_list(_) -> false.
+
+%% %% Should only be used if you know what you are doing. See t_cons/2
+%% -spec t_improper_list(erl_type(), erl_type()) -> erl_type().
+%%
+%% t_improper_list(?unit, _Termination) -> ?none;
+%% t_improper_list(_Content, ?unit) -> ?none;
+%% t_improper_list(Content, Termination) ->
+%% %% Safety check
+%% false = t_is_subtype(t_nil(), Termination),
+%% ?list(Content, Termination, ?any).
+
+-spec lift_list_to_pos_empty(erl_type()) -> erl_type().
+
+lift_list_to_pos_empty(?nil) -> ?nil;
+lift_list_to_pos_empty(?list(Content, Termination, _)) ->
+ ?list(Content, Termination, ?unknown_qual).
+
+%%-----------------------------------------------------------------------------
+%% Tuples
+%%
+
+-spec t_tuple() -> erl_type().
+
+t_tuple() ->
+ ?tuple(?any, ?any, ?any).
+
+-spec t_tuple(non_neg_integer() | [erl_type()]) -> erl_type().
+
+t_tuple(N) when is_integer(N) ->
+ ?tuple(lists:duplicate(N, ?any), N, ?any);
+t_tuple(List) ->
+ case any_none_or_unit(List) of
+ true -> t_none();
+ false ->
+ Arity = length(List),
+ case get_tuple_tags(List) of
+ [Tag] -> ?tuple(List, Arity, Tag); %% Tag can also be ?any here
+ TagList ->
+ SortedTagList = lists:sort(TagList),
+ Tuples = [?tuple([T|tl(List)], Arity, T) || T <- SortedTagList],
+ ?tuple_set([{Arity, Tuples}])
+ end
+ end.
+
+-spec get_tuple_tags([erl_type()]) -> [erl_type(),...].
+
+get_tuple_tags([?atom(?any)|_]) -> [?any];
+get_tuple_tags([?atom(Set)|_]) ->
+ case set_size(Set) > ?TUPLE_TAG_LIMIT of
+ true -> [?any];
+ false -> [t_atom(A) || A <- set_to_list(Set)]
+ end;
+get_tuple_tags(_) -> [?any].
+
+%% to be used for a tuple with known types for its arguments (not ?any)
+-spec t_tuple_args(erl_type()) -> [erl_type()].
+
+t_tuple_args(?tuple(Args, _, _)) when is_list(Args) -> Args.
+
+%% to be used for a tuple with a known size (not ?any)
+-spec t_tuple_size(erl_type()) -> non_neg_integer().
+
+t_tuple_size(?tuple(_, Size, _)) when is_integer(Size) -> Size.
+
+-spec t_tuple_sizes(erl_type()) -> 'unknown' | [non_neg_integer(),...].
+
+t_tuple_sizes(?tuple(?any, ?any, ?any)) -> unknown;
+t_tuple_sizes(?tuple(_, Size, _)) when is_integer(Size) -> [Size];
+t_tuple_sizes(?tuple_set(List)) -> [Size || {Size, _} <- List].
+
+-spec t_tuple_subtypes(erl_type()) -> 'unknown' | [erl_type(),...].
+
+t_tuple_subtypes(?tuple(?any, ?any, ?any)) -> unknown;
+t_tuple_subtypes(?tuple(_, _, _) = T) -> [T];
+t_tuple_subtypes(?tuple_set(List)) ->
+ lists:append([Tuples || {_Size, Tuples} <- List]).
+
+-spec t_is_tuple(erl_type()) -> boolean().
+
+t_is_tuple(?tuple(_, _, _)) -> true;
+t_is_tuple(?tuple_set(_)) -> true;
+t_is_tuple(_) -> false.
+
+%%-----------------------------------------------------------------------------
+%% Non-primitive types, including some handy syntactic sugar types
+%%
+
+-spec t_constant() -> erl_type().
+
+t_constant() ->
+ t_sup([t_number(), t_identifier(), t_atom(), t_fun(), t_binary()]).
+
+-spec t_is_constant(erl_type()) -> boolean().
+
+t_is_constant(X) ->
+ t_is_subtype(X, t_constant()).
+
+-spec t_arity() -> erl_type().
+
+t_arity() ->
+ t_from_range(0, 255). % was t_byte().
+
+-spec t_pos_integer() -> erl_type().
+
+t_pos_integer() ->
+ t_from_range(1, pos_inf).
+
+-spec t_non_neg_integer() -> erl_type().
+
+t_non_neg_integer() ->
+ t_from_range(0, pos_inf).
+
+-spec t_is_non_neg_integer(erl_type()) -> boolean().
+
+t_is_non_neg_integer(?integer(_) = T) ->
+ t_is_subtype(T, t_non_neg_integer());
+t_is_non_neg_integer(_) -> false.
+
+-spec t_neg_integer() -> erl_type().
+
+t_neg_integer() ->
+ t_from_range(neg_inf, -1).
+
+-spec t_fixnum() -> erl_type().
+
+t_fixnum() ->
+ t_integer(). % Gross over-approximation
+
+-spec t_pos_fixnum() -> erl_type().
+
+t_pos_fixnum() ->
+ t_pos_integer(). % Gross over-approximation
+
+-spec t_non_neg_fixnum() -> erl_type().
+
+t_non_neg_fixnum() ->
+ t_non_neg_integer(). % Gross over-approximation
+
+-spec t_mfa() -> erl_type().
+
+t_mfa() ->
+ t_tuple([t_atom(), t_atom(), t_arity()]).
+
+-spec t_module() -> erl_type().
+
+t_module() ->
+ t_atom().
+
+-spec t_node() -> erl_type().
+
+t_node() ->
+ t_atom().
+
+-spec t_iodata() -> erl_type().
+
+t_iodata() ->
+ t_sup(t_iolist(), t_binary()).
+
+-spec t_iolist() -> erl_type().
+
+t_iolist() ->
+ t_iolist(1).
+
+-spec t_iolist(non_neg_integer()) -> erl_type().
+
+t_iolist(N) when N > 0 ->
+ t_maybe_improper_list(t_sup([t_iolist(N-1), t_binary(), t_byte()]),
+ t_sup(t_binary(), t_nil()));
+t_iolist(0) ->
+ t_maybe_improper_list(t_any(), t_sup(t_binary(), t_nil())).
+
+-spec t_timeout() -> erl_type().
+
+t_timeout() ->
+ t_sup(t_non_neg_integer(), t_atom('infinity')).
+
+%%-----------------------------------------------------------------------------
+%% Some built-in opaque types
+%%
+
+-spec t_array() -> erl_type().
+
+t_array() ->
+ t_opaque(array, array, [],
+ t_tuple([t_atom('array'),
+ t_non_neg_integer(), t_non_neg_integer(),
+ t_any(), t_any()])).
+
+-spec t_dict() -> erl_type().
+
+t_dict() ->
+ t_opaque(dict, dict, [],
+ t_tuple([t_atom('dict'),
+ t_non_neg_integer(), t_non_neg_integer(),
+ t_non_neg_integer(), t_non_neg_integer(),
+ t_non_neg_integer(), t_non_neg_integer(),
+ t_tuple(), t_tuple()])).
+
+-spec t_digraph() -> erl_type().
+
+t_digraph() ->
+ t_opaque(digraph, digraph, [],
+ t_tuple([t_atom('digraph'),
+ t_sup(t_atom(), t_tid()),
+ t_sup(t_atom(), t_tid()),
+ t_sup(t_atom(), t_tid()),
+ t_boolean()])).
+
+-spec t_gb_set() -> erl_type().
+
+t_gb_set() ->
+ t_opaque(gb_sets, gb_set, [],
+ t_tuple([t_non_neg_integer(), t_sup(t_atom('nil'), t_tuple(3))])).
+
+-spec t_gb_tree() -> erl_type().
+
+t_gb_tree() ->
+ t_opaque(gb_trees, gb_tree, [],
+ t_tuple([t_non_neg_integer(), t_sup(t_atom('nil'), t_tuple(4))])).
+
+-spec t_queue() -> erl_type().
+
+t_queue() ->
+ t_opaque(queue, queue, [], t_tuple([t_list(), t_list()])).
+
+-spec t_set() -> erl_type().
+
+t_set() ->
+ t_opaque(sets, set, [],
+ t_tuple([t_atom('set'), t_non_neg_integer(), t_non_neg_integer(),
+ t_pos_integer(), t_non_neg_integer(), t_non_neg_integer(),
+ t_non_neg_integer(), t_tuple(), t_tuple()])).
+
+-spec t_tid() -> erl_type().
+
+t_tid() ->
+ t_opaque(ets, tid, [], t_integer()).
+
+-spec all_opaque_builtins() -> [erl_type()].
+
+all_opaque_builtins() ->
+ [t_array(), t_dict(), t_digraph(), t_gb_set(),
+ t_gb_tree(), t_queue(), t_set(), t_tid()].
+
+-spec is_opaque_builtin(atom(), atom()) -> boolean().
+
+is_opaque_builtin(array, array) -> true;
+is_opaque_builtin(dict, dict) -> true;
+is_opaque_builtin(digraph, digraph) -> true;
+is_opaque_builtin(gb_sets, gb_set) -> true;
+is_opaque_builtin(gb_trees, gb_tree) -> true;
+is_opaque_builtin(queue, queue) -> true;
+is_opaque_builtin(sets, set) -> true;
+is_opaque_builtin(ets, tid) -> true;
+is_opaque_builtin(_, _) -> false.
+
+%%------------------------------------
+
+%% ?none is allowed in products. A product of size 1 is not a product.
+
+-spec t_product([erl_type()]) -> erl_type().
+
+t_product([T]) -> T;
+t_product(Types) when is_list(Types) ->
+ ?product(Types).
+
+%% This function is intended to be the inverse of the one above.
+%% It should NOT be used with ?any, ?none or ?unit as input argument.
+
+-spec t_to_tlist(erl_type()) -> [erl_type()].
+
+t_to_tlist(?product(Types)) -> Types;
+t_to_tlist(T) when T =/= ?any orelse T =/= ?none orelse T =/= ?unit -> [T].
+
+%%------------------------------------
+
+-spec t_var(atom() | integer()) -> erl_type().
+
+t_var(Atom) when is_atom(Atom) -> ?var(Atom);
+t_var(Int) when is_integer(Int) -> ?var(Int).
+
+-spec t_is_var(erl_type()) -> boolean().
+
+t_is_var(?var(_)) -> true;
+t_is_var(_) -> false.
+
+-spec t_var_name(erl_type()) -> atom() | integer().
+
+t_var_name(?var(Id)) -> Id.
+
+-spec t_has_var(erl_type()) -> boolean().
+
+t_has_var(?var(_)) -> true;
+t_has_var(?function(Domain, Range)) ->
+ t_has_var(Domain) orelse t_has_var(Range);
+t_has_var(?list(Contents, Termination, _)) ->
+ t_has_var(Contents) orelse t_has_var(Termination);
+t_has_var(?product(Types)) -> t_has_var_list(Types);
+t_has_var(?tuple(?any, ?any, ?any)) -> false;
+t_has_var(?tuple(Elements, _, _)) ->
+ t_has_var_list(Elements);
+t_has_var(?tuple_set(_) = T) ->
+ t_has_var_list(t_tuple_subtypes(T));
+%% t_has_var(?union(_) = U) ->
+%% exit(lists:flatten(io_lib:format("Union happens in t_has_var/1 ~p\n",[U])));
+t_has_var(_) -> false.
+
+-spec t_has_var_list([erl_type()]) -> boolean().
+
+t_has_var_list([T|Ts]) ->
+ t_has_var(T) orelse t_has_var_list(Ts);
+t_has_var_list([]) -> false.
+
+-spec t_collect_vars(erl_type()) -> [erl_type()].
+
+t_collect_vars(T) ->
+ t_collect_vars(T, []).
+
+-spec t_collect_vars(erl_type(), [erl_type()]) -> [erl_type()].
+
+t_collect_vars(?var(_) = Var, Acc) ->
+ ordsets:add_element(Var, Acc);
+t_collect_vars(?function(Domain, Range), Acc) ->
+ ordsets:union(t_collect_vars(Domain, Acc), t_collect_vars(Range, []));
+t_collect_vars(?list(Contents, Termination, _), Acc) ->
+ ordsets:union(t_collect_vars(Contents, Acc), t_collect_vars(Termination, []));
+t_collect_vars(?product(Types), Acc) ->
+ lists:foldl(fun(T, TmpAcc) -> t_collect_vars(T, TmpAcc) end, Acc, Types);
+t_collect_vars(?tuple(?any, ?any, ?any), Acc) ->
+ Acc;
+t_collect_vars(?tuple(Types, _, _), Acc) ->
+ lists:foldl(fun(T, TmpAcc) -> t_collect_vars(T, TmpAcc) end, Acc, Types);
+t_collect_vars(?tuple_set(_) = TS, Acc) ->
+ lists:foldl(fun(T, TmpAcc) -> t_collect_vars(T, TmpAcc) end, Acc,
+ t_tuple_subtypes(TS));
+t_collect_vars(_, Acc) ->
+ Acc.
+
+
+%%=============================================================================
+%%
+%% Type construction from Erlang terms.
+%%
+%%=============================================================================
+
+%%-----------------------------------------------------------------------------
+%% Make a type from a term. No type depth is enforced.
+%%
+
+-spec t_from_term(term()) -> erl_type().
+
+t_from_term([H|T]) -> t_cons(t_from_term(H), t_from_term(T));
+t_from_term([]) -> t_nil();
+t_from_term(T) when is_atom(T) -> t_atom(T);
+t_from_term(T) when is_bitstring(T) -> t_bitstr(0, erlang:bit_size(T));
+t_from_term(T) when is_float(T) -> t_float();
+t_from_term(T) when is_function(T) ->
+ {arity, Arity} = erlang:fun_info(T, arity),
+ t_fun(Arity, t_any());
+t_from_term(T) when is_integer(T) -> t_integer(T);
+t_from_term(T) when is_pid(T) -> t_pid();
+t_from_term(T) when is_port(T) -> t_port();
+t_from_term(T) when is_reference(T) -> t_reference();
+t_from_term(T) when is_tuple(T) ->
+ t_tuple([t_from_term(E) || E <- tuple_to_list(T)]).
+
+%%-----------------------------------------------------------------------------
+%% Integer types from a range.
+%%-----------------------------------------------------------------------------
+
+%%-define(USE_UNSAFE_RANGES, true).
+
+-spec t_from_range(rng_elem(), rng_elem()) -> erl_type().
+
+-ifdef(USE_UNSAFE_RANGES).
+
+t_from_range(X, Y) ->
+ t_from_range_unsafe(X, Y).
+
+-else.
+
+t_from_range(neg_inf, pos_inf) -> t_integer();
+t_from_range(neg_inf, Y) when is_integer(Y), Y < 0 -> ?integer_neg;
+t_from_range(neg_inf, Y) when is_integer(Y), Y >= 0 -> t_integer();
+t_from_range(X, pos_inf) when is_integer(X), X >= 1 -> ?integer_pos;
+t_from_range(X, pos_inf) when is_integer(X), X >= 0 -> ?integer_non_neg;
+t_from_range(X, pos_inf) when is_integer(X), X < 0 -> t_integer();
+t_from_range(X, Y) when is_integer(X), is_integer(Y), X > Y -> t_none();
+t_from_range(X, Y) when is_integer(X), is_integer(Y) ->
+ case ((Y - X) < ?SET_LIMIT) of
+ true -> t_integers(lists:seq(X, Y));
+ false ->
+ case X >= 0 of
+ false ->
+ if Y < 0 -> ?integer_neg;
+ true -> t_integer()
+ end;
+ true ->
+ if Y =< ?MAX_BYTE, X >= 1 -> ?int_range(1, ?MAX_BYTE);
+ Y =< ?MAX_BYTE -> t_byte();
+ Y =< ?MAX_CHAR, X >= 1 -> ?int_range(1, ?MAX_CHAR);
+ Y =< ?MAX_CHAR -> t_char();
+ X >= 1 -> ?integer_pos;
+ X >= 0 -> ?integer_non_neg
+ end
+ end
+ end;
+t_from_range(pos_inf, neg_inf) -> t_none().
+
+-endif.
+
+-spec t_from_range_unsafe(rng_elem(), rng_elem()) -> erl_type().
+
+t_from_range_unsafe(neg_inf, pos_inf) -> t_integer();
+t_from_range_unsafe(neg_inf, Y) -> ?int_range(neg_inf, Y);
+t_from_range_unsafe(X, pos_inf) -> ?int_range(X, pos_inf);
+t_from_range_unsafe(X, Y) when is_integer(X), is_integer(Y), X =< Y ->
+ if (Y - X) < ?SET_LIMIT -> t_integers(lists:seq(X, Y));
+ true -> ?int_range(X, Y)
+ end;
+t_from_range_unsafe(X, Y) when is_integer(X), is_integer(Y) -> t_none();
+t_from_range_unsafe(pos_inf, neg_inf) -> t_none().
+
+-spec t_is_fixnum(erl_type()) -> boolean().
+
+t_is_fixnum(?int_range(neg_inf, _)) -> false;
+t_is_fixnum(?int_range(_, pos_inf)) -> false;
+t_is_fixnum(?int_range(From, To)) ->
+ is_fixnum(From) andalso is_fixnum(To);
+t_is_fixnum(?int_set(Set)) ->
+ is_fixnum(set_min(Set)) andalso is_fixnum(set_max(Set));
+t_is_fixnum(_) -> false.
+
+-spec is_fixnum(integer()) -> boolean().
+
+is_fixnum(N) when is_integer(N) ->
+ Bits = ?BITS,
+ (N =< ((1 bsl (Bits - 1)) - 1)) andalso (N >= -(1 bsl (Bits - 1))).
+
+infinity_geq(pos_inf, _) -> true;
+infinity_geq(_, pos_inf) -> false;
+infinity_geq(_, neg_inf) -> true;
+infinity_geq(neg_inf, _) -> false;
+infinity_geq(A, B) -> A >= B.
+
+-spec t_is_bitwidth(erl_type()) -> boolean().
+
+t_is_bitwidth(?int_range(neg_inf, _)) -> false;
+t_is_bitwidth(?int_range(_, pos_inf)) -> false;
+t_is_bitwidth(?int_range(From, To)) ->
+ infinity_geq(From, 0) andalso infinity_geq(?BITS, To);
+t_is_bitwidth(?int_set(Set)) ->
+ infinity_geq(set_min(Set), 0) andalso infinity_geq(?BITS, set_max(Set));
+t_is_bitwidth(_) -> false.
+
+-spec number_min(erl_type()) -> rng_elem().
+
+number_min(?int_range(From, _)) -> From;
+number_min(?int_set(Set)) -> set_min(Set);
+number_min(?number(?any, _Tag)) -> neg_inf.
+
+-spec number_max(erl_type()) -> rng_elem().
+
+number_max(?int_range(_, To)) -> To;
+number_max(?int_set(Set)) -> set_max(Set);
+number_max(?number(?any, _Tag)) -> pos_inf.
+
+%% -spec int_range(rgn_elem(), rng_elem()) -> erl_type().
+%%
+%% int_range(neg_inf, pos_inf) -> t_integer();
+%% int_range(neg_inf, To) -> ?int_range(neg_inf, To);
+%% int_range(From, pos_inf) -> ?int_range(From, pos_inf);
+%% int_range(From, To) when From =< To -> t_from_range(From, To);
+%% int_range(From, To) when To < From -> ?none.
+
+in_range(_, ?int_range(neg_inf, pos_inf)) -> true;
+in_range(X, ?int_range(From, pos_inf)) -> X >= From;
+in_range(X, ?int_range(neg_inf, To)) -> X =< To;
+in_range(X, ?int_range(From, To)) -> (X >= From) andalso (X =< To).
+
+-spec min(rng_elem(), rng_elem()) -> rng_elem().
+
+min(neg_inf, _) -> neg_inf;
+min(_, neg_inf) -> neg_inf;
+min(pos_inf, Y) -> Y;
+min(X, pos_inf) -> X;
+min(X, Y) when X =< Y -> X;
+min(_, Y) -> Y.
+
+-spec max(rng_elem(), rng_elem()) -> rng_elem().
+
+max(neg_inf, Y) -> Y;
+max(X, neg_inf) -> X;
+max(pos_inf, _) -> pos_inf;
+max(_, pos_inf) -> pos_inf;
+max(X, Y) when X =< Y -> Y;
+max(X, _) -> X.
+
+expand_range_from_set(Range = ?int_range(From, To), Set) ->
+ Min = min(set_min(Set), From),
+ Max = max(set_max(Set), To),
+ if From =:= Min, To =:= Max -> Range;
+ true -> t_from_range(Min, Max)
+ end.
+
+%%=============================================================================
+%%
+%% Lattice operations
+%%
+%%=============================================================================
+
+%%-----------------------------------------------------------------------------
+%% Supremum
+%%
+
+-spec t_sup([erl_type()]) -> erl_type().
+
+t_sup([?any|_]) ->
+ ?any;
+t_sup([H1, H2|T]) ->
+ t_sup([t_sup(H1, H2)|T]);
+t_sup([H]) ->
+ subst_all_vars_to_any(H);
+t_sup([]) ->
+ ?none.
+
+-spec t_sup(erl_type(), erl_type()) -> erl_type().
+
+t_sup(?any, _) -> ?any;
+t_sup(_, ?any) -> ?any;
+t_sup(?none, T) -> T;
+t_sup(T, ?none) -> T;
+t_sup(?unit, T) -> T;
+t_sup(T, ?unit) -> T;
+t_sup(T, T) -> subst_all_vars_to_any(T);
+t_sup(?var(_), _) -> ?any;
+t_sup(_, ?var(_)) -> ?any;
+t_sup(?atom(Set1), ?atom(Set2)) ->
+ ?atom(set_union(Set1, Set2));
+t_sup(?bitstr(U1, B1), ?bitstr(U2, B2)) ->
+ t_bitstr(gcd(gcd(U1, U2), abs(B1-B2)), lists:min([B1, B2]));
+t_sup(?function(Domain1, Range1), ?function(Domain2, Range2)) ->
+ %% The domain is either a product or any.
+ ?function(t_sup(Domain1, Domain2), t_sup(Range1, Range2));
+t_sup(?identifier(Set1), ?identifier(Set2)) ->
+ ?identifier(set_union(Set1, Set2));
+t_sup(?opaque(Set1), ?opaque(Set2)) ->
+ ?opaque(set_union_no_limit(Set1, Set2));
+%%Disallow unions with opaque types
+%%t_sup(T1=?opaque(_,_,_), T2) ->
+%% io:format("Debug: t_sup executed with args ~w and ~w~n",[T1, T2]), ?none;
+%%t_sup(T1, T2=?opaque(_,_,_)) ->
+%% io:format("Debug: t_sup executed with args ~w and ~w~n",[T1, T2]), ?none;
+t_sup(?remote(Set1), ?remote(Set2)) ->
+ ?remote(set_union_no_limit(Set1, Set2));
+t_sup(?matchstate(Pres1, Slots1), ?matchstate(Pres2, Slots2)) ->
+ ?matchstate(t_sup(Pres1, Pres2), t_sup(Slots1, Slots2));
+t_sup(?nil, ?nil) -> ?nil;
+t_sup(?nil, ?list(Contents, Termination, _)) ->
+ ?list(Contents, t_sup(?nil, Termination), ?unknown_qual);
+t_sup(?list(Contents, Termination, _), ?nil) ->
+ ?list(Contents, t_sup(?nil, Termination), ?unknown_qual);
+t_sup(?list(Contents1, Termination1, Size1),
+ ?list(Contents2, Termination2, Size2)) ->
+ NewSize =
+ case {Size1, Size2} of
+ {?unknown_qual, ?unknown_qual} -> ?unknown_qual;
+ {?unknown_qual, ?nonempty_qual} -> ?unknown_qual;
+ {?nonempty_qual, ?unknown_qual} -> ?unknown_qual;
+ {?nonempty_qual, ?nonempty_qual} -> ?nonempty_qual
+ end,
+ NewContents = t_sup(Contents1, Contents2),
+ NewTermination = t_sup(Termination1, Termination2),
+ TmpList = t_cons(NewContents, NewTermination),
+ case NewSize of
+ ?nonempty_qual -> TmpList;
+ ?unknown_qual ->
+ ?list(FinalContents, FinalTermination, _) = TmpList,
+ ?list(FinalContents, FinalTermination, ?unknown_qual)
+ end;
+t_sup(?number(_, _), ?number(?any, ?unknown_qual) = T) -> T;
+t_sup(?number(?any, ?unknown_qual) = T, ?number(_, _)) -> T;
+t_sup(?float, ?float) -> ?float;
+t_sup(?float, ?integer(_)) -> t_number();
+t_sup(?integer(_), ?float) -> t_number();
+t_sup(?integer(?any) = T, ?integer(_)) -> T;
+t_sup(?integer(_), ?integer(?any) = T) -> T;
+t_sup(?int_set(Set1), ?int_set(Set2)) ->
+ case set_union(Set1, Set2) of
+ ?any ->
+ t_from_range(min(set_min(Set1), set_min(Set2)),
+ max(set_max(Set1), set_max(Set2)));
+ Set -> ?int_set(Set)
+ end;
+t_sup(?int_range(From1, To1), ?int_range(From2, To2)) ->
+ t_from_range(min(From1, From2), max(To1, To2));
+t_sup(Range = ?int_range(_, _), ?int_set(Set)) ->
+ expand_range_from_set(Range, Set);
+t_sup(?int_set(Set), Range = ?int_range(_, _)) ->
+ expand_range_from_set(Range, Set);
+t_sup(?product(Types1), ?product(Types2)) ->
+ L1 = length(Types1),
+ L2 = length(Types2),
+ if L1 =:= L2 -> ?product(t_sup_lists(Types1, Types2));
+ true -> ?any
+ end;
+t_sup(?product(_), _) ->
+ ?any;
+t_sup(_, ?product(_)) ->
+ ?any;
+t_sup(?tuple(?any, ?any, ?any) = T, ?tuple(_, _, _)) -> T;
+t_sup(?tuple(_, _, _), ?tuple(?any, ?any, ?any) = T) -> T;
+t_sup(?tuple(?any, ?any, ?any) = T, ?tuple_set(_)) -> T;
+t_sup(?tuple_set(_), ?tuple(?any, ?any, ?any) = T) -> T;
+t_sup(?tuple(Elements1, Arity, Tag1) = T1,
+ ?tuple(Elements2, Arity, Tag2) = T2) ->
+ if Tag1 =:= Tag2 -> t_tuple(t_sup_lists(Elements1, Elements2));
+ Tag1 =:= ?any -> t_tuple(t_sup_lists(Elements1, Elements2));
+ Tag2 =:= ?any -> t_tuple(t_sup_lists(Elements1, Elements2));
+ Tag1 < Tag2 -> ?tuple_set([{Arity, [T1, T2]}]);
+ Tag1 > Tag2 -> ?tuple_set([{Arity, [T2, T1]}])
+ end;
+t_sup(?tuple(_, Arity1, _) = T1, ?tuple(_, Arity2, _) = T2) ->
+ sup_tuple_sets([{Arity1, [T1]}], [{Arity2, [T2]}]);
+t_sup(?tuple_set(List1), ?tuple_set(List2)) ->
+ sup_tuple_sets(List1, List2);
+t_sup(?tuple_set(List1), T2 = ?tuple(_, Arity, _)) ->
+ sup_tuple_sets(List1, [{Arity, [T2]}]);
+t_sup(?tuple(_, Arity, _) = T1, ?tuple_set(List2)) ->
+ sup_tuple_sets([{Arity, [T1]}], List2);
+t_sup(T1, T2) ->
+ ?union(U1) = force_union(T1),
+ ?union(U2) = force_union(T2),
+ sup_union(U1, U2).
+
+-spec t_sup_lists([erl_type()], [erl_type()]) -> [erl_type()].
+
+t_sup_lists([T1|Left1], [T2|Left2]) ->
+ [t_sup(T1, T2)|t_sup_lists(Left1, Left2)];
+t_sup_lists([], []) ->
+ [].
+
+sup_tuple_sets(L1, L2) ->
+ TotalArities = ordsets:union([Arity || {Arity, _} <- L1],
+ [Arity || {Arity, _} <- L2]),
+ if length(TotalArities) > ?TUPLE_ARITY_LIMIT -> t_tuple();
+ true ->
+ case sup_tuple_sets(L1, L2, []) of
+ [{_Arity, [OneTuple = ?tuple(_, _, _)]}] -> OneTuple;
+ List -> ?tuple_set(List)
+ end
+ end.
+
+sup_tuple_sets([{Arity, Tuples1}|Left1], [{Arity, Tuples2}|Left2], Acc) ->
+ NewAcc = [{Arity, sup_tuples_in_set(Tuples1, Tuples2)}|Acc],
+ sup_tuple_sets(Left1, Left2, NewAcc);
+sup_tuple_sets([{Arity1, _} = T1|Left1] = L1,
+ [{Arity2, _} = T2|Left2] = L2, Acc) ->
+ if Arity1 < Arity2 -> sup_tuple_sets(Left1, L2, [T1|Acc]);
+ Arity1 > Arity2 -> sup_tuple_sets(L1, Left2, [T2|Acc])
+ end;
+sup_tuple_sets([], L2, Acc) -> lists:reverse(Acc, L2);
+sup_tuple_sets(L1, [], Acc) -> lists:reverse(Acc, L1).
+
+sup_tuples_in_set([?tuple(_, _, ?any) = T], L) ->
+ [t_tuple(sup_tuple_elements([T|L]))];
+sup_tuples_in_set(L, [?tuple(_, _, ?any) = T]) ->
+ [t_tuple(sup_tuple_elements([T|L]))];
+sup_tuples_in_set(L1, L2) ->
+ FoldFun = fun(?tuple(_, _, Tag), AccTag) -> t_sup(Tag, AccTag) end,
+ TotalTag0 = lists:foldl(FoldFun, ?none, L1),
+ TotalTag = lists:foldl(FoldFun, TotalTag0, L2),
+ case TotalTag of
+ ?atom(?any) ->
+ %% We will reach the set limit. Widen now.
+ [t_tuple(sup_tuple_elements(L1 ++ L2))];
+ ?atom(Set) ->
+ case set_size(Set) > ?TUPLE_TAG_LIMIT of
+ true ->
+ %% We will reach the set limit. Widen now.
+ [t_tuple(sup_tuple_elements(L1 ++ L2))];
+ false ->
+ %% We can go on and build the tuple set.
+ sup_tuples_in_set(L1, L2, [])
+ end
+ end.
+
+sup_tuple_elements([?tuple(Elements, _, _)|L]) ->
+ lists:foldl(fun (?tuple(Es, _, _), Acc) -> t_sup_lists(Es, Acc) end,
+ Elements, L).
+
+sup_tuples_in_set([?tuple(Elements1, Arity, Tag1) = T1|Left1] = L1,
+ [?tuple(Elements2, Arity, Tag2) = T2|Left2] = L2, Acc) ->
+ if
+ Tag1 < Tag2 -> sup_tuples_in_set(Left1, L2, [T1|Acc]);
+ Tag1 > Tag2 -> sup_tuples_in_set(L1, Left2, [T2|Acc]);
+ Tag2 =:= Tag2 -> NewElements = t_sup_lists(Elements1, Elements2),
+ NewAcc = [?tuple(NewElements, Arity, Tag1)|Acc],
+ sup_tuples_in_set(Left1, Left2, NewAcc)
+ end;
+sup_tuples_in_set([], L2, Acc) -> lists:reverse(Acc, L2);
+sup_tuples_in_set(L1, [], Acc) -> lists:reverse(Acc, L1).
+
+sup_union(U1, U2) ->
+ sup_union(U1, U2, 0, []).
+
+sup_union([?none|Left1], [?none|Left2], N, Acc) ->
+ sup_union(Left1, Left2, N, [?none|Acc]);
+sup_union([T1|Left1], [T2|Left2], N, Acc) ->
+ sup_union(Left1, Left2, N+1, [t_sup(T1, T2)|Acc]);
+sup_union([], [], N, Acc) ->
+ if N =:= 0 -> ?none;
+ N =:= 1 ->
+ [Type] = [T || T <- Acc, T =/= ?none],
+ Type;
+ N =:= length(Acc) -> ?any;
+ true -> ?union(lists:reverse(Acc))
+ end.
+
+force_union(T = ?atom(_)) -> ?atom_union(T);
+force_union(T = ?bitstr(_, _)) -> ?bitstr_union(T);
+force_union(T = ?function(_, _)) -> ?function_union(T);
+force_union(T = ?identifier(_)) -> ?identifier_union(T);
+force_union(T = ?list(_, _, _)) -> ?list_union(T);
+force_union(T = ?nil) -> ?list_union(T);
+force_union(T = ?number(_,_)) -> ?number_union(T);
+force_union(T = ?opaque(_)) -> ?opaque_union(T);
+force_union(T = ?remote(_)) -> ?remote_union(T);
+force_union(T = ?tuple(_, _, _)) -> ?tuple_union(T);
+force_union(T = ?tuple_set(_)) -> ?tuple_union(T);
+force_union(T = ?matchstate(_, _)) -> ?matchstate_union(T);
+force_union(T = ?union(_)) -> T.
+
+%%-----------------------------------------------------------------------------
+%% An attempt to write the inverse operation of t_sup/1 -- XXX: INCOMPLETE !!
+%%
+
+-spec t_elements(erl_type()) -> [erl_type()].
+
+t_elements(?none) -> [];
+t_elements(?unit) -> [];
+t_elements(?any = T) -> [T];
+t_elements(?nil = T) -> [T];
+t_elements(?atom(?any) = T) -> [T];
+t_elements(?atom(Atoms)) ->
+ [t_atom(A) || A <- Atoms];
+t_elements(?bitstr(_, _) = T) -> [T];
+t_elements(?function(_, _) = T) -> [T];
+t_elements(?identifier(?any) = T) -> [T];
+t_elements(?identifier(IDs)) ->
+ [?identifier([T]) || T <- IDs];
+t_elements(?list(_, _, _) = T) -> [T];
+t_elements(?number(_, _) = T) ->
+ case T of
+ ?number(?any, ?unknown_qual) -> [T];
+ ?float -> [T];
+ ?integer(?any) -> [T];
+ ?int_range(_, _) -> [T];
+ ?int_set(Set) ->
+ [t_integer(I) || I <- Set]
+ end;
+t_elements(?opaque(_) = T) -> [T];
+t_elements(?tuple(_, _, _) = T) -> [T];
+t_elements(?tuple_set(_) = TS) ->
+ case t_tuple_subtypes(TS) of
+ unknown -> [];
+ Elems -> Elems
+ end;
+t_elements(?union(List)) ->
+ lists:append([t_elements(T) || T <- List]);
+t_elements(?var(_)) -> [?any]. %% yes, vars exist -- what else to do here?
+%% t_elements(T) ->
+%% io:format("T_ELEMENTS => ~p\n", [T]).
+
+%%-----------------------------------------------------------------------------
+%% Infimum
+%%
+
+-spec t_inf([erl_type()]) -> erl_type().
+
+t_inf([H1, H2|T]) ->
+ case t_inf(H1, H2) of
+ ?none -> ?none;
+ NewH -> t_inf([NewH|T])
+ end;
+t_inf([H]) -> H;
+t_inf([]) -> ?none.
+
+-spec t_inf(erl_type(), erl_type()) -> erl_type().
+
+t_inf(T1, T2) ->
+ t_inf(T1, T2, structured).
+
+-type t_inf_mode() :: 'opaque' | 'structured'.
+-spec t_inf(erl_type(), erl_type(), t_inf_mode()) -> erl_type().
+
+t_inf(?var(_), ?var(_), _Mode) -> ?any;
+t_inf(?var(_), T, _Mode) -> subst_all_vars_to_any(T);
+t_inf(T, ?var(_), _Mode) -> subst_all_vars_to_any(T);
+t_inf(?any, T, _Mode) -> subst_all_vars_to_any(T);
+t_inf(T, ?any, _Mode) -> subst_all_vars_to_any(T);
+t_inf(?unit, _, _Mode) -> ?unit;
+t_inf(_, ?unit, _Mode) -> ?unit;
+t_inf(?none, _, _Mode) -> ?none;
+t_inf(_, ?none, _Mode) -> ?none;
+t_inf(T, T, _Mode) -> subst_all_vars_to_any(T);
+t_inf(?atom(Set1), ?atom(Set2), _) ->
+ case set_intersection(Set1, Set2) of
+ ?none -> ?none;
+ NewSet -> ?atom(NewSet)
+ end;
+t_inf(?bitstr(U1, B1), ?bitstr(0, B2), _Mode) ->
+ if B2 >= B1 andalso (B2-B1) rem U1 =:= 0 -> t_bitstr(0, B2);
+ true -> ?none
+ end;
+t_inf(?bitstr(0, B1), ?bitstr(U2, B2), _Mode) ->
+ if B1 >= B2 andalso (B1-B2) rem U2 =:= 0 -> t_bitstr(0, B1);
+ true -> ?none
+ end;
+t_inf(?bitstr(U1, B1), ?bitstr(U1, B1), _Mode) ->
+ t_bitstr(U1, B1);
+t_inf(?bitstr(U1, B1), ?bitstr(U2, B2), _Mode) when U2 > U1 ->
+ inf_bitstr(U2, B2, U1, B1);
+t_inf(?bitstr(U1, B1), ?bitstr(U2, B2), _Mode) ->
+ inf_bitstr(U1, B1, U2, B2);
+t_inf(?function(Domain1, Range1), ?function(Domain2, Range2), Mode) ->
+ case t_inf(Domain1, Domain2, Mode) of
+ ?none -> ?none;
+ Domain -> ?function(Domain, t_inf(Range1, Range2, Mode))
+ end;
+t_inf(?identifier(Set1), ?identifier(Set2), _Mode) ->
+ case set_intersection(Set1, Set2) of
+ ?none -> ?none;
+ Set -> ?identifier(Set)
+ end;
+t_inf(?matchstate(Pres1, Slots1), ?matchstate(Pres2, Slots2), _Mode) ->
+ ?matchstate(t_inf(Pres1, Pres2), t_inf(Slots1, Slots2));
+t_inf(?nil, ?nil, _Mode) -> ?nil;
+t_inf(?nil, ?nonempty_list(_, _), _Mode) ->
+ ?none;
+t_inf(?nonempty_list(_, _), ?nil, _Mode) ->
+ ?none;
+t_inf(?nil, ?list(_Contents, Termination, _), Mode) ->
+ t_inf(?nil, Termination, Mode);
+t_inf(?list(_Contents, Termination, _), ?nil, Mode) ->
+ t_inf(?nil, Termination, Mode);
+t_inf(?list(Contents1, Termination1, Size1),
+ ?list(Contents2, Termination2, Size2), Mode) ->
+ case t_inf(Termination1, Termination2, Mode) of
+ ?none -> ?none;
+ Termination ->
+ case t_inf(Contents1, Contents2, Mode) of
+ ?none ->
+ %% If none of the lists are nonempty, then the infimum is nil.
+ case (Size1 =:= ?unknown_qual) andalso (Size2 =:= ?unknown_qual) of
+ true -> t_nil();
+ false -> ?none
+ end;
+ Contents ->
+ Size =
+ case {Size1, Size2} of
+ {?unknown_qual, ?unknown_qual} -> ?unknown_qual;
+ {?unknown_qual, ?nonempty_qual} -> ?nonempty_qual;
+ {?nonempty_qual, ?unknown_qual} -> ?nonempty_qual;
+ {?nonempty_qual, ?nonempty_qual} -> ?nonempty_qual
+ end,
+ ?list(Contents, Termination, Size)
+ end
+ end;
+t_inf(?number(_, _) = T1, ?number(_, _) = T2, _Mode) ->
+ case {T1, T2} of
+ {T, T} -> T;
+ {_, ?number(?any, ?unknown_qual)} -> T1;
+ {?number(?any, ?unknown_qual), _} -> T2;
+ {?float, ?integer(_)} -> ?none;
+ {?integer(_), ?float} -> ?none;
+ {?integer(?any), ?integer(_)} -> T2;
+ {?integer(_), ?integer(?any)} -> T1;
+ {?int_set(Set1), ?int_set(Set2)} ->
+ case set_intersection(Set1, Set2) of
+ ?none -> ?none;
+ Set -> ?int_set(Set)
+ end;
+ {?int_range(From1, To1), ?int_range(From2, To2)} ->
+ t_from_range(max(From1, From2), min(To1, To2));
+ {Range = ?int_range(_, _), ?int_set(Set)} ->
+ %% io:format("t_inf range, set args ~p ~p ~n", [T1, T2]),
+ Ans2 =
+ case set_filter(fun(X) -> in_range(X, Range) end, Set) of
+ ?none -> ?none;
+ NewSet -> ?int_set(NewSet)
+ end,
+ %% io:format("Ans2 ~p ~n", [Ans2]),
+ Ans2;
+ {?int_set(Set), ?int_range(_, _) = Range} ->
+ case set_filter(fun(X) -> in_range(X, Range) end, Set) of
+ ?none -> ?none;
+ NewSet -> ?int_set(NewSet)
+ end
+ end;
+t_inf(?product(Types1), ?product(Types2), Mode) ->
+ L1 = length(Types1),
+ L2 = length(Types2),
+ if L1 =:= L2 -> ?product(t_inf_lists(Types1, Types2, Mode));
+ true -> ?none
+ end;
+t_inf(?product(_), _, _Mode) ->
+ ?none;
+t_inf(_, ?product(_), _Mode) ->
+ ?none;
+t_inf(?tuple(?any, ?any, ?any), ?tuple(_, _, _) = T, _Mode) -> T;
+t_inf(?tuple(_, _, _) = T, ?tuple(?any, ?any, ?any), _Mode) -> T;
+t_inf(?tuple(?any, ?any, ?any), ?tuple_set(_) = T, _Mode) -> T;
+t_inf(?tuple_set(_) = T, ?tuple(?any, ?any, ?any), _Mode) -> T;
+t_inf(?tuple(Elements1, Arity, _Tag1), ?tuple(Elements2, Arity, _Tag2), Mode) ->
+ case t_inf_lists_strict(Elements1, Elements2, Mode) of
+ bottom -> ?none;
+ NewElements -> t_tuple(NewElements)
+ end;
+t_inf(?tuple_set(List1), ?tuple_set(List2), Mode) ->
+ inf_tuple_sets(List1, List2, Mode);
+t_inf(?tuple_set(List), ?tuple(_, Arity, _) = T, Mode) ->
+ inf_tuple_sets(List, [{Arity, [T]}], Mode);
+t_inf(?tuple(_, Arity, _) = T, ?tuple_set(List), Mode) ->
+ inf_tuple_sets(List, [{Arity, [T]}], Mode);
+%% be careful: here and in the next clause T can be ?opaque
+t_inf(?union(U1), T, Mode) ->
+ ?union(U2) = force_union(T),
+ inf_union(U1, U2, Mode);
+t_inf(T, ?union(U2), Mode) ->
+ ?union(U1) = force_union(T),
+ inf_union(U1, U2, Mode);
+%% and as a result, the cases for ?opaque should appear *after* ?union
+t_inf(?opaque(Set1), ?opaque(Set2), _Mode) ->
+ case set_intersection(Set1, Set2) of
+ ?none -> ?none;
+ NewSet -> ?opaque(NewSet)
+ end;
+t_inf(?opaque(_) = T1, T2, opaque) ->
+ case t_inf(t_opaque_structure(T1), T2, structured) of
+ ?none -> ?none;
+ _Type -> T1
+ end;
+t_inf(T1, ?opaque(_) = T2, opaque) ->
+ case t_inf(T1, t_opaque_structure(T2), structured) of
+ ?none -> ?none;
+ _Type -> T2
+ end;
+t_inf(#c{}, #c{}, _) ->
+ ?none.
+
+-spec t_inf_lists([erl_type()], [erl_type()]) -> [erl_type()].
+
+t_inf_lists(L1, L2) ->
+ t_inf_lists(L1, L2, structured).
+
+-spec t_inf_lists([erl_type()], [erl_type()], t_inf_mode()) -> [erl_type()].
+
+t_inf_lists(L1, L2, Mode) ->
+ t_inf_lists(L1, L2, [], Mode).
+
+-spec t_inf_lists([erl_type()], [erl_type()], [erl_type()], t_inf_mode()) -> [erl_type()].
+
+t_inf_lists([T1|Left1], [T2|Left2], Acc, Mode) ->
+ t_inf_lists(Left1, Left2, [t_inf(T1, T2, Mode)|Acc], Mode);
+t_inf_lists([], [], Acc, _Mode) ->
+ lists:reverse(Acc).
+
+%% Infimum of lists with strictness.
+%% If any element is the ?none type, the value 'bottom' is returned.
+
+-spec t_inf_lists_strict([erl_type()], [erl_type()], t_inf_mode()) -> 'bottom' | [erl_type()].
+
+t_inf_lists_strict(L1, L2, Mode) ->
+ t_inf_lists_strict(L1, L2, [], Mode).
+
+-spec t_inf_lists_strict([erl_type()], [erl_type()], [erl_type()], t_inf_mode()) -> 'bottom' | [erl_type()].
+
+t_inf_lists_strict([T1|Left1], [T2|Left2], Acc, Mode) ->
+ case t_inf(T1, T2, Mode) of
+ ?none -> bottom;
+ T -> t_inf_lists_strict(Left1, Left2, [T|Acc], Mode)
+ end;
+t_inf_lists_strict([], [], Acc, _Mode) ->
+ lists:reverse(Acc).
+
+inf_tuple_sets(L1, L2, Mode) ->
+ case inf_tuple_sets(L1, L2, [], Mode) of
+ [] -> ?none;
+ [{_Arity, [?tuple(_, _, _) = OneTuple]}] -> OneTuple;
+ List -> ?tuple_set(List)
+ end.
+
+inf_tuple_sets([{Arity, Tuples1}|Left1], [{Arity, Tuples2}|Left2], Acc, Mode) ->
+ case inf_tuples_in_sets(Tuples1, Tuples2, Mode) of
+ [] -> inf_tuple_sets(Left1, Left2, Acc, Mode);
+ NewTuples -> inf_tuple_sets(Left1, Left2, [{Arity, NewTuples}|Acc], Mode)
+ end;
+inf_tuple_sets(L1 = [{Arity1, _}|Left1], L2 = [{Arity2, _}|Left2], Acc, Mode) ->
+ if Arity1 < Arity2 -> inf_tuple_sets(Left1, L2, Acc, Mode);
+ Arity1 > Arity2 -> inf_tuple_sets(L1, Left2, Acc, Mode)
+ end;
+inf_tuple_sets([], _, Acc, _Mode) -> lists:reverse(Acc);
+inf_tuple_sets(_, [], Acc, _Mode) -> lists:reverse(Acc).
+
+inf_tuples_in_sets([?tuple(Elements1, _, ?any)], L2, Mode) ->
+ NewList = [t_inf_lists_strict(Elements1, Elements2, Mode)
+ || ?tuple(Elements2, _, _) <- L2],
+ [t_tuple(Es) || Es <- NewList, Es =/= bottom];
+inf_tuples_in_sets(L1, [?tuple(Elements2, _, ?any)], Mode) ->
+ NewList = [t_inf_lists_strict(Elements1, Elements2, Mode)
+ || ?tuple(Elements1, _, _) <- L1],
+ [t_tuple(Es) || Es <- NewList, Es =/= bottom];
+inf_tuples_in_sets(L1, L2, Mode) ->
+ inf_tuples_in_sets(L1, L2, [], Mode).
+
+inf_tuples_in_sets([?tuple(Elements1, Arity, Tag)|Left1],
+ [?tuple(Elements2, Arity, Tag)|Left2], Acc, Mode) ->
+ case t_inf_lists_strict(Elements1, Elements2, Mode) of
+ bottom -> inf_tuples_in_sets(Left1, Left2, Acc, Mode);
+ NewElements ->
+ inf_tuples_in_sets(Left1, Left2, [?tuple(NewElements, Arity, Tag)|Acc], Mode)
+ end;
+inf_tuples_in_sets([?tuple(_, _, Tag1)|Left1] = L1,
+ [?tuple(_, _, Tag2)|Left2] = L2, Acc, Mode) ->
+ if Tag1 < Tag2 -> inf_tuples_in_sets(Left1, L2, Acc, Mode);
+ Tag1 > Tag2 -> inf_tuples_in_sets(L1, Left2, Acc, Mode)
+ end;
+inf_tuples_in_sets([], _, Acc, _Mode) -> lists:reverse(Acc);
+inf_tuples_in_sets(_, [], Acc, _Mode) -> lists:reverse(Acc).
+
+inf_union(U1, U2, opaque) ->
+%%---------------------------------------------------------------------
+%% Under Testing
+%%----------------------------------------------------------------------
+%% OpaqueFun =
+%% fun(Union1, Union2) ->
+%% [_,_,_,_,_,_,_,_,Opaque,_] = Union1,
+%% [A,B,F,I,L,N,T,M,_,_R] = Union2,
+%% List = [A,B,F,I,L,N,T,M],
+%% case [T || T <- List, t_inf(T, Opaque, opaque) =/= ?none] of
+%% [] -> ?none;
+%% _ -> Opaque
+%% end
+%% end,
+%% O1 = OpaqueFun(U1, U2),
+%% O2 = OpaqueFun(U2, U1),
+%% Union = inf_union(U1, U2, 0, [], opaque),
+%% t_sup([O1, O2, Union]);
+ inf_union(U1, U2, 0, [], opaque);
+inf_union(U1, U2, OtherMode) ->
+ inf_union(U1, U2, 0, [], OtherMode).
+
+inf_union([?none|Left1], [?none|Left2], N, Acc, Mode) ->
+ inf_union(Left1, Left2, N, [?none|Acc], Mode);
+inf_union([T1|Left1], [T2|Left2], N, Acc, Mode) ->
+ case t_inf(T1, T2, Mode) of
+ ?none -> inf_union(Left1, Left2, N, [?none|Acc], Mode);
+ T -> inf_union(Left1, Left2, N+1, [T|Acc], Mode)
+ end;
+inf_union([], [], N, Acc, _Mode) ->
+ if N =:= 0 -> ?none;
+ N =:= 1 ->
+ [Type] = [T || T <- Acc, T =/= ?none],
+ Type;
+ N >= 2 -> ?union(lists:reverse(Acc))
+ end.
+
+inf_bitstr(U1, B1, U2, B2) ->
+ GCD = gcd(U1, U2),
+ case (B2-B1) rem GCD of
+ 0 ->
+ U = (U1*U2) div GCD,
+ B = findfirst(0, 0, U1, B1, U2, B2),
+ t_bitstr(U, B);
+ _ ->
+ ?none
+ end.
+
+findfirst(N1, N2, U1, B1, U2, B2) ->
+ Val1 = U1*N1+B1,
+ Val2 = U2*N2+B2,
+ if Val1 =:= Val2 ->
+ Val1;
+ Val1 > Val2 ->
+ findfirst(N1, N2+1, U1, B1, U2, B2);
+ Val1 < Val2 ->
+ findfirst(N1+1, N2, U1, B1, U2, B2)
+ end.
+
+%%-----------------------------------------------------------------------------
+%% Substitution of variables
+%%
+
+-spec t_subst(erl_type(), dict()) -> erl_type().
+
+t_subst(T, Dict) ->
+ case t_has_var(T) of
+ true -> t_subst(T, Dict, fun(X) -> X end);
+ false -> T
+ end.
+
+-spec subst_all_vars_to_any(erl_type()) -> erl_type().
+
+subst_all_vars_to_any(T) ->
+ case t_has_var(T) of
+ true -> t_subst(T, dict:new(), fun(_) -> ?any end);
+ false -> T
+ end.
+
+t_subst(?var(Id) = V, Dict, Fun) ->
+ case dict:find(Id, Dict) of
+ error -> Fun(V);
+ {ok, Type} -> Type
+ end;
+t_subst(?list(Contents, Termination, Size), Dict, Fun) ->
+ case t_subst(Contents, Dict, Fun) of
+ ?none -> ?none;
+ NewContents ->
+ %% Be careful here to make the termination collapse if necessary.
+ case t_subst(Termination, Dict, Fun) of
+ ?nil -> ?list(NewContents, ?nil, Size);
+ ?any -> ?list(NewContents, ?any, Size);
+ Other ->
+ ?list(NewContents, NewTermination, _) = t_cons(NewContents, Other),
+ ?list(NewContents, NewTermination, Size)
+ end
+ end;
+t_subst(?function(Domain, Range), Dict, Fun) ->
+ ?function(t_subst(Domain, Dict, Fun), t_subst(Range, Dict, Fun));
+t_subst(?product(Types), Dict, Fun) ->
+ ?product([t_subst(T, Dict, Fun) || T <- Types]);
+t_subst(?tuple(?any, ?any, ?any) = T, _Dict, _Fun) ->
+ T;
+t_subst(?tuple(Elements, _Arity, _Tag), Dict, Fun) ->
+ t_tuple([t_subst(E, Dict, Fun) || E <- Elements]);
+t_subst(?tuple_set(_) = TS, Dict, Fun) ->
+ t_sup([t_subst(T, Dict, Fun) || T <- t_tuple_subtypes(TS)]);
+t_subst(T, _Dict, _Fun) ->
+ T.
+
+%%-----------------------------------------------------------------------------
+%% Unification
+%%
+
+-spec t_unify(erl_type(), erl_type()) -> {erl_type(), [{_, erl_type()}]}.
+
+t_unify(T1, T2) ->
+ {T, Dict} = t_unify(T1, T2, dict:new()),
+ {t_subst(T, Dict), lists:keysort(1, dict:to_list(Dict))}.
+
+t_unify(?var(Id) = T, ?var(Id), Dict) ->
+ {T, Dict};
+t_unify(?var(Id1) = T, ?var(Id2), Dict) ->
+ case dict:find(Id1, Dict) of
+ error ->
+ case dict:find(Id2, Dict) of
+ error -> {T, dict:store(Id2, T, Dict)};
+ {ok, Type} -> {Type, t_unify(T, Type, Dict)}
+ end;
+ {ok, Type1} ->
+ case dict:find(Id2, Dict) of
+ error -> {Type1, dict:store(Id2, T, Dict)};
+ {ok, Type2} -> t_unify(Type1, Type2, Dict)
+ end
+ end;
+t_unify(?var(Id), Type, Dict) ->
+ case dict:find(Id, Dict) of
+ error -> {Type, dict:store(Id, Type, Dict)};
+ {ok, VarType} -> t_unify(VarType, Type, Dict)
+ end;
+t_unify(Type, ?var(Id), Dict) ->
+ case dict:find(Id, Dict) of
+ error -> {Type, dict:store(Id, Type, Dict)};
+ {ok, VarType} -> t_unify(VarType, Type, Dict)
+ end;
+t_unify(?function(Domain1, Range1), ?function(Domain2, Range2), Dict) ->
+ {Domain, Dict1} = t_unify(Domain1, Domain2, Dict),
+ {Range, Dict2} = t_unify(Range1, Range2, Dict1),
+ {?function(Domain, Range), Dict2};
+t_unify(?list(Contents1, Termination1, Size),
+ ?list(Contents2, Termination2, Size), Dict) ->
+ {Contents, Dict1} = t_unify(Contents1, Contents2, Dict),
+ {Termination, Dict2} = t_unify(Termination1, Termination2, Dict1),
+ {?list(Contents, Termination, Size), Dict2};
+t_unify(?product(Types1), ?product(Types2), Dict) ->
+ {Types, Dict1} = unify_lists(Types1, Types2, Dict),
+ {?product(Types), Dict1};
+t_unify(?tuple(?any, ?any, ?any) = T, ?tuple(?any, ?any, ?any), Dict) ->
+ {T, Dict};
+t_unify(?tuple(Elements1, Arity, _),
+ ?tuple(Elements2, Arity, _), Dict) when Arity =/= ?any ->
+ {NewElements, Dict1} = unify_lists(Elements1, Elements2, Dict),
+ {t_tuple(NewElements), Dict1};
+t_unify(?tuple_set([{Arity, _}]) = T1,
+ ?tuple(_, Arity, _) = T2, Dict) when Arity =/= ?any ->
+ unify_tuple_set_and_tuple(T1, T2, Dict);
+t_unify(?tuple(_, Arity, _) = T1,
+ ?tuple_set([{Arity, _}]) = T2, Dict) when Arity =/= ?any ->
+ unify_tuple_set_and_tuple(T2, T1, Dict);
+t_unify(?tuple_set(List1), ?tuple_set(List2), Dict) ->
+ {Tuples, NewDict} =
+ unify_lists(lists:append([T || {_Arity, T} <- List1]),
+ lists:append([T || {_Arity, T} <- List2]), Dict),
+ {t_sup(Tuples), NewDict};
+t_unify(T, T, Dict) ->
+ {T, Dict};
+t_unify(T1, T2, _) ->
+ throw({mismatch, T1, T2}).
+
+unify_tuple_set_and_tuple(?tuple_set([{Arity, List}]),
+ ?tuple(Elements2, Arity, _), Dict) ->
+ %% Can only work if the single tuple has variables at correct places.
+ %% Collapse the tuple set.
+ {NewElements, Dict1} = unify_lists(sup_tuple_elements(List), Elements2, Dict),
+ {t_tuple(NewElements), Dict1}.
+
+unify_lists(L1, L2, Dict) ->
+ unify_lists(L1, L2, Dict, []).
+
+unify_lists([T1|Left1], [T2|Left2], Dict, Acc) ->
+ {NewT, NewDict} = t_unify(T1, T2, Dict),
+ unify_lists(Left1, Left2, NewDict, [NewT|Acc]);
+unify_lists([], [], Dict, Acc) ->
+ {lists:reverse(Acc), Dict}.
+
+%%t_assign_variables_to_subtype(T1, T2) ->
+%% try
+%% Dict = assign_vars(T1, T2, dict:new()),
+%% {ok, dict:map(fun(_Param, List) -> t_sup(List) end, Dict)}
+%% catch
+%% throw:error -> error
+%% end.
+
+%%assign_vars(_, ?var(_), _Dict) ->
+%% erlang:error("Variable in right hand side of assignment");
+%%assign_vars(?any, _, Dict) ->
+%% Dict;
+%%assign_vars(?var(_) = Var, Type, Dict) ->
+%% store_var(Var, Type, Dict);
+%%assign_vars(?function(Domain1, Range1), ?function(Domain2, Range2), Dict) ->
+%% DomainList =
+%% case Domain2 of
+%% ?any -> [];
+%% ?product(List) -> List
+%% end,
+%% case any_none([Range2|DomainList]) of
+%% true -> throw(error);
+%% false ->
+%% Dict1 = assign_vars(Domain1, Domain2, Dict),
+%% assign_vars(Range1, Range2, Dict1)
+%% end;
+%%assign_vars(?list(_Contents, _Termination, ?any), ?nil, Dict) ->
+%% Dict;
+%%assign_vars(?list(Contents1, Termination1, Size1),
+%% ?list(Contents2, Termination2, Size2), Dict) ->
+%% Dict1 = assign_vars(Contents1, Contents2, Dict),
+%% Dict2 = assign_vars(Termination1, Termination2, Dict1),
+%% case {Size1, Size2} of
+%% {S, S} -> Dict2;
+%% {?any, ?nonempty_qual} -> Dict2;
+%% {_, _} -> throw(error)
+%% end;
+%%assign_vars(?product(Types1), ?product(Types2), Dict) ->
+%% case length(Types1) =:= length(Types2) of
+%% true -> assign_vars_lists(Types1, Types2, Dict);
+%% false -> throw(error)
+%% end;
+%%assign_vars(?tuple(?any, ?any, ?any), ?tuple(?any, ?any, ?any), Dict) ->
+%% Dict;
+%%assign_vars(?tuple(?any, ?any, ?any), ?tuple(_, _, _), Dict) ->
+%% Dict;
+%%assign_vars(?tuple(Elements1, Arity, _),
+%% ?tuple(Elements2, Arity, _), Dict) when Arity =/= ?any ->
+%% assign_vars_lists(Elements1, Elements2, Dict);
+%%assign_vars(?tuple_set(_) = T, ?tuple_set(List2), Dict) ->
+%% %% All Rhs tuples must already be subtypes of Lhs, so we can take
+%% %% each one separatly.
+%% assign_vars_lists([T || _ <- List2], List2, Dict);
+%%assign_vars(?tuple(?any, ?any, ?any), ?tuple_set(_), Dict) ->
+%% Dict;
+%%assign_vars(?tuple(_, Arity, _) = T1, ?tuple_set(List), Dict) ->
+%% case reduce_tuple_tags(List) of
+%% [Tuple = ?tuple(_, Arity, _)] -> assign_vars(T1, Tuple, Dict);
+%% _ -> throw(error)
+%% end;
+%%assign_vars(?tuple_set(List), ?tuple(_, Arity, Tag) = T2, Dict) ->
+%% case [T || ?tuple(_, Arity1, Tag1) = T <- List,
+%% Arity1 =:= Arity, Tag1 =:= Tag] of
+%% [] -> throw(error);
+%% [T1] -> assign_vars(T1, T2, Dict)
+%% end;
+%%assign_vars(?union(U1), T2, Dict) ->
+%% ?union(U2) = force_union(T2),
+%% assign_vars_lists(U1, U2, Dict);
+%%assign_vars(T, T, Dict) ->
+%% Dict;
+%%assign_vars(T1, T2, Dict) ->
+%% case t_is_subtype(T2, T1) of
+%% false -> throw(error);
+%% true -> Dict
+%% end.
+
+%%assign_vars_lists([T1|Left1], [T2|Left2], Dict) ->
+%% assign_vars_lists(Left1, Left2, assign_vars(T1, T2, Dict));
+%%assign_vars_lists([], [], Dict) ->
+%% Dict.
+
+%%store_var(?var(Id), Type, Dict) ->
+%% case dict:find(Id, Dict) of
+%% error -> dict:store(Id, [Type], Dict);
+%% {ok, _VarType0} -> dict:update(Id, fun(X) -> [Type|X] end, Dict)
+%% end.
+
+%%-----------------------------------------------------------------------------
+%% Subtraction.
+%%
+%% Note that the subtraction is an approximation since we do not have
+%% negative types. Also, tuples and products should be handled using
+%% the cartesian product of the elements, but this is not feasible to
+%% do.
+%%
+%% Example: {a|b,c|d}\{a,d} = {a,c}|{a,d}|{b,c}|{b,d} \ {a,d} =
+%% = {a,c}|{b,c}|{b,d} = {a|b,c|d}
+%%
+%% Instead, we can subtract if all elements but one becomes none after
+%% subtracting element-wise.
+%%
+%% Example: {a|b,c|d}\{a|b,d} = {a,c}|{a,d}|{b,c}|{b,d} \ {a,d}|{b,d} =
+%% = {a,c}|{b,c} = {a|b,c}
+
+-spec t_subtract_list(erl_type(), [erl_type()]) -> erl_type().
+
+t_subtract_list(T1, [T2|Left]) ->
+ t_subtract_list(t_subtract(T1, T2), Left);
+t_subtract_list(T, []) ->
+ T.
+
+-spec t_subtract(erl_type(), erl_type()) -> erl_type().
+
+t_subtract(_, ?any) -> ?none;
+t_subtract(?any, _) -> ?any;
+t_subtract(T, ?unit) -> T;
+t_subtract(?unit, _) -> ?unit;
+t_subtract(?none, _) -> ?none;
+t_subtract(T, ?none) -> T;
+t_subtract(?atom(Set1), ?atom(Set2)) ->
+ case set_subtract(Set1, Set2) of
+ ?none -> ?none;
+ Set -> ?atom(Set)
+ end;
+t_subtract(?bitstr(U1, B1), ?bitstr(U2, B2)) ->
+ subtract_bin(t_bitstr(U1, B1), t_inf(t_bitstr(U1, B1), t_bitstr(U2, B2)));
+t_subtract(?function(_, _) = T1, ?function(_, _) = T2) ->
+ case t_is_subtype(T1, T2) of
+ true -> ?none;
+ false -> T1
+ end;
+t_subtract(?identifier(Set1), ?identifier(Set2)) ->
+ case set_subtract(Set1, Set2) of
+ ?none -> ?none;
+ Set -> ?identifier(Set)
+ end;
+t_subtract(?opaque(Set1), ?opaque(Set2)) ->
+ case set_subtract(Set1, Set2) of
+ ?none -> ?none;
+ Set -> ?opaque(Set)
+ end;
+t_subtract(?matchstate(Pres1, Slots1), ?matchstate(Pres2, _Slots2)) ->
+ Pres = t_subtract(Pres1,Pres2),
+ case t_is_none(Pres) of
+ true -> ?none;
+ false -> ?matchstate(Pres,Slots1)
+ end;
+t_subtract(?matchstate(Present,Slots),_) ->
+ ?matchstate(Present,Slots);
+t_subtract(?nil, ?nil) ->
+ ?none;
+t_subtract(?nil, ?nonempty_list(_, _)) ->
+ ?nil;
+t_subtract(?nil, ?list(_, _, _)) ->
+ ?none;
+t_subtract(?list(Contents, Termination, _Size) = T, ?nil) ->
+ case Termination =:= ?nil of
+ true -> ?nonempty_list(Contents, Termination);
+ false -> T
+ end;
+t_subtract(?list(Contents1, Termination1, Size1) = T,
+ ?list(Contents2, Termination2, Size2)) ->
+ case t_is_subtype(Contents1, Contents2) of
+ true ->
+ case t_is_subtype(Termination1, Termination2) of
+ true ->
+ case {Size1, Size2} of
+ {?nonempty_qual, ?unknown_qual} -> ?none;
+ {?unknown_qual, ?nonempty_qual} -> Termination1;
+ {S, S} -> ?none
+ end;
+ false ->
+ %% If the termination is not covered by the subtracted type
+ %% we cannot really say anything about the result.
+ T
+ end;
+ false ->
+ %% All contents must be covered if there is going to be any
+ %% change to the list.
+ T
+ end;
+t_subtract(?float, ?float) -> ?none;
+t_subtract(?number(_, _) = T1, ?float) -> t_inf(T1, t_integer());
+t_subtract(?float, ?number(_Set, Tag)) ->
+ case Tag of
+ ?unknown_qual -> ?none;
+ _ -> ?float
+ end;
+t_subtract(?number(_, _), ?number(?any, ?unknown_qual)) -> ?none;
+t_subtract(?number(_, _) = T1, ?integer(?any)) -> t_inf(?float, T1);
+t_subtract(?int_set(Set1), ?int_set(Set2)) ->
+ case set_subtract(Set1, Set2) of
+ ?none -> ?none;
+ Set -> ?int_set(Set)
+ end;
+t_subtract(?int_range(From1, To1) = T1, ?int_range(_, _) = T2) ->
+ case t_inf(T1, T2) of
+ ?none -> T1;
+ ?int_range(From1, To1) -> ?none;
+ ?int_range(neg_inf, To) -> t_from_range(To + 1, To1);
+ ?int_range(From, pos_inf) -> t_from_range(From1, From - 1);
+ ?int_range(From, To) -> t_sup(t_from_range(From1, From - 1),
+ t_from_range(To + 1, To))
+ end;
+t_subtract(?int_range(From, To) = T1, ?int_set(Set)) ->
+ NewFrom = case set_is_element(From, Set) of
+ true -> From + 1;
+ false -> From
+ end,
+ NewTo = case set_is_element(To, Set) of
+ true -> To - 1;
+ false -> To
+ end,
+ if (NewFrom =:= From) and (NewTo =:= To) -> T1;
+ true -> t_from_range(NewFrom, NewTo)
+ end;
+t_subtract(?int_set(Set), ?int_range(From, To)) ->
+ case set_filter(fun(X) -> not ((X =< From) orelse (X >= To)) end, Set) of
+ ?none -> ?none;
+ NewSet -> ?int_set(NewSet)
+ end;
+t_subtract(?integer(?any) = T1, ?integer(_)) -> T1;
+t_subtract(?number(_, _) = T1, ?number(_, _)) -> T1;
+t_subtract(?tuple(_, _, _), ?tuple(?any, ?any, ?any)) -> ?none;
+t_subtract(?tuple_set(_), ?tuple(?any, ?any, ?any)) -> ?none;
+t_subtract(?tuple(?any, ?any, ?any) = T1, ?tuple_set(_)) -> T1;
+t_subtract(?tuple(Elements1, Arity1, _Tag1) = T1,
+ ?tuple(Elements2, Arity2, _Tag2)) ->
+ if Arity1 =/= Arity2 -> T1;
+ Arity1 =:= Arity2 ->
+ NewElements = t_subtract_lists(Elements1, Elements2),
+ case [E || E <- NewElements, E =/= ?none] of
+ [] -> ?none;
+ [_] -> t_tuple(replace_nontrivial_element(Elements1, NewElements));
+ _ -> T1
+ end
+ end;
+t_subtract(?tuple_set(List1) = T1, ?tuple(_, Arity, _) = T2) ->
+ case orddict:find(Arity, List1) of
+ error -> T1;
+ {ok, List2} ->
+ TuplesLeft0 = [Tuple || {_Arity, Tuple} <- orddict:erase(Arity, List1)],
+ TuplesLeft1 = lists:append(TuplesLeft0),
+ t_sup([t_subtract(L, T2) || L <- List2] ++ TuplesLeft1)
+ end;
+t_subtract(?tuple(_, Arity, _) = T1, ?tuple_set(List1)) ->
+ case orddict:find(Arity, List1) of
+ error -> T1;
+ {ok, List2} -> t_inf([t_subtract(T1, L) || L <- List2])
+ end;
+t_subtract(?tuple_set(_) = T1, ?tuple_set(_) = T2) ->
+ t_sup([t_subtract(T, T2) || T <- t_tuple_subtypes(T1)]);
+t_subtract(?product(Elements1) = T1, ?product(Elements2)) ->
+ Arity1 = length(Elements1),
+ Arity2 = length(Elements2),
+ if Arity1 =/= Arity2 -> T1;
+ Arity1 =:= Arity2 ->
+ NewElements = t_subtract_lists(Elements1, Elements2),
+ case [E || E <- NewElements, E =/= ?none] of
+ [] -> ?none;
+ [_] -> t_product(replace_nontrivial_element(Elements1, NewElements));
+ _ -> T1
+ end
+ end;
+t_subtract(?product(P1), _) ->
+ ?product(P1);
+t_subtract(T, ?product(_)) ->
+ T;
+t_subtract(?union(U1), ?union(U2)) ->
+ subtract_union(U1, U2);
+t_subtract(T1, T2) ->
+ ?union(U1) = force_union(T1),
+ ?union(U2) = force_union(T2),
+ subtract_union(U1, U2).
+
+-spec t_subtract_lists([erl_type()], [erl_type()]) -> [erl_type()].
+
+t_subtract_lists(L1, L2) ->
+ t_subtract_lists(L1, L2, []).
+
+-spec t_subtract_lists([erl_type()], [erl_type()], [erl_type()]) -> [erl_type()].
+
+t_subtract_lists([T1|Left1], [T2|Left2], Acc) ->
+ t_subtract_lists(Left1, Left2, [t_subtract(T1, T2)|Acc]);
+t_subtract_lists([], [], Acc) ->
+ lists:reverse(Acc).
+
+-spec subtract_union([erl_type(),...], [erl_type(),...]) -> erl_type().
+
+subtract_union(U1, U2) ->
+ subtract_union(U1, U2, 0, []).
+
+-spec subtract_union([erl_type()], [erl_type()], non_neg_integer(), [erl_type()]) -> erl_type().
+
+subtract_union([T1|Left1], [T2|Left2], N, Acc) ->
+ case t_subtract(T1, T2) of
+ ?none -> subtract_union(Left1, Left2, N, [?none|Acc]);
+ T -> subtract_union(Left1, Left2, N+1, [T|Acc])
+ end;
+subtract_union([], [], 0, _Acc) ->
+ ?none;
+subtract_union([], [], 1, Acc) ->
+ [T] = [X || X <- Acc, X =/= ?none],
+ T;
+subtract_union([], [], N, Acc) when is_integer(N), N > 1 ->
+ ?union(lists:reverse(Acc)).
+
+replace_nontrivial_element(El1, El2) ->
+ replace_nontrivial_element(El1, El2, []).
+
+replace_nontrivial_element([T1|Left1], [?none|Left2], Acc) ->
+ replace_nontrivial_element(Left1, Left2, [T1|Acc]);
+replace_nontrivial_element([_|Left1], [T2|_], Acc) ->
+ lists:reverse(Acc) ++ [T2|Left1].
+
+subtract_bin(?bitstr(U1, B1), ?bitstr(U1, B1)) ->
+ ?none;
+subtract_bin(?bitstr(U1, B1), ?none) ->
+ t_bitstr(U1, B1);
+subtract_bin(?bitstr(U1, B1), ?bitstr(0, B1)) ->
+ t_bitstr(U1, B1+U1);
+subtract_bin(?bitstr(U1, B1), ?bitstr(U1, B2)) ->
+ if (B1+U1) =/= B2 -> t_bitstr(0, B1);
+ true -> t_bitstr(U1, B1)
+ end;
+subtract_bin(?bitstr(U1, B1), ?bitstr(U2, B2)) ->
+ if (2 * U1) =:= U2 ->
+ if B1 =:= B2 ->
+ t_bitstr(U2, B1+U1);
+ (B1 + U1) =:= B2 ->
+ t_bitstr(U2, B1);
+ true ->
+ t_bitstr(U1, B1)
+ end;
+ true ->
+ t_bitstr(U1, B1)
+ end.
+
+%%-----------------------------------------------------------------------------
+%% Relations
+%%
+
+-spec t_is_equal(erl_type(), erl_type()) -> boolean().
+
+t_is_equal(T, T) -> true;
+t_is_equal(_, _) -> false.
+
+-spec t_is_subtype(erl_type(), erl_type()) -> boolean().
+
+t_is_subtype(T1, T2) ->
+ Inf = t_inf(T1, T2),
+ t_is_equal(T1, Inf).
+
+-spec t_is_instance(erl_type(), erl_type()) -> boolean().
+
+t_is_instance(ConcreteType, Type) ->
+ t_is_subtype(ConcreteType, t_unopaque(Type)).
+
+-spec t_unopaque(erl_type()) -> erl_type().
+
+t_unopaque(T) ->
+ t_unopaque(T, 'universe').
+
+-spec t_unopaque(erl_type(), 'universe' | [erl_type()]) -> erl_type().
+
+t_unopaque(?opaque(_) = T, Opaques) ->
+ case Opaques =:= universe orelse lists:member(T, Opaques) of
+ true -> t_unopaque(t_opaque_structure(T), Opaques);
+ false -> T % XXX: needs revision for parametric opaque data types
+ end;
+t_unopaque(?list(ElemT, Termination, Sz), Opaques) ->
+ ?list(t_unopaque(ElemT, Opaques), Termination, Sz);
+t_unopaque(?tuple(?any, _, _) = T, _) -> T;
+t_unopaque(?tuple(ArgTs, Sz, Tag), Opaques) when is_list(ArgTs) ->
+ NewArgTs = [t_unopaque(A, Opaques) || A <- ArgTs],
+ ?tuple(NewArgTs, Sz, Tag);
+t_unopaque(?tuple_set(Set), Opaques) ->
+ NewSet = [{Sz, [t_unopaque(T, Opaques) || T <- Tuples]}
+ || {Sz, Tuples} <- Set],
+ ?tuple_set(NewSet);
+t_unopaque(?union([A,B,F,I,L,N,T,M,O,R]), Opaques) ->
+ UL = t_unopaque(L, Opaques),
+ UT = t_unopaque(T, Opaques),
+ UO = case O of
+ ?none -> [];
+ ?opaque(Os) -> [t_unopaque(S, Opaques) || #opaque{struct = S} <- Os]
+ end,
+ t_sup([?union([A,B,F,I,UL,N,UT,M,?none,R])|UO]);
+t_unopaque(T, _) ->
+ T.
+
+%%-----------------------------------------------------------------------------
+%% K-depth abstraction.
+%%
+%% t_limit/2 is the exported function, which checks the type of the
+%% second argument and calls the module local t_limit_k/2 function.
+%%
+
+-spec t_limit(erl_type(), integer()) -> erl_type().
+
+t_limit(Term, K) when is_integer(K) ->
+ t_limit_k(Term, K).
+
+t_limit_k(_, K) when K =< 0 -> ?any;
+t_limit_k(?tuple(?any, ?any, ?any) = T, _K) -> T;
+t_limit_k(?tuple(Elements, Arity, _), K) ->
+ if K =:= 1 -> t_tuple(Arity);
+ true -> t_tuple([t_limit_k(E, K-1) || E <- Elements])
+ end;
+t_limit_k(?tuple_set(_) = T, K) ->
+ t_sup([t_limit_k(Tuple, K) || Tuple <- t_tuple_subtypes(T)]);
+t_limit_k(?list(Elements, Termination, Size), K) ->
+ NewTermination =
+ if K =:= 1 ->
+ %% We do not want to lose the termination information.
+ t_limit_k(Termination, K);
+ true -> t_limit_k(Termination, K - 1)
+ end,
+ NewElements = t_limit_k(Elements, K - 1),
+ TmpList = t_cons(NewElements, NewTermination),
+ case Size of
+ ?nonempty_qual -> TmpList;
+ ?unknown_qual ->
+ ?list(NewElements1, NewTermination1, _) = TmpList,
+ ?list(NewElements1, NewTermination1, ?unknown_qual)
+ end;
+t_limit_k(?function(Domain, Range), K) ->
+ %% The domain is either a product or any() so we do not decrease the K.
+ ?function(t_limit_k(Domain, K), t_limit_k(Range, K-1));
+t_limit_k(?product(Elements), K) ->
+ ?product([t_limit_k(X, K - 1) || X <- Elements]);
+t_limit_k(?union(Elements), K) ->
+ ?union([t_limit_k(X, K) || X <- Elements]);
+t_limit_k(T, _K) -> T.
+
+%%============================================================================
+%%
+%% Abstract records. Used for comparing contracts.
+%%
+%%============================================================================
+
+-spec t_abstract_records(erl_type(), dict()) -> erl_type().
+
+t_abstract_records(?list(Contents, Termination, Size), RecDict) ->
+ case t_abstract_records(Contents, RecDict) of
+ ?none -> ?none;
+ NewContents ->
+ %% Be careful here to make the termination collapse if necessary.
+ case t_abstract_records(Termination, RecDict) of
+ ?nil -> ?list(NewContents, ?nil, Size);
+ ?any -> ?list(NewContents, ?any, Size);
+ Other ->
+ ?list(NewContents, NewTermination, _) = t_cons(NewContents, Other),
+ ?list(NewContents, NewTermination, Size)
+ end
+ end;
+t_abstract_records(?function(Domain, Range), RecDict) ->
+ ?function(t_abstract_records(Domain, RecDict),
+ t_abstract_records(Range, RecDict));
+t_abstract_records(?product(Types), RecDict) ->
+ ?product([t_abstract_records(T, RecDict) || T <- Types]);
+t_abstract_records(?union(Types), RecDict) ->
+ t_sup([t_abstract_records(T, RecDict) || T <- Types]);
+t_abstract_records(?tuple(?any, ?any, ?any) = T, _RecDict) ->
+ T;
+t_abstract_records(?tuple(Elements, Arity, ?atom(_) = Tag), RecDict) ->
+ [TagAtom] = t_atom_vals(Tag),
+ case lookup_record(TagAtom, Arity - 1, RecDict) of
+ error -> t_tuple([t_abstract_records(E, RecDict) || E <- Elements]);
+ {ok, Fields} -> t_tuple([Tag|[T || {_Name, T} <- Fields]])
+ end;
+t_abstract_records(?tuple(Elements, _Arity, _Tag), RecDict) ->
+ t_tuple([t_abstract_records(E, RecDict) || E <- Elements]);
+t_abstract_records(?tuple_set(_) = Tuples, RecDict) ->
+ t_sup([t_abstract_records(T, RecDict) || T <- t_tuple_subtypes(Tuples)]);
+t_abstract_records(T, _RecDict) ->
+ T.
+
+%% Map over types. Depth first. Used by the contract checker. ?list is
+%% not fully implemented so take care when changing the type in Termination.
+
+-spec t_map(fun((erl_type()) -> erl_type()), erl_type()) -> erl_type().
+
+t_map(Fun, ?list(Contents, Termination, Size)) ->
+ Fun(?list(t_map(Fun, Contents), t_map(Fun, Termination), Size));
+t_map(Fun, ?function(Domain, Range)) ->
+ Fun(?function(t_map(Fun, Domain), t_map(Fun, Range)));
+t_map(Fun, ?product(Types)) ->
+ Fun(?product([t_map(Fun, T) || T <- Types]));
+t_map(Fun, ?union(Types)) ->
+ Fun(t_sup([t_map(Fun, T) || T <- Types]));
+t_map(Fun, ?tuple(?any, ?any, ?any) = T) ->
+ Fun(T);
+t_map(Fun, ?tuple(Elements, _Arity, _Tag)) ->
+ Fun(t_tuple([t_map(Fun, E) || E <- Elements]));
+t_map(Fun, ?tuple_set(_) = Tuples) ->
+ Fun(t_sup([t_map(Fun, T) || T <- t_tuple_subtypes(Tuples)]));
+t_map(Fun, T) ->
+ Fun(T).
+
+%%=============================================================================
+%%
+%% Prettyprinter
+%%
+%%=============================================================================
+
+-spec t_to_string(erl_type()) -> string().
+
+t_to_string(T) ->
+ t_to_string(T, dict:new()).
+
+-spec t_to_string(erl_type(), dict()) -> string().
+
+t_to_string(?any, _RecDict) ->
+ "any()";
+t_to_string(?none, _RecDict) ->
+ "none()";
+t_to_string(?unit, _RecDict) ->
+ "no_return()";
+t_to_string(?atom(?any), _RecDict) ->
+ "atom()";
+t_to_string(?atom(Set), _RecDict) ->
+ case set_size(Set) of
+ 2 ->
+ case set_is_element(true, Set) andalso set_is_element(false, Set) of
+ true -> "boolean()";
+ false -> set_to_string(Set)
+ end;
+ _ ->
+ set_to_string(Set)
+ end;
+t_to_string(?bitstr(8, 0), _RecDict) ->
+ "binary()";
+t_to_string(?bitstr(0, 0), _RecDict) ->
+ "<<>>";
+t_to_string(?bitstr(0, B), _RecDict) ->
+ io_lib:format("<<_:~w>>", [B]);
+t_to_string(?bitstr(U, 0), _RecDict) ->
+ io_lib:format("<<_:_*~w>>", [U]);
+t_to_string(?bitstr(U, B), _RecDict) ->
+ io_lib:format("<<_:~w,_:_*~w>>", [B, U]);
+t_to_string(?function(?any, ?any), _RecDict) ->
+ "fun()";
+t_to_string(?function(?any, Range), RecDict) ->
+ "fun((...) -> " ++ t_to_string(Range, RecDict) ++ ")";
+t_to_string(?function(?product(ArgList), Range), RecDict) ->
+ "fun((" ++ comma_sequence(ArgList, RecDict) ++ ") -> "
+ ++ t_to_string(Range, RecDict) ++ ")";
+t_to_string(?identifier(Set), _RecDict) ->
+ if Set =:= ?any -> "identifier()";
+ true -> sequence([io_lib:format("~w()", [T])
+ || T <- set_to_list(Set)], [], " | ")
+ end;
+t_to_string(?opaque(Set), _RecDict) ->
+ sequence([case is_opaque_builtin(Mod, Name) of
+ true -> io_lib:format("~w()", [Name]);
+ false -> io_lib:format("~w:~w()", [Mod, Name])
+ end
+ || #opaque{mod = Mod, name = Name} <- set_to_list(Set)], [], " | ");
+t_to_string(?matchstate(Pres, Slots), RecDict) ->
+ io_lib:format("ms(~s,~s)", [t_to_string(Pres, RecDict),
+ t_to_string(Slots,RecDict)]);
+t_to_string(?nil, _RecDict) ->
+ "[]";
+t_to_string(?nonempty_list(Contents, Termination), RecDict) ->
+ ContentString = t_to_string(Contents, RecDict),
+ case Termination of
+ ?nil ->
+ case Contents of
+ ?char -> "nonempty_string()";
+ _ -> "["++ContentString++",...]"
+ end;
+ ?any ->
+ %% Just a safety check.
+ case Contents =:= ?any of
+ true -> ok;
+ false ->
+ erlang:error({illegal_list, ?nonempty_list(Contents, Termination)})
+ end,
+ "nonempty_maybe_improper_list()";
+ _ ->
+ case t_is_subtype(t_nil(), Termination) of
+ true ->
+ "nonempty_maybe_improper_list("++ContentString++","
+ ++t_to_string(Termination, RecDict)++")";
+ false ->
+ "nonempty_improper_list("++ContentString++","
+ ++t_to_string(Termination, RecDict)++")"
+ end
+ end;
+t_to_string(?list(Contents, Termination, ?unknown_qual), RecDict) ->
+ ContentString = t_to_string(Contents, RecDict),
+ case Termination of
+ ?nil ->
+ case Contents of
+ ?char -> "string()";
+ _ -> "["++ContentString++"]"
+ end;
+ ?any ->
+ %% Just a safety check.
+ case Contents =:= ?any of
+ true -> ok;
+ false ->
+ L = ?list(Contents, Termination, ?unknown_qual),
+ erlang:error({illegal_list, L})
+ end,
+ "maybe_improper_list()";
+ _ ->
+ case t_is_subtype(t_nil(), Termination) of
+ true ->
+ "maybe_improper_list("++ContentString++","
+ ++t_to_string(Termination, RecDict)++")";
+ false ->
+ "improper_list("++ContentString++","
+ ++t_to_string(Termination, RecDict)++")"
+ end
+ end;
+t_to_string(?int_set(Set), _RecDict) ->
+ set_to_string(Set);
+t_to_string(?byte, _RecDict) -> "byte()";
+t_to_string(?char, _RecDict) -> "char()";
+t_to_string(?integer_pos, _RecDict) -> "pos_integer()";
+t_to_string(?integer_non_neg, _RecDict) -> "non_neg_integer()";
+t_to_string(?integer_neg, _RecDict) -> "neg_integer()";
+t_to_string(?int_range(From, To), _RecDict) ->
+ lists:flatten(io_lib:format("~w..~w", [From, To]));
+t_to_string(?integer(?any), _RecDict) -> "integer()";
+t_to_string(?float, _RecDict) -> "float()";
+t_to_string(?number(?any, ?unknown_qual), _RecDict) -> "number()";
+t_to_string(?product(List), RecDict) ->
+ "<" ++ comma_sequence(List, RecDict) ++ ">";
+t_to_string(?remote(Set), RecDict) ->
+ sequence([case Args =:= [] of
+ true -> io_lib:format("~w:~w()", [Mod, Name]);
+ false ->
+ ArgString = comma_sequence(Args, RecDict),
+ io_lib:format("~w:~w(~s)", [Mod, Name, ArgString])
+ end
+ || #remote{mod = Mod, name = Name, args = Args} <- set_to_list(Set)],
+ [], " | ");
+t_to_string(?tuple(?any, ?any, ?any), _RecDict) -> "tuple()";
+t_to_string(?tuple(Elements, _Arity, ?any), RecDict) ->
+ "{" ++ comma_sequence(Elements, RecDict) ++ "}";
+t_to_string(?tuple(Elements, Arity, Tag), RecDict) ->
+ [TagAtom] = t_atom_vals(Tag),
+ case lookup_record(TagAtom, Arity-1, RecDict) of
+ error -> "{" ++ comma_sequence(Elements, RecDict) ++ "}";
+ {ok, FieldNames} ->
+ record_to_string(TagAtom, Elements, FieldNames, RecDict)
+ end;
+t_to_string(?tuple_set(_) = T, RecDict) ->
+ union_sequence(t_tuple_subtypes(T), RecDict);
+t_to_string(?union(Types), RecDict) ->
+ union_sequence([T || T <- Types, T =/= ?none], RecDict);
+t_to_string(?var(Id), _RecDict) when is_atom(Id) ->
+ io_lib:format("~s", [atom_to_list(Id)]);
+t_to_string(?var(Id), _RecDict) when is_integer(Id) ->
+ io_lib:format("var(~w)", [Id]).
+
+record_to_string(Tag, [_|Fields], FieldNames, RecDict) ->
+ FieldStrings = record_fields_to_string(Fields, FieldNames, RecDict, []),
+ "#" ++ atom_to_list(Tag) ++ "{" ++ sequence(FieldStrings, [], ",") ++ "}".
+
+record_fields_to_string([Field|Left1], [{FieldName, DeclaredType}|Left2],
+ RecDict, Acc) ->
+ PrintType =
+ case t_is_equal(Field, DeclaredType) of
+ true -> false;
+ false ->
+ case t_is_any(DeclaredType) andalso t_is_atom(undefined, Field) of
+ true -> false;
+ false ->
+ TmpType = t_subtract(DeclaredType, t_atom(undefined)),
+ not t_is_equal(Field, TmpType)
+ end
+ end,
+ case PrintType of
+ false -> record_fields_to_string(Left1, Left2, RecDict, Acc);
+ true ->
+ String = atom_to_list(FieldName) ++ "::" ++ t_to_string(Field, RecDict),
+ record_fields_to_string(Left1, Left2, RecDict, [String|Acc])
+ end;
+record_fields_to_string([], [], _RecDict, Acc) ->
+ lists:reverse(Acc).
+
+comma_sequence(Types, RecDict) ->
+ List = [case T =:= ?any of
+ true -> "_";
+ false -> t_to_string(T, RecDict)
+ end || T <- Types],
+ sequence(List, ",").
+
+union_sequence(Types, RecDict) ->
+ List = [t_to_string(T, RecDict) || T <- Types],
+ sequence(List, " | ").
+
+sequence(List, Delimiter) ->
+ sequence(List, [], Delimiter).
+
+sequence([], [], _Delimiter) ->
+ [];
+sequence([T], Acc, _Delimiter) ->
+ lists:flatten(lists:reverse([T|Acc]));
+sequence([T|Left], Acc, Delimiter) ->
+ sequence(Left, [T ++ Delimiter|Acc], Delimiter).
+
+%%=============================================================================
+%%
+%% Build a type from parse forms.
+%%
+%%=============================================================================
+
+-spec t_from_form(parse_form()) -> erl_type().
+
+t_from_form(Form) ->
+ t_from_form(Form, dict:new()).
+
+-spec t_from_form(parse_form(), dict()) -> erl_type().
+
+t_from_form(Form, RecDict) ->
+ t_from_form(Form, RecDict, dict:new()).
+
+-spec t_from_form(parse_form(), dict(), dict()) -> erl_type().
+
+t_from_form({var, _L, '_'}, _RecDict, _VarDict) -> t_any();
+t_from_form({var, _L, Name}, _RecDict, VarDict) ->
+ case dict:find(Name, VarDict) of
+ error -> t_var(Name);
+ {ok, Val} -> Val
+ end;
+t_from_form({ann_type, _L, [_Var, Type]}, RecDict, VarDict) ->
+ t_from_form(Type, RecDict, VarDict);
+t_from_form({paren_type, _L, [Type]}, RecDict, VarDict) ->
+ t_from_form(Type, RecDict, VarDict);
+t_from_form({remote_type, _L, [{atom, _, Module}, {atom, _, Type}, Args]},
+ RecDict, VarDict) ->
+ t_remote(Module, Type, [t_from_form(A, RecDict, VarDict) || A <- Args]);
+t_from_form({atom, _L, Atom}, _RecDict, _VarDict) -> t_atom(Atom);
+t_from_form({integer, _L, Int}, _RecDict, _VarDict) -> t_integer(Int);
+t_from_form({type, _L, any, []}, _RecDict, _VarDict) -> t_any();
+t_from_form({type, _L, arity, []}, _RecDict, _VarDict) -> t_arity();
+t_from_form({type, _L, array, []}, _RecDict, _VarDict) -> t_array();
+t_from_form({type, _L, atom, []}, _RecDict, _VarDict) -> t_atom();
+t_from_form({type, _L, binary, []}, _RecDict, _VarDict) -> t_binary();
+t_from_form({type, _L, binary, [{integer, _, Base}, {integer, _, Unit}]},
+ _RecDict, _VarDict) ->
+ t_bitstr(Unit, Base);
+t_from_form({type, _L, bitstring, []}, _RecDict, _VarDict) -> t_bitstr();
+t_from_form({type, _L, bool, []}, _RecDict, _VarDict) -> t_boolean(); % XXX: Temporarily
+t_from_form({type, _L, boolean, []}, _RecDict, _VarDict) -> t_boolean();
+t_from_form({type, _L, byte, []}, _RecDict, _VarDict) -> t_byte();
+t_from_form({type, _L, char, []}, _RecDict, _VarDict) -> t_char();
+t_from_form({type, _L, dict, []}, _RecDict, _VarDict) -> t_dict();
+t_from_form({type, _L, digraph, []}, _RecDict, _VarDict) -> t_digraph();
+t_from_form({type, _L, float, []}, _RecDict, _VarDict) -> t_float();
+t_from_form({type, _L, function, []}, _RecDict, _VarDict) -> t_fun();
+t_from_form({type, _L, 'fun', []}, _RecDict, _VarDict) -> t_fun();
+t_from_form({type, _L, 'fun', [{type, _, any, []}, Range]}, RecDict, VarDict) ->
+ t_fun(t_from_form(Range, RecDict, VarDict));
+t_from_form({type, _L, 'fun', [{type, _, product, Domain}, Range]},
+ RecDict, VarDict) ->
+ t_fun([t_from_form(D, RecDict, VarDict) || D <- Domain],
+ t_from_form(Range, RecDict, VarDict));
+t_from_form({type, _L, gb_set, []}, _RecDict, _VarDict) -> t_gb_set();
+t_from_form({type, _L, gb_tree, []}, _RecDict, _VarDict) -> t_gb_tree();
+t_from_form({type, _L, identifier, []}, _RecDict, _VarDict) -> t_identifier();
+t_from_form({type, _L, integer, []}, _RecDict, _VarDict) -> t_integer();
+t_from_form({type, _L, iodata, []}, _RecDict, _VarDict) -> t_iodata();
+t_from_form({type, _L, iolist, []}, _RecDict, _VarDict) -> t_iolist();
+t_from_form({type, _L, list, []}, _RecDict, _VarDict) -> t_list();
+t_from_form({type, _L, list, [Type]}, RecDict, VarDict) ->
+ t_list(t_from_form(Type, RecDict, VarDict));
+t_from_form({type, _L, mfa, []}, _RecDict, _VarDict) -> t_mfa();
+t_from_form({type, _L, module, []}, _RecDict, _VarDict) -> t_module();
+t_from_form({type, _L, nil, []}, _RecDict, _VarDict) -> t_nil();
+t_from_form({type, _L, neg_integer, []}, _RecDict, _VarDict) -> t_neg_integer();
+t_from_form({type, _L, non_neg_integer, []}, _RecDict, _VarDict) ->
+ t_non_neg_integer();
+t_from_form({type, _L, no_return, []}, _RecDict, _VarDict) -> t_unit();
+t_from_form({type, _L, node, []}, _RecDict, _VarDict) -> t_node();
+t_from_form({type, _L, none, []}, _RecDict, _VarDict) -> t_none();
+t_from_form({type, _L, nonempty_list, []}, _RecDict, _VarDict) ->
+ t_nonempty_list();
+t_from_form({type, _L, nonempty_list, [Type]}, RecDict, VarDict) ->
+ t_nonempty_list(t_from_form(Type, RecDict, VarDict));
+t_from_form({type, _L, nonempty_improper_list, [Cont, Term]},
+ RecDict, VarDict) ->
+ t_cons(t_from_form(Cont, RecDict, VarDict),
+ t_from_form(Term, RecDict, VarDict));
+t_from_form({type, _L, nonempty_maybe_improper_list, []}, _RecDict, _VarDict) ->
+ t_cons(?any, ?any);
+t_from_form({type, _L, nonempty_maybe_improper_list, [Cont, Term]},
+ RecDict, VarDict) ->
+ t_cons(t_from_form(Cont, RecDict, VarDict),
+ t_from_form(Term, RecDict, VarDict));
+t_from_form({type, _L, nonempty_string, []}, _RecDict, _VarDict) ->
+ t_nonempty_string();
+t_from_form({type, _L, number, []}, _RecDict, _VarDict) -> t_number();
+t_from_form({type, _L, pid, []}, _RecDict, _VarDict) -> t_pid();
+t_from_form({type, _L, port, []}, _RecDict, _VarDict) -> t_port();
+t_from_form({type, _L, pos_integer, []}, _RecDict, _VarDict) -> t_pos_integer();
+t_from_form({type, _L, maybe_improper_list, []}, _RecDict, _VarDict) ->
+ t_maybe_improper_list();
+t_from_form({type, _L, maybe_improper_list, [Content, Termination]},
+ RecDict, VarDict) ->
+ t_maybe_improper_list(t_from_form(Content, RecDict, VarDict),
+ t_from_form(Termination, RecDict, VarDict));
+t_from_form({type, _L, product, Elements}, RecDict, VarDict) ->
+ t_product([t_from_form(E, RecDict, VarDict) || E <- Elements]);
+t_from_form({type, _L, queue, []}, _RecDict, _VarDict) -> t_queue();
+t_from_form({type, _L, range, [{integer, _, From}, {integer, _, To}]},
+ _RecDict, _VarDict) ->
+ t_from_range(From, To);
+t_from_form({type, _L, record, [Name|Fields]}, RecDict, VarDict) ->
+ record_from_form(Name, Fields, RecDict, VarDict);
+t_from_form({type, _L, reference, []}, _RecDict, _VarDict) -> t_reference();
+t_from_form({type, _L, set, []}, _RecDict, _VarDict) -> t_set();
+t_from_form({type, _L, string, []}, _RecDict, _VarDict) -> t_string();
+t_from_form({type, _L, term, []}, _RecDict, _VarDict) -> t_any();
+t_from_form({type, _L, tid, []}, _RecDict, _VarDict) -> t_tid();
+t_from_form({type, _L, timeout, []}, _RecDict, _VarDict) -> t_timeout();
+t_from_form({type, _L, tuple, any}, _RecDict, _VarDict) -> t_tuple();
+t_from_form({type, _L, tuple, Args}, RecDict, VarDict) ->
+ t_tuple([t_from_form(A, RecDict, VarDict) || A <- Args]);
+t_from_form({type, _L, union, Args}, RecDict, VarDict) ->
+ t_sup([t_from_form(A, RecDict, VarDict) || A <- Args]);
+t_from_form({type, _L, Name, Args}, RecDict, VarDict) ->
+ case lookup_type(Name, RecDict) of
+ {type, {_Module, Type, ArgNames}} when length(Args) =:= length(ArgNames) ->
+ List = lists:zipwith(fun(ArgName, ArgType) ->
+ {ArgName, t_from_form(ArgType, RecDict, VarDict)}
+ end, ArgNames, Args),
+ TmpVardict = dict:from_list(List),
+ t_from_form(Type, RecDict, TmpVardict);
+ {opaque, {Module, Type, ArgNames}} when length(Args) =:= length(ArgNames) ->
+ List = lists:zipwith(fun(ArgName, ArgType) ->
+ {ArgName, t_from_form(ArgType, RecDict, VarDict)}
+ end, ArgNames, Args),
+ TmpVardict = dict:from_list(List),
+ Rep = t_from_form(Type, RecDict, TmpVardict),
+ t_from_form({opaque, -1, Name, {Module, Args, Rep}}, RecDict, VarDict);
+ {type, _} ->
+ throw({error, io_lib:format("Unknown type ~w\n", [Name])});
+ {opaque, _} ->
+ throw({error, io_lib:format("Unknown opaque type ~w\n", [Name])});
+ error ->
+ throw({error, io_lib:format("Unable to find type ~w\n", [Name])})
+ end;
+t_from_form({opaque, _L, Name, {Mod, Args, Rep}}, _RecDict, _VarDict) ->
+ case Args of
+ [] -> t_opaque(Mod, Name, Args, Rep);
+ _ -> throw({error, "Polymorphic opaque types not supported yet"})
+ end.
+
+record_from_form({atom, _, Name}, ModFields, RecDict, VarDict) ->
+ case lookup_record(Name, RecDict) of
+ {ok, DeclFields} ->
+ case get_mod_record(ModFields, DeclFields, RecDict, VarDict) of
+ {error, FieldName} ->
+ throw({error, io_lib:format("Illegal declaration of ~w#{~w}\n",
+ [Name, FieldName])});
+ {ok, NewFields} ->
+ t_tuple([t_atom(Name)|[Type || {_FieldName, Type} <- NewFields]])
+ end;
+ error ->
+ throw({error,
+ erlang:error(io_lib:format("Unknown record #~w{}\n", [Name]))})
+ end.
+
+get_mod_record([], DeclFields, _RecDict, _VarDict) ->
+ {ok, DeclFields};
+get_mod_record(ModFields, DeclFields, RecDict, VarDict) ->
+ DeclFieldsDict = orddict:from_list(DeclFields),
+ ModFieldsDict = build_field_dict(ModFields, RecDict, VarDict),
+ case get_mod_record(DeclFieldsDict, ModFieldsDict, []) of
+ {error, _FieldName} = Error -> Error;
+ {ok, FinalOrdDict} ->
+ {ok, [{FieldName, orddict:fetch(FieldName, FinalOrdDict)}
+ || {FieldName, _} <- DeclFields]}
+ end.
+
+build_field_dict(FieldTypes, RecDict, VarDict) ->
+ build_field_dict(FieldTypes, RecDict, VarDict, []).
+
+build_field_dict([{type, _, field_type, [{atom, _, Name}, Type]}|Left],
+ RecDict, VarDict, Acc) ->
+ NewAcc = [{Name, t_from_form(Type, RecDict, VarDict)}|Acc],
+ build_field_dict(Left, RecDict, VarDict, NewAcc);
+build_field_dict([], _RecDict, _VarDict, Acc) ->
+ orddict:from_list(Acc).
+
+get_mod_record([{FieldName, DeclType}|Left1],
+ [{FieldName, ModType}|Left2], Acc) ->
+ case t_is_var(ModType) orelse t_is_subtype(ModType, DeclType) of
+ false -> {error, FieldName};
+ true -> get_mod_record(Left1, Left2, [{FieldName, ModType}|Acc])
+ end;
+get_mod_record([{FieldName1, _DeclType} = DT|Left1],
+ [{FieldName2, _ModType}|_] = List2,
+ Acc) when FieldName1 < FieldName2 ->
+ get_mod_record(Left1, List2, [DT|Acc]);
+get_mod_record(DeclFields, [], Acc) ->
+ {ok, orddict:from_list(Acc ++ DeclFields)};
+get_mod_record(_, [{FieldName2, _ModType}|_], _Acc) ->
+ {error, FieldName2}.
+
+-spec t_form_to_string(parse_form()) -> string().
+
+t_form_to_string({var, _L, '_'}) -> "_";
+t_form_to_string({var, _L, Name}) -> atom_to_list(Name);
+t_form_to_string({atom, _L, Atom}) ->
+ io_lib:write_string(atom_to_list(Atom), $'); % To quote or not to quote... '
+t_form_to_string({integer, _L, Int}) -> integer_to_list(Int);
+t_form_to_string({ann_type, _L, [Var, Type]}) ->
+ t_form_to_string(Var) ++ "::" ++ t_form_to_string(Type);
+t_form_to_string({paren_type, _L, [Type]}) ->
+ io_lib:format("(~s)", [t_form_to_string(Type)]);
+t_form_to_string({remote_type, _L, [{atom, _, Mod}, {atom, _, Name}, Args]}) ->
+ ArgString = "(" ++ sequence(t_form_to_string_list(Args), ",") ++ ")",
+ io_lib:format("~w:~w", [Mod, Name]) ++ ArgString;
+t_form_to_string({type, _L, arity, []}) -> "arity()";
+t_form_to_string({type, _L, 'fun', []}) -> "fun()";
+t_form_to_string({type, _L, 'fun', [{type, _, any, []}, Range]}) ->
+ "fun(...) -> " ++ t_form_to_string(Range);
+t_form_to_string({type, _L, 'fun', [{type, _, product, Domain}, Range]}) ->
+ "fun((" ++ sequence(t_form_to_string_list(Domain), ",") ++ ") -> "
+ ++ t_form_to_string(Range) ++ ")";
+t_form_to_string({type, _L, iodata, []}) -> "iodata()";
+t_form_to_string({type, _L, iolist, []}) -> "iolist()";
+t_form_to_string({type, _L, list, [Type]}) ->
+ "[" ++ t_form_to_string(Type) ++ "]";
+t_form_to_string({type, _L, mfa, []}) -> "mfa()";
+t_form_to_string({type, _L, module, []}) -> "module()";
+t_form_to_string({type, _L, node, []}) -> "node()";
+t_form_to_string({type, _L, nonempty_list, [Type]}) ->
+ "[" ++ t_form_to_string(Type) ++ ",...]";
+t_form_to_string({type, _L, nonempty_string, []}) -> "nonempty_string()";
+t_form_to_string({type, _L, product, Elements}) ->
+ "<" ++ sequence(t_form_to_string_list(Elements), ",") ++ ">";
+t_form_to_string({type, _L, range, [{integer, _, From}, {integer, _, To}]}) ->
+ io_lib:format("~w..~w", [From, To]);
+t_form_to_string({type, _L, record, [{atom, _, Name}]}) ->
+ io_lib:format("#~w{}", [Name]);
+t_form_to_string({type, _L, record, [{atom, _, Name}|Fields]}) ->
+ FieldString = sequence(t_form_to_string_list(Fields), ","),
+ io_lib:format("#~w{~s}", [Name, FieldString]);
+t_form_to_string({type, _L, field_type, [{atom, _, Name}, Type]}) ->
+ io_lib:format("~w::~s", [Name, t_form_to_string(Type)]);
+t_form_to_string({type, _L, term, []}) -> "term()";
+t_form_to_string({type, _L, timeout, []}) -> "timeout()";
+t_form_to_string({type, _L, tuple, any}) -> "tuple()";
+t_form_to_string({type, _L, tuple, Args}) ->
+ "{" ++ sequence(t_form_to_string_list(Args), ",") ++ "}";
+t_form_to_string({type, _L, union, Args}) ->
+ sequence(t_form_to_string_list(Args), " | ");
+t_form_to_string({type, _L, Name, []} = T) ->
+ try t_to_string(t_from_form(T))
+ catch throw:{error, _} -> atom_to_list(Name) ++ "()"
+ end;
+t_form_to_string({type, _L, binary, [{integer, _, X}, {integer, _, Y}]}) ->
+ case Y of
+ 0 ->
+ case X of
+ 0 -> "<<>>";
+ _ -> io_lib:format("<<_:~w>>", [X])
+ end
+ end;
+t_form_to_string({type, _L, Name, List}) ->
+ io_lib:format("~w(~s)", [Name, sequence(t_form_to_string_list(List), ",")]).
+
+t_form_to_string_list(List) ->
+ t_form_to_string_list(List, []).
+
+t_form_to_string_list([H|T], Acc) ->
+ t_form_to_string_list(T, [t_form_to_string(H)|Acc]);
+t_form_to_string_list([], Acc) ->
+ lists:reverse(Acc).
+
+%%=============================================================================
+%%
+%% Utilities
+%%
+%%=============================================================================
+
+-spec any_none([erl_type()]) -> boolean().
+
+any_none([?none|_Left]) -> true;
+any_none([_|Left]) -> any_none(Left);
+any_none([]) -> false.
+
+-spec any_none_or_unit([erl_type()]) -> boolean().
+
+any_none_or_unit([?none|_]) -> true;
+any_none_or_unit([?unit|_]) -> true;
+any_none_or_unit([_|Left]) -> any_none_or_unit(Left);
+any_none_or_unit([]) -> false.
+
+-spec lookup_record(atom(), dict()) -> 'error' | {'ok', [{atom(), erl_type()}]}.
+
+lookup_record(Tag, RecDict) when is_atom(Tag) ->
+ case dict:find({record, Tag}, RecDict) of
+ {ok, [{_Arity, Fields}]} -> {ok, Fields};
+ {ok, List} when is_list(List) ->
+ %% This will have to do, since we do not know which record we
+ %% are looking for.
+ error;
+ error ->
+ error
+ end.
+
+-spec lookup_record(atom(), arity(), dict()) -> 'error' | {'ok', [{atom(), erl_type()}]}.
+
+lookup_record(Tag, Arity, RecDict) when is_atom(Tag) ->
+ case dict:find({record, Tag}, RecDict) of
+ {ok, [{Arity, Fields}]} -> {ok, Fields};
+ {ok, OrdDict} -> orddict:find(Arity, OrdDict);
+ error -> error
+ end.
+
+lookup_type(Name, RecDict) ->
+ case dict:find({type, Name}, RecDict) of
+ error ->
+ case dict:find({opaque, Name}, RecDict) of
+ error -> error;
+ {ok, Found} -> {opaque, Found}
+ end;
+ {ok, Found} -> {type, Found}
+ end.
+
+-spec type_is_defined('type' | 'opaque', atom(), dict()) -> boolean().
+
+type_is_defined(TypeOrOpaque, Name, RecDict) ->
+ dict:is_key({TypeOrOpaque, Name}, RecDict).
+
+%% -----------------------------------
+%% Set
+%%
+
+set_singleton(Element) ->
+ ordsets:from_list([Element]).
+
+set_is_singleton(Element, Set) ->
+ set_singleton(Element) =:= Set.
+
+set_is_element(Element, Set) ->
+ ordsets:is_element(Element, Set).
+
+set_union(?any, _) -> ?any;
+set_union(_, ?any) -> ?any;
+set_union(S1, S2) ->
+ case ordsets:union(S1, S2) of
+ S when length(S) =< ?SET_LIMIT -> S;
+ _ -> ?any
+ end.
+
+set_union_no_limit(?any, _) -> ?any;
+set_union_no_limit(_, ?any) -> ?any;
+set_union_no_limit(S1, S2) -> ordsets:union(S1, S2).
+
+%% The intersection and subtraction can return ?none.
+%% This should always be handled right away since ?none is not a valid set.
+%% However, ?any is considered a valid set.
+
+set_intersection(?any, S) -> S;
+set_intersection(S, ?any) -> S;
+set_intersection(S1, S2) ->
+ case ordsets:intersection(S1, S2) of
+ [] -> ?none;
+ S -> S
+ end.
+
+set_subtract(_, ?any) -> ?none;
+set_subtract(?any, _) -> ?any;
+set_subtract(S1, S2) ->
+ case ordsets:subtract(S1, S2) of
+ [] -> ?none;
+ S -> S
+ end.
+
+set_from_list(List) ->
+ case length(List) of
+ L when L =< ?SET_LIMIT -> ordsets:from_list(List);
+ L when L > ?SET_LIMIT -> ?any
+ end.
+
+set_to_list(Set) ->
+ ordsets:to_list(Set).
+
+set_filter(Fun, Set) ->
+ case ordsets:filter(Fun, Set) of
+ [] -> ?none;
+ NewSet -> NewSet
+ end.
+
+set_size(Set) ->
+ ordsets:size(Set).
+
+set_to_string(Set) ->
+ L = [case is_atom(X) of
+ true -> io_lib:write_string(atom_to_list(X), $'); % stupid emacs '
+ false -> io_lib:format("~w", [X])
+ end || X <- set_to_list(Set)],
+ sequence(L, [], " | ").
+
+set_min([H|_]) -> H.
+
+set_max(Set) ->
+ hd(lists:reverse(Set)).
+
+%%=============================================================================
+%%
+%% Utilities for the binary type
+%%
+%%=============================================================================
+
+-spec gcd(integer(), integer()) -> integer().
+
+gcd(A, B) when B > A ->
+ gcd1(B, A);
+gcd(A, B) ->
+ gcd1(A, B).
+
+-spec gcd1(integer(), integer()) -> integer().
+
+gcd1(A, 0) -> A;
+gcd1(A, B) ->
+ case A rem B of
+ 0 -> B;
+ X -> gcd1(B, X)
+ end.
+
+-spec bitstr_concat(erl_type(), erl_type()) -> erl_type().
+
+bitstr_concat(?none, _) -> ?none;
+bitstr_concat(_, ?none) -> ?none;
+bitstr_concat(?bitstr(U1, B1), ?bitstr(U2, B2)) ->
+ t_bitstr(gcd(U1, U2), B1+B2).
+
+-spec bitstr_match(erl_type(), erl_type()) -> erl_type().
+
+bitstr_match(?none, _) -> ?none;
+bitstr_match(_, ?none) -> ?none;
+bitstr_match(?bitstr(0, B1), ?bitstr(0, B2)) when B1 =< B2 ->
+ t_bitstr(0, B2-B1);
+bitstr_match(?bitstr(0, _B1), ?bitstr(0, _B2)) ->
+ ?none;
+bitstr_match(?bitstr(0, B1), ?bitstr(U2, B2)) when B1 =< B2 ->
+ t_bitstr(U2, B2-B1);
+bitstr_match(?bitstr(0, B1), ?bitstr(U2, B2)) ->
+ t_bitstr(U2, handle_base(U2, B2-B1));
+bitstr_match(?bitstr(_, B1), ?bitstr(0, B2)) when B1 > B2 ->
+ ?none;
+bitstr_match(?bitstr(U1, B1), ?bitstr(U2, B2)) ->
+ GCD = gcd(U1, U2),
+ t_bitstr(GCD, handle_base(GCD, B2-B1)).
+
+-spec handle_base(integer(), integer()) -> integer().
+
+handle_base(Unit, Pos) when Pos >= 0 ->
+ Pos rem Unit;
+handle_base(Unit, Neg) ->
+ (Unit+(Neg rem Unit)) rem Unit.
+
+%%=============================================================================
+%% Consistency-testing function(s) below
+%%=============================================================================
+
+-ifdef(DO_ERL_TYPES_TEST).
+
+test() ->
+ Atom1 = t_atom(),
+ Atom2 = t_atom(foo),
+ Atom3 = t_atom(bar),
+ true = t_is_atom(Atom2),
+
+ True = t_atom(true),
+ False = t_atom(false),
+ Bool = t_boolean(),
+ true = t_is_boolean(True),
+ true = t_is_boolean(Bool),
+ false = t_is_boolean(Atom1),
+
+ Binary = t_binary(),
+ true = t_is_binary(Binary),
+
+ Bitstr = t_bitstr(),
+ true = t_is_bitstr(Bitstr),
+
+ Bitstr1 = t_bitstr(7, 3),
+ true = t_is_bitstr(Bitstr1),
+ false = t_is_binary(Bitstr1),
+
+ Bitstr2 = t_bitstr(16, 8),
+ true = t_is_bitstr(Bitstr2),
+ true = t_is_binary(Bitstr2),
+
+ ?bitstr(8, 16) = t_subtract(t_bitstr(4, 12), t_bitstr(8, 12)),
+ ?bitstr(8, 16) = t_subtract(t_bitstr(4, 12), t_bitstr(8, 12)),
+
+ Int1 = t_integer(),
+ Int2 = t_integer(1),
+ Int3 = t_integer(16#ffffffff),
+ true = t_is_integer(Int2),
+ true = t_is_byte(Int2),
+ false = t_is_byte(Int3),
+ false = t_is_byte(t_from_range(-1, 1)),
+ true = t_is_byte(t_from_range(1, ?MAX_BYTE)),
+
+ Tuple1 = t_tuple(),
+ Tuple2 = t_tuple(3),
+ Tuple3 = t_tuple([Atom1, Int1]),
+ Tuple4 = t_tuple([Tuple1, Tuple2]),
+ Tuple5 = t_tuple([Tuple3, Tuple4]),
+ Tuple6 = t_limit(Tuple5, 2),
+ Tuple7 = t_limit(Tuple5, 3),
+ true = t_is_tuple(Tuple1),
+
+ Port = t_port(),
+ Pid = t_pid(),
+ Ref = t_reference(),
+ Identifier = t_identifier(),
+ false = t_is_reference(Port),
+ true = t_is_identifier(Port),
+
+ Function1 = t_fun(),
+ Function2 = t_fun(Pid),
+ Function3 = t_fun([], Pid),
+ Function4 = t_fun([Port, Pid], Pid),
+ Function5 = t_fun([Pid, Atom1], Int2),
+ true = t_is_fun(Function3),
+
+ List1 = t_list(),
+ List2 = t_list(t_boolean()),
+ List3 = t_cons(t_boolean(), List2),
+ List4 = t_cons(t_boolean(), t_atom()),
+ List5 = t_cons(t_boolean(), t_nil()),
+ List6 = t_cons_tl(List5),
+ List7 = t_sup(List4, List5),
+ List8 = t_inf(List7, t_list()),
+ List9 = t_cons(),
+ List10 = t_cons_tl(List9),
+ true = t_is_boolean(t_cons_hd(List5)),
+ true = t_is_list(List5),
+ false = t_is_list(List4),
+
+ Product1 = t_product([Atom1, Atom2]),
+ Product2 = t_product([Atom3, Atom1]),
+ Product3 = t_product([Atom3, Atom2]),
+
+ Union1 = t_sup(Atom2, Atom3),
+ Union2 = t_sup(Tuple2, Tuple3),
+ Union3 = t_sup(Int2, Atom3),
+ Union4 = t_sup(Port, Pid),
+ Union5 = t_sup(Union4, Int1),
+ Union6 = t_sup(Function1, Function2),
+ Union7 = t_sup(Function4, Function5),
+ Union8 = t_sup(True, False),
+ true = t_is_boolean(Union8),
+ Union9 = t_sup(Int2, t_integer(2)),
+ true = t_is_byte(Union9),
+ Union10 = t_sup(t_tuple([t_atom(true), ?any]),
+ t_tuple([t_atom(false), ?any])),
+
+ ?any = t_sup(Product3, Function5),
+
+ Atom3 = t_inf(Union3, Atom1),
+ Union2 = t_inf(Union2, Tuple1),
+ Int2 = t_inf(Int1, Union3),
+ Union4 = t_inf(Union4, Identifier),
+ Port = t_inf(Union5, Port),
+ Function4 = t_inf(Union7, Function4),
+ ?none = t_inf(Product2, Atom1),
+ Product3 = t_inf(Product1, Product2),
+ Function5 = t_inf(Union7, Function5),
+ true = t_is_byte(t_inf(Union9, t_number())),
+ true = t_is_char(t_inf(Union9, t_number())),
+
+ io:format("3? ~p ~n", [?int_set([3])]),
+
+ RecDict = dict:store({foo, 2}, [bar, baz], dict:new()),
+ Record1 = t_from_term({foo, [1,2], {1,2,3}}),
+
+ Types = [
+ Atom1,
+ Atom2,
+ Atom3,
+ Binary,
+ Int1,
+ Int2,
+ Tuple1,
+ Tuple2,
+ Tuple3,
+ Tuple4,
+ Tuple5,
+ Tuple6,
+ Tuple7,
+ Ref,
+ Port,
+ Pid,
+ Identifier,
+ List1,
+ List2,
+ List3,
+ List4,
+ List5,
+ List6,
+ List7,
+ List8,
+ List9,
+ List10,
+ Function1,
+ Function2,
+ Function3,
+ Function4,
+ Function5,
+ Product1,
+ Product2,
+ Record1,
+ Union1,
+ Union2,
+ Union3,
+ Union4,
+ Union5,
+ Union6,
+ Union7,
+ Union8,
+ Union10,
+ t_inf(Union10, t_tuple([t_atom(true), t_integer()]))
+ ],
+ io:format("~p\n", [[t_to_string(X, RecDict) || X <- Types]]).
+
+-endif.
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-10 16:23:50 +0000