diff options
Diffstat (limited to 'lib/hipe/cerl/cerl_closurean.erl')
| -rw-r--r-- | lib/hipe/cerl/cerl_closurean.erl | 862 |
1 files changed, 862 insertions, 0 deletions
diff --git a/lib/hipe/cerl/cerl_closurean.erl b/lib/hipe/cerl/cerl_closurean.erl new file mode 100644 index 0000000000..12771668ac --- /dev/null +++ b/lib/hipe/cerl/cerl_closurean.erl @@ -0,0 +1,862 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2003-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +%% ===================================================================== +%% Closure analysis of Core Erlang programs. +%% +%% Copyright (C) 2001-2002 Richard Carlsson +%% +%% Author contact: [email protected] +%% ===================================================================== + +%% TODO: might need a "top" (`any') element for any-length value lists. + +-module(cerl_closurean). + +-export([analyze/1, annotate/1]). +%% The following functions are exported from this module since they +%% are also used by Dialyzer (file dialyzer/src/dialyzer_dep.erl) +-export([is_escape_op/2, is_escape_op/3, is_literal_op/2, is_literal_op/3]). + +-import(cerl, [ann_c_apply/3, ann_c_fun/3, ann_c_var/2, apply_args/1, + apply_op/1, atom_val/1, bitstr_size/1, bitstr_val/1, + binary_segments/1, c_letrec/2, c_seq/2, c_tuple/1, + c_nil/0, call_args/1, call_module/1, call_name/1, + case_arg/1, case_clauses/1, catch_body/1, clause_body/1, + clause_guard/1, clause_pats/1, cons_hd/1, cons_tl/1, + fun_body/1, fun_vars/1, get_ann/1, is_c_atom/1, + let_arg/1, let_body/1, let_vars/1, letrec_body/1, + letrec_defs/1, module_defs/1, module_defs/1, + module_exports/1, pat_vars/1, primop_args/1, + primop_name/1, receive_action/1, receive_clauses/1, + receive_timeout/1, seq_arg/1, seq_body/1, set_ann/2, + try_arg/1, try_body/1, try_vars/1, try_evars/1, + try_handler/1, tuple_es/1, type/1, values_es/1]). + +-import(cerl_trees, [get_label/1]). + +%% =========================================================================== + +-type label() :: integer() | 'top' | 'external' | 'external_call'. +-type ordset(X) :: [X]. % XXX: TAKE ME OUT +-type labelset() :: ordset(label()). +-type outlist() :: [labelset()] | 'none'. +-type escapes() :: labelset(). + +%% =========================================================================== +%% annotate(Tree) -> {Tree1, OutList, Outputs, Escapes, Dependencies, Parents} +%% +%% Tree = cerl:cerl() +%% +%% Analyzes `Tree' (see `analyze') and appends terms `{callers, +%% Labels}' and `{calls, Labels}' to the annotation list of each +%% fun-expression node and apply-expression node of `Tree', +%% respectively, where `Labels' is an ordered-set list of labels of +%% fun-expressions in `Tree', possibly also containing the atom +%% `external', corresponding to the dependency information derived +%% by the analysis. Any previous such annotations are removed from +%% `Tree'. `Tree1' is the modified tree; for details on `OutList', +%% `Outputs' , `Dependencies', `Escapes' and `Parents', see +%% `analyze'. +%% +%% Note: `Tree' must be annotated with labels in order to use this +%% function; see `analyze' for details. + +-spec annotate(cerl:cerl()) -> + {cerl:cerl(), outlist(), dict(), escapes(), dict(), dict()}. + +annotate(Tree) -> + {Xs, Out, Esc, Deps, Par} = analyze(Tree), + F = fun (T) -> + case type(T) of + 'fun' -> + L = get_label(T), + X = case dict:find(L, Deps) of + {ok, X1} -> X1; + error -> set__new() + end, + set_ann(T, append_ann(callers, + set__to_list(X), + get_ann(T))); + apply -> + L = get_label(T), + X = case dict:find(L, Deps) of + {ok, X1} -> X1; + error -> set__new() + end, + set_ann(T, append_ann(calls, + set__to_list(X), + get_ann(T))); + _ -> +%%% set_ann(T, []) % debug + T + end + end, + {cerl_trees:map(F, Tree), Xs, Out, Esc, Deps, Par}. + +append_ann(Tag, Val, [X | Xs]) -> + if tuple_size(X) >= 1, element(1, X) =:= Tag -> + append_ann(Tag, Val, Xs); + true -> + [X | append_ann(Tag, Val, Xs)] + end; +append_ann(Tag, Val, []) -> + [{Tag, Val}]. + +%% ===================================================================== +%% analyze(Tree) -> {OutList, Outputs, Escapes, Dependencies, Parents} +%% +%% Tree = cerl() +%% OutList = [LabelSet] | none +%% Outputs = dict(Label, OutList) +%% Escapes = LabelSet +%% Dependencies = dict(Label, LabelSet) +%% LabelSet = ordset(Label) +%% Label = integer() | top | external | external_call +%% Parents = dict(Label, Label) +%% +%% Analyzes a module or an expression represented by `Tree'. +%% +%% The returned `OutList' is a list of sets of labels of +%% fun-expressions which correspond to the possible closures in the +%% value list produced by `Tree' (viewed as an expression; the +%% "value" of a module contains its exported functions). The atom +%% `none' denotes missing or conflicting information. +%% +%% The atom `external' in any label set denotes any possible +%% function outside `Tree', including those in `Escapes'. The atom +%% `top' denotes the top-level expression `Tree'. +%% +%% `Outputs' is a mapping from the labels of fun-expressions in +%% `Tree' to corresponding lists of sets of labels of +%% fun-expressions (or the atom `none'), representing the possible +%% closures in the value lists returned by the respective +%% functions. +%% +%% `Dependencies' is a similar mapping from the labels of +%% fun-expressions and apply-expressions in `Tree' to sets of +%% labels of corresponding fun-expressions which may contain call +%% sites of the functions or be called from the call sites, +%% respectively. Any such label not defined in `Dependencies' +%% represents an unreachable function or a dead or faulty +%% application. +%% +%% `Escapes' is the set of labels of fun-expressions in `Tree' such +%% that corresponding closures may be accessed from outside `Tree'. +%% +%% `Parents' is a mapping from labels of fun-expressions in `Tree' +%% to the corresponding label of the nearest containing +%% fun-expression or top-level expression. This can be used to +%% extend the dependency graph, for certain analyses. +%% +%% Note: `Tree' must be annotated with labels (as done by the +%% function `cerl_trees:label/1') in order to use this function. +%% The label annotation `{label, L}' (where L should be an integer) +%% must be the first element of the annotation list of each node in +%% the tree. Instances of variables bound in `Tree' which denote +%% the same variable must have the same label; apart from this, +%% labels should be unique. Constant literals do not need to be +%% labeled. + +-record(state, {vars, out, dep, work, funs, par}). + +%% Note: In order to keep our domain simple, we assume that all remote +%% calls and primops return a single value, if any. + +%% We use the terms `closure', `label', `lambda' and `fun-expression' +%% interchangeably. The exact meaning in each case can be grasped from +%% the context. +%% +%% Rules: +%% 1) The implicit top level lambda escapes. +%% 2) A lambda returned by an escaped lambda also escapes. +%% 3) An escaped lambda can be passed an external lambda as argument. +%% 4) A lambda passed as argument to an external lambda also escapes. +%% 5) An argument passed to an unknown operation escapes. +%% 6) A call to an unknown operation can return an external lambda. +%% +%% Escaped lambdas become part of the set of external lambdas, but this +%% does not need to be represented explicitly. + +%% We wrap the given syntax tree T in a fun-expression labeled `top', +%% which is initially in the set of escaped labels. `top' will be +%% visited at least once. +%% +%% We create a separate function labeled `external', defined as: +%% "'external'/1 = fun (Escape) -> do apply 'external'/1(apply Escape()) +%% 'external'/1", which will represent any and all functions outside T, +%% and which returns itself, and contains a recursive call; this models +%% rules 2 and 4 above. It will be revisited if the set of escaped +%% labels changes, or at least once. Its parameter `Escape' is a +%% variable labeled `escape', which will hold the set of escaped labels. +%% initially it contains `top' and `external'. + +-spec analyze(cerl:cerl()) -> {outlist(), dict(), escapes(), dict(), dict()}. + +analyze(Tree) -> + %% Note that we use different name spaces for variable labels and + %% function/call site labels, so we can reuse some names here. We + %% assume that the labeling of Tree only uses integers, not atoms. + External = ann_c_var([{label, external}], {external, 1}), + Escape = ann_c_var([{label, escape}], 'Escape'), + ExtBody = c_seq(ann_c_apply([{label, loop}], External, + [ann_c_apply([{label, external_call}], + Escape, [])]), + External), + ExtFun = ann_c_fun([{label, external}], [Escape], ExtBody), +%%% io:fwrite("external fun:\n~s.\n", +%%% [cerl_prettypr:format(ExtFun, [noann])]), + Top = ann_c_var([{label, top}], {top, 0}), + TopFun = ann_c_fun([{label, top}], [], Tree), + + %% The "start fun" just makes the initialisation easier. It will not + %% be marked as escaped, and thus cannot be called. + StartFun = ann_c_fun([{label, start}], [], + c_letrec([{External, ExtFun}, {Top, TopFun}], + c_nil())), +%%% io:fwrite("start fun:\n~s.\n", +%%% [cerl_prettypr:format(StartFun, [noann])]), + + %% Gather a database of all fun-expressions in Tree and initialise + %% all their outputs and parameter variables. Bind all module- and + %% letrec-defined variables to their corresponding labels. + Funs0 = dict:new(), + Vars0 = dict:new(), + Out0 = dict:new(), + Empty = empty(), + F = fun (T, S = {Fs, Vs, Os}) -> + case type(T) of + 'fun' -> + L = get_label(T), + As = fun_vars(T), + {dict:store(L, T, Fs), + bind_vars_single(As, Empty, Vs), + dict:store(L, none, Os)}; + letrec -> + {Fs, bind_defs(letrec_defs(T), Vs), Os}; + module -> + {Fs, bind_defs(module_defs(T), Vs), Os}; + _ -> + S + end + end, + {Funs, Vars, Out} = cerl_trees:fold(F, {Funs0, Vars0, Out0}, + StartFun), + + %% Initialise Escape to the minimal set of escaped labels. + Vars1 = dict:store(escape, from_label_list([top, external]), Vars), + + %% Enter the fixpoint iteration at the StartFun. + St = loop(StartFun, start, #state{vars = Vars1, + out = Out, + dep = dict:new(), + work = init_work(), + funs = Funs, + par = dict:new()}), +%%% io:fwrite("dependencies: ~p.\n", +%%% [[{X, set__to_list(Y)} +%%% || {X, Y} <- dict:to_list(St#state.dep)]]), + {dict:fetch(top, St#state.out), + tidy_dict([start, top, external], St#state.out), + dict:fetch(escape, St#state.vars), + tidy_dict([loop], St#state.dep), + St#state.par}. + +tidy_dict([X | Xs], D) -> + tidy_dict(Xs, dict:erase(X, D)); +tidy_dict([], D) -> + D. + +loop(T, L, St0) -> +%%% io:fwrite("analyzing: ~w.\n", [L]), +%%% io:fwrite("work: ~w.\n", [St0#state.work]), + Xs0 = dict:fetch(L, St0#state.out), + {Xs, St1} = visit(fun_body(T), L, St0), + {W, M} = case equal(Xs0, Xs) of + true -> + {St1#state.work, St1#state.out}; + false -> +%%% io:fwrite("out (~w) changed: ~w <- ~w.\n", +%%% [L, Xs, Xs0]), + M1 = dict:store(L, Xs, St1#state.out), + case dict:find(L, St1#state.dep) of + {ok, S} -> + {add_work(set__to_list(S), St1#state.work), + M1}; + error -> + {St1#state.work, M1} + end + end, + St2 = St1#state{out = M}, + case take_work(W) of + {ok, L1, W1} -> + T1 = dict:fetch(L1, St2#state.funs), + loop(T1, L1, St2#state{work = W1}); + none -> + St2 + end. + +visit(T, L, St) -> + case type(T) of + literal -> + {[empty()], St}; + var -> + %% If a variable is not already in the store here, we + %% initialize it to empty(). + L1 = get_label(T), + Vars = St#state.vars, + case dict:find(L1, Vars) of + {ok, X} -> + {[X], St}; + error -> + X = empty(), + St1 = St#state{vars = dict:store(L1, X, Vars)}, + {[X], St1} + end; + 'fun' -> + %% Must revisit the fun also, because its environment might + %% have changed. (We don't keep track of such dependencies.) + L1 = get_label(T), + St1 = St#state{work = add_work([L1], St#state.work), + par = set_parent([L1], L, St#state.par)}, + {[singleton(L1)], St1}; + values -> + visit_list(values_es(T), L, St); + cons -> + {Xs, St1} = visit_list([cons_hd(T), cons_tl(T)], L, St), + {[join_single_list(Xs)], St1}; + tuple -> + {Xs, St1} = visit_list(tuple_es(T), L, St), + {[join_single_list(Xs)], St1}; + 'let' -> + {Xs, St1} = visit(let_arg(T), L, St), + Vars = bind_vars(let_vars(T), Xs, St1#state.vars), + visit(let_body(T), L, St1#state{vars = Vars}); + seq -> + {_, St1} = visit(seq_arg(T), L, St), + visit(seq_body(T), L, St1); + apply -> + {Xs, St1} = visit(apply_op(T), L, St), + {As, St2} = visit_list(apply_args(T), L, St1), + case Xs of + [X] -> + %% We store the dependency from the call site to the + %% called functions + Ls = set__to_list(X), + Out = St2#state.out, + Xs1 = join_list([dict:fetch(Lx, Out) || Lx <- Ls]), + St3 = call_site(Ls, L, As, St2), + L1 = get_label(T), + D = dict:store(L1, X, St3#state.dep), + {Xs1, St3#state{dep = D}}; + none -> + {none, St2} + end; + call -> + M = call_module(T), + F = call_name(T), + {_, St1} = visit(M, L, St), + {_, St2} = visit(F, L, St1), + {Xs, St3} = visit_list(call_args(T), L, St2), + remote_call(M, F, Xs, St3); + primop -> + As = primop_args(T), + {Xs, St1} = visit_list(As, L, St), + primop_call(atom_val(primop_name(T)), length(Xs), Xs, St1); + 'case' -> + {Xs, St1} = visit(case_arg(T), L, St), + visit_clauses(Xs, case_clauses(T), L, St1); + 'receive' -> + X = singleton(external), + {Xs1, St1} = visit_clauses([X], receive_clauses(T), L, St), + {_, St2} = visit(receive_timeout(T), L, St1), + {Xs2, St3} = visit(receive_action(T), L, St2), + {join(Xs1, Xs2), St3}; + 'try' -> + {Xs1, St1} = visit(try_arg(T), L, St), + X = singleton(external), + Vars = bind_vars(try_vars(T), [X], St1#state.vars), + {Xs2, St2} = visit(try_body(T), L, St1#state{vars = Vars}), + Evars = bind_vars(try_evars(T), [X, X, X], St2#state.vars), + {Xs3, St3} = visit(try_handler(T), L, St2#state{vars = Evars}), + {join(join(Xs1, Xs2), Xs3), St3}; + 'catch' -> + {_, St1} = visit(catch_body(T), L, St), + {[singleton(external)], St1}; + binary -> + {_, St1} = visit_list(binary_segments(T), L, St), + {[empty()], St1}; + bitstr -> + %% The other fields are constant literals. + {_, St1} = visit(bitstr_val(T), L, St), + {_, St2} = visit(bitstr_size(T), L, St1), + {none, St2}; + letrec -> + %% All the bound funs should be revisited, because the + %% environment might have changed. + Ls = [get_label(F) || {_, F} <- letrec_defs(T)], + St1 = St#state{work = add_work(Ls, St#state.work), + par = set_parent(Ls, L, St#state.par)}, + visit(letrec_body(T), L, St1); + module -> + %% All the exported functions escape, and can thus be passed + %% any external closures as arguments. We regard a module as + %% a tuple of function variables in the body of a `letrec'. + visit(c_letrec(module_defs(T), c_tuple(module_exports(T))), + L, St) + end. + +visit_clause(T, Xs, L, St) -> + Vars = bind_pats(clause_pats(T), Xs, St#state.vars), + {_, St1} = visit(clause_guard(T), L, St#state{vars = Vars}), + visit(clause_body(T), L, St1). + +%% We assume correct value-list typing. + +visit_list([T | Ts], L, St) -> + {Xs, St1} = visit(T, L, St), + {Xs1, St2} = visit_list(Ts, L, St1), + X = case Xs of + [X1] -> X1; + none -> none + end, + {[X | Xs1], St2}; +visit_list([], _L, St) -> + {[], St}. + +visit_clauses(Xs, [T | Ts], L, St) -> + {Xs1, St1} = visit_clause(T, Xs, L, St), + {Xs2, St2} = visit_clauses(Xs, Ts, L, St1), + {join(Xs1, Xs2), St2}; +visit_clauses(_, [], _L, St) -> + {none, St}. + +bind_defs([{V, F} | Ds], Vars) -> + bind_defs(Ds, dict:store(get_label(V), singleton(get_label(F)), + Vars)); +bind_defs([], Vars) -> + Vars. + +bind_pats(Ps, none, Vars) -> + bind_pats_single(Ps, empty(), Vars); +bind_pats(Ps, Xs, Vars) -> + if length(Xs) =:= length(Ps) -> + bind_pats_list(Ps, Xs, Vars); + true -> + bind_pats_single(Ps, empty(), Vars) + end. + +bind_pats_list([P | Ps], [X | Xs], Vars) -> + bind_pats_list(Ps, Xs, bind_vars_single(pat_vars(P), X, Vars)); +bind_pats_list([], [], Vars) -> + Vars. + +bind_pats_single([P | Ps], X, Vars) -> + bind_pats_single(Ps, X, bind_vars_single(pat_vars(P), X, Vars)); +bind_pats_single([], _X, Vars) -> + Vars. + +bind_vars(Vs, none, Vars) -> + bind_vars_single(Vs, empty(), Vars); +bind_vars(Vs, Xs, Vars) -> + if length(Vs) =:= length(Xs) -> + bind_vars_list(Vs, Xs, Vars); + true -> + bind_vars_single(Vs, empty(), Vars) + end. + +bind_vars_list([V | Vs], [X | Xs], Vars) -> + bind_vars_list(Vs, Xs, dict:store(get_label(V), X, Vars)); +bind_vars_list([], [], Vars) -> + Vars. + +bind_vars_single([V | Vs], X, Vars) -> + bind_vars_single(Vs, X, dict:store(get_label(V), X, Vars)); +bind_vars_single([], _X, Vars) -> + Vars. + +%% This handles a call site - adding dependencies and updating parameter +%% variables with respect to the actual parameters. The 'external' +%% function is handled specially, since it can get an arbitrary number +%% of arguments, which must be unified into a single argument. + +call_site(Ls, L, Xs, St) -> +%%% io:fwrite("call site: ~w -> ~w (~w).\n", [L, Ls, Xs]), + {D, W, V} = call_site(Ls, L, Xs, St#state.dep, St#state.work, + St#state.vars, St#state.funs), + St#state{dep = D, work = W, vars = V}. + +call_site([external | Ls], T, Xs, D, W, V, Fs) -> + D1 = add_dep(external, T, D), + X = join_single_list(Xs), + case bind_arg(escape, X, V) of + {V1, true} -> +%%% io:fwrite("escape changed: ~w <- ~w + ~w.\n", +%%% [dict:fetch(escape, V1), dict:fetch(escape, V), +%%% X]), + {W1, V2} = update_esc(set__to_list(X), W, V1, Fs), + call_site(Ls, T, Xs, D1, add_work([external], W1), V2, Fs); + {V1, false} -> + call_site(Ls, T, Xs, D1, W, V1, Fs) + end; +call_site([L | Ls], T, Xs, D, W, V, Fs) -> + D1 = add_dep(L, T, D), + Vs = fun_vars(dict:fetch(L, Fs)), + case bind_args(Vs, Xs, V) of + {V1, true} -> + call_site(Ls, T, Xs, D1, add_work([L], W), V1, Fs); + {V1, false} -> + call_site(Ls, T, Xs, D1, W, V1, Fs) + end; +call_site([], _, _, D, W, V, _) -> + {D, W, V}. + +%% Note that `visit' makes sure all lambdas are visited at least once. +%% For every called function, we add a dependency from the *called* +%% function to the function containing the call site. + +add_dep(Source, Target, Deps) -> + case dict:find(Source, Deps) of + {ok, X} -> + case set__is_member(Target, X) of + true -> + Deps; + false -> +%%% io:fwrite("new dep: ~w <- ~w.\n", [Target, Source]), + dict:store(Source, set__add(Target, X), Deps) + end; + error -> +%%% io:fwrite("new dep: ~w <- ~w.\n", [Target, Source]), + dict:store(Source, set__singleton(Target), Deps) + end. + +%% If the arity does not match the call, nothing is done here. + +bind_args(Vs, Xs, Vars) -> + if length(Vs) =:= length(Xs) -> + bind_args(Vs, Xs, Vars, false); + true -> + {Vars, false} + end. + +bind_args([V | Vs], [X | Xs], Vars, Ch) -> + L = get_label(V), + {Vars1, Ch1} = bind_arg(L, X, Vars, Ch), + bind_args(Vs, Xs, Vars1, Ch1); +bind_args([], [], Vars, Ch) -> + {Vars, Ch}. + +bind_args_single(Vs, X, Vars) -> + bind_args_single(Vs, X, Vars, false). + +bind_args_single([V | Vs], X, Vars, Ch) -> + L = get_label(V), + {Vars1, Ch1} = bind_arg(L, X, Vars, Ch), + bind_args_single(Vs, X, Vars1, Ch1); +bind_args_single([], _, Vars, Ch) -> + {Vars, Ch}. + +bind_arg(L, X, Vars) -> + bind_arg(L, X, Vars, false). + +bind_arg(L, X, Vars, Ch) -> + X0 = dict:fetch(L, Vars), + X1 = join_single(X, X0), + case equal_single(X0, X1) of + true -> + {Vars, Ch}; + false -> +%%% io:fwrite("arg (~w) changed: ~w <- ~w + ~w.\n", +%%% [L, X1, X0, X]), + {dict:store(L, X1, Vars), true} + end. + +%% This handles escapes from things like primops and remote calls. + +%% escape(none, St) -> +%% St; +escape([X], St) -> + Vars = St#state.vars, + X0 = dict:fetch(escape, Vars), + X1 = join_single(X, X0), + case equal_single(X0, X1) of + true -> + St; + false -> +%%% io:fwrite("escape changed: ~w <- ~w + ~w.\n", [X1, X0, X]), +%%% io:fwrite("updating escaping funs: ~w.\n", [set__to_list(X)]), + Vars1 = dict:store(escape, X1, Vars), + {W, Vars2} = update_esc(set__to_list(set__subtract(X, X0)), + St#state.work, Vars1, + St#state.funs), + St#state{work = add_work([external], W), vars = Vars2} + end. + +%% For all escaping lambdas, since they might be called from outside the +%% program, all their arguments may be an external lambda. (Note that we +%% only have to include the `external' label once per escaping lambda.) +%% If the escape set has changed, we need to revisit the `external' fun. + +update_esc(Ls, W, V, Fs) -> + update_esc(Ls, singleton(external), W, V, Fs). + +%% The external lambda is skipped here - the Escape variable is known to +%% contain `external' from the start. + +update_esc([external | Ls], X, W, V, Fs) -> + update_esc(Ls, X, W, V, Fs); +update_esc([L | Ls], X, W, V, Fs) -> + Vs = fun_vars(dict:fetch(L, Fs)), + case bind_args_single(Vs, X, V) of + {V1, true} -> + update_esc(Ls, X, add_work([L], W), V1, Fs); + {V1, false} -> + update_esc(Ls, X, W, V1, Fs) + end; +update_esc([], _, W, V, _) -> + {W, V}. + +set_parent([L | Ls], L1, D) -> + set_parent(Ls, L1, dict:store(L, L1, D)); +set_parent([], _L1, D) -> + D. + +%% Handle primop calls: (At present, we assume that all unknown primops +%% yield exactly one value. This might have to be changed.) + +primop_call(F, A, Xs, St0) -> + case is_pure_op(F, A) of + %% XXX: this case is currently not possible -- commented out. + %% true -> + %% case is_literal_op(F, A) of + %% true -> {[empty()], St0}; + %% false -> {[join_single_list(Xs)], St0} + %% end; + false -> + St1 = case is_escape_op(F, A) of + true -> escape([join_single_list(Xs)], St0); + false -> St0 + end, + case is_literal_op(F, A) of + true -> {none, St1}; + false -> {[singleton(external)], St1} + end + end. + +%% Handle remote-calls: (At present, we assume that all unknown calls +%% yield exactly one value. This might have to be changed.) + +remote_call(M, F, Xs, St) -> + case is_c_atom(M) andalso is_c_atom(F) of + true -> + remote_call_1(atom_val(M), atom_val(F), length(Xs), Xs, St); + false -> + %% Unknown function + {[singleton(external)], escape([join_single_list(Xs)], St)} + end. + +remote_call_1(M, F, A, Xs, St0) -> + case is_pure_op(M, F, A) of + true -> + case is_literal_op(M, F, A) of + true -> {[empty()], St0}; + false -> {[join_single_list(Xs)], St0} + end; + false -> + St1 = case is_escape_op(M, F, A) of + true -> escape([join_single_list(Xs)], St0); + false -> St0 + end, + case is_literal_op(M, F, A) of + true -> {[empty()], St1}; + false -> {[singleton(external)], St1} + end + end. + +%% Domain: none | [Vs], where Vs = set(integer()). + +join(none, Xs2) -> Xs2; +join(Xs1, none) -> Xs1; +join(Xs1, Xs2) -> + if length(Xs1) =:= length(Xs2) -> + join_1(Xs1, Xs2); + true -> + none + end. + +join_1([X1 | Xs1], [X2 | Xs2]) -> + [join_single(X1, X2) | join_1(Xs1, Xs2)]; +join_1([], []) -> + []. + +empty() -> set__new(). + +singleton(X) -> set__singleton(X). + +from_label_list(X) -> set__from_list(X). + +join_single(none, Y) -> Y; +join_single(X, none) -> X; +join_single(X, Y) -> set__union(X, Y). + +join_list([Xs | Xss]) -> + join(Xs, join_list(Xss)); +join_list([]) -> + none. + +join_single_list([X | Xs]) -> + join_single(X, join_single_list(Xs)); +join_single_list([]) -> + empty(). + +equal(none, none) -> true; +equal(none, _) -> false; +equal(_, none) -> false; +equal(X1, X2) -> equal_1(X1, X2). + +equal_1([X1 | Xs1], [X2 | Xs2]) -> + equal_single(X1, X2) andalso equal_1(Xs1, Xs2); +equal_1([], []) -> true; +equal_1(_, _) -> false. + +equal_single(X, Y) -> set__equal(X, Y). + +%% Set abstraction for label sets in the domain. + +set__new() -> []. + +set__singleton(X) -> [X]. + +set__to_list(S) -> S. + +set__from_list(S) -> ordsets:from_list(S). + +set__union(X, Y) -> ordsets:union(X, Y). + +set__add(X, S) -> ordsets:add_element(X, S). + +set__is_member(X, S) -> ordsets:is_element(X, S). + +set__subtract(X, Y) -> ordsets:subtract(X, Y). + +set__equal(X, Y) -> X =:= Y. + +%% A simple but efficient functional queue. + +queue__new() -> {[], []}. + +queue__put(X, {In, Out}) -> {[X | In], Out}. + +queue__get({In, [X | Out]}) -> {ok, X, {In, Out}}; +queue__get({[], _}) -> empty; +queue__get({In, _}) -> + [X | In1] = lists:reverse(In), + {ok, X, {[], In1}}. + +%% The work list - a queue without repeated elements. + +init_work() -> + {queue__new(), sets:new()}. + +add_work(Ls, {Q, Set}) -> + add_work(Ls, Q, Set). + +%% Note that the elements are enqueued in order. + +add_work([L | Ls], Q, Set) -> + case sets:is_element(L, Set) of + true -> + add_work(Ls, Q, Set); + false -> + add_work(Ls, queue__put(L, Q), sets:add_element(L, Set)) + end; +add_work([], Q, Set) -> + {Q, Set}. + +take_work({Queue0, Set0}) -> + case queue__get(Queue0) of + {ok, L, Queue1} -> + Set1 = sets:del_element(L, Set0), + {ok, L, {Queue1, Set1}}; + empty -> + none + end. + +%% Escape operators may let their arguments escape. Unless we know +%% otherwise, and the function is not pure, we assume this is the case. +%% Error-raising functions (fault/match_fail) are not considered as +%% escapes (but throw/exit are). Zero-argument functions need not be +%% listed. + +-spec is_escape_op(atom(), arity()) -> boolean(). + +is_escape_op(match_fail, 1) -> false; +is_escape_op(F, A) when is_atom(F), is_integer(A) -> true. + +-spec is_escape_op(module(), atom(), arity()) -> boolean(). + +is_escape_op(erlang, error, 1) -> false; +is_escape_op(erlang, error, 2) -> false; +is_escape_op(M, F, A) when is_atom(M), is_atom(F), is_integer(A) -> true. + +%% "Literal" operators will never return functional values even when +%% found in their arguments. Unless we know otherwise, we assume this is +%% not the case. (More functions can be added to this list, if needed +%% for better precision. Note that the result of `term_to_binary' still +%% contains an encoding of the closure.) + +-spec is_literal_op(atom(), arity()) -> boolean(). + +is_literal_op(match_fail, 1) -> true; +is_literal_op(F, A) when is_atom(F), is_integer(A) -> false. + +-spec is_literal_op(module(), atom(), arity()) -> boolean(). + +is_literal_op(erlang, '+', 2) -> true; +is_literal_op(erlang, '-', 2) -> true; +is_literal_op(erlang, '*', 2) -> true; +is_literal_op(erlang, '/', 2) -> true; +is_literal_op(erlang, '=:=', 2) -> true; +is_literal_op(erlang, '==', 2) -> true; +is_literal_op(erlang, '=/=', 2) -> true; +is_literal_op(erlang, '/=', 2) -> true; +is_literal_op(erlang, '<', 2) -> true; +is_literal_op(erlang, '=<', 2) -> true; +is_literal_op(erlang, '>', 2) -> true; +is_literal_op(erlang, '>=', 2) -> true; +is_literal_op(erlang, 'and', 2) -> true; +is_literal_op(erlang, 'or', 2) -> true; +is_literal_op(erlang, 'not', 1) -> true; +is_literal_op(erlang, length, 1) -> true; +is_literal_op(erlang, size, 1) -> true; +is_literal_op(erlang, fun_info, 1) -> true; +is_literal_op(erlang, fun_info, 2) -> true; +is_literal_op(erlang, fun_to_list, 1) -> true; +is_literal_op(erlang, throw, 1) -> true; +is_literal_op(erlang, exit, 1) -> true; +is_literal_op(erlang, error, 1) -> true; +is_literal_op(erlang, error, 2) -> true; +is_literal_op(M, F, A) when is_atom(M), is_atom(F), is_integer(A) -> false. + +%% Pure functions neither affect the state, nor depend on it. + +is_pure_op(F, A) when is_atom(F), is_integer(A) -> false. + +is_pure_op(M, F, A) -> erl_bifs:is_pure(M, F, A). + +%% ===================================================================== |