From 84adefa331c4159d432d22840663c38f155cd4c1 Mon Sep 17 00:00:00 2001 From: Erlang/OTP Date: Fri, 20 Nov 2009 14:54:40 +0000 Subject: The R13B03 release. --- lib/hipe/cerl/Makefile | 107 + lib/hipe/cerl/cerl_cconv.erl | 777 +++++ lib/hipe/cerl/cerl_closurean.erl | 862 ++++++ lib/hipe/cerl/cerl_hipe_primops.hrl | 88 + lib/hipe/cerl/cerl_hipeify.erl | 655 ++++ lib/hipe/cerl/cerl_hybrid_transform.erl | 153 + lib/hipe/cerl/cerl_lib.erl | 462 +++ lib/hipe/cerl/cerl_messagean.erl | 1105 +++++++ lib/hipe/cerl/cerl_pmatch.erl | 624 ++++ lib/hipe/cerl/cerl_prettypr.erl | 883 ++++++ lib/hipe/cerl/cerl_to_icode.erl | 2717 +++++++++++++++++ lib/hipe/cerl/cerl_typean.erl | 1003 ++++++ lib/hipe/cerl/erl_bif_types.erl | 5021 +++++++++++++++++++++++++++++++ lib/hipe/cerl/erl_types.erl | 3847 +++++++++++++++++++++++ 14 files changed, 18304 insertions(+) create mode 100644 lib/hipe/cerl/Makefile create mode 100644 lib/hipe/cerl/cerl_cconv.erl create mode 100644 lib/hipe/cerl/cerl_closurean.erl create mode 100644 lib/hipe/cerl/cerl_hipe_primops.hrl create mode 100644 lib/hipe/cerl/cerl_hipeify.erl create mode 100644 lib/hipe/cerl/cerl_hybrid_transform.erl create mode 100644 lib/hipe/cerl/cerl_lib.erl create mode 100644 lib/hipe/cerl/cerl_messagean.erl create mode 100644 lib/hipe/cerl/cerl_pmatch.erl create mode 100644 lib/hipe/cerl/cerl_prettypr.erl create mode 100644 lib/hipe/cerl/cerl_to_icode.erl create mode 100644 lib/hipe/cerl/cerl_typean.erl create mode 100644 lib/hipe/cerl/erl_bif_types.erl create mode 100644 lib/hipe/cerl/erl_types.erl (limited to 'lib/hipe/cerl') 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 +%% @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 +%% transform/2 for details. +%% +%%

Use the compiler option {core_transform, cerl_cconv} +%% to insert this function as a compilation pass.

+%% +%% @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" +%% +%%

See the module {@link cerl_to_icode} for details.

+ +-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: richardc@it.uu.se +%% ===================================================================== + +%% 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: richardc@it.uu.se +%% ===================================================================== + +%% 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 +%% @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 +%% transform/2 for details. +%% +%%

Use the compiler option {core_transform, +%% cerl_hipeify} to insert this function as a compilation +%% pass.

+%% +%% @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 cerl_to_icode 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. +%% +%%

Syntax trees are defined in the module cerl.

+%% +%% @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 ' is equivalent to `' if `' 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 do ' to `do do + %% ' 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 in Y' is equivalent to `do + %% let X = in Y'. Note that `' 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 = in ': + [V] = Vs, + N1 = cerl:var_name(V), + N2 = cerl:var_name(B), + if N1 =:= N2 -> + %% `let X = in X' equals `' + A; + true -> + %% `let X = in Y' when X and Y + %% are different variables is + %% equivalent to `do Y'. + reduce_expr(cerl:c_seq(A, B), Check) + end; + literal -> + %% `let X = in T' when T is a literal + %% term is equivalent to `do 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: richardc@it.uu.se +%% ===================================================================== + +%% 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, "
\n"),
+%%     io:put_chars(FD, html(Txt)),
+%%     io:put_chars(FD, "
\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, "
\n"),
+%%     io:put_chars(FD, html(Txt)),
+%%     io:put_chars(FD, "
\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 = "", +%% End = ""; +%% false -> +%% Start = "", +%% End = "" +%% end, +%% markup(Doc, Start, End); +%% true -> +%% Cont(Node, Ctxt) +%% end. + +%% color(Doc) -> +%% % Doc. +%% markup(Doc, "", ""). + +%% 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 +%% @copyright 2000-2006 Richard Carlsson +%% +%% @doc Core Erlang pattern matching compiler. +%% +%%

For reference, see Simon L. Peyton Jones "The Implementation of +%% Functional Programming Languages", chapter 5 (by Phil Wadler).

+%% +%% @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 +%% transform/2 for details. +%% +%%

Use the compiler option {core_transform, cerl_pmatch} +%% to insert this function as a compilation pass.

+%% +%% @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 case-clauses in Module. +%% receive-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 +%% {Expr, Vars}, where Expr is the resulting +%% expression, and Vars 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 +%% E is a Core Erlang case expression): +%% 
+%%   handle_case(E, Env) ->
+%%       Cs = case_clauses(E),
+%%       {E1, Vs} = cerl_pmatch(Cs, Env),
+%%       c_let(Vs, case_arg(E), E1).
+%%
+%% +%%

The environment is used for generating new variables which do not +%% shadow existing bindings.

+%% +%% @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 case-clauses in +%% Expression. receive-clauses are not +%% affected. +%% +%%

The environment is used for generating new variables which do not +%% shadow existing bindings.

+%% +%% @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: richardc@it.uu.se +%% ===================================================================== +%% +%% @doc Core Erlang prettyprinter. +%% +%%

This module is a front end to the pretty-printing library module +%% prettypr, for text formatting of Core Erlang abstract +%% syntax trees defined by the module cerl.

+ +%% 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. +%% +%%

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.

+%% +%% @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. +%% +%%

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.

+%% +%% @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 format/2. +%% +%% @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. +%% +%%

Available options: +%%

+%%
{hook, none | hook()}
+%%
Unless the value is none, the given function +%% is called for every node; see below for details. The default +%% value is none.
+%% +%%
{noann, boolean()}
+%%
If the value is true, annotations on the code +%% are not printed. The default value is false.
+%% +%%
{paper, integer()}
+%%
Specifies the preferred maximum number of characters on any +%% line, including indentation. The default value is 76.
+%% +%%
{ribbon, integer()}
+%%
Specifies the preferred maximum number of characters on any +%% line, not counting indentation. The default value is 45.
+%% +%%
{user, term()}
+%%
User-specific data for use in hook functions. The default +%% value is undefined.
+%%

+%% +%%

A hook function (cf. the hook() type) is passed the current +%% syntax tree node, the context, and a continuation. The context can be +%% examined and manipulated by functions such as +%% get_ctxt_user/1 and set_ctxt_user/2. The +%% hook must return a "document" data structure (see +%% layout/2 and best/2); this may be +%% constructed in part or in whole by applying the continuation +%% function. For example, the following is a trivial hook: +%% 

+%%     fun (Node, Ctxt, Cont) -> Cont(Node, Ctxt) end
+%%
+%% which yields the same result as if no hook was given. +%% The following, however: +%% 
+%%     fun (Node, Ctxt, Cont) ->
+%%         Doc = Cont(Node, Ctxt),
+%%         prettypr:beside(prettypr:text("<b>"),
+%%                         prettypr:beside(Doc,
+%%                                         prettypr:text("</b>")))
+%%     end
+%%
+%% will place the text of any annotated node (regardless of the +%% annotation data) between HTML "boldface begin" and "boldface end" +%% tags. The function annotate/3 is exported for use in +%% hook functions.

+%% +%% @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 layout/2 function, except +%% that here, the final layout has been selected with respect to the +%% given options. The atom empty is returned if no such +%% layout could be produced. For information on the options, see the +%% format/2 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 Terms around the +%% given abstract document. This function is exported mainly for use in +%% hook functions; see format/2. +%% +%% @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 +%% prettypr). For information on the options, see +%% format/2; note, however, that the paper and +%% ribbon options are ignored by this function. +%% +%%

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 prettypr +%% module, or used in a hook function (see format/2 for +%% details).

+%% +%% @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 +%% @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. +%% +%%

This function first calls the {@link cerl_hipeify:transform/2} +%% function on the module.

+%% +%%

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.

+%% +%% @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). +%% +%%

`Degree' specifies the number of values the function is expected +%% to return; this is typically 1 (one); cf. {@link function/3}.

+%% +%%

Notes: +%%

    +%%
  • This function assumes that the code has been transformed into a +%% very simple and explicit form, using the {@link cerl_hipeify} +%% module.
    • +%% +%%
  • Several primops (see "`cerl_hipe_primops.hrl'") are +%% detected by the translation and handled specially.
    • +%% +%%
  • Tail call optimization is handled, even when the call is +%% "hidden" by let-definitions.
    • +%% +%%
  • 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 actual inter-module calls - not +%% primitive or built-in operations.
    • +%% +%%
  • 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.
    • +%% +%%
  • 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.
    • +%%

+%% +%%

Important: 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.

+%% +%%

`receive'-expressions are expected to have a particular +%% form: +%%

    +%%
  • 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.
    • +%% +%%
  • 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.
    • +%%

+%% +%% @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 + +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} -> + <>; + {0, 4} -> + <>; + {2, 0} -> + <>; + {0, 0} -> + <> + end; + float -> + case FlagVal band 2 of + 2 -> + <>; + 0 -> + <> + 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: richardc@it.uu.se +%% +%% @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 annotate/1 for details. +%% +%%

Use the compiler option {core_transform, cerl_typean} +%% to insert this function as a compilation pass.

+%% +%% @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: richardc@it.uu.se, tobiasl@it.uu.se, kostis@it.uu.se +%% ===================================================================== + +-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: richardc@it.uu.se, tobiasl@it.uu.se, kostis@cs.ntua.gr +%% ====================================================================== + +-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. -- cgit v1.2.3