Sign Up
Log In
Log In
or
Sign Up
Places
All Projects
Status Monitor
Collapse sidebar
home:Ledest:erlang:24
erlang
2018-Remove-unused-cerl_-modules.patch
Overview
Repositories
Revisions
Requests
Users
Attributes
Meta
File 2018-Remove-unused-cerl_-modules.patch of Package erlang
From c91eaa17e235ec2e9acbb922f2b3bacd792d488f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Gustavsson?= <bjorn@erlang.org> Date: Fri, 17 Sep 2021 08:39:39 +0200 Subject: [PATCH 18/20] Remove unused cerl_* modules --- lib/dialyzer/src/Makefile | 4 - lib/dialyzer/src/cerl_closurean.erl | 856 ------------------------ lib/dialyzer/src/cerl_lib.erl | 457 ------------- lib/dialyzer/src/cerl_pmatch.erl | 620 ----------------- lib/dialyzer/src/cerl_typean.erl | 994 ---------------------------- lib/dialyzer/src/dialyzer.app.src | 6 +- 6 files changed, 1 insertion(+), 2936 deletions(-) delete mode 100644 lib/dialyzer/src/cerl_closurean.erl delete mode 100644 lib/dialyzer/src/cerl_lib.erl delete mode 100644 lib/dialyzer/src/cerl_pmatch.erl delete mode 100644 lib/dialyzer/src/cerl_typean.erl diff --git a/lib/dialyzer/src/Makefile b/lib/dialyzer/src/Makefile index 0847da9d5a..5e69bd147e 100644 --- a/lib/dialyzer/src/Makefile +++ b/lib/dialyzer/src/Makefile @@ -47,11 +47,7 @@ DIALYZER_DIR = $(ERL_TOP)/lib/dialyzer # Target Specs # ---------------------------------------------------- MODULES = \ - cerl_closurean \ - cerl_lib \ - cerl_pmatch \ cerl_prettypr \ - cerl_typean \ dialyzer \ dialyzer_analysis_callgraph \ dialyzer_behaviours \ diff --git a/lib/dialyzer/src/cerl_closurean.erl b/lib/dialyzer/src/cerl_closurean.erl deleted file mode 100644 index e4718cb819..0000000000 --- a/lib/dialyzer/src/cerl_closurean.erl +++ /dev/null @@ -1,856 +0,0 @@ -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. -%% -%% @copyright 2001-2002 Richard Carlsson -%% @author Richard Carlsson <carlsson.richard@gmail.com> -%% @doc Closure analysis of Core Erlang programs. - -%% 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:dict(), - escapes(), dict:dict(), 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:dict(), escapes(), dict:dict(), 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([{version, 2}])}. - -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(recv_wait_timeout, 1) -> false; -is_escape_op(F, A) when is_atom(F), is_integer(A) -> true. - --spec is_escape_op(atom(), 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(recv_wait_timeout, 1) -> true; -is_literal_op(match_fail, 1) -> true; -is_literal_op(F, A) when is_atom(F), is_integer(A) -> false. - --spec is_literal_op(atom(), 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/dialyzer/src/cerl_lib.erl b/lib/dialyzer/src/cerl_lib.erl deleted file mode 100644 index 3a6fb1cf51..0000000000 --- a/lib/dialyzer/src/cerl_lib.erl +++ /dev/null @@ -1,457 +0,0 @@ -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. -%% -%% @copyright 1999-2002 Richard Carlsson -%% @author Richard Carlsson <carlsson.richard@gmail.com> -%% @doc Utility functions for Core Erlang abstract syntax trees. -%% -%% <p>Syntax trees are defined in the module <a -%% href=""><code>cerl</code></a>.</p> -%% -%% @type cerl() = cerl:cerl() - --module(cerl_lib). - --define(NO_UNUSED, true). - --export([is_safe_expr/2, reduce_expr/1, is_simple_clause/1, - is_bool_switch/1, bool_switch_cases/1]). --ifndef(NO_UNUSED). --export([is_safe_expr/1, is_pure_expr/1, is_pure_expr/2, - make_bool_switch/3]). --endif. - - -%% Test if a clause has a single pattern and an always-true guard. - --spec is_simple_clause(cerl:c_clause()) -> boolean(). - -is_simple_clause(C) -> - case cerl:clause_pats(C) of - [_P] -> - G = cerl:clause_guard(C), - case cerl_clauses:eval_guard(G) of - {value, true} -> true; - _ -> false - end; - _ -> false - end. - -%% Creating an if-then-else construct that can be recognized as such. -%% `Test' *must* be guaranteed to return a boolean. - --ifndef(NO_UNUSED). -make_bool_switch(Test, True, False) -> - Cs = [cerl:c_clause([cerl:c_atom(true)], True), - cerl:c_clause([cerl:c_atom(false)], False)], - cerl:c_case(Test, Cs). --endif. - -%% A boolean switch cannot have a catch-all; only true/false branches. - --spec is_bool_switch([cerl:c_clause()]) -> boolean(). - -is_bool_switch([C1, C2]) -> - case is_simple_clause(C1) andalso is_simple_clause(C2) of - true -> - [P1] = cerl:clause_pats(C1), - [P2] = cerl:clause_pats(C2), - case cerl:is_c_atom(P1) andalso cerl:is_c_atom(P2) of - true -> - A1 = cerl:concrete(P1), - A2 = cerl:concrete(P2), - is_boolean(A1) andalso is_boolean(A2) - andalso A1 =/= A2; - false -> - false - end; - false -> - false - end; -is_bool_switch(_) -> - false. - -%% Returns the true-body and the false-body for boolean switch clauses. - --spec bool_switch_cases([cerl:c_clause()]) -> {cerl:cerl(), cerl:cerl()}. - -bool_switch_cases([C1, C2]) -> - B1 = cerl:clause_body(C1), - B2 = cerl:clause_body(C2), - [P1] = cerl:clause_pats(C1), - case cerl:concrete(P1) of - true -> - {B1, B2}; - false -> - {B2, B1} - end. - -%% -%% The type of the check functions like the default check below - XXX: refine -%% --type check_fun() :: fun((_, _) -> boolean()). - -%% The default function property check always returns `false': - -default_check(_Property, _Function) -> false. - - -%% @spec is_safe_expr(Expr::cerl()) -> boolean() -%% -%% @doc Returns `true' if `Expr' represents a "safe" Core Erlang -%% expression, otherwise `false'. An expression is safe if it always -%% completes normally and does not modify the state (although the return -%% value may depend on the state). -%% -%% Expressions of type `apply', `case', `receive' and `binary' are -%% always considered unsafe by this function. - -%% TODO: update cerl_inline to use these functions instead. - --ifndef(NO_UNUSED). -is_safe_expr(E) -> - Check = fun default_check/2, - is_safe_expr(E, Check). --endif. -%% @clear - --spec is_safe_expr(cerl:cerl(), check_fun()) -> boolean(). - -is_safe_expr(E, Check) -> - case cerl:type(E) of - literal -> - true; - var -> - true; - 'fun' -> - true; - values -> - is_safe_expr_list(cerl:values_es(E), Check); - tuple -> - is_safe_expr_list(cerl:tuple_es(E), Check); - cons -> - case is_safe_expr(cerl:cons_hd(E), Check) of - true -> - is_safe_expr(cerl:cons_tl(E), Check); - false -> - false - end; - 'let' -> - case is_safe_expr(cerl:let_arg(E), Check) of - true -> - is_safe_expr(cerl:let_body(E), Check); - false -> - false - end; - letrec -> - is_safe_expr(cerl:letrec_body(E), Check); - seq -> - case is_safe_expr(cerl:seq_arg(E), Check) of - true -> - is_safe_expr(cerl:seq_body(E), Check); - false -> - false - end; - 'catch' -> - is_safe_expr(cerl:catch_body(E), Check); - 'try' -> - %% If the guarded expression is safe, the try-handler will - %% never be evaluated, so we need only check the body. If - %% the guarded expression is pure, but could fail, we also - %% have to check the handler. - case is_safe_expr(cerl:try_arg(E), Check) of - true -> - is_safe_expr(cerl:try_body(E), Check); - false -> - case is_pure_expr(cerl:try_arg(E), Check) of - true -> - case is_safe_expr(cerl:try_body(E), Check) of - true -> - is_safe_expr(cerl:try_handler(E), Check); - false -> - false - end; - false -> - false - end - end; - primop -> - Name = cerl:atom_val(cerl:primop_name(E)), - As = cerl:primop_args(E), - case Check(safe, {Name, length(As)}) of - true -> - is_safe_expr_list(As, Check); - false -> - false - end; - call -> - Module = cerl:call_module(E), - Name = cerl:call_name(E), - case cerl:is_c_atom(Module) and cerl:is_c_atom(Name) of - true -> - M = cerl:atom_val(Module), - F = cerl:atom_val(Name), - As = cerl:call_args(E), - case Check(safe, {M, F, length(As)}) of - true -> - is_safe_expr_list(As, Check); - false -> - false - end; - false -> - false % Call to unknown function - end; - _ -> - false - end. - -is_safe_expr_list([E | Es], Check) -> - case is_safe_expr(E, Check) of - true -> - is_safe_expr_list(Es, Check); - false -> - false - end; -is_safe_expr_list([], _Check) -> - true. - - -%% @spec (Expr::cerl()) -> bool() -%% -%% @doc Returns `true' if `Expr' represents a "pure" Core Erlang -%% expression, otherwise `false'. An expression is pure if it does not -%% affect the state, nor depend on the state, although its evaluation is -%% not guaranteed to complete normally for all input. -%% -%% Expressions of type `apply', `case', `receive' and `binary' are -%% always considered impure by this function. - --ifndef(NO_UNUSED). -is_pure_expr(E) -> - Check = fun default_check/2, - is_pure_expr(E, Check). --endif. -%% @clear - -is_pure_expr(E, Check) -> - case cerl:type(E) of - literal -> - true; - var -> - true; - 'fun' -> - true; - values -> - is_pure_expr_list(cerl:values_es(E), Check); - tuple -> - is_pure_expr_list(cerl:tuple_es(E), Check); - cons -> - case is_pure_expr(cerl:cons_hd(E), Check) of - true -> - is_pure_expr(cerl:cons_tl(E), Check); - false -> - false - end; - 'let' -> - case is_pure_expr(cerl:let_arg(E), Check) of - true -> - is_pure_expr(cerl:let_body(E), Check); - false -> - false - end; - letrec -> - is_pure_expr(cerl:letrec_body(E), Check); - seq -> - case is_pure_expr(cerl:seq_arg(E), Check) of - true -> - is_pure_expr(cerl:seq_body(E), Check); - false -> - false - end; - 'catch' -> - is_pure_expr(cerl:catch_body(E), Check); - 'try' -> - case is_pure_expr(cerl:try_arg(E), Check) of - true -> - case is_pure_expr(cerl:try_body(E), Check) of - true -> - is_pure_expr(cerl:try_handler(E), Check); - false -> - false - end; - false -> - false - end; - primop -> - Name = cerl:atom_val(cerl:primop_name(E)), - As = cerl:primop_args(E), - case Check(pure, {Name, length(As)}) of - true -> - is_pure_expr_list(As, Check); - false -> - false - end; - call -> - Module = cerl:call_module(E), - Name = cerl:call_name(E), - case cerl:is_c_atom(Module) and cerl:is_c_atom(Name) of - true -> - M = cerl:atom_val(Module), - F = cerl:atom_val(Name), - As = cerl:call_args(E), - case Check(pure, {M, F, length(As)}) of - true -> - is_pure_expr_list(As, Check); - false -> - false - end; - false -> - false % Call to unknown function - end; - _ -> - false - end. - -is_pure_expr_list([E | Es], Check) -> - case is_pure_expr(E, Check) of - true -> - is_pure_expr_list(Es, Check); - false -> - false - end; -is_pure_expr_list([], _Check) -> - true. - - -%% Peephole optimizations -%% -%% This is only intended to be a light-weight cleanup optimizer, -%% removing small things that may e.g. have been generated by other -%% optimization passes or in the translation from higher-level code. -%% It is not recursive in general - it only descends until it can do no -%% more work in the current context. -%% -%% To expose hidden cases of final expressions (enabling last call -%% optimization), we try to remove all trivial let-bindings (`let X = Y -%% in X', `let X = Y in Y', `let X = Y in let ... in ...', `let X = let -%% ... in ... in ...', etc.). We do not, however, try to recognize any -%% other similar cases, even for simple `case'-expressions like `case E -%% of X -> X end', or simultaneous multiple-value bindings. - --spec reduce_expr(cerl:cerl()) -> cerl:cerl(). - -reduce_expr(E) -> - Check = fun default_check/2, - reduce_expr(E, Check). - --spec reduce_expr(cerl:cerl(), check_fun()) -> cerl:cerl(). - -reduce_expr(E, Check) -> - case cerl:type(E) of - values -> - case cerl:values_es(E) of - [E1] -> - %% Not really an "optimization" in itself, but - %% enables other rewritings by removing the wrapper. - reduce_expr(E1, Check); - _ -> - E - end; - 'seq' -> - A = reduce_expr(cerl:seq_arg(E), Check), - B = reduce_expr(cerl:seq_body(E), Check), - %% `do <E1> <E2>' is equivalent to `<E2>' if `<E1>' is - %% "safe" (cannot effect the behaviour in any way). - case is_safe_expr(A, Check) of - true -> - B; - false -> - case cerl:is_c_seq(B) of - true -> - %% Rewrite `do <E1> do <E2> <E3>' to `do do - %% <E1> <E2> <E3>' so that the "body" of the - %% outermost seq-operator is the expression - %% which produces the final result (i.e., - %% E3). This can make other optimizations - %% easier; see `let'. - B1 = cerl:seq_arg(B), - B2 = cerl:seq_body(B), - cerl:c_seq(cerl:c_seq(A, B1), B2); - false -> - cerl:c_seq(A, B) - end - end; - 'let' -> - A = reduce_expr(cerl:let_arg(E), Check), - case cerl:is_c_seq(A) of - true -> - %% `let X = do <E1> <E2> in Y' is equivalent to `do - %% <E1> let X = <E2> in Y'. Note that `<E2>' cannot - %% be a seq-operator, due to the `seq' optimization. - A1 = cerl:seq_arg(A), - A2 = cerl:seq_body(A), - E1 = cerl:update_c_let(E, cerl:let_vars(E), - A2, cerl:let_body(E)), - cerl:c_seq(A1, reduce_expr(E1, Check)); - false -> - B = reduce_expr(cerl:let_body(E), Check), - Vs = cerl:let_vars(E), - %% We give up if the body does not reduce to a - %% single variable. This is not a generic copy - %% propagation. - case cerl:type(B) of - var when length(Vs) =:= 1 -> - %% We have `let <V1> = <E> in <V2>': - [V] = Vs, - N1 = cerl:var_name(V), - N2 = cerl:var_name(B), - if N1 =:= N2 -> - %% `let X = <E> in X' equals `<E>' - A; - true -> - %% `let X = <E> in Y' when X and Y - %% are different variables is - %% equivalent to `do <E> Y'. - reduce_expr(cerl:c_seq(A, B), Check) - end; - literal -> - %% `let X = <E> in T' when T is a literal - %% term is equivalent to `do <E> T'. - reduce_expr(cerl:c_seq(A, B), Check); - _ -> - cerl:update_c_let(E, Vs, A, B) - end - end; - 'try' -> - %% Get rid of unnecessary try-expressions. - A = reduce_expr(cerl:try_arg(E), Check), - B = reduce_expr(cerl:try_body(E), Check), - case is_safe_expr(A, Check) of - true -> - B; - false -> - cerl:update_c_try(E, A, cerl:try_vars(E), B, - cerl:try_evars(E), - cerl:try_handler(E)) - end; - 'catch' -> - %% Just a simpler form of try-expressions. - B = reduce_expr(cerl:catch_body(E), Check), - case is_safe_expr(B, Check) of - true -> - B; - false -> - cerl:update_c_catch(E, B) - end; - _ -> - E - end. diff --git a/lib/dialyzer/src/cerl_pmatch.erl b/lib/dialyzer/src/cerl_pmatch.erl deleted file mode 100644 index 66fce3c8eb..0000000000 --- a/lib/dialyzer/src/cerl_pmatch.erl +++ /dev/null @@ -1,620 +0,0 @@ -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. -%% -%% @copyright 2000-2006 Richard Carlsson -%% @author Richard Carlsson <carlsson.richard@gmail.com> -%% -%% @doc Core Erlang pattern matching compiler. -%% -%% <p>For reference, see Simon L. Peyton Jones "The Implementation of -%% Functional Programming Languages", chapter 5 (by Phil Wadler).</p> -%% -%% @type cerl() = cerl:cerl(). -%% Abstract Core Erlang syntax trees. -%% @type cerl_records() = cerl:cerl_records(). -%% An explicit record representation of Core Erlang syntax trees. - --module(cerl_pmatch). - -%%-define(NO_UNUSED, true). - --export([clauses/2]). --ifndef(NO_UNUSED). --export([transform/2, core_transform/2, expr/2]). --endif. - --import(lists, [all/2, splitwith/2, foldr/3, keysort/2, foldl/3, - mapfoldl/3]). - --define(binary_id, {binary}). --define(cons_id, {cons}). --define(tuple_id, {tuple}). --define(literal_id(V), V). - - -%% @spec core_transform(Module::cerl_records(), Options::[term()]) -> -%% cerl_records() -%% -%% @doc Transforms a module represented by records. See -%% <code>transform/2</code> for details. -%% -%% <p>Use the compiler option <code>{core_transform, cerl_pmatch}</code> -%% to insert this function as a compilation pass.</p> -%% -%% @see transform/2 - --ifndef(NO_UNUSED). --spec core_transform(cerl:c_module(), [_]) -> cerl:c_module(). - -core_transform(M, Opts) -> - cerl:to_records(transform(cerl:from_records(M), Opts)). --endif. % NO_UNUSED -%% @clear - - -%% @spec transform(Module::cerl(), Options::[term()]) -> cerl() -%% -%% @doc Rewrites all <code>case</code>-clauses in <code>Module</code>. -%% <code>receive</code>-clauses are not affected. Currently, no options -%% are available. -%% -%% @see clauses/2 -%% @see expr/2 -%% @see core_transform/2 - --ifndef(NO_UNUSED). --spec transform(cerl:cerl(), [_]) -> cerl:cerl(). - -transform(M, _Opts) -> - expr(M, env__empty()). --endif. % NO_UNUSED -%% @clear - - -%% @spec clauses(Clauses::[Clause], Env) -> {Expr, Vars} -%% Clause = cerl() -%% Expr = cerl() -%% Vars = [cerl()] -%% Env = rec_env:environment() -%% -%% @doc Rewrites a sequence of clauses to an equivalent expression, -%% removing as much repeated testing as possible. Returns a pair -%% <code>{Expr, Vars}</code>, where <code>Expr</code> is the resulting -%% expression, and <code>Vars</code> is a list of new variables (i.e., -%% not already in the given environment) to be bound to the arguments to -%% the switch. The following is a typical example (assuming -%% <code>E</code> is a Core Erlang case expression): -%% <pre> -%% handle_case(E, Env) -> -%% Cs = case_clauses(E), -%% {E1, Vs} = cerl_pmatch(Cs, Env), -%% c_let(Vs, case_arg(E), E1). -%% </pre> -%% -%% <p>The environment is used for generating new variables which do not -%% shadow existing bindings.</p> -%% -%% @see rec_env -%% @see expr/2 -%% @see transform/2 - --spec clauses([cerl:cerl(),...], rec_env:environment()) -> - {cerl:cerl(), [cerl:cerl()]}. - -clauses(Cs, Env) -> - clauses(Cs, none, Env). - -clauses([C | _] = Cs, Else, Env) -> - Vs = new_vars(cerl:clause_arity(C), Env), - E = match(Vs, Cs, Else, add_vars(Vs, Env)), - {E, Vs}. - -%% The implementation very closely follows that described in the book. - -match([], Cs, Else, _Env) -> - %% If the "default action" is the atom 'none', it is simply not - %% added; otherwise it is put in the body of a final catch-all - %% clause (which is often removed by the below optimization). - Cs1 = if Else =:= none -> Cs; - true -> Cs ++ [cerl:c_clause([], Else)] - end, - %% This clause reduction is an important optimization. It selects a - %% clause body if possible, and otherwise just removes dead clauses. - case cerl_clauses:reduce(Cs1) of - {true, {C, []}} -> % if we get bindings, something is wrong! - cerl:clause_body(C); - {false, Cs2} -> - %% This happens when guards are nontrivial. - cerl:c_case(cerl:c_values([]), Cs2) - end; -match([V | _] = Vs, Cs, Else, Env) -> - foldr(fun (CsF, ElseF) -> - match_var_con(Vs, CsF, ElseF, Env) - end, - Else, - group([unalias(C, V) || C <- Cs], fun is_var_clause/1)). - -group([], _F) -> - []; -group([X | _] = Xs, F) -> - group(Xs, F, F(X)). - -group(Xs, F, P) -> - {First, Rest} = splitwith(fun (X) -> F(X) =:= P end, Xs), - [First | group(Rest, F)]. - -is_var_clause(C) -> - cerl:is_c_var(hd(cerl:clause_pats(C))). - -%% To avoid code duplication, if the 'Else' expression is too big, we -%% put it in a local function definition instead, and replace it with a -%% call. (Note that it is important that 'is_lightweight' does not yield -%% 'true' for a simple function application, or we will create a lot of -%% unnecessary extra functions.) - -match_var_con(Vs, Cs, none = Else, Env) -> - match_var_con_1(Vs, Cs, Else, Env); -match_var_con(Vs, Cs, Else, Env) -> - case is_lightweight(Else) of - true -> - match_var_con_1(Vs, Cs, Else, Env); - false -> - F = new_fvar("match_", 0, Env), - Else1 = cerl:c_apply(F, []), - Env1 = add_vars([F], Env), - cerl:c_letrec([{F, cerl:c_fun([], Else)}], - match_var_con_1(Vs, Cs, Else1, Env1)) - end. - -match_var_con_1(Vs, Cs, Else, Env) -> - case is_var_clause(hd(Cs)) of - true -> - match_var(Vs, Cs, Else, Env); - false -> - match_con(Vs, Cs, Else, Env) - end. - -match_var([V | Vs], Cs, Else, Env) -> - Cs1 = [begin - [P | Ps] = cerl:clause_pats(C), - G = make_let([P], V, cerl:clause_guard(C)), - B = make_let([P], V, cerl:clause_body(C)), - cerl:update_c_clause(C, Ps, G, B) - end - || C <- Cs], - match(Vs, Cs1, Else, Env). - -%% Since Erlang is dynamically typed, we must include the possibility -%% that none of the constructors in the group will match, and in that -%% case the "Else" code will be executed (unless it is 'none'), in the -%% body of a final catch-all clause. - -match_con([V | Vs], Cs, Else, Env) -> - case group_con(Cs) of - [{_, _, Gs}] -> - %% Don't create a group type switch if there is only one - %% such group - make_switch(V, [match_congroup(DG, Vs, CsG, Else, Env) - || {DG, _, CsG} <- Gs], - Else, Env); - Ts -> - Cs1 = [match_typegroup(T, V, Vs, Gs, Else, Env) - || {T, _, Gs} <- Ts], - make_switch(V, Cs1, Else, Env) - end. - - -match_typegroup(_T, _V, Vs, [{D, _, Cs}], Else, Env) when element(1, D) /= ?binary_id -> - %% Don't create a group type switch if there is only one constructor - %% in the group. (Note that this always happens for '[]'.) - %% Special case for binaries which always get a group switch - match_congroup(D, Vs, Cs, Else, Env); -match_typegroup(T, V, Vs, Gs, Else, Env) -> - Body = make_switch(V, [match_congroup(D, Vs, Cs, Else, Env) - || {D, _, Cs} <- Gs], - Else, Env), - typetest_clause(T, V, Body, Env). - -match_congroup({?binary_id, Segs}, Vs, Cs, Else, Env) -> - Body = match(Vs, Cs, Else, Env), - cerl:c_clause([make_pat(?binary_id, Segs)], Body); - -match_congroup({D, A}, Vs, Cs, Else, Env) -> - Vs1 = new_vars(A, Env), - Body = match(Vs1 ++ Vs, Cs, Else, add_vars(Vs1, Env)), - cerl:c_clause([make_pat(D, Vs1)], Body). - -make_switch(V, Cs, Else, Env) -> - cerl:c_case(V, if Else =:= none -> Cs; - true -> Cs ++ [cerl:c_clause([new_var(Env)], - Else)] - end). - -%% We preserve the relative order of different-type constructors as they -%% were originally listed. This is done by tracking the clause numbers. - -group_con(Cs) -> - {Cs1, _} = mapfoldl(fun (C, N) -> - [P | Ps] = cerl:clause_pats(C), - Ps1 = sub_pats(P) ++ Ps, - G = cerl:clause_guard(C), - B = cerl:clause_body(C), - C1 = cerl:update_c_clause(C, Ps1, G, B), - D = con_desc(P), - {{D, N, C1}, N + 1} - end, - 0, Cs), - %% Sort and group constructors. - Css = group(keysort(1, Cs1), fun ({D,_,_}) -> D end), - %% Sort each group "back" by line number, and move the descriptor - %% and line number to the wrapper for the group. - Gs = [finalize_congroup(C) || C <- Css], - %% Group by type only (put e.g. different-arity tuples together). - Gss = group(Gs, fun ({D,_,_}) -> con_desc_type(D) end), - %% Sort and wrap the type groups. - Ts = [finalize_typegroup(G) || G <- Gss], - %% Sort type-groups by first clause order - keysort(2, Ts). - -finalize_congroup(Cs) -> - [{D,N,_}|_] = Cs1 = keysort(2, Cs), - {D, N, [C || {_,_,C} <- Cs1]}. - -finalize_typegroup(Gs) -> - [{D,N,_}|_] = Gs1 = keysort(2, Gs), - {con_desc_type(D), N, Gs1}. - -%% Since Erlang clause patterns can contain "alias patterns", we must -%% eliminate these, by turning them into let-definitions in the guards -%% and bodies of the clauses. - -unalias(C, V) -> - [P | Ps] = cerl:clause_pats(C), - B = cerl:clause_body(C), - G = cerl:clause_guard(C), - unalias(P, V, Ps, B, G, C). - -unalias(P, V, Ps, B, G, C) -> - case cerl:type(P) of - alias -> - V1 = cerl:alias_var(P), - B1 = make_let([V1], V, B), - G1 = make_let([V1], V, G), - unalias(cerl:alias_pat(P), V, Ps, B1, G1, C); - _ -> - cerl:update_c_clause(C, [P | Ps], G, B) - end. - -%% Generating a type-switch clause - -typetest_clause([], _V, E, _Env) -> - cerl:c_clause([cerl:c_nil()], E); -typetest_clause(atom, V, E, _Env) -> - typetest_clause_1(is_atom, V, E); -typetest_clause(integer, V, E, _Env) -> - typetest_clause_1(is_integer, V, E); -typetest_clause(float, V, E, _Env) -> - typetest_clause_1(is_float, V, E); -typetest_clause(cons, _V, E, Env) -> - [V1, V2] = new_vars(2, Env), - cerl:c_clause([cerl:c_cons(V1, V2)], E); % there is no 'is cons' -typetest_clause(tuple, V, E, _Env) -> - typetest_clause_1(is_tuple, V, E); -typetest_clause(binary, V, E, _Env) -> - typetest_clause_1(is_binary, V, E). - -typetest_clause_1(T, V, E) -> - cerl:c_clause([V], cerl:c_call(cerl:c_atom('erlang'), - cerl:c_atom(T), [V]), E). - -%% This returns a constructor descriptor, to be used for grouping and -%% pattern generation. It consists of an identifier term and the arity. - -con_desc(E) -> - case cerl:type(E) of - cons -> {?cons_id, 2}; - tuple -> {?tuple_id, cerl:tuple_arity(E)}; - binary -> {?binary_id, cerl:binary_segments(E)}; - literal -> - case cerl:concrete(E) of - [_|_] -> {?cons_id, 2}; - T when is_tuple(T) -> {?tuple_id, tuple_size(T)}; - V -> {?literal_id(V), 0} - end; - _ -> - throw({bad_constructor, E}) - end. - -%% This returns the type class for a constructor descriptor, for -%% grouping of clauses. It does not distinguish between tuples of -%% different arity, nor between different values of atoms, integers and -%% floats. - -con_desc_type({?literal_id([]), _}) -> []; -con_desc_type({?literal_id(V), _}) when is_atom(V) -> atom; -con_desc_type({?literal_id(V), _}) when is_integer(V) -> integer; -con_desc_type({?literal_id(V), _}) when is_float(V) -> float; -con_desc_type({?cons_id, 2}) -> cons; -con_desc_type({?tuple_id, _}) -> tuple; -con_desc_type({?binary_id, _}) -> binary. - -%% This creates a new constructor pattern from a type descriptor and a -%% list of variables. - -make_pat(?cons_id, [V1, V2]) -> cerl:c_cons(V1, V2); -make_pat(?tuple_id, Vs) -> cerl:c_tuple(Vs); -make_pat(?binary_id, Segs) -> cerl:c_binary(Segs); -make_pat(?literal_id(Val), []) -> cerl:abstract(Val). - -%% This returns the list of subpatterns of a constructor pattern. - -sub_pats(E) -> - case cerl:type(E) of - cons -> - [cerl:cons_hd(E), cerl:cons_tl(E)]; - tuple -> - cerl:tuple_es(E); - binary -> - []; - literal -> - case cerl:concrete(E) of - [H|T] -> [cerl:abstract(H), cerl:abstract(T)]; - T when is_tuple(T) -> [cerl:abstract(X) - || X <- tuple_to_list(T)]; - _ -> [] - end; - _ -> - throw({bad_constructor_pattern, E}) - end. - -%% This avoids generating stupid things like "let X = ... in 'true'", -%% and "let X = Y in X", keeping the generated code cleaner. It also -%% prevents expressions from being considered "non-lightweight" when -%% code duplication is disallowed (see is_lightweight for details). - -make_let(Vs, A, B) -> - cerl_lib:reduce_expr(cerl:c_let(Vs, A, B)). - -%% --------------------------------------------------------------------- -%% Rewriting a module or other expression: - -%% @spec expr(Expression::cerl(), Env) -> cerl() -%% Env = rec_env:environment() -%% -%% @doc Rewrites all <code>case</code>-clauses in -%% <code>Expression</code>. <code>receive</code>-clauses are not -%% affected. -%% -%% <p>The environment is used for generating new variables which do not -%% shadow existing bindings.</p> -%% -%% @see clauses/2 -%% @see rec_env - --ifndef(NO_UNUSED). --spec expr(cerl:cerl(), rec_env:environment()) -> cerl:cerl(). - -expr(E, Env) -> - case cerl:type(E) of - binary -> - Es = expr_list(cerl:binary_segments(E), Env), - cerl:update_c_binary(E, Es); - bitstr -> - V = expr(cerl:bitstr_val(E), Env), - Sz = expr(cerl:bitstr_size(E), Env), - Unit = expr(cerl:bitstr_unit(E), Env), - Type = expr(cerl:bitstr_type(E), Env), - cerl:update_c_bitstr(E, V, Sz, Unit, Type, cerl:bitstr_flags(E)); - 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. - - -%% --------------------------------------------------------------------- -%% 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/dialyzer/src/cerl_typean.erl b/lib/dialyzer/src/cerl_typean.erl deleted file mode 100644 index b0e5c10d7d..0000000000 --- a/lib/dialyzer/src/cerl_typean.erl +++ /dev/null @@ -1,994 +0,0 @@ -%% -*- erlang-indent-level: 4 -*- -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. -%% -%% @copyright 2001-2002 Richard Carlsson -%% @author Richard Carlsson <carlsson.richard@gmail.com> -%% @doc Type analysis of Core Erlang programs. - -%% TODO: filters must handle conjunctions for better precision! -%% TODO: should get filters from patterns as well as guards. -%% TODO: unused functions are being included in the analysis. - --module(cerl_typean). - --export([core_transform/2, analyze/1, pp_hook/0]). -%%-export([analyze/2, analyze/5, annotate/1, annotate/2, annotate/5]). - --import(erl_types, [t_any/0, t_atom/0, t_atom_vals/1, t_binary/0, - t_cons/2, t_cons_hd/1, t_cons_tl/1, t_float/0, - t_fun/0, t_fun/2, t_from_range/2, t_from_term/1, - t_inf/2, t_integer/0, - t_is_any/1, t_is_atom/1, t_is_cons/1, t_is_list/1, - t_is_maybe_improper_list/1, t_is_none/1, t_is_tuple/1, - t_limit/2, t_list_elements/1, t_maybe_improper_list/0, - t_none/0, t_number/0, t_pid/0, t_port/0, t_product/1, - t_reference/0, t_sup/2, t_to_tlist/1, t_tuple/0, t_tuple/1, - t_tuple_args/1, t_tuple_size/1, t_tuple_subtypes/1]). - --import(cerl, [ann_c_fun/3, ann_c_var/2, alias_pat/1, alias_var/1, - apply_args/1, apply_op/1, atom_val/1, bitstr_size/1, - bitstr_val/1, bitstr_type/1, bitstr_flags/1, binary_segments/1, - c_letrec/2, c_nil/0, - c_values/1, call_args/1, call_module/1, call_name/1, - case_arg/1, case_clauses/1, catch_body/1, clause_body/1, - clause_guard/1, clause_pats/1, concrete/1, cons_hd/1, - cons_tl/1, fun_body/1, fun_vars/1, get_ann/1, int_val/1, - is_c_atom/1, is_c_int/1, let_arg/1, let_body/1, let_vars/1, - letrec_body/1, letrec_defs/1, module_defs/1, - module_defs/1, module_exports/1, pat_vars/1, - primop_args/1, primop_name/1, receive_action/1, - receive_clauses/1, receive_timeout/1, seq_arg/1, - seq_body/1, set_ann/2, try_arg/1, try_body/1, - try_evars/1, try_handler/1, try_vars/1, tuple_arity/1, - tuple_es/1, type/1, values_es/1, var_name/1]). - --import(cerl_trees, [get_label/1]). - --ifdef(DEBUG). --define(ANNOTATE(X), case erl_types:t_to_string(X) of Q when length(Q) < 255 -> list_to_atom(Q); Q -> Q end). --else. --define(ANNOTATE(X), X). --endif. - -%% Limit for type representation depth. --define(DEF_LIMIT, 3). - - -%% @spec core_transform(Module::cerl_records(), Options::[term()]) -> -%% cerl_records() -%% -%% @doc Annotates a module represented by records with type -%% information. See <code>annotate/1</code> for details. -%% -%% <p>Use the compiler option <code>{core_transform, cerl_typean}</code> -%% to insert this function as a compilation pass.</p> -%% -%% @see module/2 - --spec core_transform(cerl:cerl(), [term()]) -> cerl:cerl(). - -core_transform(Code, _Opts) -> - {Code1, _} = cerl_trees:label(cerl:from_records(Code)), - %% io:fwrite("Running type analysis..."), - %% {T1,_} = statistics(runtime), - {Code2, _, _} = annotate(Code1), - %% {T2,_} = statistics(runtime), - %% io:fwrite("(~w ms).\n", [T2 - T1]), - cerl:to_records(Code2). - - -%% ===================================================================== -%% annotate(Tree) -> {Tree1, Type, Vars} -%% -%% Tree = cerl:cerl() -%% -%% Analyzes `Tree' (see `analyze') and appends terms `{type, Type}' -%% to the annotation list of each fun-expression node and -%% apply-expression node of `Tree', respectively, where `Labels' is -%% an ordered-set list of labels of fun-expressions in `Tree', -%% possibly also containing the atom `external', corresponding to -%% the dependency information derived by the analysis. Any previous -%% such annotations are removed from `Tree'. `Tree1' is the -%% modified tree; for details on `OutList', `Outputs' , -%% `Dependencies' and `Escapes', see `analyze'. -%% -%% Note: `Tree' must be annotated with labels in order to use this -%% function; see `analyze' for details. - -annotate(Tree) -> - annotate(Tree, ?DEF_LIMIT). - -annotate(Tree, Limit) -> - {_, _, Esc, Dep, Par} = cerl_closurean:analyze(Tree), - annotate(Tree, Limit, Esc, Dep, Par). - -annotate(Tree, Limit, Esc, Dep, Par) -> - {Type, Out, Vars} = analyze(Tree, Limit, Esc, Dep, Par), - DelAnn = fun (T) -> set_ann(T, delete_ann(type, get_ann(T))) end, - SetType = fun (T, Dict) -> - case dict:find(get_label(T), Dict) of - {ok, X} -> - case t_is_any(X) of - true -> - DelAnn(T); - false -> - set_ann(T, append_ann(type, - ?ANNOTATE(X), - get_ann(T))) - end; - error -> - DelAnn(T) - end - end, - F = fun (T) -> - case type(T) of - var -> - SetType(T, Vars); - apply -> - SetType(T, Out); - call -> - SetType(T, Out); - primop -> - SetType(T, Out); - 'fun' -> - SetType(T, Out); - _ -> - DelAnn(T) - end - end, - {cerl_trees:map(F, Tree), Type, Vars}. - -append_ann(Tag, Val, [X | Xs]) -> - if tuple_size(X) >= 1, element(1, X) =:= Tag -> - append_ann(Tag, Val, Xs); - true -> - [X | append_ann(Tag, Val, Xs)] - end; -append_ann(Tag, Val, []) -> - [{Tag, Val}]. - -delete_ann(Tag, [X | Xs]) -> - if tuple_size(X) >= 1, element(1, X) =:= Tag -> - delete_ann(Tag, Xs); - true -> - [X | delete_ann(Tag, Xs)] - end; -delete_ann(_, []) -> - []. - - -%% ===================================================================== -%% analyze(Tree) -> {OutList, Outputs, Dependencies} -%% -%% Tree = cerl:cerl() -%% OutList = [LabelSet] | none -%% Outputs = dict(integer(), OutList) -%% Dependencies = dict(integer(), LabelSet) -%% LabelSet = ordset(Label) -%% Label = integer() | external -%% -%% Analyzes a module or an expression represented by `Tree'. -%% -%% The returned `OutList' is a list of sets of labels of -%% fun-expressions which correspond to the possible closures in the -%% value list produced by `Tree' (viewed as an expression; the -%% "value" of a module contains its exported functions). The atom -%% `none' denotes missing or conflicting information. -%% -%% The atom `external' in any label set denotes any possible -%% function outside `Tree', including those in `Escapes'. -%% -%% `Outputs' is a mapping from the labels of fun-expressions in -%% `Tree' to corresponding lists of sets of labels of -%% fun-expressions (or the atom `none'), representing the possible -%% closures in the value lists returned by the respective -%% functions. -%% -%% `Dependencies' is a similar mapping from the labels of -%% fun-expressions and apply-expressions in `Tree' to sets of -%% labels of corresponding fun-expressions which may contain call -%% sites of the functions or be called from the call sites, -%% respectively. Any such label not defined in `Dependencies' -%% represents an unreachable function or a dead or faulty -%% application. -%% -%% `Escapes' is the set of labels of fun-expressions in `Tree' such -%% that corresponding closures may be accessed from outside `Tree'. -%% -%% Note: `Tree' must be annotated with labels (as done by the -%% function `cerl_trees:label/1') in order to use this function. -%% The label annotation `{label, L}' (where L should be an integer) -%% must be the first element of the annotation list of each node in -%% the tree. Instances of variables bound in `Tree' which denote -%% the same variable must have the same label; apart from this, -%% labels should be unique. Constant literals do not need to be -%% labeled. - --record(state, {k, vars, out, dep, work, funs, envs}). - -%% Note: In order to keep our domain simple, we assume that all remote -%% calls and primops return a single value, if any. - -%% We wrap the given syntax tree T in a fun-expression labeled `top', -%% which is initially in the set of escaped labels. `top' will be -%% visited at least once. -%% -%% We create a separate function labeled `external', defined as: -%% "External = fun () -> Any", which will represent any and all -%% functions outside T, and whose return value has unknown type. - --type label() :: integer() | 'external' | 'top'. --type ordset(X) :: [X]. % XXX: TAKE ME OUT --type labelset() :: ordset(label()). --type outlist() :: [labelset()] | 'none'. - --spec analyze(cerl:cerl()) -> {outlist(), dict:dict(), 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, [{version, 2}]), - 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([{version, 2}])}. - -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/dialyzer/src/dialyzer.app.src b/lib/dialyzer/src/dialyzer.app.src index 3090895190..93d004d2e7 100644 --- a/lib/dialyzer/src/dialyzer.app.src +++ b/lib/dialyzer/src/dialyzer.app.src @@ -22,11 +22,7 @@ {application, dialyzer, [{description, "DIscrepancy AnaLYZer of ERlang programs, version %VSN%"}, {vsn, "%VSN%"}, - {modules, [cerl_closurean, - cerl_lib, - cerl_pmatch, - cerl_prettypr, - cerl_typean, + {modules, [cerl_prettypr, dialyzer, dialyzer_analysis_callgraph, dialyzer_behaviours, -- 2.31.1
Locations
Projects
Search
Status Monitor
Help
OpenBuildService.org
Documentation
API Documentation
Code of Conduct
Contact
Support
@OBShq
Terms
openSUSE Build Service is sponsored by
The Open Build Service is an
openSUSE project
.
Sign Up
Log In
Places
Places
All Projects
Status Monitor
