aboutsummaryrefslogtreecommitdiffstats
path: root/lib/compiler/src
diff options
context:
space:
mode:
authorErlang/OTP <[email protected]>2009-11-20 14:54:40 +0000
committerErlang/OTP <[email protected]>2009-11-20 14:54:40 +0000
commit84adefa331c4159d432d22840663c38f155cd4c1 (patch)
treebff9a9c66adda4df2106dfd0e5c053ab182a12bd /lib/compiler/src
downloadotp-84adefa331c4159d432d22840663c38f155cd4c1.tar.gz
otp-84adefa331c4159d432d22840663c38f155cd4c1.tar.bz2
otp-84adefa331c4159d432d22840663c38f155cd4c1.zip
The R13B03 release.OTP_R13B03
Diffstat (limited to 'lib/compiler/src')
-rw-r--r--lib/compiler/src/Makefile187
-rw-r--r--lib/compiler/src/beam_asm.erl419
-rw-r--r--lib/compiler/src/beam_block.erl624
-rw-r--r--lib/compiler/src/beam_bool.erl751
-rw-r--r--lib/compiler/src/beam_bsm.erl708
-rw-r--r--lib/compiler/src/beam_clean.erl377
-rw-r--r--lib/compiler/src/beam_dead.erl599
-rw-r--r--lib/compiler/src/beam_dict.erl231
-rw-r--r--lib/compiler/src/beam_disasm.erl1148
-rw-r--r--lib/compiler/src/beam_disasm.hrl43
-rw-r--r--lib/compiler/src/beam_flatten.erl154
-rw-r--r--lib/compiler/src/beam_jump.erl562
-rw-r--r--lib/compiler/src/beam_listing.erl119
-rw-r--r--lib/compiler/src/beam_peep.erl191
-rw-r--r--lib/compiler/src/beam_trim.erl332
-rw-r--r--lib/compiler/src/beam_type.erl691
-rw-r--r--lib/compiler/src/beam_utils.erl858
-rw-r--r--lib/compiler/src/beam_validator.erl1764
-rw-r--r--lib/compiler/src/cerl.erl4438
-rw-r--r--lib/compiler/src/cerl_clauses.erl428
-rw-r--r--lib/compiler/src/cerl_inline.erl2717
-rw-r--r--lib/compiler/src/cerl_trees.erl828
-rw-r--r--lib/compiler/src/compile.erl1400
-rw-r--r--lib/compiler/src/compiler.app.src66
-rw-r--r--lib/compiler/src/compiler.appup.src1
-rw-r--r--lib/compiler/src/core_lib.erl229
-rw-r--r--lib/compiler/src/core_lint.erl536
-rw-r--r--lib/compiler/src/core_parse.hrl98
-rw-r--r--lib/compiler/src/core_parse.yrl383
-rw-r--r--lib/compiler/src/core_pp.erl504
-rw-r--r--lib/compiler/src/core_scan.erl468
-rw-r--r--lib/compiler/src/erl_bifs.erl217
-rw-r--r--lib/compiler/src/genop.tab276
-rw-r--r--lib/compiler/src/rec_env.erl640
-rw-r--r--lib/compiler/src/sys_core_dsetel.erl346
-rw-r--r--lib/compiler/src/sys_core_fold.erl2851
-rw-r--r--lib/compiler/src/sys_core_inline.erl212
-rw-r--r--lib/compiler/src/sys_expand_pmod.erl423
-rw-r--r--lib/compiler/src/sys_pre_attributes.erl213
-rw-r--r--lib/compiler/src/sys_pre_expand.erl687
-rw-r--r--lib/compiler/src/v3_codegen.erl2051
-rw-r--r--lib/compiler/src/v3_core.erl2136
-rw-r--r--lib/compiler/src/v3_kernel.erl1924
-rw-r--r--lib/compiler/src/v3_kernel.hrl83
-rw-r--r--lib/compiler/src/v3_kernel_pp.erl493
-rw-r--r--lib/compiler/src/v3_life.erl565
-rw-r--r--lib/compiler/src/v3_life.hrl26
47 files changed, 34997 insertions, 0 deletions
diff --git a/lib/compiler/src/Makefile b/lib/compiler/src/Makefile
new file mode 100644
index 0000000000..fde2b1a655
--- /dev/null
+++ b/lib/compiler/src/Makefile
@@ -0,0 +1,187 @@
+#
+# %CopyrightBegin%
+#
+# Copyright Ericsson AB 1996-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%
+#
+
+ifdef BOOTSTRAP_COMPILER
+EGEN=$(BOOTSTRAP_COMPILER)/egen
+EBIN=$(BOOTSTRAP_COMPILER)/ebin
+else
+ifdef BOOTSTRAP
+EGEN=$(BOOTSTRAP_TOP)/lib/compiler/egen
+EBIN=$(BOOTSTRAP_TOP)/lib/compiler/ebin
+endif
+endif
+
+include $(ERL_TOP)/make/target.mk
+include $(ERL_TOP)/make/$(TARGET)/otp.mk
+
+# ----------------------------------------------------
+# Application version
+# ----------------------------------------------------
+include ../vsn.mk
+VSN=$(COMPILER_VSN)
+
+# ----------------------------------------------------
+# Release directory specification
+# ----------------------------------------------------
+RELSYSDIR = $(RELEASE_PATH)/lib/compiler-$(VSN)
+
+# ----------------------------------------------------
+# Target Specs
+# ----------------------------------------------------
+MODULES = \
+ compile \
+ sys_pre_attributes \
+ sys_pre_expand \
+ sys_expand_pmod \
+ v3_core \
+ sys_core_fold \
+ sys_core_inline \
+ sys_core_dsetel \
+ core_lib \
+ core_scan \
+ core_parse \
+ core_lint \
+ core_pp \
+ v3_kernel \
+ v3_kernel_pp \
+ v3_life \
+ v3_codegen \
+ beam_block \
+ beam_bool \
+ beam_dead \
+ beam_jump \
+ beam_type \
+ beam_clean \
+ beam_peep \
+ beam_bsm \
+ beam_trim \
+ beam_flatten \
+ beam_listing \
+ beam_asm \
+ beam_dict \
+ beam_opcodes \
+ beam_disasm \
+ beam_utils \
+ beam_validator \
+ erl_bifs \
+ cerl \
+ cerl_clauses \
+ cerl_inline \
+ cerl_trees \
+ rec_env
+
+BEAM_H = $(wildcard ../priv/beam_h/*.h)
+
+HRL_FILES= \
+ beam_disasm.hrl \
+ core_parse.hrl \
+ v3_kernel.hrl \
+ v3_life.hrl
+
+YRL_FILE = core_parse.yrl
+
+EXTRA_FILES= $(EGEN)/beam_opcodes.hrl
+
+ERL_FILES= $(MODULES:%=%.erl)
+INSTALL_FILES= $(MODULES:%=$(EBIN)/%.$(EMULATOR)) $(APP_TARGET) $(APPUP_TARGET)
+TARGET_FILES= $(INSTALL_FILES)
+
+APP_FILE= compiler.app
+APP_SRC= $(APP_FILE).src
+APP_TARGET= $(EBIN)/$(APP_FILE)
+
+APPUP_FILE= compiler.appup
+APPUP_SRC= $(APPUP_FILE).src
+APPUP_TARGET= $(EBIN)/$(APPUP_FILE)
+
+# ----------------------------------------------------
+# FLAGS
+# ----------------------------------------------------
+
+ERL_COMPILE_FLAGS += +inline +warn_unused_import -I../../stdlib/include -I$(EGEN) -W
+
+# ----------------------------------------------------
+# Targets
+# ----------------------------------------------------
+
+debug opt: $(TARGET_FILES)
+
+docs:
+
+clean:
+ rm -f $(TARGET_FILES)
+ rm -f $(EGEN)/beam_opcodes.erl $(EGEN)/beam_opcodes.hrl
+ rm -f $(EGEN)/core_parse.erl
+ rm -f core
+
+# ----------------------------------------------------
+# Special Build Targets
+# ----------------------------------------------------
+
+$(APP_TARGET): $(APP_SRC) ../vsn.mk
+ sed -e 's;%VSN%;$(VSN);' $< > $@
+
+$(APPUP_TARGET): $(APPUP_SRC) ../vsn.mk
+ sed -e 's;%VSN%;$(VSN);' $< > $@
+
+$(EGEN)/beam_opcodes.erl $(EGEN)/beam_opcodes.hrl: genop.tab
+ $(PERL) $(ERL_TOP)/erts/emulator/utils/beam_makeops -compiler -outdir $(EGEN) $<
+
+$(EBIN)/beam_asm.beam: $(ESRC)/beam_asm.erl $(EGEN)/beam_opcodes.hrl
+ $(ERLC) $(ERL_COMPILE_FLAGS) -DCOMPILER_VSN='"$(VSN)"' -o$(EBIN) $<
+
+$(EBIN)/cerl_inline.beam: $(ESRC)/cerl_inline.erl
+ $(ERLC) $(ERL_COMPILE_FLAGS) +nowarn_shadow_vars -o$(EBIN) $<
+
+# ----------------------------------------------------
+# Release Target
+# ----------------------------------------------------
+include $(ERL_TOP)/make/otp_release_targets.mk
+
+release_spec: opt
+ $(INSTALL_DIR) $(RELSYSDIR)/src
+ $(INSTALL_DATA) $(ERL_FILES) $(HRL_FILES) $(EXTRA_FILES) \
+ $(YRL_FILE) $(RELSYSDIR)/src
+ $(INSTALL_DIR) $(RELSYSDIR)/ebin
+ $(INSTALL_DATA) $(INSTALL_FILES) $(RELSYSDIR)/ebin
+
+release_docs_spec:
+
+# ----------------------------------------------------
+# Dependencies -- alphabetically, please
+# ----------------------------------------------------
+
+$(EBIN)/beam_disasm.beam: $(EGEN)/beam_opcodes.hrl beam_disasm.hrl
+$(EBIN)/beam_listing.beam: v3_life.hrl
+$(EBIN)/beam_validator.beam: beam_disasm.hrl
+$(EBIN)/cerl.beam: core_parse.hrl
+$(EBIN)/compile.beam: core_parse.hrl ../../stdlib/include/erl_compile.hrl
+$(EBIN)/core_lib.beam: core_parse.hrl
+$(EBIN)/core_lint.beam: core_parse.hrl
+$(EBIN)/core_parse.beam: core_parse.hrl $(EGEN)/core_parse.erl
+$(EBIN)/core_pp.beam: core_parse.hrl
+$(EBIN)/sys_core_dsetel.beam: core_parse.hrl
+$(EBIN)/sys_core_fold.beam: core_parse.hrl
+$(EBIN)/sys_core_inline.beam: core_parse.hrl
+$(EBIN)/sys_pre_expand.beam: ../../stdlib/include/erl_bits.hrl
+$(EBIN)/v3_codegen.beam: v3_life.hrl
+$(EBIN)/v3_core.beam: core_parse.hrl
+$(EBIN)/v3_kernel.beam: core_parse.hrl v3_kernel.hrl
+$(EBIN)/v3_kernel_pp.beam: v3_kernel.hrl
+$(EBIN)/v3_life.beam: v3_kernel.hrl v3_life.hrl
diff --git a/lib/compiler/src/beam_asm.erl b/lib/compiler/src/beam_asm.erl
new file mode 100644
index 0000000000..90d25d87b2
--- /dev/null
+++ b/lib/compiler/src/beam_asm.erl
@@ -0,0 +1,419 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1996-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%
+%%
+%% Purpose : Assembler for threaded Beam.
+
+-module(beam_asm).
+
+-export([module/4]).
+-export([encode/2]).
+
+-import(lists, [map/2,member/2,keymember/3,duplicate/2,filter/2]).
+-include("beam_opcodes.hrl").
+
+module(Code, Abst, SourceFile, Opts) ->
+ {ok,assemble(Code, Abst, SourceFile, Opts)}.
+
+assemble({Mod,Exp,Attr0,Asm0,NumLabels}, Abst, SourceFile, Opts) ->
+ {1,Dict0} = beam_dict:atom(Mod, beam_dict:new()),
+ NumFuncs = length(Asm0),
+ {Asm,Attr} = on_load(Asm0, Attr0),
+ {Code,Dict1} = assemble_1(Asm, Exp, Dict0, []),
+ build_file(Code, Attr, Dict1, NumLabels, NumFuncs, Abst, SourceFile, Opts).
+
+on_load(Fs0, Attr0) ->
+ case proplists:get_value(on_load, Attr0) of
+ undefined ->
+ {Fs0,Attr0};
+ [{Name,0}] ->
+ Fs = map(fun({function,N,0,Entry,Asm0}) when N =:= Name ->
+ [{label,_}=L,
+ {func_info,_,_,_}=Fi,
+ {label,_}=E|Asm1] = Asm0,
+ Asm = [L,Fi,E,on_load|Asm1],
+ {function,N,0,Entry,Asm};
+ (F) ->
+ F
+ end, Fs0),
+ Attr = proplists:delete(on_load, Attr0),
+ {Fs,Attr}
+ end.
+
+assemble_1([{function,Name,Arity,Entry,Asm}|T], Exp, Dict0, Acc) ->
+ Dict1 = case member({Name,Arity}, Exp) of
+ true ->
+ beam_dict:export(Name, Arity, Entry, Dict0);
+ false ->
+ beam_dict:local(Name, Arity, Entry, Dict0)
+ end,
+ {Code, Dict2} = assemble_function(Asm, Acc, Dict1),
+ assemble_1(T, Exp, Dict2, Code);
+assemble_1([], _Exp, Dict0, Acc) ->
+ {IntCodeEnd,Dict1} = make_op(int_code_end, Dict0),
+ {list_to_binary(lists:reverse(Acc, [IntCodeEnd])),Dict1}.
+
+assemble_function([H|T], Acc, Dict0) ->
+ {Code, Dict} = make_op(H, Dict0),
+ assemble_function(T, [Code| Acc], Dict);
+assemble_function([], Code, Dict) ->
+ {Code, Dict}.
+
+build_file(Code, Attr, Dict, NumLabels, NumFuncs, Abst, SourceFile, Opts) ->
+ %% Create the code chunk.
+
+ CodeChunk = chunk(<<"Code">>,
+ <<16:32,
+ (beam_opcodes:format_number()):32,
+ (beam_dict:highest_opcode(Dict)):32,
+ NumLabels:32,
+ NumFuncs:32>>,
+ Code),
+
+ %% Create the atom table chunk.
+
+ {NumAtoms, AtomTab} = beam_dict:atom_table(Dict),
+ AtomChunk = chunk(<<"Atom">>, <<NumAtoms:32>>, AtomTab),
+
+ %% Create the import table chunk.
+
+ {NumImps, ImpTab0} = beam_dict:import_table(Dict),
+ Imp = flatten_imports(ImpTab0),
+ ImportChunk = chunk(<<"ImpT">>, <<NumImps:32>>, Imp),
+
+ %% Create the export table chunk.
+
+ {NumExps, ExpTab0} = beam_dict:export_table(Dict),
+ Exp = flatten_exports(ExpTab0),
+ ExpChunk = chunk(<<"ExpT">>, <<NumExps:32>>, Exp),
+
+ %% Create the local function table chunk.
+
+ {NumLocals, Locals} = beam_dict:local_table(Dict),
+ Loc = flatten_exports(Locals),
+ LocChunk = chunk(<<"LocT">>, <<NumLocals:32>>, Loc),
+
+ %% Create the string table chunk.
+
+ {_,StringTab} = beam_dict:string_table(Dict),
+ StringChunk = chunk(<<"StrT">>, StringTab),
+
+ %% Create the fun table chunk. It is important not to build an empty chunk,
+ %% as that would change the MD5.
+
+ LambdaChunk = case beam_dict:lambda_table(Dict) of
+ {0,[]} -> [];
+ {NumLambdas,LambdaTab} ->
+ chunk(<<"FunT">>, <<NumLambdas:32>>, LambdaTab)
+ end,
+
+ %% Create the literal table chunk. It is important not to build an empty chunk,
+ %% as that would change the MD5.
+
+ LiteralChunk = case beam_dict:literal_table(Dict) of
+ {0,[]} -> [];
+ {NumLiterals,LitTab0} ->
+ LitTab1 = iolist_to_binary(LitTab0),
+ LitTab2 = <<NumLiterals:32,LitTab1/binary>>,
+ LitTab = iolist_to_binary(zlib:compress(LitTab2)),
+ chunk(<<"LitT">>, <<(byte_size(LitTab2)):32>>, LitTab)
+ end,
+
+
+ %% Create the attributes and compile info chunks.
+
+ Essentials0 = [AtomChunk,CodeChunk,StringChunk,ImportChunk,
+ ExpChunk,LambdaChunk,LiteralChunk],
+ Essentials = [iolist_to_binary(C) || C <- Essentials0],
+ {Attributes,Compile} = build_attributes(Opts, SourceFile, Attr, Essentials),
+ AttrChunk = chunk(<<"Attr">>, Attributes),
+ CompileChunk = chunk(<<"CInf">>, Compile),
+
+ %% Create the abstract code chunk.
+
+ AbstChunk = chunk(<<"Abst">>, Abst),
+
+ %% Create IFF chunk.
+
+ Chunks = case member(slim, Opts) of
+ true -> [Essentials,AttrChunk,CompileChunk,AbstChunk];
+ false -> [Essentials,LocChunk,AttrChunk,CompileChunk,AbstChunk]
+ end,
+ build_form(<<"BEAM">>, Chunks).
+
+%% Build an IFF form.
+
+build_form(Id, Chunks0) when byte_size(Id) =:= 4, is_list(Chunks0) ->
+ Chunks = list_to_binary(Chunks0),
+ Size = byte_size(Chunks),
+ 0 = Size rem 4, % Assertion: correct padding?
+ <<"FOR1",(Size+4):32,Id/binary,Chunks/binary>>.
+
+%% Build a correctly padded chunk (with no sub-header).
+
+chunk(Id, Contents) when byte_size(Id) =:= 4, is_binary(Contents) ->
+ Size = byte_size(Contents),
+ [<<Id/binary,Size:32>>,Contents|pad(Size)];
+chunk(Id, Contents) when is_list(Contents) ->
+ chunk(Id, list_to_binary(Contents)).
+
+%% Build a correctly padded chunk (with a sub-header).
+
+chunk(Id, Head, Contents) when byte_size(Id) =:= 4, is_binary(Head), is_binary(Contents) ->
+ Size = byte_size(Head)+byte_size(Contents),
+ [<<Id/binary,Size:32,Head/binary>>,Contents|pad(Size)];
+chunk(Id, Head, Contents) when is_list(Contents) ->
+ chunk(Id, Head, list_to_binary(Contents)).
+
+pad(Size) ->
+ case Size rem 4 of
+ 0 -> [];
+ Rem -> duplicate(4 - Rem, 0)
+ end.
+
+flatten_exports(Exps) ->
+ list_to_binary(map(fun({F,A,L}) -> <<F:32,A:32,L:32>> end, Exps)).
+
+flatten_imports(Imps) ->
+ list_to_binary(map(fun({M,F,A}) -> <<M:32,F:32,A:32>> end, Imps)).
+
+build_attributes(Opts, SourceFile, Attr0, Essentials) ->
+ Attr = filter(fun({type,_}) -> false;
+ ({spec,_}) -> false;
+ (_) -> true
+ end, Attr0),
+ Misc = case member(slim, Opts) of
+ false ->
+ {{Y,Mo,D},{H,Mi,S}} = erlang:universaltime(),
+ [{time,{Y,Mo,D,H,Mi,S}},{source,SourceFile}];
+ true -> []
+ end,
+ Compile = [{options,Opts},{version,?COMPILER_VSN}|Misc],
+ {term_to_binary(calc_vsn(Attr, Essentials)),term_to_binary(Compile)}.
+
+%%
+%% If the attributes contains no 'vsn' attribute, we'll insert one
+%% with an MD5 "checksum" calculated on the code as its value.
+%% We'll not change an existing 'vsn' attribute.
+%%
+
+calc_vsn(Attr, Essentials0) ->
+ case keymember(vsn, 1, Attr) of
+ true -> Attr;
+ false ->
+ Essentials = filter_essentials(Essentials0),
+ <<Number:128>> = erlang:md5(Essentials),
+ [{vsn,[Number]}|Attr]
+ end.
+
+%% filter_essentials([Chunk]) -> [Chunk']
+%% Filter essentials so that we obtain the same MD5 as code:module_md5/1 and
+%% beam_lib:md5/1 would calculate for this module.
+
+filter_essentials([<<"FunT",_Sz:4/binary,Entries:4/binary,Table0/binary>>|T]) ->
+ Table = filter_funtab(Table0, <<0:32>>),
+ [Entries,Table|filter_essentials(T)];
+filter_essentials([<<_Tag:4/binary,Sz:32,Data:Sz/binary,_Padding/binary>>|T]) ->
+ [Data|filter_essentials(T)];
+filter_essentials([<<>>|T]) ->
+ filter_essentials(T);
+filter_essentials([]) -> [].
+
+filter_funtab(<<Important:20/binary,_OldUniq:4/binary,T/binary>>, Zero) ->
+ [Important,Zero|filter_funtab(T, Zero)];
+filter_funtab(<<>>, _) -> [].
+
+bif_type(fnegate, 1) -> {op,fnegate};
+bif_type(fadd, 2) -> {op,fadd};
+bif_type(fsub, 2) -> {op,fsub};
+bif_type(fmul, 2) -> {op,fmul};
+bif_type(fdiv, 2) -> {op,fdiv};
+bif_type(_, 1) -> bif1;
+bif_type(_, 2) -> bif2.
+
+make_op({'%',_}, Dict) ->
+ {[],Dict};
+make_op({bif, Bif, {f,_}, [], Dest}, Dict) ->
+ %% BIFs without arguments cannot fail.
+ encode_op(bif0, [{extfunc, erlang, Bif, 0}, Dest], Dict);
+make_op({bif, raise, _Fail, [_A1,_A2] = Args, _Dest}, Dict) ->
+ encode_op(raise, Args, Dict);
+make_op({bif,Bif,Fail,Args,Dest}, Dict) ->
+ Arity = length(Args),
+ case bif_type(Bif, Arity) of
+ {op,Op} ->
+ make_op(list_to_tuple([Op,Fail|Args++[Dest]]), Dict);
+ BifOp when is_atom(BifOp) ->
+ encode_op(BifOp, [Fail,{extfunc,erlang,Bif,Arity}|Args++[Dest]],
+ Dict)
+ end;
+make_op({gc_bif,Bif,Fail,Live,Args,Dest}, Dict) ->
+ Arity = length(Args),
+ BifOp = case Arity of
+ 1 -> gc_bif1;
+ 2 -> gc_bif2
+ end,
+ encode_op(BifOp, [Fail,Live,{extfunc,erlang,Bif,Arity}|Args++[Dest]],Dict);
+make_op({bs_add=Op,Fail,[Src1,Src2,Unit],Dest}, Dict) ->
+ encode_op(Op, [Fail,Src1,Src2,Unit,Dest], Dict);
+make_op({test,Cond,Fail,Ops}, Dict) when is_list(Ops) ->
+ encode_op(Cond, [Fail|Ops], Dict);
+make_op({test,Cond,Fail,Live,[Op|Ops],Dst}, Dict) when is_list(Ops) ->
+ encode_op(Cond, [Fail,Op,Live|Ops++[Dst]], Dict);
+make_op({make_fun2,{f,Lbl},Index,OldUniq,NumFree}, Dict0) ->
+ {Fun,Dict} = beam_dict:lambda(Lbl, Index, OldUniq, NumFree, Dict0),
+ make_op({make_fun2,Fun}, Dict);
+make_op({kill,Y}, Dict) ->
+ make_op({init,Y}, Dict);
+make_op({Name,Arg1}, Dict) ->
+ encode_op(Name, [Arg1], Dict);
+make_op({Name,Arg1,Arg2}, Dict) ->
+ encode_op(Name, [Arg1,Arg2], Dict);
+make_op({Name,Arg1,Arg2,Arg3}, Dict) ->
+ encode_op(Name, [Arg1,Arg2,Arg3], Dict);
+make_op({Name,Arg1,Arg2,Arg3,Arg4}, Dict) ->
+ encode_op(Name, [Arg1,Arg2,Arg3,Arg4], Dict);
+make_op({Name,Arg1,Arg2,Arg3,Arg4,Arg5}, Dict) ->
+ encode_op(Name, [Arg1,Arg2,Arg3,Arg4,Arg5], Dict);
+make_op({Name,Arg1,Arg2,Arg3,Arg4,Arg5,Arg6}, Dict) ->
+ encode_op(Name, [Arg1,Arg2,Arg3,Arg4,Arg5,Arg6], Dict);
+%% make_op({Name,Arg1,Arg2,Arg3,Arg4,Arg5,Arg6,Arg7}, Dict) ->
+%% encode_op(Name, [Arg1,Arg2,Arg3,Arg4,Arg5,Arg6,Arg7], Dict);
+make_op({Name,Arg1,Arg2,Arg3,Arg4,Arg5,Arg6,Arg7,Arg8}, Dict) ->
+ encode_op(Name, [Arg1,Arg2,Arg3,Arg4,Arg5,Arg6,Arg7,Arg8], Dict);
+make_op(Op, Dict) when is_atom(Op) ->
+ encode_op(Op, [], Dict).
+
+encode_op(Name, Args, Dict0) when is_atom(Name) ->
+ Op = beam_opcodes:opcode(Name, length(Args)),
+ Dict = beam_dict:opcode(Op, Dict0),
+ encode_op_1(Args, Dict, Op).
+
+encode_op_1([A0|As], Dict0, Acc) ->
+ {A,Dict} = encode_arg(A0, Dict0),
+ encode_op_1(As, Dict, [Acc,A]);
+encode_op_1([], Dict, Acc) -> {Acc,Dict}.
+
+encode_arg({x, X}, Dict) when is_integer(X), X >= 0 ->
+ {encode(?tag_x, X), Dict};
+encode_arg({y, Y}, Dict) when is_integer(Y), Y >= 0 ->
+ {encode(?tag_y, Y), Dict};
+encode_arg({atom, Atom}, Dict0) when is_atom(Atom) ->
+ {Index, Dict} = beam_dict:atom(Atom, Dict0),
+ {encode(?tag_a, Index), Dict};
+encode_arg({integer, N}, Dict) ->
+ {encode(?tag_i, N), Dict};
+encode_arg(nil, Dict) ->
+ {encode(?tag_a, 0), Dict};
+encode_arg({f, W}, Dict) ->
+ {encode(?tag_f, W), Dict};
+%% encode_arg({'char', C}, Dict) ->
+%% {encode(?tag_h, C), Dict};
+encode_arg({string, String}, Dict0) ->
+ {Offset, Dict} = beam_dict:string(String, Dict0),
+ {encode(?tag_u, Offset), Dict};
+encode_arg({extfunc, M, F, A}, Dict0) ->
+ {Index, Dict} = beam_dict:import(M, F, A, Dict0),
+ {encode(?tag_u, Index), Dict};
+encode_arg({list, List}, Dict0) ->
+ {L, Dict} = encode_list(List, Dict0, []),
+ {[encode(?tag_z, 1), encode(?tag_u, length(List))|L], Dict};
+encode_arg({float, Float}, Dict) when is_float(Float) ->
+ {[encode(?tag_z, 0),<<Float:64/float>>], Dict};
+encode_arg({fr,Fr}, Dict) ->
+ {[encode(?tag_z, 2),encode(?tag_u, Fr)], Dict};
+encode_arg({field_flags,Flags0}, Dict) ->
+ Flags = lists:foldl(fun (F, S) -> S bor flag_to_bit(F) end, 0, Flags0),
+ {encode(?tag_u, Flags), Dict};
+encode_arg({alloc,List}, Dict) ->
+ encode_alloc_list(List, Dict);
+encode_arg({literal,Lit}, Dict0) ->
+ {Index,Dict} = beam_dict:literal(Lit, Dict0),
+ {[encode(?tag_z, 4),encode(?tag_u, Index)],Dict};
+encode_arg(Int, Dict) when is_integer(Int) ->
+ {encode(?tag_u, Int),Dict}.
+
+%%flag_to_bit(aligned) -> 16#01; %% No longer useful.
+flag_to_bit(little) -> 16#02;
+flag_to_bit(big) -> 16#00;
+flag_to_bit(signed) -> 16#04;
+flag_to_bit(unsigned)-> 16#00;
+%%flag_to_bit(exact) -> 16#08;
+flag_to_bit(native) -> 16#10;
+flag_to_bit({anno,_}) -> 0.
+
+encode_list([H|T], Dict0, Acc) when not is_list(H) ->
+ {Enc,Dict} = encode_arg(H, Dict0),
+ encode_list(T, Dict, [Acc,Enc]);
+encode_list([], Dict, Acc) -> {Acc,Dict}.
+
+encode_alloc_list(L0, Dict0) ->
+ {Bin,Dict} = encode_alloc_list_1(L0, Dict0, []),
+ {[encode(?tag_z, 3),encode(?tag_u, length(L0)),Bin],Dict}.
+
+encode_alloc_list_1([{words,Words}|T], Dict, Acc0) ->
+ Acc = [Acc0,encode(?tag_u, 0),encode(?tag_u, Words)],
+ encode_alloc_list_1(T, Dict, Acc);
+encode_alloc_list_1([{floats,Floats}|T], Dict, Acc0) ->
+ Acc = [Acc0,encode(?tag_u, 1),encode(?tag_u, Floats)],
+ encode_alloc_list_1(T, Dict, Acc);
+encode_alloc_list_1([], Dict, Acc) ->
+ {iolist_to_binary(Acc),Dict}.
+
+encode(Tag, N) when N < 0 ->
+ encode1(Tag, negative_to_bytes(N, []));
+encode(Tag, N) when N < 16 ->
+ (N bsl 4) bor Tag;
+encode(Tag, N) when N < 16#800 ->
+ [((N bsr 3) band 2#11100000) bor Tag bor 2#00001000, N band 16#ff];
+encode(Tag, N) ->
+ encode1(Tag, to_bytes(N, [])).
+
+encode1(Tag, Bytes) ->
+ case length(Bytes) of
+ Num when 2 =< Num, Num =< 8 ->
+ [((Num-2) bsl 5) bor 2#00011000 bor Tag| Bytes];
+ Num when 8 < Num ->
+ [2#11111000 bor Tag, encode(?tag_u, Num-9)| Bytes]
+ end.
+
+
+to_bytes(N0, Acc) ->
+ Bits = 3*128,
+ case N0 bsr Bits of
+ 0 ->
+ to_bytes_1(N0, Acc);
+ N ->
+ to_bytes(N, binary_to_list(<<N0:Bits>>) ++ Acc)
+ end.
+
+to_bytes_1(0, [B|_]=Done) when B < 128 -> Done;
+to_bytes_1(N, Acc) -> to_bytes(N bsr 8, [N band 16#ff|Acc]).
+
+negative_to_bytes(N0, Acc) ->
+ Bits = 3*128,
+ case N0 bsr Bits of
+ -1 ->
+ negative_to_bytes_1(N0, Acc);
+ N ->
+ negative_to_bytes_1(N, binary_to_list(<<N0:Bits>>) ++ Acc)
+ end.
+
+negative_to_bytes_1(-1, [B1,_B2|_]=Done) when B1 > 127 ->
+ Done;
+negative_to_bytes_1(N, Acc) ->
+ negative_to_bytes_1(N bsr 8, [N band 16#ff|Acc]).
diff --git a/lib/compiler/src/beam_block.erl b/lib/compiler/src/beam_block.erl
new file mode 100644
index 0000000000..d4a4ddca8a
--- /dev/null
+++ b/lib/compiler/src/beam_block.erl
@@ -0,0 +1,624 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1999-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%
+%%
+%% Purpose : Partitions assembly instructions into basic blocks and
+%% optimizes them.
+
+-module(beam_block).
+
+-export([module/2]).
+-import(lists, [mapfoldl/3,reverse/1,reverse/2,foldl/3,member/2]).
+-define(MAXREG, 1024).
+
+module({Mod,Exp,Attr,Fs0,Lc0}, _Opt) ->
+ {Fs,Lc} = mapfoldl(fun function/2, Lc0, Fs0),
+ {ok,{Mod,Exp,Attr,Fs,Lc}}.
+
+function({function,Name,Arity,CLabel,Is0}, Lc0) ->
+ try
+ %% Extra labels may thwart optimizations.
+ Is1 = beam_jump:remove_unused_labels(Is0),
+
+ %% Collect basic blocks and optimize them.
+ Is2 = blockify(Is1),
+ Is3 = beam_utils:live_opt(Is2),
+ Is4 = opt_blocks(Is3),
+ Is5 = beam_utils:delete_live_annos(Is4),
+
+ %% Optimize bit syntax.
+ {Is,Lc} = bsm_opt(Is5, Lc0),
+
+ %% Done.
+ {{function,Name,Arity,CLabel,Is},Lc}
+ catch
+ Class:Error ->
+ Stack = erlang:get_stacktrace(),
+ io:fwrite("Function: ~w/~w\n", [Name,Arity]),
+ erlang:raise(Class, Error, Stack)
+ end.
+
+%% blockify(Instructions0) -> Instructions
+%% Collect sequences of instructions to basic blocks.
+%% Also do some simple optimations on instructions outside the blocks.
+
+blockify(Is) ->
+ blockify(Is, []).
+
+blockify([{loop_rec,{f,Fail},{x,0}},{loop_rec_end,_Lbl},{label,Fail}|Is], Acc) ->
+ %% Useless instruction sequence.
+ blockify(Is, Acc);
+
+%% New bit syntax matching.
+blockify([{bs_save2,R,Point}=I,{bs_restore2,R,Point}|Is], Acc) ->
+ blockify([I|Is], Acc);
+blockify([{bs_save2,R,Point}=I,{test,is_eq_exact,_,_}=Test,
+ {bs_restore2,R,Point}|Is], Acc) ->
+ blockify([I,Test|Is], Acc);
+
+%% Do other peep-hole optimizations.
+blockify([{test,is_atom,{f,Fail},[Reg]}=I|
+ [{select_val,Reg,{f,Fail},
+ {list,[{atom,false},{f,_}=BrFalse,
+ {atom,true}=AtomTrue,{f,_}=BrTrue]}}|Is]=Is0],
+ [{block,Bl}|_]=Acc) ->
+ case is_last_bool(Bl, Reg) of
+ false ->
+ blockify(Is0, [I|Acc]);
+ true ->
+ %% The last instruction is a boolean operator/guard BIF that can't fail.
+ %% We can convert the three-way branch to a two-way branch (eliminating
+ %% the reference to the failure label).
+ blockify(Is, [{jump,BrTrue},
+ {test,is_eq_exact,BrFalse,[Reg,AtomTrue]}|Acc])
+ end;
+blockify([{test,is_atom,{f,Fail},[Reg]}=I|
+ [{select_val,Reg,{f,Fail},
+ {list,[{atom,true}=AtomTrue,{f,_}=BrTrue,
+ {atom,false},{f,_}=BrFalse]}}|Is]=Is0],
+ [{block,Bl}|_]=Acc) ->
+ case is_last_bool(Bl, Reg) of
+ false ->
+ blockify(Is0, [I|Acc]);
+ true ->
+ blockify(Is, [{jump,BrTrue},
+ {test,is_eq_exact,BrFalse,[Reg,AtomTrue]}|Acc])
+ end;
+blockify([I|Is0]=IsAll, Acc) ->
+ case is_bs_put(I) of
+ true ->
+ {BsPuts0,Is} = collect_bs_puts(IsAll),
+ BsPuts = opt_bs_puts(BsPuts0),
+ blockify(Is, reverse(BsPuts, Acc));
+ false ->
+ case collect(I) of
+ error -> blockify(Is0, [I|Acc]);
+ Instr when is_tuple(Instr) ->
+ {Block,Is} = collect_block(IsAll),
+ blockify(Is, [{block,Block}|Acc])
+ end
+ end;
+blockify([], Acc) -> reverse(Acc).
+
+is_last_bool([{set,[Reg],As,{bif,N,_}}], Reg) ->
+ Ar = length(As),
+ erl_internal:new_type_test(N, Ar) orelse erl_internal:comp_op(N, Ar)
+ orelse erl_internal:bool_op(N, Ar);
+is_last_bool([_|Is], Reg) -> is_last_bool(Is, Reg);
+is_last_bool([], _) -> false.
+
+collect_block(Is) ->
+ collect_block(Is, []).
+
+collect_block([{allocate_zero,Ns,R},{test_heap,Nh,R}|Is], Acc) ->
+ collect_block(Is, [{set,[],[],{alloc,R,{no_opt,Ns,Nh,[]}}}|Acc]);
+collect_block([I|Is]=Is0, Acc) ->
+ case collect(I) of
+ error -> {reverse(Acc),Is0};
+ Instr -> collect_block(Is, [Instr|Acc])
+ end.
+
+collect({allocate_zero,N,R}) -> {set,[],[],{alloc,R,{zero,N,0,[]}}};
+collect({test_heap,N,R}) -> {set,[],[],{alloc,R,{nozero,nostack,N,[]}}};
+collect({bif,N,F,As,D}) -> {set,[D],As,{bif,N,F}};
+collect({gc_bif,N,F,R,As,D}) -> {set,[D],As,{alloc,R,{gc_bif,N,F}}};
+collect({move,S,D}) -> {set,[D],[S],move};
+collect({put_list,S1,S2,D}) -> {set,[D],[S1,S2],put_list};
+collect({put_tuple,A,D}) -> {set,[D],[],{put_tuple,A}};
+collect({put,S}) -> {set,[],[S],put};
+collect({put_string,L,S,D}) -> {set,[D],[],{put_string,L,S}};
+collect({get_tuple_element,S,I,D}) -> {set,[D],[S],{get_tuple_element,I}};
+collect({set_tuple_element,S,D,I}) -> {set,[],[S,D],{set_tuple_element,I}};
+collect({get_list,S,D1,D2}) -> {set,[D1,D2],[S],get_list};
+collect(remove_message) -> {set,[],[],remove_message};
+collect({'catch',R,L}) -> {set,[R],[],{'catch',L}};
+collect(_) -> error.
+
+opt_blocks([{block,Bl0}|Is]) ->
+ %% The live annotation at the beginning is not useful.
+ [{'%live',_}|Bl] = Bl0,
+ [{block,opt_block(Bl)}|opt_blocks(Is)];
+opt_blocks([I|Is]) ->
+ [I|opt_blocks(Is)];
+opt_blocks([]) -> [].
+
+opt_block(Is0) ->
+ %% We explicitly move any allocate instruction upwards before optimising
+ %% moves, to avoid any potential problems with the calculation of live
+ %% registers.
+ Is1 = move_allocates(Is0),
+ Is = find_fixpoint(fun opt/1, Is1),
+ opt_alloc(Is).
+
+find_fixpoint(OptFun, Is0) ->
+ case OptFun(Is0) of
+ Is0 -> Is0;
+ Is1 -> find_fixpoint(OptFun, Is1)
+ end.
+
+%% move_allocates(Is0) -> Is
+%% Move allocates upwards in the instruction stream, in the hope of
+%% getting more possibilities for optimizing away moves later.
+
+move_allocates(Is) ->
+ move_allocates_1(reverse(Is), []).
+
+move_allocates_1([{set,[],[],{alloc,_,_}=Alloc}|Is0], Acc0) ->
+ {Is,Acc} = move_allocates_2(Alloc, Is0, Acc0),
+ move_allocates_1(Is, Acc);
+move_allocates_1([I|Is], Acc) ->
+ move_allocates_1(Is, [I|Acc]);
+move_allocates_1([], Is) -> Is.
+
+move_allocates_2({alloc,Live,Info}, [{set,[],[],{alloc,Live0,Info0}}|Is], Acc) ->
+ Live = Live0, % Assertion.
+ Alloc = {alloc,Live,combine_alloc(Info0, Info)},
+ move_allocates_2(Alloc, Is, Acc);
+move_allocates_2({alloc,Live,Info}=Alloc0, [I|Is]=Is0, Acc) ->
+ case alloc_may_pass(I) of
+ false ->
+ {Is0,[{set,[],[],Alloc0}|Acc]};
+ true ->
+ Alloc = {alloc,alloc_live_regs(I, Live),Info},
+ move_allocates_2(Alloc, Is, [I|Acc])
+ end;
+move_allocates_2(Alloc, [], Acc) ->
+ {[],[{set,[],[],Alloc}|Acc]}.
+
+alloc_may_pass({set,_,_,{alloc,_,_}}) -> false;
+alloc_may_pass({set,_,_,{set_tuple_element,_}}) -> false;
+alloc_may_pass({set,_,_,put_list}) -> false;
+alloc_may_pass({set,_,_,{put_tuple,_}}) -> false;
+alloc_may_pass({set,_,_,put}) -> false;
+alloc_may_pass({set,_,_,{put_string,_,_}}) -> false;
+alloc_may_pass({set,_,_,_}) -> true.
+
+combine_alloc({_,Ns,Nh1,Init}, {_,nostack,Nh2,[]}) ->
+ {zero,Ns,beam_utils:combine_heap_needs(Nh1, Nh2),Init}.
+
+%% opt([Instruction]) -> [Instruction]
+%% Optimize the instruction stream inside a basic block.
+
+opt([{set,[Dst],As,{bif,Bif,Fail}}=I1,
+ {set,[Dst],[Dst],{bif,'not',Fail}}=I2|Is]) ->
+ %% Get rid of the 'not' if the operation can be inverted.
+ case inverse_comp_op(Bif) of
+ none -> [I1,I2|opt(Is)];
+ RevBif -> [{set,[Dst],As,{bif,RevBif,Fail}}|opt(Is)]
+ end;
+opt([{set,[X],[X],move}|Is]) -> opt(Is);
+opt([{set,[D1],[{integer,Idx1},Reg],{bif,element,{f,0}}}=I1,
+ {set,[D2],[{integer,Idx2},Reg],{bif,element,{f,0}}}=I2|Is])
+ when Idx1 < Idx2, D1 =/= D2, D1 =/= Reg, D2 =/= Reg ->
+ opt([I2,I1|Is]);
+opt([{set,Ds0,Ss,Op}|Is0]) ->
+ {Ds,Is} = opt_moves(Ds0, Is0),
+ [{set,Ds,Ss,Op}|opt(Is)];
+opt([{'%live',_}=I|Is]) ->
+ [I|opt(Is)];
+opt([]) -> [].
+
+%% opt_moves([Dest], [Instruction]) -> {[Dest],[Instruction]}
+%% For each Dest, does the optimization described in opt_move/2.
+
+opt_moves([], Is0) -> {[],Is0};
+opt_moves([D0]=Ds, Is0) ->
+ case opt_move(D0, Is0) of
+ not_possible -> {Ds,Is0};
+ {D1,Is} -> {[D1],Is}
+ end;
+opt_moves([X0,Y0], Is0) ->
+ {X,Is2} = case opt_move(X0, Is0) of
+ not_possible -> {X0,Is0};
+ {Y0,_} -> {X0,Is0};
+ {_X1,_Is1} = XIs1 -> XIs1
+ end,
+ case opt_move(Y0, Is2) of
+ not_possible -> {[X,Y0],Is2};
+ {X,_} -> {[X,Y0],Is2};
+ {Y,Is} -> {[X,Y],Is}
+ end.
+
+%% opt_move(Dest, [Instruction]) -> {UpdatedDest,[Instruction]} | not_possible
+%% If there is a {move,Dest,FinalDest} instruction
+%% in the instruction stream, remove the move instruction
+%% and let FinalDest be the destination.
+%%
+%% For this optimization to be safe, we must be sure that
+%% Dest will not be referenced in any other by other instructions
+%% in the rest of the instruction stream. Not even the indirect
+%% reference by an instruction that may allocate (such as
+%% test_heap/2 or a GC Bif) is allowed.
+
+opt_move(Dest, Is) ->
+ opt_move_1(Dest, Is, ?MAXREG, []).
+
+opt_move_1(R, [{set,_,_,{alloc,Live,_}}|_]=Is, SafeRegs, Acc) when Live < SafeRegs ->
+ %% Downgrade number of safe regs and rescan the instruction, as it most probably
+ %% is a gc_bif instruction.
+ opt_move_1(R, Is, Live, Acc);
+opt_move_1(R, [{set,[{x,X}=D],[R],move}|Is], SafeRegs, Acc) ->
+ case X < SafeRegs andalso beam_utils:is_killed_block(R, Is) of
+ true -> opt_move_2(D, Acc, Is);
+ false -> not_possible
+ end;
+opt_move_1(R, [{set,[D],[R],move}|Is], _SafeRegs, Acc) ->
+ case beam_utils:is_killed_block(R, Is) of
+ true -> opt_move_2(D, Acc, Is);
+ false -> not_possible
+ end;
+opt_move_1(R, [I|Is], SafeRegs, Acc) ->
+ case is_transparent(R, I) of
+ false -> not_possible;
+ true -> opt_move_1(R, Is, SafeRegs, [I|Acc])
+ end.
+
+%% Reverse the instructions, while checking that there are no instructions that
+%% would interfere with using the new destination register chosen.
+
+opt_move_2(D, [I|Is], Acc) ->
+ case is_transparent(D, I) of
+ false -> not_possible;
+ true -> opt_move_2(D, Is, [I|Acc])
+ end;
+opt_move_2(D, [], Acc) -> {D,Acc}.
+
+%% is_transparent(Register, Instruction) -> true | false
+%% Returns true if Instruction does not in any way references Register
+%% (even indirectly by an allocation instruction).
+%% Returns false if Instruction does reference Register, or we are
+%% not sure.
+
+is_transparent({x,X}, {set,_,_,{alloc,Live,_}}) when X < Live ->
+ false;
+is_transparent(R, {set,Ds,Ss,_Op}) ->
+ case member(R, Ds) of
+ true -> false;
+ false -> not member(R, Ss)
+ end;
+is_transparent(_, _) -> false.
+
+%% opt_alloc(Instructions) -> Instructions'
+%% Optimises all allocate instructions.
+
+opt_alloc([{set,[],[],{alloc,R,{_,Ns,Nh,[]}}}|Is]) ->
+ [{set,[],[],opt_alloc(Is, Ns, Nh, R)}|opt(Is)];
+opt_alloc([I|Is]) -> [I|opt_alloc(Is)];
+opt_alloc([]) -> [].
+
+%% opt_alloc(Instructions, FrameSize, HeapNeed, LivingRegs) -> [Instr]
+%% Generates the optimal sequence of instructions for
+%% allocating and initalizing the stack frame and needed heap.
+
+opt_alloc(_Is, nostack, Nh, LivingRegs) ->
+ {alloc,LivingRegs,{nozero,nostack,Nh,[]}};
+opt_alloc(Is, Ns, Nh, LivingRegs) ->
+ InitRegs = init_yreg(Is, 0),
+ case count_ones(InitRegs) of
+ N when N*2 > Ns ->
+ {alloc,LivingRegs,{nozero,Ns,Nh,gen_init(Ns, InitRegs)}};
+ _ ->
+ {alloc,LivingRegs,{zero,Ns,Nh,[]}}
+ end.
+
+gen_init(Fs, Regs) -> gen_init(Fs, Regs, 0, []).
+
+gen_init(SameFs, _Regs, SameFs, Acc) -> reverse(Acc);
+gen_init(Fs, Regs, Y, Acc) when Regs band 1 =:= 0 ->
+ gen_init(Fs, Regs bsr 1, Y+1, [{init,{y,Y}}|Acc]);
+gen_init(Fs, Regs, Y, Acc) ->
+ gen_init(Fs, Regs bsr 1, Y+1, Acc).
+
+%% init_yreg(Instructions, RegSet) -> RegSetInitialized
+%% Calculate the set of initialized y registers.
+
+init_yreg([{set,_,_,{bif,_,_}}|_], Reg) -> Reg;
+init_yreg([{set,_,_,{alloc,_,{gc_bif,_,_}}}|_], Reg) -> Reg;
+init_yreg([{set,Ds,_,_}|Is], Reg) -> init_yreg(Is, add_yregs(Ds, Reg));
+init_yreg(_Is, Reg) -> Reg.
+
+add_yregs(Ys, Reg) -> foldl(fun(Y, R0) -> add_yreg(Y, R0) end, Reg, Ys).
+
+add_yreg({y,Y}, Reg) -> Reg bor (1 bsl Y);
+add_yreg(_, Reg) -> Reg.
+
+count_ones(Bits) -> count_ones(Bits, 0).
+count_ones(0, Acc) -> Acc;
+count_ones(Bits, Acc) ->
+ count_ones(Bits bsr 1, Acc + (Bits band 1)).
+
+%% Calculate the new number of live registers when we move an allocate
+%% instruction upwards, passing a 'set' instruction.
+
+alloc_live_regs({set,Ds,Ss,_}, Regs0) ->
+ Rset = x_live(Ss, x_dead(Ds, (1 bsl Regs0)-1)),
+ live_regs(Rset).
+
+live_regs(Regs) ->
+ live_regs_1(0, Regs).
+
+live_regs_1(N, 0) -> N;
+live_regs_1(N, Regs) -> live_regs_1(N+1, Regs bsr 1).
+
+x_dead([{x,N}|Rs], Regs) -> x_dead(Rs, Regs band (bnot (1 bsl N)));
+x_dead([_|Rs], Regs) -> x_dead(Rs, Regs);
+x_dead([], Regs) -> Regs.
+
+x_live([{x,N}|Rs], Regs) -> x_live(Rs, Regs bor (1 bsl N));
+x_live([_|Rs], Regs) -> x_live(Rs, Regs);
+x_live([], Regs) -> Regs.
+
+%% inverse_comp_op(Op) -> none|RevOp
+
+inverse_comp_op('=:=') -> '=/=';
+inverse_comp_op('=/=') -> '=:=';
+inverse_comp_op('==') -> '/=';
+inverse_comp_op('/=') -> '==';
+inverse_comp_op('>') -> '=<';
+inverse_comp_op('<') -> '>=';
+inverse_comp_op('>=') -> '<';
+inverse_comp_op('=<') -> '>';
+inverse_comp_op(_) -> none.
+
+%%%
+%%% Evaluation of constant bit fields.
+%%%
+
+is_bs_put({bs_put_integer,_,_,_,_,_}) -> true;
+is_bs_put({bs_put_float,_,_,_,_,_}) -> true;
+is_bs_put(_) -> false.
+
+collect_bs_puts(Is) ->
+ collect_bs_puts_1(Is, []).
+
+collect_bs_puts_1([I|Is]=Is0, Acc) ->
+ case is_bs_put(I) of
+ false -> {reverse(Acc),Is0};
+ true -> collect_bs_puts_1(Is, [I|Acc])
+ end.
+
+opt_bs_puts(Is) ->
+ opt_bs_1(Is, []).
+
+opt_bs_1([{bs_put_float,Fail,{integer,Sz},1,Flags0,Src}=I0|Is], Acc) ->
+ try eval_put_float(Src, Sz, Flags0) of
+ <<Int:Sz>> ->
+ Flags = force_big(Flags0),
+ I = {bs_put_integer,Fail,{integer,Sz},1,Flags,{integer,Int}},
+ opt_bs_1([I|Is], Acc)
+ catch
+ error:_ ->
+ opt_bs_1(Is, [I0|Acc])
+ end;
+opt_bs_1([{bs_put_integer,_,{integer,8},1,_,{integer,_}}|_]=IsAll, Acc0) ->
+ {Is,Acc} = bs_collect_string(IsAll, Acc0),
+ opt_bs_1(Is, Acc);
+opt_bs_1([{bs_put_integer,Fail,{integer,Sz},1,F,{integer,N}}=I|Is0], Acc) when Sz > 8 ->
+ case field_endian(F) of
+ big ->
+ %% We can do this optimization for any field size without risk
+ %% for code explosion.
+ case bs_split_int(N, Sz, Fail, Is0) of
+ no_split -> opt_bs_1(Is0, [I|Acc]);
+ Is -> opt_bs_1(Is, Acc)
+ end;
+ little when Sz < 128 ->
+ %% We only try to optimize relatively small fields, to avoid
+ %% an explosion in code size.
+ <<Int:Sz>> = <<N:Sz/little>>,
+ Flags = force_big(F),
+ Is = [{bs_put_integer,Fail,{integer,Sz},1,
+ Flags,{integer,Int}}|Is0],
+ opt_bs_1(Is, Acc);
+ _ -> %native or too wide little field
+ opt_bs_1(Is0, [I|Acc])
+ end;
+opt_bs_1([{Op,Fail,{integer,Sz},U,F,Src}|Is], Acc) when U > 1 ->
+ opt_bs_1([{Op,Fail,{integer,U*Sz},1,F,Src}|Is], Acc);
+opt_bs_1([I|Is], Acc) ->
+ opt_bs_1(Is, [I|Acc]);
+opt_bs_1([], Acc) -> reverse(Acc).
+
+eval_put_float(Src, Sz, Flags) when Sz =< 256 -> %Only evaluate if Sz is reasonable.
+ Val = value(Src),
+ case field_endian(Flags) of
+ little -> <<Val:Sz/little-float-unit:1>>;
+ big -> <<Val:Sz/big-float-unit:1>>
+ %% native intentionally not handled here - we can't optimize it.
+ end.
+
+value({integer,I}) -> I;
+value({float,F}) -> F.
+
+bs_collect_string(Is, [{bs_put_string,Len,{string,Str}}|Acc]) ->
+ bs_coll_str_1(Is, Len, reverse(Str), Acc);
+bs_collect_string(Is, Acc) ->
+ bs_coll_str_1(Is, 0, [], Acc).
+
+bs_coll_str_1([{bs_put_integer,_,{integer,Sz},U,_,{integer,V}}|Is],
+ Len, StrAcc, IsAcc) when U*Sz =:= 8 ->
+ Byte = V band 16#FF,
+ bs_coll_str_1(Is, Len+1, [Byte|StrAcc], IsAcc);
+bs_coll_str_1(Is, Len, StrAcc, IsAcc) ->
+ {Is,[{bs_put_string,Len,{string,reverse(StrAcc)}}|IsAcc]}.
+
+field_endian({field_flags,F}) -> field_endian_1(F).
+
+field_endian_1([big=E|_]) -> E;
+field_endian_1([little=E|_]) -> E;
+field_endian_1([native=E|_]) -> E;
+field_endian_1([_|Fs]) -> field_endian_1(Fs).
+
+force_big({field_flags,F}) ->
+ {field_flags,force_big_1(F)}.
+
+force_big_1([big|_]=Fs) -> Fs;
+force_big_1([little|Fs]) -> [big|Fs];
+force_big_1([F|Fs]) -> [F|force_big_1(Fs)].
+
+bs_split_int(0, Sz, _, _) when Sz > 64 ->
+ %% We don't want to split in this case because the
+ %% string will consist of only zeroes.
+ no_split;
+bs_split_int(-1, Sz, _, _) when Sz > 64 ->
+ %% We don't want to split in this case because the
+ %% string will consist of only 255 bytes.
+ no_split;
+bs_split_int(N, Sz, Fail, Acc) ->
+ FirstByteSz = case Sz rem 8 of
+ 0 -> 8;
+ Rem -> Rem
+ end,
+ bs_split_int_1(N, FirstByteSz, Sz, Fail, Acc).
+
+bs_split_int_1(-1, _, Sz, Fail, Acc) when Sz > 64 ->
+ I = {bs_put_integer,Fail,{integer,Sz},1,{field_flags,[big]},{integer,-1}},
+ [I|Acc];
+bs_split_int_1(0, _, Sz, Fail, Acc) when Sz > 64 ->
+ I = {bs_put_integer,Fail,{integer,Sz},1,{field_flags,[big]},{integer,0}},
+ [I|Acc];
+bs_split_int_1(N, ByteSz, Sz, Fail, Acc) when Sz > 0 ->
+ Mask = (1 bsl ByteSz) - 1,
+ I = {bs_put_integer,Fail,{integer,ByteSz},1,
+ {field_flags,[big]},{integer,N band Mask}},
+ bs_split_int_1(N bsr ByteSz, 8, Sz-ByteSz, Fail, [I|Acc]);
+bs_split_int_1(_, _, _, _, Acc) -> Acc.
+
+
+%%%
+%%% Optimization of new bit syntax matching: get rid
+%%% of redundant bs_restore2/2 instructions across select_val
+%%% instructions, as well as a few other simple peep-hole optimizations.
+%%%
+
+bsm_opt(Is0, Lc0) ->
+ {Is1,D0,Lc} = bsm_scan(Is0, [], Lc0, []),
+ Is2 = case D0 of
+ [] ->
+ Is1;
+ _ ->
+ D = gb_trees:from_orddict(orddict:from_list(D0)),
+ bsm_reroute(Is1, D, none, [])
+ end,
+ Is = beam_clean:bs_clean_saves(Is2),
+ {bsm_opt_2(Is, []),Lc}.
+
+bsm_scan([{label,L}=Lbl,{bs_restore2,_,Save}=R|Is], D0, Lc, Acc0) ->
+ D = [{{L,Save},Lc}|D0],
+ Acc = [{label,Lc},R,Lbl|Acc0],
+ bsm_scan(Is, D, Lc+1, Acc);
+bsm_scan([I|Is], D, Lc, Acc) ->
+ bsm_scan(Is, D, Lc, [I|Acc]);
+bsm_scan([], D, Lc, Acc) ->
+ {reverse(Acc),D,Lc}.
+
+bsm_reroute([{bs_save2,Reg,Save}=I|Is], D, _, Acc) ->
+ bsm_reroute(Is, D, {Reg,Save}, [I|Acc]);
+bsm_reroute([{bs_restore2,Reg,Save}=I|Is], D, _, Acc) ->
+ bsm_reroute(Is, D, {Reg,Save}, [I|Acc]);
+bsm_reroute([{label,_}=I|Is], D, S, Acc) ->
+ bsm_reroute(Is, D, S, [I|Acc]);
+bsm_reroute([{select_val,Reg,F0,{list,Lbls0}}|Is], D, {_,Save}=S, Acc0) ->
+ [F|Lbls] = bsm_subst_labels([F0|Lbls0], Save, D),
+ Acc = [{select_val,Reg,F,{list,Lbls}}|Acc0],
+ bsm_reroute(Is, D, S, Acc);
+bsm_reroute([{test,TestOp,F0,TestArgs}=I|Is], D, {_,Save}=S, Acc0) ->
+ F = bsm_subst_label(F0, Save, D),
+ Acc = [{test,TestOp,F,TestArgs}|Acc0],
+ case bsm_not_bs_test(I) of
+ true ->
+ %% The test instruction will not update the bit offset for the
+ %% binary being matched. Therefore the save position can be kept.
+ bsm_reroute(Is, D, S, Acc);
+ false ->
+ %% The test instruction might update the bit offset. Kill our
+ %% remembered Save position.
+ bsm_reroute(Is, D, none, Acc)
+ end;
+bsm_reroute([{test,TestOp,F0,Live,TestArgs,Dst}|Is], D, {_,Save}, Acc0) ->
+ F = bsm_subst_label(F0, Save, D),
+ Acc = [{test,TestOp,F,Live,TestArgs,Dst}|Acc0],
+ %% The test instruction will update the bit offset. Kill our
+ %% remembered Save position.
+ bsm_reroute(Is, D, none, Acc);
+bsm_reroute([{block,[{set,[],[],{alloc,_,_}}]}=Bl,
+ {bs_context_to_binary,_}=I|Is], D, S, Acc) ->
+ %% To help further bit syntax optimizations.
+ bsm_reroute([I,Bl|Is], D, S, Acc);
+bsm_reroute([I|Is], D, _, Acc) ->
+ bsm_reroute(Is, D, none, [I|Acc]);
+bsm_reroute([], _, _, Acc) -> reverse(Acc).
+
+bsm_opt_2([{test,bs_test_tail2,F,[Ctx,Bits]}|Is],
+ [{test,bs_skip_bits2,F,[Ctx,{integer,I},Unit,_Flags]}|Acc]) ->
+ bsm_opt_2(Is, [{test,bs_test_tail2,F,[Ctx,Bits+I*Unit]}|Acc]);
+bsm_opt_2([{test,bs_skip_bits2,F,[Ctx,{integer,I1},Unit1,_]}|Is],
+ [{test,bs_skip_bits2,F,[Ctx,{integer,I2},Unit2,Flags]}|Acc]) ->
+ bsm_opt_2(Is, [{test,bs_skip_bits2,F,
+ [Ctx,{integer,I1*Unit1+I2*Unit2},1,Flags]}|Acc]);
+bsm_opt_2([{test,bs_match_string,F,[Ctx,Bin1]},
+ {test,bs_match_string,F,[Ctx,Bin2]}|Is], Acc) ->
+ I = {test,bs_match_string,F,[Ctx,<<Bin1/bitstring,Bin2/bitstring>>]},
+ bsm_opt_2([I|Is], Acc);
+bsm_opt_2([I|Is], Acc) ->
+ bsm_opt_2(Is, [I|Acc]);
+bsm_opt_2([], Acc) -> reverse(Acc).
+
+%% bsm_not_bs_test({test,Name,_,Operands}) -> true|false.
+%% Test whether is the test is a "safe", i.e. does not move the
+%% bit offset for a binary.
+%%
+%% 'true' means that the test is safe, 'false' that we don't know or
+%% that the test moves the offset (e.g. bs_get_integer2).
+
+bsm_not_bs_test({test,bs_test_tail2,_,[_,_]}) -> true;
+bsm_not_bs_test(Test) -> beam_utils:is_pure_test(Test).
+
+bsm_subst_labels(Fs, Save, D) ->
+ bsm_subst_labels_1(Fs, Save, D, []).
+
+bsm_subst_labels_1([F|Fs], Save, D, Acc) ->
+ bsm_subst_labels_1(Fs, Save, D, [bsm_subst_label(F, Save, D)|Acc]);
+bsm_subst_labels_1([], _, _, Acc) ->
+ reverse(Acc).
+
+bsm_subst_label({f,Lbl0}=F, Save, D) ->
+ case gb_trees:lookup({Lbl0,Save}, D) of
+ {value,Lbl} -> {f,Lbl};
+ none -> F
+ end;
+bsm_subst_label(Other, _, _) -> Other.
diff --git a/lib/compiler/src/beam_bool.erl b/lib/compiler/src/beam_bool.erl
new file mode 100644
index 0000000000..d8c201a194
--- /dev/null
+++ b/lib/compiler/src/beam_bool.erl
@@ -0,0 +1,751 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2004-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+%%
+%% Purpose: Optimizes booleans in guards.
+
+-module(beam_bool).
+
+-export([module/2]).
+
+-import(lists, [reverse/1,reverse/2,foldl/3,mapfoldl/3,map/2]).
+
+-define(MAXREG, 1024).
+
+-record(st,
+ {next, %Next label number.
+ ll %Live regs at labels.
+ }).
+
+module({Mod,Exp,Attr,Fs0,Lc}, _Opts) ->
+ %%io:format("~p:\n", [Mod]),
+ {Fs,_} = mapfoldl(fun(Fn, Lbl) -> function(Fn, Lbl) end, 100000000, Fs0),
+ {ok,{Mod,Exp,Attr,Fs,Lc}}.
+
+function({function,Name,Arity,CLabel,Is0}, Lbl0) ->
+ try
+ {Is,#st{next=Lbl}} = bool_opt(Is0, Lbl0),
+ {{function,Name,Arity,CLabel,Is},Lbl}
+ catch
+ Class:Error ->
+ Stack = erlang:get_stacktrace(),
+ io:fwrite("Function: ~w/~w\n", [Name,Arity]),
+ erlang:raise(Class, Error, Stack)
+ end.
+
+%%
+%% Optimize boolean expressions that use guard bifs. Rewrite to
+%% use test instructions if possible.
+%%
+
+bool_opt(Asm, Lbl) ->
+ LiveInfo = beam_utils:index_labels(Asm),
+ bopt(Asm, [], #st{next=Lbl,ll=LiveInfo}).
+
+bopt([{block,Bl0}=Block|
+ [{jump,{f,Succ}},
+ {label,Fail},
+ {block,[{set,[Dst],[{atom,false}],move}]},
+ {label,Succ}|Is]=Is0], Acc0, St) ->
+ case split_block(Bl0, Dst, Fail, Acc0, true) of
+ failed ->
+ bopt(Is0, [Block|Acc0], St);
+ {Bl,PreBlock} ->
+ Acc1 = case PreBlock of
+ [] -> Acc0;
+ _ -> [{block,PreBlock}|Acc0]
+ end,
+ Acc = [{protected,[Dst],Bl,{Fail,Succ}}|Acc1],
+ bopt(Is, Acc, St)
+ end;
+bopt([{test,is_eq_exact,{f,Fail},[Reg,{atom,true}]}=I|Is], [{block,_}|_]=Acc0, St0) ->
+ case bopt_block(Reg, Fail, Is, Acc0, St0) of
+ failed -> bopt(Is, [I|Acc0], St0);
+ {Acc,St} -> bopt(Is, Acc, St)
+ end;
+bopt([I|Is], Acc, St) ->
+ bopt(Is, [I|Acc], St);
+bopt([], Acc, St) ->
+ {bopt_reverse(Acc, []),St}.
+
+bopt_reverse([{protected,[Dst],Block,{Fail,Succ}}|Is], Acc0) ->
+ Acc = [{block,Block},{jump,{f,Succ}},
+ {label,Fail},
+ {block,[{set,[Dst],[{atom,false}],move}]},
+ {label,Succ}|Acc0],
+ bopt_reverse(Is, Acc);
+bopt_reverse([I|Is], Acc) ->
+ bopt_reverse(Is, [I|Acc]);
+bopt_reverse([], Acc) -> Acc.
+
+%% bopt_block(Reg, Fail, OldIs, Accumulator, St) -> failed | {NewAcc,St}
+%% Attempt to optimized a block of guard BIFs followed by a test
+%% instruction.
+bopt_block(Reg, Fail, OldIs, [{block,Bl0}|Acc0], St0) ->
+ case split_block(Bl0, Reg, Fail, Acc0, false) of
+ failed ->
+ %% Reason for failure: The block either contained no
+ %% guard BIFs with the failure label Fail, or the final
+ %% instruction in the block did not assign the Reg register.
+
+ %%io:format("split ~p: ~P\n", [Reg,Bl0,20]),
+ failed;
+ {Bl1,BlPre} ->
+ %% The block has been splitted. Bl1 is a non-empty list
+ %% of guard BIF instructions having the failure label Fail.
+ %% BlPre is a (possibly empty list) of instructions preceeding
+ %% Bl1.
+ Acc1 = make_block(BlPre, Acc0),
+ {Bl,Acc} = extend_block(Bl1, Fail, Acc1),
+ try
+ {NewCode,St} = bopt_tree_cg(Bl, Fail, St0),
+ ensure_opt_safe(Bl, NewCode, OldIs, Fail, Acc, St),
+ {NewCode++Acc,St}
+ catch
+ %% Not possible to rewrite because a boolean value is
+ %% passed to another guard bif, e.g. 'abs(A > B)'
+ %% (in this case, obviously nonsense code). Rare in
+ %% practice.
+ throw:mixed ->
+ failed;
+
+ %% The 'xor' operator was used. We currently don't
+ %% find it worthwile to translate 'xor' operators
+ %% (the code would be clumsy).
+ throw:'xor' ->
+ failed;
+
+ %% The block does not contain a boolean expression,
+ %% but only a call to a guard BIF.
+ %% For instance: ... when element(1, T) ->
+ throw:not_boolean_expr ->
+ failed;
+
+ %% The block contains a 'move' instruction that could
+ %% not be handled.
+ throw:move ->
+ failed;
+
+ %% The optimization is not safe. (A register
+ %% used by the instructions following the
+ %% optimized code is either not assigned a
+ %% value at all or assigned a different value.)
+ throw:all_registers_not_killed ->
+ failed;
+ throw:registers_used ->
+ failed;
+
+ %% A protected block refered to the value
+ %% returned by another protected block,
+ %% probably because the Core Erlang code
+ %% used nested try/catches in the guard.
+ %% (v3_core never produces nested try/catches
+ %% in guards, so it must have been another
+ %% Core Erlang translator.)
+ throw:protected_violation ->
+ failed
+ end
+ end.
+
+%% ensure_opt_safe(OriginalCode, OptCode, FollowingCode, Fail,
+%% ReversedPreceedingCode, State) -> ok
+%% Comparing the original code to the optimized code, determine
+%% whether the optimized code is guaranteed to work in the same
+%% way as the original code.
+%%
+%% Throws an exception if the optmization is not safe.
+%%
+ensure_opt_safe(Bl, NewCode, OldIs, Fail, PreceedingCode, St) ->
+ %% Here are the conditions that must be true for the
+ %% optimization to be safe.
+ %%
+ %% 1. If a register is INITIALIZED by PreceedingCode,
+ %% then if that register assigned a value in the original
+ %% code, but not in the optimized code, it must be UNUSED or KILLED
+ %% in the code that follows.
+ %%
+ %% 2. If a register is not known to be INITIALIZED by PreccedingCode,
+ %% then if that register assigned a value in the original
+ %% code, but not in the optimized code, it must be KILLED
+ %% by the code that follows.
+ %%
+ %% 3. Any register that is assigned a value in the optimized
+ %% code must be UNUSED or KILLED in the following code.
+ %% (Possible future improvement: Registers that are known
+ %% to be assigned the SAME value in the original and optimized
+ %% code don't need to be unused in the following code.)
+
+ InitInPreceeding = initialized_regs(PreceedingCode),
+
+ PrevDst = dst_regs(Bl),
+ NewDst = dst_regs(NewCode),
+ NotSet = ordsets:subtract(PrevDst, NewDst),
+ MustBeKilled = ordsets:subtract(NotSet, InitInPreceeding),
+ MustBeUnused = ordsets:subtract(ordsets:union(NotSet, NewDst), MustBeKilled),
+
+ case all_killed(MustBeKilled, OldIs, Fail, St) of
+ false -> throw(all_registers_not_killed);
+ true -> ok
+ end,
+ case none_used(MustBeUnused, OldIs, Fail, St) of
+ false -> throw(registers_used);
+ true -> ok
+ end,
+ ok.
+
+update_fail_label([{set,_,_,move}=I|Is], Fail, Acc) ->
+ update_fail_label(Is, Fail, [I|Acc]);
+update_fail_label([{set,Ds,As,{bif,N,{f,_}}}|Is], Fail, Acc) ->
+ update_fail_label(Is, Fail, [{set,Ds,As,{bif,N,{f,Fail}}}|Acc]);
+update_fail_label([{set,Ds,As,{alloc,Regs,{gc_bif,N,{f,_}}}}|Is], Fail, Acc) ->
+ update_fail_label(Is, Fail,
+ [{set,Ds,As,{alloc,Regs,{gc_bif,N,{f,Fail}}}}|Acc]);
+update_fail_label([], _, Acc) -> reverse(Acc).
+
+make_block(Bl) ->
+ make_block(Bl, []).
+
+make_block([], Acc) -> Acc;
+make_block(Bl, Acc) -> [{block,Bl}|Acc].
+
+extend_block(BlAcc, Fail, [{protected,_,_,_}=Prot|OldAcc]) ->
+ extend_block([Prot|BlAcc], Fail, OldAcc);
+extend_block(BlAcc0, Fail, [{block,Is0}|OldAcc]) ->
+ case extend_block_1(reverse(Is0), Fail, BlAcc0) of
+ {BlAcc,[]} -> extend_block(BlAcc, Fail, OldAcc);
+ {BlAcc,Is} -> {BlAcc,[{block,Is}|OldAcc]}
+ end;
+extend_block(BlAcc, _, OldAcc) -> {BlAcc,OldAcc}.
+
+extend_block_1([{set,[_],_,{bif,_,{f,Fail}}}=I|Is], Fail, Acc) ->
+ extend_block_1(Is, Fail, [I|Acc]);
+extend_block_1([{set,[_],As,{bif,Bif,_}}=I|Is]=Is0, Fail, Acc) ->
+ case safe_bool_op(Bif, length(As)) of
+ false -> {Acc,reverse(Is0)};
+ true -> extend_block_1(Is, Fail, [I|Acc])
+ end;
+extend_block_1([_|_]=Is, _, Acc) -> {Acc,reverse(Is)};
+extend_block_1([], _, Acc) -> {Acc,[]}.
+
+%% split_block([Instruction], Destination, FailLabel, [PreInstruction],
+%% ProhibitFailLabelInPreBlock) -> failed | {Block,PreBlock}
+%% Split a sequence of instructions into two blocks - one containing
+%% all guard bif instructions and a pre-block all instructions before
+%% the guard BIFs.
+
+split_block(Is0, Dst, Fail, PreIs, ProhibitFailLabel) ->
+ case ProhibitFailLabel andalso beam_jump:is_label_used_in(Fail, PreIs) of
+ true ->
+ %% The failure label was used in one of the instructions (most
+ %% probably bit syntax construction) preceeding the block,
+ %% the caller might eliminate the label.
+ failed;
+ false ->
+ case reverse(Is0) of
+ [{set,[Dst],_,_}|_]=Is ->
+ split_block_1(Is, Fail, ProhibitFailLabel);
+ _ -> failed
+ end
+ end.
+
+split_block_1(Is, Fail, ProhibitFailLabel) ->
+ case split_block_2(Is, Fail, []) of
+ {[],_} -> failed;
+ {_,PreBlock}=Res ->
+ case ProhibitFailLabel andalso
+ split_block_label_used(PreBlock, Fail) of
+ true ->
+ %% The failure label was used in the pre-block;
+ %% not allowed, because the label may be removed.
+ failed;
+ false ->
+ Res
+ end
+ end.
+
+split_block_2([{set,_,_,move}=I|Is], Fail, Acc) ->
+ split_block_2(Is, Fail, [I|Acc]);
+split_block_2([{set,[_],_,{bif,_,{f,Fail}}}=I|Is], Fail, Acc) ->
+ split_block_2(Is, Fail, [I|Acc]);
+split_block_2([{set,[_],_,{alloc,_,{gc_bif,_,{f,Fail}}}}=I|Is], Fail, Acc) ->
+ split_block_2(Is, Fail, [I|Acc]);
+split_block_2(Is0, _, Acc) ->
+ Is = reverse(Is0),
+ {Acc,Is}.
+
+split_block_label_used([{set,[_],_,{bif,_,{f,Fail}}}|_], Fail) ->
+ true;
+split_block_label_used([{set,[_],_,{alloc,_,{gc_bif,_,{f,Fail}}}}|_], Fail) ->
+ true;
+split_block_label_used([_|Is], Fail) ->
+ split_block_label_used(Is, Fail);
+split_block_label_used([], _) -> false.
+
+dst_regs(Is) ->
+ dst_regs(Is, []).
+
+dst_regs([{block,Bl}|Is], Acc) ->
+ dst_regs(Bl, dst_regs(Is, Acc));
+dst_regs([{set,[D],_,{bif,_,{f,_}}}|Is], Acc) ->
+ dst_regs(Is, [D|Acc]);
+dst_regs([{set,[D],_,{alloc,_,{gc_bif,_,{f,_}}}}|Is], Acc) ->
+ dst_regs(Is, [D|Acc]);
+dst_regs([_|Is], Acc) ->
+ dst_regs(Is, Acc);
+dst_regs([], Acc) -> ordsets:from_list(Acc).
+
+all_killed([R|Rs], OldIs, Fail, St) ->
+ case is_killed(R, OldIs, Fail, St) of
+ false -> false;
+ true -> all_killed(Rs, OldIs, Fail, St)
+ end;
+all_killed([], _, _, _) -> true.
+
+none_used([R|Rs], OldIs, Fail, St) ->
+ case is_not_used(R, OldIs, Fail, St) of
+ false -> false;
+ true -> none_used(Rs, OldIs, Fail, St)
+ end;
+none_used([], _, _, _) -> true.
+
+bopt_tree_cg(Block0, Fail, St) ->
+ Free = free_variables(Block0),
+ Block = ssa_block(Block0),
+%% io:format("~p\n", [Block0]),
+%% io:format("~p\n", [Block]),
+%% io:format("~p\n", [gb_trees:to_list(Free)]),
+ case bopt_tree(Block, Free, []) of
+ {Pre0,[{_,Tree}]} ->
+ Pre1 = update_fail_label(Pre0, Fail, []),
+ Regs0 = init_regs(gb_trees:keys(Free)),
+%% io:format("~p\n", [dst_regs(Block0)]),
+%% io:format("~p\n", [Pre1]),
+%% io:format("~p\n", [Tree]),
+%% io:nl(),
+ {Pre,Regs} = rename_regs(Pre1, Regs0),
+%% io:format("~p\n", [Regs0]),
+%% io:format("~p\n", [Pre]),
+ bopt_cg(Tree, Fail, Regs, make_block(Pre), St);
+ _Res ->
+ throw(not_boolean_expr)
+ end.
+
+bopt_tree([{set,[Dst],As0,{bif,'not',_}}|Is], Forest0, Pre) ->
+ {[Arg],Forest1} = bopt_bool_args(As0, Forest0),
+ Forest = gb_trees:enter(Dst, {'not',Arg}, Forest1),
+ bopt_tree(Is, Forest, Pre);
+bopt_tree([{set,[Dst],As0,{bif,'and',_}}|Is], Forest0, Pre) ->
+ {As,Forest1} = bopt_bool_args(As0, Forest0),
+ Node = make_and_node(As),
+ Forest = gb_trees:enter(Dst, Node, Forest1),
+ bopt_tree(Is, Forest, Pre);
+bopt_tree([{set,[Dst],As0,{bif,'or',_}}|Is], Forest0, Pre) ->
+ {As,Forest1} = bopt_bool_args(As0, Forest0),
+ Node = make_or_node(As),
+ Forest = gb_trees:enter(Dst, Node, Forest1),
+ bopt_tree(Is, Forest, Pre);
+bopt_tree([{set,_,_,{bif,'xor',_}}|_], _, _) ->
+ throw('xor');
+bopt_tree([{protected,[Dst],Code,_}|Is], Forest0, Pre) ->
+ ProtForest0 = gb_trees:from_orddict([P || {_,any}=P <- gb_trees:to_list(Forest0)]),
+ {ProtPre,[{_,ProtTree}]} = bopt_tree(Code, ProtForest0, []),
+ Prot = {prot,ProtPre,ProtTree},
+ Forest = gb_trees:enter(Dst, Prot, Forest0),
+ bopt_tree(Is, Forest, Pre);
+bopt_tree([{set,[Dst],[Src],move}=Move|Is], Forest, Pre) ->
+ case {Src,Dst} of
+ {{tmp,_},_} -> throw(move);
+ {_,{tmp,_}} -> throw(move);
+ _ -> ok
+ end,
+ bopt_tree(Is, Forest, [Move|Pre]);
+bopt_tree([{set,[Dst],As,{bif,N,_}}=Bif|Is], Forest0, Pre) ->
+ Ar = length(As),
+ case safe_bool_op(N, Ar) of
+ false ->
+ bopt_good_args(As, Forest0),
+ Forest = gb_trees:enter(Dst, any, Forest0),
+ bopt_tree(Is, Forest, [Bif|Pre]);
+ true ->
+ bopt_good_args(As, Forest0),
+ Test = bif_to_test(Dst, N, As),
+ Forest = gb_trees:enter(Dst, Test, Forest0),
+ bopt_tree(Is, Forest, Pre)
+ end;
+bopt_tree([{set,[Dst],As,{alloc,_,{gc_bif,_,_}}}=Bif|Is], Forest0, Pre) ->
+ bopt_good_args(As, Forest0),
+ Forest = gb_trees:enter(Dst, any, Forest0),
+ bopt_tree(Is, Forest, [Bif|Pre]);
+bopt_tree([], Forest, Pre) ->
+ {reverse(Pre),[R || {_,V}=R <- gb_trees:to_list(Forest), V =/= any]}.
+
+safe_bool_op(N, Ar) ->
+ erl_internal:new_type_test(N, Ar) orelse erl_internal:comp_op(N, Ar).
+
+bopt_bool_args(As, Forest) ->
+ mapfoldl(fun bopt_bool_arg/2, Forest, As).
+
+bopt_bool_arg({T,_}=R, Forest) when T =:= x; T =:= y; T =:= tmp ->
+ Val = case gb_trees:get(R, Forest) of
+ any -> {test,is_eq_exact,fail,[R,{atom,true}]};
+ Val0 -> Val0
+ end,
+ {Val,gb_trees:delete(R, Forest)};
+bopt_bool_arg(Term, Forest) ->
+ {Term,Forest}.
+
+bopt_good_args([A|As], Regs) ->
+ bopt_good_arg(A, Regs),
+ bopt_good_args(As, Regs);
+bopt_good_args([], _) -> ok.
+
+bopt_good_arg({Tag,_}=X, Regs) when Tag =:= x; Tag =:= tmp ->
+ case gb_trees:get(X, Regs) of
+ any -> ok;
+ _Other ->
+ %%io:format("not any: ~p: ~p\n", [X,_Other]),
+ throw(mixed)
+ end;
+bopt_good_arg(_, _) -> ok.
+
+bif_to_test(_, N, As) ->
+ beam_utils:bif_to_test(N, As, fail).
+
+make_and_node(Is) ->
+ AndList0 = make_and_list(Is),
+ case simplify_and_list(AndList0) of
+ [] -> {atom,true};
+ [Op] -> Op;
+ AndList -> {'and',AndList}
+ end.
+
+make_and_list([{'and',As}|Is]) ->
+ make_and_list(As++Is);
+make_and_list([I|Is]) ->
+ [I|make_and_list(Is)];
+make_and_list([]) -> [].
+
+simplify_and_list([{atom,true}|T]) ->
+ simplify_and_list(T);
+simplify_and_list([{atom,false}=False|_]) ->
+ [False];
+simplify_and_list([H|T]) ->
+ [H|simplify_and_list(T)];
+simplify_and_list([]) -> [].
+
+make_or_node(Is) ->
+ OrList0 = make_or_list(Is),
+ case simplify_or_list(OrList0) of
+ [] -> {atom,false};
+ [Op] -> Op;
+ OrList -> {'or',OrList}
+ end.
+
+make_or_list([{'or',As}|Is]) ->
+ make_or_list(As++Is);
+make_or_list([I|Is]) ->
+ [I|make_or_list(Is)];
+make_or_list([]) -> [].
+
+simplify_or_list([{atom,false}|T]) ->
+ simplify_or_list(T);
+simplify_or_list([{atom,true}=True|_]) ->
+ [True];
+simplify_or_list([H|T]) ->
+ [H|simplify_or_list(T)];
+simplify_or_list([]) -> [].
+
+%% Code generation for a boolean tree.
+
+bopt_cg({'not',Arg}, Fail, Rs, Acc, St) ->
+ I = bopt_cg_not(Arg),
+ bopt_cg(I, Fail, Rs, Acc, St);
+bopt_cg({'and',As}, Fail, Rs, Acc, St) ->
+ bopt_cg_and(As, Fail, Rs, Acc, St);
+bopt_cg({'or',As}, Fail, Rs, Acc, St0) ->
+ {Succ,St} = new_label(St0),
+ bopt_cg_or(As, Succ, Fail, Rs, Acc, St);
+bopt_cg({test,N,fail,As0}, Fail, Rs, Acc, St) ->
+ As = rename_sources(As0, Rs),
+ Test = {test,N,{f,Fail},As},
+ {[Test|Acc],St};
+bopt_cg({inverted_test,N,fail,As0}, Fail, Rs, Acc, St0) ->
+ As = rename_sources(As0, Rs),
+ {Lbl,St} = new_label(St0),
+ {[{label,Lbl},{jump,{f,Fail}},{test,N,{f,Lbl},As}|Acc],St};
+bopt_cg({prot,Pre0,Tree}, Fail, Rs0, Acc, St0) ->
+ Pre1 = update_fail_label(Pre0, Fail, []),
+ {Pre,Rs} = rename_regs(Pre1, Rs0),
+ bopt_cg(Tree, Fail, Rs, make_block(Pre, Acc), St0);
+bopt_cg({atom,true}, _Fail, _Rs, Acc, St) ->
+ {Acc,St};
+bopt_cg({atom,false}, Fail, _Rs, Acc, St) ->
+ {[{jump,{f,Fail}}|Acc],St}.
+
+bopt_cg_not({'and',As0}) ->
+ As = [bopt_cg_not(A) || A <- As0],
+ {'or',As};
+bopt_cg_not({'or',As0}) ->
+ As = [bopt_cg_not(A) || A <- As0],
+ {'and',As};
+bopt_cg_not({'not',Arg}) ->
+ bopt_cg_not_not(Arg);
+bopt_cg_not({test,Test,Fail,As}) ->
+ {inverted_test,Test,Fail,As};
+bopt_cg_not({atom,Bool}) when is_boolean(Bool) ->
+ {atom,not Bool}.
+
+bopt_cg_not_not({'and',As}) ->
+ {'and',[bopt_cg_not_not(A) || A <- As]};
+bopt_cg_not_not({'or',As}) ->
+ {'or',[bopt_cg_not_not(A) || A <- As]};
+bopt_cg_not_not({'not',Arg}) ->
+ bopt_cg_not(Arg);
+bopt_cg_not_not(Leaf) -> Leaf.
+
+bopt_cg_and([I|Is], Fail, Rs, Acc0, St0) ->
+ {Acc,St} = bopt_cg(I, Fail, Rs, Acc0, St0),
+ bopt_cg_and(Is, Fail, Rs, Acc, St);
+bopt_cg_and([], _, _, Acc, St) -> {Acc,St}.
+
+bopt_cg_or([I], Succ, Fail, Rs, Acc0, St0) ->
+ {Acc,St} = bopt_cg(I, Fail, Rs, Acc0, St0),
+ {[{label,Succ}|Acc],St};
+bopt_cg_or([I|Is], Succ, Fail, Rs, Acc0, St0) ->
+ {Lbl,St1} = new_label(St0),
+ {Acc,St} = bopt_cg(I, Lbl, Rs, Acc0, St1),
+ bopt_cg_or(Is, Succ, Fail, Rs, [{label,Lbl},{jump,{f,Succ}}|Acc], St).
+
+new_label(#st{next=LabelNum}=St) when is_integer(LabelNum) ->
+ {LabelNum,St#st{next=LabelNum+1}}.
+
+free_variables(Is) ->
+ E = gb_sets:empty(),
+ free_vars_1(Is, E, E, E).
+
+free_vars_1([{set,Ds,As,move}|Is], F0, N0, A) ->
+ F = gb_sets:union(F0, gb_sets:difference(var_list(As), N0)),
+ N = gb_sets:union(N0, var_list(Ds)),
+ free_vars_1(Is, F, N, A);
+free_vars_1([{set,Ds,As,{bif,_,_}}|Is], F0, N0, A) ->
+ F = gb_sets:union(F0, gb_sets:difference(var_list(As), N0)),
+ N = gb_sets:union(N0, var_list(Ds)),
+ free_vars_1(Is, F, N, A);
+free_vars_1([{set,Ds,As,{alloc,Regs,{gc_bif,_,_}}}|Is], F0, N0, A0) ->
+ A = gb_sets:union(A0, gb_sets:from_list(free_vars_regs(Regs))),
+ F = gb_sets:union(F0, gb_sets:difference(var_list(As), N0)),
+ N = gb_sets:union(N0, var_list(Ds)),
+ free_vars_1(Is, F, N, A);
+free_vars_1([{protected,_,Pa,_}|Is], F, N, A) ->
+ free_vars_1(Pa++Is, F, N, A);
+free_vars_1([], F0, N, A) ->
+ F = case gb_sets:is_empty(A) of
+ true ->
+ %% No GC BIFs.
+ {x,X} = gb_sets:smallest(N),
+ P = ordsets:from_list(free_vars_regs(X)),
+ ordsets:union(gb_sets:to_list(F0), P);
+ false ->
+ %% At least one GC BIF.
+ gb_sets:to_list(gb_sets:union(F0, gb_sets:difference(A, N)))
+ end,
+ gb_trees:from_orddict([{K,any} || K <- F]).
+
+var_list(Is) ->
+ var_list_1(Is, gb_sets:empty()).
+
+var_list_1([{Tag,_}=X|Is], D) when Tag =:= x; Tag =:= y ->
+ var_list_1(Is, gb_sets:add(X, D));
+var_list_1([_|Is], D) ->
+ var_list_1(Is, D);
+var_list_1([], D) -> D.
+
+free_vars_regs(0) -> [];
+free_vars_regs(X) -> [{x,X-1}|free_vars_regs(X-1)].
+
+rename_regs(Is, Regs) ->
+ rename_regs(Is, Regs, []).
+
+rename_regs([{set,_,_,move}=I|Is], Regs, Acc) ->
+ rename_regs(Is, Regs, [I|Acc]);
+rename_regs([{set,[Dst0],Ss0,{alloc,_,Info}}|Is], Regs0, Acc) ->
+ Live = live_regs(Regs0),
+ Ss = rename_sources(Ss0, Regs0),
+ Regs = put_reg(Dst0, Regs0),
+ Dst = fetch_reg(Dst0, Regs),
+ rename_regs(Is, Regs, [{set,[Dst],Ss,{alloc,Live,Info}}|Acc]);
+rename_regs([{set,[Dst0],Ss0,Info}|Is], Regs0, Acc) ->
+ Ss = rename_sources(Ss0, Regs0),
+ Regs = put_reg(Dst0, Regs0),
+ Dst = fetch_reg(Dst0, Regs),
+ rename_regs(Is, Regs, [{set,[Dst],Ss,Info}|Acc]);
+rename_regs([], Regs, Acc) -> {reverse(Acc),Regs}.
+
+rename_sources(Ss, Regs) ->
+ map(fun({x,_}=R) -> fetch_reg(R, Regs);
+ ({tmp,_}=R) -> fetch_reg(R, Regs);
+ (E) -> E
+ end, Ss).
+
+%%%
+%%% Keeping track of register assignments.
+%%%
+
+init_regs(Free) ->
+ init_regs_1(Free, 0).
+
+init_regs_1([{x,I}=V|T], I) ->
+ [{I,V}|init_regs_1(T, I+1)];
+init_regs_1([{x,X}|_]=T, I) when I < X ->
+ [{I,reserved}|init_regs_1(T, I+1)];
+init_regs_1([{y,_}|_], _) -> [];
+init_regs_1([], _) -> [].
+
+put_reg(V, Rs) -> put_reg_1(V, Rs, 0).
+
+put_reg_1(V, [R|Rs], I) -> [R|put_reg_1(V, Rs, I+1)];
+put_reg_1(V, [], I) -> [{I,V}].
+
+fetch_reg(V, [{I,V}|_]) -> {x,I};
+fetch_reg(V, [_|SRs]) -> fetch_reg(V, SRs).
+
+live_regs(Regs) ->
+ foldl(fun ({I,_}, _) -> I;
+ ([], Max) -> Max end,
+ -1, Regs)+1.
+
+
+%%%
+%%% Convert a block to Static Single Assignment (SSA) form.
+%%%
+
+-record(ssa,
+ {live=0, %Variable counter.
+ sub=gb_trees:empty(), %Substitution table.
+ prot=gb_sets:empty(), %Targets assigned by protecteds.
+ in_prot=false %Inside a protected.
+ }).
+
+ssa_block(Is0) ->
+ {Is,_} = ssa_block_1(Is0, #ssa{}, []),
+ Is.
+
+ssa_block_1([{protected,[_],Pa0,Pb}|Is], Sub0, Acc) ->
+ {Pa,Sub1} = ssa_block_1(Pa0, Sub0#ssa{in_prot=true}, []),
+ Dst = ssa_last_target(Pa),
+ Sub = Sub1#ssa{prot=gb_sets:insert(Dst, Sub1#ssa.prot),
+ in_prot=Sub0#ssa.in_prot},
+ ssa_block_1(Is, Sub, [{protected,[Dst],Pa,Pb}|Acc]);
+ssa_block_1([{set,[Dst],As,Bif}|Is], Sub0, Acc0) ->
+ Sub1 = ssa_in_use_list(As, Sub0),
+ Sub = ssa_assign(Dst, Sub1),
+ Acc = [{set,[ssa_sub(Dst, Sub)],ssa_sub_list(As, Sub0),Bif}|Acc0],
+ ssa_block_1(Is, Sub, Acc);
+ssa_block_1([], Sub, Acc) -> {reverse(Acc),Sub}.
+
+ssa_in_use_list(As, Sub) ->
+ foldl(fun ssa_in_use/2, Sub, As).
+
+ssa_in_use({x,_}=R, #ssa{sub=Sub0}=Ssa) ->
+ case gb_trees:is_defined(R, Sub0) of
+ true -> Ssa;
+ false ->
+ Sub = gb_trees:insert(R, R, Sub0),
+ Ssa#ssa{sub=Sub}
+ end;
+ssa_in_use(_, Ssa) -> Ssa.
+
+ssa_assign({x,_}=R, #ssa{sub=Sub0}=Ssa0) ->
+ {NewReg,Ssa} = ssa_new_reg(Ssa0),
+ case gb_trees:is_defined(R, Sub0) of
+ false ->
+ Sub = gb_trees:insert(R, NewReg, Sub0),
+ Ssa#ssa{sub=Sub};
+ true ->
+ Sub1 = gb_trees:update(R, NewReg, Sub0),
+ Sub = gb_trees:insert(NewReg, NewReg, Sub1),
+ Ssa#ssa{sub=Sub}
+ end;
+ssa_assign(_, Ssa) -> Ssa.
+
+ssa_sub_list(List, Sub) ->
+ [ssa_sub(E, Sub) || E <- List].
+
+ssa_sub(R0, #ssa{sub=Sub,prot=Prot,in_prot=InProt}) ->
+ case gb_trees:lookup(R0, Sub) of
+ none -> R0;
+ {value,R} ->
+ case InProt andalso gb_sets:is_element(R, Prot) of
+ true ->
+ throw(protected_violation);
+ false ->
+ R
+ end
+ end.
+
+ssa_new_reg(#ssa{live=Reg}=Ssa) ->
+ {{tmp,Reg},Ssa#ssa{live=Reg+1}}.
+
+ssa_last_target([{set,[Dst],_,_}]) -> Dst;
+ssa_last_target([_|Is]) -> ssa_last_target(Is).
+
+%% is_killed(Register, [Instruction], FailLabel, State) -> true|false
+%% Determine whether a register is killed in the instruction sequence.
+%% The state is used to allow us to determine the kill state
+%% across branches.
+
+is_killed(R, Is, Label, #st{ll=Ll}) ->
+ beam_utils:is_killed(R, Is, Ll) andalso
+ beam_utils:is_killed_at(R, Label, Ll).
+
+%% is_not_used(Register, [Instruction], FailLabel, State) -> true|false
+%% Determine whether a register is never used in the instruction sequence
+%% (it could still referenced by an allocate instruction, meaning that
+%% it MUST be initialized).
+%% The state is used to allow us to determine the usage state
+%% across branches.
+
+is_not_used(R, Is, Label, #st{ll=Ll}) ->
+ beam_utils:is_not_used(R, Is, Ll) andalso
+ beam_utils:is_not_used_at(R, Label, Ll).
+
+%% initialized_regs([Instruction]) -> [Register])
+%% Given a REVERSED instruction sequence, return a list of the registers
+%% that are guaranteed to be initialized (not contain garbage).
+
+initialized_regs(Is) ->
+ initialized_regs(Is, ordsets:new()).
+
+initialized_regs([{set,Dst,Src,_}|Is], Regs) ->
+ initialized_regs(Is, add_init_regs(Dst, add_init_regs(Src, Regs)));
+initialized_regs([{test,_,_,Src}|Is], Regs) ->
+ initialized_regs(Is, add_init_regs(Src, Regs));
+initialized_regs([{block,Bl}|Is], Regs) ->
+ initialized_regs(reverse(Bl, Is), Regs);
+initialized_regs([{bs_context_to_binary,Src}|Is], Regs) ->
+ initialized_regs(Is, add_init_regs([Src], Regs));
+initialized_regs([{label,_},{func_info,_,_,Arity}|_], Regs) ->
+ InitRegs = free_vars_regs(Arity),
+ add_init_regs(InitRegs, Regs);
+initialized_regs([_|_], Regs) -> Regs;
+initialized_regs([], Regs) -> Regs.
+
+add_init_regs([{x,_}=X|T], Regs) ->
+ add_init_regs(T, ordsets:add_element(X, Regs));
+add_init_regs([_|T], Regs) ->
+ add_init_regs(T, Regs);
+add_init_regs([], Regs) -> Regs.
diff --git a/lib/compiler/src/beam_bsm.erl b/lib/compiler/src/beam_bsm.erl
new file mode 100644
index 0000000000..2a36fda1ea
--- /dev/null
+++ b/lib/compiler/src/beam_bsm.erl
@@ -0,0 +1,708 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2007-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+%%
+
+-module(beam_bsm).
+-export([module/2,format_error/1]).
+
+-import(lists, [member/2,foldl/3,reverse/1,sort/1,all/2]).
+
+%%%
+%%% We optimize bit syntax matching where the tail end of a binary is
+%%% matched out and immediately passed on to a bs_start_match2 instruction,
+%%% such as in this code sequence:
+%%%
+%%% func_info ...
+%%% L1 test bs_start_match2 {f,...} {x,0} Live SavePositions {x,0}
+%%% . . .
+%%% test bs_get_binary2 {f,...} {x,0} all 1 Flags {x,0}
+%%% . . .
+%%% call_only 2 L1
+%%%
+%%% The sequence can be optimized simply by removing the bs_get_binary2
+%%% instruction. Another example:
+%%%
+%%% func_info ...
+%%% L1 test bs_start_match2 {f,...} {x,0} Live SavePositions {x,0}
+%%% . . .
+%%% test bs_get_binary2 {f,...} {x,0} all 8 Flags {x,1}
+%%% . . .
+%%% move {x,1} {x,0}
+%%% call_only 2 L1
+%%%
+%%% In this case, the bs_get_binary2 instruction must be replaced by
+%%%
+%%% test bs_unit {x,1} 8
+%%%
+%%% to ensure that the match fail if the length of the binary in bits
+%%% is not evenly divisible by 8.
+%%%
+%%% Note that the bs_start_match2 instruction doesn't need to be in the same
+%%% function as the caller. It can be in the beginning of any function, or
+%%% follow the bs_get_binary2 instruction in the same function. The important
+%%% thing is that the match context register is not copied or built into
+%%% data structures or passed to BIFs.
+%%%
+
+-record(btb,
+ {f, %Gbtrees for all functions.
+ index, %{Label,Code} index (for liveness).
+ ok_br, %Labels that are OK.
+ must_not_save, %Must not save position when
+ % optimizing (reaches
+ % bs_context_to_binary).
+ must_save %Must save position when optimizing.
+ }).
+
+module({Mod,Exp,Attr,Fs0,Lc}, Opts) ->
+ D = #btb{f=btb_index(Fs0)},
+ Fs = [function(F, D) || F <- Fs0],
+ Code = {Mod,Exp,Attr,Fs,Lc},
+ case proplists:get_bool(bin_opt_info, Opts) of
+ true ->
+ {ok,Code,collect_warnings(Fs)};
+ false ->
+ {ok,Code}
+ end.
+
+-spec format_error('bin_opt' | {'no_bin_opt', term()}) -> nonempty_string().
+
+format_error(bin_opt) ->
+ "OPTIMIZED: creation of sub binary delayed";
+format_error({no_bin_opt,Reason}) ->
+ lists:flatten(["NOT OPTIMIZED: "|format_error_1(Reason)]).
+
+%%%
+%%% Local functions.
+%%%
+
+function({function,Name,Arity,Entry,Is}, D0) ->
+ try
+ Index = beam_utils:index_labels(Is),
+ D = D0#btb{index=Index},
+ {function,Name,Arity,Entry,btb_opt_1(Is, D, [])}
+ catch
+ Class:Error ->
+ Stack = erlang:get_stacktrace(),
+ io:fwrite("Function: ~w/~w\n", [Name,Arity]),
+ erlang:raise(Class, Error, Stack)
+ end.
+
+btb_opt_1([{test,bs_get_binary2,F,_,[Reg,{atom,all},U,Fs],Reg}=I0|Is], D, Acc0) ->
+ case btb_reaches_match(Is, [Reg], D) of
+ {error,Reason} ->
+ Comment = btb_comment_no_opt(Reason, Fs),
+ btb_opt_1(Is, D, [Comment,I0|Acc0]);
+ {ok,MustSave} ->
+ Comment = btb_comment_opt(Fs),
+ Acc1 = btb_gen_save(MustSave, Reg, [Comment|Acc0]),
+ Acc = case U of
+ 1 -> Acc1;
+ _ -> [{test,bs_test_unit,F,[Reg,U]}|Acc1]
+ end,
+ btb_opt_1(Is, D, Acc)
+ end;
+btb_opt_1([{test,bs_get_binary2,F,_,[Ctx,{atom,all},U,Fs],Dst}=I0|Is], D, Acc0) ->
+ case btb_reaches_match(Is, [Ctx,Dst], D) of
+ {error,Reason} ->
+ Comment = btb_comment_no_opt(Reason, Fs),
+ btb_opt_1(Is, D, [Comment,I0|Acc0]);
+ {ok,MustSave} when U =:= 1 ->
+ Comment = btb_comment_opt(Fs),
+ Acc1 = btb_gen_save(MustSave, Ctx, [Comment|Acc0]),
+ Acc = [{move,Ctx,Dst}|Acc1],
+ btb_opt_1(Is, D, Acc);
+ {ok,MustSave} ->
+ Comment = btb_comment_opt(Fs),
+ Acc1 = btb_gen_save(MustSave, Ctx, [Comment|Acc0]),
+ Acc = [{move,Ctx,Dst},{test,bs_test_unit,F,[Ctx,U]}|Acc1],
+ btb_opt_1(Is, D, Acc)
+ end;
+btb_opt_1([I|Is], D, Acc) ->
+ %%io:format("~p\n", [I]),
+ btb_opt_1(Is, D, [I|Acc]);
+btb_opt_1([], _, Acc) ->
+ reverse(Acc).
+
+btb_gen_save(true, Reg, Acc) ->
+ [{bs_save2,Reg,{atom,start}}|Acc];
+btb_gen_save(false, _, Acc) -> Acc.
+
+%% btb_reaches_match([Instruction], [Register], D) ->
+%% {ok,MustSave}|{error,Reason}
+%%
+%% The list of Registers should be a list of registers referencing a
+%% match context. The Register may contain one element if the
+%% bs_get_binary2 instruction looks like
+%%
+%% test bs_get_binary2 {f,...} Ctx all _ _ Ctx
+%%
+%% or two elements if the instruction looks like
+%%
+%% test bs_get_binary2 {f,...} Ctx all _ _ Dst
+%%
+%% This function determines whether the bs_get_binary2 instruction
+%% can be omitted (retaining the match context instead of creating
+%% a sub binary).
+%%
+%% The rule is that the match context ultimately must end up at a
+%% bs_start_match2 instruction and nowhere else. That it, it must not
+%% be passed to BIFs, or copied or put into data structures. There
+%% must only be one copy alive when the match context reaches the
+%% bs_start_match2 instruction.
+%%
+%% At a branch, we must follow all branches and make sure that the above
+%% rule is followed (or that the branch kills the match context).
+%%
+%% The MustSave return value will be true if control may end up at
+%% bs_context_to_binary instruction. Since that instruction uses the
+%% saved start position, we must use "bs_save2 Ctx start" to
+%% update the saved start position. An additional complication is that
+%% "bs_save2 Ctx start" must not be used if Dst and Ctx are
+%% different registers and both registers may be passed to
+%% a bs_context_to_binary instruction.
+%%
+
+btb_reaches_match(Is, RegList, D0) ->
+ try
+ Regs = btb_regs_from_list(RegList),
+ D = D0#btb{ok_br=gb_sets:empty(),must_not_save=false,must_save=false},
+ #btb{must_not_save=MustNotSave,must_save=MustSave} =
+ btb_reaches_match_1(Is, Regs, D),
+ case MustNotSave and MustSave of
+ true -> btb_error(must_and_must_not_save);
+ _ -> {ok,MustSave}
+ end
+ catch
+ throw:{error,_}=Error -> Error
+ end.
+
+btb_reaches_match_1(Is, Regs, D) ->
+ case btb_are_registers_empty(Regs) of
+ false ->
+ btb_reaches_match_2(Is, Regs, D);
+ true ->
+ %% The context was killed, which is OK.
+ D
+ end.
+
+btb_reaches_match_2([{block,Bl}|Is], Regs0, D) ->
+ Regs = btb_reaches_match_block(Bl, Regs0),
+ btb_reaches_match_1(Is, Regs, D);
+btb_reaches_match_2([{call_only,Arity,{f,Lbl}}|_], Regs0, D) ->
+ Regs = btb_kill_not_live(Arity, Regs0),
+ btb_tail_call(Lbl, Regs, D);
+btb_reaches_match_2([{call_ext_only,Arity,Func}|_], Regs0, D) ->
+ Regs = btb_kill_not_live(Arity, Regs0),
+ btb_tail_call(Func, Regs, D);
+btb_reaches_match_2([{call_last,Arity,{f,Lbl},_}|_], Regs0, D) ->
+ Regs1 = btb_kill_not_live(Arity, Regs0),
+ Regs = btb_kill_yregs(Regs1),
+ btb_tail_call(Lbl, Regs, D);
+btb_reaches_match_2([{call,Arity,{f,Lbl}}|Is], Regs, D) ->
+ btb_call(Arity, Lbl, Regs, Is, D);
+btb_reaches_match_2([{apply,Arity}|Is], Regs, D) ->
+ btb_call(Arity+2, apply, Regs, Is, D);
+btb_reaches_match_2([{call_fun,Live}=I|Is], Regs, D) ->
+ btb_call(Live, I, Regs, Is, D);
+btb_reaches_match_2([{make_fun2,_,_,_,Live}|Is], Regs, D) ->
+ btb_call(Live, make_fun2, Regs, Is, D);
+btb_reaches_match_2([{call_ext,Arity,{extfunc,Mod,Name,Arity}=Func}|Is], Regs0, D) ->
+ %% Allow us scanning beyond the call in case the match
+ %% context is saved on the stack.
+ case erl_bifs:is_exit_bif(Mod, Name, Arity) of
+ false ->
+ btb_call(Arity, Func, Regs0, Is, D);
+ true ->
+ Regs = btb_kill_not_live(Arity, Regs0),
+ btb_tail_call(Func, Regs, D)
+ end;
+btb_reaches_match_2([{call_ext_last,Arity,_,_}=I|_], Regs, D) ->
+ btb_ensure_not_used(btb_regs_from_arity(Arity), I, Regs),
+ D;
+btb_reaches_match_2([{kill,Y}|Is], Regs, D) ->
+ btb_reaches_match_1(Is, btb_kill([Y], Regs), D);
+btb_reaches_match_2([{deallocate,_}|Is], Regs0, D) ->
+ Regs = btb_kill_yregs(Regs0),
+ btb_reaches_match_1(Is, Regs, D);
+btb_reaches_match_2([return=I|_], Regs0, D) ->
+ btb_ensure_not_used([{x,0}], I, Regs0),
+ D;
+btb_reaches_match_2([{gc_bif,_,{f,F},Live,Ss,Dst}=I|Is], Regs0, D0) ->
+ btb_ensure_not_used(Ss, I, Regs0),
+ Regs1 = btb_kill_not_live(Live, Regs0),
+ Regs = btb_kill([Dst], Regs1),
+ D = btb_follow_branch(F, Regs, D0),
+ btb_reaches_match_1(Is, Regs, D);
+btb_reaches_match_2([{bif,_,{f,F},Ss,Dst}=I|Is], Regs0, D0) ->
+ btb_ensure_not_used(Ss, I, Regs0),
+ Regs = btb_kill([Dst], Regs0),
+ D = btb_follow_branch(F, Regs, D0),
+ btb_reaches_match_1(Is, Regs, D);
+btb_reaches_match_2([{test,bs_start_match2,_,_,[Ctx,_],Ctx}|Is], Regs, D) ->
+ case btb_context_regs(Regs) of
+ [Ctx] ->
+ D;
+ CtxRegs ->
+ case member(Ctx, CtxRegs) of
+ false -> btb_reaches_match_2(Is, Regs, D);
+ true -> btb_error(unsuitable_bs_start_match)
+ end
+ end;
+btb_reaches_match_2([{test,bs_start_match2,_,_,[Bin,_],Ctx}|Is], Regs, D) ->
+ CtxRegs = btb_context_regs(Regs),
+ case member(Bin, CtxRegs) orelse member(Ctx, CtxRegs) of
+ false -> btb_reaches_match_2(Is, Regs, D);
+ true -> btb_error(unsuitable_bs_start_match)
+ end;
+btb_reaches_match_2([{test,_,{f,F},Ss}=I|Is], Regs, D0) ->
+ btb_ensure_not_used(Ss, I, Regs),
+ D = btb_follow_branch(F, Regs, D0),
+ btb_reaches_match_1(Is, Regs, D);
+btb_reaches_match_2([{test,_,{f,F},_,Ss,_}=I|Is], Regs, D0) ->
+ btb_ensure_not_used(Ss, I, Regs),
+ D = btb_follow_branch(F, Regs, D0),
+ btb_reaches_match_1(Is, Regs, D);
+btb_reaches_match_2([{select_val,Src,{f,F},{list,Conds}}=I|Is], Regs, D0) ->
+ btb_ensure_not_used([Src], I, Regs),
+ D1 = btb_follow_branch(F, Regs, D0),
+ D = btb_follow_branches(Conds, Regs, D1),
+ btb_reaches_match_1(Is, Regs, D);
+btb_reaches_match_2([{select_tuple_arity,Src,{f,F},{list,Conds}}=I|Is], Regs, D0) ->
+ btb_ensure_not_used([Src], I, Regs),
+ D1 = btb_follow_branch(F, Regs, D0),
+ D = btb_follow_branches(Conds, Regs, D1),
+ btb_reaches_match_1(Is, Regs, D);
+btb_reaches_match_2([{jump,{f,Lbl}}|_], Regs, #btb{index=Li}=D) ->
+ Is = fetch_code_at(Lbl, Li),
+ btb_reaches_match_2(Is, Regs, D);
+btb_reaches_match_2([{label,_}|Is], Regs, D) ->
+ btb_reaches_match_2(Is, Regs, D);
+btb_reaches_match_2([{bs_add,{f,0},_,Dst}|Is], Regs, D) ->
+ btb_reaches_match_1(Is, btb_kill([Dst], Regs), D);
+btb_reaches_match_2([bs_init_writable|Is], Regs0, D) ->
+ Regs = btb_kill_not_live(0, Regs0),
+ btb_reaches_match_1(Is, Regs, D);
+btb_reaches_match_2([{bs_init2,{f,0},_,_,_,_,Dst}|Is], Regs, D) ->
+ btb_reaches_match_1(Is, btb_kill([Dst], Regs), D);
+btb_reaches_match_2([{bs_init_bits,{f,0},_,_,_,_,Dst}|Is], Regs, D) ->
+ btb_reaches_match_1(Is, btb_kill([Dst], Regs), D);
+btb_reaches_match_2([{bs_append,{f,0},_,_,_,_,Src,_,Dst}=I|Is], Regs, D) ->
+ btb_ensure_not_used([Src], I, Regs),
+ btb_reaches_match_1(Is, btb_kill([Dst], Regs), D);
+btb_reaches_match_2([{bs_private_append,{f,0},_,_,Src,_,Dst}=I|Is], Regs, D) ->
+ btb_ensure_not_used([Src], I, Regs),
+ btb_reaches_match_1(Is, btb_kill([Dst], Regs), D);
+btb_reaches_match_2([{bs_put_integer,{f,0},_,_,_,Src}=I|Is], Regs, D) ->
+ btb_ensure_not_used([Src], I, Regs),
+ btb_reaches_match_1(Is, Regs, D);
+btb_reaches_match_2([{bs_put_float,{f,0},_,_,_,Src}=I|Is], Regs, D) ->
+ btb_ensure_not_used([Src], I, Regs),
+ btb_reaches_match_1(Is, Regs, D);
+btb_reaches_match_2([{bs_put_binary,{f,0},_,_,_,Src}=I|Is], Regs, D) ->
+ btb_ensure_not_used([Src], I, Regs),
+ btb_reaches_match_1(Is, Regs, D);
+btb_reaches_match_2([{bs_put_string,_,_}|Is], Regs, D) ->
+ btb_reaches_match_1(Is, Regs, D);
+btb_reaches_match_2([{bs_utf8_size,_,Src,Dst}=I|Is], Regs, D) ->
+ btb_ensure_not_used([Src], I, Regs),
+ btb_reaches_match_1(Is, btb_kill([Dst], Regs), D);
+btb_reaches_match_2([{bs_utf16_size,_,Src,Dst}=I|Is], Regs, D) ->
+ btb_ensure_not_used([Src], I, Regs),
+ btb_reaches_match_1(Is, btb_kill([Dst], Regs), D);
+btb_reaches_match_2([{bs_put_utf8,_,_,Src}=I|Is], Regs, D) ->
+ btb_ensure_not_used([Src], I, Regs),
+ btb_reaches_match_1(Is, Regs, D);
+btb_reaches_match_2([{bs_put_utf16,_,_,Src}=I|Is], Regs, D) ->
+ btb_ensure_not_used([Src], I, Regs),
+ btb_reaches_match_1(Is, Regs, D);
+btb_reaches_match_2([{bs_put_utf32,_,_,Src}=I|Is], Regs, D) ->
+ btb_ensure_not_used([Src], I, Regs),
+ btb_reaches_match_1(Is, Regs, D);
+btb_reaches_match_2([{bs_restore2,Src,_}=I|Is], Regs0, D) ->
+ case btb_contains_context(Src, Regs0) of
+ false ->
+ btb_reaches_match_1(Is, Regs0, D);
+ true ->
+ %% Check that all other copies of the context registers
+ %% are killed by the following instructions.
+ Regs = btb_kill([Src], Regs0),
+ CtxRegs = btb_context_regs(Regs),
+ case btb_are_all_killed(CtxRegs, Is, D) of
+ false -> btb_error({CtxRegs,not_all_killed_after,I});
+ true -> D#btb{must_not_save=true}
+ end
+ end;
+btb_reaches_match_2([{bs_context_to_binary,Src}=I|Is], Regs0, D) ->
+ case btb_contains_context(Src, Regs0) of
+ false ->
+ btb_reaches_match_1(Is, Regs0, D);
+ true ->
+ %% Check that all other copies of the context registers
+ %% are killed by the following instructions.
+ Regs = btb_kill([Src], Regs0),
+ CtxRegs = btb_context_regs(Regs),
+ case btb_are_all_killed(CtxRegs, Is, D) of
+ false -> btb_error({CtxRegs,not_all_killed_after,I});
+ true -> D#btb{must_not_save=true}
+ end
+ end;
+btb_reaches_match_2([{badmatch,Src}=I|_], Regs, D) ->
+ btb_ensure_not_used([Src], I, Regs),
+ D;
+btb_reaches_match_2([{case_end,Src}=I|_], Regs, D) ->
+ btb_ensure_not_used([Src], I, Regs),
+ D;
+btb_reaches_match_2([if_end|_], _Regs, D) ->
+ D;
+btb_reaches_match_2([{func_info,_,_,Arity}=I|_], Regs0, D) ->
+ Regs = btb_kill_yregs(btb_kill_not_live(Arity, Regs0)),
+ case btb_context_regs(Regs) of
+ [] -> D;
+ _ -> {binary_used_in,I}
+ end;
+btb_reaches_match_2([I|_], Regs, _) ->
+ btb_error({btb_context_regs(Regs),I,not_handled}).
+
+btb_call(Arity, Lbl, Regs0, Is, D0) ->
+ Regs = btb_kill_not_live(Arity, Regs0),
+ case btb_are_x_registers_empty(Regs) of
+ false ->
+ %% There is a match context in one of the x registers.
+ %% First handle the call as if it were a tail call.
+ D = btb_tail_call(Lbl, Regs, D0),
+
+ %% No problem so far, but now we must make sure that
+ %% we don't have any copies of the match context
+ %% tucked away in an y register.
+ RegList = btb_context_regs(Regs),
+ case [R || {y,_}=R <- RegList] of
+ [] -> D;
+ [_|_] -> btb_error({multiple_uses,RegList})
+ end;
+ true ->
+ %% No match context in any x register. It could have been
+ %% saved to an y register, so continue to scan the code following
+ %% the call.
+ btb_reaches_match_1(Is, Regs, D0)
+ end.
+
+btb_tail_call(Lbl, Regs, #btb{f=Ftree,must_save=MustSave0}=D) ->
+ %% Ignore any y registers here.
+ case [R || {x,_}=R <- btb_context_regs(Regs)] of
+ [] ->
+ D;
+ [{x,_}=Reg] ->
+ case gb_trees:lookup(Lbl, Ftree) of
+ {value,{Reg,MustSave}} ->
+ D#btb{must_save=MustSave0 or MustSave};
+ _ when is_integer(Lbl) ->
+ btb_error({{label,Lbl},no_suitable_bs_start_match});
+ _ ->
+ btb_error({binary_used_in,Lbl})
+ end;
+ [_|_] when not is_integer(Lbl) ->
+ btb_error({binary_used_in,Lbl});
+ [_|_]=RegList ->
+ btb_error({multiple_uses,RegList})
+ end.
+
+%% btb_follow_branches([Cond], Regs, D) -> D'
+%% Recursively follow all the branches.
+
+btb_follow_branches([{f,Lbl}|T], Regs, D0) ->
+ D = btb_follow_branch(Lbl, Regs, D0),
+ btb_follow_branches(T, Regs, D);
+btb_follow_branches([_|T], Regs, D) ->
+ btb_follow_branches(T, Regs, D);
+btb_follow_branches([], _, D) -> D.
+
+%% btb_follow_branch(Lbl, Regs, D) -> D'
+%% Recursively follow the branch.
+
+btb_follow_branch(0, _Regs, D) -> D;
+btb_follow_branch(Lbl, Regs, #btb{ok_br=Br0,index=Li}=D) ->
+ case gb_sets:is_member(Lbl, Br0) of
+ true ->
+ %% We have already followed this branch and it was OK.
+ D;
+ false ->
+ %% New branch. Try it.
+ Is = fetch_code_at(Lbl, Li),
+ #btb{ok_br=Br,must_not_save=MustNotSave,must_save=MustSave} =
+ btb_reaches_match_1(Is, Regs, D),
+
+ %% Since we got back, this branch is OK.
+ D#btb{ok_br=gb_sets:insert(Lbl, Br),must_not_save=MustNotSave,
+ must_save=MustSave}
+ end.
+
+btb_reaches_match_block([{set,Ds,Ss,{alloc,Live,_}}=I|Is], Regs0) ->
+ %% An allocation instruction or a GC bif. We'll kill all registers
+ %% if any copy of the context is used as the source to the BIF.
+ btb_ensure_not_used(Ss, I, Regs0),
+ Regs1 = btb_kill_not_live(Live, Regs0),
+ Regs = btb_kill(Ds, Regs1),
+ btb_reaches_match_block(Is, Regs);
+btb_reaches_match_block([{set,[Dst]=Ds,[Src],move}|Is], Regs0) ->
+ Regs1 = btb_kill(Ds, Regs0),
+ Regs = case btb_contains_context(Src, Regs1) of
+ false -> Regs1;
+ true -> btb_set_context(Dst, Regs1)
+ end,
+ btb_reaches_match_block(Is, Regs);
+btb_reaches_match_block([{set,Ds,Ss,_}=I|Is], Regs0) ->
+ btb_ensure_not_used(Ss, I, Regs0),
+ Regs = btb_kill(Ds, Regs0),
+ btb_reaches_match_block(Is, Regs);
+btb_reaches_match_block([], Regs) ->
+ Regs.
+
+%% btb_regs_from_arity(Arity) -> [Register])
+%% Create a list of x registers from a function arity.
+
+btb_regs_from_arity(Arity) ->
+ btb_regs_from_arity_1(Arity, []).
+
+btb_regs_from_arity_1(0, Acc) -> Acc;
+btb_regs_from_arity_1(N, Acc) -> btb_regs_from_arity_1(N-1, [{x,N-1}|Acc]).
+
+%% btb_are_all_killed([Register], [Instruction], D) -> true|false
+%% Test whether all of the register are killed in the instruction stream.
+
+btb_are_all_killed(RegList, Is, #btb{index=Li}) ->
+ all(fun(R) ->
+ beam_utils:is_killed(R, Is, Li)
+ end, RegList).
+
+%% btp_regs_from_list([Register]) -> RegisterSet.
+%% Create a register set from a list of registers.
+
+btb_regs_from_list(L) ->
+ foldl(fun(R, Regs) ->
+ btb_set_context(R, Regs)
+ end, {0,0}, L).
+
+%% btb_set_context(Register, RegisterSet) -> RegisterSet'
+%% Update RegisterSet to indicate that Register contains the matching context.
+
+btb_set_context({x,N}, {Xregs,Yregs}) ->
+ {Xregs bor (1 bsl N),Yregs};
+btb_set_context({y,N}, {Xregs,Yregs}) ->
+ {Xregs,Yregs bor (1 bsl N)}.
+
+%% btb_ensure_not_used([Register], Instruction, RegisterSet) -> ok
+%% If any register in RegisterSet (the register(s) known to contain
+%% the match context) is used in the list of registers, generate an error.
+
+btb_ensure_not_used(Rs, I, Regs) ->
+ case lists:any(fun(R) -> btb_contains_context(R, Regs) end, Rs) of
+ true -> btb_error({binary_used_in,I});
+ false -> ok
+ end.
+
+%% btb_kill([Register], RegisterSet) -> RegisterSet'
+%% Kill all registers mentioned in the list of registers.
+
+btb_kill([{x,N}|Rs], {Xregs,Yregs}) ->
+ btb_kill(Rs, {Xregs band (bnot (1 bsl N)),Yregs});
+btb_kill([{y,N}|Rs], {Xregs,Yregs}) ->
+ btb_kill(Rs, {Xregs,Yregs band (bnot (1 bsl N))});
+btb_kill([{fr,_}|Rs], Regs) ->
+ btb_kill(Rs, Regs);
+btb_kill([], Regs) -> Regs.
+
+%% btb_kill_not_live(Live, RegisterSet) -> RegisterSet'
+%% Kill all registers indicated not live by Live.
+
+btb_kill_not_live(Live, {Xregs,Yregs}) ->
+ {Xregs band ((1 bsl Live)-1),Yregs}.
+
+%% btb_kill(Regs0) -> Regs
+%% Kill all y registers.
+
+btb_kill_yregs({Xregs,_}) -> {Xregs,0}.
+
+%% btb_are_registers_empty(RegisterSet) -> true|false
+%% Test whether the register set is empty.
+
+btb_are_registers_empty({0,0}) -> true;
+btb_are_registers_empty({_,_}) -> false.
+
+%% btb_are_x_registers_empty(Regs) -> true|false
+%% Test whether the x registers are empty.
+
+btb_are_x_registers_empty({0,_}) -> true;
+btb_are_x_registers_empty({_,_}) -> false.
+
+%% btb_contains_context(Register, RegisterSet) -> true|false
+%% Test whether Register contains the context.
+
+btb_contains_context({x,N}, {Regs,_}) -> Regs band (1 bsl N) =/= 0;
+btb_contains_context({y,N}, {_,Regs}) -> Regs band (1 bsl N) =/= 0;
+btb_contains_context(_, _) -> false.
+
+%% btb_context_regs(RegisterSet) -> [Register]
+%% Convert the register set to an explicit list of registers.
+btb_context_regs({Xregs,Yregs}) ->
+ btb_context_regs_1(Xregs, 0, x, btb_context_regs_1(Yregs, 0, y, [])).
+
+btb_context_regs_1(0, _, _, Acc) ->
+ Acc;
+btb_context_regs_1(Regs, N, Tag, Acc) when (Regs band 1) =:= 1 ->
+ btb_context_regs_1(Regs bsr 1, N+1, Tag, [{Tag,N}|Acc]);
+btb_context_regs_1(Regs, N, Tag, Acc) ->
+ btb_context_regs_1(Regs bsr 1, N+1, Tag, Acc).
+
+%% btb_index([Function]) -> GbTree({EntryLabel,{Register,MustSave}})
+%% Build an index of functions that accept a match context instead of
+%% a binary. MustSave is true if the function may pass the match
+%% context to the bs_context_to_binary instruction (in which case
+%% the current position in the binary must have saved into the
+%% start position using "bs_save_2 Ctx start".
+
+btb_index(Fs) ->
+ btb_index_1(Fs, []).
+
+btb_index_1([{function,_,_,Entry,Is0}|Fs], Acc0) ->
+ [{label,_},{func_info,_,_,_},{label,Entry}|Is] = Is0,
+ Acc = btb_index_2(Is, Entry, false, Acc0),
+ btb_index_1(Fs, Acc);
+btb_index_1([], Acc) -> gb_trees:from_orddict(sort(Acc)).
+
+btb_index_2([{test,bs_start_match2,{f,_},_,[Reg,_],Reg}|_],
+ Entry, MustSave, Acc) ->
+ [{Entry,{Reg,MustSave}}|Acc];
+btb_index_2(Is0, Entry, _, Acc) ->
+ try btb_index_find_start_match(Is0) of
+ Is -> btb_index_2(Is, Entry, true, Acc)
+ catch
+ throw:none -> Acc
+ end.
+
+btb_index_find_start_match([{test,_,{f,F},_},{bs_context_to_binary,_}|Is]) ->
+ btb_index_find_label(Is, F);
+btb_index_find_start_match(_) ->
+ throw(none).
+
+btb_index_find_label([{label,L}|Is], L) -> Is;
+btb_index_find_label([_|Is], L) -> btb_index_find_label(Is, L).
+
+btb_error(Error) ->
+ throw({error,Error}).
+
+fetch_code_at(Lbl, Li) ->
+ case beam_utils:code_at(Lbl, Li) of
+ Is when is_list(Is) -> Is
+ end.
+
+%%%
+%%% Compilation information warnings.
+%%%
+
+btb_comment_opt({field_flags,[{anno,A}|_]}) ->
+ {'%',{bin_opt,A}};
+btb_comment_opt(_) ->
+ {'%',{bin_opt,[]}}.
+
+btb_comment_no_opt(Reason, {field_flags,[{anno,A}|_]}) ->
+ {'%',{no_bin_opt,Reason,A}};
+btb_comment_no_opt(Reason, _) ->
+ {'%',{no_bin_opt,Reason,[]}}.
+
+collect_warnings(Fs) ->
+ D = warning_index_functions(Fs),
+ foldl(fun(F, A) -> collect_warnings_fun(F, D, A) end, [], Fs).
+
+collect_warnings_fun({function,_,_,_,Is}, D, A) ->
+ collect_warnings_instr(Is, D, A).
+
+collect_warnings_instr([{'%',{bin_opt,Where}}|Is], D, Acc0) ->
+ Acc = add_warning(bin_opt, Where, Acc0),
+ collect_warnings_instr(Is, D, Acc);
+collect_warnings_instr([{'%',{no_bin_opt,Reason0,Where}}|Is], D, Acc0) ->
+ Reason = warning_translate_label(Reason0, D),
+ Acc = add_warning({no_bin_opt,Reason}, Where, Acc0),
+ collect_warnings_instr(Is, D, Acc);
+collect_warnings_instr([_|Is], D, Acc) ->
+ collect_warnings_instr(Is, D, Acc);
+collect_warnings_instr([], _, Acc) -> Acc.
+
+add_warning(Term, Anno, Ws) ->
+ Line = abs(get_line(Anno)),
+ File = get_file(Anno),
+ [{File,[{Line,?MODULE,Term}]}|Ws].
+
+warning_translate_label(Term, D) when is_tuple(Term) ->
+ case element(1, Term) of
+ {label,F} ->
+ case gb_trees:lookup(F, D) of
+ none -> Term;
+ {value,FA} -> setelement(1, Term, FA)
+ end;
+ _ -> Term
+ end;
+warning_translate_label(Term, _) -> Term.
+
+get_line([Line|_]) when is_integer(Line) -> Line;
+get_line([_|T]) -> get_line(T);
+get_line([]) -> none.
+
+get_file([{file,File}|_]) -> File;
+get_file([_|T]) -> get_file(T);
+get_file([]) -> "no_file". % should not happen
+
+warning_index_functions(Fs) ->
+ D = [{Entry,{F,A}} || {function,F,A,Entry,_} <- Fs],
+ gb_trees:from_orddict(sort(D)).
+
+format_error_1({binary_used_in,{extfunc,M,F,A}}) ->
+ [io_lib:format("sub binary used by ~p:~p/~p", [M,F,A])|
+ case {M,F,A} of
+ {erlang,split_binary,2} ->
+ "; SUGGEST using binary matching instead of split_binary/2";
+ _ ->
+ ""
+ end];
+format_error_1({binary_used_in,_}) ->
+ "sub binary is used or returned";
+format_error_1({multiple_uses,_}) ->
+ "sub binary is matched or used in more than one place";
+format_error_1(unsuitable_bs_start_match) ->
+ "the binary matching instruction that follows in the same function "
+ "have problems that prevent delayed sub binary optimization "
+ "(probably indicated by INFO warnings)";
+format_error_1({{F,A},no_suitable_bs_start_match}) ->
+ io_lib:format("called function ~p/~p does not begin with a suitable "
+ "binary matching instruction", [F,A]);
+format_error_1(must_and_must_not_save) ->
+ "different control paths use different positions in the binary";
+format_error_1({_,I,not_handled}) ->
+ case I of
+ {'catch',_,_} ->
+ "the compiler currently does not attempt the delayed sub binary "
+ "optimization when catch is used";
+ {'try',_,_} ->
+ "the compiler currently does not attempt the delayed sub binary "
+ "optimization when try/catch is used";
+ _ ->
+ io_lib:format("compiler limitation: instruction ~p prevents "
+ "delayed sub binary optimization", [I])
+ end;
+format_error_1(Term) ->
+ io_lib:format("~w", [Term]).
diff --git a/lib/compiler/src/beam_clean.erl b/lib/compiler/src/beam_clean.erl
new file mode 100644
index 0000000000..64c93e11f7
--- /dev/null
+++ b/lib/compiler/src/beam_clean.erl
@@ -0,0 +1,377 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2000-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%
+%%
+%% Purpose : Clean up, such as removing unused labels and unused functions.
+
+-module(beam_clean).
+
+-export([module/2]).
+-export([bs_clean_saves/1]).
+-export([clean_labels/1]).
+-import(lists, [map/2,foldl/3,reverse/1]).
+
+module({Mod,Exp,Attr,Fs0,_}, _Opt) ->
+ Order = [Lbl || {function,_,_,Lbl,_} <- Fs0],
+ All = foldl(fun({function,_,_,Lbl,_}=Func,D) -> dict:store(Lbl, Func, D) end,
+ dict:new(), Fs0),
+ WorkList = rootset(Fs0, Exp, Attr),
+ Used = find_all_used(WorkList, All, sets:from_list(WorkList)),
+ Fs1 = remove_unused(Order, Used, All),
+ {Fs2,Lc} = clean_labels(Fs1),
+ Fs = bs_fix(Fs2),
+ {ok,{Mod,Exp,Attr,Fs,Lc}}.
+
+%% Remove all bs_save2/2 instructions not referenced by a bs_restore2/2.
+bs_clean_saves(Is) ->
+ Needed = bs_restores(Is, []),
+ bs_clean_saves_1(Is, gb_sets:from_list(Needed), []).
+
+%% Determine the rootset, i.e. exported functions and
+%% the on_load function (if any).
+
+rootset(Fs, Root0, Attr) ->
+ Root1 = case proplists:get_value(on_load, Attr) of
+ undefined -> Root0;
+ [OnLoad] -> [OnLoad|Root0]
+ end,
+ Root = sofs:set(Root1, [function]),
+ Map0 = [{{Name,Arity},Lbl} || {function,Name,Arity,Lbl,_} <- Fs],
+ Map = sofs:relation(Map0, [{function,label}]),
+ sofs:to_external(sofs:image(Map, Root)).
+
+%% Remove the unused functions.
+
+remove_unused([F|Fs], Used, All) ->
+ case sets:is_element(F, Used) of
+ false -> remove_unused(Fs, Used, All);
+ true -> [dict:fetch(F, All)|remove_unused(Fs, Used, All)]
+ end;
+remove_unused([], _, _) -> [].
+
+%% Find all used functions.
+
+find_all_used([F|Fs0], All, Used0) ->
+ {function,_,_,_,Code} = dict:fetch(F, All),
+ {Fs,Used} = update_work_list(Code, {Fs0,Used0}),
+ find_all_used(Fs, All, Used);
+find_all_used([], _All, Used) -> Used.
+
+update_work_list([{call,_,{f,L}}|Is], Sets) ->
+ update_work_list(Is, add_to_work_list(L, Sets));
+update_work_list([{call_last,_,{f,L},_}|Is], Sets) ->
+ update_work_list(Is, add_to_work_list(L, Sets));
+update_work_list([{call_only,_,{f,L}}|Is], Sets) ->
+ update_work_list(Is, add_to_work_list(L, Sets));
+update_work_list([{make_fun2,{f,L},_,_,_}|Is], Sets) ->
+ update_work_list(Is, add_to_work_list(L, Sets));
+update_work_list([_|Is], Sets) ->
+ update_work_list(Is, Sets);
+update_work_list([], Sets) -> Sets.
+
+add_to_work_list(F, {Fs,Used}=Sets) ->
+ case sets:is_element(F, Used) of
+ true -> Sets;
+ false -> {[F|Fs],sets:add_element(F, Used)}
+ end.
+
+
+%%%
+%%% Coalesce adjacent labels. Renumber all labels to eliminate gaps.
+%%% This cleanup will slightly reduce file size and slightly speed up loading.
+%%%
+%%% We also expand is_record/3 to a sequence of instructions. It is done
+%%% here merely because this module will always be called even if optimization
+%%% is turned off. We don't want to do the expansion in beam_asm because we
+%%% want to see the expanded code in a .S file.
+%%%
+
+-record(st, {lmap, %Translation tables for labels.
+ entry, %Number of entry label.
+ lc %Label counter
+ }).
+
+clean_labels(Fs0) ->
+ St0 = #st{lmap=[],lc=1},
+ {Fs1,#st{lmap=Lmap0,lc=Lc}} = function_renumber(Fs0, St0, []),
+ Lmap = gb_trees:from_orddict(ordsets:from_list(Lmap0)),
+ Fs = function_replace(Fs1, Lmap, []),
+ {Fs,Lc}.
+
+function_renumber([{function,Name,Arity,_Entry,Asm0}|Fs], St0, Acc) ->
+ {Asm,St} = renumber_labels(Asm0, [], St0),
+ function_renumber(Fs, St, [{function,Name,Arity,St#st.entry,Asm}|Acc]);
+function_renumber([], St, Acc) -> {Acc,St}.
+
+renumber_labels([{bif,is_record,{f,_},
+ [Term,{atom,Tag}=TagAtom,{integer,Arity}],Dst}|Is0], Acc, St) ->
+ ContLabel = 900000000+2*St#st.lc,
+ FailLabel = ContLabel+1,
+ Fail = {f,FailLabel},
+ Tmp = Dst,
+ Is = case is_record_tuple(Term, Tag, Arity) of
+ yes ->
+ [{move,{atom,true},Dst}|Is0];
+ no ->
+ [{move,{atom,false},Dst}|Is0];
+ maybe ->
+ [{test,is_tuple,Fail,[Term]},
+ {test,test_arity,Fail,[Term,Arity]},
+ {get_tuple_element,Term,0,Tmp},
+ {test,is_eq_exact,Fail,[Tmp,TagAtom]},
+ {move,{atom,true},Dst},
+ {jump,{f,ContLabel}},
+ {label,FailLabel},
+ {move,{atom,false},Dst},
+ {jump,{f,ContLabel}}, %Improves optimization by beam_dead.
+ {label,ContLabel}|Is0]
+ end,
+ renumber_labels(Is, Acc, St);
+renumber_labels([{test,is_record,{f,_}=Fail,
+ [Term,{atom,Tag}=TagAtom,{integer,Arity}]}|Is0], Acc, St) ->
+ Tmp = {x,1023},
+ Is = case is_record_tuple(Term, Tag, Arity) of
+ yes ->
+ Is0;
+ no ->
+ [{jump,Fail}|Is0];
+ maybe ->
+ [{test,is_tuple,Fail,[Term]},
+ {test,test_arity,Fail,[Term,Arity]},
+ {get_tuple_element,Term,0,Tmp},
+ {test,is_eq_exact,Fail,[Tmp,TagAtom]}|Is0]
+ end,
+ renumber_labels(Is, Acc, St);
+renumber_labels([{label,Old}|Is], [{label,New}|_]=Acc, #st{lmap=D0}=St) ->
+ D = [{Old,New}|D0],
+ renumber_labels(Is, Acc, St#st{lmap=D});
+renumber_labels([{label,Old}|Is], Acc, St0) ->
+ New = St0#st.lc,
+ D = [{Old,New}|St0#st.lmap],
+ renumber_labels(Is, [{label,New}|Acc], St0#st{lmap=D,lc=New+1});
+renumber_labels([{func_info,_,_,_}=Fi|Is], Acc, St0) ->
+ renumber_labels(Is, [Fi|Acc], St0#st{entry=St0#st.lc});
+renumber_labels([I|Is], Acc, St0) ->
+ renumber_labels(Is, [I|Acc], St0);
+renumber_labels([], Acc, St) -> {Acc,St}.
+
+is_record_tuple({x,_}, _, _) -> maybe;
+is_record_tuple({y,_}, _, _) -> maybe;
+is_record_tuple({literal,Tuple}, Tag, Arity)
+ when element(1, Tuple) =:= Tag, tuple_size(Tuple) =:= Arity -> yes;
+is_record_tuple(_, _, _) -> no.
+
+function_replace([{function,Name,Arity,Entry,Asm0}|Fs], Dict, Acc) ->
+ Asm = try
+ replace(Asm0, [], Dict)
+ catch
+ throw:{error,{undefined_label,Lbl}=Reason} ->
+ io:format("Function ~s/~w refers to undefined label ~w\n",
+ [Name,Arity,Lbl]),
+ exit(Reason)
+ end,
+ function_replace(Fs, Dict, [{function,Name,Arity,Entry,Asm}|Acc]);
+function_replace([], _, Acc) -> Acc.
+
+replace([{test,bs_match_string=Op,{f,Lbl},[Ctx,Bin0]}|Is], Acc, D) ->
+ Bits = bit_size(Bin0),
+ Bin = case Bits rem 8 of
+ 0 -> Bin0;
+ Rem -> <<Bin0/bitstring,0:(8-Rem)>>
+ end,
+ I = {test,Op,{f,label(Lbl, D)},[Ctx,Bits,{string,binary_to_list(Bin)}]},
+ replace(Is, [I|Acc], D);
+replace([{test,Test,{f,Lbl},Ops}|Is], Acc, D) ->
+ replace(Is, [{test,Test,{f,label(Lbl, D)},Ops}|Acc], D);
+replace([{test,Test,{f,Lbl},Live,Ops,Dst}|Is], Acc, D) ->
+ replace(Is, [{test,Test,{f,label(Lbl, D)},Live,Ops,Dst}|Acc], D);
+replace([{select_val,R,{f,Fail0},{list,Vls0}}|Is], Acc, D) ->
+ Vls1 = map(fun ({f,L}) -> {f,label(L, D)};
+ (Other) -> Other end, Vls0),
+ Fail = label(Fail0, D),
+ case redundant_values(Vls1, Fail, []) of
+ [] ->
+ %% Oops, no choices left. The loader will not accept that.
+ %% Convert to a plain jump.
+ replace(Is, [{jump,{f,Fail}}|Acc], D);
+ Vls ->
+ replace(Is, [{select_val,R,{f,Fail},{list,Vls}}|Acc], D)
+ end;
+replace([{select_tuple_arity,R,{f,Fail},{list,Vls0}}|Is], Acc, D) ->
+ Vls = map(fun ({f,L}) -> {f,label(L, D)};
+ (Other) -> Other end, Vls0),
+ replace(Is, [{select_tuple_arity,R,{f,label(Fail, D)},{list,Vls}}|Acc], D);
+replace([{'try',R,{f,Lbl}}|Is], Acc, D) ->
+ replace(Is, [{'try',R,{f,label(Lbl, D)}}|Acc], D);
+replace([{'catch',R,{f,Lbl}}|Is], Acc, D) ->
+ replace(Is, [{'catch',R,{f,label(Lbl, D)}}|Acc], D);
+replace([{jump,{f,Lbl}}|Is], Acc, D) ->
+ replace(Is, [{jump,{f,label(Lbl, D)}}|Acc], D);
+replace([{loop_rec,{f,Lbl},R}|Is], Acc, D) ->
+ replace(Is, [{loop_rec,{f,label(Lbl, D)},R}|Acc], D);
+replace([{loop_rec_end,{f,Lbl}}|Is], Acc, D) ->
+ replace(Is, [{loop_rec_end,{f,label(Lbl, D)}}|Acc], D);
+replace([{wait,{f,Lbl}}|Is], Acc, D) ->
+ replace(Is, [{wait,{f,label(Lbl, D)}}|Acc], D);
+replace([{wait_timeout,{f,Lbl},To}|Is], Acc, D) ->
+ replace(Is, [{wait_timeout,{f,label(Lbl, D)},To}|Acc], D);
+replace([{bif,Name,{f,Lbl},As,R}|Is], Acc, D) when Lbl =/= 0 ->
+ replace(Is, [{bif,Name,{f,label(Lbl, D)},As,R}|Acc], D);
+replace([{gc_bif,Name,{f,Lbl},Live,As,R}|Is], Acc, D) when Lbl =/= 0 ->
+ replace(Is, [{gc_bif,Name,{f,label(Lbl, D)},Live,As,R}|Acc], D);
+replace([{call,Ar,{f,Lbl}}|Is], Acc, D) ->
+ replace(Is, [{call,Ar,{f,label(Lbl,D)}}|Acc], D);
+replace([{call_last,Ar,{f,Lbl},N}|Is], Acc, D) ->
+ replace(Is, [{call_last,Ar,{f,label(Lbl,D)},N}|Acc], D);
+replace([{call_only,Ar,{f,Lbl}}|Is], Acc, D) ->
+ replace(Is, [{call_only,Ar,{f,label(Lbl, D)}}|Acc], D);
+replace([{make_fun2,{f,Lbl},U1,U2,U3}|Is], Acc, D) ->
+ replace(Is, [{make_fun2,{f,label(Lbl, D)},U1,U2,U3}|Acc], D);
+replace([{bs_init2,{f,Lbl},Sz,Words,R,F,Dst}|Is], Acc, D) when Lbl =/= 0 ->
+ replace(Is, [{bs_init2,{f,label(Lbl, D)},Sz,Words,R,F,Dst}|Acc], D);
+replace([{bs_init_bits,{f,Lbl},Sz,Words,R,F,Dst}|Is], Acc, D) when Lbl =/= 0 ->
+ replace(Is, [{bs_init_bits,{f,label(Lbl, D)},Sz,Words,R,F,Dst}|Acc], D);
+replace([{bs_put_integer,{f,Lbl},Bits,Unit,Fl,Val}|Is], Acc, D) when Lbl =/= 0 ->
+ replace(Is, [{bs_put_integer,{f,label(Lbl, D)},Bits,Unit,Fl,Val}|Acc], D);
+replace([{bs_put_utf8=I,{f,Lbl},Fl,Val}|Is], Acc, D) when Lbl =/= 0 ->
+ replace(Is, [{I,{f,label(Lbl, D)},Fl,Val}|Acc], D);
+replace([{bs_put_utf16=I,{f,Lbl},Fl,Val}|Is], Acc, D) when Lbl =/= 0 ->
+ replace(Is, [{I,{f,label(Lbl, D)},Fl,Val}|Acc], D);
+replace([{bs_put_utf32=I,{f,Lbl},Fl,Val}|Is], Acc, D) when Lbl =/= 0 ->
+ replace(Is, [{I,{f,label(Lbl, D)},Fl,Val}|Acc], D);
+replace([{bs_put_binary,{f,Lbl},Bits,Unit,Fl,Val}|Is], Acc, D) when Lbl =/= 0 ->
+ replace(Is, [{bs_put_binary,{f,label(Lbl, D)},Bits,Unit,Fl,Val}|Acc], D);
+replace([{bs_put_float,{f,Lbl},Bits,Unit,Fl,Val}|Is], Acc, D) when Lbl =/= 0 ->
+ replace(Is, [{bs_put_float,{f,label(Lbl, D)},Bits,Unit,Fl,Val}|Acc], D);
+replace([{bs_add,{f,Lbl},Src,Dst}|Is], Acc, D) when Lbl =/= 0 ->
+ replace(Is, [{bs_add,{f,label(Lbl, D)},Src,Dst}|Acc], D);
+replace([{bs_append,{f,Lbl},_,_,_,_,_,_,_}=I0|Is], Acc, D) when Lbl =/= 0 ->
+ I = setelement(2, I0, {f,label(Lbl, D)}),
+ replace(Is, [I|Acc], D);
+replace([{bs_utf8_size=I,{f,Lbl},Src,Dst}|Is], Acc, D) when Lbl =/= 0 ->
+ replace(Is, [{I,{f,label(Lbl, D)},Src,Dst}|Acc], D);
+replace([{bs_utf16_size=I,{f,Lbl},Src,Dst}|Is], Acc, D) when Lbl =/= 0 ->
+ replace(Is, [{I,{f,label(Lbl, D)},Src,Dst}|Acc], D);
+replace([I|Is], Acc, D) ->
+ replace(Is, [I|Acc], D);
+replace([], Acc, _) -> Acc.
+
+label(Old, D) ->
+ case gb_trees:lookup(Old, D) of
+ {value,Val} -> Val;
+ none -> throw({error,{undefined_label,Old}})
+ end.
+
+redundant_values([_,{f,Fail}|Vls], Fail, Acc) ->
+ redundant_values(Vls, Fail, Acc);
+redundant_values([Val,Lbl|Vls], Fail, Acc) ->
+ redundant_values(Vls, Fail, [Lbl,Val|Acc]);
+redundant_values([], _, Acc) -> reverse(Acc).
+
+%%%
+%%% Final fixup of bs_start_match2/5,bs_save2/bs_restore2 instructions for
+%%% new bit syntax matching (introduced in R11B).
+%%%
+%%% Pass 1: Scan the code, looking for bs_restore2/2 instructions.
+%%%
+%%% Pass 2: Update bs_save2/2 and bs_restore/2 instructions. Remove
+%%% any bs_save2/2 instruction whose save position are never referenced
+%%% by any bs_restore2/2 instruction.
+%%%
+%%% Note this module can be invoked several times, so we must be careful
+%%% not to touch instructions that have already been fixed up.
+%%%
+
+bs_fix(Fs) ->
+ bs_fix(Fs, []).
+
+bs_fix([{function,Name,Arity,Entry,Asm0}|Fs], Acc) ->
+ Asm = bs_function(Asm0),
+ bs_fix(Fs, [{function,Name,Arity,Entry,Asm}|Acc]);
+bs_fix([], Acc) -> reverse(Acc).
+
+bs_function(Is) ->
+ Dict0 = bs_restores(Is, []),
+ S0 = sofs:relation(Dict0, [{context,save_point}]),
+ S1 = sofs:relation_to_family(S0),
+ S = sofs:to_external(S1),
+ Dict = make_save_point_dict(S, []),
+ bs_replace(Is, Dict, []).
+
+make_save_point_dict([{Ctx,Pts}|T], Acc0) ->
+ Acc = make_save_point_dict_1(Pts, Ctx, 0, Acc0),
+ make_save_point_dict(T, Acc);
+make_save_point_dict([], Acc) ->
+ gb_trees:from_orddict(ordsets:from_list(Acc)).
+
+make_save_point_dict_1([H|T], Ctx, I, Acc) ->
+ make_save_point_dict_1(T, Ctx, I+1, [{{Ctx,H},I}|Acc]);
+make_save_point_dict_1([], Ctx, I, Acc) ->
+ [{Ctx,I}|Acc].
+
+%% Pass 1.
+bs_restores([{bs_restore2,_,{Same,Same}}|Is], Dict) ->
+ %% This save point is special. No explicit save is needed.
+ bs_restores(Is, Dict);
+bs_restores([{bs_restore2,_,{atom,start}}|Is], Dict) ->
+ %% This instruction can occur if "compilation"
+ %% started from a .S file.
+ bs_restores(Is, Dict);
+bs_restores([{bs_restore2,_,{_,_}=SavePoint}|Is], Dict) ->
+ bs_restores(Is, [SavePoint|Dict]);
+bs_restores([_|Is], Dict) ->
+ bs_restores(Is, Dict);
+bs_restores([], Dict) -> Dict.
+
+%% Pass 2.
+bs_replace([{test,bs_start_match2,F,Live,[Src,Ctx],CtxR}|T], Dict, Acc) when is_atom(Ctx) ->
+ Slots = case gb_trees:lookup(Ctx, Dict) of
+ {value,Slots0} -> Slots0;
+ none -> 0
+ end,
+ I = {test,bs_start_match2,F,Live,[Src,Slots],CtxR},
+ bs_replace(T, Dict, [I|Acc]);
+bs_replace([{bs_save2,CtxR,{_,_}=SavePoint}|T], Dict, Acc) ->
+ case gb_trees:lookup(SavePoint, Dict) of
+ {value,N} ->
+ bs_replace(T, Dict, [{bs_save2,CtxR,N}|Acc]);
+ none ->
+ bs_replace(T, Dict, Acc)
+ end;
+bs_replace([{bs_restore2,_,{atom,start}}=I|T], Dict, Acc) ->
+ %% This instruction can occur if "compilation"
+ %% started from a .S file.
+ bs_replace(T, Dict, [I|Acc]);
+bs_replace([{bs_restore2,CtxR,{Same,Same}}|T], Dict, Acc) ->
+ %% This save point refers to the point in the binary where the match
+ %% started. It has a special name.
+ bs_replace(T, Dict, [{bs_restore2,CtxR,{atom,start}}|Acc]);
+bs_replace([{bs_restore2,CtxR,{_,_}=SavePoint}|T], Dict, Acc) ->
+ N = gb_trees:get(SavePoint, Dict),
+ bs_replace(T, Dict, [{bs_restore2,CtxR,N}|Acc]);
+bs_replace([I|Is], Dict, Acc) ->
+ bs_replace(Is, Dict, [I|Acc]);
+bs_replace([], _, Acc) -> reverse(Acc).
+
+bs_clean_saves_1([{bs_save2,_,{_,_}=SavePoint}=I|Is], Needed, Acc) ->
+ case gb_sets:is_member(SavePoint, Needed) of
+ false -> bs_clean_saves_1(Is, Needed, Acc);
+ true -> bs_clean_saves_1(Is, Needed, [I|Acc])
+ end;
+bs_clean_saves_1([I|Is], Needed, Acc) ->
+ bs_clean_saves_1(Is, Needed, [I|Acc]);
+bs_clean_saves_1([], _, Acc) -> reverse(Acc).
diff --git a/lib/compiler/src/beam_dead.erl b/lib/compiler/src/beam_dead.erl
new file mode 100644
index 0000000000..7b4cd814a2
--- /dev/null
+++ b/lib/compiler/src/beam_dead.erl
@@ -0,0 +1,599 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2002-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+%%
+
+-module(beam_dead).
+
+-export([module/2]).
+
+%%% The following optimisations are done:
+%%%
+%%% (1) In this code
+%%%
+%%% move DeadValue {x,0}
+%%% jump L2
+%%% .
+%%% .
+%%% .
+%%% L2: move Anything {x,0}
+%%% .
+%%% .
+%%% .
+%%%
+%%% the first assignment to {x,0} has no effect (is dead),
+%%% so it can be removed. Besides removing a move instruction,
+%%% if the move was preceeded by a label, the resulting code
+%%% will look this
+%%%
+%%% L1: jump L2
+%%% .
+%%% .
+%%% .
+%%% L2: move Anything {x,0}
+%%% .
+%%% .
+%%% .
+%%%
+%%% which can be further optimized by the jump optimizer (beam_jump).
+%%%
+%%% (2) In this code
+%%%
+%%% L1: move AtomLiteral {x,0}
+%%% jump L2
+%%% .
+%%% .
+%%% .
+%%% L2: test is_atom FailLabel {x,0}
+%%% select_val {x,0}, FailLabel [... AtomLiteral => L3...]
+%%% .
+%%% .
+%%% .
+%%% L3: ...
+%%%
+%%% FailLabel: ...
+%%%
+%%% the first code fragment can be changed to
+%%%
+%%% L1: move AtomLiteral {x,0}
+%%% jump L3
+%%%
+%%% If the literal is not included in the table of literals in the
+%%% select_val instruction, the first code fragment will instead be
+%%% rewritten as:
+%%%
+%%% L1: move AtomLiteral {x,0}
+%%% jump FailLabel
+%%%
+%%% The move instruction will be removed by optimization (1) above,
+%%% if the code following the L3 label overwrites {x,0}.
+%%%
+%%% The code following the L2 label will be kept, but it will be removed later
+%%% by the jump optimizer.
+%%%
+%%% (3) In this code
+%%%
+%%% test is_eq_exact ALabel Src Dst
+%%% move Src Dst
+%%%
+%%% the move instruction can be removed.
+%%% Same thing for
+%%%
+%%% test is_nil ALabel Dst
+%%% move [] Dst
+%%%
+%%%
+%%% (4) In this code
+%%%
+%%% select_val {x,Reg}, ALabel [... Literal => L1...]
+%%% .
+%%% .
+%%% .
+%%% L1: move Literal {x,Reg}
+%%%
+%%% we can remove the move instruction.
+%%%
+%%% (5) In the following code
+%%%
+%%% bif '=:=' Fail Src1 Src2 {x,0}
+%%% jump L1
+%%% .
+%%% .
+%%% .
+%%% L1: select_val {x,0}, ALabel [... true => L2..., ...false => L3...]
+%%% .
+%%% .
+%%% .
+%%% L2: .... L3: ....
+%%%
+%%% the first two instructions can be replaced with
+%%%
+%%% test is_eq_exact L3 Src1 Src2
+%%% jump L2
+%%%
+%%% provided that {x,0} is killed at both L2 and L3.
+%%%
+
+-import(lists, [mapfoldl/3,reverse/1]).
+
+module({Mod,Exp,Attr,Fs0,_}, _Opts) ->
+ Fs1 = [split_blocks(F) || F <- Fs0],
+ {Fs2,Lc1} = beam_clean:clean_labels(Fs1),
+ {Fs,Lc} = mapfoldl(fun function/2, Lc1, Fs2),
+ %%{Fs,Lc} = {Fs2,Lc1},
+ {ok,{Mod,Exp,Attr,Fs,Lc}}.
+
+function({function,Name,Arity,CLabel,Is0}, Lc0) ->
+ try
+ Is1 = beam_jump:remove_unused_labels(Is0),
+
+ %% Initialize label information with the code
+ %% for the func_info label. Without it, a register
+ %% may seem to be live when it is not.
+ [{label,L},{func_info,_,_,_}=FI|_] = Is1,
+ D0 = beam_utils:empty_label_index(),
+ D = beam_utils:index_label(L, [FI], D0),
+
+ %% Optimize away dead code.
+ {Is2,Lc} = forward(Is1, Lc0),
+ Is3 = backward(Is2, D),
+ Is = move_move_into_block(Is3, []),
+ {{function,Name,Arity,CLabel,Is},Lc}
+ catch
+ Class:Error ->
+ Stack = erlang:get_stacktrace(),
+ io:fwrite("Function: ~w/~w\n", [Name,Arity]),
+ erlang:raise(Class, Error, Stack)
+ end.
+
+%% We must split the basic block when we encounter instructions with labels,
+%% such as catches and BIFs. All labels must be visible outside the blocks.
+%% Also remove empty blocks.
+
+split_blocks({function,Name,Arity,CLabel,Is0}) ->
+ Is = split_blocks(Is0, []),
+ {function,Name,Arity,CLabel,Is}.
+
+split_blocks([{block,[]}|Is], Acc) ->
+ split_blocks(Is, Acc);
+split_blocks([{block,Bl}|Is], Acc0) ->
+ Acc = split_block(Bl, [], Acc0),
+ split_blocks(Is, Acc);
+split_blocks([I|Is], Acc) ->
+ split_blocks(Is, [I|Acc]);
+split_blocks([], Acc) -> reverse(Acc).
+
+split_block([{set,[R],[_,_,_]=As,{bif,is_record,{f,Lbl}}}|Is], Bl, Acc) ->
+ %% is_record/3 must be translated by beam_clean; therefore,
+ %% it must be outside of any block.
+ split_block(Is, [], [{bif,is_record,{f,Lbl},As,R}|make_block(Bl, Acc)]);
+split_block([{set,[R],As,{bif,N,{f,Lbl}=Fail}}|Is], Bl, Acc) when Lbl =/= 0 ->
+ split_block(Is, [], [{bif,N,Fail,As,R}|make_block(Bl, Acc)]);
+split_block([{set,[R],As,{alloc,Live,{gc_bif,N,{f,Lbl}=Fail}}}|Is], Bl, Acc)
+ when Lbl =/= 0 ->
+ split_block(Is, [], [{gc_bif,N,Fail,Live,As,R}|make_block(Bl, Acc)]);
+split_block([{set,[R],[],{'catch',L}}|Is], Bl, Acc) ->
+ split_block(Is, [], [{'catch',R,L}|make_block(Bl, Acc)]);
+split_block([I|Is], Bl, Acc) ->
+ split_block(Is, [I|Bl], Acc);
+split_block([], Bl, Acc) -> make_block(Bl, Acc).
+
+make_block([], Acc) -> Acc;
+make_block([{set,[D],Ss,{bif,Op,Fail}}|Bl]=Bl0, Acc) ->
+ %% If the last instruction in the block is a comparison or boolean operator
+ %% (such as '=:='), move it out of the block to facilitate further
+ %% optimizations.
+ Arity = length(Ss),
+ case erl_internal:comp_op(Op, Arity) orelse
+ erl_internal:new_type_test(Op, Arity) orelse
+ erl_internal:bool_op(Op, Arity) of
+ false ->
+ [{block,reverse(Bl0)}|Acc];
+ true ->
+ I = {bif,Op,Fail,Ss,D},
+ case Bl =:= [] of
+ true -> [I|Acc];
+ false -> [I,{block,reverse(Bl)}|Acc]
+ end
+ end;
+make_block([{set,[Dst],[Src],move}|Bl], Acc) ->
+ %% Make optimization of {move,Src,Dst}, {jump,...} possible.
+ I = {move,Src,Dst},
+ case Bl =:= [] of
+ true -> [I|Acc];
+ false -> [I,{block,reverse(Bl)}|Acc]
+ end;
+make_block(Bl, Acc) -> [{block,reverse(Bl)}|Acc].
+
+%% 'move' instructions outside of blocks may thwart the jump optimizer.
+%% Move them back into the block.
+
+move_move_into_block([{block,Bl0},{move,S,D}|Is], Acc) ->
+ Bl = Bl0 ++ [{set,[D],[S],move}],
+ move_move_into_block([{block,Bl}|Is], Acc);
+move_move_into_block([{move,S,D}|Is], Acc) ->
+ Bl = [{set,[D],[S],move}],
+ move_move_into_block([{block,Bl}|Is], Acc);
+move_move_into_block([I|Is], Acc) ->
+ move_move_into_block(Is, [I|Acc]);
+move_move_into_block([], Acc) -> reverse(Acc).
+
+%%%
+%%% Scan instructions in execution order and remove dead code.
+%%%
+
+forward(Is, Lc) ->
+ forward(Is, gb_trees:empty(), Lc, []).
+
+forward([{block,[]}|Is], D, Lc, Acc) ->
+ %% Empty blocks can prevent optimizations.
+ forward(Is, D, Lc, Acc);
+forward([{select_val,Reg,_,{list,List}}=I|Is], D0, Lc, Acc) ->
+ D = update_value_dict(List, Reg, D0),
+ forward(Is, D, Lc, [I|Acc]);
+forward([{label,Lbl}=LblI,{block,[{set,[Dst],[Lit],move}|BlkIs]}=Blk|Is], D, Lc, Acc) ->
+ Block = case gb_trees:lookup({Lbl,Dst}, D) of
+ {value,Lit} ->
+ %% The move instruction seems to be redundant, but also make
+ %% sure that the instruction preceeding the label
+ %% cannot fall through to the move instruction.
+ case is_unreachable_after(Acc) of
+ false -> Blk; %Must keep move instruction.
+ true -> {block,BlkIs} %Safe to remove move instruction.
+ end;
+ _ -> Blk %Keep move instruction.
+ end,
+ forward([Block|Is], D, Lc, [LblI|Acc]);
+forward([{label,Lbl}=LblI|[{move,Lit,Dst}|Is1]=Is0], D, Lc, Acc) ->
+ Is = case gb_trees:lookup({Lbl,Dst}, D) of
+ {value,Lit} ->
+ %% The move instruction seems to be redundant, but also make
+ %% sure that the instruction preceeding the label
+ %% cannot fall through to the move instruction.
+ case is_unreachable_after(Acc) of
+ false -> Is0; %Must keep move instruction.
+ true -> Is1 %Safe to remove move instruction.
+ end;
+ _ -> Is0 %Keep move instruction.
+ end,
+ forward(Is, D, Lc, [LblI|Acc]);
+forward([{test,is_eq_exact,_,[Dst,Src]}=I,
+ {block,[{set,[Dst],[Src],move}|Bl]}|Is], D, Lc, Acc) ->
+ forward([I,{block,Bl}|Is], D, Lc, Acc);
+forward([{test,is_nil,_,[Dst]}=I,
+ {block,[{set,[Dst],[nil],move}|Bl]}|Is], D, Lc, Acc) ->
+ forward([I,{block,Bl}|Is], D, Lc, Acc);
+forward([{test,is_eq_exact,_,[Dst,Src]}=I,{move,Src,Dst}|Is], D, Lc, Acc) ->
+ forward([I|Is], D, Lc, Acc);
+forward([{test,is_nil,_,[Dst]}=I,{move,nil,Dst}|Is], D, Lc, Acc) ->
+ forward([I|Is], D, Lc, Acc);
+forward([{test,is_eq_exact,_,[_,{atom,_}]}=I|Is], D, Lc, [{label,_}|_]=Acc) ->
+ case Is of
+ [{label,_}|_] -> forward(Is, D, Lc, [I|Acc]);
+ _ -> forward(Is, D, Lc+1, [{label,Lc},I|Acc])
+ end;
+forward([{test,is_ne_exact,_,[_,{atom,_}]}=I|Is], D, Lc, [{label,_}|_]=Acc) ->
+ case Is of
+ [{label,_}|_] -> forward(Is, D, Lc, [I|Acc]);
+ _ -> forward(Is, D, Lc+1, [{label,Lc},I|Acc])
+ end;
+forward([I|Is], D, Lc, Acc) ->
+ forward(Is, D, Lc, [I|Acc]);
+forward([], _, Lc, Acc) -> {Acc,Lc}.
+
+update_value_dict([Lit,{f,Lbl}|T], Reg, D0) ->
+ Key = {Lbl,Reg},
+ D = case gb_trees:lookup(Key, D0) of
+ none -> gb_trees:insert(Key, Lit, D0); %New.
+ {value,Lit} -> D0; %Already correct.
+ {value,inconsistent} -> D0; %Inconsistent.
+ {value,_} -> gb_trees:update(Key, inconsistent, D0)
+ end,
+ update_value_dict(T, Reg, D);
+update_value_dict([], _, D) -> D.
+
+is_unreachable_after([I|_]) ->
+ beam_jump:is_unreachable_after(I).
+
+%%%
+%%% Scan instructions in reverse execution order and remove dead code.
+%%%
+
+backward(Is, D) ->
+ backward(Is, D, []).
+
+backward([{test,is_eq_exact,Fail,[Dst,{integer,Arity}]}=I|
+ [{bif,tuple_size,Fail,[Reg],Dst}|Is]=Is0], D, Acc) ->
+ %% Provided that Dst is killed following this sequence,
+ %% we can rewrite the instructions like this:
+ %%
+ %% bif tuple_size Fail Reg Dst ==> is_tuple Fail Reg
+ %% is_eq_exact Fail Dst Integer test_arity Fail Reg Integer
+ %%
+ %% (still two instructions, but they they will be combined to
+ %% one by the loader).
+ case beam_utils:is_killed(Dst, Acc, D) andalso (Arity bsr 32) =:= 0 of
+ false ->
+ %% Not safe because the register Dst is not killed
+ %% (probably cannot not happen in practice) or the arity
+ %% does not fit in 32 bits (the loader will fail to load
+ %% the module). We must move the first instruction to the
+ %% accumulator to avoid an infinite loop.
+ backward(Is0, D, [I|Acc]);
+ true ->
+ %% Safe.
+ backward([{test,test_arity,Fail,[Reg,Arity]},
+ {test,is_tuple,Fail,[Reg]}|Is], D, Acc)
+ end;
+backward([{label,Lbl}=L|Is], D, Acc) ->
+ backward(Is, beam_utils:index_label(Lbl, Acc, D), [L|Acc]);
+backward([{select_val,Reg,{f,Fail0},{list,List0}}|Is], D, Acc) ->
+ List = shortcut_select_list(List0, Reg, D, []),
+ Fail1 = shortcut_label(Fail0, D),
+ Fail = shortcut_bs_test(Fail1, Is, D),
+ Sel = {select_val,Reg,{f,Fail},{list,List}},
+ backward(Is, D, [Sel|Acc]);
+backward([{jump,{f,To0}},{move,Src,Reg}=Move0|Is], D, Acc) ->
+ {To,Move} = case Src of
+ {atom,Val0} ->
+ To1 = shortcut_select_label(To0, Reg, Val0, D),
+ {To2,Val} = shortcut_boolean_label(To1, Reg, Val0, D),
+ {To2,{move,{atom,Val},Reg}};
+ _ ->
+ {shortcut_label(To0, D),Move0}
+ end,
+ Jump = {jump,{f,To}},
+ case beam_utils:is_killed_at(Reg, To, D) of
+ false -> backward([Move|Is], D, [Jump|Acc]);
+ true -> backward([Jump|Is], D, Acc)
+ end;
+backward([{jump,{f,To}}=J|[{bif,Op,_,Ops,Reg}|Is]=Is0], D, Acc) ->
+ try replace_comp_op(To, Reg, Op, Ops, D) of
+ I -> backward(Is, D, I++Acc)
+ catch
+ throw:not_possible -> backward(Is0, D, [J|Acc])
+ end;
+backward([{test,bs_start_match2,{f,To0},Live,[Src|_]=Info,Dst}|Is], D, Acc) ->
+ To = shortcut_bs_start_match(To0, Src, D),
+ I = {test,bs_start_match2,{f,To},Live,Info,Dst},
+ backward(Is, D, [I|Acc]);
+backward([{test,is_eq_exact=Op,{f,To0},[Reg,{atom,Val}]=Ops}|Is], D, Acc) ->
+ To1 = shortcut_bs_test(To0, Is, D),
+ To = shortcut_fail_label(To1, Reg, Val, D),
+ I = {test,Op,{f,To},Ops},
+ backward(Is, D, [I|Acc]);
+backward([{test,Op,{f,To0},Ops0}|Is], D, Acc) ->
+ To1 = shortcut_bs_test(To0, Is, D),
+ To2 = shortcut_label(To1, D),
+ %% Try to shortcut a repeated test:
+ %%
+ %% test Op {f,Fail1} Operands test Op {f,Fail2} Operands
+ %% . . . ==> ...
+ %% Fail1: test Op {f,Fail2} Operands Fail1: test Op {f,Fail2} Operands
+ %%
+ To = case beam_utils:code_at(To2, D) of
+ [{test,Op,{f,To3},Ops}|_] ->
+ case equal_ops(Ops0, Ops) of
+ true -> To3;
+ false -> To2
+ end;
+ _Code ->
+ To2
+ end,
+ I = {test,Op,{f,To},Ops0},
+ backward(Is, D, [I|Acc]);
+backward([{test,Op,{f,To0},Live,Ops0,Dst}|Is], D, Acc) ->
+ To1 = shortcut_bs_test(To0, Is, D),
+ To2 = shortcut_label(To1, D),
+ %% Try to shortcut a repeated test:
+ %%
+ %% test Op {f,Fail1} _ Ops _ test Op {f,Fail2} _ Ops _
+ %% . . . ==> ...
+ %% Fail1: test Op {f,Fail2} _ Ops _ Fail1: test Op {f,Fail2} _ Ops _
+ %%
+ To = case beam_utils:code_at(To2, D) of
+ [{test,Op,{f,To3},_,Ops,_}|_] ->
+ case equal_ops(Ops0, Ops) of
+ true -> To3;
+ false -> To2
+ end;
+ _Code ->
+ To2
+ end,
+ I = {test,Op,{f,To},Live,Ops0,Dst},
+ backward(Is, D, [I|Acc]);
+backward([{kill,_}=I|Is], D, [Exit|_]=Acc) ->
+ case beam_jump:is_exit_instruction(Exit) of
+ false -> backward(Is, D, [I|Acc]);
+ true -> backward(Is, D, Acc)
+ end;
+backward([I|Is], D, Acc) ->
+ backward(Is, D, [I|Acc]);
+backward([], _D, Acc) -> Acc.
+
+equal_ops([{field_flags,FlA0}|T0], [{field_flags,FlB0}|T1]) ->
+ FlA = lists:keydelete(anno, 1, FlA0),
+ FlB = lists:keydelete(anno, 1, FlB0),
+ FlA =:= FlB andalso equal_ops(T0, T1);
+equal_ops([Op|T0], [Op|T1]) ->
+ equal_ops(T0, T1);
+equal_ops([], []) -> true;
+equal_ops(_, _) -> false.
+
+shortcut_select_list([{_,Val}=Lit,{f,To0}|T], Reg, D, Acc) ->
+ To = shortcut_select_label(To0, Reg, Val, D),
+ shortcut_select_list(T, Reg, D, [{f,To},Lit|Acc]);
+shortcut_select_list([], _, _, Acc) -> reverse(Acc).
+
+shortcut_label(To0, D) ->
+ case beam_utils:code_at(To0, D) of
+ [{jump,{f,To}}|_] -> shortcut_label(To, D);
+ _ -> To0
+ end.
+
+shortcut_select_label(To0, Reg, Val, D) ->
+ case beam_utils:code_at(To0, D) of
+ [{jump,{f,To}}|_] ->
+ shortcut_select_label(To, Reg, Val, D);
+ [{test,is_atom,_,[Reg]},{select_val,Reg,{f,Fail},{list,Map}}|_] ->
+ To = find_select_val(Map, Val, Fail),
+ shortcut_select_label(To, Reg, Val, D);
+ [{test,is_eq_exact,{f,_},[Reg,{atom,Val}]},{label,To}|_] when is_atom(Val) ->
+ shortcut_select_label(To, Reg, Val, D);
+ [{test,is_eq_exact,{f,_},[Reg,{atom,Val}]},{jump,{f,To}}|_] when is_atom(Val) ->
+ shortcut_select_label(To, Reg, Val, D);
+ [{test,is_eq_exact,{f,To},[Reg,{atom,AnotherVal}]}|_]
+ when is_atom(Val), Val =/= AnotherVal ->
+ shortcut_select_label(To, Reg, Val, D);
+ [{test,is_ne_exact,{f,To},[Reg,{atom,Val}]}|_] when is_atom(Val) ->
+ shortcut_select_label(To, Reg, Val, D);
+ [{test,is_ne_exact,{f,_},[Reg,{atom,_}]},{label,To}|_] when is_atom(Val) ->
+ shortcut_select_label(To, Reg, Val, D);
+ [{test,is_tuple,{f,To},[Reg]}|_] when is_atom(Val) ->
+ shortcut_select_label(To, Reg, Val, D);
+ _ ->
+ To0
+ end.
+
+shortcut_fail_label(To0, Reg, Val, D) ->
+ case beam_utils:code_at(To0, D) of
+ [{jump,{f,To}}|_] ->
+ shortcut_fail_label(To, Reg, Val, D);
+ [{test,is_eq_exact,{f,To},[Reg,{atom,Val}]}|_] when is_atom(Val) ->
+ shortcut_fail_label(To, Reg, Val, D);
+ _ ->
+ To0
+ end.
+
+shortcut_boolean_label(To0, Reg, Bool0, D) when is_boolean(Bool0) ->
+ case beam_utils:code_at(To0, D) of
+ [{bif,'not',_,[Reg],Reg},{jump,{f,To}}|_] ->
+ Bool = not Bool0,
+ {shortcut_select_label(To, Reg, Bool, D),Bool};
+ _ ->
+ {To0,Bool0}
+ end;
+shortcut_boolean_label(To, _, Bool, _) -> {To,Bool}.
+
+find_select_val([{_,Val},{f,To}|_], Val, _) -> To;
+find_select_val([{_,_}, {f,_}|T], Val, Fail) ->
+ find_select_val(T, Val, Fail);
+find_select_val([], _, Fail) -> Fail.
+
+replace_comp_op(To, Reg, Op, Ops, D) ->
+ False = comp_op_find_shortcut(To, Reg, false, D),
+ True = comp_op_find_shortcut(To, Reg, true, D),
+ [bif_to_test(Op, Ops, False),{jump,{f,True}}].
+
+comp_op_find_shortcut(To0, Reg, Val, D) ->
+ case shortcut_select_label(To0, Reg, Val, D) of
+ To0 ->
+ not_possible();
+ To ->
+ case beam_utils:is_killed_at(Reg, To, D) of
+ false -> not_possible();
+ true -> To
+ end
+ end.
+
+bif_to_test(Name, Args, Fail) ->
+ try
+ beam_utils:bif_to_test(Name, Args, {f,Fail})
+ catch
+ error:_ -> not_possible()
+ end.
+
+not_possible() -> throw(not_possible).
+
+
+%% shortcut_bs_test(TargetLabel, [Instruction], D) -> TargetLabel'
+%% Try to shortcut the failure label for a bit syntax matching.
+%% We know that the binary contains at least Bits bits after
+%% the latest save point.
+
+shortcut_bs_test(To, Is, D) ->
+ shortcut_bs_test_1(beam_utils:code_at(To, D), Is, To, D).
+
+shortcut_bs_test_1([{bs_restore2,Reg,SavePoint}|Is], PrevIs, To, D) ->
+ shortcut_bs_test_2(Is, {Reg,SavePoint}, PrevIs, To, D);
+shortcut_bs_test_1([_|_], _, To, _) -> To.
+
+shortcut_bs_test_2([{label,_}|Is], Save, PrevIs, To, D) ->
+ shortcut_bs_test_2(Is, Save, PrevIs, To, D);
+shortcut_bs_test_2([{test,bs_test_tail2,{f,To},[_,TailBits]}|_],
+ {Reg,_Point} = RP, PrevIs, To0, D) ->
+ case count_bits_matched(PrevIs, RP, 0) of
+ Bits when Bits > TailBits ->
+ %% This instruction will fail. We know because a restore has been
+ %% done from the previous point SavePoint in the binary, and we also know
+ %% that the binary contains at least Bits bits from SavePoint.
+ %%
+ %% Since we will skip a bs_restore2 if we shortcut to label To,
+ %% we must now make sure that code at To does not depend on the position
+ %% in the context in any way.
+ case shortcut_bs_pos_used(To, Reg, D) of
+ false -> To;
+ true -> To0
+ end;
+ _Bits ->
+ To0
+ end;
+shortcut_bs_test_2([_|_], _, _, To, _) -> To.
+
+count_bits_matched([{test,_,_,_,[_,Sz,U,{field_flags,_}],_}|Is], SavePoint, Bits) ->
+ case Sz of
+ {integer,N} -> count_bits_matched(Is, SavePoint, Bits+N*U);
+ _ -> count_bits_matched(Is, SavePoint, Bits)
+ end;
+count_bits_matched([{test,_,_,_}|Is], SavePoint, Bits) ->
+ count_bits_matched(Is, SavePoint, Bits);
+count_bits_matched([{bs_save2,Reg,SavePoint}|_], {Reg,SavePoint}, Bits) ->
+ %% The save point we are looking for - we are done.
+ Bits;
+count_bits_matched([{bs_save2,_,_}|Is], SavePoint, Bits) ->
+ %% Another save point - keep counting.
+ count_bits_matched(Is, SavePoint, Bits);
+count_bits_matched([_|_], _, Bits) -> Bits.
+
+shortcut_bs_pos_used(To, Reg, D) ->
+ shortcut_bs_pos_used_1(beam_utils:code_at(To, D), Reg, D).
+
+shortcut_bs_pos_used_1([{bs_restore2,Reg,_}|_], Reg, _) ->
+ false;
+shortcut_bs_pos_used_1([{bs_context_to_binary,Reg}|_], Reg, _) ->
+ false;
+shortcut_bs_pos_used_1(Is, Reg, D) ->
+ not beam_utils:is_killed(Reg, Is, D).
+
+%% shortcut_bs_start_match(TargetLabel, Reg) -> TargetLabel
+%% A failing bs_start_match2 instruction means that the source
+%% cannot be a binary, so there is no need to jump bs_context_to_binary/1
+%% or another bs_start_match2 instruction.
+
+shortcut_bs_start_match(To, Reg, D) ->
+ shortcut_bs_start_match_1(beam_utils:code_at(To, D), Reg, To).
+
+shortcut_bs_start_match_1([{bs_context_to_binary,Reg}|Is], Reg, To) ->
+ shortcut_bs_start_match_2(Is, Reg, To);
+shortcut_bs_start_match_1(_, _, To) -> To.
+
+shortcut_bs_start_match_2([{jump,{f,To}}|_], _, _) ->
+ To;
+shortcut_bs_start_match_2([{test,bs_start_match2,{f,To},_,[Reg|_],_}|_], Reg, _) ->
+ To;
+shortcut_bs_start_match_2(_Is, _Reg, To) ->
+ To.
diff --git a/lib/compiler/src/beam_dict.erl b/lib/compiler/src/beam_dict.erl
new file mode 100644
index 0000000000..4ffe8bc606
--- /dev/null
+++ b/lib/compiler/src/beam_dict.erl
@@ -0,0 +1,231 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1998-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%
+%%
+%% Purpose: Maintain atom, import, export, and other tables for assembler.
+
+-module(beam_dict).
+
+-export([new/0,opcode/2,highest_opcode/1,
+ atom/2,local/4,export/4,import/4,
+ string/2,lambda/5,literal/2,
+ atom_table/1,local_table/1,export_table/1,import_table/1,
+ string_table/1,lambda_table/1,literal_table/1]).
+
+-type label() :: non_neg_integer().
+
+-record(asm,
+ {atoms = gb_trees:empty() :: gb_tree(), %{Atom,Index}
+ exports = [] :: [{label(), arity(), label()}],
+ locals = [] :: [{label(), arity(), label()}],
+ imports = gb_trees:empty() :: gb_tree(), %{{M,F,A},Index}
+ strings = [] :: [string()], %String pool
+ lambdas = [], %[{...}]
+ literals = dict:new() :: dict(), %Format: {Literal,Number}
+ next_atom = 1 :: pos_integer(),
+ next_import = 0 :: non_neg_integer(),
+ string_offset = 0 :: non_neg_integer(),
+ next_literal = 0 :: non_neg_integer(),
+ highest_opcode = 0 :: non_neg_integer()
+ }).
+-type bdict() :: #asm{}.
+
+%%-----------------------------------------------------------------------------
+
+-spec new() -> bdict().
+
+new() ->
+ #asm{}.
+
+%% Remember the highest opcode.
+-spec opcode(non_neg_integer(), bdict()) -> bdict().
+
+opcode(Op, Dict) when Dict#asm.highest_opcode > Op -> Dict;
+opcode(Op, Dict) -> Dict#asm{highest_opcode=Op}.
+
+%% Returns the highest opcode encountered.
+-spec highest_opcode(bdict()) -> non_neg_integer().
+
+highest_opcode(#asm{highest_opcode=Op}) -> Op.
+
+%% Returns the index for an atom (adding it to the atom table if necessary).
+%% atom(Atom, Dict) -> {Index,Dict'}
+-spec atom(atom(), bdict()) -> {pos_integer(), bdict()}.
+
+atom(Atom, #asm{atoms=Atoms0,next_atom=NextIndex}=Dict) when is_atom(Atom) ->
+ case gb_trees:lookup(Atom, Atoms0) of
+ {value,Index} ->
+ {Index,Dict};
+ none ->
+ Atoms = gb_trees:insert(Atom, NextIndex, Atoms0),
+ {NextIndex,Dict#asm{atoms=Atoms,next_atom=NextIndex+1}}
+ end.
+
+%% Remembers an exported function.
+%% export(Func, Arity, Label, Dict) -> Dict'
+-spec export(atom(), arity(), label(), bdict()) -> bdict().
+
+export(Func, Arity, Label, Dict0) when is_atom(Func),
+ is_integer(Arity),
+ is_integer(Label) ->
+ {Index, Dict1} = atom(Func, Dict0),
+ Dict1#asm{exports = [{Index, Arity, Label}| Dict1#asm.exports]}.
+
+%% Remembers a local function.
+%% local(Func, Arity, Label, Dict) -> Dict'
+-spec local(atom(), arity(), label(), bdict()) -> bdict().
+
+local(Func, Arity, Label, Dict0) when is_atom(Func),
+ is_integer(Arity),
+ is_integer(Label) ->
+ {Index,Dict1} = atom(Func, Dict0),
+ Dict1#asm{locals=[{Index,Arity,Label}|Dict1#asm.locals]}.
+
+%% Returns the index for an import entry (adding it to the import table if necessary).
+%% import(Mod, Func, Arity, Dict) -> {Index,Dict'}
+-spec import(atom(), atom(), arity(), bdict()) -> {non_neg_integer(), bdict()}.
+
+import(Mod0, Name0, Arity, #asm{imports=Imp0,next_import=NextIndex}=D0)
+ when is_atom(Mod0), is_atom(Name0), is_integer(Arity) ->
+ {Mod,D1} = atom(Mod0, D0),
+ {Name,D2} = atom(Name0, D1),
+ MFA = {Mod,Name,Arity},
+ case gb_trees:lookup(MFA, Imp0) of
+ {value,Index} ->
+ {Index,D2};
+ none ->
+ Imp = gb_trees:insert(MFA, NextIndex, Imp0),
+ {NextIndex,D2#asm{imports=Imp,next_import=NextIndex+1}}
+ end.
+
+%% Returns the index for a string in the string table (adding the string to the
+%% table if necessary).
+%% string(String, Dict) -> {Offset, Dict'}
+-spec string(string(), bdict()) -> {non_neg_integer(), bdict()}.
+
+string(Str, Dict) when is_list(Str) ->
+ #asm{strings=Strings,string_offset=NextOffset} = Dict,
+ case old_string(Str, Strings) of
+ none ->
+ NewDict = Dict#asm{strings=Strings++Str,
+ string_offset=NextOffset+length(Str)},
+ {NextOffset,NewDict};
+ Offset when is_integer(Offset) ->
+ {NextOffset-Offset,Dict}
+ end.
+
+%% Returns the index for a funentry (adding it to the table if necessary).
+%% lambda(Lbl, Index, Uniq, NumFree, Dict) -> {Index,Dict'}
+-spec lambda(label(), non_neg_integer(), integer(), non_neg_integer(), bdict()) ->
+ {non_neg_integer(), bdict()}.
+
+lambda(Lbl, Index, OldUniq, NumFree, #asm{lambdas=Lambdas0}=Dict) ->
+ OldIndex = length(Lambdas0),
+ Lambdas = [{Lbl,{OldIndex,Lbl,Index,NumFree,OldUniq}}|Lambdas0],
+ {OldIndex,Dict#asm{lambdas=Lambdas}}.
+
+%% Returns the index for a literal (adding it to the atom table if necessary).
+%% literal(Literal, Dict) -> {Index,Dict'}
+-spec literal(term(), bdict()) -> {non_neg_integer(), bdict()}.
+
+literal(Lit, #asm{literals=Tab0,next_literal=NextIndex}=Dict) ->
+ case dict:find(Lit, Tab0) of
+ {ok,Index} ->
+ {Index,Dict};
+ error ->
+ Tab = dict:store(Lit, NextIndex, Tab0),
+ {NextIndex,Dict#asm{literals=Tab,next_literal=NextIndex+1}}
+ end.
+
+%% Returns the atom table.
+%% atom_table(Dict) -> {LastIndex,[Length,AtomString...]}
+-spec atom_table(bdict()) -> {non_neg_integer(), [[non_neg_integer(),...]]}.
+
+atom_table(#asm{atoms=Atoms,next_atom=NumAtoms}) ->
+ Sorted = lists:keysort(2, gb_trees:to_list(Atoms)),
+ Fun = fun({A,_}) ->
+ L = atom_to_list(A),
+ [length(L)|L]
+ end,
+ AtomTab = lists:map(Fun, Sorted),
+ {NumAtoms-1,AtomTab}.
+
+%% Returns the table of local functions.
+%% local_table(Dict) -> {NumLocals, [{Function, Arity, Label}...]}
+-spec local_table(bdict()) -> {non_neg_integer(), [{label(),arity(),label()}]}.
+
+local_table(#asm{locals = Locals}) ->
+ {length(Locals),Locals}.
+
+%% Returns the export table.
+%% export_table(Dict) -> {NumExports, [{Function, Arity, Label}...]}
+-spec export_table(bdict()) -> {non_neg_integer(), [{label(),arity(),label()}]}.
+
+export_table(#asm{exports = Exports}) ->
+ {length(Exports),Exports}.
+
+%% Returns the import table.
+%% import_table(Dict) -> {NumImports, [{Module, Function, Arity}...]}
+-spec import_table(bdict()) -> {non_neg_integer(), [{label(),label(),arity()}]}.
+
+import_table(#asm{imports=Imp,next_import=NumImports}) ->
+ Sorted = lists:keysort(2, gb_trees:to_list(Imp)),
+ ImpTab = [MFA || {MFA,_} <- Sorted],
+ {NumImports,ImpTab}.
+
+-spec string_table(bdict()) -> {non_neg_integer(), [string()]}.
+
+string_table(#asm{strings=Strings,string_offset=Size}) ->
+ {Size,Strings}.
+
+-spec lambda_table(bdict()) -> {non_neg_integer(), [<<_:192>>]}.
+
+lambda_table(#asm{locals=Loc0,lambdas=Lambdas0}) ->
+ Lambdas1 = sofs:relation(Lambdas0),
+ Loc = sofs:relation([{Lbl,{F,A}} || {F,A,Lbl} <- Loc0]),
+ Lambdas2 = sofs:relative_product1(Lambdas1, Loc),
+ Lambdas = [<<F:32,A:32,Lbl:32,Index:32,NumFree:32,OldUniq:32>> ||
+ {{_,Lbl,Index,NumFree,OldUniq},{F,A}} <- sofs:to_external(Lambdas2)],
+ {length(Lambdas),Lambdas}.
+
+%% Returns the literal table.
+%% literal_table(Dict) -> {NumLiterals, [<<TermSize>>,TermInExternalFormat]}
+-spec literal_table(bdict()) -> {non_neg_integer(), [[binary(),...]]}.
+
+literal_table(#asm{literals=Tab,next_literal=NumLiterals}) ->
+ L0 = dict:fold(fun(Lit, Num, Acc) ->
+ [{Num,my_term_to_binary(Lit)}|Acc]
+ end, [], Tab),
+ L1 = lists:sort(L0),
+ L = [[<<(byte_size(Term)):32>>,Term] || {_,Term} <- L1],
+ {NumLiterals,L}.
+
+my_term_to_binary(Term) ->
+ term_to_binary(Term, [{minor_version,1}]).
+
+%% Search for string Str in the string pool Pool.
+%% old_string(Str, Pool) -> none | Index
+-spec old_string(string(), [string()]) -> 'none' | pos_integer().
+
+old_string([C|Str]=Str0, [C|Pool]) ->
+ case lists:prefix(Str, Pool) of
+ true -> length(Pool)+1;
+ false -> old_string(Str0, Pool)
+ end;
+old_string([_|_]=Str, [_|Pool]) ->
+ old_string(Str, Pool);
+old_string([_|_], []) -> none.
diff --git a/lib/compiler/src/beam_disasm.erl b/lib/compiler/src/beam_disasm.erl
new file mode 100644
index 0000000000..c956f2f000
--- /dev/null
+++ b/lib/compiler/src/beam_disasm.erl
@@ -0,0 +1,1148 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2000-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%
+%%=======================================================================
+%% Notes:
+%% 1. It does NOT work for .beam files of previous BEAM versions.
+%% 2. If handling of new BEAM instructions is needed, this should be
+%% inserted at the end of function resolve_inst().
+%%=======================================================================
+
+-module(beam_disasm).
+
+-export([file/1]). %% the main function
+-export([function__code/1, format_error/1]).
+-ifdef(DEBUG_DISASM).
+-export([dfs/1, df/1, files/1, pp/1, pp/2]).
+-endif.
+
+-author("Kostis Sagonas").
+
+-include("beam_opcodes.hrl").
+-include("beam_disasm.hrl").
+
+%%-----------------------------------------------------------------------
+
+-type literals() :: 'none' | gb_tree().
+-type symbolic_tag() :: 'a' | 'f' | 'h' | 'i' | 'u' | 'x' | 'y' | 'z'.
+-type disasm_tag() :: symbolic_tag() | 'fr' | 'atom' | 'float' | 'literal'.
+-type disasm_term() :: 'nil' | {disasm_tag(), _}.
+
+%%-----------------------------------------------------------------------
+
+-define(NO_DEBUG(Str,Xs), ok).
+-define(DEBUG(Str,Xs), io:format(Str,Xs)).
+-define(exit(Reason), exit({?MODULE,?LINE,Reason})).
+
+%%-----------------------------------------------------------------------
+%% Utility functions to get/set their fields. (Uncomment and export
+%% them when/if they get used in other files.)
+%%-----------------------------------------------------------------------
+
+%% -spec function__name(#function{}) -> atom().
+%% function__name(#function{name = N}) -> N.
+%% -spec function__arity(#function{}) -> arity().
+%% function__arity(#function{arity = A}) -> A.
+%% function__entry(#function{entry = E}) -> E.
+
+-spec function__code(#function{}) -> [beam_instr()].
+function__code(#function{code = Code}) -> Code.
+
+-spec function__code_update(#function{}, [beam_instr()]) -> #function{}.
+function__code_update(Function, NewCode) ->
+ Function#function{code = NewCode}.
+
+%%-----------------------------------------------------------------------
+%% Error information
+
+-spec format_error({'internal',term()} | {'error',atom(),term()}) -> string().
+
+format_error({internal,Error}) ->
+ io_lib:format("~p: disassembly failed with reason ~P.",
+ [?MODULE, Error, 25]);
+format_error({error,Module,Error}) ->
+ lists:flatten(Module:format_error(Error)).
+
+%%-----------------------------------------------------------------------
+%% User comfort functions to directly disassemble to file or to
+%% stream, pretty-printed, and to just pretty-print, also commented.
+%%-----------------------------------------------------------------------
+
+-ifdef(DEBUG_DISASM).
+
+dfs(Files) when is_list(Files) ->
+ lists:foreach(fun df/1, Files).
+
+df(Module) when is_atom(Module) ->
+ case code:which(Module) of
+ File when is_list(File) ->
+ df(File);
+ Reason when is_atom(Reason) ->
+ {error,?MODULE,Reason}
+ end;
+df(File) when is_list(File) ->
+ file(File, filename:rootname(File, ".beam")++".dis").
+
+files(Files) when is_list(Files) ->
+ lists:foreach(fun (File) -> file(File, group_leader()) end, Files).
+
+file(File, Dest) ->
+ case file(File) of
+ #beam_file{code = DisasmCode} ->
+ pp(Dest, [{file,File}, {code,DisasmCode}]);
+ Error -> Error
+ end.
+
+-spec pp([_]) -> 'ok' | {'error', atom()}.
+
+pp(Disasm) ->
+ pp(group_leader(), Disasm).
+
+-spec pp(pid() | file:filename(), [_]) -> 'ok' | {'error', atom()}.
+
+pp(Stream, Disasm) when is_pid(Stream), is_list(Disasm) ->
+ NL = io_lib:nl(),
+ lists:foreach(
+ fun ({code,Code}) ->
+ lists:foreach(
+ fun (#function{name=F,arity=A,entry=E,code=C}) ->
+ io:format(Stream, "~p.~n", [{function,F,A,E}]),
+ lists:foreach(
+ fun (I) ->
+ io:put_chars(Stream, [pp_instr(I)|NL])
+ end, C),
+ io:nl(Stream)
+ end, Code);
+ (Item) ->
+ io:format(Stream, "~p.~n~n", [Item])
+ end, Disasm),
+ ok;
+pp(File, Disasm) when is_list(Disasm) ->
+ case file:open(File, [write]) of
+ {ok,F} ->
+ Result = pp(F, Disasm),
+ ok = file:close(F),
+ Result;
+ {error,_Reason} = Error -> Error
+ end.
+
+pp_instr({comment,I,Comment}) ->
+ [pp_instr(I)|" % "++Comment];
+pp_instr({comment,Comment}) ->
+ ["%% "++Comment];
+pp_instr({label,_}=I) ->
+ io_lib:format(" ~p.", [I]);
+pp_instr(I) ->
+ io_lib:format(" ~p.", [I]).
+
+-endif.
+
+%%-----------------------------------------------------------------------
+%% The main exported function
+%% File is either a file name or a binary containing the code.
+%% Call `format_error({error, Module, Reason})' for an error string.
+%%-----------------------------------------------------------------------
+
+-spec file(file:filename() | binary()) -> #beam_file{} | {'error',atom(),_}.
+
+file(File) ->
+ try process_chunks(File)
+ catch error:Reason ->
+ {error,?MODULE,{internal,{Reason,erlang:get_stacktrace()}}}
+ end.
+
+%%-----------------------------------------------------------------------
+%% Interface might need to be revised -- do not depend on it.
+%%-----------------------------------------------------------------------
+
+process_chunks(F) ->
+ case beam_lib:chunks(F, [atoms,"Code","StrT",
+ indexed_imports,labeled_exports]) of
+ {ok,{Module,
+ [{atoms,AtomsList},{"Code",CodeBin},{"StrT",StrBin},
+ {indexed_imports,ImportsList},{labeled_exports,Exports}]}} ->
+ Atoms = mk_atoms(AtomsList),
+ LambdaBin = optional_chunk(F, "FunT"),
+ Lambdas = beam_disasm_lambdas(LambdaBin, Atoms),
+ LiteralBin = optional_chunk(F, "LitT"),
+ Literals = beam_disasm_literals(LiteralBin),
+ Code = beam_disasm_code(CodeBin, Atoms, mk_imports(ImportsList),
+ StrBin, Lambdas, Literals, Module),
+ Attributes = optional_chunk(F, attributes),
+ CompInfo =
+ case optional_chunk(F, "CInf") of
+ none -> none;
+ CompInfoBin when is_binary(CompInfoBin) ->
+ binary_to_term(CompInfoBin)
+ end,
+ #beam_file{module = Module,
+ labeled_exports = Exports,
+ attributes = Attributes,
+ compile_info = CompInfo,
+ code = Code};
+ Error -> Error
+ end.
+
+%%-----------------------------------------------------------------------
+%% Retrieve an optional chunk or none if the chunk doesn't exist.
+%%-----------------------------------------------------------------------
+
+optional_chunk(F, ChunkTag) ->
+ case beam_lib:chunks(F, [ChunkTag]) of
+ {ok,{_Module,[{ChunkTag,Chunk}]}} -> Chunk;
+ {error,beam_lib,{missing_chunk,_,ChunkTag}} -> none
+ end.
+
+%%-----------------------------------------------------------------------
+%% Disassembles the lambda (fun) table of a BEAM file.
+%%-----------------------------------------------------------------------
+
+-type l_info() :: {non_neg_integer(), {_,_,_,_,_,_}}.
+-spec beam_disasm_lambdas('none' | binary(), gb_tree()) -> 'none' | [l_info()].
+
+beam_disasm_lambdas(none, _) -> none;
+beam_disasm_lambdas(<<_:32,Tab/binary>>, Atoms) ->
+ disasm_lambdas(Tab, Atoms, 0).
+
+disasm_lambdas(<<F:32,A:32,Lbl:32,Index:32,NumFree:32,OldUniq:32,More/binary>>,
+ Atoms, OldIndex) ->
+ Info = {lookup(F, Atoms),A,Lbl,Index,NumFree,OldUniq},
+ [{OldIndex,Info}|disasm_lambdas(More, Atoms, OldIndex+1)];
+disasm_lambdas(<<>>, _, _) -> [].
+
+%%-----------------------------------------------------------------------
+%% Disassembles the literal table (constant pool) of a BEAM file.
+%%-----------------------------------------------------------------------
+
+-spec beam_disasm_literals('none' | binary()) -> literals().
+
+beam_disasm_literals(none) -> none;
+beam_disasm_literals(<<_:32,Compressed/binary>>) ->
+ <<_:32,Tab/binary>> = zlib:uncompress(Compressed),
+ gb_trees:from_orddict(disasm_literals(Tab, 0)).
+
+disasm_literals(<<Sz:32,Ext:Sz/binary,T/binary>>, Index) ->
+ [{Index,binary_to_term(Ext)}|disasm_literals(T, Index+1)];
+disasm_literals(<<>>, _) -> [].
+
+%%-----------------------------------------------------------------------
+%% Disassembles the code chunk of a BEAM file:
+%% - The code is first disassembled into a long list of instructions.
+%% - This list is then split into functions and all names are resolved.
+%%-----------------------------------------------------------------------
+
+beam_disasm_code(<<_SS:32, % Sub-Size (length of information before code)
+ _IS:32, % Instruction Set Identifier (always 0)
+ _OM:32, % Opcode Max
+ _L:32,_F:32,
+ CodeBin/binary>>, Atoms, Imports,
+ Str, Lambdas, Literals, M) ->
+ Code = binary_to_list(CodeBin),
+ try disasm_code(Code, Atoms, Literals) of
+ DisasmCode ->
+ Functions = get_function_chunks(DisasmCode),
+ Labels = mk_labels(local_labels(Functions)),
+ [function__code_update(Function,
+ resolve_names(Is, Imports, Str,
+ Labels, Lambdas, Literals, M))
+ || Function = #function{code=Is} <- Functions]
+ catch
+ error:Rsn ->
+ ?NO_DEBUG('code disassembling failed: ~p~n', [Rsn]),
+ ?exit(Rsn)
+ end.
+
+%%-----------------------------------------------------------------------
+
+disasm_code([B|Bs], Atoms, Literals) ->
+ {Instr,RestBs} = disasm_instr(B, Bs, Atoms, Literals),
+ [Instr|disasm_code(RestBs, Atoms, Literals)];
+disasm_code([], _, _) -> [].
+
+%%-----------------------------------------------------------------------
+%% Splits the code stream into chunks representing the code of functions.
+%%
+%% NOTE: code actually looks like
+%% label L1: ... label Ln:
+%% func_info ...
+%% label entry:
+%% ...
+%% <on failure, use label Li to show where things died>
+%% ...
+%% So the labels before each func_info should be included as well.
+%% Ideally, only one such label is needed, but the BEAM compiler
+%% before R8 didn't care to remove the redundant ones.
+%%-----------------------------------------------------------------------
+
+get_function_chunks([]) ->
+ ?exit(empty_code_segment);
+get_function_chunks(Code) ->
+ get_funs(labels_r(Code, [])).
+
+labels_r([], R) -> {R, []};
+labels_r([{label,_}=I|Is], R) ->
+ labels_r(Is, [I|R]);
+labels_r(Is, R) -> {R, Is}.
+
+get_funs({[],[]}) -> [];
+get_funs({_,[]}) ->
+ ?exit(no_func_info_in_code_segment);
+get_funs({LsR0,[{func_info,[{atom,M}=AtomM,{atom,F}=AtomF,ArityArg]}|Code0]})
+ when is_atom(M), is_atom(F) ->
+ Arity = resolve_arg_unsigned(ArityArg),
+ {LsR,Code,RestCode} = get_fun(Code0, []),
+ Entry = case Code of
+ [{label,[{u,E}]}|_] -> E;
+ _ -> undefined
+ end,
+ [#function{name=F,
+ arity=Arity,
+ entry=Entry,
+ code=lists:reverse(LsR0, [{func_info,AtomM,AtomF,Arity}|Code])}
+ |get_funs({LsR,RestCode})].
+
+get_fun([{func_info,_}|_]=Is, R0) ->
+ {LsR,R} = labels_r(R0, []),
+ {LsR,lists:reverse(R),Is};
+get_fun([{int_code_end,[]}], R) ->
+ {[],lists:reverse(R),[]};
+get_fun([I|Is], R) ->
+ get_fun(Is, [I|R]);
+get_fun([], R) ->
+ ?DEBUG('warning: code segment did not end with int_code_end~n',[]),
+ {[],lists:reverse(R),[]}.
+
+%%-----------------------------------------------------------------------
+%% Collects local labels -- I am not sure this is 100% what is needed.
+%%-----------------------------------------------------------------------
+
+local_labels(Funs) ->
+ lists:sort(lists:foldl(fun (F, R) ->
+ local_labels_1(function__code(F), R)
+ end, [], Funs)).
+
+%% The first clause below attempts to provide some (limited form of)
+%% backwards compatibility; it is not needed for .beam files generated
+%% by the R8 compiler. The clause should one fine day be taken out.
+local_labels_1([{label,_}|[{label,_}|_]=Code], R) ->
+ local_labels_1(Code, R);
+local_labels_1([{label,_},{func_info,{atom,M},{atom,F},A}|Code], R)
+ when is_atom(M), is_atom(F) ->
+ local_labels_2(Code, R, M, F, A);
+local_labels_1(Code, _) ->
+ ?exit({'local_labels: no label in code',Code}).
+
+local_labels_2([{label,[{u,L}]}|Code], R, M, F, A) ->
+ local_labels_2(Code, [{L,{M,F,A}}|R], M, F, A);
+local_labels_2(_, R, _, _, _) -> R.
+
+%%-----------------------------------------------------------------------
+%% Disassembles a single BEAM instruction; most instructions are handled
+%% in a generic way; indexing instructions are handled separately.
+%%-----------------------------------------------------------------------
+
+disasm_instr(B, Bs, Atoms, Literals) ->
+ {SymOp, Arity} = beam_opcodes:opname(B),
+ case SymOp of
+ select_val ->
+ disasm_select_inst(select_val, Bs, Atoms, Literals);
+ select_tuple_arity ->
+ disasm_select_inst(select_tuple_arity, Bs, Atoms, Literals);
+ _ ->
+ try decode_n_args(Arity, Bs, Atoms, Literals) of
+ {Args, RestBs} ->
+ ?NO_DEBUG("instr ~p~n", [{SymOp, Args}]),
+ {{SymOp, Args}, RestBs}
+ catch
+ error:Rsn ->
+ ?NO_DEBUG("decode_n_args(~p,~p) failed~n", [Arity, Bs]),
+ ?exit({cannot_disasm_instr, {SymOp, Arity, Rsn}})
+ end
+ end.
+
+%%-----------------------------------------------------------------------
+%% Disassembles a BEAM select_* instruction used for indexing.
+%% Currently handles {select_val,3} and {select_tuple_arity,3} insts.
+%%
+%% The arguments of a "select"-type instruction look as follows:
+%% <reg>, {f,FailLabel}, {list, <num cases>, [<case1> ... <caseN>]}
+%% where each case is of the form [symbol,{f,Label}].
+%%-----------------------------------------------------------------------
+
+disasm_select_inst(Inst, Bs, Atoms, Literals) ->
+ {X, Bs1} = decode_arg(Bs, Atoms, Literals),
+ {F, Bs2} = decode_arg(Bs1, Atoms, Literals),
+ {Z, Bs3} = decode_arg(Bs2, Atoms, Literals),
+ {U, Bs4} = decode_arg(Bs3, Atoms, Literals),
+ {u, Len} = U,
+ {List, RestBs} = decode_n_args(Len, Bs4, Atoms, Literals),
+ {{Inst, [X,F,{Z,U,List}]}, RestBs}.
+
+%%-----------------------------------------------------------------------
+%% decode_arg([Byte]) -> {Arg, [Byte]}
+%%
+%% - an arg can have variable length, so we must return arg + remaining bytes
+%% - decodes an argument into its 'raw' form: { Tag, Value }
+%% several types map to a single tag, so the byte code instr must then
+%% assign a type to it
+%%-----------------------------------------------------------------------
+
+-spec decode_arg([byte(),...]) -> {{disasm_tag(),_}, [byte()]}.
+
+decode_arg([B|Bs]) ->
+ Tag = decode_tag(B band 2#111),
+ ?NO_DEBUG('Tag = ~p, B = ~p, Bs = ~p~n', [Tag, B, Bs]),
+ case Tag of
+ z ->
+ decode_z_tagged(Tag, B, Bs, no_literals);
+ _ ->
+ %% all other cases are handled as if they were integers
+ decode_int(Tag, B, Bs)
+ end.
+
+-spec decode_arg([byte(),...], gb_tree(), literals()) -> {disasm_term(), [byte()]}.
+
+decode_arg([B|Bs0], Atoms, Literals) ->
+ Tag = decode_tag(B band 2#111),
+ ?NO_DEBUG('Tag = ~p, B = ~p, Bs = ~p~n', [Tag, B, Bs]),
+ case Tag of
+ z ->
+ decode_z_tagged(Tag, B, Bs0, Literals);
+ a ->
+ %% atom or nil
+ case decode_int(Tag, B, Bs0) of
+ {{a,0},Bs} -> {nil,Bs};
+ {{a,I},Bs} -> {{atom,lookup(I, Atoms)},Bs}
+ end;
+ _ ->
+ %% all other cases are handled as if they were integers
+ decode_int(Tag, B, Bs0)
+ end.
+
+%%-----------------------------------------------------------------------
+%% Decodes an integer value. Handles positives, negatives, and bignums.
+%%
+%% Tries to do the opposite of:
+%% beam_asm:encode(1, 5) = [81]
+%% beam_asm:encode(1, 1000) = [105,232]
+%% beam_asm:encode(1, 2047) = [233,255]
+%% beam_asm:encode(1, 2048) = [25,8,0]
+%% beam_asm:encode(1,-1) = [25,255,255]
+%% beam_asm:encode(1,-4294967295) = [121,255,0,0,0,1]
+%% beam_asm:encode(1, 4294967295) = [121,0,255,255,255,255]
+%% beam_asm:encode(1, 429496729501) = [121,99,255,255,255,157]
+%%-----------------------------------------------------------------------
+
+decode_int(Tag,B,Bs) when (B band 16#08) =:= 0 ->
+ %% N < 16 = 4 bits, NNNN:0:TTT
+ N = B bsr 4,
+ {{Tag,N},Bs};
+decode_int(Tag,B,Bs) when (B band 16#10) =:= 0 ->
+ %% N < 2048 = 11 bits = 3:8 bits, NNN:01:TTT, NNNNNNNN
+ [B1|Bs1] = Bs,
+ Val0 = B band 2#11100000,
+ N = (Val0 bsl 3) bor B1,
+ ?NO_DEBUG('NNN:01:TTT, NNNNNNNN = ~n~p:01:~p, ~p = ~p~n', [Val0,Tag,B,N]),
+ {{Tag,N},Bs1};
+decode_int(Tag,B,Bs) ->
+ {Len,Bs1} = decode_int_length(B,Bs),
+ {IntBs,RemBs} = take_bytes(Len,Bs1),
+ N = build_arg(IntBs),
+ [F|_] = IntBs,
+ Num = if F > 127, Tag =:= i -> decode_negative(N,Len);
+ true -> N
+ end,
+ ?NO_DEBUG('Len = ~p, IntBs = ~p, Num = ~p~n', [Len,IntBs,Num]),
+ {{Tag,Num},RemBs}.
+
+-spec decode_int_length(integer(), [byte()]) -> {integer(), [byte()]}.
+
+decode_int_length(B, Bs) ->
+ %% The following imitates get_erlang_integer() in beam_load.c
+ %% Len is the size of the integer value in bytes
+ case B bsr 5 of
+ 7 ->
+ {Arg,ArgBs} = decode_arg(Bs),
+ case Arg of
+ {u,L} ->
+ {L+9,ArgBs}; % 9 stands for 7+2
+ _ ->
+ ?exit({decode_int,weird_bignum_sublength,Arg})
+ end;
+ L ->
+ {L+2,Bs}
+ end.
+
+-spec decode_negative(non_neg_integer(), non_neg_integer()) -> neg_integer().
+
+decode_negative(N, Len) ->
+ N - (1 bsl (Len*8)). % 8 is number of bits in a byte
+
+%%-----------------------------------------------------------------------
+%% Decodes lists and floating point numbers.
+%%-----------------------------------------------------------------------
+
+decode_z_tagged(Tag,B,Bs,Literals) when (B band 16#08) =:= 0 ->
+ N = B bsr 4,
+ case N of
+ 0 -> % float
+ decode_float(Bs);
+ 1 -> % list
+ {{Tag,N},Bs};
+ 2 -> % fr
+ decode_fr(Bs);
+ 3 -> % allocation list
+ decode_alloc_list(Bs, Literals);
+ 4 -> % literal
+ {{u,LitIndex},RestBs} = decode_arg(Bs),
+ {{literal,gb_trees:get(LitIndex, Literals)},RestBs};
+ _ ->
+ ?exit({decode_z_tagged,{invalid_extended_tag,N}})
+ end;
+decode_z_tagged(_,B,_,_) ->
+ ?exit({decode_z_tagged,{weird_value,B}}).
+
+-spec decode_float([byte(),...]) -> {{'float', float()}, [byte()]}.
+
+decode_float(Bs) ->
+ {FL,RestBs} = take_bytes(8,Bs),
+ <<Float:64/float>> = list_to_binary(FL),
+ {{float,Float},RestBs}.
+
+-spec decode_fr([byte(),...]) -> {{'fr', non_neg_integer()}, [byte()]}.
+
+decode_fr(Bs) ->
+ {{u,Fr},RestBs} = decode_arg(Bs),
+ {{fr,Fr},RestBs}.
+
+decode_alloc_list(Bs, Literals) ->
+ {{u,N},RestBs} = decode_arg(Bs),
+ decode_alloc_list_1(N, Literals, RestBs, []).
+
+decode_alloc_list_1(0, _Literals, RestBs, Acc) ->
+ {{u,{alloc,lists:reverse(Acc)}},RestBs};
+decode_alloc_list_1(N, Literals, Bs0, Acc) ->
+ {{u,Type},Bs1} = decode_arg(Bs0),
+ {{u,Val},Bs} = decode_arg(Bs1),
+ Res = case Type of
+ 0 -> {words,Val};
+ 1 -> {floats,Val};
+ 2 -> {literal,gb_trees:get(Val, Literals)}
+ end,
+ decode_alloc_list_1(N-1, Literals, Bs, [Res|Acc]).
+
+%%-----------------------------------------------------------------------
+%% take N bytes from a stream, return {Taken_bytes, Remaining_bytes}
+%%-----------------------------------------------------------------------
+
+-spec take_bytes(non_neg_integer(), [byte()]) -> {[byte()], [byte()]}.
+
+take_bytes(N, Bs) ->
+ take_bytes(N, Bs, []).
+
+take_bytes(N, [B|Bs], Acc) when N > 0 ->
+ take_bytes(N-1, Bs, [B|Acc]);
+take_bytes(0, Bs, Acc) ->
+ {lists:reverse(Acc), Bs}.
+
+%%-----------------------------------------------------------------------
+%% from a list of bytes Bn,Bn-1,...,B1,B0
+%% build (Bn << 8*n) bor ... bor (B1 << 8) bor (B0 << 0)
+%%-----------------------------------------------------------------------
+
+build_arg(Bs) ->
+ build_arg(Bs, 0).
+
+build_arg([B|Bs], N) ->
+ build_arg(Bs, (N bsl 8) bor B);
+build_arg([], N) ->
+ N.
+
+%%-----------------------------------------------------------------------
+%% Decodes a bunch of arguments and returns them in a list
+%%-----------------------------------------------------------------------
+
+decode_n_args(N, Bs, Atoms, Literals) when N >= 0 ->
+ decode_n_args(N, [], Bs, Atoms, Literals).
+
+decode_n_args(N, Acc, Bs0, Atoms, Literals) when N > 0 ->
+ {A1,Bs} = decode_arg(Bs0, Atoms, Literals),
+ decode_n_args(N-1, [A1|Acc], Bs, Atoms, Literals);
+decode_n_args(0, Acc, Bs, _, _) ->
+ {lists:reverse(Acc),Bs}.
+
+%%-----------------------------------------------------------------------
+%% Convert a numeric tag value into a symbolic one
+%%-----------------------------------------------------------------------
+
+-spec decode_tag(0..7) -> symbolic_tag().
+
+decode_tag(?tag_u) -> u;
+decode_tag(?tag_i) -> i;
+decode_tag(?tag_a) -> a;
+decode_tag(?tag_x) -> x;
+decode_tag(?tag_y) -> y;
+decode_tag(?tag_f) -> f;
+decode_tag(?tag_h) -> h;
+decode_tag(?tag_z) -> z.
+
+%%-----------------------------------------------------------------------
+%% - replace all references {a,I} with the atom with index I (or {atom,A})
+%% - replace all references to {i,K} in an external call position with
+%% the proper MFA (position in list, first elt = 0, yields MFA to use)
+%% - resolve strings, represented as <offset, length>, into their
+%% actual values by using string table
+%% (note: string table should be passed as a BINARY so that we can
+%% use binary_to_list/3!)
+%% - convert instruction to its readable form ...
+%%
+%% Currently, only the first three are done (systematically, at least).
+%%
+%% Note: It MAY be premature to remove the lists of args, since that
+%% representation means it is simpler to iterate over all args, etc.
+%%-----------------------------------------------------------------------
+
+resolve_names(Fun, Imports, Str, Lbls, Lambdas, Literals, M) ->
+ [resolve_inst(Instr, Imports, Str, Lbls, Lambdas, Literals, M) || Instr <- Fun].
+
+%%
+%% New make_fun2/4 instruction added in August 2001 (R8).
+%% New put_literal/2 instruction added in Feb 2006 R11B-4.
+%% We handle them specially here to avoid adding an argument to
+%% the clause for every instruction.
+%%
+
+resolve_inst({make_fun2,Args}, _, _, _, Lambdas, _, M) ->
+ [OldIndex] = resolve_args(Args),
+ {OldIndex,{F,A,_Lbl,_Index,NumFree,OldUniq}} =
+ lists:keyfind(OldIndex, 1, Lambdas),
+ {make_fun2,{M,F,A},OldIndex,OldUniq,NumFree};
+resolve_inst({put_literal,[{u,Index},Dst]},_,_,_,_,Literals,_) ->
+ {put_literal,{literal,gb_trees:get(Index, Literals)},Dst};
+resolve_inst(Instr, Imports, Str, Lbls, _Lambdas, _Literals, _M) ->
+ %% io:format(?MODULE_STRING":resolve_inst ~p.~n", [Instr]),
+ resolve_inst(Instr, Imports, Str, Lbls).
+
+resolve_inst({label,[{u,L}]},_,_,_) ->
+ {label,L};
+resolve_inst(FuncInfo,_,_,_) when element(1, FuncInfo) =:= func_info ->
+ FuncInfo; % already resolved
+%% resolve_inst(int_code_end,_,_,_,_) -> % instruction already handled
+%% int_code_end; % should not really be handled here
+resolve_inst({call,[{u,N},{f,L}]},_,_,Lbls) ->
+ {call,N,lookup(L,Lbls)};
+resolve_inst({call_last,[{u,N},{f,L},{u,U}]},_,_,Lbls) ->
+ {call_last,N,lookup(L,Lbls),U};
+resolve_inst({call_only,[{u,N},{f,L}]},_,_,Lbls) ->
+ {call_only,N,lookup(L,Lbls)};
+resolve_inst({call_ext,[{u,N},{u,MFAix}]},Imports,_,_) ->
+ {call_ext,N,lookup(MFAix+1,Imports)};
+resolve_inst({call_ext_last,[{u,N},{u,MFAix},{u,X}]},Imports,_,_) ->
+ {call_ext_last,N,lookup(MFAix+1,Imports),X};
+resolve_inst({bif0,Args},Imports,_,_) ->
+ [Bif,Reg] = resolve_args(Args),
+ {extfunc,_Mod,BifName,_Arity} = lookup(Bif+1,Imports),
+ {bif,BifName,nofail,[],Reg};
+resolve_inst({bif1,Args},Imports,_,_) ->
+ [F,Bif,A1,Reg] = resolve_args(Args),
+ {extfunc,_Mod,BifName,_Arity} = lookup(Bif+1,Imports),
+ {bif,BifName,F,[A1],Reg};
+resolve_inst({bif2,Args},Imports,_,_) ->
+ [F,Bif,A1,A2,Reg] = resolve_args(Args),
+ {extfunc,_Mod,BifName,_Arity} = lookup(Bif+1,Imports),
+ {bif,BifName,F,[A1,A2],Reg};
+resolve_inst({allocate,[{u,X0},{u,X1}]},_,_,_) ->
+ {allocate,X0,X1};
+resolve_inst({allocate_heap,[{u,X0},{u,X1},{u,X2}]},_,_,_) ->
+ {allocate_heap,X0,X1,X2};
+resolve_inst({allocate_zero,[{u,X0},{u,X1}]},_,_,_) ->
+ {allocate_zero,X0,X1};
+resolve_inst({allocate_heap_zero,[{u,X0},{u,X1},{u,X2}]},_,_,_) ->
+ {allocate_heap_zero,X0,X1,X2};
+resolve_inst({test_heap,[{u,X0},{u,X1}]},_,_,_) ->
+ {test_heap,X0,X1};
+resolve_inst({init,[Dst]},_,_,_) ->
+ {init,Dst};
+resolve_inst({deallocate,[{u,L}]},_,_,_) ->
+ {deallocate,L};
+resolve_inst({return,[]},_,_,_) ->
+ return;
+resolve_inst({send,[]},_,_,_) ->
+ send;
+resolve_inst({remove_message,[]},_,_,_) ->
+ remove_message;
+resolve_inst({timeout,[]},_,_,_) ->
+ timeout;
+resolve_inst({loop_rec,[Lbl,Dst]},_,_,_) ->
+ {loop_rec,Lbl,Dst};
+resolve_inst({loop_rec_end,[Lbl]},_,_,_) ->
+ {loop_rec_end,Lbl};
+resolve_inst({wait,[Lbl]},_,_,_) ->
+ {wait,Lbl};
+resolve_inst({wait_timeout,[Lbl,Int]},_,_,_) ->
+ {wait_timeout,Lbl,resolve_arg(Int)};
+resolve_inst({m_plus,Args},_,_,_) ->
+ [W,SrcR1,SrcR2,DstR] = resolve_args(Args),
+ {arithbif,'+',W,[SrcR1,SrcR2],DstR};
+resolve_inst({m_minus,Args},_,_,_) ->
+ [W,SrcR1,SrcR2,DstR] = resolve_args(Args),
+ {arithbif,'-',W,[SrcR1,SrcR2],DstR};
+resolve_inst({m_times,Args},_,_,_) ->
+ [W,SrcR1,SrcR2,DstR] = resolve_args(Args),
+ {arithbif,'*',W,[SrcR1,SrcR2],DstR};
+resolve_inst({m_div,Args},_,_,_) ->
+ [W,SrcR1,SrcR2,DstR] = resolve_args(Args),
+ {arithbif,'/',W,[SrcR1,SrcR2],DstR};
+resolve_inst({int_div,Args},_,_,_) ->
+ [W,SrcR1,SrcR2,DstR] = resolve_args(Args),
+ {arithbif,'div',W,[SrcR1,SrcR2],DstR};
+resolve_inst({int_rem,Args},_,_,_) ->
+ [W,SrcR1,SrcR2,DstR] = resolve_args(Args),
+ {arithbif,'rem',W,[SrcR1,SrcR2],DstR};
+resolve_inst({int_band,Args},_,_,_) ->
+ [W,SrcR1,SrcR2,DstR] = resolve_args(Args),
+ {arithbif,'band',W,[SrcR1,SrcR2],DstR};
+resolve_inst({int_bor,Args},_,_,_) ->
+ [W,SrcR1,SrcR2,DstR] = resolve_args(Args),
+ {arithbif,'bor',W,[SrcR1,SrcR2],DstR};
+resolve_inst({int_bxor,Args},_,_,_) ->
+ [W,SrcR1,SrcR2,DstR] = resolve_args(Args),
+ {arithbif,'bxor',W,[SrcR1,SrcR2],DstR};
+resolve_inst({int_bsl,Args},_,_,_) ->
+ [W,SrcR1,SrcR2,DstR] = resolve_args(Args),
+ {arithbif,'bsl',W,[SrcR1,SrcR2],DstR};
+resolve_inst({int_bsr,Args},_,_,_) ->
+ [W,SrcR1,SrcR2,DstR] = resolve_args(Args),
+ {arithbif,'bsr',W,[SrcR1,SrcR2],DstR};
+resolve_inst({int_bnot,Args},_,_,_) ->
+ [W,SrcR,DstR] = resolve_args(Args),
+ {arithbif,'bnot',W,[SrcR],DstR};
+resolve_inst({is_lt=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({is_ge=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({is_eq=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({is_ne=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({is_eq_exact=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({is_ne_exact=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({is_integer=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({is_float=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({is_number=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({is_atom=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({is_pid=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({is_reference=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({is_port=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({is_nil=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({is_binary=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({is_constant=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({is_list=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({is_nonempty_list=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({is_tuple=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({test_arity=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({select_val,Args},_,_,_) ->
+ [Reg,FLbl,{{z,1},{u,_Len},List0}] = Args,
+ List = resolve_args(List0),
+ {select_val,Reg,FLbl,{list,List}};
+resolve_inst({select_tuple_arity,Args},_,_,_) ->
+ [Reg,FLbl,{{z,1},{u,_Len},List0}] = Args,
+ List = resolve_args(List0),
+ {select_tuple_arity,Reg,FLbl,{list,List}};
+resolve_inst({jump,[Lbl]},_,_,_) ->
+ {jump,Lbl};
+resolve_inst({'catch',[Dst,Lbl]},_,_,_) ->
+ {'catch',Dst,Lbl};
+resolve_inst({catch_end,[Dst]},_,_,_) ->
+ {catch_end,Dst};
+resolve_inst({move,[Src,Dst]},_,_,_) ->
+ {move,resolve_arg(Src),Dst};
+resolve_inst({get_list,[Src,Dst1,Dst2]},_,_,_) ->
+ {get_list,Src,Dst1,Dst2};
+resolve_inst({get_tuple_element,[Src,{u,Off},Dst]},_,_,_) ->
+ {get_tuple_element,resolve_arg(Src),Off,resolve_arg(Dst)};
+resolve_inst({set_tuple_element,[Src,Dst,{u,Off}]},_,_,_) ->
+ {set_tuple_element,resolve_arg(Src),resolve_arg(Dst),Off};
+resolve_inst({put_string,[{u,Len},{u,Off},Dst]},_,Strings,_) ->
+ String = if Len > 0 -> binary_to_list(Strings, Off+1, Off+Len);
+ true -> ""
+ end,
+ {put_string,Len,{string,String},Dst};
+resolve_inst({put_list,[Src1,Src2,Dst]},_,_,_) ->
+ {put_list,resolve_arg(Src1),resolve_arg(Src2),Dst};
+resolve_inst({put_tuple,[{u,Arity},Dst]},_,_,_) ->
+ {put_tuple,Arity,Dst};
+resolve_inst({put,[Src]},_,_,_) ->
+ {put,resolve_arg(Src)};
+resolve_inst({badmatch,[X]},_,_,_) ->
+ {badmatch,resolve_arg(X)};
+resolve_inst({if_end,[]},_,_,_) ->
+ if_end;
+resolve_inst({case_end,[X]},_,_,_) ->
+ {case_end,resolve_arg(X)};
+resolve_inst({call_fun,[{u,N}]},_,_,_) ->
+ {call_fun,N};
+resolve_inst({make_fun,Args},_,_,Lbls) ->
+ [{f,L},Magic,FreeVars] = resolve_args(Args),
+ {make_fun,lookup(L,Lbls),Magic,FreeVars};
+resolve_inst({is_function=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+resolve_inst({call_ext_only,[{u,N},{u,MFAix}]},Imports,_,_) ->
+ {call_ext_only,N,lookup(MFAix+1,Imports)};
+%%
+%% Instructions for handling binaries added in R7A & R7B
+%%
+resolve_inst({bs_start_match,[F,Reg]},_,_,_) ->
+ {bs_start_match,F,Reg};
+resolve_inst({bs_get_integer=I,[Lbl,Arg2,{u,N},{u,U},Arg5]},_,_,_) ->
+ [A2,A5] = resolve_args([Arg2,Arg5]),
+ {test,I,Lbl,[A2,N,decode_field_flags(U),A5]};
+resolve_inst({bs_get_float=I,[Lbl,Arg2,{u,N},{u,U},Arg5]},_,_,_) ->
+ [A2,A5] = resolve_args([Arg2,Arg5]),
+ {test,I,Lbl,[A2,N,decode_field_flags(U),A5]};
+resolve_inst({bs_get_binary=I,[Lbl,Arg2,{u,N},{u,U},Arg5]},_,_,_) ->
+ [A2,A5] = resolve_args([Arg2,Arg5]),
+ {test,I,Lbl,[A2,N,decode_field_flags(U),A5]};
+resolve_inst({bs_skip_bits,[Lbl,Arg2,{u,N},{u,U}]},_,_,_) ->
+ A2 = resolve_arg(Arg2),
+ {test,bs_skip_bits,Lbl,[A2,N,decode_field_flags(U)]};
+resolve_inst({bs_test_tail,[F,{u,N}]},_,_,_) ->
+ {test,bs_test_tail,F,[N]};
+resolve_inst({bs_save,[{u,N}]},_,_,_) ->
+ {bs_save,N};
+resolve_inst({bs_restore,[{u,N}]},_,_,_) ->
+ {bs_restore,N};
+resolve_inst({bs_init,[{u,N},{u,U}]},_,_,_) ->
+ {bs_init,N,decode_field_flags(U)};
+resolve_inst({bs_final,[F,X]},_,_,_) ->
+ {bs_final,F,X};
+resolve_inst({bs_put_integer,[Lbl,Arg2,{u,N},{u,U},Arg5]},_,_,_) ->
+ [A2,A5] = resolve_args([Arg2,Arg5]),
+ {bs_put_integer,Lbl,A2,N,decode_field_flags(U),A5};
+resolve_inst({bs_put_binary,[Lbl,Arg2,{u,N},{u,U},Arg5]},_,_,_) ->
+ [A2,A5] = resolve_args([Arg2,Arg5]),
+ {bs_put_binary,Lbl,A2,N,decode_field_flags(U),A5};
+resolve_inst({bs_put_float,[Lbl,Arg2,{u,N},{u,U},Arg5]},_,_,_) ->
+ [A2,A5] = resolve_args([Arg2,Arg5]),
+ {bs_put_float,Lbl,A2,N,decode_field_flags(U),A5};
+resolve_inst({bs_put_string,[{u,Len},{u,Off}]},_,Strings,_) ->
+ String = if Len > 0 -> binary_to_list(Strings, Off+1, Off+Len);
+ true -> ""
+ end,
+ {bs_put_string,Len,{string,String}};
+resolve_inst({bs_need_buf,[{u,N}]},_,_,_) ->
+ {bs_need_buf,N};
+
+%%
+%% Instructions for handling floating point numbers added in June 2001 (R8).
+%%
+resolve_inst({fclearerror,[]},_,_,_) ->
+ fclearerror;
+resolve_inst({fcheckerror,[Arg]},_,_,_) ->
+ {fcheckerror,resolve_arg(Arg)};
+resolve_inst({fmove,Args},_,_,_) ->
+ [FR,Reg] = resolve_args(Args),
+ {fmove,FR,Reg};
+resolve_inst({fconv,Args},_,_,_) ->
+ [Reg,FR] = resolve_args(Args),
+ {fconv,Reg,FR};
+resolve_inst({fadd=I,Args},_,_,_) ->
+ [F,A1,A2,Reg] = resolve_args(Args),
+ {arithfbif,I,F,[A1,A2],Reg};
+resolve_inst({fsub=I,Args},_,_,_) ->
+ [F,A1,A2,Reg] = resolve_args(Args),
+ {arithfbif,I,F,[A1,A2],Reg};
+resolve_inst({fmul=I,Args},_,_,_) ->
+ [F,A1,A2,Reg] = resolve_args(Args),
+ {arithfbif,I,F,[A1,A2],Reg};
+resolve_inst({fdiv=I,Args},_,_,_) ->
+ [F,A1,A2,Reg] = resolve_args(Args),
+ {arithfbif,I,F,[A1,A2],Reg};
+resolve_inst({fnegate,Args},_,_,_) ->
+ [F,Arg,Reg] = resolve_args(Args),
+ {arithfbif,fnegate,F,[Arg],Reg};
+
+%%
+%% Instructions for try expressions added in January 2003 (R10).
+%%
+resolve_inst({'try',[Reg,Lbl]},_,_,_) -> % analogous to 'catch'
+ {'try',Reg,Lbl};
+resolve_inst({try_end,[Reg]},_,_,_) -> % analogous to 'catch_end'
+ {try_end,Reg};
+resolve_inst({try_case,[Reg]},_,_,_) -> % analogous to 'catch_end'
+ {try_case,Reg};
+resolve_inst({try_case_end,[Arg]},_,_,_) ->
+ {try_case_end,resolve_arg(Arg)};
+resolve_inst({raise,[_Reg1,_Reg2]=Regs},_,_,_) ->
+ {raise,{f,0},Regs,{x,0}}; % do NOT wrap this as a 'bif'
+ % as there is no raise/2 bif!
+
+%%
+%% New bit syntax instructions added in February 2004 (R10B).
+%%
+resolve_inst({bs_init2,[Lbl,Arg2,{u,W},{u,R},{u,F},Arg6]},_,_,_) ->
+ [A2,A6] = resolve_args([Arg2,Arg6]),
+ {bs_init2,Lbl,A2,W,R,decode_field_flags(F),A6};
+resolve_inst({bs_bits_to_bytes,[Lbl,Arg2,Arg3]},_,_,_) ->
+ [A2,A3] = resolve_args([Arg2,Arg3]),
+ {bs_bits_to_bytes,Lbl,A2,A3};
+resolve_inst({bs_add=I,[Lbl,Arg2,Arg3,Arg4,Arg5]},_,_,_) ->
+ [A2,A3,A4,A5] = resolve_args([Arg2,Arg3,Arg4,Arg5]),
+ {I,Lbl,[A2,A3,A4],A5};
+
+%%
+%% New apply instructions added in April 2004 (R10B).
+%%
+resolve_inst({apply,[{u,Arity}]},_,_,_) ->
+ {apply,Arity};
+resolve_inst({apply_last,[{u,Arity},{u,D}]},_,_,_) ->
+ {apply_last,Arity,D};
+
+%%
+%% New test instruction added in April 2004 (R10B).
+%%
+resolve_inst({is_boolean=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+
+%%
+%% New instruction added in June 2005.
+%%
+resolve_inst({is_function2=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+
+%%
+%% New bit syntax matching added in Dec 2005 (R11B).
+%%
+resolve_inst({bs_start_match2=I,[F,Reg,{u,Live},{u,Max},Ms]},_,_,_) ->
+ {test,I,F,[Reg,Live,Max,Ms]};
+resolve_inst({bs_get_integer2=I,[Lbl,Ms,{u,Live},Arg2,{u,N},{u,U},Arg5]},_,_,_) ->
+ [A2,A5] = resolve_args([Arg2,Arg5]),
+ {test,I,Lbl,[Ms, Live,A2,N,decode_field_flags(U),A5]};
+resolve_inst({bs_get_binary2=I,[Lbl,Ms,{u,Live},Arg2,{u,N},{u,U},Arg5]},_,_,_) ->
+ [A2,A5] = resolve_args([Arg2,Arg5]),
+ {test,I,Lbl,[Ms, Live,A2,N,decode_field_flags(U),A5]};
+resolve_inst({bs_get_float2=I,[Lbl,Ms,{u,Live},Arg2,{u,N},{u,U},Arg5]},_,_,_) ->
+ [A2,A5] = resolve_args([Arg2,Arg5]),
+ {test,I,Lbl,[Ms, Live,A2,N,decode_field_flags(U),A5]};
+resolve_inst({bs_skip_bits2=I,[Lbl,Ms,Arg2,{u,N},{u,U}]},_,_,_) ->
+ A2 = resolve_arg(Arg2),
+ {test,I,Lbl,[Ms,A2,N,decode_field_flags(U)]};
+resolve_inst({bs_test_tail2=I,[F,Ms,{u,N}]},_,_,_) ->
+ {test,I,F,[Ms,N]};
+resolve_inst({bs_save2=I,[Ms,{u,N}]},_,_,_) ->
+ {I,Ms,N};
+resolve_inst({bs_restore2=I,[Ms,{u,N}]},_,_,_) ->
+ {I,Ms,N};
+resolve_inst({bs_save2=I,[Ms,{atom,_}=Atom]},_,_,_) ->
+ %% New operand type in R12B.
+ {I,Ms,Atom};
+resolve_inst({bs_restore2=I,[Ms,{atom,_}=Atom]},_,_,_) ->
+ %% New operand type in R12B.
+ {I,Ms,Atom};
+
+%%
+%% New instructions for guard BIFs that may GC. Added in Jan 2006 (R11B).
+%%
+resolve_inst({gc_bif1,Args},Imports,_,_) ->
+ [F,Live,Bif,A1,Reg] = resolve_args(Args),
+ {extfunc,_Mod,BifName,_Arity} = lookup(Bif+1,Imports),
+ {gc_bif,BifName,F,Live,[A1],Reg};
+resolve_inst({gc_bif2,Args},Imports,_,_) ->
+ [F,Live,Bif,A1,A2,Reg] = resolve_args(Args),
+ {extfunc,_Mod,BifName,_Arity} = lookup(Bif+1,Imports),
+ {gc_bif,BifName,F,Live,[A1,A2],Reg};
+
+%%
+%% New instructions for creating non-byte aligned binaries.
+%%
+resolve_inst({bs_bits_to_bytes2,[_Arg2,_Arg3]=Args},_,_,_) ->
+ [A2,A3] = resolve_args(Args),
+ {bs_bits_to_bytes2,A2,A3};
+resolve_inst({bs_final2,[X,Y]},_,_,_) ->
+ {bs_final2,X,Y};
+
+%%
+%% R11B-5.
+%%
+resolve_inst({is_bitstr=I,Args0},_,_,_) ->
+ [L|Args] = resolve_args(Args0),
+ {test,I,L,Args};
+
+%%
+%% R12B.
+%%
+resolve_inst({bs_context_to_binary=I,[Reg0]},_,_,_) ->
+ Reg = resolve_arg(Reg0),
+ {I,Reg};
+resolve_inst({bs_test_unit=I,[F,Ms,{u,N}]},_,_,_) ->
+ {test,I,F,[Ms,N]};
+resolve_inst({bs_match_string=I,[F,Ms,{u,Bits},{u,Off}]},_,Strings,_) ->
+ Len = (Bits+7) div 8,
+ String = if
+ Len > 0 ->
+ <<_:Off/binary,Bin:Len/binary,_/binary>> = Strings,
+ Bin;
+ true -> <<>>
+ end,
+ {test,I,F,[Ms,Bits,String]};
+resolve_inst({bs_init_writable=I,[]},_,_,_) ->
+ I;
+resolve_inst({bs_append=I,[Lbl,Arg2,{u,W},{u,R},{u,U},Arg6,{u,F},Arg8]},_,_,_) ->
+ [A2,A6,A8] = resolve_args([Arg2,Arg6,Arg8]),
+ {I,Lbl,A2,W,R,U,A6,decode_field_flags(F),A8};
+resolve_inst({bs_private_append=I,[Lbl,Arg2,{u,U},Arg4,{u,F},Arg6]},_,_,_) ->
+ [A2,A4,A6] = resolve_args([Arg2,Arg4,Arg6]),
+ {I,Lbl,A2,U,A4,decode_field_flags(F),A6};
+resolve_inst({trim=I,[{u,N},{u,Remaining}]},_,_,_) ->
+ {I,N,Remaining};
+resolve_inst({bs_init_bits,[Lbl,Arg2,{u,W},{u,R},{u,F},Arg6]},_,_,_) ->
+ [A2,A6] = resolve_args([Arg2,Arg6]),
+ {bs_init_bits,Lbl,A2,W,R,decode_field_flags(F),A6};
+
+%%
+%% R12B-5.
+%%
+resolve_inst({bs_get_utf8=I,[Lbl,Arg2,Arg3,{u,U},Arg4]},_,_,_) ->
+ [A2,A3,A4] = resolve_args([Arg2,Arg3,Arg4]),
+ {test,I,Lbl,[A2,A3,decode_field_flags(U),A4]};
+resolve_inst({bs_skip_utf8=I,[Lbl,Arg2,Arg3,{u,U}]},_,_,_) ->
+ [A2,A3] = resolve_args([Arg2,Arg3]),
+ {test,I,Lbl,[A2,A3,decode_field_flags(U)]};
+resolve_inst({bs_get_utf16=I,[Lbl,Arg2,Arg3,{u,U},Arg4]},_,_,_) ->
+ [A2,A3,A4] = resolve_args([Arg2,Arg3,Arg4]),
+ {test,I,Lbl,[A2,A3,decode_field_flags(U),A4]};
+resolve_inst({bs_skip_utf16=I,[Lbl,Arg2,Arg3,{u,U}]},_,_,_) ->
+ [A2,A3] = resolve_args([Arg2,Arg3]),
+ {test,I,Lbl,[A2,A3,decode_field_flags(U)]};
+resolve_inst({bs_get_utf32=I,[Lbl,Arg2,Arg3,{u,U},Arg4]},_,_,_) ->
+ [A2,A3,A4] = resolve_args([Arg2,Arg3,Arg4]),
+ {test,I,Lbl,[A2,A3,decode_field_flags(U),A4]};
+resolve_inst({bs_skip_utf32=I,[Lbl,Arg2,Arg3,{u,U}]},_,_,_) ->
+ [A2,A3] = resolve_args([Arg2,Arg3]),
+ {test,I,Lbl,[A2,A3,decode_field_flags(U)]};
+resolve_inst({bs_utf8_size=I,[Lbl,Arg2,Arg3]},_,_,_) ->
+ [A2,A3] = resolve_args([Arg2,Arg3]),
+ {I,Lbl,A2,A3};
+resolve_inst({bs_put_utf8=I,[Lbl,{u,U},Arg3]},_,_,_) ->
+ A3 = resolve_arg(Arg3),
+ {I,Lbl,decode_field_flags(U),A3};
+resolve_inst({bs_utf16_size=I,[Lbl,Arg2,Arg3]},_,_,_) ->
+ [A2,A3] = resolve_args([Arg2,Arg3]),
+ {I,Lbl,A2,A3};
+resolve_inst({bs_put_utf16=I,[Lbl,{u,U},Arg3]},_,_,_) ->
+ A3 = resolve_arg(Arg3),
+ {I,Lbl,decode_field_flags(U),A3};
+resolve_inst({bs_put_utf32=I,[Lbl,{u,U},Arg3]},_,_,_) ->
+ A3 = resolve_arg(Arg3),
+ {I,Lbl,decode_field_flags(U),A3};
+
+%%
+%% R13B03.
+%%
+resolve_inst({on_load,[]},_,_,_) ->
+ on_load;
+
+%%
+%% Catches instructions that are not yet handled.
+%%
+resolve_inst(X,_,_,_) -> ?exit({resolve_inst,X}).
+
+%%-----------------------------------------------------------------------
+%% Resolves arguments in a generic way.
+%%-----------------------------------------------------------------------
+
+resolve_args(Args) -> [resolve_arg(A) || A <- Args].
+
+resolve_arg({x,N} = Arg) when is_integer(N), N >= 0 -> Arg;
+resolve_arg({y,N} = Arg) when is_integer(N), N >= 0 -> Arg;
+resolve_arg({fr,N} = Arg) when is_integer(N), N >= 0 -> Arg;
+resolve_arg({f,N} = Arg) when is_integer(N), N >= 0 -> Arg;
+resolve_arg({u,_} = Arg) -> resolve_arg_unsigned(Arg);
+resolve_arg({i,_} = Arg) -> resolve_arg_integer(Arg);
+resolve_arg({atom,Atom} = Arg) when is_atom(Atom) -> Arg;
+resolve_arg({float,F} = Arg) when is_float(F) -> Arg;
+resolve_arg({literal,_} = Arg) -> Arg;
+resolve_arg(nil) -> nil.
+
+resolve_arg_unsigned({u,N}) when is_integer(N), N >= 0 -> N.
+
+resolve_arg_integer({i,N}) when is_integer(N) -> {integer,N}.
+
+%%-----------------------------------------------------------------------
+%% The purpose of the following is just to add a hook for future changes.
+%% Currently, field flags are numbers 1-2-4-8 and only two of these
+%% numbers (BSF_LITTLE 2 -- BSF_SIGNED 4) have a semantic significance;
+%% others are just hints for speeding up the execution; see "erl_bits.h".
+%%-----------------------------------------------------------------------
+
+decode_field_flags(FF) ->
+ {field_flags,FF}.
+
+%%-----------------------------------------------------------------------
+%% Private Utilities
+%%-----------------------------------------------------------------------
+
+mk_imports(ImportList) ->
+ gb_trees:from_orddict([{I,{extfunc,M,F,A}} || {I,M,F,A} <- ImportList]).
+
+mk_atoms(AtomList) ->
+ gb_trees:from_orddict(AtomList).
+
+mk_labels(LabelList) ->
+ gb_trees:from_orddict(LabelList).
+
+lookup(I, Imports) ->
+ gb_trees:get(I, Imports).
diff --git a/lib/compiler/src/beam_disasm.hrl b/lib/compiler/src/beam_disasm.hrl
new file mode 100644
index 0000000000..c2aca1199e
--- /dev/null
+++ b/lib/compiler/src/beam_disasm.hrl
@@ -0,0 +1,43 @@
+%% -*- erlang-indent-level: 4 -*-
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2007-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%
+%%
+%% Purpose: Exposes type definitions used also in other parts of
+%% the system (e.g. in the translation from Beam to Icode).
+
+%%
+%% XXX: THE FOLLOWING TYPE DECLARATION DOES NOT BELONG HERE...
+%%
+-type beam_instr() :: 'bs_init_writable' | 'fclearerror' | 'if_end'
+ | 'remove_message' | 'return' | 'send' | 'timeout'
+ | tuple(). %% XXX: Very underspecified - FIX THIS
+
+%%-----------------------------------------------------------------------
+%% Record definitions
+%%-----------------------------------------------------------------------
+
+-record(function, {name :: atom(),
+ arity :: byte(),
+ entry, %% unused ??
+ code = [] :: [beam_instr()]}).
+
+-record(beam_file, {module :: module(),
+ labeled_exports = [] :: [beam_lib:labeled_entry()],
+ attributes = [] :: [beam_lib:attrib_entry()],
+ compile_info = [] :: [beam_lib:compinfo_entry()],
+ code = [] :: [#function{}]}).
diff --git a/lib/compiler/src/beam_flatten.erl b/lib/compiler/src/beam_flatten.erl
new file mode 100644
index 0000000000..d9de7e2495
--- /dev/null
+++ b/lib/compiler/src/beam_flatten.erl
@@ -0,0 +1,154 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1999-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%
+%%
+%% Purpose : Converts intermediate assembly code to final format.
+
+-module(beam_flatten).
+
+-export([module/2]).
+
+-import(lists, [reverse/1,reverse/2]).
+
+module({Mod,Exp,Attr,Fs,Lc}, _Opt) ->
+ {ok,{Mod,Exp,Attr,[function(F) || F <- Fs],Lc}}.
+
+function({function,Name,Arity,CLabel,Is0}) ->
+ Is1 = block(Is0),
+ Is = opt(Is1),
+ {function,Name,Arity,CLabel,Is}.
+
+block(Is) ->
+ block(Is, []).
+
+block([{block,Is0}|Is1], Acc) -> block(Is1, norm_block(Is0, Acc));
+block([I|Is], Acc) -> block(Is, [I|Acc]);
+block([], Acc) -> reverse(Acc).
+
+norm_block([{set,[],[],{alloc,R,Alloc}}|Is], Acc0) ->
+ case insert_alloc_in_bs_init(Acc0, Alloc) of
+ impossible ->
+ norm_block(Is, reverse(norm_allocate(Alloc, R), Acc0));
+ Acc ->
+ norm_block(Is, Acc)
+ end;
+norm_block([I|Is], Acc) -> norm_block(Is, [norm(I)|Acc]);
+norm_block([], Acc) -> Acc.
+
+norm({set,[D],As,{bif,N,F}}) -> {bif,N,F,As,D};
+norm({set,[D],As,{alloc,R,{gc_bif,N,F}}}) -> {gc_bif,N,F,R,As,D};
+norm({set,[D],[S],move}) -> {move,S,D};
+norm({set,[D],[S],fmove}) -> {fmove,S,D};
+norm({set,[D],[S],fconv}) -> {fconv,S,D};
+norm({set,[D],[S1,S2],put_list}) -> {put_list,S1,S2,D};
+norm({set,[D],[],{put_tuple,A}}) -> {put_tuple,A,D};
+norm({set,[],[S],put}) -> {put,S};
+norm({set,[D],[],{put_string,L,S}}) -> {put_string,L,S,D};
+norm({set,[D],[S],{get_tuple_element,I}}) -> {get_tuple_element,S,I,D};
+norm({set,[],[S,D],{set_tuple_element,I}}) -> {set_tuple_element,S,D,I};
+norm({set,[D1,D2],[S],get_list}) -> {get_list,S,D1,D2};
+norm({set,[],[],remove_message}) -> remove_message;
+norm({set,[],[],fclearerror}) -> fclearerror;
+norm({set,[],[],fcheckerror}) -> {fcheckerror,{f,0}}.
+
+norm_allocate({_Zero,nostack,Nh,[]}, Regs) ->
+ [{test_heap,Nh,Regs}];
+norm_allocate({zero,0,Nh,[]}, Regs) ->
+ norm_allocate({nozero,0,Nh,[]}, Regs);
+norm_allocate({zero,Ns,0,[]}, Regs) ->
+ [{allocate_zero,Ns,Regs}];
+norm_allocate({zero,Ns,Nh,[]}, Regs) ->
+ [{allocate_heap_zero,Ns,Nh,Regs}];
+norm_allocate({nozero,Ns,0,Inits}, Regs) ->
+ [{allocate,Ns,Regs}|Inits];
+norm_allocate({nozero,Ns,Nh,Inits}, Regs) ->
+ [{allocate_heap,Ns,Nh,Regs}|Inits].
+
+%% insert_alloc_in_bs_init(ReverseInstructionStream, AllocationInfo) ->
+%% impossible | ReverseInstructionStream'
+%% A bs_init2/6 instruction should not be followed by a test heap instruction.
+%% Given the AllocationInfo from a test heap instruction, merge the
+%% allocation amounts into the previous bs_init2/6 instruction (if any).
+%%
+insert_alloc_in_bs_init([I|_]=Is, Alloc) ->
+ case is_bs_constructor(I) of
+ false -> impossible;
+ true -> insert_alloc_1(Is, Alloc, [])
+ end.
+
+insert_alloc_1([{bs_init2=Op,Fail,Bs,Ws1,Regs,F,Dst}|Is], {_,nostack,Ws2,[]}, Acc) ->
+ Al = beam_utils:combine_heap_needs(Ws1, Ws2),
+ I = {Op,Fail,Bs,Al,Regs,F,Dst},
+ reverse(Acc, [I|Is]);
+insert_alloc_1([{bs_init_bits=Op,Fail,Bs,Ws1,Regs,F,Dst}|Is], {_,nostack,Ws2,[]}, Acc) ->
+ Al = beam_utils:combine_heap_needs(Ws1, Ws2),
+ I = {Op,Fail,Bs,Al,Regs,F,Dst},
+ reverse(Acc, [I|Is]);
+insert_alloc_1([{bs_append,Fail,Sz,Ws1,Regs,U,Bin,Fl,Dst}|Is],
+ {_,nostack,Ws2,[]}, Acc) ->
+ Al = beam_utils:combine_heap_needs(Ws1, Ws2),
+ I = {bs_append,Fail,Sz,Al,Regs,U,Bin,Fl,Dst},
+ reverse(Acc, [I|Is]);
+insert_alloc_1([I|Is], Alloc, Acc) ->
+ insert_alloc_1(Is, Alloc, [I|Acc]).
+
+
+%% is_bs_constructor(Instruction) -> true|false.
+%% Test whether the instruction is a bit syntax construction
+%% instruction that can occur at the end of a bit syntax
+%% construction. (Since an empty binary would be expressed
+%% as a literal, the bs_init2/6 instruction will not occur
+%% at the end and therefore it is no need to test for it here.)
+%%
+is_bs_constructor({bs_put_integer,_,_,_,_,_}) -> true;
+is_bs_constructor({bs_put_utf8,_,_,_}) -> true;
+is_bs_constructor({bs_put_utf16,_,_,_}) -> true;
+is_bs_constructor({bs_put_utf32,_,_,_}) -> true;
+is_bs_constructor({bs_put_float,_,_,_,_,_}) -> true;
+is_bs_constructor({bs_put_binary,_,_,_,_,_}) -> true;
+is_bs_constructor({bs_put_string,_,_}) -> true;
+is_bs_constructor(_) -> false.
+
+%% opt(Is0) -> Is
+%% Simple peep-hole optimization to move a {move,Any,{x,0}} past
+%% any kill up to the next call instruction. (To give the loader
+%% an opportunity to combine the 'move' and the 'call' instructions.)
+%%
+opt(Is) ->
+ opt_1(Is, []).
+
+opt_1([{move,_,{x,0}}=I|Is0], Acc0) ->
+ case move_past_kill(Is0, I, Acc0) of
+ impossible -> opt_1(Is0, [I|Acc0]);
+ {Is,Acc} -> opt_1(Is, Acc)
+ end;
+opt_1([I|Is], Acc) ->
+ opt_1(Is, [I|Acc]);
+opt_1([], Acc) -> reverse(Acc).
+
+move_past_kill([{kill,Src}|_], {move,Src,_}, _) ->
+ impossible;
+move_past_kill([{kill,_}=I|Is], Move, Acc) ->
+ move_past_kill(Is, Move, [I|Acc]);
+move_past_kill([{trim,N,_}=I|Is], {move,Src,Dst}=Move, Acc) ->
+ case Src of
+ {y,Y} when Y < N-> impossible;
+ {y,Y} -> {Is,[{move,{y,Y-N},Dst},I|Acc]};
+ _ -> {Is,[Move,I|Acc]}
+ end;
+move_past_kill(Is, Move, Acc) ->
+ {Is,[Move|Acc]}.
diff --git a/lib/compiler/src/beam_jump.erl b/lib/compiler/src/beam_jump.erl
new file mode 100644
index 0000000000..739928f411
--- /dev/null
+++ b/lib/compiler/src/beam_jump.erl
@@ -0,0 +1,562 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1999-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%
+%%
+%%% Purpose : Optimise jumps and remove unreachable code.
+
+-module(beam_jump).
+
+-export([module/2,module_labels/1,
+ is_unreachable_after/1,is_exit_instruction/1,
+ remove_unused_labels/1,is_label_used_in/2]).
+
+%%% The following optimisations are done:
+%%%
+%%% (1) This code with two identical instruction sequences
+%%%
+%%% L1: <Instruction sequence>
+%%% L2:
+%%% . . .
+%%% L3: <Instruction sequence>
+%%% L4:
+%%%
+%%% can be replaced with
+%%%
+%%% L1: jump L3
+%%% L2:
+%%% . . .
+%%% L3: <Instruction sequence>
+%%% L4
+%%%
+%%% Note: The instruction sequence must end with an instruction
+%%% such as a jump that never transfers control to the instruction
+%%% following it.
+%%%
+%%% (2) case_end, if_end, and badmatch, and function calls that cause an
+%%% exit (such as calls to exit/1) are moved to the end of the function.
+%%% The purpose is to allow further optimizations at the place from
+%%% which the code was moved.
+%%%
+%%% (3) Any unreachable code is removed. Unreachable code is code
+%%% after jump, call_last and other instructions which never
+%%% transfer control to the following instruction. Code is
+%%% unreachable up to the next *referenced* label. Note that the
+%%% optimisations below might generate more possibilities for
+%%% removing unreachable code.
+%%%
+%%% (4) This code:
+%%% L1: jump L2
+%%% . . .
+%%% L2: ...
+%%%
+%%% will be changed to
+%%%
+%%% jump L2
+%%% . . .
+%%% L1:
+%%% L2: ...
+%%%
+%%% If the jump is unreachable, it will be removed according to (1).
+%%%
+%%% (5) In
+%%%
+%%% jump L1
+%%% L1:
+%%%
+%%% the jump (but not the label) will be removed.
+%%%
+%%% (6) If test instructions are used to skip a single jump instruction,
+%%% the test is inverted and the jump is eliminated (provided that
+%%% the test can be inverted). Example:
+%%%
+%%% is_eq L1 {x,1} {x,2}
+%%% jump L2
+%%% L1:
+%%%
+%%% will be changed to
+%%%
+%%% is_ne L2 {x,1} {x,2}
+%%% L1:
+%%%
+%%% Because there may be backward references to the label L1
+%%% (for instance from the wait_timeout/1 instruction), we will
+%%% always keep the label. (beam_clean will remove any unused
+%%% labels.)
+%%%
+%%% Note: This modules depends on (almost) all branches and jumps only
+%%% going forward, so that we can remove instructions (including definition
+%%% of labels) after any label that has not been referenced by the code
+%%% preceeding the labels. Regarding the few instructions that have backward
+%%% references to labels, we assume that they only transfer control back
+%%% to an instruction that has already been executed. That is, code such as
+%%%
+%%% jump L_entry
+%%%
+%%% L_again:
+%%% .
+%%% .
+%%% .
+%%% L_entry:
+%%% .
+%%% .
+%%% .
+%%% jump L_again;
+%%%
+%%% is NOT allowed (and such code is never generated by the code generator).
+%%%
+%%% Terminology note: The optimisation done here is called unreachable-code
+%%% removal, NOT dead-code elimination. Dead code elimination means the
+%%% removal of instructions that are executed, but have no visible effect
+%%% on the program state.
+%%%
+
+-import(lists, [reverse/1,reverse/2,foldl/3,dropwhile/2]).
+
+module({Mod,Exp,Attr,Fs0,Lc}, _Opt) ->
+ Fs = [function(F) || F <- Fs0],
+ {ok,{Mod,Exp,Attr,Fs,Lc}}.
+
+module_labels({Mod,Exp,Attr,Fs,Lc}) ->
+ {Mod,Exp,Attr,[function_labels(F) || F <- Fs],Lc}.
+
+function_labels({function,Name,Arity,CLabel,Asm0}) ->
+ Asm = remove_unused_labels(Asm0),
+ {function,Name,Arity,CLabel,Asm}.
+
+%% function(Function) -> Function'
+%% Optimize jumps and branches.
+%%
+%% NOTE: This function assumes that there are no labels inside blocks.
+function({function,Name,Arity,CLabel,Asm0}) ->
+ Asm1 = share(Asm0),
+ Asm2 = move(Asm1),
+ Asm3 = opt(Asm2, CLabel),
+ Asm = remove_unused_labels(Asm3),
+ {function,Name,Arity,CLabel,Asm}.
+
+%%%
+%%% (1) We try to share the code for identical code segments by replacing all
+%%% occurrences except the last with jumps to the last occurrence.
+%%%
+
+share(Is0) ->
+ %% We will get more sharing if we never fall through to a label.
+ Is = eliminate_fallthroughs(Is0, []),
+ share_1(Is, dict:new(), [], []).
+
+share_1([{label,_}=Lbl|Is], Dict, [], Acc) ->
+ share_1(Is, Dict, [], [Lbl|Acc]);
+share_1([{label,L}=Lbl|Is], Dict0, Seq, Acc) ->
+ case dict:find(Seq, Dict0) of
+ error ->
+ Dict = dict:store(Seq, L, Dict0),
+ share_1(Is, Dict, [], [Lbl|Seq ++ Acc]);
+ {ok,Label} ->
+ share_1(Is, Dict0, [], [Lbl,{jump,{f,Label}}|Acc])
+ end;
+share_1([{func_info,_,_,_}=I|Is], _, [], Acc) ->
+ Is++[I|Acc];
+share_1([I|Is], Dict, Seq, Acc) ->
+ case is_unreachable_after(I) of
+ false ->
+ share_1(Is, Dict, [I|Seq], Acc);
+ true ->
+ share_1(Is, Dict, [I], Acc)
+ end.
+
+
+%% Eliminate all fallthroughs. Return the result reversed.
+
+eliminate_fallthroughs([I,{label,L}=Lbl|Is], Acc) ->
+ case is_unreachable_after(I) orelse is_label(I) of
+ false ->
+ %% Eliminate fallthrough.
+ eliminate_fallthroughs(Is, [Lbl,{jump,{f,L}},I|Acc]);
+ true ->
+ eliminate_fallthroughs(Is, [Lbl,I|Acc])
+ end;
+eliminate_fallthroughs([I|Is], Acc) ->
+ eliminate_fallthroughs(Is, [I|Acc]);
+eliminate_fallthroughs([], Acc) -> Acc.
+
+is_label({label,_}) -> true;
+is_label(_) -> false.
+
+%%%
+%%% (2) Move short code sequences ending in an instruction that causes an exit
+%%% to the end of the function.
+%%%
+%%% Implementation note: Since share/1 eliminated fallthroughs to labels,
+%%% we don't have to test whether instructions before labels may fail through.
+%%%
+move(Is) ->
+ move_1(Is, [], []).
+
+move_1([I|Is], End, Acc) ->
+ case is_exit_instruction(I) of
+ false -> move_1(Is, End, [I|Acc]);
+ true -> move_2(I, Is, End, Acc)
+ end;
+move_1([], End, Acc) ->
+ reverse(Acc, reverse(End)).
+
+move_2(Exit, Is, End, [{block,_},{label,_},{func_info,_,_,_}|_]=Acc) ->
+ move_1(Is, End, [Exit|Acc]);
+move_2(Exit, Is, End, [{block,_}=Blk,{label,_}=Lbl,Unreachable|More]) ->
+ move_1([Unreachable|Is], [Exit,Blk,Lbl|End], More);
+move_2(Exit, Is, End, [{bs_context_to_binary,_}=Bs,{label,_}=Lbl,
+ Unreachable|More]) ->
+ move_1([Unreachable|Is], [Exit,Bs,Lbl|End], More);
+move_2(Exit, Is, End, [{label,_}=Lbl,Unreachable|More]) ->
+ move_1([Unreachable|Is], [Exit,Lbl|End], More);
+move_2(Exit, Is, End, Acc) ->
+ move_1(Is, End, [Exit|Acc]).
+
+%%%
+%%% (3) (4) (5) (6) Jump and unreachable code optimizations.
+%%%
+
+-record(st, {fc, %Label for function class errors.
+ entry, %Entry label (must not be moved).
+ mlbl, %Moved labels.
+ labels %Set of referenced labels.
+ }).
+
+opt([{label,Fc}|_]=Is0, CLabel) ->
+ Lbls = initial_labels(Is0),
+ find_fixpoint(fun(Is) ->
+ St = #st{fc=Fc,entry=CLabel,mlbl=dict:new(),
+ labels=Lbls},
+ opt(Is, [], St)
+ end, Is0).
+
+find_fixpoint(OptFun, Is0) ->
+ case OptFun(Is0) of
+ Is0 -> Is0;
+ Is -> find_fixpoint(OptFun, Is)
+ end.
+
+opt([{test,Test0,{f,Lnum}=Lbl,Ops}=I|Is0], Acc, St) ->
+ case Is0 of
+ [{jump,{f,Lnum}}|Is] ->
+ %% We have
+ %% Test Label Ops
+ %% jump Label
+ %% The test instruction is definitely not needed.
+ %% The jump instruction is not needed if there is
+ %% a definition of Label following the jump instruction.
+ case is_label_defined(Is, Lnum) of
+ false ->
+ %% The jump instruction is still needed.
+ opt(Is0, [I|Acc], label_used(Lbl, St));
+ true ->
+ %% Neither the test nor the jump are needed.
+ opt(Is, Acc, St)
+ end;
+ [{jump,To}|Is] ->
+ case is_label_defined(Is, Lnum) of
+ false ->
+ opt(Is0, [I|Acc], label_used(Lbl, St));
+ true ->
+ case invert_test(Test0) of
+ not_possible ->
+ opt(Is0, [I|Acc], label_used(Lbl, St));
+ Test ->
+ opt([{test,Test,To,Ops}|Is], Acc, St)
+ end
+ end;
+ _Other ->
+ opt(Is0, [I|Acc], label_used(Lbl, St))
+ end;
+opt([{test,_,{f,_}=Lbl,_,_,_}=I|Is], Acc, St) ->
+ opt(Is, [I|Acc], label_used(Lbl, St));
+opt([{select_val,_R,Fail,{list,Vls}}=I|Is], Acc, St) ->
+ skip_unreachable(Is, [I|Acc], label_used([Fail|Vls], St));
+opt([{select_tuple_arity,_R,Fail,{list,Vls}}=I|Is], Acc, St) ->
+ skip_unreachable(Is, [I|Acc], label_used([Fail|Vls], St));
+opt([{label,L}=I|Is], Acc, #st{entry=L}=St) ->
+ %% NEVER move the entry label.
+ opt(Is, [I|Acc], St);
+opt([{label,L1},{jump,{f,L2}}=I|Is], [Prev|Acc], St0) ->
+ St = St0#st{mlbl=dict:append(L2, L1, St0#st.mlbl)},
+ opt([Prev,I|Is], Acc, label_used({f,L2}, St));
+opt([{label,Lbl}=I|Is], Acc, #st{mlbl=Mlbl}=St0) ->
+ case dict:find(Lbl, Mlbl) of
+ {ok,Lbls} ->
+ %% Essential to remove the list of labels from the dictionary,
+ %% since we will rescan the inserted labels. We MUST rescan.
+ St = St0#st{mlbl=dict:erase(Lbl, Mlbl)},
+ insert_labels([Lbl|Lbls], Is, Acc, St);
+ error -> opt(Is, [I|Acc], St0)
+ end;
+opt([{jump,{f,Lbl}},{label,Lbl}=I|Is], Acc, St) ->
+ opt([I|Is], Acc, St);
+opt([{jump,Lbl}=I|Is], Acc, St) ->
+ skip_unreachable(Is, [I|Acc], label_used(Lbl, St));
+%% Optimization: quickly handle some common instructions that don't
+%% have any failure labels and where is_unreachable_after(I) =:= false.
+opt([{block,_}=I|Is], Acc, St) ->
+ opt(Is, [I|Acc], St);
+opt([{kill,_}=I|Is], Acc, St) ->
+ opt(Is, [I|Acc], St);
+opt([{call,_,_}=I|Is], Acc, St) ->
+ opt(Is, [I|Acc], St);
+opt([{deallocate,_}=I|Is], Acc, St) ->
+ opt(Is, [I|Acc], St);
+%% All other instructions.
+opt([I|Is], Acc, #st{labels=Used0}=St0) ->
+ Used = ulbl(I, Used0),
+ St = St0#st{labels=Used},
+ case is_unreachable_after(I) of
+ true -> skip_unreachable(Is, [I|Acc], St);
+ false -> opt(Is, [I|Acc], St)
+ end;
+opt([], Acc, #st{fc=Fc,mlbl=Mlbl}) ->
+ Code = reverse(Acc),
+ case dict:find(Fc, Mlbl) of
+ {ok,Lbls} -> insert_fc_labels(Lbls, Mlbl, Code);
+ error -> Code
+ end.
+
+insert_fc_labels([L|Ls], Mlbl, Acc0) ->
+ Acc = [{label,L}|Acc0],
+ case dict:find(L, Mlbl) of
+ error ->
+ insert_fc_labels(Ls, Mlbl, Acc);
+ {ok,Lbls} ->
+ insert_fc_labels(Lbls++Ls, Mlbl, Acc)
+ end;
+insert_fc_labels([], _, Acc) -> Acc.
+
+%% label_defined(Is, Label) -> true | false.
+%% Test whether the label Label is defined at the start of the instruction
+%% sequence, possibly preceeded by other label definitions.
+%%
+is_label_defined([{label,L}|_], L) -> true;
+is_label_defined([{label,_}|Is], L) -> is_label_defined(Is, L);
+is_label_defined(_, _) -> false.
+
+%% invert_test(Test0) -> not_possible | Test
+
+invert_test(is_ge) -> is_lt;
+invert_test(is_lt) -> is_ge;
+invert_test(is_eq) -> is_ne;
+invert_test(is_ne) -> is_eq;
+invert_test(is_eq_exact) -> is_ne_exact;
+invert_test(is_ne_exact) -> is_eq_exact;
+invert_test(_) -> not_possible.
+
+insert_labels([L|Ls], Is, [{jump,{f,L}}|Acc], St) ->
+ insert_labels(Ls, [{label,L}|Is], Acc, St);
+insert_labels([L|Ls], Is, Acc, St) ->
+ insert_labels(Ls, [{label,L}|Is], Acc, St);
+insert_labels([], Is, Acc, St) ->
+ opt(Is, Acc, St).
+
+%% skip_unreachable([Instruction], St).
+%% Remove all instructions (including definitions of labels
+%% that have not been referenced yet) up to the next
+%% referenced label, then call opt/3 to optimize the rest
+%% of the instruction sequence.
+%%
+skip_unreachable([{label,L}|_Is]=Is0, [{jump,{f,L}}|Acc], St) ->
+ opt(Is0, Acc, St);
+skip_unreachable([{label,L}|Is]=Is0, Acc, St) ->
+ case is_label_used(L, St) of
+ true -> opt(Is0, Acc, St);
+ false -> skip_unreachable(Is, Acc, St)
+ end;
+skip_unreachable([_|Is], Acc, St) ->
+ skip_unreachable(Is, Acc, St);
+skip_unreachable([], Acc, St) ->
+ opt([], Acc, St).
+
+%% Add one or more label to the set of used labels.
+
+label_used({f,L}, St) -> St#st{labels=gb_sets:add(L, St#st.labels)};
+label_used([H|T], St0) -> label_used(T, label_used(H, St0));
+label_used([], St) -> St;
+label_used(_Other, St) -> St.
+
+%% Test if label is used.
+
+is_label_used(L, St) ->
+ gb_sets:is_member(L, St#st.labels).
+
+%% is_unreachable_after(Instruction) -> boolean()
+%% Test whether the code after Instruction is unreachable.
+
+is_unreachable_after({func_info,_M,_F,_A}) -> true;
+is_unreachable_after(return) -> true;
+is_unreachable_after({call_ext_last,_Ar,_ExtFunc,_D}) -> true;
+is_unreachable_after({call_ext_only,_Ar,_ExtFunc}) -> true;
+is_unreachable_after({call_last,_Ar,_Lbl,_D}) -> true;
+is_unreachable_after({call_only,_Ar,_Lbl}) -> true;
+is_unreachable_after({apply_last,_Ar,_N}) -> true;
+is_unreachable_after({jump,_Lbl}) -> true;
+is_unreachable_after({select_val,_R,_Lbl,_Cases}) -> true;
+is_unreachable_after({select_tuple_arity,_R,_Lbl,_Cases}) -> true;
+is_unreachable_after({loop_rec_end,_}) -> true;
+is_unreachable_after({wait,_}) -> true;
+is_unreachable_after(I) -> is_exit_instruction(I).
+
+%% is_exit_instruction(Instruction) -> boolean()
+%% Test whether the instruction Instruction always
+%% causes an exit/failure.
+
+is_exit_instruction({call_ext,_,{extfunc,M,F,A}}) ->
+ erl_bifs:is_exit_bif(M, F, A);
+is_exit_instruction({call_ext_last,_,{extfunc,M,F,A},_}) ->
+ erl_bifs:is_exit_bif(M, F, A);
+is_exit_instruction({call_ext_only,_,{extfunc,M,F,A}}) ->
+ erl_bifs:is_exit_bif(M, F, A);
+is_exit_instruction(if_end) -> true;
+is_exit_instruction({case_end,_}) -> true;
+is_exit_instruction({try_case_end,_}) -> true;
+is_exit_instruction({badmatch,_}) -> true;
+is_exit_instruction(_) -> false.
+
+%% is_label_used_in(LabelNumber, [Instruction]) -> boolean()
+%% Check whether the label is used in the instruction sequence
+%% (including inside blocks).
+
+is_label_used_in(Lbl, Is) ->
+ is_label_used_in_1(Is, Lbl, gb_sets:empty()).
+
+is_label_used_in_1([{block,Block}|Is], Lbl, Empty) ->
+ lists:any(fun(I) -> is_label_used_in_2(I, Lbl) end, Block)
+ orelse is_label_used_in_1(Is, Lbl, Empty);
+is_label_used_in_1([I|Is], Lbl, Empty) ->
+ Used = ulbl(I, Empty),
+ gb_sets:is_member(Lbl, Used) orelse is_label_used_in_1(Is, Lbl, Empty);
+is_label_used_in_1([], _, _) -> false.
+
+is_label_used_in_2({set,_,_,Info}, Lbl) ->
+ case Info of
+ {bif,_,{f,F}} -> F =:= Lbl;
+ {alloc,_,{gc_bif,_,{f,F}}} -> F =:= Lbl;
+ {'catch',{f,F}} -> F =:= Lbl;
+ {alloc,_,_} -> false;
+ {put_tuple,_} -> false;
+ {put_string,_,_} -> false;
+ {get_tuple_element,_} -> false;
+ {set_tuple_element,_} -> false;
+ _ when is_atom(Info) -> false
+ end.
+
+%% remove_unused_labels(Instructions0) -> Instructions
+%% Remove all unused labels. Also remove unreachable
+%% instructions following labels that are removed.
+
+remove_unused_labels(Is) ->
+ Used0 = initial_labels(Is),
+ Used = foldl(fun ulbl/2, Used0, Is),
+ rem_unused(Is, Used, []).
+
+rem_unused([{label,Lbl}=I|Is0], Used, [Prev|_]=Acc) ->
+ case gb_sets:is_member(Lbl, Used) of
+ false ->
+ Is = case is_unreachable_after(Prev) of
+ true ->
+ dropwhile(fun({label,_}) -> false;
+ (_) -> true
+ end, Is0);
+ false -> Is0
+ end,
+ rem_unused(Is, Used, Acc);
+ true ->
+ rem_unused(Is0, Used, [I|Acc])
+ end;
+rem_unused([I|Is], Used, Acc) ->
+ rem_unused(Is, Used, [I|Acc]);
+rem_unused([], _, Acc) -> reverse(Acc).
+
+initial_labels(Is) ->
+ initial_labels(Is, []).
+
+initial_labels([{label,Lbl}|Is], Acc) ->
+ initial_labels(Is, [Lbl|Acc]);
+initial_labels([{func_info,_,_,_},{label,Lbl}|_], Acc) ->
+ gb_sets:from_list([Lbl|Acc]).
+
+%% ulbl(Instruction, UsedGbSet) -> UsedGbSet'
+%% Update the gb_set UsedGbSet with any function-local labels
+%% (i.e. not with labels in call instructions) referenced by
+%% the instruction Instruction.
+%%
+%% NOTE: This function does NOT look for labels inside blocks.
+
+ulbl({test,_,Fail,_}, Used) ->
+ mark_used(Fail, Used);
+ulbl({test,_,Fail,_,_,_}, Used) ->
+ mark_used(Fail, Used);
+ulbl({select_val,_,Fail,{list,Vls}}, Used) ->
+ mark_used_list(Vls, mark_used(Fail, Used));
+ulbl({select_tuple_arity,_,Fail,{list,Vls}}, Used) ->
+ mark_used_list(Vls, mark_used(Fail, Used));
+ulbl({'try',_,Lbl}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({'catch',_,Lbl}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({jump,Lbl}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({loop_rec,Lbl,_}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({loop_rec_end,Lbl}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({wait,Lbl}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({wait_timeout,Lbl,_To}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({bif,_Name,Lbl,_As,_R}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({gc_bif,_Name,Lbl,_Live,_As,_R}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({bs_init2,Lbl,_,_,_,_,_}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({bs_init_bits,Lbl,_,_,_,_,_}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({bs_put_integer,Lbl,_Bits,_Unit,_Fl,_Val}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({bs_put_float,Lbl,_Bits,_Unit,_Fl,_Val}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({bs_put_binary,Lbl,_Bits,_Unit,_Fl,_Val}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({bs_put_utf8,Lbl,_Fl,_Val}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({bs_put_utf16,Lbl,_Fl,_Val}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({bs_put_utf32,Lbl,_Fl,_Val}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({bs_add,Lbl,_,_}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({bs_append,Lbl,_,_,_,_,_,_,_}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({bs_utf8_size,Lbl,_,_}, Used) ->
+ mark_used(Lbl, Used);
+ulbl({bs_utf16_size,Lbl,_,_}, Used) ->
+ mark_used(Lbl, Used);
+ulbl(_, Used) -> Used.
+
+mark_used({f,0}, Used) -> Used;
+mark_used({f,L}, Used) -> gb_sets:add(L, Used).
+
+mark_used_list([{f,L}|T], Used) ->
+ mark_used_list(T, gb_sets:add(L, Used));
+mark_used_list([_|T], Used) ->
+ mark_used_list(T, Used);
+mark_used_list([], Used) -> Used.
diff --git a/lib/compiler/src/beam_listing.erl b/lib/compiler/src/beam_listing.erl
new file mode 100644
index 0000000000..be7b14c3dd
--- /dev/null
+++ b/lib/compiler/src/beam_listing.erl
@@ -0,0 +1,119 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1997-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+%%
+-module(beam_listing).
+
+-export([module/2]).
+
+-include("v3_life.hrl").
+
+-import(lists, [foreach/2]).
+
+module(File, Core) when element(1, Core) == c_module ->
+ %% This is a core module.
+ io:put_chars(File, core_pp:format(Core));
+module(File, Kern) when element(1, Kern) == k_mdef ->
+ %% This is a kernel module.
+ io:put_chars(File, v3_kernel_pp:format(Kern));
+ %%io:put_chars(File, io_lib:format("~p~n", [Kern]));
+module(File, {Mod,Exp,Attr,Kern}) ->
+ %% This is output from beam_life (v3).
+ io:fwrite(File, "~w.~n~p.~n~p.~n", [Mod,Exp,Attr]),
+ foreach(fun (F) -> function(File, F) end, Kern);
+module(Stream, {Mod,Exp,Attr,Code,NumLabels}) ->
+ %% This is output from beam_codegen.
+ io:format(Stream, "{module, ~p}. %% version = ~w\n",
+ [Mod, beam_opcodes:format_number()]),
+ io:format(Stream, "\n{exports, ~p}.\n", [Exp]),
+ io:format(Stream, "\n{attributes, ~p}.\n", [Attr]),
+ io:format(Stream, "\n{labels, ~p}.\n", [NumLabels]),
+ foreach(
+ fun ({function,Name,Arity,Entry,Asm}) ->
+ io:format(Stream, "\n\n{function, ~w, ~w, ~w}.\n",
+ [Name, Arity, Entry]),
+ foreach(fun(Op) -> print_op(Stream, Op) end, Asm) end,
+ Code);
+module(Stream, {Mod,Exp,Inter}) ->
+ %% Other kinds of intermediate formats.
+ io:fwrite(Stream, "~w.~n~p.~n", [Mod,Exp]),
+ foreach(fun (F) -> io:format(Stream, "~p.\n", [F]) end, Inter);
+module(Stream, [_|_]=Fs) ->
+ %% Form-based abstract format.
+ foreach(fun (F) -> io:format(Stream, "~p.\n", [F]) end, Fs).
+
+print_op(Stream, Label) when element(1, Label) == label ->
+ io:format(Stream, " ~p.\n", [Label]);
+print_op(Stream, Op) ->
+ io:format(Stream, " ~p.\n", [Op]).
+
+function(File, {function,Name,Arity,Args,Body,Vdb}) ->
+ io:nl(File),
+ io:format(File, "function ~p/~p.\n", [Name,Arity]),
+ io:format(File, " ~p.\n", [Args]),
+ print_vdb(File, Vdb),
+ put(beam_listing_nl, false),
+ nl(File),
+ foreach(fun(F) -> format(File, F, []) end, Body),
+ nl(File),
+ erase(beam_listing_nl).
+
+format(File, #l{ke=Ke,i=I,vdb=Vdb}, Ind) ->
+ nl(File),
+ ind_format(File, Ind, "~p ", [I]),
+ print_vdb(File, Vdb),
+ nl(File),
+ format(File, Ke, Ind);
+format(File, Tuple, Ind) when is_tuple(Tuple) ->
+ ind_format(File, Ind, "{", []),
+ format_list(File, tuple_to_list(Tuple), [$\s|Ind]),
+ ind_format(File, Ind, "}", []);
+format(File, List, Ind) when is_list(List) ->
+ ind_format(File, Ind, "[", []),
+ format_list(File, List, [$\s|Ind]),
+ ind_format(File, Ind, "]", []);
+format(File, F, Ind) ->
+ ind_format(File, Ind, "~p", [F]).
+
+format_list(File, [F], Ind) ->
+ format(File, F, Ind);
+format_list(File, [F|Fs], Ind) ->
+ format(File, F, Ind),
+ ind_format(File, Ind, ",", []),
+ format_list(File, Fs, Ind);
+format_list(_, [], _) -> ok.
+
+
+print_vdb(File, [{Var,F,E}|Vs]) ->
+ io:format(File, "~p:~p..~p ", [Var,F,E]),
+ print_vdb(File, Vs);
+print_vdb(_, []) -> ok.
+
+ind_format(File, Ind, Format, Args) ->
+ case get(beam_listing_nl) of
+ true ->
+ put(beam_listing_nl, false),
+ io:put_chars(File, Ind);
+ false -> ok
+ end,
+ io:format(File, Format, Args).
+
+nl(File) ->
+ case put(beam_listing_nl, true) of
+ true -> ok;
+ false -> io:nl(File)
+ end.
diff --git a/lib/compiler/src/beam_peep.erl b/lib/compiler/src/beam_peep.erl
new file mode 100644
index 0000000000..d03ac4b1f4
--- /dev/null
+++ b/lib/compiler/src/beam_peep.erl
@@ -0,0 +1,191 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2008-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+%%
+
+-module(beam_peep).
+
+-export([module/2]).
+
+-import(lists, [reverse/1,member/2]).
+
+module({Mod,Exp,Attr,Fs0,_}, _Opts) ->
+ %% First coalesce adjacent labels.
+ {Fs1,Lc} = beam_clean:clean_labels(Fs0),
+
+ %% Do the peep hole optimizations.
+ Fs = [function(F) || F <- Fs1],
+ {ok,{Mod,Exp,Attr,Fs,Lc}}.
+
+function({function,Name,Arity,CLabel,Is0}) ->
+ try
+ Is1 = peep(Is0),
+ Is = beam_jump:remove_unused_labels(Is1),
+ {function,Name,Arity,CLabel,Is}
+ catch
+ Class:Error ->
+ Stack = erlang:get_stacktrace(),
+ io:fwrite("Function: ~w/~w\n", [Name,Arity]),
+ erlang:raise(Class, Error, Stack)
+ end.
+
+
+%% Peep-hole optimizations suitable to perform when most of the
+%% optimations passes have been run.
+%%
+%% (1) In a sequence of tests, we can remove any test instruction
+%% that has been previously seen, because it will certainly
+%% succeed.
+%%
+%% For instance, in the following code sequence
+%%
+%% is_eq_exact _Fail SomeRegister SomeLiteral
+%% is_ne_exact _Fail SomeOtherRegister SomeOtherLiteral
+%% is_eq_exact _Fail SomeRegister SomeLiteral
+%% is_ne_exact _Fail SomeOtherRegister StillSomeOtherLiteral
+%%
+%% the third test is redundant. The code sequence will be produced
+%% by a combination of semicolon and command guards, such as
+%%
+%% InEncoding =:= latin1, OutEncoding =:= unicode;
+%% InEncoding =:= latin1, OutEncoding =:= utf8 ->
+%%
+%% (2) Code like
+%%
+%% is_ne_exact Fail Reg Literal1
+%% is_ne_exact Fail Reg Literal2
+%% is_ne_exact Fail Reg Literal3
+%% is_eq_exact UltimateFail Reg Literal4
+%% Fail: ....
+%%
+%% can be rewritten to
+%%
+%% select_val Reg UltimateFail [ Literal1 Fail
+%% Literal2 Fail
+%% Literal3 Fail
+%% Literal4 Fail ]
+%%
+%% (3) A select_val/4 instruction that only verifies that
+%% its argument is either 'true' or 'false' can be
+%% be replaced with an is_boolean/2 instruction. That is:
+%%
+%% select_val Reg Fail [ true Next false Next ]
+%% Next: ...
+%%
+%% can be rewritten to
+%%
+%% is_boolean Fail Reg
+%% Next: ...
+%%
+
+peep(Is) ->
+ peep(Is, gb_sets:empty(), []).
+
+peep([{bif,tuple_size,_,[_]=Ops,Dst}=I|Is], SeenTests0, Acc) ->
+ %% Pretend that we have seen {test,is_tuple,_,Ops}.
+ SeenTests1 = gb_sets:add({is_tuple,Ops}, SeenTests0),
+ %% Kill all remembered tests that depend on the destination register.
+ SeenTests = kill_seen(Dst, SeenTests1),
+ peep(Is, SeenTests, [I|Acc]);
+peep([{bif,_,_,_,Dst}=I|Is], SeenTests0, Acc) ->
+ %% Kill all remembered tests that depend on the destination register.
+ SeenTests = kill_seen(Dst, SeenTests0),
+ peep(Is, SeenTests, [I|Acc]);
+peep([{gc_bif,_,_,_,_,Dst}=I|Is], SeenTests0, Acc) ->
+ %% Kill all remembered tests that depend on the destination register.
+ SeenTests = kill_seen(Dst, SeenTests0),
+ peep(Is, SeenTests, [I|Acc]);
+peep([{test,is_boolean,{f,Fail},Ops}|_]=Is, SeenTests,
+ [{test,is_atom,{f,Fail},Ops}|Acc]) ->
+ %% The previous is_atom/2 test (with the same failure label) is redundant.
+ %% (If is_boolean(Src) is true, is_atom(Src) is also true, so it is
+ %% OK to still remember that we have seen is_atom/1.)
+ peep(Is, SeenTests, Acc);
+peep([{test,Op,_,Ops}=I|Is], SeenTests0, Acc) ->
+ case beam_utils:is_pure_test(I) of
+ false ->
+ %% Bit syntax matching, which may modify registers and/or
+ %% match state. Clear all information about tests that
+ %% has succeeded.
+ peep(Is, gb_sets:empty(), [I|Acc]);
+ true ->
+ Test = {Op,Ops},
+ case gb_sets:is_element(Test, SeenTests0) of
+ true ->
+ %% This test has already succeeded and
+ %% is therefore redundant.
+ peep(Is, SeenTests0, Acc);
+ false ->
+ %% Remember that we have seen this test.
+ SeenTests = gb_sets:insert(Test, SeenTests0),
+ make_select_val(I, Is, SeenTests, Acc)
+ end
+ end;
+peep([{select_val,Src,Fail,
+ {list,[{atom,false},{f,L},{atom,true},{f,L}]}}|
+ [{label,L}|_]=Is], SeenTests, Acc) ->
+ I = {test,is_boolean,Fail,[Src]},
+ peep([I|Is], SeenTests, Acc);
+peep([{select_val,Src,Fail,
+ {list,[{atom,true},{f,L},{atom,false},{f,L}]}}|
+ [{label,L}|_]=Is], SeenTests, Acc) ->
+ I = {test,is_boolean,Fail,[Src]},
+ peep([I|Is], SeenTests, Acc);
+peep([I|Is], _, Acc) ->
+ %% An unknown instruction. Throw away all information we
+ %% have collected about test instructions.
+ peep(Is, gb_sets:empty(), [I|Acc]);
+peep([], _, Acc) -> reverse(Acc).
+
+make_select_val({test,is_ne_exact,{f,Fail},[Val,Lit]}=I0,
+ Is0, SeenTests, Acc) ->
+ try
+ Type = case Lit of
+ {atom,_} -> atom;
+ {integer,_} -> integer;
+ _ -> throw(impossible)
+ end,
+ {I,Is} = make_select_val_1(Is0, Fail, Val, Type, [Lit,{f,Fail}]),
+ peep([I|Is], SeenTests, Acc)
+ catch
+ impossible ->
+ peep(Is0, SeenTests, [I0|Acc])
+ end;
+make_select_val(I, Is, SeenTests, Acc) ->
+ peep(Is, SeenTests, [I|Acc]).
+
+make_select_val_1([{test,is_ne_exact,{f,Fail},[Val,{Type,_}=Lit]}|Is],
+ Fail, Val, Type, Acc) ->
+ make_select_val_1(Is, Fail, Val, Type, [Lit,{f,Fail}|Acc]);
+make_select_val_1([{test,is_eq_exact,{f,UltimateFail},[Val,{Type,_}=Lit]} |
+ [{label,Fail}|_]=Is], Fail, Val, Type, Acc) ->
+ Choices = [Lit,{f,Fail}|Acc],
+ I = {select_val,Val,{f,UltimateFail},{list,Choices}},
+ {I,Is};
+make_select_val_1(_Is, _Fail, _Val, _Type, _Acc) -> throw(impossible).
+
+kill_seen(Dst, Seen0) ->
+ gb_sets:from_ordset(kill_seen_1(gb_sets:to_list(Seen0), Dst)).
+
+kill_seen_1([{_,Ops}=Test|T], Dst) ->
+ case member(Dst, Ops) of
+ true -> kill_seen_1(T, Dst);
+ false -> [Test|kill_seen_1(T, Dst)]
+ end;
+kill_seen_1([], _) -> [].
+
+
diff --git a/lib/compiler/src/beam_trim.erl b/lib/compiler/src/beam_trim.erl
new file mode 100644
index 0000000000..790aba0a9a
--- /dev/null
+++ b/lib/compiler/src/beam_trim.erl
@@ -0,0 +1,332 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2007-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+%%
+
+-module(beam_trim).
+-export([module/2]).
+
+-import(lists, [reverse/1,reverse/2,splitwith/2,sort/1]).
+
+-record(st,
+ {safe, %Safe labels.
+ lbl %Code at each label.
+ }).
+
+module({Mod,Exp,Attr,Fs0,Lc}, _Opts) ->
+ Fs = [function(F) || F <- Fs0],
+ {ok,{Mod,Exp,Attr,Fs,Lc}}.
+
+function({function,Name,Arity,CLabel,Is0}) ->
+ %%ok = io:fwrite("~w: ~p\n", [?LINE,{Name,Arity}]),
+ St = #st{safe=safe_labels(Is0, []),lbl=beam_utils:index_labels(Is0)},
+ Is = trim(Is0, St, []),
+ {function,Name,Arity,CLabel,Is}.
+
+trim([{kill,_}|_]=Is0, St, Acc) ->
+ {Kills0,Is1} = splitwith(fun({kill,_}) -> true;
+ (_) -> false
+ end, Is0),
+ Kills = sort(Kills0),
+ try
+ {FrameSize,Layout} = frame_layout(Is1, Kills, St),
+ Configs = trim_instructions(Layout),
+ try_remap(Configs, Is1, FrameSize)
+ of
+ {Is,TrimInstr} ->
+ trim(Is, St, reverse(TrimInstr)++Acc)
+ catch
+ not_possible ->
+ trim(Is1, St, reverse(Kills, Acc))
+ end;
+trim([I|Is], St, Acc) ->
+ trim(Is, St, [I|Acc]);
+trim([], _, Acc) ->
+ reverse(Acc).
+
+%% trim_instructions([{kill,R}|{live,R}|{dead,R}]) -> {[Instruction],MapFun}
+%% Figure out the sequence of moves and trim to use.
+
+trim_instructions(Layout) ->
+ Cost = length([I || {kill,_}=I <- Layout]),
+ trim_instructions_1(Layout, 0, [], {Cost,[]}).
+
+trim_instructions_1([{kill,{y,Trim0}}|Ks], Trim0, Moves, Config0) ->
+ Trim = Trim0 + 1,
+ Config = save_config(Ks, Trim, Moves, Config0),
+ trim_instructions_1(Ks, Trim, Moves, Config);
+trim_instructions_1([{dead,{y,Trim0}}|Ks], Trim0, Moves, Config0) ->
+ Trim = Trim0 + 1,
+ Config = save_config(Ks, Trim, Moves, Config0),
+ trim_instructions_1(Ks, Trim, Moves, Config);
+trim_instructions_1([{live,{y,Trim0}=Src}|Ks0], Trim0, Moves0, Config0) ->
+ case take_last_dead(Ks0) of
+ none ->
+ {_,ConfigList} = Config0,
+ ConfigList;
+ {Dst,Ks} ->
+ Trim = Trim0 + 1,
+ Moves = [{move,Src,Dst}|Moves0],
+ Config = save_config(Ks, Trim, Moves, Config0),
+ trim_instructions_1(Ks, Trim, Moves, Config)
+ end;
+trim_instructions_1([], _, _, {_,ConfigList}) ->
+ ConfigList.
+
+take_last_dead(L) ->
+ take_last_dead_1(reverse(L)).
+
+take_last_dead_1([{kill,Reg}|Is]) ->
+ {Reg,reverse(Is)};
+take_last_dead_1([{dead,Reg}|Is]) ->
+ {Reg,reverse(Is)};
+take_last_dead_1(_) -> none.
+
+save_config(Ks, Trim, Moves, {MaxCost,Acc}=Config) ->
+ case config_cost(Ks, Moves) of
+ Cost when Cost =< MaxCost ->
+ {MaxCost,[{Ks,Trim,Moves}|Acc]};
+ _Cost ->
+ Config
+ end.
+
+config_cost(Ks, Moves) ->
+ %% We estimate that a {move,{y,_},{y,_}} instruction is roughly twice as
+ %% expensive as a {kill,{y,_}} instruction. A {trim,_} instruction is
+ %% roughly as expensive as a {kill,{y,_}} instruction.
+
+ config_cost_1(Ks, 1+2*length(Moves)).
+
+config_cost_1([{kill,_}|Ks], Cost) ->
+ config_cost_1(Ks, Cost+1);
+config_cost_1([_|Ks], Cost) ->
+ config_cost_1(Ks, Cost);
+config_cost_1([], Cost) -> Cost.
+
+expand_config({Layout,Trim,Moves}, FrameSize) ->
+ Kills = [Kill || {kill,_}=Kill <- Layout],
+ {Kills++reverse(Moves, [{trim,Trim,FrameSize-Trim}]),create_map(Trim, Moves)}.
+
+create_map(Trim, []) ->
+ fun({y,Y}) when Y < Trim -> throw(not_possible);
+ ({y,Y}) -> {y,Y-Trim};
+ ({frame_size,N}) -> N - Trim;
+ (Any) -> Any
+ end;
+create_map(Trim, Moves) ->
+ GbTree0 = [{Src,Dst-Trim} || {move,{y,Src},{y,Dst}} <- Moves],
+ GbTree = gb_trees:from_orddict(sort(GbTree0)),
+ IllegalTargets = gb_sets:from_list([Dst || {move,_,{y,Dst}} <- Moves]),
+ fun({y,Y0}) when Y0 < Trim ->
+ case gb_trees:lookup(Y0, GbTree) of
+ {value,Y} -> {y,Y};
+ none -> throw(not_possible)
+ end;
+ ({y,Y}) ->
+ case gb_sets:is_element(Y, IllegalTargets) of
+ true -> throw(not_possible);
+ false -> {y,Y-Trim}
+ end;
+ ({frame_size,N}) -> N - Trim;
+ (Any) -> Any
+ end.
+
+try_remap([C|Cs], Is, FrameSize) ->
+ {TrimInstr,Map} = expand_config(C, FrameSize),
+ try
+ {remap(Is, Map, []),TrimInstr}
+ catch
+ throw:not_possible ->
+ try_remap(Cs, Is, FrameSize)
+ end;
+try_remap([], _, _) -> throw(not_possible).
+
+remap([{block,Bl0}|Is], Map, Acc) ->
+ Bl = remap_block(Bl0, Map, []),
+ remap(Is, Map, [{block,Bl}|Acc]);
+remap([{call_fun,_}=I|Is], Map, Acc) ->
+ remap(Is, Map, [I|Acc]);
+remap([{call,_,_}=I|Is], Map, Acc) ->
+ remap(Is, Map, [I|Acc]);
+remap([{call_ext,_,_}=I|Is], Map, Acc) ->
+ remap(Is, Map, [I|Acc]);
+remap([{apply,_}=I|Is], Map, Acc) ->
+ remap(Is, Map, [I|Acc]);
+remap([{bif,Name,Fail,Ss,D}|Is], Map, Acc) ->
+ I = {bif,Name,Fail,[Map(S) || S <- Ss],Map(D)},
+ remap(Is, Map, [I|Acc]);
+remap([{gc_bif,Name,Fail,Live,Ss,D}|Is], Map, Acc) ->
+ I = {gc_bif,Name,Fail,Live,[Map(S) || S <- Ss],Map(D)},
+ remap(Is, Map, [I|Acc]);
+remap([{bs_add,Fail,[SrcA,SrcB,U],D}|Is], Map, Acc) ->
+ I = {bs_add,Fail,[Map(SrcA),Map(SrcB),U],Map(D)},
+ remap(Is, Map, [I|Acc]);
+remap([{bs_append=Op,Fail,Bits,Heap,Live,Unit,Bin,Flags,D}|Is], Map, Acc) ->
+ I = {Op,Fail,Map(Bits),Heap,Live,Unit,Map(Bin),Flags,Map(D)},
+ remap(Is, Map, [I|Acc]);
+remap([{bs_private_append=Op,Fail,Bits,Unit,Bin,Flags,D}|Is], Map, Acc) ->
+ I = {Op,Fail,Map(Bits),Unit,Map(Bin),Flags,Map(D)},
+ remap(Is, Map, [I|Acc]);
+remap([bs_init_writable=I|Is], Map, Acc) ->
+ remap(Is, Map, [I|Acc]);
+remap([{bs_init2,Fail,Src,Live,U,Flags,D}|Is], Map, Acc) ->
+ I = {bs_init2,Fail,Map(Src),Live,U,Flags,Map(D)},
+ remap(Is, Map, [I|Acc]);
+remap([{bs_init_bits,Fail,Src,Live,U,Flags,D}|Is], Map, Acc) ->
+ I = {bs_init_bits,Fail,Map(Src),Live,U,Flags,Map(D)},
+ remap(Is, Map, [I|Acc]);
+remap([{bs_put_binary=Op,Fail,Src,U,Flags,D}|Is], Map, Acc) ->
+ I = {Op,Fail,Map(Src),U,Flags,Map(D)},
+ remap(Is, Map, [I|Acc]);
+remap([{bs_put_integer=Op,Fail,Src,U,Flags,D}|Is], Map, Acc) ->
+ I = {Op,Fail,Map(Src),U,Flags,Map(D)},
+ remap(Is, Map, [I|Acc]);
+remap([{bs_put_float=Op,Fail,Src,U,Flags,D}|Is], Map, Acc) ->
+ I = {Op,Fail,Map(Src),U,Flags,Map(D)},
+ remap(Is, Map, [I|Acc]);
+remap([{bs_put_string,_,_}=I|Is], Map, Acc) ->
+ remap(Is, Map, [I|Acc]);
+remap([{kill,Y}|T], Map, Acc) ->
+ remap(T, Map, [{kill,Map(Y)}|Acc]);
+remap([send=I|T], Map, Acc) ->
+ remap(T, Map, [I|Acc]);
+remap([{make_fun2,_,_,_,_}=I|T], Map, Acc) ->
+ remap(T, Map, [I|Acc]);
+remap([{deallocate,N}|Is], Map, Acc) ->
+ I = {deallocate,Map({frame_size,N})},
+ remap(Is, Map, [I|Acc]);
+remap([{test,Name,Fail,Ss}|Is], Map, Acc) ->
+ I = {test,Name,Fail,[Map(S) || S <- Ss]},
+ remap(Is, Map, [I|Acc]);
+remap([{test,Name,Fail,Live,Ss,Dst}|Is], Map, Acc) ->
+ I = {test,Name,Fail,Live,[Map(S) || S <- Ss],Map(Dst)},
+ remap(Is, Map, [I|Acc]);
+remap([return|_]=Is, _, Acc) ->
+ reverse(Acc, Is);
+remap([{call_last,Ar,Name,N}|Is], Map, Acc) ->
+ I = {call_last,Ar,Name,Map({frame_size,N})},
+ reverse(Acc, [I|Is]);
+remap([{call_ext_last,Ar,Name,N}|Is], Map, Acc) ->
+ I = {call_ext_last,Ar,Name,Map({frame_size,N})},
+ reverse(Acc, [I|Is]).
+
+remap_block([{set,Ds0,Ss0,Info}|Is], Map, Acc) ->
+ Ds = [Map(D) || D <- Ds0],
+ Ss = [Map(S) || S <- Ss0],
+ remap_block(Is, Map, [{set,Ds,Ss,Info}|Acc]);
+remap_block([], _, Acc) -> reverse(Acc).
+
+safe_labels([{label,L},{badmatch,{Tag,_}}|Is], Acc) when Tag =/= y ->
+ safe_labels(Is, [L|Acc]);
+safe_labels([{label,L},{case_end,{Tag,_}}|Is], Acc) when Tag =/= y ->
+ safe_labels(Is, [L|Acc]);
+safe_labels([{label,L},if_end|Is], Acc) ->
+ safe_labels(Is, [L|Acc]);
+safe_labels([{label,L},
+ {block,[{set,[{x,0}],[{Tag,_}],move}]},
+ {call_ext,1,{extfunc,erlang,error,1}}|Is], Acc) when Tag =/= y ->
+ safe_labels(Is, [L|Acc]);
+safe_labels([_|Is], Acc) ->
+ safe_labels(Is, Acc);
+safe_labels([], Acc) -> gb_sets:from_list(Acc).
+
+%% frame_layout([Instruction], [{kill,_}], St) ->
+%% [{kill,Reg} | {live,Reg} | {dead,Reg}]
+%% Figure out the layout of the stack frame.
+
+frame_layout(Is, Kills, #st{safe=Safe,lbl=D}) ->
+ N = frame_size(Is, Safe),
+ IsKilled = fun(R) -> beam_utils:is_killed(R, Is, D) end,
+ {N,frame_layout_1(Kills, 0, N, IsKilled, [])}.
+
+frame_layout_1([{kill,{y,Y}}=I|Ks], Y, N, IsKilled, Acc) ->
+ frame_layout_1(Ks, Y+1, N, IsKilled, [I|Acc]);
+frame_layout_1(Ks, Y, N, IsKilled, Acc) when Y < N ->
+ R = {y,Y},
+ I = case IsKilled(R) of
+ false -> {live,R};
+ true -> {dead,R}
+ end,
+ frame_layout_1(Ks, Y+1, N, IsKilled, [I|Acc]);
+frame_layout_1([], Y, Y, _, Acc) ->
+ frame_layout_2(Acc).
+
+frame_layout_2([{live,_}|Is]) -> frame_layout_2(Is);
+frame_layout_2(Is) -> reverse(Is).
+
+%% frame_size([Instruction], SafeLabels) -> FrameSize
+%% Find out the frame size by looking at the code that follows.
+
+frame_size([{block,_}|Is], Safe) ->
+ frame_size(Is, Safe);
+frame_size([{call_fun,_}|Is], Safe) ->
+ frame_size(Is, Safe);
+frame_size([{call,_,_}|Is], Safe) ->
+ frame_size(Is, Safe);
+frame_size([{call_ext,A,{extfunc,M,F,A}}|Is], Safe) ->
+ case erl_bifs:is_exit_bif(M, F, A) of
+ true -> throw(not_possible);
+ false -> frame_size(Is, Safe)
+ end;
+frame_size([{apply,_}|Is], Safe) ->
+ frame_size(Is, Safe);
+frame_size([{bif,_,{f,L},_,_}|Is], Safe) ->
+ frame_size_branch(L, Is, Safe);
+frame_size([{gc_bif,_,{f,L},_,_,_}|Is], Safe) ->
+ frame_size_branch(L, Is, Safe);
+frame_size([{test,_,{f,L},_}|Is], Safe) ->
+ frame_size_branch(L, Is, Safe);
+frame_size([{test,_,{f,L},_,_,_}|Is], Safe) ->
+ frame_size_branch(L, Is, Safe);
+frame_size([{bs_add,{f,L},_,_}|Is], Safe) ->
+ frame_size_branch(L, Is, Safe);
+frame_size([{bs_append,{f,L},_,_,_,_,_,_,_}|Is], Safe) ->
+ frame_size_branch(L, Is, Safe);
+frame_size([{bs_private_append,{f,L},_,_,_,_,_}|Is], Safe) ->
+ frame_size_branch(L, Is, Safe);
+frame_size([bs_init_writable|Is], Safe) ->
+ frame_size(Is, Safe);
+frame_size([{bs_init2,{f,L},_,_,_,_,_}|Is], Safe) ->
+ frame_size_branch(L, Is, Safe);
+frame_size([{bs_init_bits,{f,L},_,_,_,_,_}|Is], Safe) ->
+ frame_size_branch(L, Is, Safe);
+frame_size([{bs_put_binary,{f,L},_,_,_,_}|Is], Safe) ->
+ frame_size_branch(L, Is, Safe);
+frame_size([{bs_put_integer,{f,L},_,_,_,_}|Is], Safe) ->
+ frame_size_branch(L, Is, Safe);
+frame_size([{bs_put_float,{f,L},_,_,_,_}|Is], Safe) ->
+ frame_size_branch(L, Is, Safe);
+frame_size([{bs_put_string,_,_}|Is], Safe) ->
+ frame_size(Is, Safe);
+frame_size([{kill,_}|Is], Safe) ->
+ frame_size(Is, Safe);
+frame_size([send|Is], Safe) ->
+ frame_size(Is, Safe);
+frame_size([{make_fun2,_,_,_,_}|Is], Safe) ->
+ frame_size(Is, Safe);
+frame_size([{deallocate,N}|_], _) -> N;
+frame_size([{call_last,_,_,N}|_], _) -> N;
+frame_size([{call_ext_last,_,_,N}|_], _) -> N;
+frame_size([_|_], _) -> throw(not_possible).
+
+frame_size_branch(0, Is, Safe) ->
+ frame_size(Is, Safe);
+frame_size_branch(L, Is, Safe) ->
+ case gb_sets:is_member(L, Safe) of
+ false -> throw(not_possible);
+ true -> frame_size(Is, Safe)
+ end.
diff --git a/lib/compiler/src/beam_type.erl b/lib/compiler/src/beam_type.erl
new file mode 100644
index 0000000000..ba903a12b6
--- /dev/null
+++ b/lib/compiler/src/beam_type.erl
@@ -0,0 +1,691 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1999-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%
+%%
+%% Purpose : Type-based optimisations.
+
+-module(beam_type).
+
+-export([module/2]).
+
+-import(lists, [foldl/3,reverse/1,filter/2]).
+
+module({Mod,Exp,Attr,Fs0,Lc}, _Opts) ->
+ Fs = [function(F) || F <- Fs0],
+ {ok,{Mod,Exp,Attr,Fs,Lc}}.
+
+function({function,Name,Arity,CLabel,Asm0}) ->
+ Asm1 = beam_utils:live_opt(Asm0),
+ Asm2 = opt(Asm1, [], tdb_new()),
+ Asm = beam_utils:delete_live_annos(Asm2),
+ {function,Name,Arity,CLabel,Asm}.
+
+%% opt([Instruction], Accumulator, TypeDb) -> {[Instruction'],TypeDb'}
+%% Keep track of type information; try to simplify.
+
+opt([{block,Body1}|Is], [{block,Body0}|Acc], Ts0) ->
+ {Body2,Ts} = simplify(Body1, Ts0),
+ Body = merge_blocks(Body0, Body2),
+ opt(Is, [{block,Body}|Acc], Ts);
+opt([{block,Body0}|Is], Acc, Ts0) ->
+ {Body,Ts} = simplify(Body0, Ts0),
+ opt(Is, [{block,Body}|Acc], Ts);
+opt([I0|Is], Acc, Ts0) ->
+ case simplify_basic([I0], Ts0) of
+ {[],Ts} -> opt(Is, Acc, Ts);
+ {[I],Ts} -> opt(Is, [I|Acc], Ts)
+ end;
+opt([], Acc, _) -> reverse(Acc).
+
+%% simplify(Instruction, TypeDb) -> NewInstruction
+%% Simplify an instruction using type information (this is
+%% technically a "strength reduction").
+
+simplify(Is0, TypeDb0) ->
+ {Is,_} = BasicRes = simplify_basic(Is0, TypeDb0),
+ case simplify_float(Is, TypeDb0) of
+ not_possible -> BasicRes;
+ {_,_}=Res -> Res
+ end.
+
+%% simplify_basic([Instruction], TypeDatabase) -> {[Instruction],TypeDatabase'}
+%% Basic simplification, mostly tuples, no floating point optimizations.
+
+simplify_basic(Is, Ts) ->
+ simplify_basic_1(Is, Ts, []).
+
+simplify_basic_1([{set,[D],[{integer,Index},Reg],{bif,element,_}}=I0|Is], Ts0, Acc) ->
+ I = case max_tuple_size(Reg, Ts0) of
+ Sz when 0 < Index, Index =< Sz ->
+ {set,[D],[Reg],{get_tuple_element,Index-1}};
+ _Other -> I0
+ end,
+ Ts = update(I, Ts0),
+ simplify_basic_1(Is, Ts, [I|Acc]);
+simplify_basic_1([{set,[_],[_],{bif,_,{f,0}}}=I|Is], Ts0, Acc) ->
+ Ts = update(I, Ts0),
+ simplify_basic_1(Is, Ts, [I|Acc]);
+simplify_basic_1([{set,[D],[TupleReg],{get_tuple_element,0}}=I|Is0], Ts0, Acc) ->
+ case tdb_find(TupleReg, Ts0) of
+ {tuple,_,[Contents]} ->
+ simplify_basic_1([{set,[D],[Contents],move}|Is0], Ts0, Acc);
+ _ ->
+ Ts = update(I, Ts0),
+ simplify_basic_1(Is0, Ts, [I|Acc])
+ end;
+simplify_basic_1([{set,_,_,{'catch',_}}=I|Is], _Ts, Acc) ->
+ simplify_basic_1(Is, tdb_new(), [I|Acc]);
+simplify_basic_1([{test,is_tuple,_,[R]}=I|Is], Ts, Acc) ->
+ case tdb_find(R, Ts) of
+ {tuple,_,_} -> simplify_basic_1(Is, Ts, Acc);
+ _ -> simplify_basic_1(Is, Ts, [I|Acc])
+ end;
+simplify_basic_1([{test,test_arity,_,[R,Arity]}=I|Is], Ts0, Acc) ->
+ case tdb_find(R, Ts0) of
+ {tuple,Arity,_} ->
+ simplify_basic_1(Is, Ts0, Acc);
+ _Other ->
+ Ts = update(I, Ts0),
+ simplify_basic_1(Is, Ts, [I|Acc])
+ end;
+simplify_basic_1([{test,is_eq_exact,Fail,[R,{atom,_}=Atom]}=I|Is0], Ts0, Acc0) ->
+ Acc = case tdb_find(R, Ts0) of
+ {atom,_}=Atom -> Acc0;
+ {atom,_} -> [{jump,Fail}|Acc0];
+ _ -> [I|Acc0]
+ end,
+ Ts = update(I, Ts0),
+ simplify_basic_1(Is0, Ts, Acc);
+simplify_basic_1([{test,is_record,_,[R,{atom,_}=Tag,{integer,Arity}]}=I|Is], Ts0, Acc) ->
+ case tdb_find(R, Ts0) of
+ {tuple,Arity,[Tag]} ->
+ simplify_basic_1(Is, Ts0, Acc);
+ _Other ->
+ Ts = update(I, Ts0),
+ simplify_basic_1(Is, Ts, [I|Acc])
+ end;
+
+simplify_basic_1([I|Is], Ts0, Acc) ->
+ Ts = update(I, Ts0),
+ simplify_basic_1(Is, Ts, [I|Acc]);
+simplify_basic_1([], Ts, Acc) ->
+ Is = reverse(Acc),
+ {Is,Ts}.
+
+%% simplify_float([Instruction], TypeDatabase) ->
+%% {[Instruction],TypeDatabase'} | not_possible
+%% Simplify floating point operations in blocks.
+%%
+simplify_float(Is0, Ts0) ->
+ {Is1,Ts} = simplify_float_1(Is0, Ts0, [], []),
+ Is2 = flt_need_heap(Is1),
+ try
+ {flt_liveness(Is2),Ts}
+ catch
+ throw:not_possible -> not_possible
+ end.
+
+simplify_float_1([{set,[D0],[A],{alloc,_,{gc_bif,'-',{f,0}}}}=I|Is]=Is0, Ts0, Rs0, Acc0) ->
+ case tdb_find(A, Ts0) of
+ float ->
+ {Rs1,Acc1} = load_reg(A, Ts0, Rs0, Acc0),
+ {D,Rs} = find_dest(D0, Rs1),
+ Areg = fetch_reg(A, Rs),
+ Acc = [{set,[D],[Areg],{bif,fnegate,{f,0}}}|clearerror(Acc1)],
+ Ts = tdb_update([{D0,float}], Ts0),
+ simplify_float_1(Is, Ts, Rs, Acc);
+ _Other ->
+ Ts = update(I, Ts0),
+ {Rs,Acc} = flush(Rs0, Is0, Acc0),
+ simplify_float_1(Is, Ts, Rs, [I|checkerror(Acc)])
+ end;
+simplify_float_1([{set,[D0],[A,B],{alloc,_,{gc_bif,Op0,{f,0}}}}=I|Is]=Is0, Ts0, Rs0, Acc0) ->
+ case float_op(Op0, A, B, Ts0) of
+ no ->
+ Ts = update(I, Ts0),
+ {Rs,Acc} = flush(Rs0, Is0, Acc0),
+ simplify_float_1(Is, Ts, Rs, [I|checkerror(Acc)]);
+ {yes,Op} ->
+ {Rs1,Acc1} = load_reg(A, Ts0, Rs0, Acc0),
+ {Rs2,Acc2} = load_reg(B, Ts0, Rs1, Acc1),
+ {D,Rs} = find_dest(D0, Rs2),
+ Areg = fetch_reg(A, Rs),
+ Breg = fetch_reg(B, Rs),
+ Acc = [{set,[D],[Areg,Breg],{bif,Op,{f,0}}}|clearerror(Acc2)],
+ Ts = tdb_update([{D0,float}], Ts0),
+ simplify_float_1(Is, Ts, Rs, Acc)
+ end;
+simplify_float_1([{set,_,_,{'catch',_}}=I|Is]=Is0, _Ts, Rs0, Acc0) ->
+ Acc = flush_all(Rs0, Is0, Acc0),
+ simplify_float_1(Is, tdb_new(), Rs0, [I|Acc]);
+simplify_float_1([I|Is]=Is0, Ts0, Rs0, Acc0) ->
+ Ts = update(I, Ts0),
+ {Rs,Acc} = flush(Rs0, Is0, Acc0),
+ simplify_float_1(Is, Ts, Rs, [I|checkerror(Acc)]);
+simplify_float_1([], Ts, Rs, Acc0) ->
+ Acc = checkerror(Acc0),
+ Is0 = reverse(flush_all(Rs, [], Acc)),
+ Is = opt_fmoves(Is0, []),
+ {Is,Ts}.
+
+opt_fmoves([{set,[{x,_}=R],[{fr,_}]=Src,fmove}=I1,
+ {set,[{y,_}]=Dst,[{x,_}=R],move}=I2|Is], Acc) ->
+ case beam_utils:is_killed_block(R, Is) of
+ false -> opt_fmoves(Is, [I2,I1|Acc]);
+ true -> opt_fmoves(Is, [{set,Dst,Src,fmove}|Acc])
+ end;
+opt_fmoves([I|Is], Acc) ->
+ opt_fmoves(Is, [I|Acc]);
+opt_fmoves([], Acc) -> reverse(Acc).
+
+clearerror(Is) ->
+ clearerror(Is, Is).
+
+clearerror([{set,[],[],fclearerror}|_], OrigIs) -> OrigIs;
+clearerror([{set,[],[],fcheckerror}|_], OrigIs) -> [{set,[],[],fclearerror}|OrigIs];
+clearerror([_|Is], OrigIs) -> clearerror(Is, OrigIs);
+clearerror([], OrigIs) -> [{set,[],[],fclearerror}|OrigIs].
+
+%% merge_blocks(Block1, Block2) -> Block.
+%% Combine two blocks and eliminate any move instructions that assign
+%% to registers that are killed later in the block.
+%%
+merge_blocks(B1, [{'%live',_}|B2]) ->
+ merge_blocks_1(B1++[{set,[],[],stop_here}|B2]).
+
+merge_blocks_1([{set,[],_,stop_here}|Is]) -> Is;
+merge_blocks_1([{set,[D],_,move}=I|Is]) ->
+ case beam_utils:is_killed_block(D, Is) of
+ true -> merge_blocks_1(Is);
+ false -> [I|merge_blocks_1(Is)]
+ end;
+merge_blocks_1([I|Is]) -> [I|merge_blocks_1(Is)].
+
+%% flt_need_heap([Instruction]) -> [Instruction]
+%% Insert need heap allocation instructions in the instruction stream
+%% to properly account for both inserted floating point operations and
+%% normal term build operations (such as put_list/3).
+%%
+%% Ignore old heap allocation instructions (except if they allocate a stack
+%% frame too), as they may be in the wrong place (because gc_bif instructions
+%% could have been converted to floating point operations).
+
+flt_need_heap(Is) ->
+ flt_need_heap_1(reverse(Is), 0, 0, []).
+
+flt_need_heap_1([{set,[],[],{alloc,_,Alloc}}|Is], H, Fl, Acc) ->
+ case Alloc of
+ {_,nostack,_,_} ->
+ %% Remove any existing test_heap/2 instruction.
+ flt_need_heap_1(Is, H, Fl, Acc);
+ {Z,Stk,_,Inits} when is_integer(Stk) ->
+ %% Keep any allocate*/2 instruction and recalculate heap need.
+ I = {set,[],[],{alloc,regs,{Z,Stk,build_alloc(H, Fl),Inits}}},
+ flt_need_heap_1(Is, 0, 0, [I|Acc])
+ end;
+flt_need_heap_1([I|Is], H0, Fl0, Acc) ->
+ {Ns,H1,Fl1} = flt_need_heap_2(I, H0, Fl0),
+ flt_need_heap_1(Is, H1, Fl1, [I|Ns]++Acc);
+flt_need_heap_1([], H, Fl, Acc) ->
+ flt_alloc(H, Fl) ++ Acc.
+
+%% First come all instructions that build. We pass through, while we
+%% add to the need for heap words and floats on the heap.
+flt_need_heap_2({set,[_],[{fr,_}],fmove}, H, Fl) ->
+ {[],H,Fl+1};
+flt_need_heap_2({set,_,_,put_list}, H, Fl) ->
+ {[],H+2,Fl};
+flt_need_heap_2({set,_,_,{put_tuple,_}}, H, Fl) ->
+ {[],H+1,Fl};
+flt_need_heap_2({set,_,_,put}, H, Fl) ->
+ {[],H+1,Fl};
+flt_need_heap_2({set,_,_,{put_string,L,_Str}}, H, Fl) ->
+ {[],H+2*L,Fl};
+%% Then the "neutral" instructions. We just pass them.
+flt_need_heap_2({set,[{fr,_}],_,_}, H, Fl) ->
+ {[],H,Fl};
+flt_need_heap_2({set,[],[],fclearerror}, H, Fl) ->
+ {[],H,Fl};
+flt_need_heap_2({set,[],[],fcheckerror}, H, Fl) ->
+ {[],H,Fl};
+flt_need_heap_2({set,_,_,{bif,_,_}}, H, Fl) ->
+ {[],H,Fl};
+flt_need_heap_2({set,_,_,move}, H, Fl) ->
+ {[],H,Fl};
+flt_need_heap_2({set,_,_,{get_tuple_element,_}}, H, Fl) ->
+ {[],H,Fl};
+flt_need_heap_2({set,_,_,get_list}, H, Fl) ->
+ {[],H,Fl};
+flt_need_heap_2({set,_,_,{'catch',_}}, H, Fl) ->
+ {[],H,Fl};
+%% All other instructions should cause the insertion of an allocation
+%% instruction if needed.
+flt_need_heap_2(_, H, Fl) ->
+ {flt_alloc(H, Fl),0,0}.
+
+flt_alloc(0, 0) ->
+ [];
+flt_alloc(H, 0) ->
+ [{set,[],[],{alloc,regs,{nozero,nostack,H,[]}}}];
+flt_alloc(H, F) ->
+ [{set,[],[],{alloc,regs,{nozero,nostack,
+ build_alloc(H, F),[]}}}].
+
+build_alloc(Words, 0) -> Words;
+build_alloc(Words, Floats) -> {alloc,[{words,Words},{floats,Floats}]}.
+
+
+%% flt_liveness([Instruction]) -> [Instruction]
+%% (Re)calculate the number of live registers for each heap allocation
+%% function. We base liveness of the number of live registers at
+%% entry to the instruction sequence.
+%%
+%% A 'not_possible' term will be thrown if the set of live registers
+%% is not continous at an allocation function (e.g. if {x,0} and {x,2}
+%% are live, but not {x,1}).
+
+flt_liveness([{'%live',Live}=LiveInstr|Is]) ->
+ flt_liveness_1(Is, init_regs(Live), [LiveInstr]).
+
+flt_liveness_1([{set,Ds,Ss,{alloc,_,Alloc}}|Is], Regs0, Acc) ->
+ Live = live_regs(Regs0),
+ I = {set,Ds,Ss,{alloc,Live,Alloc}},
+ Regs = foldl(fun(R, A) -> set_live(R, A) end, Regs0, Ds),
+ flt_liveness_1(Is, Regs, [I|Acc]);
+flt_liveness_1([{set,Ds,_,_}=I|Is], Regs0, Acc) ->
+ Regs = foldl(fun(R, A) -> set_live(R, A) end, Regs0, Ds),
+ flt_liveness_1(Is, Regs, [I|Acc]);
+flt_liveness_1([{'%live',_}=I|Is], Regs, Acc) ->
+ flt_liveness_1(Is, Regs, [I|Acc]);
+flt_liveness_1([], _Regs, Acc) -> reverse(Acc).
+
+init_regs(Live) ->
+ (1 bsl Live) - 1.
+
+live_regs(Regs) ->
+ live_regs_1(Regs, 0).
+
+live_regs_1(0, N) -> N;
+live_regs_1(R, N) ->
+ case R band 1 of
+ 0 -> throw(not_possible);
+ 1 -> live_regs_1(R bsr 1, N+1)
+ end.
+
+set_live({x,X}, Regs) -> Regs bor (1 bsl X);
+set_live(_, Regs) -> Regs.
+
+%% update(Instruction, TypeDb) -> NewTypeDb
+%% Update the type database to account for executing an instruction.
+%%
+%% First the cases for instructions inside basic blocks.
+update({'%live',_}, Ts) -> Ts;
+update({set,[D],[S],move}, Ts) ->
+ tdb_copy(S, D, Ts);
+update({set,[D],[{integer,I},Reg],{bif,element,_}}, Ts0) ->
+ tdb_update([{Reg,{tuple,I,[]}},{D,kill}], Ts0);
+update({set,[D],[_Index,Reg],{bif,element,_}}, Ts0) ->
+ tdb_update([{Reg,{tuple,0,[]}},{D,kill}], Ts0);
+update({set,[D],[S],{get_tuple_element,0}}, Ts) ->
+ tdb_update([{D,{tuple_element,S,0}}], Ts);
+update({set,[D],[S],{alloc,_,{gc_bif,float,{f,0}}}}, Ts0) ->
+ %% Make sure we reject non-numeric literal argument.
+ case possibly_numeric(S) of
+ true -> tdb_update([{D,float}], Ts0);
+ false -> Ts0
+ end;
+update({set,[D],[S1,S2],{alloc,_,{gc_bif,'/',{f,0}}}}, Ts0) ->
+ %% Make sure we reject non-numeric literals.
+ case possibly_numeric(S1) andalso possibly_numeric(S2) of
+ true -> tdb_update([{D,float}], Ts0);
+ false -> Ts0
+ end;
+update({set,[D],[S1,S2],{alloc,_,{gc_bif,Op,{f,0}}}}, Ts0) ->
+ case arith_op(Op) of
+ no ->
+ tdb_update([{D,kill}], Ts0);
+ {yes,_} ->
+ case {tdb_find(S1, Ts0),tdb_find(S2, Ts0)} of
+ {float,_} -> tdb_update([{D,float}], Ts0);
+ {_,float} -> tdb_update([{D,float}], Ts0);
+ {_,_} -> tdb_update([{D,kill}], Ts0)
+ end
+ end;
+update({set,[],_Src,_Op}, Ts0) -> Ts0;
+update({set,[D],_Src,_Op}, Ts0) ->
+ tdb_update([{D,kill}], Ts0);
+update({set,[D1,D2],_Src,_Op}, Ts0) ->
+ tdb_update([{D1,kill},{D2,kill}], Ts0);
+update({kill,D}, Ts) ->
+ tdb_update([{D,kill}], Ts);
+
+%% Instructions outside of blocks.
+update({test,is_float,_Fail,[Src]}, Ts0) ->
+ tdb_update([{Src,float}], Ts0);
+update({test,test_arity,_Fail,[Src,Arity]}, Ts0) ->
+ tdb_update([{Src,{tuple,Arity,[]}}], Ts0);
+update({test,is_eq_exact,_,[Reg,{atom,_}=Atom]}, Ts) ->
+ case tdb_find(Reg, Ts) of
+ error ->
+ Ts;
+ {tuple_element,TupleReg,0} ->
+ tdb_update([{TupleReg,{tuple,1,[Atom]}}], Ts);
+ _ ->
+ Ts
+ end;
+update({test,is_record,_Fail,[Src,Tag,{integer,Arity}]}, Ts) ->
+ tdb_update([{Src,{tuple,Arity,[Tag]}}], Ts);
+update({test,_Test,_Fail,_Other}, Ts) ->
+ Ts;
+update({call_ext,Ar,{extfunc,math,Math,Ar}}, Ts) ->
+ case is_math_bif(Math, Ar) of
+ true -> tdb_update([{{x,0},float}], Ts);
+ false -> tdb_kill_xregs(Ts)
+ end;
+update({call_ext,3,{extfunc,erlang,setelement,3}}, Ts0) ->
+ Op = case tdb_find({x,1}, Ts0) of
+ error -> kill;
+ Info -> Info
+ end,
+ Ts1 = tdb_kill_xregs(Ts0),
+ tdb_update([{{x,0},Op}], Ts1);
+update({call,_Arity,_Func}, Ts) -> tdb_kill_xregs(Ts);
+update({call_ext,_Arity,_Func}, Ts) -> tdb_kill_xregs(Ts);
+update({make_fun2,_,_,_,_}, Ts) -> tdb_kill_xregs(Ts);
+
+%% The instruction is unknown. Kill all information.
+update(_I, _Ts) -> tdb_new().
+
+is_math_bif(cos, 1) -> true;
+is_math_bif(cosh, 1) -> true;
+is_math_bif(sin, 1) -> true;
+is_math_bif(sinh, 1) -> true;
+is_math_bif(tan, 1) -> true;
+is_math_bif(tanh, 1) -> true;
+is_math_bif(acos, 1) -> true;
+is_math_bif(acosh, 1) -> true;
+is_math_bif(asin, 1) -> true;
+is_math_bif(asinh, 1) -> true;
+is_math_bif(atan, 1) -> true;
+is_math_bif(atanh, 1) -> true;
+is_math_bif(erf, 1) -> true;
+is_math_bif(erfc, 1) -> true;
+is_math_bif(exp, 1) -> true;
+is_math_bif(log, 1) -> true;
+is_math_bif(log10, 1) -> true;
+is_math_bif(sqrt, 1) -> true;
+is_math_bif(atan2, 2) -> true;
+is_math_bif(pow, 2) -> true;
+is_math_bif(pi, 0) -> true;
+is_math_bif(_, _) -> false.
+
+%% Reject non-numeric literals.
+possibly_numeric({x,_}) -> true;
+possibly_numeric({y,_}) -> true;
+possibly_numeric({integer,_}) -> true;
+possibly_numeric({float,_}) -> true;
+possibly_numeric(_) -> false.
+
+max_tuple_size(Reg, Ts) ->
+ case tdb_find(Reg, Ts) of
+ {tuple,Sz,_} -> Sz;
+ _Other -> 0
+ end.
+
+float_op('/', A, B, _) ->
+ case possibly_numeric(A) andalso possibly_numeric(B) of
+ true -> {yes,fdiv};
+ false -> no
+ end;
+float_op(Op, {float,_}, B, _) ->
+ case possibly_numeric(B) of
+ true -> arith_op(Op);
+ false -> no
+ end;
+float_op(Op, A, {float,_}, _) ->
+ case possibly_numeric(A) of
+ true -> arith_op(Op);
+ false -> no
+ end;
+float_op(Op, A, B, Ts) ->
+ case {tdb_find(A, Ts),tdb_find(B, Ts)} of
+ {float,_} -> arith_op(Op);
+ {_,float} -> arith_op(Op);
+ {_,_} -> no
+ end.
+
+find_dest(V, Rs0) ->
+ case find_reg(V, Rs0) of
+ {ok,FR} ->
+ {FR,mark(V, Rs0, dirty)};
+ error ->
+ Rs = put_reg(V, Rs0, dirty),
+ {ok,FR} = find_reg(V, Rs),
+ {FR,Rs}
+ end.
+
+load_reg({float,_}=F, _, Rs0, Is0) ->
+ Rs = put_reg(F, Rs0, clean),
+ {ok,FR} = find_reg(F, Rs),
+ Is = [{set,[FR],[F],fmove}|Is0],
+ {Rs,Is};
+load_reg(V, Ts, Rs0, Is0) ->
+ case find_reg(V, Rs0) of
+ {ok,_FR} -> {Rs0,Is0};
+ error ->
+ Rs = put_reg(V, Rs0, clean),
+ {ok,FR} = find_reg(V, Rs),
+ Op = case tdb_find(V, Ts) of
+ float -> fmove;
+ _ -> fconv
+ end,
+ Is = [{set,[FR],[V],Op}|Is0],
+ {Rs,Is}
+ end.
+
+arith_op('+') -> {yes,fadd};
+arith_op('-') -> {yes,fsub};
+arith_op('*') -> {yes,fmul};
+arith_op('/') -> {yes,fdiv};
+arith_op(_) -> no.
+
+flush(Rs, [{set,[_],[],{put_tuple,_}}|_]=Is0, Acc0) ->
+ Acc = flush_all(Rs, Is0, Acc0),
+ {[],Acc};
+flush(Rs0, [{set,Ds,Ss,_Op}|_], Acc0) ->
+ Save = gb_sets:from_list(Ss),
+ Acc = save_regs(Rs0, Save, Acc0),
+ Rs1 = foldl(fun(S, A) -> mark(S, A, clean) end, Rs0, Ss),
+ Kill = gb_sets:from_list(Ds),
+ Rs = kill_regs(Rs1, Kill),
+ {Rs,Acc};
+flush(Rs0, Is, Acc0) ->
+ Acc = flush_all(Rs0, Is, Acc0),
+ {[],Acc}.
+
+flush_all([{_,{float,_},_}|Rs], Is, Acc) ->
+ flush_all(Rs, Is, Acc);
+flush_all([{I,V,dirty}|Rs], Is, Acc0) ->
+ Acc = checkerror(Acc0),
+ case beam_utils:is_killed_block(V, Is) of
+ true -> flush_all(Rs, Is, Acc);
+ false -> flush_all(Rs, Is, [{set,[V],[{fr,I}],fmove}|Acc])
+ end;
+flush_all([{_,_,clean}|Rs], Is, Acc) -> flush_all(Rs, Is, Acc);
+flush_all([free|Rs], Is, Acc) -> flush_all(Rs, Is, Acc);
+flush_all([], _, Acc) -> Acc.
+
+save_regs(Rs, Save, Acc) ->
+ foldl(fun(R, A) -> save_reg(R, Save, A) end, Acc, Rs).
+
+save_reg({I,V,dirty}, Save, Acc) ->
+ case gb_sets:is_member(V, Save) of
+ true -> [{set,[V],[{fr,I}],fmove}|checkerror(Acc)];
+ false -> Acc
+ end;
+save_reg(_, _, Acc) -> Acc.
+
+kill_regs(Rs, Kill) ->
+ [kill_reg(R, Kill) || R <- Rs].
+
+kill_reg({_,V,_}=R, Kill) ->
+ case gb_sets:is_member(V, Kill) of
+ true -> free;
+ false -> R
+ end;
+kill_reg(R, _) -> R.
+
+mark(V, [{I,V,_}|Rs], Mark) -> [{I,V,Mark}|Rs];
+mark(V, [R|Rs], Mark) -> [R|mark(V, Rs, Mark)];
+mark(_, [], _) -> [].
+
+fetch_reg(V, [{I,V,_}|_]) -> {fr,I};
+fetch_reg(V, [_|SRs]) -> fetch_reg(V, SRs).
+
+find_reg(V, [{I,V,_}|_]) -> {ok,{fr,I}};
+find_reg(V, [_|SRs]) -> find_reg(V, SRs);
+find_reg(_, []) -> error.
+
+put_reg(V, Rs, Dirty) -> put_reg_1(V, Rs, Dirty, 0).
+
+put_reg_1(V, [free|Rs], Dirty, I) -> [{I,V,Dirty}|Rs];
+put_reg_1(V, [R|Rs], Dirty, I) -> [R|put_reg_1(V, Rs, Dirty, I+1)];
+put_reg_1(V, [], Dirty, I) -> [{I,V,Dirty}].
+
+checkerror(Is) ->
+ checkerror_1(Is, Is).
+
+checkerror_1([{set,[],[],fcheckerror}|_], OrigIs) -> OrigIs;
+checkerror_1([{set,[],[],fclearerror}|_], OrigIs) -> OrigIs;
+checkerror_1([{set,_,_,{bif,fadd,_}}|_], OrigIs) -> checkerror_2(OrigIs);
+checkerror_1([{set,_,_,{bif,fsub,_}}|_], OrigIs) -> checkerror_2(OrigIs);
+checkerror_1([{set,_,_,{bif,fmul,_}}|_], OrigIs) -> checkerror_2(OrigIs);
+checkerror_1([{set,_,_,{bif,fdiv,_}}|_], OrigIs) -> checkerror_2(OrigIs);
+checkerror_1([{set,_,_,{bif,fnegate,_}}|_], OrigIs) -> checkerror_2(OrigIs);
+checkerror_1([_|Is], OrigIs) -> checkerror_1(Is, OrigIs);
+checkerror_1([], OrigIs) -> OrigIs.
+
+checkerror_2(OrigIs) -> [{set,[],[],fcheckerror}|OrigIs].
+
+
+%%% Routines for maintaining a type database. The type database
+%%% associates type information with registers.
+%%%
+%%% {tuple,Size,First} means that the corresponding register contains a
+%%% tuple with *at least* Size elements. An tuple with unknown
+%%% size is represented as {tuple,0}. First is either [] (meaning that
+%%% the tuple's first element is unknown) or [FirstElement] (the contents
+%%% of the first element).
+%%%
+%%% 'float' means that the register contains a float.
+
+%% tdb_new() -> EmptyDataBase
+%% Creates a new, empty type database.
+
+tdb_new() -> [].
+
+%% tdb_find(Register, Db) -> Information|error
+%% Returns type information or the atom error if there is no type
+%% information available for Register.
+
+tdb_find({x,_}=K, Ts) -> tdb_find_1(K, Ts);
+tdb_find({y,_}=K, Ts) -> tdb_find_1(K, Ts);
+tdb_find(_, _) -> error.
+
+tdb_find_1(K, Ts) ->
+ case orddict:find(K, Ts) of
+ {ok,Val} -> Val;
+ error -> error
+ end.
+
+%% tdb_copy(Source, Dest, Db) -> Db'
+%% Update the type information for Dest to have the same type
+%% as the Source.
+
+tdb_copy({Tag,_}=S, D, Ts) when Tag =:= x; Tag =:= y ->
+ case tdb_find(S, Ts) of
+ error -> orddict:erase(D, Ts);
+ Type -> orddict:store(D, Type, Ts)
+ end;
+tdb_copy(Literal, D, Ts) -> orddict:store(D, Literal, Ts).
+
+%% tdb_update([UpdateOp], Db) -> NewDb
+%% UpdateOp = {Register,kill}|{Register,NewInfo}
+%% Updates a type database. If a 'kill' operation is given, the type
+%% information for that register will be removed from the database.
+%% A kill operation takes precedence over other operations for the same
+%% register (i.e. [{{x,0},kill},{{x,0},{tuple,5}}] means that the
+%% the existing type information, if any, will be discarded, and the
+%% the '{tuple,5}' information ignored.
+%%
+%% If NewInfo information is given and there exists information about
+%% the register, the old and new type information will be merged.
+%% For instance, {tuple,5} and {tuple,10} will be merged to produce
+%% {tuple,10}.
+
+tdb_update(Uis0, Ts0) ->
+ Uis1 = filter(fun ({{x,_},_Op}) -> true;
+ ({{y,_},_Op}) -> true;
+ (_) -> false
+ end, Uis0),
+ tdb_update1(lists:sort(Uis1), Ts0).
+
+tdb_update1([{Key,kill}|Ops], [{K,_Old}|_]=Db) when Key < K ->
+ tdb_update1(remove_key(Key, Ops), Db);
+tdb_update1([{Key,_New}=New|Ops], [{K,_Old}|_]=Db) when Key < K ->
+ [New|tdb_update1(Ops, Db)];
+tdb_update1([{Key,kill}|Ops], [{Key,_}|Db]) ->
+ tdb_update1(remove_key(Key, Ops), Db);
+tdb_update1([{Key,NewInfo}|Ops], [{Key,OldInfo}|Db]) ->
+ [{Key,merge_type_info(NewInfo, OldInfo)}|tdb_update1(Ops, Db)];
+tdb_update1([{_,_}|_]=Ops, [Old|Db]) ->
+ [Old|tdb_update1(Ops, Db)];
+tdb_update1([{Key,kill}|Ops], []) ->
+ tdb_update1(remove_key(Key, Ops), []);
+tdb_update1([{_,_}=New|Ops], []) ->
+ [New|tdb_update1(Ops, [])];
+tdb_update1([], Db) -> Db.
+
+%% tdb_kill_xregs(Db) -> NewDb
+%% Kill all information about x registers. Also kill all tuple_element
+%% dependencies from y registers to x registers.
+
+tdb_kill_xregs([{{x,_},_Type}|Db]) -> tdb_kill_xregs(Db);
+tdb_kill_xregs([{{y,_},{tuple_element,{x,_},_}}|Db]) -> tdb_kill_xregs(Db);
+tdb_kill_xregs([Any|Db]) -> [Any|tdb_kill_xregs(Db)];
+tdb_kill_xregs([]) -> [].
+
+remove_key(Key, [{Key,_Op}|Ops]) -> remove_key(Key, Ops);
+remove_key(_, Ops) -> Ops.
+
+merge_type_info(I, I) -> I;
+merge_type_info({tuple,Sz1,Same}, {tuple,Sz2,Same}=Max) when Sz1 < Sz2 ->
+ Max;
+merge_type_info({tuple,Sz1,Same}=Max, {tuple,Sz2,Same}) when Sz1 > Sz2 ->
+ Max;
+merge_type_info({tuple,Sz1,[]}, {tuple,_Sz2,First}=Tuple2) ->
+ merge_type_info({tuple,Sz1,First}, Tuple2);
+merge_type_info({tuple,_Sz1,First}=Tuple1, {tuple,Sz2,_}) ->
+ merge_type_info(Tuple1, {tuple,Sz2,First});
+merge_type_info(NewType, _) ->
+ verify_type(NewType),
+ NewType.
+
+verify_type({tuple,Sz,[]}) when is_integer(Sz) -> ok;
+verify_type({tuple,Sz,[_]}) when is_integer(Sz) -> ok;
+verify_type({tuple_element,_,_}) -> ok;
+verify_type(float) -> ok.
diff --git a/lib/compiler/src/beam_utils.erl b/lib/compiler/src/beam_utils.erl
new file mode 100644
index 0000000000..ac249e6672
--- /dev/null
+++ b/lib/compiler/src/beam_utils.erl
@@ -0,0 +1,858 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2007-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%
+%%
+%% Purpose : Common utilities used by several optimization passes.
+%%
+
+-module(beam_utils).
+-export([is_killed_block/2,is_killed/3,is_killed_at/3,
+ is_not_used/3,is_not_used_at/3,
+ empty_label_index/0,index_label/3,index_labels/1,
+ code_at/2,bif_to_test/3,is_pure_test/1,
+ live_opt/1,delete_live_annos/1,combine_heap_needs/2]).
+
+-import(lists, [member/2,sort/1,reverse/1]).
+
+-record(live,
+ {bl, %Block check fun.
+ lbl, %Label to code index.
+ res}). %Result cache for each label.
+
+
+%% is_killed_block(Register, [Instruction]) -> true|false
+%% Determine whether a register is killed by the instruction sequence inside
+%% a block.
+%%
+%% If true is returned, it means that the register will not be
+%% referenced in ANY way (not even indirectly by an allocate instruction);
+%% i.e. it is OK to enter the instruction sequence with Register
+%% containing garbage.
+
+is_killed_block(R, Is) ->
+ case check_killed_block(R, Is) of
+ killed -> true;
+ used -> false;
+ transparent -> false
+ end.
+
+%% is_killed(Register, [Instruction], State) -> true|false
+%% Determine whether a register is killed by the instruction sequence.
+%% If true is returned, it means that the register will not be
+%% referenced in ANY way (not even indirectly by an allocate instruction);
+%% i.e. it is OK to enter the instruction sequence with Register
+%% containing garbage.
+%%
+%% The state (constructed by index_instructions/1) is used to allow us
+%% to determine the kill state across branches.
+
+is_killed(R, Is, D) ->
+ St = #live{bl=fun check_killed_block/2,lbl=D,res=gb_trees:empty()},
+ case check_liveness(R, Is, St) of
+ {killed,_} -> true;
+ {used,_} -> false;
+ {unknown,_} -> false
+ end.
+
+%% is_killed_at(Reg, Lbl, State) -> true|false
+%% Determine whether Reg is killed at label Lbl.
+
+is_killed_at(R, Lbl, D) when is_integer(Lbl) ->
+ St0 = #live{bl=fun check_killed_block/2,lbl=D,res=gb_trees:empty()},
+ case check_liveness_at(R, Lbl, St0) of
+ {killed,_} -> true;
+ {used,_} -> false;
+ {unknown,_} -> false
+ end.
+
+%% is_not_used(Register, [Instruction], State) -> true|false
+%% Determine whether a register is never used in the instruction sequence
+%% (it could still be referenced by an allocate instruction, meaning that
+%% it MUST be initialized, but that its value does not matter).
+%% The state is used to allow us to determine the usage state
+%% across branches.
+
+is_not_used(R, Is, D) ->
+ St = #live{bl=fun check_used_block/2,lbl=D,res=gb_trees:empty()},
+ case check_liveness(R, Is, St) of
+ {killed,_} -> true;
+ {used,_} -> false;
+ {unknown,_} -> false
+ end.
+
+%% is_not_used(Register, [Instruction], State) -> true|false
+%% Determine whether a register is never used in the instruction sequence
+%% (it could still be referenced by an allocate instruction, meaning that
+%% it MUST be initialized, but that its value does not matter).
+%% The state is used to allow us to determine the usage state
+%% across branches.
+
+is_not_used_at(R, Lbl, D) ->
+ St = #live{bl=fun check_used_block/2,lbl=D,res=gb_trees:empty()},
+ case check_liveness_at(R, Lbl, St) of
+ {killed,_} -> true;
+ {used,_} -> false;
+ {unknown,_} -> false
+ end.
+
+%% index_labels(FunctionIs) -> State
+%% Index the instruction sequence so that we can quickly
+%% look up the instruction following a specific label.
+
+index_labels(Is) ->
+ index_labels_1(Is, []).
+
+%% empty_label_index() -> State
+%% Create an empty label index.
+
+empty_label_index() ->
+ gb_trees:empty().
+
+%% index_label(Label, [Instruction], State) -> State
+%% Add an index for a label.
+
+index_label(Lbl, Is0, Acc) ->
+ Is = lists:dropwhile(fun({label,_}) -> true;
+ (_) -> false end, Is0),
+ gb_trees:enter(Lbl, Is, Acc).
+
+
+%% code_at(Label, State) -> [I].
+%% Retrieve the code at the given label.
+
+code_at(L, Ll) ->
+ case gb_trees:lookup(L, Ll) of
+ {value,Code} -> Code;
+ none -> none
+ end.
+
+%% bif_to_test(Bif, [Op], Fail) -> {test,Test,Fail,[Op]}
+%% Convert a BIF to a test. Fail if not possible.
+
+bif_to_test(is_atom, [_]=Ops, Fail) -> {test,is_atom,Fail,Ops};
+bif_to_test(is_boolean, [_]=Ops, Fail) -> {test,is_boolean,Fail,Ops};
+bif_to_test(is_binary, [_]=Ops, Fail) -> {test,is_binary,Fail,Ops};
+bif_to_test(is_bitstring,[_]=Ops, Fail) -> {test,is_bitstr,Fail,Ops};
+bif_to_test(is_float, [_]=Ops, Fail) -> {test,is_float,Fail,Ops};
+bif_to_test(is_function, [_]=Ops, Fail) -> {test,is_function,Fail,Ops};
+bif_to_test(is_function, [_,_]=Ops, Fail) -> {test,is_function2,Fail,Ops};
+bif_to_test(is_integer, [_]=Ops, Fail) -> {test,is_integer,Fail,Ops};
+bif_to_test(is_list, [_]=Ops, Fail) -> {test,is_list,Fail,Ops};
+bif_to_test(is_number, [_]=Ops, Fail) -> {test,is_number,Fail,Ops};
+bif_to_test(is_pid, [_]=Ops, Fail) -> {test,is_pid,Fail,Ops};
+bif_to_test(is_port, [_]=Ops, Fail) -> {test,is_port,Fail,Ops};
+bif_to_test(is_reference, [_]=Ops, Fail) -> {test,is_reference,Fail,Ops};
+bif_to_test(is_tuple, [_]=Ops, Fail) -> {test,is_tuple,Fail,Ops};
+bif_to_test('=<', [A,B], Fail) -> {test,is_ge,Fail,[B,A]};
+bif_to_test('>', [A,B], Fail) -> {test,is_lt,Fail,[B,A]};
+bif_to_test('<', [_,_]=Ops, Fail) -> {test,is_lt,Fail,Ops};
+bif_to_test('>=', [_,_]=Ops, Fail) -> {test,is_ge,Fail,Ops};
+bif_to_test('==', [A,[]], Fail) -> {test,is_nil,Fail,[A]};
+bif_to_test('==', [_,_]=Ops, Fail) -> {test,is_eq,Fail,Ops};
+bif_to_test('/=', [_,_]=Ops, Fail) -> {test,is_ne,Fail,Ops};
+bif_to_test('=:=', [A,[]], Fail) -> {test,is_nil,Fail,[A]};
+bif_to_test('=:=', [_,_]=Ops, Fail) -> {test,is_eq_exact,Fail,Ops};
+bif_to_test('=/=', [_,_]=Ops, Fail) -> {test,is_ne_exact,Fail,Ops};
+bif_to_test(is_record, [_,_,_]=Ops, Fail) -> {test,is_record,Fail,Ops}.
+
+
+%% is_pure_test({test,Op,Fail,Ops}) -> true|false.
+%% Return 'true' if the test instruction does not modify any
+%% registers and/or bit syntax matching state, nor modifies
+%% any bit syntax matching state.
+%%
+is_pure_test({test,is_eq,_,[_,_]}) -> true;
+is_pure_test({test,is_ne,_,[_,_]}) -> true;
+is_pure_test({test,is_eq_exact,_,[_,_]}) -> true;
+is_pure_test({test,is_ne_exact,_,[_,_]}) -> true;
+is_pure_test({test,is_ge,_,[_,_]}) -> true;
+is_pure_test({test,is_lt,_,[_,_]}) -> true;
+is_pure_test({test,is_nil,_,[_]}) -> true;
+is_pure_test({test,is_nonempty_list,_,[_]}) -> true;
+is_pure_test({test,test_arity,_,[_,_]}) -> true;
+is_pure_test({test,Op,_,Ops}) ->
+ erl_internal:new_type_test(Op, length(Ops)).
+
+
+%% live_opt([Instruction]) -> [Instruction].
+%% Go through the instruction sequence in reverse execution
+%% order, keep track of liveness and remove 'move' instructions
+%% whose destination is a register that will not be used.
+%% Also insert {'%live',Live} annotations at the beginning
+%% and end of each block.
+%%
+live_opt([{label,Fail}=I1,
+ {func_info,_,_,Live}=I2|Is]) ->
+ D = gb_trees:insert(Fail, live_call(Live), gb_trees:empty()),
+ [I1,I2|live_opt(reverse(Is), 0, D, [])].
+
+
+%% delete_live_annos([Instruction]) -> [Instruction].
+%% Delete all live annotations.
+%%
+delete_live_annos([{block,Bl0}|Is]) ->
+ case delete_live_annos(Bl0) of
+ [] -> delete_live_annos(Is);
+ [_|_]=Bl -> [{block,Bl}|delete_live_annos(Is)]
+ end;
+delete_live_annos([{'%live',_}|Is]) ->
+ delete_live_annos(Is);
+delete_live_annos([I|Is]) ->
+ [I|delete_live_annos(Is)];
+delete_live_annos([]) -> [].
+
+%% combine_heap_needs(HeapNeed1, HeapNeed2) -> HeapNeed
+%% Combine the heap need for two allocation instructions.
+
+combine_heap_needs({alloc,Alloc1}, {alloc,Alloc2}) ->
+ {alloc,combine_alloc_lists(Alloc1, Alloc2)};
+combine_heap_needs({alloc,Alloc}, Words) when is_integer(Words) ->
+ {alloc,combine_alloc_lists(Alloc, [{words,Words}])};
+combine_heap_needs(Words, {alloc,Alloc}) when is_integer(Words) ->
+ {alloc,combine_alloc_lists(Alloc, [{words,Words}])};
+combine_heap_needs(H1, H2) when is_integer(H1), is_integer(H2) ->
+ H1+H2.
+
+%%%
+%%% Local functions.
+%%%
+
+
+%% check_liveness(Reg, [Instruction], {State,BlockCheckFun}) ->
+%% {killed | used | unknown,UpdateState}
+%% Finds out how Reg is used in the instruction sequence. Returns one of:
+%% killed - Reg is assigned a new value or killed by an allocation instruction
+%% used - Reg is used (or possibly referenced by an allocation instruction)
+%% unknown - not possible to determine (perhaps because of an instruction
+%% that we don't recognize)
+
+check_liveness(R, [{set,_,_,_}=I|_], St) ->
+ erlang:error(only_allowed_in_blocks, [R,I,St]);
+check_liveness(R, [{block,Blk}|Is], #live{bl=BlockCheck}=St) ->
+ case BlockCheck(R, Blk) of
+ transparent -> check_liveness(R, Is, St);
+ Other when is_atom(Other) -> {Other,St}
+ end;
+check_liveness(R, [{label,_}|Is], St) ->
+ check_liveness(R, Is, St);
+check_liveness(R, [{test,_,{f,Fail},As}|Is], St0) ->
+ case member(R, As) of
+ true ->
+ {used,St0};
+ false ->
+ case check_liveness_at(R, Fail, St0) of
+ {killed,St} -> check_liveness(R, Is, St);
+ {_,_}=Other -> Other
+ end
+ end;
+check_liveness(R, [{test,_,{f,Fail},Live,Ss,_}|Is], St0) ->
+ case R of
+ {x,X} ->
+ case X < Live orelse member(R, Ss) of
+ true -> {used,St0};
+ false -> check_liveness_at(R, Fail, St0)
+ end;
+ {y,_} ->
+ case check_liveness_at(R, Fail, St0) of
+ {killed,St} -> check_liveness(R, Is, St);
+ {_,_}=Other -> Other
+ end
+ end;
+check_liveness(R, [{select_val,R,_,_}|_], St) ->
+ {used,St};
+check_liveness(R, [{select_val,_,Fail,{list,Branches}}|_], St) ->
+ check_liveness_everywhere(R, [Fail|Branches], St);
+check_liveness(R, [{select_tuple_arity,R,_,_}|_], St) ->
+ {used,St};
+check_liveness(R, [{select_tuple_arity,_,Fail,{list,Branches}}|_], St) ->
+ check_liveness_everywhere(R, [Fail|Branches], St);
+check_liveness(R, [{jump,{f,F}}|_], St) ->
+ check_liveness_at(R, F, St);
+check_liveness(R, [{case_end,Used}|_], St) ->
+ check_liveness_ret(R, Used, St);
+check_liveness(R, [{badmatch,Used}|_], St) ->
+ check_liveness_ret(R, Used, St);
+check_liveness(_, [if_end|_], St) ->
+ {killed,St};
+check_liveness(R, [{func_info,_,_,Ar}|_], St) ->
+ case R of
+ {x,X} when X < Ar -> {used,St};
+ _ -> {killed,St}
+ end;
+check_liveness(R, [{kill,R}|_], St) ->
+ {killed,St};
+check_liveness(R, [{kill,_}|Is], St) ->
+ check_liveness(R, Is, St);
+check_liveness(R, [bs_init_writable|Is], St) ->
+ if
+ R =:= {x,0} -> {used,St};
+ true -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{bs_private_append,_,Bits,_,Bin,_,Dst}|Is], St) ->
+ case R of
+ Bits -> {used,St};
+ Bin -> {used,St};
+ Dst -> {killed,St};
+ _ -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{bs_append,_,Bits,_,_,_,Bin,_,Dst}|Is], St) ->
+ case R of
+ Bits -> {used,St};
+ Bin -> {used,St};
+ Dst -> {killed,St};
+ _ -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{bs_init2,_,_,_,_,_,Dst}|Is], St) ->
+ if
+ R =:= Dst -> {killed,St};
+ true -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{bs_init_bits,_,_,_,_,_,Dst}|Is], St) ->
+ if
+ R =:= Dst -> {killed,St};
+ true -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{bs_put_string,_,_}|Is], St) ->
+ check_liveness(R, Is, St);
+check_liveness(R, [{deallocate,_}|Is], St) ->
+ case R of
+ {y,_} -> {killed,St};
+ _ -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [return|_], St) ->
+ check_liveness_live_ret(R, 1, St);
+check_liveness(R, [{call_last,Live,_,_}|_], St) ->
+ check_liveness_live_ret(R, Live, St);
+check_liveness(R, [{call_only,Live,_}|_], St) ->
+ check_liveness_live_ret(R, Live, St);
+check_liveness(R, [{call_ext_last,Live,_,_}|_], St) ->
+ check_liveness_live_ret(R, Live, St);
+check_liveness(R, [{call_ext_only,Live,_}|_], St) ->
+ check_liveness_live_ret(R, Live, St);
+check_liveness(R, [{call,Live,_}|Is], St) ->
+ case R of
+ {x,X} when X < Live -> {used,St};
+ {x,_} -> {killed,St};
+ {y,_} -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{call_ext,Live,Func}|Is], St) ->
+ case R of
+ {x,X} when X < Live ->
+ {used,St};
+ {x,_} ->
+ {killed,St};
+ {y,_} ->
+ {extfunc,Mod,Name,Arity} = Func,
+ case erl_bifs:is_exit_bif(Mod, Name, Arity) of
+ false ->
+ check_liveness(R, Is, St);
+ true ->
+ %% We must make sure we don't check beyond this instruction
+ %% or we will fall through into random unrelated code and
+ %% get stuck in a loop.
+ %%
+ %% We don't want to overwrite a 'catch', so consider this
+ %% register in use.
+ %%
+ {used,St}
+ end
+ end;
+check_liveness(R, [{call_fun,Live}|Is], St) ->
+ case R of
+ {x,X} when X =< Live -> {used,St};
+ {x,_} -> {killed,St};
+ {y,_} -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{apply,Args}|Is], St) ->
+ case R of
+ {x,X} when X < Args+2 -> {used,St};
+ {x,_} -> {killed,St};
+ {y,_} -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{apply_last,Args,_}|_], St) ->
+ check_liveness_live_ret(R, Args+2, St);
+check_liveness(R, [send|Is], St) ->
+ case R of
+ {x,X} when X < 2 -> {used,St};
+ {x,_} -> {killed,St};
+ {y,_} -> check_liveness(R, Is, St)
+ end;
+check_liveness({x,R}, [{'%live',Live}|Is], St) ->
+ if
+ R < Live -> check_liveness(R, Is, St);
+ true -> {killed,St}
+ end;
+check_liveness(R, [{bif,Op,{f,Fail},Ss,D}|Is], St0) ->
+ case check_liveness_fail(R, Op, Ss, Fail, St0) of
+ {killed,St} = Killed ->
+ case member(R, Ss) of
+ true -> {used,St};
+ false when R =:= D -> Killed;
+ false -> check_liveness(R, Is, St)
+ end;
+ Other ->
+ Other
+ end;
+check_liveness(R, [{gc_bif,Op,{f,Fail},_,Ss,D}|Is], St0) ->
+ case check_liveness_fail(R, Op, Ss, Fail, St0) of
+ {killed,St} = Killed ->
+ case member(R, Ss) of
+ true -> {used,St};
+ false when R =:= D -> Killed;
+ false -> check_liveness(R, Is, St)
+ end;
+ Other ->
+ Other
+ end;
+check_liveness(R, [{bs_add,{f,0},Ss,D}|Is], St) ->
+ case member(R, Ss) of
+ true -> {used,St};
+ false when R =:= D -> {killed,St};
+ false -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{bs_bits_to_bytes2,Src,Dst}|Is], St) ->
+ case R of
+ Src -> {used,St};
+ Dst -> {killed,St};
+ _ -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{bs_put_binary,{f,0},Sz,_,_,Src}|Is], St) ->
+ case member(R, [Sz,Src]) of
+ true -> {used,St};
+ false -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{bs_put_integer,{f,0},Sz,_,_,Src}|Is], St) ->
+ case member(R, [Sz,Src]) of
+ true -> {used,St};
+ false -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{bs_put_float,{f,0},Sz,_,_,Src}|Is], St) ->
+ case member(R, [Sz,Src]) of
+ true -> {used,St};
+ false -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{bs_restore2,S,_}|Is], St) ->
+ case R of
+ S -> {used,St};
+ _ -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{bs_save2,S,_}|Is], St) ->
+ case R of
+ S -> {used,St};
+ _ -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{move,S,D}|Is], St) ->
+ case R of
+ S -> {used,St};
+ D -> {killed,St};
+ _ -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{make_fun2,_,_,_,NumFree}|Is], St) ->
+ case R of
+ {x,X} when X < NumFree -> {used,St};
+ {x,_} -> {killed,St};
+ _ -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{try_end,Y}|Is], St) ->
+ case R of
+ Y -> {killed,St};
+ _ -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{catch_end,Y}|Is], St) ->
+ case R of
+ Y -> {killed,St};
+ _ -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{get_tuple_element,S,_,D}|Is], St) ->
+ case R of
+ S -> {used,St};
+ D -> {killed,St};
+ _ -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{bs_context_to_binary,S}|Is], St) ->
+ case R of
+ S -> {used,St};
+ _ -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{loop_rec,{f,_},{x,0}}|Is], St) ->
+ case R of
+ {x,_} -> {killed,St};
+ _ -> check_liveness(R, Is, St)
+ end;
+check_liveness(R, [{loop_rec_end,{f,Fail}}|_], St) ->
+ check_liveness_at(R, Fail, St);
+check_liveness(_R, Is, St) when is_list(Is) ->
+%% case Is of
+%% [I|_] ->
+%% io:format("~p ~p\n", [_R,I]);
+%% _ -> ok
+%% end,
+ {unknown,St}.
+
+check_liveness_everywhere(R, [{f,Lbl}|T], St0) ->
+ case check_liveness_at(R, Lbl, St0) of
+ {killed,St} -> check_liveness_everywhere(R, T, St);
+ {_,_}=Other -> Other
+ end;
+check_liveness_everywhere(R, [_|T], St) ->
+ check_liveness_everywhere(R, T, St);
+check_liveness_everywhere(_, [], St) ->
+ {killed,St}.
+
+check_liveness_at(R, Lbl, #live{lbl=Ll,res=ResMemorized}=St0) ->
+ case gb_trees:lookup(Lbl, ResMemorized) of
+ {value,Res} ->
+ {Res,St0};
+ none ->
+ {Res,St} = case gb_trees:lookup(Lbl, Ll) of
+ {value,Is} -> check_liveness(R, Is, St0);
+ none -> {unknown,St0}
+ end,
+ {Res,St#live{res=gb_trees:insert(Lbl, Res, St#live.res)}}
+ end.
+
+check_liveness_ret(R, R, St) -> {used,St};
+check_liveness_ret(_, _, St) -> {killed,St}.
+
+check_liveness_live_ret({x,R}, Live, St) ->
+ if
+ R < Live -> {used,St};
+ true -> {killed,St}
+ end;
+check_liveness_live_ret({y,_}, _, St) ->
+ {killed,St}.
+
+check_liveness_fail(_, _, _, 0, St) ->
+ {killed,St};
+check_liveness_fail(R, Op, Args, Fail, St) ->
+ Arity = length(Args),
+ case erl_internal:comp_op(Op, Arity) orelse
+ erl_internal:new_type_test(Op, Arity) of
+ true -> {killed,St};
+ false -> check_liveness_at(R, Fail, St)
+ end.
+
+%% check_killed_block(Reg, [Instruction], State) -> killed | transparent | used
+%% Finds out how Reg is used in the instruction sequence inside a block.
+%% Returns one of:
+%% killed - Reg is assigned a new value or killed by an allocation instruction
+%% transparent - Reg is neither used nor killed
+%% used - Reg is used or referenced by an allocation instruction.
+%%
+%% (Unknown instructions will cause an exception.)
+
+check_killed_block({x,X}, [{set,_,_,{alloc,Live,_}}|_]) ->
+ if
+ X >= Live -> killed;
+ true -> used
+ end;
+check_killed_block(R, [{set,Ds,Ss,_Op}|Is]) ->
+ case member(R, Ss) of
+ true -> used;
+ false ->
+ case member(R, Ds) of
+ true -> killed;
+ false -> check_killed_block(R, Is)
+ end
+ end;
+check_killed_block(R, [{'%live',Live}|Is]) ->
+ case R of
+ {x,X} when X >= Live -> killed;
+ _ -> check_killed_block(R, Is)
+ end;
+check_killed_block(_, []) -> transparent.
+
+%% check_used_block(Reg, [Instruction], State) -> killed | transparent | used
+%% Finds out how Reg is used in the instruction sequence inside a block.
+%% Returns one of:
+%% killed - Reg is assigned a new value or killed by an allocation instruction
+%% transparent - Reg is neither used nor killed
+%% used - Reg is explicitly used by an instruction
+%%
+%% (Unknown instructions will cause an exception.)
+
+check_used_block({x,X}=R, [{set,_,_,{alloc,Live,_}}|Is]) ->
+ if
+ X >= Live -> killed;
+ true -> check_used_block(R, Is)
+ end;
+check_used_block(R, [{set,Ds,Ss,_Op}|Is]) ->
+ case member(R, Ss) of
+ true -> used;
+ false ->
+ case member(R, Ds) of
+ true -> killed;
+ false -> check_used_block(R, Is)
+ end
+ end;
+check_used_block(R, [{'%live',Live}|Is]) ->
+ case R of
+ {x,X} when X >= Live -> killed;
+ _ -> check_used_block(R, Is)
+ end;
+check_used_block(_, []) -> transparent.
+
+index_labels_1([{label,Lbl}|Is0], Acc) ->
+ Is = lists:dropwhile(fun({label,_}) -> true;
+ (_) -> false end, Is0),
+ index_labels_1(Is0, [{Lbl,Is}|Acc]);
+index_labels_1([_|Is], Acc) ->
+ index_labels_1(Is, Acc);
+index_labels_1([], Acc) -> gb_trees:from_orddict(sort(Acc)).
+
+%% Help functions for combine_heap_needs.
+
+combine_alloc_lists(Al1, Al2) ->
+ combine_alloc_lists_1(sort(Al1++Al2)).
+
+combine_alloc_lists_1([{words,W1},{words,W2}|T])
+ when is_integer(W1), is_integer(W2) ->
+ [{words,W1+W2}|combine_alloc_lists_1(T)];
+combine_alloc_lists_1([{floats,F1},{floats,F2}|T])
+ when is_integer(F1), is_integer(F2) ->
+ [{floats,F1+F2}|combine_alloc_lists_1(T)];
+combine_alloc_lists_1([{words,_}=W|T]) ->
+ [W|combine_alloc_lists_1(T)];
+combine_alloc_lists_1([{floats,_}=F|T]) ->
+ [F|combine_alloc_lists_1(T)];
+combine_alloc_lists_1([]) -> [].
+
+%% live_opt/4.
+
+%% Bit syntax instructions.
+live_opt([{bs_context_to_binary,Src}=I|Is], Regs0, D, Acc) ->
+ Regs = x_live([Src], Regs0),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{bs_add,Fail,[Src1,Src2,_],Dst}=I|Is], Regs0, D, Acc) ->
+ Regs1 = x_live([Src1,Src2], x_dead([Dst], Regs0)),
+ Regs = live_join_label(Fail, D, Regs1),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{bs_init2,Fail,_,_,Live,_,_}=I|Is], _, D, Acc) ->
+ Regs1 = live_call(Live),
+ Regs = live_join_label(Fail, D, Regs1),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{bs_init_bits,Fail,Src1,_,Live,_,Src2}=I|Is], _, D, Acc) ->
+ Regs1 = live_call(Live),
+ Regs2 = x_live([Src1,Src2], Regs1),
+ Regs = live_join_label(Fail, D, Regs2),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{bs_append,Fail,Src1,_,Live,_,Src2,_,Dst}=I|Is], _Regs0, D, Acc) ->
+ Regs1 = x_dead([Dst], x_live([Src1,Src2], live_call(Live))),
+ Regs = live_join_label(Fail, D, Regs1),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{bs_private_append,Fail,Src1,_,Src2,_,Dst}=I|Is], Regs0, D, Acc) ->
+ Regs1 = x_live([Src1,Src2], x_dead([Dst], Regs0)),
+ Regs = live_join_label(Fail, D, Regs1),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{bs_put_binary,Fail,Src1,_,_,Src2}=I|Is], Regs0, D, Acc) ->
+ Regs1 = x_live([Src1,Src2], Regs0),
+ Regs = live_join_label(Fail, D, Regs1),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{bs_put_float,Fail,Src1,_,_,Src2}=I|Is], Regs0, D, Acc) ->
+ Regs1 = x_live([Src1,Src2], Regs0),
+ Regs = live_join_label(Fail, D, Regs1),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{bs_put_integer,Fail,Src1,_,_,Src2}=I|Is], Regs0, D, Acc) ->
+ Regs1 = x_live([Src1,Src2], Regs0),
+ Regs = live_join_label(Fail, D, Regs1),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{bs_put_utf8,Fail,_,Src}=I|Is], Regs0, D, Acc) ->
+ Regs1 = x_live([Src], Regs0),
+ Regs = live_join_label(Fail, D, Regs1),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{bs_put_utf16,Fail,_,Src}=I|Is], Regs0, D, Acc) ->
+ Regs1 = x_live([Src], Regs0),
+ Regs = live_join_label(Fail, D, Regs1),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{bs_put_utf32,Fail,_,Src}=I|Is], Regs0, D, Acc) ->
+ Regs1 = x_live([Src], Regs0),
+ Regs = live_join_label(Fail, D, Regs1),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{bs_restore2,Src,_}=I|Is], Regs0, D, Acc) ->
+ Regs = x_live([Src], Regs0),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{bs_save2,Src,_}=I|Is], Regs0, D, Acc) ->
+ Regs = x_live([Src], Regs0),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{bs_utf8_size,Fail,Src,Dst}=I|Is], Regs0, D, Acc) ->
+ Regs1 = x_live([Src], x_dead([Dst], Regs0)),
+ Regs = live_join_label(Fail, D, Regs1),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{bs_utf16_size,Fail,Src,Dst}=I|Is], Regs0, D, Acc) ->
+ Regs1 = x_live([Src], x_dead([Dst], Regs0)),
+ Regs = live_join_label(Fail, D, Regs1),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{test,bs_start_match2,Fail,Live,[Src,_],_}=I|Is], _, D, Acc) ->
+ Regs0 = live_call(Live),
+ Regs1 = x_live([Src], Regs0),
+ Regs = live_join_label(Fail, D, Regs1),
+ live_opt(Is, Regs, D, [I|Acc]);
+
+%% Other instructions.
+live_opt([{block,Bl0}|Is], Regs0, D, Acc) ->
+ Live0 = {'%live',live_regs(Regs0)},
+ {Bl,Regs} = live_opt_block(reverse(Bl0), Regs0, D, [Live0]),
+ Live = {'%live',live_regs(Regs)},
+ live_opt(Is, Regs, D, [{block,[Live|Bl]}|Acc]);
+live_opt([{label,L}=I|Is], Regs, D0, Acc) ->
+ D = gb_trees:insert(L, Regs, D0),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{jump,{f,L}}=I|Is], _, D, Acc) ->
+ Regs = gb_trees:get(L, D),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([return=I|Is], _, D, Acc) ->
+ live_opt(Is, 1, D, [I|Acc]);
+live_opt([{catch_end,_}=I|Is], _, D, Acc) ->
+ live_opt(Is, live_call(1), D, [I|Acc]);
+live_opt([{badmatch,Src}=I|Is], _, D, Acc) ->
+ Regs = x_live([Src], 0),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{case_end,Src}=I|Is], _, D, Acc) ->
+ Regs = x_live([Src], 0),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([if_end=I|Is], _, D, Acc) ->
+ Regs = 0,
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([bs_init_writable=I|Is], _, D, Acc) ->
+ live_opt(Is, live_call(1), D, [I|Acc]);
+live_opt([{call,Arity,_}=I|Is], _, D, Acc) ->
+ live_opt(Is, live_call(Arity), D, [I|Acc]);
+live_opt([{call_ext,Arity,_}=I|Is], _, D, Acc) ->
+ live_opt(Is, live_call(Arity), D, [I|Acc]);
+live_opt([{call_fun,Arity}=I|Is], _, D, Acc) ->
+ live_opt(Is, live_call(Arity+1), D, [I|Acc]);
+live_opt([{call_last,Arity,_,_}=I|Is], _, D, Acc) ->
+ live_opt(Is, live_call(Arity), D, [I|Acc]);
+live_opt([{call_ext_last,Arity,_,_}=I|Is], _, D, Acc) ->
+ live_opt(Is, live_call(Arity), D, [I|Acc]);
+live_opt([{apply,Arity}=I|Is], _, D, Acc) ->
+ live_opt(Is, live_call(Arity+2), D, [I|Acc]);
+live_opt([{apply_last,Arity,_}=I|Is], _, D, Acc) ->
+ live_opt(Is, live_call(Arity+2), D, [I|Acc]);
+live_opt([{call_only,Arity,_}=I|Is], _, D, Acc) ->
+ live_opt(Is, live_call(Arity), D, [I|Acc]);
+live_opt([{call_ext_only,Arity,_}=I|Is], _, D, Acc) ->
+ live_opt(Is, live_call(Arity), D, [I|Acc]);
+live_opt([{make_fun2,_,_,_,Arity}=I|Is], _, D, Acc) ->
+ live_opt(Is, live_call(Arity), D, [I|Acc]);
+live_opt([send=I|Is], _, D, Acc) ->
+ live_opt(Is, live_call(2), D, [I|Acc]);
+live_opt([{test,_,Fail,Ss}=I|Is], Regs0, D, Acc) ->
+ Regs1 = x_live(Ss, Regs0),
+ Regs = live_join_label(Fail, D, Regs1),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{test,_,Fail,Live,Ss,_}=I|Is], _, D, Acc) ->
+ Regs0 = live_call(Live),
+ Regs1 = x_live(Ss, Regs0),
+ Regs = live_join_label(Fail, D, Regs1),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{select_val,Src,Fail,{list,List}}=I|Is], Regs0, D, Acc) ->
+ Regs1 = x_live([Src], Regs0),
+ Regs = live_join_labels([Fail|List], D, Regs1),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{select_tuple_arity,Src,Fail,{list,List}}=I|Is], Regs0, D, Acc) ->
+ Regs1 = x_live([Src], Regs0),
+ Regs = live_join_labels([Fail|List], D, Regs1),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{'try',_,Fail}=I|Is], Regs0, D, Acc) ->
+ Regs = live_join_label(Fail, D, Regs0),
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{try_case,_}=I|Is], _, D, Acc) ->
+ live_opt(Is, live_call(1), D, [I|Acc]);
+live_opt([{loop_rec,_Fail,_Dst}=I|Is], _, D, Acc) ->
+ live_opt(Is, 0, D, [I|Acc]);
+live_opt([timeout=I|Is], _, D, Acc) ->
+ live_opt(Is, 0, D, [I|Acc]);
+
+%% Transparent instructions - they neither use nor modify x registers.
+live_opt([{bs_put_string,_,_}=I|Is], Regs, D, Acc) ->
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{deallocate,_}=I|Is], Regs, D, Acc) ->
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{kill,_}=I|Is], Regs, D, Acc) ->
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{try_case_end,_}=I|Is], Regs, D, Acc) ->
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{try_end,_}=I|Is], Regs, D, Acc) ->
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{loop_rec_end,_}=I|Is], Regs, D, Acc) ->
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{wait,_}=I|Is], Regs, D, Acc) ->
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{wait_timeout,_,{Tag,_}}=I|Is], Regs, D, Acc) when Tag =/= x ->
+ live_opt(Is, Regs, D, [I|Acc]);
+
+%% The following instructions can occur if the "compilation" has been
+%% started from a .S file using the 'asm' option.
+live_opt([{trim,_,_}=I|Is], Regs, D, Acc) ->
+ live_opt(Is, Regs, D, [I|Acc]);
+live_opt([{allocate,_,Live}=I|Is], _, D, Acc) ->
+ live_opt(Is, live_call(Live), D, [I|Acc]);
+live_opt([{allocate_heap,_,_,Live}=I|Is], _, D, Acc) ->
+ live_opt(Is, live_call(Live), D, [I|Acc]);
+
+live_opt([], _, _, Acc) -> Acc.
+
+live_opt_block([{set,[],[],{alloc,Live,_}}=I|Is], _, D, Acc) ->
+ live_opt_block(Is, live_call(Live), D, [I|Acc]);
+live_opt_block([{set,Ds,Ss,Op}=I|Is], Regs0, D, Acc) ->
+ Regs = case Op of
+ {alloc,Live,_} -> live_call(Live);
+ _ -> x_live(Ss, x_dead(Ds, Regs0))
+ end,
+ case Ds of
+ [{x,X}] ->
+ case (not is_live(X, Regs0)) andalso Op =:= move of
+ true ->
+ live_opt_block(Is, Regs0, D, Acc);
+ false ->
+ live_opt_block(Is, Regs, D, [I|Acc])
+ end;
+ _ ->
+ live_opt_block(Is, Regs, D, [I|Acc])
+ end;
+live_opt_block([], Regs, _, Acc) -> {Acc,Regs}.
+
+live_join_labels([{f,L}|T], D, Regs0) when L =/= 0 ->
+ Regs = gb_trees:get(L, D) bor Regs0,
+ live_join_labels(T, D, Regs);
+live_join_labels([_|T], D, Regs) ->
+ live_join_labels(T, D, Regs);
+live_join_labels([], _, Regs) -> Regs.
+
+live_join_label({f,0}, _, Regs) ->
+ Regs;
+live_join_label({f,L}, D, Regs) ->
+ gb_trees:get(L, D) bor Regs.
+
+live_call(Live) -> (1 bsl Live) - 1.
+
+live_regs(Regs) ->
+ live_regs_1(0, Regs).
+
+live_regs_1(N, 0) -> N;
+live_regs_1(N, Regs) -> live_regs_1(N+1, Regs bsr 1).
+
+x_dead([{x,N}|Rs], Regs) -> x_dead(Rs, Regs band (bnot (1 bsl N)));
+x_dead([_|Rs], Regs) -> x_dead(Rs, Regs);
+x_dead([], Regs) -> Regs.
+
+x_live([{x,N}|Rs], Regs) -> x_live(Rs, Regs bor (1 bsl N));
+x_live([_|Rs], Regs) -> x_live(Rs, Regs);
+x_live([], Regs) -> Regs.
+
+is_live(X, Regs) -> ((Regs bsr X) band 1) =:= 1.
diff --git a/lib/compiler/src/beam_validator.erl b/lib/compiler/src/beam_validator.erl
new file mode 100644
index 0000000000..08ba9c3ee4
--- /dev/null
+++ b/lib/compiler/src/beam_validator.erl
@@ -0,0 +1,1764 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2004-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+
+-module(beam_validator).
+
+-export([file/1, files/1]).
+
+%% Interface for compiler.
+-export([module/2, format_error/1]).
+
+-include("beam_disasm.hrl").
+
+-import(lists, [reverse/1,foldl/3,foreach/2,member/2,dropwhile/2]).
+
+-define(MAXREG, 1024).
+
+%%-define(DEBUG, 1).
+-ifdef(DEBUG).
+-define(DBG_FORMAT(F, D), (io:format((F), (D)))).
+-else.
+-define(DBG_FORMAT(F, D), ok).
+-endif.
+
+%%%
+%%% API functions.
+%%%
+
+-spec file(file:filename()) -> 'ok' | {'error', term()}.
+
+file(Name) when is_list(Name) ->
+ case case filename:extension(Name) of
+ ".S" -> s_file(Name);
+ ".beam" -> beam_file(Name)
+ end of
+ [] -> ok;
+ Es -> {error,Es}
+ end.
+
+-spec files([file:filename()]) -> 'ok'.
+
+files([F|Fs]) ->
+ ?DBG_FORMAT("# Verifying: ~p~n", [F]),
+ case file(F) of
+ ok -> ok;
+ {error,Es} ->
+ io:format("~p:~n~s~n", [F,format_error(Es)])
+ end,
+ files(Fs);
+files([]) -> ok.
+
+%% To be called by the compiler.
+module({Mod,Exp,Attr,Fs,Lc}=Code, _Opts)
+ when is_atom(Mod), is_list(Exp), is_list(Attr), is_integer(Lc) ->
+ case validate(Mod, Fs) of
+ [] -> {ok,Code};
+ Es0 ->
+ Es = [{?MODULE,E} || E <- Es0],
+ {error,[{atom_to_list(Mod),Es}]}
+ end.
+
+-spec format_error(term()) -> iolist().
+
+format_error([]) -> [];
+format_error([{{M,F,A},{I,Off,Desc}}|Es]) ->
+ [io_lib:format(" ~p:~p/~p+~p:~n ~p - ~p~n",
+ [M,F,A,Off,I,Desc])|format_error(Es)];
+format_error([Error|Es]) ->
+ [format_error(Error)|format_error(Es)];
+format_error({{_M,F,A},{I,Off,limit}}) ->
+ io_lib:format(
+ "function ~p/~p+~p:~n"
+ " An implementation limit was reached.~n"
+ " Try reducing the complexity of this function.~n~n"
+ " Instruction: ~p~n", [F,A,Off,I]);
+format_error({{_M,F,A},{undef_labels,Lbls}}) ->
+ io_lib:format(
+ "function ~p/~p:~n"
+ " Internal consistency check failed - please report this bug.~n"
+ " The following label(s) were referenced but not defined:~n", [F,A]) ++
+ " " ++ [[integer_to_list(L)," "] || L <- Lbls] ++ "\n";
+format_error({{_M,F,A},{I,Off,Desc}}) ->
+ io_lib:format(
+ "function ~p/~p+~p:~n"
+ " Internal consistency check failed - please report this bug.~n"
+ " Instruction: ~p~n"
+ " Error: ~p:~n", [F,A,Off,I,Desc]);
+format_error({Module,Error}) ->
+ [Module:format_error(Error)];
+format_error(Error) ->
+ io_lib:format("~p~n", [Error]).
+
+%%%
+%%% Local functions follow.
+%%%
+
+s_file(Name) ->
+ {ok,Is} = file:consult(Name),
+ {module,Module} = lists:keyfind(module, 1, Is),
+ Fs = find_functions(Is),
+ validate(Module, Fs).
+
+find_functions(Fs) ->
+ find_functions_1(Fs, none, [], []).
+
+find_functions_1([{function,Name,Arity,Entry}|Is], Func, FuncAcc, Acc0) ->
+ Acc = add_func(Func, FuncAcc, Acc0),
+ find_functions_1(Is, {Name,Arity,Entry}, [], Acc);
+find_functions_1([I|Is], Func, FuncAcc, Acc) ->
+ find_functions_1(Is, Func, [I|FuncAcc], Acc);
+find_functions_1([], Func, FuncAcc, Acc) ->
+ reverse(add_func(Func, FuncAcc, Acc)).
+
+add_func(none, _, Acc) -> Acc;
+add_func({Name,Arity,Entry}, Is, Acc) ->
+ [{function,Name,Arity,Entry,reverse(Is)}|Acc].
+
+beam_file(Name) ->
+ try beam_disasm:file(Name) of
+ {error,beam_lib,Reason} -> [{beam_lib,Reason}];
+ #beam_file{module=Module, code=Code0} ->
+ Code = normalize_disassembled_code(Code0),
+ validate(Module, Code)
+ catch _:_ -> [disassembly_failed]
+ end.
+
+%%%
+%%% The validator follows.
+%%%
+%%% The purpose of the validator is to find errors in the generated
+%%% code that may cause the emulator to crash or behave strangely.
+%%% We don't care about type errors in the user's code that will
+%%% cause a proper exception at run-time.
+%%%
+
+%%% Things currently not checked. XXX
+%%%
+%%% - Heap allocation for binaries.
+%%% - That put_tuple is followed by the correct number of
+%%% put instructions.
+%%%
+
+%% validate(Module, [Function]) -> [] | [Error]
+%% A list of functions with their code. The code is in the same
+%% format as used in the compiler and in .S files.
+
+validate(Module, Fs) ->
+ Ft = index_bs_start_match(Fs, []),
+ validate_0(Module, Fs, Ft).
+
+index_bs_start_match([{function,_,_,Entry,Code}|Fs], Acc0) ->
+ case Code of
+ [_,_,{label,Entry}|Is] ->
+ Acc = index_bs_start_match_1(Is, Entry, Acc0),
+ index_bs_start_match(Fs, Acc);
+ _ ->
+ index_bs_start_match(Fs, Acc0)
+ end;
+index_bs_start_match([], Acc) ->
+ gb_trees:from_orddict(lists:sort(Acc)).
+
+index_bs_start_match_1([{test,bs_start_match2,_,_,_,_}=I|_], Entry, Acc) ->
+ [{Entry,[I]}|Acc];
+index_bs_start_match_1([{test,_,{f,F},_},{bs_context_to_binary,_}|Is0], Entry, Acc) ->
+ [{label,F}|Is] = dropwhile(fun({label,L}) when L =:= F -> false;
+ (_) -> true
+ end, Is0),
+ index_bs_start_match_1(Is, Entry, Acc);
+index_bs_start_match_1(_, _, Acc) -> Acc.
+
+validate_0(_Module, [], _) -> [];
+validate_0(Module, [{function,Name,Ar,Entry,Code}|Fs], Ft) ->
+ try validate_1(Code, Name, Ar, Entry, Ft) of
+ _ -> validate_0(Module, Fs, Ft)
+ catch
+ Error ->
+ [Error|validate_0(Module, Fs, Ft)];
+ error:Error ->
+ [validate_error(Error, Module, Name, Ar)|validate_0(Module, Fs, Ft)]
+ end.
+
+-ifdef(DEBUG).
+validate_error(Error, Module, Name, Ar) ->
+ exit(validate_error_1(Error, Module, Name, Ar)).
+-else.
+validate_error(Error, Module, Name, Ar) ->
+ validate_error_1(Error, Module, Name, Ar).
+-endif.
+validate_error_1(Error, Module, Name, Ar) ->
+ {{Module,Name,Ar},
+ {internal_error,'_',{Error,erlang:get_stacktrace()}}}.
+
+-record(st, %Emulation state
+ {x=init_regs(0, term) :: gb_tree(), %x register info.
+ y=init_regs(0, initialized) :: gb_tree(), %y register info.
+ f=init_fregs(), %
+ numy=none, %Number of y registers.
+ h=0, %Available heap size.
+ hf=0, %Available heap size for floats.
+ fls=undefined, %Floating point state.
+ ct=[], %List of hot catch/try labels
+ bsm=undefined, %Bit syntax matching state.
+ bits=undefined, %Number of bits in bit syntax binary.
+ setelem=false %Previous instruction was setelement/3.
+ }).
+
+-record(vst, %Validator state
+ {current=none :: #st{} | 'none', %Current state
+ branched=gb_trees:empty() :: gb_tree(), %States at jumps
+ labels=gb_sets:empty() :: gb_set(), %All defined labels
+ ft=gb_trees:empty() :: gb_tree() %Some other functions
+ % in the module (those that start with bs_start_match2).
+ }).
+
+-ifdef(DEBUG).
+print_st(#st{x=Xs,y=Ys,numy=NumY,h=H,ct=Ct}) ->
+ io:format(" #st{x=~p~n"
+ " y=~p~n"
+ " numy=~p,h=~p,ct=~w~n",
+ [gb_trees:to_list(Xs),gb_trees:to_list(Ys),NumY,H,Ct]).
+-endif.
+
+validate_1(Is, Name, Arity, Entry, Ft) ->
+ validate_2(labels(Is), Name, Arity, Entry, Ft).
+
+validate_2({Ls1,[{func_info,{atom,Mod},{atom,Name},Arity}=_F|Is]},
+ Name, Arity, Entry, Ft) ->
+ lists:foreach(fun (_L) -> ?DBG_FORMAT(" ~p.~n", [{label,_L}]) end, Ls1),
+ ?DBG_FORMAT(" ~p.~n", [_F]),
+ validate_3(labels(Is), Name, Arity, Entry, Mod, Ls1, Ft);
+validate_2({Ls1,Is}, Name, Arity, _Entry, _Ft) ->
+ error({{'_',Name,Arity},{first(Is),length(Ls1),illegal_instruction}}).
+
+validate_3({Ls2,Is}, Name, Arity, Entry, Mod, Ls1, Ft) ->
+ lists:foreach(fun (_L) -> ?DBG_FORMAT(" ~p.~n", [{label,_L}]) end, Ls2),
+ Offset = 1 + length(Ls1) + 1 + length(Ls2),
+ EntryOK = (Entry =:= undefined) orelse lists:member(Entry, Ls2),
+ if
+ EntryOK ->
+ St = init_state(Arity),
+ Vst0 = #vst{current=St,
+ branched=gb_trees_from_list([{L,St} || L <- Ls1]),
+ labels=gb_sets:from_list(Ls1++Ls2),
+ ft=Ft},
+ MFA = {Mod,Name,Arity},
+ Vst = valfun(Is, MFA, Offset, Vst0),
+ validate_fun_info_branches(Ls1, MFA, Vst);
+ true ->
+ error({{Mod,Name,Arity},{first(Is),Offset,no_entry_label}})
+ end.
+
+validate_fun_info_branches([L|Ls], MFA, #vst{branched=Branches}=Vst0) ->
+ Vst = Vst0#vst{current=gb_trees:get(L, Branches)},
+ validate_fun_info_branches_1(0, MFA, Vst),
+ validate_fun_info_branches(Ls, MFA, Vst);
+validate_fun_info_branches([], _, _) -> ok.
+
+validate_fun_info_branches_1(Arity, {_,_,Arity}, _) -> ok;
+validate_fun_info_branches_1(X, {Mod,Name,Arity}=MFA, Vst) ->
+ try
+ get_term_type({x,X}, Vst)
+ catch Error ->
+ I = {func_info,{atom,Mod},{atom,Name},Arity},
+ Offset = 2,
+ error({MFA,{I,Offset,Error}})
+ end,
+ validate_fun_info_branches_1(X+1, MFA, Vst).
+
+first([X|_]) -> X;
+first([]) -> [].
+
+labels(Is) ->
+ labels_1(Is, []).
+
+labels_1([{label,L}|Is], R) ->
+ labels_1(Is, [L|R]);
+labels_1(Is, R) ->
+ {lists:reverse(R),Is}.
+
+init_state(Arity) ->
+ Xs = init_regs(Arity, term),
+ Ys = init_regs(0, initialized),
+ kill_heap_allocation(#st{x=Xs,y=Ys,numy=none,ct=[]}).
+
+kill_heap_allocation(St) ->
+ St#st{h=0,hf=0}.
+
+init_regs(0, _) ->
+ gb_trees:empty();
+init_regs(N, Type) ->
+ gb_trees_from_list([{R,Type} || R <- lists:seq(0, N-1)]).
+
+valfun([], MFA, _Offset, #vst{branched=Targets0,labels=Labels0}=Vst) ->
+ Targets = gb_trees:keys(Targets0),
+ Labels = gb_sets:to_list(Labels0),
+ case Targets -- Labels of
+ [] -> Vst;
+ Undef ->
+ Error = {undef_labels,Undef},
+ error({MFA,Error})
+ end;
+valfun([I|Is], MFA, Offset, Vst0) ->
+ ?DBG_FORMAT(" ~p.\n", [I]),
+ valfun(Is, MFA, Offset+1,
+ try
+ Vst = val_dsetel(I, Vst0),
+ valfun_1(I, Vst)
+ catch Error ->
+ error({MFA,{I,Offset,Error}})
+ end).
+
+%% Instructions that are allowed in dead code or when failing,
+%% that is while the state is undecided in some way.
+valfun_1({label,Lbl}, #vst{current=St0,branched=B,labels=Lbls}=Vst) ->
+ St = merge_states(Lbl, St0, B),
+ Vst#vst{current=St,branched=gb_trees:enter(Lbl, St, B),
+ labels=gb_sets:add(Lbl, Lbls)};
+valfun_1(_I, #vst{current=none}=Vst) ->
+ %% Ignore instructions after erlang:error/1,2, which
+ %% the original R10B compiler thought would return.
+ ?DBG_FORMAT("Ignoring ~p\n", [_I]),
+ Vst;
+valfun_1({badmatch,Src}, Vst) ->
+ assert_term(Src, Vst),
+ kill_state(Vst);
+valfun_1({case_end,Src}, Vst) ->
+ assert_term(Src, Vst),
+ kill_state(Vst);
+valfun_1(if_end, Vst) ->
+ kill_state(Vst);
+valfun_1({try_case_end,Src}, Vst) ->
+ assert_term(Src, Vst),
+ kill_state(Vst);
+%% Instructions that can not cause exceptions
+valfun_1({bs_context_to_binary,Ctx}, #vst{current=#st{x=Xs}}=Vst) ->
+ case Ctx of
+ {Tag,X} when Tag =:= x; Tag =:= y ->
+ Type = case gb_trees:lookup(X, Xs) of
+ {value,{match_context,_,_}} -> term;
+ _ -> get_term_type(Ctx, Vst)
+ end,
+ set_type_reg(Type, Ctx, Vst);
+ _ ->
+ error({bad_source,Ctx})
+ end;
+valfun_1(bs_init_writable=I, Vst) ->
+ call(I, 1, Vst);
+valfun_1({move,{y,_}=Src,{y,_}=Dst}, Vst) ->
+ %% The stack trimming optimization may generate a move from an initialized
+ %% but unassigned Y register to another Y register.
+ case get_term_type_1(Src, Vst) of
+ {catchtag,_} -> error({catchtag,Src});
+ {trytag,_} -> error({trytag,Src});
+ Type -> set_type_reg(Type, Dst, Vst)
+ end;
+valfun_1({move,Src,Dst}, Vst) ->
+ Type = get_move_term_type(Src, Vst),
+ set_type_reg(Type, Dst, Vst);
+valfun_1({fmove,Src,{fr,_}=Dst}, Vst) ->
+ assert_type(float, Src, Vst),
+ set_freg(Dst, Vst);
+valfun_1({fmove,{fr,_}=Src,Dst}, Vst0) ->
+ assert_freg_set(Src, Vst0),
+ assert_fls(checked, Vst0),
+ Vst = eat_heap_float(Vst0),
+ set_type_reg({float,[]}, Dst, Vst);
+valfun_1({kill,{y,_}=Reg}, Vst) ->
+ set_type_y(initialized, Reg, Vst);
+valfun_1({init,{y,_}=Reg}, Vst) ->
+ set_type_y(initialized, Reg, Vst);
+valfun_1({test_heap,Heap,Live}, Vst) ->
+ test_heap(Heap, Live, Vst);
+valfun_1({bif,_Op,nofail,Src,Dst}, Vst) ->
+ %% The 'nofail' atom only occurs in disassembled code.
+ validate_src(Src, Vst),
+ set_type_reg(term, Dst, Vst);
+valfun_1({bif,Op,{f,_},Src,Dst}=I, Vst) ->
+ case is_bif_safe(Op, length(Src)) of
+ false ->
+ %% Since the BIF can fail, make sure that any catch state
+ %% is updated.
+ valfun_2(I, Vst);
+ true ->
+ %% It can't fail, so we finish handling it here (not updating
+ %% catch state).
+ validate_src(Src, Vst),
+ Type = bif_type(Op, Src, Vst),
+ set_type_reg(Type, Dst, Vst)
+ end;
+%% Put instructions.
+valfun_1({put_list,A,B,Dst}, Vst0) ->
+ assert_term(A, Vst0),
+ assert_term(B, Vst0),
+ Vst = eat_heap(2, Vst0),
+ set_type_reg(cons, Dst, Vst);
+valfun_1({put_tuple,Sz,Dst}, Vst0) when is_integer(Sz) ->
+ Vst = eat_heap(1, Vst0),
+ set_type_reg({tuple,Sz}, Dst, Vst);
+valfun_1({put,Src}, Vst) ->
+ assert_term(Src, Vst),
+ eat_heap(1, Vst);
+valfun_1({put_string,Sz,_,Dst}, Vst0) when is_integer(Sz) ->
+ Vst = eat_heap(2*Sz, Vst0),
+ set_type_reg(cons, Dst, Vst);
+%% Misc.
+valfun_1({'%live',Live}, Vst) ->
+ verify_live(Live, Vst),
+ Vst;
+valfun_1(remove_message, Vst) ->
+ Vst;
+valfun_1({'%',_}, Vst) ->
+ Vst;
+%% Exception generating calls
+valfun_1({call_ext,Live,Func}=I, Vst) ->
+ case return_type(Func, Vst) of
+ exception ->
+ verify_live(Live, Vst),
+ kill_state(Vst);
+ _ ->
+ valfun_2(I, Vst)
+ end;
+valfun_1(_I, #vst{current=#st{ct=undecided}}) ->
+ error(unknown_catch_try_state);
+%%
+%% Allocate and deallocate, et.al
+valfun_1({allocate,Stk,Live}, Vst) ->
+ allocate(false, Stk, 0, Live, Vst);
+valfun_1({allocate_heap,Stk,Heap,Live}, Vst) ->
+ allocate(false, Stk, Heap, Live, Vst);
+valfun_1({allocate_zero,Stk,Live}, Vst) ->
+ allocate(true, Stk, 0, Live, Vst);
+valfun_1({allocate_heap_zero,Stk,Heap,Live}, Vst) ->
+ allocate(true, Stk, Heap, Live, Vst);
+valfun_1({deallocate,StkSize}, #vst{current=#st{numy=StkSize}}=Vst) ->
+ verify_no_ct(Vst),
+ deallocate(Vst);
+valfun_1({deallocate,_}, #vst{current=#st{numy=NumY}}) ->
+ error({allocated,NumY});
+valfun_1({trim,N,Remaining}, #vst{current=#st{y=Yregs0,numy=NumY}=St}=Vst) ->
+ if
+ N =< NumY, N+Remaining =:= NumY ->
+ Yregs1 = [{Y-N,Type} || {Y,Type} <- gb_trees:to_list(Yregs0), Y >= N],
+ Yregs = gb_trees_from_list(Yregs1),
+ Vst#vst{current=St#st{y=Yregs,numy=NumY-N}};
+ true ->
+ error({trim,N,Remaining,allocated,NumY})
+ end;
+%% Catch & try.
+valfun_1({'catch',Dst,{f,Fail}}, Vst0) when Fail /= none ->
+ Vst = #vst{current=#st{ct=Fails}=St} =
+ set_type_y({catchtag,[Fail]}, Dst, Vst0),
+ Vst#vst{current=St#st{ct=[[Fail]|Fails]}};
+valfun_1({'try',Dst,{f,Fail}}, Vst0) ->
+ Vst = #vst{current=#st{ct=Fails}=St} =
+ set_type_y({trytag,[Fail]}, Dst, Vst0),
+ Vst#vst{current=St#st{ct=[[Fail]|Fails]}};
+valfun_1({catch_end,Reg}, #vst{current=#st{ct=[Fail|Fails]}=St0}=Vst0) ->
+ case get_special_y_type(Reg, Vst0) of
+ {catchtag,Fail} ->
+ Vst = #vst{current=St} =
+ set_type_y(initialized_ct, Reg,
+ Vst0#vst{current=St0#st{ct=Fails}}),
+ Xs = gb_trees_from_list([{0,term}]),
+ Vst#vst{current=St#st{x=Xs,fls=undefined}};
+ Type ->
+ error({bad_type,Type})
+ end;
+valfun_1({try_end,Reg}, #vst{current=#st{ct=[Fail|Fails]}=St}=Vst0) ->
+ case get_special_y_type(Reg, Vst0) of
+ {trytag,Fail} ->
+ Vst = case Fail of
+ [FailLabel] -> branch_state(FailLabel, Vst0);
+ _ -> Vst0
+ end,
+ set_type_reg(initialized_ct, Reg,
+ Vst#vst{current=St#st{ct=Fails,fls=undefined}});
+ Type ->
+ error({bad_type,Type})
+ end;
+valfun_1({try_case,Reg}, #vst{current=#st{ct=[Fail|Fails]}=St0}=Vst0) ->
+ case get_special_y_type(Reg, Vst0) of
+ {trytag,Fail} ->
+ Vst = #vst{current=St} =
+ set_type_y(initialized_ct, Reg,
+ Vst0#vst{current=St0#st{ct=Fails}}),
+ Xs = gb_trees_from_list([{0,{atom,[]}},{1,term},{2,term}]), %XXX
+ Vst#vst{current=St#st{x=Xs,fls=undefined}};
+ Type ->
+ error({bad_type,Type})
+ end;
+valfun_1(I, Vst) ->
+ valfun_2(I, Vst).
+
+%% Update branched state if necessary and try next set of instructions.
+valfun_2(I, #vst{current=#st{ct=[]}}=Vst) ->
+ valfun_3(I, Vst);
+valfun_2(I, #vst{current=#st{ct=[[Fail]|_]}}=Vst) when is_integer(Fail) ->
+ %% Update branched state
+ valfun_3(I, branch_state(Fail, Vst));
+valfun_2(_, _) ->
+ error(ambigous_catch_try_state).
+
+%% Handle the remaining floating point instructions here.
+%% Floating point.
+valfun_3({fconv,Src,{fr,_}=Dst}, Vst) ->
+ assert_term(Src, Vst),
+ set_freg(Dst, Vst);
+valfun_3({bif,fadd,_,[_,_]=Src,Dst}, Vst) ->
+ float_op(Src, Dst, Vst);
+valfun_3({bif,fdiv,_,[_,_]=Src,Dst}, Vst) ->
+ float_op(Src, Dst, Vst);
+valfun_3({bif,fmul,_,[_,_]=Src,Dst}, Vst) ->
+ float_op(Src, Dst, Vst);
+valfun_3({bif,fnegate,_,[_]=Src,Dst}, Vst) ->
+ float_op(Src, Dst, Vst);
+valfun_3({bif,fsub,_,[_,_]=Src,Dst}, Vst) ->
+ float_op(Src, Dst, Vst);
+valfun_3(fclearerror, Vst) ->
+ case get_fls(Vst) of
+ undefined -> ok;
+ checked -> ok;
+ Fls -> error({bad_floating_point_state,Fls})
+ end,
+ set_fls(cleared, Vst);
+valfun_3({fcheckerror,_}, Vst) ->
+ assert_fls(cleared, Vst),
+ set_fls(checked, Vst);
+valfun_3(I, Vst) ->
+ %% The instruction is not a float instruction.
+ case get_fls(Vst) of
+ undefined ->
+ valfun_4(I, Vst);
+ checked ->
+ valfun_4(I, Vst);
+ Fls ->
+ error({unsafe_instruction,{float_error_state,Fls}})
+ end.
+
+%% Instructions that can cause exceptions.
+valfun_4({apply,Live}, Vst) ->
+ call(apply, Live+2, Vst);
+valfun_4({apply_last,Live,_}, Vst) ->
+ tail_call(apply, Live+2, Vst);
+valfun_4({call_fun,Live}, Vst) ->
+ call('fun', Live+1, Vst);
+valfun_4({call,Live,Func}, Vst) ->
+ call(Func, Live, Vst);
+valfun_4({call_ext,Live,Func}, Vst) ->
+ %% Exception BIFs has already been taken care of above.
+ call(Func, Live, Vst);
+valfun_4({call_only,Live,Func}, Vst) ->
+ tail_call(Func, Live, Vst);
+valfun_4({call_ext_only,Live,Func}, Vst) ->
+ tail_call(Func, Live, Vst);
+valfun_4({call_last,Live,Func,StkSize}, #vst{current=#st{numy=StkSize}}=Vst) ->
+ tail_call(Func, Live, Vst);
+valfun_4({call_last,_,_,_}, #vst{current=#st{numy=NumY}}) ->
+ error({allocated,NumY});
+valfun_4({call_ext_last,Live,Func,StkSize},
+ #vst{current=#st{numy=StkSize}}=Vst) ->
+ tail_call(Func, Live, Vst);
+valfun_4({call_ext_last,_,_,_}, #vst{current=#st{numy=NumY}}) ->
+ error({allocated,NumY});
+valfun_4({make_fun,_,_,Live}, Vst) ->
+ call('fun', Live, Vst);
+valfun_4({make_fun2,_,_,_,Live}, Vst) ->
+ call(make_fun, Live, Vst);
+%% Other BIFs
+valfun_4({bif,tuple_size,{f,Fail},[Tuple],Dst}, Vst0) ->
+ TupleType0 = get_term_type(Tuple, Vst0),
+ Vst1 = branch_state(Fail, Vst0),
+ TupleType = upgrade_tuple_type({tuple,[0]}, TupleType0),
+ Vst = set_type(TupleType, Tuple, Vst1),
+ set_type_reg({integer,[]}, Dst, Vst);
+valfun_4({bif,element,{f,Fail},[Pos,Tuple],Dst}, Vst0) ->
+ TupleType0 = get_term_type(Tuple, Vst0),
+ PosType = get_term_type(Pos, Vst0),
+ Vst1 = branch_state(Fail, Vst0),
+ TupleType = upgrade_tuple_type({tuple,[get_tuple_size(PosType)]}, TupleType0),
+ Vst = set_type(TupleType, Tuple, Vst1),
+ set_type_reg(term, Dst, Vst);
+valfun_4({raise,{f,_}=Fail,Src,Dst}, Vst) ->
+ valfun_4({bif,raise,Fail,Src,Dst}, Vst);
+valfun_4({bif,Op,{f,Fail},Src,Dst}, Vst0) ->
+ validate_src(Src, Vst0),
+ Vst = branch_state(Fail, Vst0),
+ Type = bif_type(Op, Src, Vst),
+ set_type_reg(Type, Dst, Vst);
+valfun_4({gc_bif,Op,{f,Fail},Live,Src,Dst}, #vst{current=St0}=Vst0) ->
+ St = kill_heap_allocation(St0),
+ Vst1 = Vst0#vst{current=St},
+ verify_live(Live, Vst1),
+ Vst2 = prune_x_regs(Live, Vst1),
+ validate_src(Src, Vst2),
+ Vst = branch_state(Fail, Vst2),
+ Type = bif_type(Op, Src, Vst),
+ set_type_reg(Type, Dst, Vst);
+valfun_4(return, #vst{current=#st{numy=none}}=Vst) ->
+ kill_state(Vst);
+valfun_4(return, #vst{current=#st{numy=NumY}}) ->
+ error({stack_frame,NumY});
+valfun_4({jump,{f,Lbl}}, Vst) ->
+ kill_state(branch_state(Lbl, Vst));
+valfun_4({loop_rec,{f,Fail},Dst}, Vst0) ->
+ Vst = branch_state(Fail, Vst0),
+ set_type_reg(term, Dst, Vst);
+valfun_4({wait,_}, Vst) ->
+ kill_state(Vst);
+valfun_4({wait_timeout,_,Src}, Vst) ->
+ assert_term(Src, Vst),
+ Vst;
+valfun_4({loop_rec_end,_}, Vst) ->
+ kill_state(Vst);
+valfun_4(timeout, #vst{current=St}=Vst) ->
+ Vst#vst{current=St#st{x=init_regs(0, term)}};
+valfun_4(send, Vst) ->
+ call(send, 2, Vst);
+valfun_4({set_tuple_element,Src,Tuple,I}, Vst) ->
+ assert_term(Src, Vst),
+ assert_type({tuple_element,I+1}, Tuple, Vst);
+%% Match instructions.
+valfun_4({select_val,Src,{f,Fail},{list,Choices}}, Vst) ->
+ assert_term(Src, Vst),
+ Lbls = [L || {f,L} <- Choices]++[Fail],
+ kill_state(foldl(fun(L, S) -> branch_state(L, S) end, Vst, Lbls));
+valfun_4({select_tuple_arity,Tuple,{f,Fail},{list,Choices}}, Vst) ->
+ assert_type(tuple, Tuple, Vst),
+ kill_state(branch_arities(Choices, Tuple, branch_state(Fail, Vst)));
+valfun_4({get_list,Src,D1,D2}, Vst0) ->
+ assert_type(cons, Src, Vst0),
+ Vst = set_type_reg(term, D1, Vst0),
+ set_type_reg(term, D2, Vst);
+valfun_4({get_tuple_element,Src,I,Dst}, Vst) ->
+ assert_type({tuple_element,I+1}, Src, Vst),
+ set_type_reg(term, Dst, Vst);
+
+%% New bit syntax matching instructions.
+valfun_4({test,bs_start_match2,{f,Fail},Live,[Ctx,NeedSlots],Ctx}, Vst0) ->
+ %% If source and destination registers are the same, match state
+ %% is OK as input.
+ _ = get_move_term_type(Ctx, Vst0),
+ verify_live(Live, Vst0),
+ Vst1 = prune_x_regs(Live, Vst0),
+ Vst = branch_state(Fail, Vst1),
+ set_type_reg(bsm_match_state(NeedSlots), Ctx, Vst);
+valfun_4({test,bs_start_match2,{f,Fail},Live,[Src,Slots],Dst}, Vst0) ->
+ assert_term(Src, Vst0),
+ verify_live(Live, Vst0),
+ Vst1 = prune_x_regs(Live, Vst0),
+ Vst = branch_state(Fail, Vst1),
+ set_type_reg(bsm_match_state(Slots), Dst, Vst);
+valfun_4({test,bs_match_string,{f,Fail},[Ctx,_,_]}, Vst) ->
+ bsm_validate_context(Ctx, Vst),
+ branch_state(Fail, Vst);
+valfun_4({test,bs_skip_bits2,{f,Fail},[Ctx,Src,_,_]}, Vst) ->
+ bsm_validate_context(Ctx, Vst),
+ assert_term(Src, Vst),
+ branch_state(Fail, Vst);
+valfun_4({test,bs_test_tail2,{f,Fail},[Ctx,_]}, Vst) ->
+ bsm_validate_context(Ctx, Vst),
+ branch_state(Fail, Vst);
+valfun_4({test,bs_test_unit,{f,Fail},[Ctx,_]}, Vst) ->
+ bsm_validate_context(Ctx, Vst),
+ branch_state(Fail, Vst);
+valfun_4({test,bs_skip_utf8,{f,Fail},[Ctx,Live,_]}, Vst) ->
+ validate_bs_skip_utf(Fail, Ctx, Live, Vst);
+valfun_4({test,bs_skip_utf16,{f,Fail},[Ctx,Live,_]}, Vst) ->
+ validate_bs_skip_utf(Fail, Ctx, Live, Vst);
+valfun_4({test,bs_skip_utf32,{f,Fail},[Ctx,Live,_]}, Vst) ->
+ validate_bs_skip_utf(Fail, Ctx, Live, Vst);
+valfun_4({test,bs_get_integer2,{f,Fail},Live,[Ctx,_,_,_],Dst}, Vst) ->
+ validate_bs_get(Fail, Ctx, Live, Dst, Vst);
+valfun_4({test,bs_get_float2,{f,Fail},Live,[Ctx,_,_,_],Dst}, Vst) ->
+ validate_bs_get(Fail, Ctx, Live, Dst, Vst);
+valfun_4({test,bs_get_binary2,{f,Fail},Live,[Ctx,_,_,_],Dst}, Vst) ->
+ validate_bs_get(Fail, Ctx, Live, Dst, Vst);
+valfun_4({test,bs_get_utf8,{f,Fail},Live,[Ctx,_],Dst}, Vst) ->
+ validate_bs_get(Fail, Ctx, Live, Dst, Vst);
+valfun_4({test,bs_get_utf16,{f,Fail},Live,[Ctx,_],Dst}, Vst) ->
+ validate_bs_get(Fail, Ctx, Live, Dst, Vst);
+valfun_4({test,bs_get_utf32,{f,Fail},Live,[Ctx,_],Dst}, Vst) ->
+ validate_bs_get(Fail, Ctx, Live, Dst, Vst);
+valfun_4({bs_save2,Ctx,SavePoint}, Vst) ->
+ bsm_save(Ctx, SavePoint, Vst);
+valfun_4({bs_restore2,Ctx,SavePoint}, Vst) ->
+ bsm_restore(Ctx, SavePoint, Vst);
+
+%% Bit syntax instructions.
+valfun_4({bs_start_match,{f,_Fail}=F,Src}, Vst) ->
+ valfun_4({test,bs_start_match,F,[Src]}, Vst);
+valfun_4({test,bs_start_match,{f,Fail},[Src]}, Vst) ->
+ assert_term(Src, Vst),
+ bs_start_match(branch_state(Fail, Vst));
+
+valfun_4({bs_save,SavePoint}, Vst) ->
+ bs_assert_state(Vst),
+ bs_save(SavePoint, Vst);
+valfun_4({bs_restore,SavePoint}, Vst) ->
+ bs_assert_state(Vst),
+ bs_assert_savepoint(SavePoint, Vst),
+ Vst;
+valfun_4({test,bs_skip_bits,{f,Fail},[Src,_,_]}, Vst) ->
+ bs_assert_state(Vst),
+ assert_term(Src, Vst),
+ branch_state(Fail, Vst);
+valfun_4({test,bs_test_tail,{f,Fail},_}, Vst) ->
+ bs_assert_state(Vst),
+ branch_state(Fail, Vst);
+valfun_4({test,_,{f,Fail},[_,_,_,Dst]}, Vst0) ->
+ bs_assert_state(Vst0),
+ Vst = branch_state(Fail, Vst0),
+ set_type_reg({integer,[]}, Dst, Vst);
+
+%% Other test instructions.
+valfun_4({test,is_float,{f,Lbl},[Float]}, Vst) ->
+ assert_term(Float, Vst),
+ set_type({float,[]}, Float, branch_state(Lbl, Vst));
+valfun_4({test,is_tuple,{f,Lbl},[Tuple]}, Vst) ->
+ Type0 = get_term_type(Tuple, Vst),
+ Type = upgrade_tuple_type({tuple,[0]}, Type0),
+ set_type(Type, Tuple, branch_state(Lbl, Vst));
+valfun_4({test,is_nonempty_list,{f,Lbl},[Cons]}, Vst) ->
+ assert_term(Cons, Vst),
+ set_type(cons, Cons, branch_state(Lbl, Vst));
+valfun_4({test,test_arity,{f,Lbl},[Tuple,Sz]}, Vst) when is_integer(Sz) ->
+ assert_type(tuple, Tuple, Vst),
+ set_type_reg({tuple,Sz}, Tuple, branch_state(Lbl, Vst));
+valfun_4({test,_Op,{f,Lbl},Src}, Vst) ->
+ validate_src(Src, Vst),
+ branch_state(Lbl, Vst);
+valfun_4({bs_add,{f,Fail},[A,B,_],Dst}, Vst) ->
+ assert_term(A, Vst),
+ assert_term(B, Vst),
+ set_type_reg({integer,[]}, Dst, branch_state(Fail, Vst));
+valfun_4({bs_utf8_size,{f,Fail},A,Dst}, Vst) ->
+ assert_term(A, Vst),
+ set_type_reg({integer,[]}, Dst, branch_state(Fail, Vst));
+valfun_4({bs_utf16_size,{f,Fail},A,Dst}, Vst) ->
+ assert_term(A, Vst),
+ set_type_reg({integer,[]}, Dst, branch_state(Fail, Vst));
+valfun_4({bs_bits_to_bytes2,Src,Dst}, Vst) ->
+ assert_term(Src, Vst),
+ set_type_reg({integer,[]}, Dst, Vst);
+valfun_4({bs_bits_to_bytes,{f,Fail},Src,Dst}, Vst) ->
+ assert_term(Src, Vst),
+ set_type_reg({integer,[]}, Dst, branch_state(Fail, Vst));
+valfun_4({bs_init2,{f,Fail},_,Heap,Live,_,Dst}, Vst0) ->
+ verify_live(Live, Vst0),
+ Vst1 = heap_alloc(Heap, Vst0),
+ Vst2 = branch_state(Fail, Vst1),
+ Vst3 = prune_x_regs(Live, Vst2),
+ Vst = bs_zero_bits(Vst3),
+ set_type_reg(binary, Dst, Vst);
+valfun_4({bs_init_bits,{f,Fail},_,Heap,Live,_,Dst}, Vst0) ->
+ verify_live(Live, Vst0),
+ Vst1 = heap_alloc(Heap, Vst0),
+ Vst2 = branch_state(Fail, Vst1),
+ Vst3 = prune_x_regs(Live, Vst2),
+ Vst = bs_zero_bits(Vst3),
+ set_type_reg(binary, Dst, Vst);
+valfun_4({bs_append,{f,Fail},Bits,Heap,Live,_Unit,Bin,_Flags,Dst}, Vst0) ->
+ verify_live(Live, Vst0),
+ assert_term(Bits, Vst0),
+ assert_term(Bin, Vst0),
+ Vst1 = heap_alloc(Heap, Vst0),
+ Vst2 = branch_state(Fail, Vst1),
+ Vst3 = prune_x_regs(Live, Vst2),
+ Vst = bs_zero_bits(Vst3),
+ set_type_reg(binary, Dst, Vst);
+valfun_4({bs_private_append,{f,Fail},Bits,_Unit,Bin,_Flags,Dst}, Vst0) ->
+ assert_term(Bits, Vst0),
+ assert_term(Bin, Vst0),
+ Vst1 = branch_state(Fail, Vst0),
+ Vst = bs_zero_bits(Vst1),
+ set_type_reg(binary, Dst, Vst);
+valfun_4({bs_put_string,Sz,_}, Vst) when is_integer(Sz) ->
+ Vst;
+valfun_4({bs_put_binary,{f,Fail},Sz,_,_,Src}=I, Vst0) ->
+ assert_term(Sz, Vst0),
+ assert_term(Src, Vst0),
+ Vst = bs_align_check(I, Vst0),
+ branch_state(Fail, Vst);
+valfun_4({bs_put_float,{f,Fail},Sz,_,_,Src}=I, Vst0) ->
+ assert_term(Sz, Vst0),
+ assert_term(Src, Vst0),
+ Vst = bs_align_check(I, Vst0),
+ branch_state(Fail, Vst);
+valfun_4({bs_put_integer,{f,Fail},Sz,_,_,Src}=I, Vst0) ->
+ assert_term(Sz, Vst0),
+ assert_term(Src, Vst0),
+ Vst = bs_align_check(I, Vst0),
+ branch_state(Fail, Vst);
+valfun_4({bs_put_utf8,{f,Fail},_,Src}=I, Vst0) ->
+ assert_term(Src, Vst0),
+ Vst = bs_align_check(I, Vst0),
+ branch_state(Fail, Vst);
+valfun_4({bs_put_utf16,{f,Fail},_,Src}=I, Vst0) ->
+ assert_term(Src, Vst0),
+ Vst = bs_align_check(I, Vst0),
+ branch_state(Fail, Vst);
+valfun_4({bs_put_utf32,{f,Fail},_,Src}=I, Vst0) ->
+ assert_term(Src, Vst0),
+ Vst = bs_align_check(I, Vst0),
+ branch_state(Fail, Vst);
+%% Old bit syntax construction (before R10B).
+valfun_4({bs_init,_,_}, Vst) ->
+ bs_zero_bits(Vst);
+valfun_4({bs_need_buf,_}, Vst) -> Vst;
+valfun_4({bs_final,{f,Fail},Dst}, Vst0) ->
+ Vst = branch_state(Fail, Vst0),
+ set_type_reg(binary, Dst, Vst);
+valfun_4({bs_final2,Src,Dst}, Vst0) ->
+ assert_term(Src, Vst0),
+ set_type_reg(binary, Dst, Vst0);
+valfun_4(_, _) ->
+ error(unknown_instruction).
+
+%%
+%% Common code for validating bs_get* instructions.
+%%
+validate_bs_get(Fail, Ctx, Live, Dst, Vst0) ->
+ bsm_validate_context(Ctx, Vst0),
+ verify_live(Live, Vst0),
+ Vst1 = prune_x_regs(Live, Vst0),
+ Vst = branch_state(Fail, Vst1),
+ set_type_reg(term, Dst, Vst).
+
+%%
+%% Common code for validating bs_skip_utf* instructions.
+%%
+validate_bs_skip_utf(Fail, Ctx, Live, Vst0) ->
+ bsm_validate_context(Ctx, Vst0),
+ verify_live(Live, Vst0),
+ Vst = prune_x_regs(Live, Vst0),
+ branch_state(Fail, Vst).
+
+%%
+%% Special state handling for setelement/3 and the set_tuple_element/3 instruction.
+%% A possibility for garbage collection must not occur between setelement/3 and
+%% set_tuple_element/3.
+%%
+val_dsetel({move,_,_}, Vst) ->
+ Vst;
+val_dsetel({put_string,0,{string,""},_}, Vst) ->
+ %% An empty string is OK since it doesn't build anything.
+ Vst;
+val_dsetel({call_ext,3,{extfunc,erlang,setelement,3}}, #vst{current=St}=Vst) ->
+ Vst#vst{current=St#st{setelem=true}};
+val_dsetel({set_tuple_element,_,_,_}, #vst{current=#st{setelem=false}}) ->
+ error(illegal_context_for_set_tuple_element);
+val_dsetel({set_tuple_element,_,_,_}, #vst{current=#st{setelem=true}}=Vst) ->
+ Vst;
+val_dsetel(_, #vst{current=#st{setelem=true}=St}=Vst) ->
+ Vst#vst{current=St#st{setelem=false}};
+val_dsetel(_, Vst) -> Vst.
+
+kill_state(#vst{current=#st{ct=[[Fail]|_]}}=Vst) when is_integer(Fail) ->
+ %% There is an active catch. Make sure that we merge the state into
+ %% the catch label before clearing it, so that that we can be sure
+ %% that the label gets a state.
+ kill_state_1(branch_state(Fail, Vst));
+kill_state(Vst) ->
+ kill_state_1(Vst).
+
+kill_state_1(Vst) ->
+ Vst#vst{current=none}.
+
+%% A "plain" call.
+%% The stackframe must be initialized.
+%% The instruction will return to the instruction following the call.
+call(Name, Live, #vst{current=St}=Vst) ->
+ verify_live(Live, Vst),
+ verify_y_init(Vst),
+ case return_type(Name, Vst) of
+ Type when Type =/= exception ->
+ %% Type is never 'exception' because it has been handled earlier.
+ Xs = gb_trees_from_list([{0,Type}]),
+ Vst#vst{current=St#st{x=Xs,f=init_fregs(),bsm=undefined}}
+ end.
+
+%% Tail call.
+%% The stackframe must have a known size and be initialized.
+%% Does not return to the instruction following the call.
+tail_call(Name, Live, Vst) ->
+ verify_call_args(Name, Live, Vst),
+ verify_y_init(Vst),
+ verify_no_ct(Vst),
+ kill_state(Vst).
+
+verify_call_args(_, 0, #vst{}) ->
+ ok;
+verify_call_args({f,Lbl}, Live, Vst) when is_integer(Live)->
+ Verify = fun(R) ->
+ case get_move_term_type(R, Vst) of
+ {match_context,_,_} ->
+ verify_call_match_context(Lbl, Vst);
+ _ ->
+ ok
+ end
+ end,
+ verify_call_args_1(Live, Verify, Vst);
+verify_call_args(_, Live, Vst) when is_integer(Live)->
+ Verify = fun(R) -> get_term_type(R, Vst) end,
+ verify_call_args_1(Live, Verify, Vst);
+verify_call_args(_, Live, _) ->
+ error({bad_number_of_live_regs,Live}).
+
+verify_call_args_1(0, _, _) -> ok;
+verify_call_args_1(N, Verify, Vst) ->
+ X = N - 1,
+ Verify({x,X}),
+ verify_call_args_1(X, Verify, Vst).
+
+verify_call_match_context(Lbl, #vst{ft=Ft}) ->
+ case gb_trees:lookup(Lbl, Ft) of
+ none ->
+ error(no_bs_start_match2);
+ {value,[{test,bs_start_match2,_,_,[Ctx,_],Ctx}|_]} ->
+ ok;
+ {value,[{test,bs_start_match2,_,_,[Bin,_,_],Ctx}|_]} ->
+ error({binary_and_context_regs_different,Bin,Ctx})
+ end.
+
+allocate(Zero, Stk, Heap, Live, #vst{current=#st{numy=none}=St}=Vst0) ->
+ verify_live(Live, Vst0),
+ Vst = prune_x_regs(Live, Vst0),
+ Ys = init_regs(Stk, case Zero of
+ true -> initialized;
+ false -> uninitialized
+ end),
+ heap_alloc(Heap, Vst#vst{current=St#st{y=Ys,numy=Stk}});
+allocate(_, _, _, _, #vst{current=#st{numy=Numy}}) ->
+ error({existing_stack_frame,{size,Numy}}).
+
+deallocate(#vst{current=St}=Vst) ->
+ Vst#vst{current=St#st{y=init_regs(0, initialized),numy=none,bsm=undefined}}.
+
+test_heap(Heap, Live, Vst0) ->
+ verify_live(Live, Vst0),
+ Vst = prune_x_regs(Live, Vst0),
+ heap_alloc(Heap, Vst).
+
+heap_alloc(Heap, #vst{current=St0}=Vst) ->
+ St1 = kill_heap_allocation(St0#st{bsm=undefined}),
+ St = heap_alloc_1(Heap, St1),
+ Vst#vst{current=St}.
+
+heap_alloc_1({alloc,Alloc}, St) ->
+ heap_alloc_2(Alloc, St);
+heap_alloc_1(HeapWords, St) when is_integer(HeapWords) ->
+ St#st{h=HeapWords}.
+
+heap_alloc_2([{words,HeapWords}|T], St0) ->
+ St = St0#st{h=HeapWords},
+ heap_alloc_2(T, St);
+heap_alloc_2([{floats,Floats}|T], St0) ->
+ St = St0#st{hf=Floats},
+ heap_alloc_2(T, St);
+heap_alloc_2([], St) -> St.
+
+prune_x_regs(Live, #vst{current=#st{x=Xs0}=St0}=Vst) when is_integer(Live) ->
+ Xs1 = gb_trees:to_list(Xs0),
+ Xs = [P || {R,_}=P <- Xs1, R < Live],
+ St = St0#st{x=gb_trees:from_orddict(Xs)},
+ Vst#vst{current=St}.
+
+%%%
+%%% Floating point checking.
+%%%
+%%% Possible values for the fls field (=floating point error state).
+%%%
+%%% undefined - Undefined (initial state). No float operations allowed.
+%%%
+%%% cleared - fclearerror/0 has been executed. Float operations
+%%% are allowed (such as fadd).
+%%%
+%%% checked - fcheckerror/1 has been executed. It is allowed to
+%%% move values out of floating point registers.
+%%%
+%%% The following instructions may be executed in any state:
+%%%
+%%% fconv Src {fr,_}
+%%% fmove Src {fr,_} %% Move INTO floating point register.
+%%%
+
+float_op(Src, Dst, Vst0) ->
+ foreach (fun(S) -> assert_freg_set(S, Vst0) end, Src),
+ assert_fls(cleared, Vst0),
+ Vst = set_fls(cleared, Vst0),
+ set_freg(Dst, Vst).
+
+assert_fls(Fls, Vst) ->
+ case get_fls(Vst) of
+ Fls -> Vst;
+ OtherFls -> error({bad_floating_point_state,OtherFls})
+ end.
+
+set_fls(Fls, #vst{current=#st{}=St}=Vst) when is_atom(Fls) ->
+ Vst#vst{current=St#st{fls=Fls}}.
+
+get_fls(#vst{current=#st{fls=Fls}}) when is_atom(Fls) -> Fls.
+
+init_fregs() -> 0.
+
+set_freg({fr,Fr}, #vst{current=#st{f=Fregs0}=St}=Vst)
+ when is_integer(Fr), 0 =< Fr ->
+ limit_check(Fr),
+ Bit = 1 bsl Fr,
+ if
+ Fregs0 band Bit =:= 0 ->
+ Fregs = Fregs0 bor Bit,
+ Vst#vst{current=St#st{f=Fregs}};
+ true -> Vst
+ end;
+set_freg(Fr, _) -> error({bad_target,Fr}).
+
+assert_freg_set({fr,Fr}=Freg, #vst{current=#st{f=Fregs}})
+ when is_integer(Fr), 0 =< Fr ->
+ if
+ Fregs band (1 bsl Fr) =/= 0 ->
+ limit_check(Fr);
+ true -> error({uninitialized_reg,Freg})
+ end;
+assert_freg_set(Fr, _) -> error({bad_source,Fr}).
+
+%%%
+%%% Binary matching.
+%%%
+%%% Possible values for the bsm field (=bit syntax matching state).
+%%%
+%%% undefined - Undefined (initial state). No matching instructions allowed.
+%%%
+%%% (gb set) - The gb set contains the defined save points.
+%%%
+%%% The bsm field is reset to 'undefined' by instructions that may cause a
+%%% a garbage collection (might move the binary) and/or context switch
+%%% (may invalidate the save points).
+
+bs_start_match(#vst{current=#st{bsm=undefined}=St}=Vst) ->
+ Vst#vst{current=St#st{bsm=gb_sets:empty()}};
+bs_start_match(Vst) ->
+ %% Must retain save points here - it is possible to restore back
+ %% to a previous binary.
+ Vst.
+
+bs_save(Reg, #vst{current=#st{bsm=Saved}=St}=Vst)
+ when is_integer(Reg), Reg < ?MAXREG ->
+ Vst#vst{current=St#st{bsm=gb_sets:add(Reg, Saved)}};
+bs_save(_, _) -> error(limit).
+
+bs_assert_savepoint(Reg, #vst{current=#st{bsm=Saved}}) ->
+ case gb_sets:is_member(Reg, Saved) of
+ false -> error({no_save_point,Reg});
+ true -> ok
+ end.
+
+bs_assert_state(#vst{current=#st{bsm=undefined}}) ->
+ error(no_bs_match_state);
+bs_assert_state(_) -> ok.
+
+
+%%%
+%%% New binary matching instructions.
+%%%
+
+bsm_match_state(Slots) ->
+ {match_context,0,Slots}.
+
+bsm_validate_context(Reg, Vst) ->
+ bsm_get_context(Reg, Vst),
+ ok.
+
+bsm_get_context({x,X}=Reg, #vst{current=#st{x=Xs}}=_Vst) when is_integer(X) ->
+ case gb_trees:lookup(X, Xs) of
+ {value,{match_context,_,_}=Ctx} -> Ctx;
+ _ -> error({no_bsm_context,Reg})
+ end;
+bsm_get_context(Reg, _) -> error({bad_source,Reg}).
+
+bsm_save(Reg, {atom,start}, Vst) ->
+ %% Save point refering to where the match started.
+ %% It is always valid. But don't forget to validate the context register.
+ bsm_get_context(Reg, Vst),
+ Vst;
+bsm_save(Reg, SavePoint, Vst) ->
+ case bsm_get_context(Reg, Vst) of
+ {match_context,Bits,Slots} when SavePoint < Slots ->
+ Ctx = {match_context,Bits bor (1 bsl SavePoint),Slots},
+ set_type_reg(Ctx, Reg, Vst);
+ _ -> error({illegal_save,SavePoint})
+ end.
+
+bsm_restore(Reg, {atom,start}, Vst) ->
+ %% (Mostly) automatic save point refering to where the match started.
+ %% It is always valid. But don't forget to validate the context register.
+ bsm_get_context(Reg, Vst),
+ Vst;
+bsm_restore(Reg, SavePoint, Vst) ->
+ case bsm_get_context(Reg, Vst) of
+ {match_context,Bits,Slots} when SavePoint < Slots ->
+ case Bits band (1 bsl SavePoint) of
+ 0 -> error({illegal_restore,SavePoint,not_set});
+ _ -> Vst
+ end;
+ _ -> error({illegal_restore,SavePoint,range})
+ end.
+
+
+%%%
+%%% Validation of alignment in the bit syntax. (Currently, construction only.)
+%%%
+%%% We make sure that the aligned flag is only set when we can be sure of the
+%%% aligment.
+%%%
+
+bs_zero_bits(#vst{current=St}=Vst) ->
+ Vst#vst{current=St#st{bits=0}}.
+
+bs_align_check({bs_put_utf8,_,Flags,_}, #vst{current=#st{}=St}=Vst) ->
+ bs_verify_flags(Flags, St),
+ Vst;
+bs_align_check({bs_put_utf16,_,Flags,_}, #vst{current=#st{}=St}=Vst) ->
+ bs_verify_flags(Flags, St),
+ Vst;
+bs_align_check({bs_put_utf32,_,Flags,_}, #vst{current=#st{}=St}=Vst) ->
+ bs_verify_flags(Flags, St),
+ Vst;
+bs_align_check({_,_,Sz,U,Flags,_}, #vst{current=#st{bits=Bits}=St}=Vst) ->
+ bs_verify_flags(Flags, St),
+ bs_update_bits(Bits, Sz, U, St, Vst).
+
+bs_update_bits(undefined, _, _, _, Vst) -> Vst;
+bs_update_bits(Bits0, {integer,Sz}, U, St, Vst) ->
+ Bits = Bits0 + U*Sz,
+ Vst#vst{current=St#st{bits=Bits}};
+bs_update_bits(_, {atom,all}, _, _, Vst) ->
+ %% A binary will not change the alignment.
+ Vst;
+bs_update_bits(_, _, U, _, Vst) when U rem 8 =:= 0 ->
+ %% Units of 8, 16, and so on will not change the aligment.
+ Vst;
+bs_update_bits(_, _, _, St, Vst) ->
+ %% We can no longer be sure about aligment.
+ Vst#vst{current=St#st{bits=undefined}}.
+
+bs_verify_flags({field_flags,Fl}, #st{bits=Bits}) ->
+ case bs_is_aligned(Fl) of
+ false -> ok;
+ true when is_integer(Bits), Bits rem 8 =:= 0 -> ok;
+ true -> error({aligned_flag_set,{bits,Bits}})
+ end.
+
+bs_is_aligned(Fl) when is_integer(Fl) -> Fl band 1 =:= 1;
+bs_is_aligned(Fl) when is_list(Fl) -> member(aligned, Fl).
+
+%%%
+%%% Keeping track of types.
+%%%
+
+set_type(Type, {x,_}=Reg, Vst) -> set_type_reg(Type, Reg, Vst);
+set_type(Type, {y,_}=Reg, Vst) -> set_type_y(Type, Reg, Vst);
+set_type(_, _, #vst{}=Vst) -> Vst.
+
+set_type_reg(Type, {x,X}, #vst{current=#st{x=Xs}=St}=Vst)
+ when is_integer(X), 0 =< X ->
+ limit_check(X),
+ Vst#vst{current=St#st{x=gb_trees:enter(X, Type, Xs)}};
+set_type_reg(Type, Reg, Vst) ->
+ set_type_y(Type, Reg, Vst).
+
+set_type_y(Type, {y,Y}=Reg, #vst{current=#st{y=Ys0,numy=NumY}=St}=Vst)
+ when is_integer(Y), 0 =< Y ->
+ limit_check(Y),
+ case {Y,NumY} of
+ {_,none} ->
+ error({no_stack_frame,Reg});
+ {_,_} when Y > NumY ->
+ error({y_reg_out_of_range,Reg,NumY});
+ {_,_} ->
+ Ys = if Type =:= initialized_ct ->
+ gb_trees:enter(Y, initialized, Ys0);
+ true ->
+ case gb_trees:lookup(Y, Ys0) of
+ none ->
+ gb_trees:insert(Y, Type, Ys0);
+ {value,uinitialized} ->
+ gb_trees:insert(Y, Type, Ys0);
+ {value,{catchtag,_}=Tag} ->
+ error(Tag);
+ {value,{trytag,_}=Tag} ->
+ error(Tag);
+ {value,_} ->
+ gb_trees:update(Y, Type, Ys0)
+ end
+ end,
+ Vst#vst{current=St#st{y=Ys}}
+ end;
+set_type_y(Type, Reg, #vst{}) -> error({invalid_store,Reg,Type}).
+
+assert_term(Src, Vst) ->
+ get_term_type(Src, Vst),
+ ok.
+
+%% The possible types.
+%%
+%% First non-term types:
+%%
+%% initialized Only for Y registers. Means that the Y register
+%% has been initialized with some valid term so that
+%% it is safe to pass to the garbage collector.
+%% NOT safe to use in any other way (will not crash the
+%% emulator, but clearly points to a bug in the compiler).
+%%
+%% {catchtag,[Lbl]} A special term used within a catch. Must only be used
+%% by the catch instructions; NOT safe to use in other
+%% instructions.
+%%
+%% {trytag,[Lbl]} A special term used within a try block. Must only be
+%% used by the catch instructions; NOT safe to use in other
+%% instructions.
+%%
+%% exception Can only be used as a type returned by return_type/2
+%% (which gives the type of the value returned by a BIF).
+%% Thus 'exception' is never stored as type descriptor
+%% for a register.
+%%
+%% {match_context,_,_} A matching context for bit syntax matching. We do allow
+%% it to moved/to from stack, but otherwise it must only
+%% be accessed by bit syntax matching instructions.
+%%
+%%
+%% Normal terms:
+%%
+%% term Any valid Erlang (but not of the special types above).
+%%
+%% bool The atom 'true' or the atom 'false'.
+%%
+%% cons Cons cell: [_|_]
+%%
+%% nil Empty list: []
+%%
+%% {tuple,[Sz]} Tuple. An element has been accessed using
+%% element/2 or setelement/3 so that it is known that
+%% the type is a tuple of size at least Sz.
+%%
+%% {tuple,Sz} Tuple. A test_arity instruction has been seen
+%% so that it is known that the size is exactly Sz.
+%%
+%% {atom,[]} Atom.
+%% {atom,Atom}
+%%
+%% {integer,[]} Integer.
+%% {integer,Integer}
+%%
+%% {float,[]} Float.
+%% {float,Float}
+%%
+%% number Integer or Float of unknown value
+%%
+
+assert_type(WantedType, Term, Vst) ->
+ assert_type(WantedType, get_term_type(Term, Vst)),
+ Vst.
+
+assert_type(Correct, Correct) -> ok;
+assert_type(float, {float,_}) -> ok;
+assert_type(tuple, {tuple,_}) -> ok;
+assert_type({tuple_element,I}, {tuple,[Sz]})
+ when 1 =< I, I =< Sz ->
+ ok;
+assert_type({tuple_element,I}, {tuple,Sz})
+ when is_integer(Sz), 1 =< I, I =< Sz ->
+ ok;
+assert_type(Needed, Actual) ->
+ error({bad_type,{needed,Needed},{actual,Actual}}).
+
+
+%% upgrade_tuple_type(NewTupleType, OldType) -> TupleType.
+%% upgrade_tuple_type/2 is used when linear code finds out more and
+%% more information about a tuple type, so that the type gets more
+%% specialized. If OldType is not a tuple type, the type information
+%% is inconsistent, and we know that some instructions will never
+%% be executed at run-time.
+
+upgrade_tuple_type({tuple,[Sz]}, {tuple,[OldSz]}=T) when Sz < OldSz ->
+ %% The old type has a higher value for the least tuple size.
+ T;
+upgrade_tuple_type({tuple,[Sz]}, {tuple,OldSz}=T)
+ when is_integer(Sz), is_integer(OldSz), Sz =< OldSz ->
+ %% The old size is exact, and the new size is smaller than the old size.
+ T;
+upgrade_tuple_type({tuple,_}=T, _) ->
+ %% The new type information is exact or has a higher value for
+ %% the least tuple size.
+ %% Note that inconsistencies are also handled in this
+ %% clause, e.g. if the old type was an integer or a tuple accessed
+ %% outside its size; inconsistences will generally cause an exception
+ %% at run-time but are safe from our point of view.
+ T.
+
+get_tuple_size({integer,[]}) -> 0;
+get_tuple_size({integer,Sz}) -> Sz;
+get_tuple_size(_) -> 0.
+
+validate_src(Ss, Vst) when is_list(Ss) ->
+ foreach(fun(S) -> get_term_type(S, Vst) end, Ss).
+
+%% get_move_term_type(Src, ValidatorState) -> Type
+%% Get the type of the source Src. The returned type Type will be
+%% a standard Erlang type (no catch/try tags). Match contexts are OK.
+
+get_move_term_type(Src, Vst) ->
+ case get_term_type_1(Src, Vst) of
+ initialized -> error({unassigned,Src});
+ {catchtag,_} -> error({catchtag,Src});
+ {trytag,_} -> error({trytag,Src});
+ Type -> Type
+ end.
+
+%% get_term_type(Src, ValidatorState) -> Type
+%% Get the type of the source Src. The returned type Type will be
+%% a standard Erlang type (no catch/try tags or match contexts).
+
+get_term_type(Src, Vst) ->
+ case get_term_type_1(Src, Vst) of
+ initialized -> error({unassigned,Src});
+ {catchtag,_} -> error({catchtag,Src});
+ {trytag,_} -> error({trytag,Src});
+ {match_context,_,_} -> error({match_context,Src});
+ Type -> Type
+ end.
+
+%% get_special_y_type(Src, ValidatorState) -> Type
+%% Return the type for the Y register without doing any validity checks.
+
+get_special_y_type({y,_}=Reg, Vst) -> get_term_type_1(Reg, Vst);
+get_special_y_type(Src, _) -> error({source_not_y_reg,Src}).
+
+get_term_type_1(nil=T, _) -> T;
+get_term_type_1({atom,A}=T, _) when is_atom(A) -> T;
+get_term_type_1({float,F}=T, _) when is_float(F) -> T;
+get_term_type_1({integer,I}=T, _) when is_integer(I) -> T;
+get_term_type_1({literal,_}=T, _) -> T;
+get_term_type_1({x,X}=Reg, #vst{current=#st{x=Xs}}) when is_integer(X) ->
+ case gb_trees:lookup(X, Xs) of
+ {value,Type} -> Type;
+ none -> error({uninitialized_reg,Reg})
+ end;
+get_term_type_1({y,Y}=Reg, #vst{current=#st{y=Ys}}) when is_integer(Y) ->
+ case gb_trees:lookup(Y, Ys) of
+ none -> error({uninitialized_reg,Reg});
+ {value,uninitialized} -> error({uninitialized_reg,Reg});
+ {value,Type} -> Type
+ end;
+get_term_type_1(Src, _) -> error({bad_source,Src}).
+
+
+branch_arities([], _, #vst{}=Vst) -> Vst;
+branch_arities([Sz,{f,L}|T], Tuple, #vst{current=St}=Vst0)
+ when is_integer(Sz) ->
+ Vst1 = set_type_reg({tuple,Sz}, Tuple, Vst0),
+ Vst = branch_state(L, Vst1),
+ branch_arities(T, Tuple, Vst#vst{current=St}).
+
+branch_state(0, #vst{}=Vst) -> Vst;
+branch_state(L, #vst{current=St,branched=B}=Vst) ->
+ Vst#vst{
+ branched=case gb_trees:is_defined(L, B) of
+ false ->
+ gb_trees:insert(L, St, B);
+ true ->
+ MergedSt = merge_states(L, St, B),
+ gb_trees:update(L, MergedSt, B)
+ end}.
+
+%% merge_states/3 is used when there are more than one way to arrive
+%% at this point, and the type states for the different paths has
+%% to be merged. The type states are downgraded to the least common
+%% subset for the subsequent code.
+
+merge_states(L, St, Branched) when L =/= 0 ->
+ case gb_trees:lookup(L, Branched) of
+ none -> St;
+ {value,OtherSt} when St =:= none -> OtherSt;
+ {value,OtherSt} -> merge_states_1(St, OtherSt)
+ end.
+
+merge_states_1(#st{x=Xs0,y=Ys0,numy=NumY0,h=H0,ct=Ct0,bsm=Bsm0}=St,
+ #st{x=Xs1,y=Ys1,numy=NumY1,h=H1,ct=Ct1,bsm=Bsm1}) ->
+ NumY = merge_stk(NumY0, NumY1),
+ Xs = merge_regs(Xs0, Xs1),
+ Ys = merge_y_regs(Ys0, Ys1),
+ Ct = merge_ct(Ct0, Ct1),
+ Bsm = merge_bsm(Bsm0, Bsm1),
+ St#st{x=Xs,y=Ys,numy=NumY,h=min(H0, H1),ct=Ct,bsm=Bsm}.
+
+merge_stk(S, S) -> S;
+merge_stk(_, _) -> undecided.
+
+merge_ct(S, S) -> S;
+merge_ct(Ct0, Ct1) -> merge_ct_1(Ct0, Ct1).
+
+merge_ct_1([C0|Ct0], [C1|Ct1]) ->
+ [ordsets:from_list(C0++C1)|merge_ct_1(Ct0, Ct1)];
+merge_ct_1([], []) -> [];
+merge_ct_1(_, _) -> undecided.
+
+merge_regs(Rs0, Rs1) ->
+ Rs = merge_regs_1(gb_trees:to_list(Rs0), gb_trees:to_list(Rs1)),
+ gb_trees_from_list(Rs).
+
+merge_regs_1([Same|Rs1], [Same|Rs2]) ->
+ [Same|merge_regs_1(Rs1, Rs2)];
+merge_regs_1([{R1,_}|Rs1], [{R2,_}|_]=Rs2) when R1 < R2 ->
+ merge_regs_1(Rs1, Rs2);
+merge_regs_1([{R1,_}|_]=Rs1, [{R2,_}|Rs2]) when R1 > R2 ->
+ merge_regs_1(Rs1, Rs2);
+merge_regs_1([{R,Type1}|Rs1], [{R,Type2}|Rs2]) ->
+ [{R,merge_types(Type1, Type2)}|merge_regs_1(Rs1, Rs2)];
+merge_regs_1([], []) -> [];
+merge_regs_1([], [_|_]) -> [];
+merge_regs_1([_|_], []) -> [].
+
+merge_y_regs(Rs0, Rs1) ->
+ Rs = merge_y_regs_1(gb_trees:to_list(Rs0), gb_trees:to_list(Rs1)),
+ gb_trees_from_list(Rs).
+
+merge_y_regs_1([Same|Rs1], [Same|Rs2]) ->
+ [Same|merge_y_regs_1(Rs1, Rs2)];
+merge_y_regs_1([{R1,_}|Rs1], [{R2,_}|_]=Rs2) when R1 < R2 ->
+ [{R1,uninitialized}|merge_y_regs_1(Rs1, Rs2)];
+merge_y_regs_1([{R1,_}|_]=Rs1, [{R2,_}|Rs2]) when R1 > R2 ->
+ [{R2,uninitialized}|merge_y_regs_1(Rs1, Rs2)];
+merge_y_regs_1([{R,Type1}|Rs1], [{R,Type2}|Rs2]) ->
+ [{R,merge_types(Type1, Type2)}|merge_y_regs_1(Rs1, Rs2)];
+merge_y_regs_1([], []) -> [];
+merge_y_regs_1([], [_|_]=Rs) -> Rs;
+merge_y_regs_1([_|_]=Rs, []) -> Rs.
+
+%% merge_types(Type1, Type2) -> Type
+%% Return the most specific type possible.
+%% Note: Type1 must NOT be the same as Type2.
+merge_types(uninitialized=I, _) -> I;
+merge_types(_, uninitialized=I) -> I;
+merge_types(initialized=I, _) -> I;
+merge_types(_, initialized=I) -> I;
+merge_types({catchtag,T0},{catchtag,T1}) ->
+ {catchtag,ordsets:from_list(T0++T1)};
+merge_types({trytag,T0},{trytag,T1}) ->
+ {trytag,ordsets:from_list(T0++T1)};
+merge_types({tuple,A}, {tuple,B}) ->
+ {tuple,[min(tuple_sz(A), tuple_sz(B))]};
+merge_types({Type,A}, {Type,B})
+ when Type =:= atom; Type =:= integer; Type =:= float ->
+ if A =:= B -> {Type,A};
+ true -> {Type,[]}
+ end;
+merge_types({Type,_}, number)
+ when Type =:= integer; Type =:= float ->
+ number;
+merge_types(number, {Type,_})
+ when Type =:= integer; Type =:= float ->
+ number;
+merge_types(bool, {atom,A}) ->
+ merge_bool(A);
+merge_types({atom,A}, bool) ->
+ merge_bool(A);
+merge_types({match_context,B0,Slots},{match_context,B1,Slots}) ->
+ {match_context,B0 bor B1,Slots};
+merge_types({match_context,_,_}=M, _) ->
+ M;
+merge_types(_, {match_context,_,_}=M) ->
+ M;
+merge_types(T1, T2) when T1 =/= T2 ->
+ %% Too different. All we know is that the type is a 'term'.
+ term.
+
+merge_bsm(undefined, _) -> undefined;
+merge_bsm(_, undefined) -> undefined;
+merge_bsm(Bsm0, Bsm1) -> gb_sets:intersection(Bsm0, Bsm1).
+
+tuple_sz([Sz]) -> Sz;
+tuple_sz(Sz) -> Sz.
+
+merge_bool([]) -> {atom,[]};
+merge_bool(true) -> bool;
+merge_bool(false) -> bool;
+merge_bool(_) -> {atom,[]}.
+
+verify_y_init(#vst{current=#st{y=Ys}}) ->
+ verify_y_init_1(gb_trees:to_list(Ys)).
+
+verify_y_init_1([]) -> ok;
+verify_y_init_1([{Y,uninitialized}|_]) ->
+ error({uninitialized_reg,{y,Y}});
+verify_y_init_1([{_,_}|Ys]) ->
+ verify_y_init_1(Ys).
+
+verify_live(0, #vst{}) -> ok;
+verify_live(N, #vst{current=#st{x=Xs}}) ->
+ verify_live_1(N, Xs).
+
+verify_live_1(0, _) -> ok;
+verify_live_1(N, Xs) when is_integer(N) ->
+ X = N-1,
+ case gb_trees:is_defined(X, Xs) of
+ false -> error({{x,X},not_live});
+ true -> verify_live_1(X, Xs)
+ end;
+verify_live_1(N, _) -> error({bad_number_of_live_regs,N}).
+
+verify_no_ct(#vst{current=#st{numy=none}}) -> ok;
+verify_no_ct(#vst{current=#st{numy=undecided}}) ->
+ error(unknown_size_of_stackframe);
+verify_no_ct(#vst{current=#st{y=Ys}}) ->
+ case [Y || Y <- gb_trees:to_list(Ys), verify_no_ct_1(Y)] of
+ [] -> ok;
+ CT -> error({unfinished_catch_try,CT})
+ end.
+
+verify_no_ct_1({_, {catchtag, _}}) -> true;
+verify_no_ct_1({_, {trytag, _}}) -> true;
+verify_no_ct_1({_, _}) -> false.
+
+eat_heap(N, #vst{current=#st{h=Heap0}=St}=Vst) ->
+ case Heap0-N of
+ Neg when Neg < 0 ->
+ error({heap_overflow,{left,Heap0},{wanted,N}});
+ Heap ->
+ Vst#vst{current=St#st{h=Heap}}
+ end.
+
+eat_heap_float(#vst{current=#st{hf=HeapFloats0}=St}=Vst) ->
+ case HeapFloats0-1 of
+ Neg when Neg < 0 ->
+ error({heap_overflow,{left,{HeapFloats0,floats}},{wanted,{1,floats}}});
+ HeapFloats ->
+ Vst#vst{current=St#st{hf=HeapFloats}}
+ end.
+
+bif_type('-', Src, Vst) ->
+ arith_type(Src, Vst);
+bif_type('+', Src, Vst) ->
+ arith_type(Src, Vst);
+bif_type('*', Src, Vst) ->
+ arith_type(Src, Vst);
+bif_type(abs, [Num], Vst) ->
+ case get_term_type(Num, Vst) of
+ {float,_}=T -> T;
+ {integer,_}=T -> T;
+ _ -> number
+ end;
+bif_type(float, _, _) -> {float,[]};
+bif_type('/', _, _) -> {float,[]};
+%% Integer operations.
+bif_type('div', [_,_], _) -> {integer,[]};
+bif_type('rem', [_,_], _) -> {integer,[]};
+bif_type(length, [_], _) -> {integer,[]};
+bif_type(size, [_], _) -> {integer,[]};
+bif_type(trunc, [_], _) -> {integer,[]};
+bif_type(round, [_], _) -> {integer,[]};
+bif_type('band', [_,_], _) -> {integer,[]};
+bif_type('bor', [_,_], _) -> {integer,[]};
+bif_type('bxor', [_,_], _) -> {integer,[]};
+bif_type('bnot', [_], _) -> {integer,[]};
+bif_type('bsl', [_,_], _) -> {integer,[]};
+bif_type('bsr', [_,_], _) -> {integer,[]};
+%% Booleans.
+bif_type('==', [_,_], _) -> bool;
+bif_type('/=', [_,_], _) -> bool;
+bif_type('=<', [_,_], _) -> bool;
+bif_type('<', [_,_], _) -> bool;
+bif_type('>=', [_,_], _) -> bool;
+bif_type('>', [_,_], _) -> bool;
+bif_type('=:=', [_,_], _) -> bool;
+bif_type('=/=', [_,_], _) -> bool;
+bif_type('not', [_], _) -> bool;
+bif_type('and', [_,_], _) -> bool;
+bif_type('or', [_,_], _) -> bool;
+bif_type('xor', [_,_], _) -> bool;
+bif_type(is_atom, [_], _) -> bool;
+bif_type(is_boolean, [_], _) -> bool;
+bif_type(is_binary, [_], _) -> bool;
+bif_type(is_float, [_], _) -> bool;
+bif_type(is_function, [_], _) -> bool;
+bif_type(is_integer, [_], _) -> bool;
+bif_type(is_list, [_], _) -> bool;
+bif_type(is_number, [_], _) -> bool;
+bif_type(is_pid, [_], _) -> bool;
+bif_type(is_port, [_], _) -> bool;
+bif_type(is_reference, [_], _) -> bool;
+bif_type(is_tuple, [_], _) -> bool;
+%% Misc.
+bif_type(node, [], _) -> {atom,[]};
+bif_type(node, [_], _) -> {atom,[]};
+bif_type(hd, [_], _) -> term;
+bif_type(tl, [_], _) -> term;
+bif_type(get, [_], _) -> term;
+bif_type(raise, [_,_], _) -> exception;
+bif_type(Bif, _, _) when is_atom(Bif) -> term.
+
+is_bif_safe('/=', 2) -> true;
+is_bif_safe('<', 2) -> true;
+is_bif_safe('=/=', 2) -> true;
+is_bif_safe('=:=', 2) -> true;
+is_bif_safe('=<', 2) -> true;
+is_bif_safe('==', 2) -> true;
+is_bif_safe('>', 2) -> true;
+is_bif_safe('>=', 2) -> true;
+is_bif_safe(is_atom, 1) -> true;
+is_bif_safe(is_boolean, 1) -> true;
+is_bif_safe(is_binary, 1) -> true;
+is_bif_safe(is_float, 1) -> true;
+is_bif_safe(is_function, 1) -> true;
+is_bif_safe(is_integer, 1) -> true;
+is_bif_safe(is_list, 1) -> true;
+is_bif_safe(is_number, 1) -> true;
+is_bif_safe(is_pid, 1) -> true;
+is_bif_safe(is_port, 1) -> true;
+is_bif_safe(is_reference, 1) -> true;
+is_bif_safe(is_tuple, 1) -> true;
+is_bif_safe(get, 1) -> true;
+is_bif_safe(self, 0) -> true;
+is_bif_safe(node, 0) -> true;
+is_bif_safe(_, _) -> false.
+
+arith_type([A,B], Vst) ->
+ case {get_term_type(A, Vst),get_term_type(B, Vst)} of
+ {{float,_},_} -> {float,[]};
+ {_,{float,_}} -> {float,[]};
+ {_,_} -> number
+ end;
+arith_type(_, _) -> number.
+
+return_type({extfunc,M,F,A}, Vst) -> return_type_1(M, F, A, Vst);
+return_type(_, _) -> term.
+
+return_type_1(erlang, setelement, 3, Vst) ->
+ Tuple = {x,1},
+ TupleType =
+ case get_term_type(Tuple, Vst) of
+ {tuple,_}=TT -> TT;
+ _ -> {tuple,[0]}
+ end,
+ case get_term_type({x,0}, Vst) of
+ {integer,[]} -> TupleType;
+ {integer,I} -> upgrade_tuple_type({tuple,[I]}, TupleType);
+ _ -> TupleType
+ end;
+return_type_1(erlang, F, A, _) ->
+ return_type_erl(F, A);
+return_type_1(math, F, A, _) ->
+ return_type_math(F, A);
+return_type_1(M, F, A, _) when is_atom(M), is_atom(F), is_integer(A), A >= 0 ->
+ term.
+
+return_type_erl(exit, 1) -> exception;
+return_type_erl(throw, 1) -> exception;
+return_type_erl(fault, 1) -> exception;
+return_type_erl(fault, 2) -> exception;
+return_type_erl(error, 1) -> exception;
+return_type_erl(error, 2) -> exception;
+return_type_erl(F, A) when is_atom(F), is_integer(A), A >= 0 -> term.
+
+return_type_math(cos, 1) -> {float,[]};
+return_type_math(cosh, 1) -> {float,[]};
+return_type_math(sin, 1) -> {float,[]};
+return_type_math(sinh, 1) -> {float,[]};
+return_type_math(tan, 1) -> {float,[]};
+return_type_math(tanh, 1) -> {float,[]};
+return_type_math(acos, 1) -> {float,[]};
+return_type_math(acosh, 1) -> {float,[]};
+return_type_math(asin, 1) -> {float,[]};
+return_type_math(asinh, 1) -> {float,[]};
+return_type_math(atan, 1) -> {float,[]};
+return_type_math(atanh, 1) -> {float,[]};
+return_type_math(erf, 1) -> {float,[]};
+return_type_math(erfc, 1) -> {float,[]};
+return_type_math(exp, 1) -> {float,[]};
+return_type_math(log, 1) -> {float,[]};
+return_type_math(log10, 1) -> {float,[]};
+return_type_math(sqrt, 1) -> {float,[]};
+return_type_math(atan2, 2) -> {float,[]};
+return_type_math(pow, 2) -> {float,[]};
+return_type_math(pi, 0) -> {float,[]};
+return_type_math(F, A) when is_atom(F), is_integer(A), A >= 0 -> term.
+
+limit_check(Num) when is_integer(Num), Num >= ?MAXREG ->
+ error(limit);
+limit_check(_) -> ok.
+
+min(A, B) when is_integer(A), is_integer(B), A < B -> A;
+min(A, B) when is_integer(A), is_integer(B) -> B.
+
+gb_trees_from_list(L) -> gb_trees:from_orddict(lists:sort(L)).
+
+-ifdef(DEBUG).
+error(Error) -> exit(Error).
+-else.
+error(Error) -> throw(Error).
+-endif.
+
+
+%%%
+%%% Rewrite disassembled code to the same format as we used internally
+%%% to not have to worry later.
+%%%
+
+normalize_disassembled_code(Fs) ->
+ Index = ndc_index(Fs, []),
+ ndc(Fs, Index, []).
+
+ndc_index([{function,Name,Arity,Entry,_Code}|Fs], Acc) ->
+ ndc_index(Fs, [{{Name,Arity},Entry}|Acc]);
+ndc_index([], Acc) ->
+ gb_trees:from_orddict(lists:sort(Acc)).
+
+ndc([{function,Name,Arity,Entry,Code0}|Fs], D, Acc) ->
+ Code = ndc_1(Code0, D, []),
+ ndc(Fs, D, [{function,Name,Arity,Entry,Code}|Acc]);
+ndc([], _, Acc) -> reverse(Acc).
+
+ndc_1([{call=Op,A,{_,F,A}}|Is], D, Acc) ->
+ ndc_1(Is, D, [{Op,A,{f,gb_trees:get({F,A}, D)}}|Acc]);
+ndc_1([{call_only=Op,A,{_,F,A}}|Is], D, Acc) ->
+ ndc_1(Is, D, [{Op,A,{f,gb_trees:get({F,A}, D)}}|Acc]);
+ndc_1([{call_last=Op,A,{_,F,A},Sz}|Is], D, Acc) ->
+ ndc_1(Is, D, [{Op,A,{f,gb_trees:get({F,A}, D)},Sz}|Acc]);
+ndc_1([{arithbif,Op,F,Src,Dst}|Is], D, Acc) ->
+ ndc_1(Is, D, [{bif,Op,F,Src,Dst}|Acc]);
+ndc_1([{arithfbif,Op,F,Src,Dst}|Is], D, Acc) ->
+ ndc_1(Is, D, [{bif,Op,F,Src,Dst}|Acc]);
+ndc_1([{test,bs_start_match2=Op,F,[A1,Live,A3,Dst]}|Is], D, Acc) ->
+ ndc_1(Is, D, [{test,Op,F,Live,[A1,A3],Dst}|Acc]);
+ndc_1([{test,bs_get_binary2=Op,F,[A1,Live,A3,A4,A5,Dst]}|Is], D, Acc) ->
+ ndc_1(Is, D, [{test,Op,F,Live,[A1,A3,A4,A5],Dst}|Acc]);
+ndc_1([{test,bs_get_float2=Op,F,[A1,Live,A3,A4,A5,Dst]}|Is], D, Acc) ->
+ ndc_1(Is, D, [{test,Op,F,Live,[A1,A3,A4,A5],Dst}|Acc]);
+ndc_1([{test,bs_get_integer2=Op,F,[A1,Live,A3,A4,A5,Dst]}|Is], D, Acc) ->
+ ndc_1(Is, D, [{test,Op,F,Live,[A1,A3,A4,A5],Dst}|Acc]);
+ndc_1([{test,bs_get_utf8=Op,F,[A1,Live,A3,Dst]}|Is], D, Acc) ->
+ ndc_1(Is, D, [{test,Op,F,Live,[A1,A3],Dst}|Acc]);
+ndc_1([{test,bs_get_utf16=Op,F,[A1,Live,A3,Dst]}|Is], D, Acc) ->
+ ndc_1(Is, D, [{test,Op,F,Live,[A1,A3],Dst}|Acc]);
+ndc_1([{test,bs_get_utf32=Op,F,[A1,Live,A3,Dst]}|Is], D, Acc) ->
+ ndc_1(Is, D, [{test,Op,F,Live,[A1,A3],Dst}|Acc]);
+ndc_1([I|Is], D, Acc) ->
+ ndc_1(Is, D, [I|Acc]);
+ndc_1([], _, Acc) ->
+ reverse(Acc).
diff --git a/lib/compiler/src/cerl.erl b/lib/compiler/src/cerl.erl
new file mode 100644
index 0000000000..74fc0878cf
--- /dev/null
+++ b/lib/compiler/src/cerl.erl
@@ -0,0 +1,4438 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2001-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+
+%% =====================================================================
+%% @doc Core Erlang abstract syntax trees.
+%%
+%% <p> This module defines an abstract data type for representing Core
+%% Erlang source code as syntax trees.</p>
+%%
+%% <p>A recommended starting point for the first-time user is the
+%% documentation of the function <a
+%% href="#type-1"><code>type/1</code></a>.</p>
+%%
+%% <h3><b>NOTES:</b></h3>
+%%
+%% <p>This module deals with the composition and decomposition of
+%% <em>syntactic</em> entities (as opposed to semantic ones); its
+%% purpose is to hide all direct references to the data structures
+%% used to represent these entities. With few exceptions, the
+%% functions in this module perform no semantic interpretation of
+%% their inputs, and in general, the user is assumed to pass
+%% type-correct arguments - if this is not done, the effects are not
+%% defined.</p>
+%%
+%% <p>Currently, the internal data structure used is the same as
+%% the record-based data structures used traditionally in the Beam
+%% compiler.</p>
+%%
+%% <p>The internal representations of abstract syntax trees are
+%% subject to change without notice, and should not be documented
+%% outside this module. Furthermore, we do not give any guarantees on
+%% how an abstract syntax tree may or may not be represented, <em>with
+%% the following exceptions</em>: no syntax tree is represented by a
+%% single atom, such as <code>none</code>, by a list constructor
+%% <code>[X | Y]</code>, or by the empty list <code>[]</code>. This
+%% can be relied on when writing functions that operate on syntax
+%% trees.</p>
+%%
+%% @type cerl(). An abstract Core Erlang syntax tree.
+%%
+%% <p>Every abstract syntax tree has a <em>type</em>, given by the
+%% function <a href="#type-1"><code>type/1</code></a>. In addition,
+%% each syntax tree has a list of <em>user annotations</em> (cf. <a
+%% href="#get_ann-1"><code>get_ann/1</code></a>), which are included
+%% in the Core Erlang syntax.</p>
+
+-module(cerl).
+
+-export([abstract/1, add_ann/2, alias_pat/1, alias_var/1,
+ ann_abstract/2, ann_c_alias/3, ann_c_apply/3, ann_c_atom/2,
+ ann_c_call/4, ann_c_case/3, ann_c_catch/2, ann_c_char/2,
+ ann_c_clause/3, ann_c_clause/4, ann_c_cons/3, ann_c_float/2,
+ ann_c_fname/3, ann_c_fun/3, ann_c_int/2, ann_c_let/4,
+ ann_c_letrec/3, ann_c_module/4, ann_c_module/5, ann_c_nil/1,
+ ann_c_cons_skel/3, ann_c_tuple_skel/2, ann_c_primop/3,
+ ann_c_receive/2, ann_c_receive/4, ann_c_seq/3, ann_c_string/2,
+ ann_c_try/6, ann_c_tuple/2, ann_c_values/2, ann_c_var/2,
+ ann_make_data/3, ann_make_list/2, ann_make_list/3,
+ ann_make_data_skel/3, ann_make_tree/3, apply_args/1,
+ apply_arity/1, apply_op/1, atom_lit/1, atom_name/1, atom_val/1,
+ c_alias/2, c_apply/2, c_atom/1, c_call/3, c_case/2, c_catch/1,
+ c_char/1, c_clause/2, c_clause/3, c_cons/2, c_float/1,
+ c_fname/2, c_fun/2, c_int/1, c_let/3, c_letrec/2, c_module/3,
+ c_module/4, c_nil/0, c_cons_skel/2, c_tuple_skel/1, c_primop/2,
+ c_receive/1, c_receive/3, c_seq/2, c_string/1, c_try/5,
+ c_tuple/1, c_values/1, c_var/1, call_args/1, call_arity/1,
+ call_module/1, call_name/1, case_arg/1, case_arity/1,
+ case_clauses/1, catch_body/1, char_lit/1, char_val/1,
+ clause_arity/1, clause_body/1, clause_guard/1, clause_pats/1,
+ clause_vars/1, concrete/1, cons_hd/1, cons_tl/1, copy_ann/2,
+ data_arity/1, data_es/1, data_type/1, float_lit/1, float_val/1,
+ fname_arity/1, fname_id/1, fold_literal/1, from_records/1,
+ fun_arity/1, fun_body/1, fun_vars/1, get_ann/1, int_lit/1,
+ int_val/1, is_c_alias/1, is_c_apply/1, is_c_atom/1,
+ is_c_call/1, is_c_case/1, is_c_catch/1, is_c_char/1,
+ is_c_clause/1, is_c_cons/1, is_c_float/1, is_c_fname/1,
+ is_c_fun/1, is_c_int/1, is_c_let/1, is_c_letrec/1, is_c_list/1,
+ is_c_module/1, is_c_nil/1, is_c_primop/1, is_c_receive/1,
+ is_c_seq/1, is_c_string/1, is_c_try/1, is_c_tuple/1,
+ is_c_values/1, is_c_var/1, is_data/1, is_leaf/1, is_literal/1,
+ is_literal_term/1, is_print_char/1, is_print_string/1,
+ let_arg/1, let_arity/1, let_body/1, let_vars/1, letrec_body/1,
+ letrec_defs/1, letrec_vars/1, list_elements/1, list_length/1,
+ make_data/2, make_list/1, make_list/2, make_data_skel/2,
+ make_tree/2, meta/1, module_attrs/1, module_defs/1,
+ module_exports/1, module_name/1, module_vars/1,
+ pat_list_vars/1, pat_vars/1, primop_args/1, primop_arity/1,
+ primop_name/1, receive_action/1, receive_clauses/1,
+ receive_timeout/1, seq_arg/1, seq_body/1, set_ann/2,
+ string_lit/1, string_val/1, subtrees/1, to_records/1,
+ try_arg/1, try_body/1, try_vars/1, try_evars/1, try_handler/1,
+ tuple_arity/1, tuple_es/1, type/1, unfold_literal/1,
+ update_c_alias/3, update_c_apply/3, update_c_call/4,
+ update_c_case/3, update_c_catch/2, update_c_clause/4,
+ update_c_cons/3, update_c_cons_skel/3, update_c_fname/2,
+ update_c_fname/3, update_c_fun/3, update_c_let/4,
+ update_c_letrec/3, update_c_module/5, update_c_primop/3,
+ update_c_receive/4, update_c_seq/3, update_c_try/6,
+ update_c_tuple/2, update_c_tuple_skel/2, update_c_values/2,
+ update_c_var/2, update_data/3, update_list/2, update_list/3,
+ update_data_skel/3, update_tree/2, update_tree/3,
+ values_arity/1, values_es/1, var_name/1, c_binary/1,
+ update_c_binary/2, ann_c_binary/2, is_c_binary/1,
+ binary_segments/1, c_bitstr/3, c_bitstr/4, c_bitstr/5,
+ update_c_bitstr/5, update_c_bitstr/6, ann_c_bitstr/5,
+ ann_c_bitstr/6, is_c_bitstr/1, bitstr_val/1, bitstr_size/1,
+ bitstr_bitsize/1, bitstr_unit/1, bitstr_type/1,
+ bitstr_flags/1]).
+
+%%
+%% needed by the include file below -- do not move
+%%
+-type var_name() :: integer() | atom() | {atom(), integer()}.
+
+-include("core_parse.hrl").
+
+-type c_alias() :: #c_alias{}.
+-type c_apply() :: #c_apply{}.
+-type c_binary() :: #c_binary{}.
+-type c_bitstr() :: #c_bitstr{}.
+-type c_call() :: #c_call{}.
+-type c_case() :: #c_case{}.
+-type c_catch() :: #c_catch{}.
+-type c_clause() :: #c_clause{}.
+-type c_cons() :: #c_cons{}.
+-type c_fun() :: #c_fun{}.
+-type c_let() :: #c_let{}.
+-type c_letrec() :: #c_letrec{}.
+-type c_literal() :: #c_literal{}.
+-type c_module() :: #c_module{}.
+-type c_primop() :: #c_primop{}.
+-type c_receive() :: #c_receive{}.
+-type c_seq() :: #c_seq{}.
+-type c_try() :: #c_try{}.
+-type c_tuple() :: #c_tuple{}.
+-type c_values() :: #c_values{}.
+-type c_var() :: #c_var{}.
+
+-type cerl() :: c_alias() | c_apply() | c_binary() | c_bitstr()
+ | c_call() | c_case() | c_catch() | c_clause() | c_cons()
+ | c_fun() | c_let() | c_letrec() | c_literal()
+ | c_module() | c_primop() | c_receive() | c_seq()
+ | c_try() | c_tuple() | c_values() | c_var().
+
+%% =====================================================================
+%% Representation (general)
+%%
+%% All nodes are represented by tuples of arity 2 or (generally)
+%% greater, whose first element is an atom which uniquely identifies the
+%% type of the node, and whose second element is a (proper) list of
+%% annotation terms associated with the node - this is by default empty.
+%%
+%% For most node constructor functions, there are analogous functions
+%% named 'ann_...', taking one extra argument 'As' (always the first
+%% argument), specifying an annotation list at node creation time.
+%% Similarly, there are also functions named 'update_...', taking one
+%% extra argument 'Old', specifying a node from which all fields not
+%% explicitly given as arguments should be copied (generally, this is
+%% the annotation field only).
+%% =====================================================================
+
+%% @spec type(Node::cerl()) -> atom()
+%%
+%% @doc Returns the type tag of <code>Node</code>. Current node types
+%% are:
+%%
+%% <p><center><table border="1">
+%% <tr>
+%% <td>alias</td>
+%% <td>apply</td>
+%% <td>binary</td>
+%% <td>bitstr</td>
+%% <td>call</td>
+%% <td>case</td>
+%% <td>catch</td>
+%% </tr><tr>
+%% <td>clause</td>
+%% <td>cons</td>
+%% <td>fun</td>
+%% <td>let</td>
+%% <td>letrec</td>
+%% <td>literal</td>
+%% <td>module</td>
+%% </tr><tr>
+%% <td>primop</td>
+%% <td>receive</td>
+%% <td>seq</td>
+%% <td>try</td>
+%% <td>tuple</td>
+%% <td>values</td>
+%% <td>var</td>
+%% </tr>
+%% </table></center></p>
+%%
+%% <p>Note: The name of the primary constructor function for a node
+%% type is always the name of the type itself, prefixed by
+%% "<code>c_</code>"; recognizer predicates are correspondingly
+%% prefixed by "<code>is_c_</code>". Furthermore, to simplify
+%% preservation of annotations (cf. <code>get_ann/1</code>), there are
+%% analogous constructor functions prefixed by "<code>ann_c_</code>"
+%% and "<code>update_c_</code>", for setting the annotation list of
+%% the new node to either a specific value or to the annotations of an
+%% existing node, respectively.</p>
+%%
+%% @see abstract/1
+%% @see c_alias/2
+%% @see c_apply/2
+%% @see c_binary/1
+%% @see c_bitstr/5
+%% @see c_call/3
+%% @see c_case/2
+%% @see c_catch/1
+%% @see c_clause/3
+%% @see c_cons/2
+%% @see c_fun/2
+%% @see c_let/3
+%% @see c_letrec/2
+%% @see c_module/3
+%% @see c_primop/2
+%% @see c_receive/1
+%% @see c_seq/2
+%% @see c_try/3
+%% @see c_tuple/1
+%% @see c_values/1
+%% @see c_var/1
+%% @see get_ann/1
+%% @see to_records/1
+%% @see from_records/1
+%% @see data_type/1
+%% @see subtrees/1
+%% @see meta/1
+
+-type ctype() :: 'alias' | 'apply' | 'binary' | 'bitrst' | 'call' | 'case'
+ | 'catch' | 'clause' | 'cons' | 'fun' | 'let' | 'letrec'
+ | 'literal' | 'module' | 'primop' | 'receive' | 'seq' | 'try'
+ | 'tuple' | 'values' | 'var'.
+
+-spec type(cerl()) -> ctype().
+
+type(#c_alias{}) -> alias;
+type(#c_apply{}) -> apply;
+type(#c_binary{}) -> binary;
+type(#c_bitstr{}) -> bitstr;
+type(#c_call{}) -> call;
+type(#c_case{}) -> 'case';
+type(#c_catch{}) -> 'catch';
+type(#c_clause{}) -> clause;
+type(#c_cons{}) -> cons;
+type(#c_fun{}) -> 'fun';
+type(#c_let{}) -> 'let';
+type(#c_letrec{}) -> letrec;
+type(#c_literal{}) -> literal;
+type(#c_module{}) -> module;
+type(#c_primop{}) -> primop;
+type(#c_receive{}) -> 'receive';
+type(#c_seq{}) -> seq;
+type(#c_try{}) -> 'try';
+type(#c_tuple{}) -> tuple;
+type(#c_values{}) -> values;
+type(#c_var{}) -> var.
+
+
+%% @spec is_leaf(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is a leaf node,
+%% otherwise <code>false</code>. The current leaf node types are
+%% <code>literal</code> and <code>var</code>.
+%%
+%% <p>Note: all literals (cf. <code>is_literal/1</code>) are leaf
+%% nodes, even if they represent structured (constant) values such as
+%% <code>{foo, [bar, baz]}</code>. Also note that variables are leaf
+%% nodes but not literals.</p>
+%%
+%% @see type/1
+%% @see is_literal/1
+
+-spec is_leaf(cerl()) -> boolean().
+
+is_leaf(Node) ->
+ case type(Node) of
+ literal -> true;
+ var -> true;
+ _ -> false
+ end.
+
+
+%% @spec get_ann(cerl()) -> [term()]
+%%
+%% @doc Returns the list of user annotations associated with a syntax
+%% tree node. For a newly created node, this is the empty list. The
+%% annotations may be any terms.
+%%
+%% @see set_ann/2
+
+-spec get_ann(cerl()) -> [term()].
+
+get_ann(Node) ->
+ element(2, Node).
+
+
+%% @spec set_ann(Node::cerl(), Annotations::[term()]) -> cerl()
+%%
+%% @doc Sets the list of user annotations of <code>Node</code> to
+%% <code>Annotations</code>.
+%%
+%% @see get_ann/1
+%% @see add_ann/2
+%% @see copy_ann/2
+
+-spec set_ann(cerl(), [term()]) -> cerl().
+
+set_ann(Node, List) ->
+ setelement(2, Node, List).
+
+
+%% @spec add_ann(Annotations::[term()], Node::cerl()) -> cerl()
+%%
+%% @doc Appends <code>Annotations</code> to the list of user
+%% annotations of <code>Node</code>.
+%%
+%% <p>Note: this is equivalent to <code>set_ann(Node, Annotations ++
+%% get_ann(Node))</code>, but potentially more efficient.</p>
+%%
+%% @see get_ann/1
+%% @see set_ann/2
+
+-spec add_ann([term()], cerl()) -> cerl().
+
+add_ann(Terms, Node) ->
+ set_ann(Node, Terms ++ get_ann(Node)).
+
+
+%% @spec copy_ann(Source::cerl(), Target::cerl()) -> cerl()
+%%
+%% @doc Copies the list of user annotations from <code>Source</code>
+%% to <code>Target</code>.
+%%
+%% <p>Note: this is equivalent to <code>set_ann(Target,
+%% get_ann(Source))</code>, but potentially more efficient.</p>
+%%
+%% @see get_ann/1
+%% @see set_ann/2
+
+-spec copy_ann(cerl(), cerl()) -> cerl().
+
+copy_ann(Source, Target) ->
+ set_ann(Target, get_ann(Source)).
+
+
+%% @spec abstract(Term::term()) -> cerl()
+%%
+%% @doc Creates a syntax tree corresponding to an Erlang term.
+%% <code>Term</code> must be a literal term, i.e., one that can be
+%% represented as a source code literal. Thus, it may not contain a
+%% process identifier, port, reference, binary or function value as a
+%% subterm.
+%%
+%% <p>Note: This is a constant time operation.</p>
+%%
+%% @see ann_abstract/2
+%% @see concrete/1
+%% @see is_literal/1
+%% @see is_literal_term/1
+
+-spec abstract(term()) -> c_literal().
+
+abstract(T) ->
+ #c_literal{val = T}.
+
+
+%% @spec ann_abstract(Annotations::[term()], Term::term()) -> cerl()
+%% @see abstract/1
+
+-spec ann_abstract([term()], term()) -> c_literal().
+
+ann_abstract(As, T) ->
+ #c_literal{val = T, anno = As}.
+
+
+%% @spec is_literal_term(Term::term()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Term</code> can be
+%% represented as a literal, otherwise <code>false</code>. This
+%% function takes time proportional to the size of <code>Term</code>.
+%%
+%% @see abstract/1
+
+-spec is_literal_term(term()) -> boolean().
+
+is_literal_term(T) when is_integer(T) -> true;
+is_literal_term(T) when is_float(T) -> true;
+is_literal_term(T) when is_atom(T) -> true;
+is_literal_term([]) -> true;
+is_literal_term([H | T]) ->
+ is_literal_term(H) andalso is_literal_term(T);
+is_literal_term(T) when is_tuple(T) ->
+ is_literal_term_list(tuple_to_list(T));
+is_literal_term(B) when is_bitstring(B) -> true;
+is_literal_term(_) ->
+ false.
+
+-spec is_literal_term_list([term()]) -> boolean().
+
+is_literal_term_list([T | Ts]) ->
+ case is_literal_term(T) of
+ true ->
+ is_literal_term_list(Ts);
+ false ->
+ false
+ end;
+is_literal_term_list([]) ->
+ true.
+
+
+%% @spec concrete(Node::cerl()) -> term()
+%%
+%% @doc Returns the Erlang term represented by a syntax tree. An
+%% exception is thrown if <code>Node</code> does not represent a
+%% literal term.
+%%
+%% <p>Note: This is a constant time operation.</p>
+%%
+%% @see abstract/1
+%% @see is_literal/1
+
+%% Because the normal tuple and list constructor operations always
+%% return a literal if the arguments are literals, 'concrete' and
+%% 'is_literal' never need to traverse the structure.
+
+-spec concrete(c_literal()) -> term().
+
+concrete(#c_literal{val = V}) ->
+ V.
+
+
+%% @spec is_literal(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> represents a
+%% literal term, otherwise <code>false</code>. This function returns
+%% <code>true</code> if and only if the value of
+%% <code>concrete(Node)</code> is defined.
+%%
+%% <p>Note: This is a constant time operation.</p>
+%%
+%% @see abstract/1
+%% @see concrete/1
+%% @see fold_literal/1
+
+-spec is_literal(cerl()) -> boolean().
+
+is_literal(#c_literal{}) ->
+ true;
+is_literal(_) ->
+ false.
+
+
+%% @spec fold_literal(Node::cerl()) -> cerl()
+%%
+%% @doc Assures that literals have a compact representation. This is
+%% occasionally useful if <code>c_cons_skel/2</code>,
+%% <code>c_tuple_skel/1</code> or <code>unfold_literal/1</code> were
+%% used in the construction of <code>Node</code>, and you want to revert
+%% to the normal "folded" representation of literals. If
+%% <code>Node</code> represents a tuple or list constructor, its
+%% elements are rewritten recursively, and the node is reconstructed
+%% using <code>c_cons/2</code> or <code>c_tuple/1</code>, respectively;
+%% otherwise, <code>Node</code> is not changed.
+%%
+%% @see is_literal/1
+%% @see c_cons_skel/2
+%% @see c_tuple_skel/1
+%% @see c_cons/2
+%% @see c_tuple/1
+%% @see unfold_literal/1
+
+-spec fold_literal(cerl()) -> cerl().
+
+fold_literal(Node) ->
+ case type(Node) of
+ tuple ->
+ update_c_tuple(Node, fold_literal_list(tuple_es(Node)));
+ cons ->
+ update_c_cons(Node, fold_literal(cons_hd(Node)),
+ fold_literal(cons_tl(Node)));
+ _ ->
+ Node
+ end.
+
+fold_literal_list([E | Es]) ->
+ [fold_literal(E) | fold_literal_list(Es)];
+fold_literal_list([]) ->
+ [].
+
+
+%% @spec unfold_literal(Node::cerl()) -> cerl()
+%%
+%% @doc Assures that literals have a fully expanded representation. If
+%% <code>Node</code> represents a literal tuple or list constructor, its
+%% elements are rewritten recursively, and the node is reconstructed
+%% using <code>c_cons_skel/2</code> or <code>c_tuple_skel/1</code>,
+%% respectively; otherwise, <code>Node</code> is not changed. The {@link
+%% fold_literal/1} can be used to revert to the normal compact
+%% representation.
+%%
+%% @see is_literal/1
+%% @see c_cons_skel/2
+%% @see c_tuple_skel/1
+%% @see c_cons/2
+%% @see c_tuple/1
+%% @see fold_literal/1
+
+-spec unfold_literal(cerl()) -> cerl().
+
+unfold_literal(Node) ->
+ case type(Node) of
+ literal ->
+ copy_ann(Node, unfold_concrete(concrete(Node)));
+ _ ->
+ Node
+ end.
+
+unfold_concrete(Val) ->
+ case Val of
+ _ when is_tuple(Val) ->
+ c_tuple_skel(unfold_concrete_list(tuple_to_list(Val)));
+ [H|T] ->
+ c_cons_skel(unfold_concrete(H), unfold_concrete(T));
+ _ ->
+ abstract(Val)
+ end.
+
+unfold_concrete_list([E | Es]) ->
+ [unfold_concrete(E) | unfold_concrete_list(Es)];
+unfold_concrete_list([]) ->
+ [].
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_module(Name::cerl(), Exports, Definitions) -> cerl()
+%%
+%% Exports = [cerl()]
+%% Definitions = [{cerl(), cerl()}]
+%%
+%% @equiv c_module(Name, Exports, [], Definitions)
+
+-spec c_module(cerl(), [cerl()], [{cerl(), cerl()}]) -> c_module().
+
+c_module(Name, Exports, Es) ->
+ #c_module{name = Name, exports = Exports, attrs = [], defs = Es}.
+
+
+%% @spec c_module(Name::cerl(), Exports, Attributes, Definitions) ->
+%% cerl()
+%%
+%% Exports = [cerl()]
+%% Attributes = [{cerl(), cerl()}]
+%% Definitions = [{cerl(), cerl()}]
+%%
+%% @doc Creates an abstract module definition. The result represents
+%% <pre>
+%% module <em>Name</em> [<em>E1</em>, ..., <em>Ek</em>]
+%% attributes [<em>K1</em> = <em>T1</em>, ...,
+%% <em>Km</em> = <em>Tm</em>]
+%% <em>V1</em> = <em>F1</em>
+%% ...
+%% <em>Vn</em> = <em>Fn</em>
+%% end</pre>
+%%
+%% if <code>Exports</code> = <code>[E1, ..., Ek]</code>,
+%% <code>Attributes</code> = <code>[{K1, T1}, ..., {Km, Tm}]</code>,
+%% and <code>Definitions</code> = <code>[{V1, F1}, ..., {Vn,
+%% Fn}]</code>.
+%%
+%% <p><code>Name</code> and all the <code>Ki</code> must be atom
+%% literals, and all the <code>Ti</code> must be constant literals. All
+%% the <code>Vi</code> and <code>Ei</code> must have type
+%% <code>var</code> and represent function names. All the
+%% <code>Fi</code> must have type <code>'fun'</code>.</p>
+%%
+%% @see c_module/3
+%% @see module_name/1
+%% @see module_exports/1
+%% @see module_attrs/1
+%% @see module_defs/1
+%% @see module_vars/1
+%% @see ann_c_module/4
+%% @see ann_c_module/5
+%% @see update_c_module/5
+%% @see c_atom/1
+%% @see c_var/1
+%% @see c_fun/2
+%% @see is_literal/1
+
+-spec c_module(cerl(), [cerl()], [{cerl(), cerl()}], [{cerl(), cerl()}]) ->
+ c_module().
+
+c_module(Name, Exports, Attrs, Es) ->
+ #c_module{name = Name, exports = Exports, attrs = Attrs, defs = Es}.
+
+
+%% @spec ann_c_module(As::[term()], Name::cerl(), Exports,
+%% Definitions) -> cerl()
+%%
+%% Exports = [cerl()]
+%% Definitions = [{cerl(), cerl()}]
+%%
+%% @see c_module/3
+%% @see ann_c_module/5
+
+-spec ann_c_module([term()], cerl(), [cerl()], [{cerl(), cerl()}]) ->
+ c_module().
+
+ann_c_module(As, Name, Exports, Es) ->
+ #c_module{name = Name, exports = Exports, attrs = [], defs = Es,
+ anno = As}.
+
+
+%% @spec ann_c_module(As::[term()], Name::cerl(), Exports,
+%% Attributes, Definitions) -> cerl()
+%%
+%% Exports = [cerl()]
+%% Attributes = [{cerl(), cerl()}]
+%% Definitions = [{cerl(), cerl()}]
+%%
+%% @see c_module/4
+%% @see ann_c_module/4
+
+-spec ann_c_module([term()], cerl(), [cerl()],
+ [{cerl(), cerl()}], [{cerl(), cerl()}]) -> c_module().
+
+ann_c_module(As, Name, Exports, Attrs, Es) ->
+ #c_module{name = Name, exports = Exports, attrs = Attrs, defs = Es,
+ anno = As}.
+
+
+%% @spec update_c_module(Old::cerl(), Name::cerl(), Exports,
+%% Attributes, Definitions) -> cerl()
+%%
+%% Exports = [cerl()]
+%% Attributes = [{cerl(), cerl()}]
+%% Definitions = [{cerl(), cerl()}]
+%%
+%% @see c_module/4
+
+-spec update_c_module(c_module(), cerl(), [cerl()],
+ [{cerl(), cerl()}], [{cerl(), cerl()}]) -> c_module().
+
+update_c_module(Node, Name, Exports, Attrs, Es) ->
+ #c_module{name = Name, exports = Exports, attrs = Attrs, defs = Es,
+ anno = get_ann(Node)}.
+
+
+%% @spec is_c_module(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% module definition, otherwise <code>false</code>.
+%%
+%% @see type/1
+
+-spec is_c_module(cerl()) -> boolean().
+
+is_c_module(#c_module{}) ->
+ true;
+is_c_module(_) ->
+ false.
+
+
+%% @spec module_name(Node::cerl()) -> cerl()
+%%
+%% @doc Returns the name subtree of an abstract module definition.
+%%
+%% @see c_module/4
+
+-spec module_name(c_module()) -> cerl().
+
+module_name(Node) ->
+ Node#c_module.name.
+
+
+%% @spec module_exports(Node::cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of exports subtrees of an abstract module
+%% definition.
+%%
+%% @see c_module/4
+
+-spec module_exports(c_module()) -> [cerl()].
+
+module_exports(Node) ->
+ Node#c_module.exports.
+
+
+%% @spec module_attrs(Node::cerl()) -> [{cerl(), cerl()}]
+%%
+%% @doc Returns the list of pairs of attribute key/value subtrees of
+%% an abstract module definition.
+%%
+%% @see c_module/4
+
+-spec module_attrs(c_module()) -> [{cerl(), cerl()}].
+
+module_attrs(Node) ->
+ Node#c_module.attrs.
+
+
+%% @spec module_defs(Node::cerl()) -> [{cerl(), cerl()}]
+%%
+%% @doc Returns the list of function definitions of an abstract module
+%% definition.
+%%
+%% @see c_module/4
+
+-spec module_defs(c_module()) -> [{cerl(), cerl()}].
+
+module_defs(Node) ->
+ Node#c_module.defs.
+
+
+%% @spec module_vars(Node::cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of left-hand side function variable subtrees
+%% of an abstract module definition.
+%%
+%% @see c_module/4
+
+-spec module_vars(c_module()) -> [cerl()].
+
+module_vars(Node) ->
+ [F || {F, _} <- module_defs(Node)].
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_int(Value::integer()) -> cerl()
+%%
+%% @doc Creates an abstract integer literal. The lexical
+%% representation is the canonical decimal numeral of
+%% <code>Value</code>.
+%%
+%% @see ann_c_int/2
+%% @see is_c_int/1
+%% @see int_val/1
+%% @see int_lit/1
+%% @see c_char/1
+
+-spec c_int(integer()) -> c_literal().
+
+c_int(Value) ->
+ #c_literal{val = Value}.
+
+
+%% @spec ann_c_int(As::[term()], Value::integer()) -> cerl()
+%% @see c_int/1
+
+-spec ann_c_int([term()], integer()) -> c_literal().
+
+ann_c_int(As, Value) ->
+ #c_literal{val = Value, anno = As}.
+
+
+%% @spec is_c_int(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> represents an
+%% integer literal, otherwise <code>false</code>.
+%% @see c_int/1
+
+-spec is_c_int(cerl()) -> boolean().
+
+is_c_int(#c_literal{val = V}) when is_integer(V) ->
+ true;
+is_c_int(_) ->
+ false.
+
+
+%% @spec int_val(cerl()) -> integer()
+%%
+%% @doc Returns the value represented by an integer literal node.
+%% @see c_int/1
+
+-spec int_val(c_literal()) -> integer().
+
+int_val(Node) ->
+ Node#c_literal.val.
+
+
+%% @spec int_lit(cerl()) -> string()
+%%
+%% @doc Returns the numeral string represented by an integer literal
+%% node.
+%% @see c_int/1
+
+-spec int_lit(c_literal()) -> string().
+
+int_lit(Node) ->
+ integer_to_list(int_val(Node)).
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_float(Value::float()) -> cerl()
+%%
+%% @doc Creates an abstract floating-point literal. The lexical
+%% representation is the decimal floating-point numeral of
+%% <code>Value</code>.
+%%
+%% @see ann_c_float/2
+%% @see is_c_float/1
+%% @see float_val/1
+%% @see float_lit/1
+
+%% Note that not all floating-point numerals can be represented with
+%% full precision.
+
+-spec c_float(float()) -> c_literal().
+
+c_float(Value) ->
+ #c_literal{val = Value}.
+
+
+%% @spec ann_c_float(As::[term()], Value::float()) -> cerl()
+%% @see c_float/1
+
+-spec ann_c_float([term()], float()) -> c_literal().
+
+ann_c_float(As, Value) ->
+ #c_literal{val = Value, anno = As}.
+
+
+%% @spec is_c_float(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> represents a
+%% floating-point literal, otherwise <code>false</code>.
+%% @see c_float/1
+
+-spec is_c_float(cerl()) -> boolean().
+
+is_c_float(#c_literal{val = V}) when is_float(V) ->
+ true;
+is_c_float(_) ->
+ false.
+
+
+%% @spec float_val(cerl()) -> float()
+%%
+%% @doc Returns the value represented by a floating-point literal
+%% node.
+%% @see c_float/1
+
+-spec float_val(c_literal()) -> float().
+
+float_val(Node) ->
+ Node#c_literal.val.
+
+
+%% @spec float_lit(cerl()) -> string()
+%%
+%% @doc Returns the numeral string represented by a floating-point
+%% literal node.
+%% @see c_float/1
+
+-spec float_lit(c_literal()) -> string().
+
+float_lit(Node) ->
+ float_to_list(float_val(Node)).
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_atom(Name) -> cerl()
+%% Name = atom() | string()
+%%
+%% @doc Creates an abstract atom literal. The print name of the atom
+%% is the character sequence represented by <code>Name</code>.
+%%
+%% <p>Note: passing a string as argument to this function causes a
+%% corresponding atom to be created for the internal representation.</p>
+%%
+%% @see ann_c_atom/2
+%% @see is_c_atom/1
+%% @see atom_val/1
+%% @see atom_name/1
+%% @see atom_lit/1
+
+-spec c_atom(atom() | string()) -> c_literal().
+
+c_atom(Name) when is_atom(Name) ->
+ #c_literal{val = Name};
+c_atom(Name) ->
+ #c_literal{val = list_to_atom(Name)}.
+
+
+%% @spec ann_c_atom(As::[term()], Name) -> cerl()
+%% Name = atom() | string()
+%% @see c_atom/1
+
+-spec ann_c_atom([term()], atom() | string()) -> c_literal().
+
+ann_c_atom(As, Name) when is_atom(Name) ->
+ #c_literal{val = Name, anno = As};
+ann_c_atom(As, Name) ->
+ #c_literal{val = list_to_atom(Name), anno = As}.
+
+
+%% @spec is_c_atom(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> represents an
+%% atom literal, otherwise <code>false</code>.
+%%
+%% @see c_atom/1
+
+-spec is_c_atom(cerl()) -> boolean().
+
+is_c_atom(#c_literal{val = V}) when is_atom(V) ->
+ true;
+is_c_atom(_) ->
+ false.
+
+%% @spec atom_val(cerl()) -> atom()
+%%
+%% @doc Returns the value represented by an abstract atom.
+%%
+%% @see c_atom/1
+
+-spec atom_val(c_literal()) -> atom().
+
+atom_val(Node) ->
+ Node#c_literal.val.
+
+
+%% @spec atom_name(cerl()) -> string()
+%%
+%% @doc Returns the printname of an abstract atom.
+%%
+%% @see c_atom/1
+
+-spec atom_name(c_literal()) -> string().
+
+atom_name(Node) ->
+ atom_to_list(atom_val(Node)).
+
+
+%% @spec atom_lit(cerl()) -> string()
+%%
+%% @doc Returns the literal string represented by an abstract
+%% atom. This always includes surrounding single-quote characters.
+%%
+%% <p>Note that an abstract atom may have several literal
+%% representations, and that the representation yielded by this
+%% function is not fixed; e.g.,
+%% <code>atom_lit(c_atom("a\012b"))</code> could yield the string
+%% <code>"\'a\\nb\'"</code>.</p>
+%%
+%% @see c_atom/1
+
+%% TODO: replace the use of the unofficial 'write_string/2'.
+
+-spec atom_lit(cerl()) -> string().
+
+atom_lit(Node) ->
+ io_lib:write_string(atom_name(Node), $'). %' stupid Emacs.
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_char(Value) -> cerl()
+%%
+%% Value = char() | integer()
+%%
+%% @doc Creates an abstract character literal. If the local
+%% implementation of Erlang defines <code>char()</code> as a subset of
+%% <code>integer()</code>, this function is equivalent to
+%% <code>c_int/1</code>. Otherwise, if the given value is an integer,
+%% it will be converted to the character with the corresponding
+%% code. The lexical representation of a character is
+%% "<code>$<em>Char</em></code>", where <code>Char</code> is a single
+%% printing character or an escape sequence.
+%%
+%% @see c_int/1
+%% @see c_string/1
+%% @see ann_c_char/2
+%% @see is_c_char/1
+%% @see char_val/1
+%% @see char_lit/1
+%% @see is_print_char/1
+
+-spec c_char(non_neg_integer()) -> c_literal().
+
+c_char(Value) when is_integer(Value), Value >= 0 ->
+ #c_literal{val = Value}.
+
+
+%% @spec ann_c_char(As::[term()], Value::char()) -> cerl()
+%% @see c_char/1
+
+-spec ann_c_char([term()], char()) -> c_literal().
+
+ann_c_char(As, Value) ->
+ #c_literal{val = Value, anno = As}.
+
+
+%% @spec is_c_char(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> may represent a
+%% character literal, otherwise <code>false</code>.
+%%
+%% <p>If the local implementation of Erlang defines
+%% <code>char()</code> as a subset of <code>integer()</code>, then
+%% <code>is_c_int(<em>Node</em>)</code> will also yield
+%% <code>true</code>.</p>
+%%
+%% @see c_char/1
+%% @see is_print_char/1
+
+-spec is_c_char(c_literal()) -> boolean().
+
+is_c_char(#c_literal{val = V}) when is_integer(V), V >= 0 ->
+ is_char_value(V);
+is_c_char(_) ->
+ false.
+
+
+%% @spec is_print_char(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> may represent a
+%% "printing" character, otherwise <code>false</code>. (Cf.
+%% <code>is_c_char/1</code>.) A "printing" character has either a
+%% given graphical representation, or a "named" escape sequence such
+%% as "<code>\n</code>". Currently, only ISO 8859-1 (Latin-1)
+%% character values are recognized.
+%%
+%% @see c_char/1
+%% @see is_c_char/1
+
+-spec is_print_char(cerl()) -> boolean().
+
+is_print_char(#c_literal{val = V}) when is_integer(V), V >= 0 ->
+ is_print_char_value(V);
+is_print_char(_) ->
+ false.
+
+
+%% @spec char_val(cerl()) -> char()
+%%
+%% @doc Returns the value represented by an abstract character literal.
+%%
+%% @see c_char/1
+
+-spec char_val(c_literal()) -> char().
+
+char_val(Node) ->
+ Node#c_literal.val.
+
+
+%% @spec char_lit(cerl()) -> string()
+%%
+%% @doc Returns the literal string represented by an abstract
+%% character. This includes a leading <code>$</code>
+%% character. Currently, all characters that are not in the set of ISO
+%% 8859-1 (Latin-1) "printing" characters will be escaped.
+%%
+%% @see c_char/1
+
+-spec char_lit(c_literal()) -> string().
+
+char_lit(Node) ->
+ io_lib:write_char(char_val(Node)).
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_string(Value::string()) -> cerl()
+%%
+%% @doc Creates an abstract string literal. Equivalent to creating an
+%% abstract list of the corresponding character literals
+%% (cf. <code>is_c_string/1</code>), but is typically more
+%% efficient. The lexical representation of a string is
+%% "<code>"<em>Chars</em>"</code>", where <code>Chars</code> is a
+%% sequence of printing characters or spaces.
+%%
+%% @see c_char/1
+%% @see ann_c_string/2
+%% @see is_c_string/1
+%% @see string_val/1
+%% @see string_lit/1
+%% @see is_print_string/1
+
+-spec c_string(string()) -> c_literal().
+
+c_string(Value) ->
+ #c_literal{val = Value}.
+
+
+%% @spec ann_c_string(As::[term()], Value::string()) -> cerl()
+%% @see c_string/1
+
+-spec ann_c_string([term()], string()) -> c_literal().
+
+ann_c_string(As, Value) ->
+ #c_literal{val = Value, anno = As}.
+
+
+%% @spec is_c_string(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> may represent a
+%% string literal, otherwise <code>false</code>. Strings are defined
+%% as lists of characters; see <code>is_c_char/1</code> for details.
+%%
+%% @see c_string/1
+%% @see is_c_char/1
+%% @see is_print_string/1
+
+-spec is_c_string(cerl()) -> boolean().
+
+is_c_string(#c_literal{val = V}) ->
+ is_char_list(V);
+is_c_string(_) ->
+ false.
+
+
+%% @spec is_print_string(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> may represent a
+%% string literal containing only "printing" characters, otherwise
+%% <code>false</code>. See <code>is_c_string/1</code> and
+%% <code>is_print_char/1</code> for details. Currently, only ISO
+%% 8859-1 (Latin-1) character values are recognized.
+%%
+%% @see c_string/1
+%% @see is_c_string/1
+%% @see is_print_char/1
+
+-spec is_print_string(cerl()) -> boolean().
+
+is_print_string(#c_literal{val = V}) ->
+ is_print_char_list(V);
+is_print_string(_) ->
+ false.
+
+
+%% @spec string_val(cerl()) -> string()
+%%
+%% @doc Returns the value represented by an abstract string literal.
+%%
+%% @see c_string/1
+
+-spec string_val(c_literal()) -> string().
+
+string_val(Node) ->
+ Node#c_literal.val.
+
+
+%% @spec string_lit(cerl()) -> string()
+%%
+%% @doc Returns the literal string represented by an abstract string.
+%% This includes surrounding double-quote characters
+%% <code>"..."</code>. Currently, characters that are not in the set
+%% of ISO 8859-1 (Latin-1) "printing" characters will be escaped,
+%% except for spaces.
+%%
+%% @see c_string/1
+
+-spec string_lit(c_literal()) -> string().
+
+string_lit(Node) ->
+ io_lib:write_string(string_val(Node)).
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_nil() -> cerl()
+%%
+%% @doc Creates an abstract empty list. The result represents
+%% "<code>[]</code>". The empty list is traditionally called "nil".
+%%
+%% @see ann_c_nil/1
+%% @see is_c_list/1
+%% @see c_cons/2
+
+-spec c_nil() -> c_literal().
+
+c_nil() ->
+ #c_literal{val = []}.
+
+
+%% @spec ann_c_nil(As::[term()]) -> cerl()
+%% @see c_nil/0
+
+-spec ann_c_nil([term()]) -> c_literal().
+
+ann_c_nil(As) ->
+ #c_literal{val = [], anno = As}.
+
+
+%% @spec is_c_nil(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% empty list, otherwise <code>false</code>.
+
+-spec is_c_nil(cerl()) -> boolean().
+
+is_c_nil(#c_literal{val = []}) ->
+ true;
+is_c_nil(_) ->
+ false.
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_cons(Head::cerl(), Tail::cerl()) -> cerl()
+%%
+%% @doc Creates an abstract list constructor. The result represents
+%% "<code>[<em>Head</em> | <em>Tail</em>]</code>". Note that if both
+%% <code>Head</code> and <code>Tail</code> have type
+%% <code>literal</code>, then the result will also have type
+%% <code>literal</code>, and annotations on <code>Head</code> and
+%% <code>Tail</code> are lost.
+%%
+%% <p>Recall that in Erlang, the tail element of a list constructor is
+%% not necessarily a list.</p>
+%%
+%% @see ann_c_cons/3
+%% @see update_c_cons/3
+%% @see c_cons_skel/2
+%% @see is_c_cons/1
+%% @see cons_hd/1
+%% @see cons_tl/1
+%% @see is_c_list/1
+%% @see c_nil/0
+%% @see list_elements/1
+%% @see list_length/1
+%% @see make_list/2
+
+%% *Always* collapse literals.
+
+-spec c_cons(cerl(), cerl()) -> c_literal() | c_cons().
+
+c_cons(#c_literal{val = Head}, #c_literal{val = Tail}) ->
+ #c_literal{val = [Head | Tail]};
+c_cons(Head, Tail) ->
+ #c_cons{hd = Head, tl = Tail}.
+
+
+%% @spec ann_c_cons(As::[term()], Head::cerl(), Tail::cerl()) -> cerl()
+%% @see c_cons/2
+
+-spec ann_c_cons([term()], cerl(), cerl()) -> c_literal() | c_cons().
+
+ann_c_cons(As, #c_literal{val = Head}, #c_literal{val = Tail}) ->
+ #c_literal{val = [Head | Tail], anno = As};
+ann_c_cons(As, Head, Tail) ->
+ #c_cons{hd = Head, tl = Tail, anno = As}.
+
+
+%% @spec update_c_cons(Old::cerl(), Head::cerl(), Tail::cerl()) ->
+%% cerl()
+%% @see c_cons/2
+
+-spec update_c_cons(c_literal() | c_cons(), cerl(), cerl()) ->
+ c_literal() | c_cons().
+
+update_c_cons(Node, #c_literal{val = Head}, #c_literal{val = Tail}) ->
+ #c_literal{val = [Head | Tail], anno = get_ann(Node)};
+update_c_cons(Node, Head, Tail) ->
+ #c_cons{hd = Head, tl = Tail, anno = get_ann(Node)}.
+
+
+%% @spec c_cons_skel(Head::cerl(), Tail::cerl()) -> cerl()
+%%
+%% @doc Creates an abstract list constructor skeleton. Does not fold
+%% constant literals, i.e., the result always has type
+%% <code>cons</code>, representing "<code>[<em>Head</em> |
+%% <em>Tail</em>]</code>".
+%%
+%% <p>This function is occasionally useful when it is necessary to have
+%% annotations on the subnodes of a list constructor node, even when the
+%% subnodes are constant literals. Note however that
+%% <code>is_literal/1</code> will yield <code>false</code> and
+%% <code>concrete/1</code> will fail if passed the result from this
+%% function.</p>
+%%
+%% <p><code>fold_literal/1</code> can be used to revert a node to the
+%% normal-form representation.</p>
+%%
+%% @see ann_c_cons_skel/3
+%% @see update_c_cons_skel/3
+%% @see c_cons/2
+%% @see is_c_cons/1
+%% @see is_c_list/1
+%% @see c_nil/0
+%% @see is_literal/1
+%% @see fold_literal/1
+%% @see concrete/1
+
+%% *Never* collapse literals.
+
+-spec c_cons_skel(cerl(), cerl()) -> c_cons().
+
+c_cons_skel(Head, Tail) ->
+ #c_cons{hd = Head, tl = Tail}.
+
+
+%% @spec ann_c_cons_skel(As::[term()], Head::cerl(), Tail::cerl()) ->
+%% cerl()
+%% @see c_cons_skel/2
+
+-spec ann_c_cons_skel([term()], cerl(), cerl()) -> c_cons().
+
+ann_c_cons_skel(As, Head, Tail) ->
+ #c_cons{hd = Head, tl = Tail, anno = As}.
+
+
+%% @spec update_c_cons_skel(Old::cerl(), Head::cerl(), Tail::cerl()) ->
+%% cerl()
+%% @see c_cons_skel/2
+
+-spec update_c_cons_skel(c_cons() | c_literal(), cerl(), cerl()) -> c_cons().
+
+update_c_cons_skel(Node, Head, Tail) ->
+ #c_cons{hd = Head, tl = Tail, anno = get_ann(Node)}.
+
+
+%% @spec is_c_cons(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% list constructor, otherwise <code>false</code>.
+
+-spec is_c_cons(cerl()) -> boolean().
+
+is_c_cons(#c_cons{}) ->
+ true;
+is_c_cons(#c_literal{val = [_ | _]}) ->
+ true;
+is_c_cons(_) ->
+ false.
+
+
+%% @spec cons_hd(cerl()) -> cerl()
+%%
+%% @doc Returns the head subtree of an abstract list constructor.
+%%
+%% @see c_cons/2
+
+-spec cons_hd(c_cons() | c_literal()) -> cerl().
+
+cons_hd(#c_cons{hd = Head}) ->
+ Head;
+cons_hd(#c_literal{val = [Head | _]}) ->
+ #c_literal{val = Head}.
+
+
+%% @spec cons_tl(cerl()) -> cerl()
+%%
+%% @doc Returns the tail subtree of an abstract list constructor.
+%%
+%% <p>Recall that the tail does not necessarily represent a proper
+%% list.</p>
+%%
+%% @see c_cons/2
+
+-spec cons_tl(c_cons() | c_literal()) -> cerl().
+
+cons_tl(#c_cons{tl = Tail}) ->
+ Tail;
+cons_tl(#c_literal{val = [_ | Tail]}) ->
+ #c_literal{val = Tail}.
+
+
+%% @spec is_c_list(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> represents a
+%% proper list, otherwise <code>false</code>. A proper list is either
+%% the empty list <code>[]</code>, or a cons cell <code>[<em>Head</em> |
+%% <em>Tail</em>]</code>, where recursively <code>Tail</code> is a
+%% proper list.
+%%
+%% <p>Note: Because <code>Node</code> is a syntax tree, the actual
+%% run-time values corresponding to its subtrees may often be partially
+%% or completely unknown. Thus, if <code>Node</code> represents e.g.
+%% "<code>[... | Ns]</code>" (where <code>Ns</code> is a variable), then
+%% the function will return <code>false</code>, because it is not known
+%% whether <code>Ns</code> will be bound to a list at run-time. If
+%% <code>Node</code> instead represents e.g. "<code>[1, 2, 3]</code>" or
+%% "<code>[A | []]</code>", then the function will return
+%% <code>true</code>.</p>
+%%
+%% @see c_cons/2
+%% @see c_nil/0
+%% @see list_elements/1
+%% @see list_length/1
+
+-spec is_c_list(cerl()) -> boolean().
+
+is_c_list(#c_cons{tl = Tail}) ->
+ is_c_list(Tail);
+is_c_list(#c_literal{val = V}) ->
+ is_proper_list(V);
+is_c_list(_) ->
+ false.
+
+is_proper_list([_ | Tail]) ->
+ is_proper_list(Tail);
+is_proper_list([]) ->
+ true;
+is_proper_list(_) ->
+ false.
+
+%% @spec list_elements(cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of element subtrees of an abstract list.
+%% <code>Node</code> must represent a proper list. E.g., if
+%% <code>Node</code> represents "<code>[<em>X1</em>, <em>X2</em> |
+%% [<em>X3</em>, <em>X4</em> | []]</code>", then
+%% <code>list_elements(Node)</code> yields the list <code>[X1, X2, X3,
+%% X4]</code>.
+%%
+%% @see c_cons/2
+%% @see c_nil/1
+%% @see is_c_list/1
+%% @see list_length/1
+%% @see make_list/2
+
+-spec list_elements(c_cons() | c_literal()) -> [cerl()].
+
+list_elements(#c_cons{hd = Head, tl = Tail}) ->
+ [Head | list_elements(Tail)];
+list_elements(#c_literal{val = V}) ->
+ abstract_list(V).
+
+abstract_list([X | Xs]) ->
+ [abstract(X) | abstract_list(Xs)];
+abstract_list([]) ->
+ [].
+
+
+%% @spec list_length(Node::cerl()) -> integer()
+%%
+%% @doc Returns the number of element subtrees of an abstract list.
+%% <code>Node</code> must represent a proper list. E.g., if
+%% <code>Node</code> represents "<code>[X1 | [X2, X3 | [X4, X5,
+%% X6]]]</code>", then <code>list_length(Node)</code> returns the
+%% integer 6.
+%%
+%% <p>Note: this is equivalent to
+%% <code>length(list_elements(Node))</code>, but potentially more
+%% efficient.</p>
+%%
+%% @see c_cons/2
+%% @see c_nil/1
+%% @see is_c_list/1
+%% @see list_elements/1
+
+-spec list_length(c_cons() | c_literal()) -> non_neg_integer().
+
+list_length(L) ->
+ list_length(L, 0).
+
+list_length(#c_cons{tl = Tail}, A) ->
+ list_length(Tail, A + 1);
+list_length(#c_literal{val = V}, A) ->
+ A + length(V).
+
+
+%% @spec make_list(List) -> Node
+%% @equiv make_list(List, none)
+
+-spec make_list([cerl()]) -> cerl().
+
+make_list(List) ->
+ ann_make_list([], List).
+
+
+%% @spec make_list(List::[cerl()], Tail) -> cerl()
+%%
+%% Tail = cerl() | none
+%%
+%% @doc Creates an abstract list from the elements in <code>List</code>
+%% and the optional <code>Tail</code>. If <code>Tail</code> is
+%% <code>none</code>, the result will represent a nil-terminated list,
+%% otherwise it represents "<code>[... | <em>Tail</em>]</code>".
+%%
+%% @see c_cons/2
+%% @see c_nil/0
+%% @see ann_make_list/3
+%% @see update_list/3
+%% @see list_elements/1
+
+-spec make_list([cerl()], cerl() | 'none') -> cerl().
+
+make_list(List, Tail) ->
+ ann_make_list([], List, Tail).
+
+
+%% @spec update_list(Old::cerl(), List::[cerl()]) -> cerl()
+%% @equiv update_list(Old, List, none)
+
+-spec update_list(cerl(), [cerl()]) -> cerl().
+
+update_list(Node, List) ->
+ ann_make_list(get_ann(Node), List).
+
+
+%% @spec update_list(Old::cerl(), List::[cerl()], Tail) -> cerl()
+%%
+%% Tail = cerl() | none
+%%
+%% @see make_list/2
+%% @see update_list/2
+
+-spec update_list(cerl(), [cerl()], cerl() | 'none') -> cerl().
+
+update_list(Node, List, Tail) ->
+ ann_make_list(get_ann(Node), List, Tail).
+
+
+%% @spec ann_make_list(As::[term()], List::[cerl()]) -> cerl()
+%% @equiv ann_make_list(As, List, none)
+
+-spec ann_make_list([term()], [cerl()]) -> cerl().
+
+ann_make_list(As, List) ->
+ ann_make_list(As, List, none).
+
+
+%% @spec ann_make_list(As::[term()], List::[cerl()], Tail) -> cerl()
+%%
+%% Tail = cerl() | none
+%%
+%% @see make_list/2
+%% @see ann_make_list/2
+
+-spec ann_make_list([term()], [cerl()], cerl() | 'none') -> cerl().
+
+ann_make_list(As, [H | T], Tail) ->
+ ann_c_cons(As, H, make_list(T, Tail)); % `c_cons' folds literals
+ann_make_list(As, [], none) ->
+ ann_c_nil(As);
+ann_make_list(_, [], Node) ->
+ Node.
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_tuple(Elements::[cerl()]) -> cerl()
+%%
+%% @doc Creates an abstract tuple. If <code>Elements</code> is
+%% <code>[E1, ..., En]</code>, the result represents
+%% "<code>{<em>E1</em>, ..., <em>En</em>}</code>". Note that if all
+%% nodes in <code>Elements</code> have type <code>literal</code>, or if
+%% <code>Elements</code> is empty, then the result will also have type
+%% <code>literal</code> and annotations on nodes in
+%% <code>Elements</code> are lost.
+%%
+%% <p>Recall that Erlang has distinct 1-tuples, i.e., <code>{X}</code>
+%% is always distinct from <code>X</code> itself.</p>
+%%
+%% @see ann_c_tuple/2
+%% @see update_c_tuple/2
+%% @see is_c_tuple/1
+%% @see tuple_es/1
+%% @see tuple_arity/1
+%% @see c_tuple_skel/1
+
+%% *Always* collapse literals.
+
+-spec c_tuple([cerl()]) -> c_tuple() | c_literal().
+
+c_tuple(Es) ->
+ case is_lit_list(Es) of
+ false ->
+ #c_tuple{es = Es};
+ true ->
+ #c_literal{val = list_to_tuple(lit_list_vals(Es))}
+ end.
+
+
+%% @spec ann_c_tuple(As::[term()], Elements::[cerl()]) -> cerl()
+%% @see c_tuple/1
+
+-spec ann_c_tuple([term()], [cerl()]) -> c_tuple() | c_literal().
+
+ann_c_tuple(As, Es) ->
+ case is_lit_list(Es) of
+ false ->
+ #c_tuple{es = Es, anno = As};
+ true ->
+ #c_literal{val = list_to_tuple(lit_list_vals(Es)), anno = As}
+ end.
+
+
+%% @spec update_c_tuple(Old::cerl(), Elements::[cerl()]) -> cerl()
+%% @see c_tuple/1
+
+-spec update_c_tuple(c_tuple() | c_literal(), [cerl()]) -> c_tuple() | c_literal().
+
+update_c_tuple(Node, Es) ->
+ case is_lit_list(Es) of
+ false ->
+ #c_tuple{es = Es, anno = get_ann(Node)};
+ true ->
+ #c_literal{val = list_to_tuple(lit_list_vals(Es)),
+ anno = get_ann(Node)}
+ end.
+
+
+%% @spec c_tuple_skel(Elements::[cerl()]) -> cerl()
+%%
+%% @doc Creates an abstract tuple skeleton. Does not fold constant
+%% literals, i.e., the result always has type <code>tuple</code>,
+%% representing "<code>{<em>E1</em>, ..., <em>En</em>}</code>", if
+%% <code>Elements</code> is <code>[E1, ..., En]</code>.
+%%
+%% <p>This function is occasionally useful when it is necessary to have
+%% annotations on the subnodes of a tuple node, even when all the
+%% subnodes are constant literals. Note however that
+%% <code>is_literal/1</code> will yield <code>false</code> and
+%% <code>concrete/1</code> will fail if passed the result from this
+%% function.</p>
+%%
+%% <p><code>fold_literal/1</code> can be used to revert a node to the
+%% normal-form representation.</p>
+%%
+%% @see ann_c_tuple_skel/2
+%% @see update_c_tuple_skel/2
+%% @see c_tuple/1
+%% @see tuple_es/1
+%% @see is_c_tuple/1
+%% @see is_literal/1
+%% @see fold_literal/1
+%% @see concrete/1
+
+%% *Never* collapse literals.
+
+-spec c_tuple_skel([cerl()]) -> c_tuple().
+
+c_tuple_skel(Es) ->
+ #c_tuple{es = Es}.
+
+
+%% @spec ann_c_tuple_skel(As::[term()], Elements::[cerl()]) -> cerl()
+%% @see c_tuple_skel/1
+
+-spec ann_c_tuple_skel([term()], [cerl()]) -> c_tuple().
+
+ann_c_tuple_skel(As, Es) ->
+ #c_tuple{es = Es, anno = As}.
+
+
+%% @spec update_c_tuple_skel(Old::cerl(), Elements::[cerl()]) -> cerl()
+%% @see c_tuple_skel/1
+
+-spec update_c_tuple_skel(c_tuple(), [cerl()]) -> c_tuple().
+
+update_c_tuple_skel(Old, Es) ->
+ #c_tuple{es = Es, anno = get_ann(Old)}.
+
+
+%% @spec is_c_tuple(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% tuple, otherwise <code>false</code>.
+%%
+%% @see c_tuple/1
+
+-spec is_c_tuple(cerl()) -> boolean().
+
+is_c_tuple(#c_tuple{}) ->
+ true;
+is_c_tuple(#c_literal{val = V}) when is_tuple(V) ->
+ true;
+is_c_tuple(_) ->
+ false.
+
+
+%% @spec tuple_es(cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of element subtrees of an abstract tuple.
+%%
+%% @see c_tuple/1
+
+-spec tuple_es(c_tuple() | c_literal()) -> [cerl()].
+
+tuple_es(#c_tuple{es = Es}) ->
+ Es;
+tuple_es(#c_literal{val = V}) ->
+ make_lit_list(tuple_to_list(V)).
+
+
+%% @spec tuple_arity(Node::cerl()) -> integer()
+%%
+%% @doc Returns the number of element subtrees of an abstract tuple.
+%%
+%% <p>Note: this is equivalent to <code>length(tuple_es(Node))</code>,
+%% but potentially more efficient.</p>
+%%
+%% @see tuple_es/1
+%% @see c_tuple/1
+
+-spec tuple_arity(c_tuple() | c_literal()) -> non_neg_integer().
+
+tuple_arity(#c_tuple{es = Es}) ->
+ length(Es);
+tuple_arity(#c_literal{val = V}) when is_tuple(V) ->
+ tuple_size(V).
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_var(Name::var_name()) -> cerl()
+%%
+%% var_name() = integer() | atom() | {atom(), integer()}
+%%
+%% @doc Creates an abstract variable. A variable is identified by its
+%% name, given by the <code>Name</code> parameter.
+%%
+%% <p>If a name is given by a single atom, it should either be a
+%% "simple" atom which does not need to be single-quoted in Erlang, or
+%% otherwise its print name should correspond to a proper Erlang
+%% variable, i.e., begin with an uppercase character or an
+%% underscore. Names on the form <code>{A, N}</code> represent
+%% function name variables "<code><em>A</em>/<em>N</em></code>"; these
+%% are special variables which may be bound only in the function
+%% definitions of a module or a <code>letrec</code>. They may not be
+%% bound in <code>let</code> expressions and cannot occur in clause
+%% patterns. The atom <code>A</code> in a function name may be any
+%% atom; the integer <code>N</code> must be nonnegative. The functions
+%% <code>c_fname/2</code> etc. are utilities for handling function
+%% name variables.</p>
+%%
+%% <p>When printing variable names, they must have the form of proper
+%% Core Erlang variables and function names. E.g., a name represented
+%% by an integer such as <code>42</code> could be formatted as
+%% "<code>_42</code>", an atom <code>'Xxx'</code> simply as
+%% "<code>Xxx</code>", and an atom <code>foo</code> as
+%% "<code>_foo</code>". However, one must assure that any two valid
+%% distinct names are never mapped to the same strings. Tuples such
+%% as <code>{foo, 2}</code> representing function names can simply by
+%% formatted as "<code>'foo'/2</code>", with no risk of conflicts.</p>
+%%
+%% @see ann_c_var/2
+%% @see update_c_var/2
+%% @see is_c_var/1
+%% @see var_name/1
+%% @see c_fname/2
+%% @see c_module/4
+%% @see c_letrec/2
+
+-spec c_var(var_name()) -> c_var().
+
+c_var(Name) ->
+ #c_var{name = Name}.
+
+
+%% @spec ann_c_var(As::[term()], Name::var_name()) -> cerl()
+%%
+%% @see c_var/1
+
+-spec ann_c_var([term()], var_name()) -> c_var().
+
+ann_c_var(As, Name) ->
+ #c_var{name = Name, anno = As}.
+
+%% @spec update_c_var(Old::cerl(), Name::var_name()) -> cerl()
+%%
+%% @see c_var/1
+
+-spec update_c_var(c_var(), var_name()) -> c_var().
+
+update_c_var(Node, Name) ->
+ #c_var{name = Name, anno = get_ann(Node)}.
+
+
+%% @spec is_c_var(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% variable, otherwise <code>false</code>.
+%%
+%% @see c_var/1
+
+-spec is_c_var(cerl()) -> boolean().
+
+is_c_var(#c_var{}) ->
+ true;
+is_c_var(_) ->
+ false.
+
+
+%% @spec c_fname(Name::atom(), Arity::integer()) -> cerl()
+%% @equiv c_var({Name, Arity})
+%% @see fname_id/1
+%% @see fname_arity/1
+%% @see is_c_fname/1
+%% @see ann_c_fname/3
+%% @see update_c_fname/3
+
+-spec c_fname(atom(), non_neg_integer()) -> c_var().
+
+c_fname(Atom, Arity) ->
+ c_var({Atom, Arity}).
+
+
+%% @spec ann_c_fname(As::[term()], Name::atom(), Arity::integer()) ->
+%% cerl()
+%% @equiv ann_c_var(As, {Atom, Arity})
+%% @see c_fname/2
+
+-spec ann_c_fname([term()], atom(), non_neg_integer()) -> c_var().
+
+ann_c_fname(As, Atom, Arity) ->
+ ann_c_var(As, {Atom, Arity}).
+
+
+%% @spec update_c_fname(Old::cerl(), Name::atom()) -> cerl()
+%% @doc Like <code>update_c_fname/3</code>, but takes the arity from
+%% <code>Node</code>.
+%% @see update_c_fname/3
+%% @see c_fname/2
+
+-spec update_c_fname(c_var(), atom()) -> c_var().
+
+update_c_fname(#c_var{name = {_, Arity}, anno = As}, Atom) ->
+ #c_var{name = {Atom, Arity}, anno = As}.
+
+
+%% @spec update_c_fname(Old::cerl(), Name::atom(), Arity::integer()) ->
+%% cerl()
+%% @equiv update_c_var(Old, {Atom, Arity})
+%% @see update_c_fname/2
+%% @see c_fname/2
+
+-spec update_c_fname(c_var(), atom(), integer()) -> c_var().
+
+update_c_fname(Node, Atom, Arity) ->
+ update_c_var(Node, {Atom, Arity}).
+
+
+%% @spec is_c_fname(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% function name variable, otherwise <code>false</code>.
+%%
+%% @see c_fname/2
+%% @see c_var/1
+%% @see c_var_name/1
+
+-spec is_c_fname(cerl()) -> boolean().
+
+is_c_fname(#c_var{name = {A, N}}) when is_atom(A), is_integer(N), N >= 0 ->
+ true;
+is_c_fname(_) ->
+ false.
+
+
+%% @spec var_name(cerl()) -> var_name()
+%%
+%% @doc Returns the name of an abstract variable.
+%%
+%% @see c_var/1
+
+-spec var_name(c_var()) -> var_name().
+
+var_name(Node) ->
+ Node#c_var.name.
+
+
+%% @spec fname_id(cerl()) -> atom()
+%%
+%% @doc Returns the identifier part of an abstract function name
+%% variable.
+%%
+%% @see fname_arity/1
+%% @see c_fname/2
+
+-spec fname_id(c_var()) -> atom().
+
+fname_id(#c_var{name={A,_}}) ->
+ A.
+
+
+%% @spec fname_arity(cerl()) -> byte()
+%%
+%% @doc Returns the arity part of an abstract function name variable.
+%%
+%% @see fname_id/1
+%% @see c_fname/2
+
+-spec fname_arity(c_var()) -> byte().
+
+fname_arity(#c_var{name={_,N}}) ->
+ N.
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_values(Elements::[cerl()]) -> cerl()
+%%
+%% @doc Creates an abstract value list. If <code>Elements</code> is
+%% <code>[E1, ..., En]</code>, the result represents
+%% "<code>&lt;<em>E1</em>, ..., <em>En</em>&gt;</code>".
+%%
+%% @see ann_c_values/2
+%% @see update_c_values/2
+%% @see is_c_values/1
+%% @see values_es/1
+%% @see values_arity/1
+
+-spec c_values([cerl()]) -> c_values().
+
+c_values(Es) ->
+ #c_values{es = Es}.
+
+
+%% @spec ann_c_values(As::[term()], Elements::[cerl()]) -> cerl()
+%% @see c_values/1
+
+-spec ann_c_values([term()], [cerl()]) -> c_values().
+
+ann_c_values(As, Es) ->
+ #c_values{es = Es, anno = As}.
+
+
+%% @spec update_c_values(Old::cerl(), Elements::[cerl()]) -> cerl()
+%% @see c_values/1
+
+-spec update_c_values(c_values(), [cerl()]) -> c_values().
+
+update_c_values(Node, Es) ->
+ #c_values{es = Es, anno = get_ann(Node)}.
+
+
+%% @spec is_c_values(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% value list; otherwise <code>false</code>.
+%%
+%% @see c_values/1
+
+-spec is_c_values(cerl()) -> boolean().
+
+is_c_values(#c_values{}) ->
+ true;
+is_c_values(_) ->
+ false.
+
+
+%% @spec values_es(cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of element subtrees of an abstract value
+%% list.
+%%
+%% @see c_values/1
+%% @see values_arity/1
+
+-spec values_es(c_values()) -> [cerl()].
+
+values_es(Node) ->
+ Node#c_values.es.
+
+
+%% @spec values_arity(Node::cerl()) -> integer()
+%%
+%% @doc Returns the number of element subtrees of an abstract value
+%% list.
+%%
+%% <p>Note: This is equivalent to
+%% <code>length(values_es(Node))</code>, but potentially more
+%% efficient.</p>
+%%
+%% @see c_values/1
+%% @see values_es/1
+
+-spec values_arity(c_values()) -> non_neg_integer().
+
+values_arity(Node) ->
+ length(values_es(Node)).
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_binary(Segments::[cerl()]) -> cerl()
+%%
+%% @doc Creates an abstract binary-template. A binary object is a
+%% sequence of 8-bit bytes. It is specified by zero or more bit-string
+%% template <em>segments</em> of arbitrary lengths (in number of bits),
+%% such that the sum of the lengths is evenly divisible by 8. If
+%% <code>Segments</code> is <code>[S1, ..., Sn]</code>, the result
+%% represents "<code>#{<em>S1</em>, ..., <em>Sn</em>}#</code>". All the
+%% <code>Si</code> must have type <code>bitstr</code>.
+%%
+%% @see ann_c_binary/2
+%% @see update_c_binary/2
+%% @see is_c_binary/1
+%% @see binary_segments/1
+%% @see c_bitstr/5
+
+-spec c_binary([cerl()]) -> c_binary().
+
+c_binary(Segments) ->
+ #c_binary{segments = Segments}.
+
+
+%% @spec ann_c_binary(As::[term()], Segments::[cerl()]) -> cerl()
+%% @see c_binary/1
+
+-spec ann_c_binary([term()], [cerl()]) -> c_binary().
+
+ann_c_binary(As, Segments) ->
+ #c_binary{segments = Segments, anno = As}.
+
+
+%% @spec update_c_binary(Old::cerl(), Segments::[cerl()]) -> cerl()
+%% @see c_binary/1
+
+-spec update_c_binary(c_binary(), [cerl()]) -> c_binary().
+
+update_c_binary(Node, Segments) ->
+ #c_binary{segments = Segments, anno = get_ann(Node)}.
+
+
+%% @spec is_c_binary(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% binary-template; otherwise <code>false</code>.
+%%
+%% @see c_binary/1
+
+-spec is_c_binary(cerl()) -> boolean().
+
+is_c_binary(#c_binary{}) ->
+ true;
+is_c_binary(_) ->
+ false.
+
+
+%% @spec binary_segments(cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of segment subtrees of an abstract
+%% binary-template.
+%%
+%% @see c_binary/1
+%% @see c_bitstr/5
+
+-spec binary_segments(c_binary()) -> [cerl()].
+
+binary_segments(Node) ->
+ Node#c_binary.segments.
+
+
+%% @spec c_bitstr(Value::cerl(), Size::cerl(), Unit::cerl(),
+%% Type::cerl(), Flags::cerl()) -> cerl()
+%%
+%% @doc Creates an abstract bit-string template. These can only occur as
+%% components of an abstract binary-template (see {@link c_binary/1}).
+%% The result represents "<code>#&lt;<em>Value</em>&gt;(<em>Size</em>,
+%% <em>Unit</em>, <em>Type</em>, <em>Flags</em>)</code>", where
+%% <code>Unit</code> must represent a positive integer constant,
+%% <code>Type</code> must represent a constant atom (one of
+%% <code>'integer'</code>, <code>'float'</code>, or
+%% <code>'binary'</code>), and <code>Flags</code> must represent a
+%% constant list <code>"[<em>F1</em>, ..., <em>Fn</em>]"</code> where
+%% all the <code>Fi</code> are atoms.
+%%
+%% @see c_binary/1
+%% @see ann_c_bitstr/6
+%% @see update_c_bitstr/6
+%% @see is_c_bitstr/1
+%% @see bitstr_val/1
+%% @see bitstr_size/1
+%% @see bitstr_unit/1
+%% @see bitstr_type/1
+%% @see bitstr_flags/1
+
+-spec c_bitstr(cerl(), cerl(), cerl(), cerl(), cerl()) -> c_bitstr().
+
+c_bitstr(Val, Size, Unit, Type, Flags) ->
+ #c_bitstr{val = Val, size = Size, unit = Unit, type = Type,
+ flags = Flags}.
+
+
+%% @spec c_bitstr(Value::cerl(), Size::cerl(), Type::cerl(),
+%% Flags::cerl()) -> cerl()
+%% @equiv c_bitstr(Value, Size, abstract(1), Type, Flags)
+
+-spec c_bitstr(cerl(), cerl(), cerl(), cerl()) -> c_bitstr().
+
+c_bitstr(Val, Size, Type, Flags) ->
+ c_bitstr(Val, Size, abstract(1), Type, Flags).
+
+
+%% @spec c_bitstr(Value::cerl(), Type::cerl(),
+%% Flags::cerl()) -> cerl()
+%% @equiv c_bitstr(Value, abstract(all), abstract(1), Type, Flags)
+
+-spec c_bitstr(cerl(), cerl(), cerl()) -> c_bitstr().
+
+c_bitstr(Val, Type, Flags) ->
+ c_bitstr(Val, abstract(all), abstract(1), Type, Flags).
+
+
+%% @spec ann_c_bitstr(As::[term()], Value::cerl(), Size::cerl(),
+%% Unit::cerl(), Type::cerl(), Flags::cerl()) -> cerl()
+%% @see c_bitstr/5
+%% @see ann_c_bitstr/5
+
+-spec ann_c_bitstr([term()], cerl(), cerl(), cerl(), cerl(), cerl()) ->
+ c_bitstr().
+
+ann_c_bitstr(As, Val, Size, Unit, Type, Flags) ->
+ #c_bitstr{val = Val, size = Size, unit = Unit, type = Type,
+ flags = Flags, anno = As}.
+
+%% @spec ann_c_bitstr(As::[term()], Value::cerl(), Size::cerl(),
+%% Type::cerl(), Flags::cerl()) -> cerl()
+%% @equiv ann_c_bitstr(As, Value, Size, abstract(1), Type, Flags)
+
+-spec ann_c_bitstr([term()], cerl(), cerl(), cerl(), cerl()) -> c_bitstr().
+
+ann_c_bitstr(As, Value, Size, Type, Flags) ->
+ ann_c_bitstr(As, Value, Size, abstract(1), Type, Flags).
+
+
+%% @spec update_c_bitstr(Old::cerl(), Value::cerl(), Size::cerl(),
+%% Unit::cerl(), Type::cerl(), Flags::cerl()) -> cerl()
+%% @see c_bitstr/5
+%% @see update_c_bitstr/5
+
+-spec update_c_bitstr(c_bitstr(), cerl(), cerl(), cerl(), cerl(), cerl()) ->
+ c_bitstr().
+
+update_c_bitstr(Node, Val, Size, Unit, Type, Flags) ->
+ #c_bitstr{val = Val, size = Size, unit = Unit, type = Type,
+ flags = Flags, anno = get_ann(Node)}.
+
+
+%% @spec update_c_bitstr(Old::cerl(), Value::cerl(), Size::cerl(),
+%% Type::cerl(), Flags::cerl()) -> cerl()
+%% @equiv update_c_bitstr(Node, Value, Size, abstract(1), Type, Flags)
+
+-spec update_c_bitstr(c_bitstr(), cerl(), cerl(), cerl(), cerl()) -> c_bitstr().
+
+update_c_bitstr(Node, Value, Size, Type, Flags) ->
+ update_c_bitstr(Node, Value, Size, abstract(1), Type, Flags).
+
+%% @spec is_c_bitstr(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% bit-string template; otherwise <code>false</code>.
+%%
+%% @see c_bitstr/5
+
+-spec is_c_bitstr(cerl()) -> boolean().
+
+is_c_bitstr(#c_bitstr{}) ->
+ true;
+is_c_bitstr(_) ->
+ false.
+
+
+%% @spec bitstr_val(cerl()) -> cerl()
+%%
+%% @doc Returns the value subtree of an abstract bit-string template.
+%%
+%% @see c_bitstr/5
+
+-spec bitstr_val(c_bitstr()) -> cerl().
+
+bitstr_val(Node) ->
+ Node#c_bitstr.val.
+
+
+%% @spec bitstr_size(cerl()) -> cerl()
+%%
+%% @doc Returns the size subtree of an abstract bit-string template.
+%%
+%% @see c_bitstr/5
+
+-spec bitstr_size(c_bitstr()) -> cerl().
+
+bitstr_size(Node) ->
+ Node#c_bitstr.size.
+
+
+%% @spec bitstr_bitsize(cerl()) -> any | all | utf | integer()
+%%
+%% @doc Returns the total size in bits of an abstract bit-string
+%% template. If the size field is an integer literal, the result is the
+%% product of the size and unit values; if the size field is the atom
+%% literal <code>all</code>, the atom <code>all</code> is returned.
+%% If the size is not a literal, the atom <code>any</code> is returned.
+%%
+%% @see c_bitstr/5
+
+-spec bitstr_bitsize(c_bitstr()) -> 'all' | 'any' | 'utf' | non_neg_integer().
+
+bitstr_bitsize(Node) ->
+ Size = Node#c_bitstr.size,
+ case is_literal(Size) of
+ true ->
+ case concrete(Size) of
+ all ->
+ all;
+ undefined ->
+ %% just an assertion below
+ "utf" ++ _ = atom_to_list(concrete(Node#c_bitstr.type)),
+ utf;
+ S when is_integer(S) ->
+ S * concrete(Node#c_bitstr.unit)
+ end;
+ false ->
+ any
+ end.
+
+
+%% @spec bitstr_unit(cerl()) -> cerl()
+%%
+%% @doc Returns the unit subtree of an abstract bit-string template.
+%%
+%% @see c_bitstr/5
+
+-spec bitstr_unit(c_bitstr()) -> cerl().
+
+bitstr_unit(Node) ->
+ Node#c_bitstr.unit.
+
+
+%% @spec bitstr_type(cerl()) -> cerl()
+%%
+%% @doc Returns the type subtree of an abstract bit-string template.
+%%
+%% @see c_bitstr/5
+
+-spec bitstr_type(c_bitstr()) -> cerl().
+
+bitstr_type(Node) ->
+ Node#c_bitstr.type.
+
+
+%% @spec bitstr_flags(cerl()) -> cerl()
+%%
+%% @doc Returns the flags subtree of an abstract bit-string template.
+%%
+%% @see c_bitstr/5
+
+-spec bitstr_flags(c_bitstr()) -> cerl().
+
+bitstr_flags(Node) ->
+ Node#c_bitstr.flags.
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_fun(Variables::[cerl()], Body::cerl()) -> cerl()
+%%
+%% @doc Creates an abstract fun-expression. If <code>Variables</code>
+%% is <code>[V1, ..., Vn]</code>, the result represents "<code>fun
+%% (<em>V1</em>, ..., <em>Vn</em>) -> <em>Body</em></code>". All the
+%% <code>Vi</code> must have type <code>var</code>.
+%%
+%% @see ann_c_fun/3
+%% @see update_c_fun/3
+%% @see is_c_fun/1
+%% @see fun_vars/1
+%% @see fun_body/1
+%% @see fun_arity/1
+
+-spec c_fun([cerl()], cerl()) -> c_fun().
+
+c_fun(Variables, Body) ->
+ #c_fun{vars = Variables, body = Body}.
+
+
+%% @spec ann_c_fun(As::[term()], Variables::[cerl()], Body::cerl()) ->
+%% cerl()
+%% @see c_fun/2
+
+-spec ann_c_fun([term()], [cerl()], cerl()) -> c_fun().
+
+ann_c_fun(As, Variables, Body) ->
+ #c_fun{vars = Variables, body = Body, anno = As}.
+
+
+%% @spec update_c_fun(Old::cerl(), Variables::[cerl()],
+%% Body::cerl()) -> cerl()
+%% @see c_fun/2
+
+-spec update_c_fun(c_fun(), [cerl()], cerl()) -> c_fun().
+
+update_c_fun(Node, Variables, Body) ->
+ #c_fun{vars = Variables, body = Body, anno = get_ann(Node)}.
+
+
+%% @spec is_c_fun(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% fun-expression, otherwise <code>false</code>.
+%%
+%% @see c_fun/2
+
+-spec is_c_fun(cerl()) -> boolean().
+
+is_c_fun(#c_fun{}) ->
+ true; % Now this is fun!
+is_c_fun(_) ->
+ false.
+
+
+%% @spec fun_vars(cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of parameter subtrees of an abstract
+%% fun-expression.
+%%
+%% @see c_fun/2
+%% @see fun_arity/1
+
+-spec fun_vars(c_fun()) -> [cerl()].
+
+fun_vars(Node) ->
+ Node#c_fun.vars.
+
+
+%% @spec fun_body(cerl()) -> cerl()
+%%
+%% @doc Returns the body subtree of an abstract fun-expression.
+%%
+%% @see c_fun/2
+
+-spec fun_body(c_fun()) -> cerl().
+
+fun_body(Node) ->
+ Node#c_fun.body.
+
+
+%% @spec fun_arity(Node::cerl()) -> integer()
+%%
+%% @doc Returns the number of parameter subtrees of an abstract
+%% fun-expression.
+%%
+%% <p>Note: this is equivalent to <code>length(fun_vars(Node))</code>,
+%% but potentially more efficient.</p>
+%%
+%% @see c_fun/2
+%% @see fun_vars/1
+
+-spec fun_arity(c_fun()) -> non_neg_integer().
+
+fun_arity(Node) ->
+ length(fun_vars(Node)).
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_seq(Argument::cerl(), Body::cerl()) -> cerl()
+%%
+%% @doc Creates an abstract sequencing expression. The result
+%% represents "<code>do <em>Argument</em> <em>Body</em></code>".
+%%
+%% @see ann_c_seq/3
+%% @see update_c_seq/3
+%% @see is_c_seq/1
+%% @see seq_arg/1
+%% @see seq_body/1
+
+-spec c_seq(cerl(), cerl()) -> c_seq().
+
+c_seq(Argument, Body) ->
+ #c_seq{arg = Argument, body = Body}.
+
+
+%% @spec ann_c_seq(As::[term()], Argument::cerl(), Body::cerl()) ->
+%% cerl()
+%% @see c_seq/2
+
+-spec ann_c_seq([term()], cerl(), cerl()) -> c_seq().
+
+ann_c_seq(As, Argument, Body) ->
+ #c_seq{arg = Argument, body = Body, anno = As}.
+
+
+%% @spec update_c_seq(Old::cerl(), Argument::cerl(), Body::cerl()) ->
+%% cerl()
+%% @see c_seq/2
+
+-spec update_c_seq(c_seq(), cerl(), cerl()) -> c_seq().
+
+update_c_seq(Node, Argument, Body) ->
+ #c_seq{arg = Argument, body = Body, anno = get_ann(Node)}.
+
+
+%% @spec is_c_seq(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% sequencing expression, otherwise <code>false</code>.
+%%
+%% @see c_seq/2
+
+-spec is_c_seq(cerl()) -> boolean().
+
+is_c_seq(#c_seq{}) ->
+ true;
+is_c_seq(_) ->
+ false.
+
+
+%% @spec seq_arg(cerl()) -> cerl()
+%%
+%% @doc Returns the argument subtree of an abstract sequencing
+%% expression.
+%%
+%% @see c_seq/2
+
+-spec seq_arg(c_seq()) -> cerl().
+
+seq_arg(Node) ->
+ Node#c_seq.arg.
+
+
+%% @spec seq_body(cerl()) -> cerl()
+%%
+%% @doc Returns the body subtree of an abstract sequencing expression.
+%%
+%% @see c_seq/2
+
+-spec seq_body(c_seq()) -> cerl().
+
+seq_body(Node) ->
+ Node#c_seq.body.
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_let(Variables::[cerl()], Argument::cerl(), Body::cerl()) ->
+%% cerl()
+%%
+%% @doc Creates an abstract let-expression. If <code>Variables</code>
+%% is <code>[V1, ..., Vn]</code>, the result represents "<code>let
+%% &lt;<em>V1</em>, ..., <em>Vn</em>&gt; = <em>Argument</em> in
+%% <em>Body</em></code>". All the <code>Vi</code> must have type
+%% <code>var</code>.
+%%
+%% @see ann_c_let/4
+%% @see update_c_let/4
+%% @see is_c_let/1
+%% @see let_vars/1
+%% @see let_arg/1
+%% @see let_body/1
+%% @see let_arity/1
+
+-spec c_let([cerl()], cerl(), cerl()) -> c_let().
+
+c_let(Variables, Argument, Body) ->
+ #c_let{vars = Variables, arg = Argument, body = Body}.
+
+
+%% ann_c_let(As, Variables, Argument, Body) -> Node
+%% @see c_let/3
+
+-spec ann_c_let([term()], [cerl()], cerl(), cerl()) -> c_let().
+
+ann_c_let(As, Variables, Argument, Body) ->
+ #c_let{vars = Variables, arg = Argument, body = Body, anno = As}.
+
+
+%% update_c_let(Old, Variables, Argument, Body) -> Node
+%% @see c_let/3
+
+-spec update_c_let(c_let(), [cerl()], cerl(), cerl()) -> c_let().
+
+update_c_let(Node, Variables, Argument, Body) ->
+ #c_let{vars = Variables, arg = Argument, body = Body,
+ anno = get_ann(Node)}.
+
+
+%% @spec is_c_let(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% let-expression, otherwise <code>false</code>.
+%%
+%% @see c_let/3
+
+-spec is_c_let(cerl()) -> boolean().
+
+is_c_let(#c_let{}) ->
+ true;
+is_c_let(_) ->
+ false.
+
+
+%% @spec let_vars(cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of left-hand side variables of an abstract
+%% let-expression.
+%%
+%% @see c_let/3
+%% @see let_arity/1
+
+-spec let_vars(c_let()) -> [cerl()].
+
+let_vars(Node) ->
+ Node#c_let.vars.
+
+
+%% @spec let_arg(cerl()) -> cerl()
+%%
+%% @doc Returns the argument subtree of an abstract let-expression.
+%%
+%% @see c_let/3
+
+-spec let_arg(c_let()) -> cerl().
+
+let_arg(Node) ->
+ Node#c_let.arg.
+
+
+%% @spec let_body(cerl()) -> cerl()
+%%
+%% @doc Returns the body subtree of an abstract let-expression.
+%%
+%% @see c_let/3
+
+-spec let_body(c_let()) -> cerl().
+
+let_body(Node) ->
+ Node#c_let.body.
+
+
+%% @spec let_arity(Node::cerl()) -> integer()
+%%
+%% @doc Returns the number of left-hand side variables of an abstract
+%% let-expression.
+%%
+%% <p>Note: this is equivalent to <code>length(let_vars(Node))</code>,
+%% but potentially more efficient.</p>
+%%
+%% @see c_let/3
+%% @see let_vars/1
+
+-spec let_arity(c_let()) -> non_neg_integer().
+
+let_arity(Node) ->
+ length(let_vars(Node)).
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_letrec(Definitions::[{cerl(), cerl()}], Body::cerl()) ->
+%% cerl()
+%%
+%% @doc Creates an abstract letrec-expression. If
+%% <code>Definitions</code> is <code>[{V1, F1}, ..., {Vn, Fn}]</code>,
+%% the result represents "<code>letrec <em>V1</em> = <em>F1</em>
+%% ... <em>Vn</em> = <em>Fn</em> in <em>Body</em></code>. All the
+%% <code>Vi</code> must have type <code>var</code> and represent
+%% function names. All the <code>Fi</code> must have type
+%% <code>'fun'</code>.
+%%
+%% @see ann_c_letrec/3
+%% @see update_c_letrec/3
+%% @see is_c_letrec/1
+%% @see letrec_defs/1
+%% @see letrec_body/1
+%% @see letrec_vars/1
+
+-spec c_letrec([{cerl(), cerl()}], cerl()) -> c_letrec().
+
+c_letrec(Defs, Body) ->
+ #c_letrec{defs = Defs, body = Body}.
+
+
+%% @spec ann_c_letrec(As::[term()], Definitions::[{cerl(), cerl()}],
+%% Body::cerl()) -> cerl()
+%% @see c_letrec/2
+
+-spec ann_c_letrec([term()], [{cerl(), cerl()}], cerl()) -> c_letrec().
+
+ann_c_letrec(As, Defs, Body) ->
+ #c_letrec{defs = Defs, body = Body, anno = As}.
+
+
+%% @spec update_c_letrec(Old::cerl(),
+%% Definitions::[{cerl(), cerl()}],
+%% Body::cerl()) -> cerl()
+%% @see c_letrec/2
+
+-spec update_c_letrec(c_letrec(), [{cerl(), cerl()}], cerl()) -> c_letrec().
+
+update_c_letrec(Node, Defs, Body) ->
+ #c_letrec{defs = Defs, body = Body, anno = get_ann(Node)}.
+
+
+%% @spec is_c_letrec(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% letrec-expression, otherwise <code>false</code>.
+%%
+%% @see c_letrec/2
+
+-spec is_c_letrec(cerl()) -> boolean().
+
+is_c_letrec(#c_letrec{}) ->
+ true;
+is_c_letrec(_) ->
+ false.
+
+
+%% @spec letrec_defs(Node::cerl()) -> [{cerl(), cerl()}]
+%%
+%% @doc Returns the list of definitions of an abstract
+%% letrec-expression. If <code>Node</code> represents "<code>letrec
+%% <em>V1</em> = <em>F1</em> ... <em>Vn</em> = <em>Fn</em> in
+%% <em>Body</em></code>", the returned value is <code>[{V1, F1}, ...,
+%% {Vn, Fn}]</code>.
+%%
+%% @see c_letrec/2
+
+-spec letrec_defs(c_letrec()) -> [{cerl(), cerl()}].
+
+letrec_defs(Node) ->
+ Node#c_letrec.defs.
+
+
+%% @spec letrec_body(cerl()) -> cerl()
+%%
+%% @doc Returns the body subtree of an abstract letrec-expression.
+%%
+%% @see c_letrec/2
+
+-spec letrec_body(c_letrec()) -> cerl().
+
+letrec_body(Node) ->
+ Node#c_letrec.body.
+
+
+%% @spec letrec_vars(cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of left-hand side function variable subtrees
+%% of a letrec-expression. If <code>Node</code> represents
+%% "<code>letrec <em>V1</em> = <em>F1</em> ... <em>Vn</em> =
+%% <em>Fn</em> in <em>Body</em></code>", the returned value is
+%% <code>[V1, ..., Vn]</code>.
+%%
+%% @see c_letrec/2
+
+-spec letrec_vars(c_letrec()) -> [cerl()].
+
+letrec_vars(Node) ->
+ [F || {F, _} <- letrec_defs(Node)].
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_case(Argument::cerl(), Clauses::[cerl()]) -> cerl()
+%%
+%% @doc Creates an abstract case-expression. If <code>Clauses</code>
+%% is <code>[C1, ..., Cn]</code>, the result represents "<code>case
+%% <em>Argument</em> of <em>C1</em> ... <em>Cn</em>
+%% end</code>". <code>Clauses</code> must not be empty.
+%%
+%% @see ann_c_case/3
+%% @see update_c_case/3
+%% @see is_c_case/1
+%% @see c_clause/3
+%% @see case_arg/1
+%% @see case_clauses/1
+%% @see case_arity/1
+
+-spec c_case(cerl(), [cerl()]) -> c_case().
+
+c_case(Expr, Clauses) ->
+ #c_case{arg = Expr, clauses = Clauses}.
+
+
+%% @spec ann_c_case(As::[term()], Argument::cerl(),
+%% Clauses::[cerl()]) -> cerl()
+%% @see c_case/2
+
+-spec ann_c_case([term()], cerl(), [cerl()]) -> c_case().
+
+ann_c_case(As, Expr, Clauses) ->
+ #c_case{arg = Expr, clauses = Clauses, anno = As}.
+
+
+%% @spec update_c_case(Old::cerl(), Argument::cerl(),
+%% Clauses::[cerl()]) -> cerl()
+%% @see c_case/2
+
+-spec update_c_case(c_case(), cerl(), [cerl()]) -> c_case().
+
+update_c_case(Node, Expr, Clauses) ->
+ #c_case{arg = Expr, clauses = Clauses, anno = get_ann(Node)}.
+
+
+%% is_c_case(Node) -> boolean()
+%%
+%% Node = cerl()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% case-expression; otherwise <code>false</code>.
+%%
+%% @see c_case/2
+
+-spec is_c_case(cerl()) -> boolean().
+
+is_c_case(#c_case{}) ->
+ true;
+is_c_case(_) ->
+ false.
+
+
+%% @spec case_arg(cerl()) -> cerl()
+%%
+%% @doc Returns the argument subtree of an abstract case-expression.
+%%
+%% @see c_case/2
+
+-spec case_arg(c_case()) -> cerl().
+
+case_arg(Node) ->
+ Node#c_case.arg.
+
+
+%% @spec case_clauses(cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of clause subtrees of an abstract
+%% case-expression.
+%%
+%% @see c_case/2
+%% @see case_arity/1
+
+-spec case_clauses(c_case()) -> [cerl()].
+
+case_clauses(Node) ->
+ Node#c_case.clauses.
+
+
+%% @spec case_arity(Node::cerl()) -> integer()
+%%
+%% @doc Equivalent to
+%% <code>clause_arity(hd(case_clauses(Node)))</code>, but potentially
+%% more efficient.
+%%
+%% @see c_case/2
+%% @see case_clauses/1
+%% @see clause_arity/1
+
+-spec case_arity(c_case()) -> non_neg_integer().
+
+case_arity(Node) ->
+ clause_arity(hd(case_clauses(Node))).
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_clause(Patterns::[cerl()], Body::cerl()) -> cerl()
+%% @equiv c_clause(Patterns, c_atom(true), Body)
+%% @see c_atom/1
+
+-spec c_clause([cerl()], cerl()) -> c_clause().
+
+c_clause(Patterns, Body) ->
+ c_clause(Patterns, c_atom(true), Body).
+
+
+%% @spec c_clause(Patterns::[cerl()], Guard::cerl(), Body::cerl()) ->
+%% cerl()
+%%
+%% @doc Creates an an abstract clause. If <code>Patterns</code> is
+%% <code>[P1, ..., Pn]</code>, the result represents
+%% "<code>&lt;<em>P1</em>, ..., <em>Pn</em>&gt; when <em>Guard</em> ->
+%% <em>Body</em></code>".
+%%
+%% @see c_clause/2
+%% @see ann_c_clause/4
+%% @see update_c_clause/4
+%% @see is_c_clause/1
+%% @see c_case/2
+%% @see c_receive/3
+%% @see clause_pats/1
+%% @see clause_guard/1
+%% @see clause_body/1
+%% @see clause_arity/1
+%% @see clause_vars/1
+
+-spec c_clause([cerl()], cerl(), cerl()) -> c_clause().
+
+c_clause(Patterns, Guard, Body) ->
+ #c_clause{pats = Patterns, guard = Guard, body = Body}.
+
+
+%% @spec ann_c_clause(As::[term()], Patterns::[cerl()],
+%% Body::cerl()) -> cerl()
+%% @equiv ann_c_clause(As, Patterns, c_atom(true), Body)
+%% @see c_clause/3
+
+-spec ann_c_clause([term()], [cerl()], cerl()) -> c_clause().
+
+ann_c_clause(As, Patterns, Body) ->
+ ann_c_clause(As, Patterns, c_atom(true), Body).
+
+
+%% @spec ann_c_clause(As::[term()], Patterns::[cerl()], Guard::cerl(),
+%% Body::cerl()) -> cerl()
+%% @see ann_c_clause/3
+%% @see c_clause/3
+
+-spec ann_c_clause([term()], [cerl()], cerl(), cerl()) -> c_clause().
+
+ann_c_clause(As, Patterns, Guard, Body) ->
+ #c_clause{pats = Patterns, guard = Guard, body = Body, anno = As}.
+
+
+%% @spec update_c_clause(Old::cerl(), Patterns::[cerl()],
+%% Guard::cerl(), Body::cerl()) -> cerl()
+%% @see c_clause/3
+
+-spec update_c_clause(c_clause(), [cerl()], cerl(), cerl()) -> c_clause().
+
+update_c_clause(Node, Patterns, Guard, Body) ->
+ #c_clause{pats = Patterns, guard = Guard, body = Body,
+ anno = get_ann(Node)}.
+
+
+%% @spec is_c_clause(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% clause, otherwise <code>false</code>.
+%%
+%% @see c_clause/3
+
+-spec is_c_clause(cerl()) -> boolean().
+
+is_c_clause(#c_clause{}) ->
+ true;
+is_c_clause(_) ->
+ false.
+
+
+%% @spec clause_pats(cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of pattern subtrees of an abstract clause.
+%%
+%% @see c_clause/3
+%% @see clause_arity/1
+
+-spec clause_pats(c_clause()) -> [cerl()].
+
+clause_pats(Node) ->
+ Node#c_clause.pats.
+
+
+%% @spec clause_guard(cerl()) -> cerl()
+%%
+%% @doc Returns the guard subtree of an abstract clause.
+%%
+%% @see c_clause/3
+
+-spec clause_guard(c_clause()) -> cerl().
+
+clause_guard(Node) ->
+ Node#c_clause.guard.
+
+
+%% @spec clause_body(cerl()) -> cerl()
+%%
+%% @doc Returns the body subtree of an abstract clause.
+%%
+%% @see c_clause/3
+
+-spec clause_body(c_clause()) -> cerl().
+
+clause_body(Node) ->
+ Node#c_clause.body.
+
+
+%% @spec clause_arity(Node::cerl()) -> integer()
+%%
+%% @doc Returns the number of pattern subtrees of an abstract clause.
+%%
+%% <p>Note: this is equivalent to
+%% <code>length(clause_pats(Node))</code>, but potentially more
+%% efficient.</p>
+%%
+%% @see c_clause/3
+%% @see clause_pats/1
+
+-spec clause_arity(c_clause()) -> non_neg_integer().
+
+clause_arity(Node) ->
+ length(clause_pats(Node)).
+
+
+%% @spec clause_vars(cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of all abstract variables in the patterns of
+%% an abstract clause. The order of listing is not defined.
+%%
+%% @see c_clause/3
+%% @see pat_list_vars/1
+
+-spec clause_vars(c_clause()) -> [cerl()].
+
+clause_vars(Clause) ->
+ pat_list_vars(clause_pats(Clause)).
+
+
+%% @spec pat_vars(Pattern::cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of all abstract variables in a pattern. An
+%% exception is thrown if <code>Node</code> does not represent a
+%% well-formed Core Erlang clause pattern. The order of listing is not
+%% defined.
+%%
+%% @see pat_list_vars/1
+%% @see clause_vars/1
+
+-spec pat_vars(cerl()) -> [cerl()].
+
+pat_vars(Node) ->
+ pat_vars(Node, []).
+
+pat_vars(Node, Vs) ->
+ case type(Node) of
+ var ->
+ [Node | Vs];
+ literal ->
+ Vs;
+ cons ->
+ pat_vars(cons_hd(Node), pat_vars(cons_tl(Node), Vs));
+ tuple ->
+ pat_list_vars(tuple_es(Node), Vs);
+ binary ->
+ pat_list_vars(binary_segments(Node), Vs);
+ bitstr ->
+ pat_vars(bitstr_val(Node), Vs);
+ alias ->
+ pat_vars(alias_pat(Node), [alias_var(Node) | Vs])
+ end.
+
+
+%% @spec pat_list_vars(Patterns::[cerl()]) -> [cerl()]
+%%
+%% @doc Returns the list of all abstract variables in the given
+%% patterns. An exception is thrown if some element in
+%% <code>Patterns</code> does not represent a well-formed Core Erlang
+%% clause pattern. The order of listing is not defined.
+%%
+%% @see pat_vars/1
+%% @see clause_vars/1
+
+-spec pat_list_vars([cerl()]) -> [cerl()].
+
+pat_list_vars(Ps) ->
+ pat_list_vars(Ps, []).
+
+pat_list_vars([P | Ps], Vs) ->
+ pat_list_vars(Ps, pat_vars(P, Vs));
+pat_list_vars([], Vs) ->
+ Vs.
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_alias(Variable::cerl(), Pattern::cerl()) -> cerl()
+%%
+%% @doc Creates an abstract pattern alias. The result represents
+%% "<code><em>Variable</em> = <em>Pattern</em></code>".
+%%
+%% @see ann_c_alias/3
+%% @see update_c_alias/3
+%% @see is_c_alias/1
+%% @see alias_var/1
+%% @see alias_pat/1
+%% @see c_clause/3
+
+-spec c_alias(c_var(), cerl()) -> c_alias().
+
+c_alias(Var, Pattern) ->
+ #c_alias{var = Var, pat = Pattern}.
+
+
+%% @spec ann_c_alias(As::[term()], Variable::cerl(),
+%% Pattern::cerl()) -> cerl()
+%% @see c_alias/2
+
+-spec ann_c_alias([term()], c_var(), cerl()) -> c_alias().
+
+ann_c_alias(As, Var, Pattern) ->
+ #c_alias{var = Var, pat = Pattern, anno = As}.
+
+
+%% @spec update_c_alias(Old::cerl(), Variable::cerl(),
+%% Pattern::cerl()) -> cerl()
+%% @see c_alias/2
+
+-spec update_c_alias(c_alias(), cerl(), cerl()) -> c_alias().
+
+update_c_alias(Node, Var, Pattern) ->
+ #c_alias{var = Var, pat = Pattern, anno = get_ann(Node)}.
+
+
+%% @spec is_c_alias(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% pattern alias, otherwise <code>false</code>.
+%%
+%% @see c_alias/2
+
+-spec is_c_alias(cerl()) -> boolean().
+
+is_c_alias(#c_alias{}) ->
+ true;
+is_c_alias(_) ->
+ false.
+
+
+%% @spec alias_var(cerl()) -> cerl()
+%%
+%% @doc Returns the variable subtree of an abstract pattern alias.
+%%
+%% @see c_alias/2
+
+-spec alias_var(c_alias()) -> c_var().
+
+alias_var(Node) ->
+ Node#c_alias.var.
+
+
+%% @spec alias_pat(cerl()) -> cerl()
+%%
+%% @doc Returns the pattern subtree of an abstract pattern alias.
+%%
+%% @see c_alias/2
+
+-spec alias_pat(c_alias()) -> cerl().
+
+alias_pat(Node) ->
+ Node#c_alias.pat.
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_receive(Clauses::[cerl()]) -> cerl()
+%% @equiv c_receive(Clauses, c_atom(infinity), c_atom(true))
+%% @see c_atom/1
+
+-spec c_receive([cerl()]) -> c_receive().
+
+c_receive(Clauses) ->
+ c_receive(Clauses, c_atom(infinity), c_atom(true)).
+
+
+%% @spec c_receive(Clauses::[cerl()], Timeout::cerl(),
+%% Action::cerl()) -> cerl()
+%%
+%% @doc Creates an abstract receive-expression. If
+%% <code>Clauses</code> is <code>[C1, ..., Cn]</code>, the result
+%% represents "<code>receive <em>C1</em> ... <em>Cn</em> after
+%% <em>Timeout</em> -> <em>Action</em> end</code>".
+%%
+%% @see c_receive/1
+%% @see ann_c_receive/4
+%% @see update_c_receive/4
+%% @see is_c_receive/1
+%% @see receive_clauses/1
+%% @see receive_timeout/1
+%% @see receive_action/1
+
+-spec c_receive([cerl()], cerl(), cerl()) -> c_receive().
+
+c_receive(Clauses, Timeout, Action) ->
+ #c_receive{clauses = Clauses, timeout = Timeout, action = Action}.
+
+
+%% @spec ann_c_receive(As::[term()], Clauses::[cerl()]) -> cerl()
+%% @equiv ann_c_receive(As, Clauses, c_atom(infinity), c_atom(true))
+%% @see c_receive/3
+%% @see c_atom/1
+
+-spec ann_c_receive([term()], [cerl()]) -> c_receive().
+
+ann_c_receive(As, Clauses) ->
+ ann_c_receive(As, Clauses, c_atom(infinity), c_atom(true)).
+
+
+%% @spec ann_c_receive(As::[term()], Clauses::[cerl()],
+%% Timeout::cerl(), Action::cerl()) -> cerl()
+%% @see ann_c_receive/2
+%% @see c_receive/3
+
+-spec ann_c_receive([term()], [cerl()], cerl(), cerl()) -> c_receive().
+
+ann_c_receive(As, Clauses, Timeout, Action) ->
+ #c_receive{clauses = Clauses, timeout = Timeout, action = Action,
+ anno = As}.
+
+
+%% @spec update_c_receive(Old::cerl(), Clauses::[cerl()],
+%% Timeout::cerl(), Action::cerl()) -> cerl()
+%% @see c_receive/3
+
+-spec update_c_receive(c_receive(), [cerl()], cerl(), cerl()) -> c_receive().
+
+update_c_receive(Node, Clauses, Timeout, Action) ->
+ #c_receive{clauses = Clauses, timeout = Timeout, action = Action,
+ anno = get_ann(Node)}.
+
+
+%% @spec is_c_receive(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% receive-expression, otherwise <code>false</code>.
+%%
+%% @see c_receive/3
+
+-spec is_c_receive(cerl()) -> boolean().
+
+is_c_receive(#c_receive{}) ->
+ true;
+is_c_receive(_) ->
+ false.
+
+
+%% @spec receive_clauses(cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of clause subtrees of an abstract
+%% receive-expression.
+%%
+%% @see c_receive/3
+
+-spec receive_clauses(c_receive()) -> [cerl()].
+
+receive_clauses(Node) ->
+ Node#c_receive.clauses.
+
+
+%% @spec receive_timeout(cerl()) -> cerl()
+%%
+%% @doc Returns the timeout subtree of an abstract receive-expression.
+%%
+%% @see c_receive/3
+
+-spec receive_timeout(c_receive()) -> cerl().
+
+receive_timeout(Node) ->
+ Node#c_receive.timeout.
+
+
+%% @spec receive_action(cerl()) -> cerl()
+%%
+%% @doc Returns the action subtree of an abstract receive-expression.
+%%
+%% @see c_receive/3
+
+-spec receive_action(c_receive()) -> cerl().
+
+receive_action(Node) ->
+ Node#c_receive.action.
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_apply(Operator::cerl(), Arguments::[cerl()]) -> cerl()
+%%
+%% @doc Creates an abstract function application. If
+%% <code>Arguments</code> is <code>[A1, ..., An]</code>, the result
+%% represents "<code>apply <em>Operator</em>(<em>A1</em>, ...,
+%% <em>An</em>)</code>".
+%%
+%% @see ann_c_apply/3
+%% @see update_c_apply/3
+%% @see is_c_apply/1
+%% @see apply_op/1
+%% @see apply_args/1
+%% @see apply_arity/1
+%% @see c_call/3
+%% @see c_primop/2
+
+-spec c_apply(cerl(), [cerl()]) -> c_apply().
+
+c_apply(Operator, Arguments) ->
+ #c_apply{op = Operator, args = Arguments}.
+
+
+%% @spec ann_c_apply(As::[term()], Operator::cerl(),
+%% Arguments::[cerl()]) -> cerl()
+%% @see c_apply/2
+
+-spec ann_c_apply([term()], cerl(), [cerl()]) -> c_apply().
+
+ann_c_apply(As, Operator, Arguments) ->
+ #c_apply{op = Operator, args = Arguments, anno = As}.
+
+
+%% @spec update_c_apply(Old::cerl(), Operator::cerl(),
+%% Arguments::[cerl()]) -> cerl()
+%% @see c_apply/2
+
+-spec update_c_apply(c_apply(), cerl(), [cerl()]) -> c_apply().
+
+update_c_apply(Node, Operator, Arguments) ->
+ #c_apply{op = Operator, args = Arguments, anno = get_ann(Node)}.
+
+
+%% @spec is_c_apply(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% function application, otherwise <code>false</code>.
+%%
+%% @see c_apply/2
+
+-spec is_c_apply(cerl()) -> boolean().
+
+is_c_apply(#c_apply{}) ->
+ true;
+is_c_apply(_) ->
+ false.
+
+
+%% @spec apply_op(cerl()) -> cerl()
+%%
+%% @doc Returns the operator subtree of an abstract function
+%% application.
+%%
+%% @see c_apply/2
+
+-spec apply_op(c_apply()) -> cerl().
+
+apply_op(Node) ->
+ Node#c_apply.op.
+
+
+%% @spec apply_args(cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of argument subtrees of an abstract function
+%% application.
+%%
+%% @see c_apply/2
+%% @see apply_arity/1
+
+-spec apply_args(c_apply()) -> [cerl()].
+
+apply_args(Node) ->
+ Node#c_apply.args.
+
+
+%% @spec apply_arity(Node::cerl()) -> integer()
+%%
+%% @doc Returns the number of argument subtrees of an abstract
+%% function application.
+%%
+%% <p>Note: this is equivalent to
+%% <code>length(apply_args(Node))</code>, but potentially more
+%% efficient.</p>
+%%
+%% @see c_apply/2
+%% @see apply_args/1
+
+-spec apply_arity(c_apply()) -> non_neg_integer().
+
+apply_arity(Node) ->
+ length(apply_args(Node)).
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_call(Module::cerl(), Name::cerl(), Arguments::[cerl()]) ->
+%% cerl()
+%%
+%% @doc Creates an abstract inter-module call. If
+%% <code>Arguments</code> is <code>[A1, ..., An]</code>, the result
+%% represents "<code>call <em>Module</em>:<em>Name</em>(<em>A1</em>,
+%% ..., <em>An</em>)</code>".
+%%
+%% @see ann_c_call/4
+%% @see update_c_call/4
+%% @see is_c_call/1
+%% @see call_module/1
+%% @see call_name/1
+%% @see call_args/1
+%% @see call_arity/1
+%% @see c_apply/2
+%% @see c_primop/2
+
+-spec c_call(cerl(), cerl(), [cerl()]) -> c_call().
+
+c_call(Module, Name, Arguments) ->
+ #c_call{module = Module, name = Name, args = Arguments}.
+
+
+%% @spec ann_c_call(As::[term()], Module::cerl(), Name::cerl(),
+%% Arguments::[cerl()]) -> cerl()
+%% @see c_call/3
+
+-spec ann_c_call([term()], cerl(), cerl(), [cerl()]) -> c_call().
+
+ann_c_call(As, Module, Name, Arguments) ->
+ #c_call{module = Module, name = Name, args = Arguments, anno = As}.
+
+
+%% @spec update_c_call(Old::cerl(), Module::cerl(), Name::cerl(),
+%% Arguments::[cerl()]) -> cerl()
+%% @see c_call/3
+
+-spec update_c_call(cerl(), cerl(), cerl(), [cerl()]) -> c_call().
+
+update_c_call(Node, Module, Name, Arguments) ->
+ #c_call{module = Module, name = Name, args = Arguments,
+ anno = get_ann(Node)}.
+
+
+%% @spec is_c_call(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% inter-module call expression; otherwise <code>false</code>.
+%%
+%% @see c_call/3
+
+-spec is_c_call(cerl()) -> boolean().
+
+is_c_call(#c_call{}) ->
+ true;
+is_c_call(_) ->
+ false.
+
+
+%% @spec call_module(cerl()) -> cerl()
+%%
+%% @doc Returns the module subtree of an abstract inter-module call.
+%%
+%% @see c_call/3
+
+-spec call_module(c_call()) -> cerl().
+
+call_module(Node) ->
+ Node#c_call.module.
+
+
+%% @spec call_name(cerl()) -> cerl()
+%%
+%% @doc Returns the name subtree of an abstract inter-module call.
+%%
+%% @see c_call/3
+
+-spec call_name(c_call()) -> cerl().
+
+call_name(Node) ->
+ Node#c_call.name.
+
+
+%% @spec call_args(cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of argument subtrees of an abstract
+%% inter-module call.
+%%
+%% @see c_call/3
+%% @see call_arity/1
+
+-spec call_args(c_call()) -> [cerl()].
+
+call_args(Node) ->
+ Node#c_call.args.
+
+
+%% @spec call_arity(Node::cerl()) -> integer()
+%%
+%% @doc Returns the number of argument subtrees of an abstract
+%% inter-module call.
+%%
+%% <p>Note: this is equivalent to
+%% <code>length(call_args(Node))</code>, but potentially more
+%% efficient.</p>
+%%
+%% @see c_call/3
+%% @see call_args/1
+
+-spec call_arity(c_call()) -> non_neg_integer().
+
+call_arity(Node) ->
+ length(call_args(Node)).
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_primop(Name::cerl(), Arguments::[cerl()]) -> cerl()
+%%
+%% @doc Creates an abstract primitive operation call. If
+%% <code>Arguments</code> is <code>[A1, ..., An]</code>, the result
+%% represents "<code>primop <em>Name</em>(<em>A1</em>, ...,
+%% <em>An</em>)</code>". <code>Name</code> must be an atom literal.
+%%
+%% @see ann_c_primop/3
+%% @see update_c_primop/3
+%% @see is_c_primop/1
+%% @see primop_name/1
+%% @see primop_args/1
+%% @see primop_arity/1
+%% @see c_apply/2
+%% @see c_call/3
+
+-spec c_primop(cerl(), [cerl()]) -> c_primop().
+
+c_primop(Name, Arguments) ->
+ #c_primop{name = Name, args = Arguments}.
+
+
+%% @spec ann_c_primop(As::[term()], Name::cerl(),
+%% Arguments::[cerl()]) -> cerl()
+%% @see c_primop/2
+
+-spec ann_c_primop([term()], cerl(), [cerl()]) -> c_primop().
+
+ann_c_primop(As, Name, Arguments) ->
+ #c_primop{name = Name, args = Arguments, anno = As}.
+
+
+%% @spec update_c_primop(Old::cerl(), Name::cerl(),
+%% Arguments::[cerl()]) -> cerl()
+%% @see c_primop/2
+
+-spec update_c_primop(cerl(), cerl(), [cerl()]) -> c_primop().
+
+update_c_primop(Node, Name, Arguments) ->
+ #c_primop{name = Name, args = Arguments, anno = get_ann(Node)}.
+
+
+%% @spec is_c_primop(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% primitive operation call, otherwise <code>false</code>.
+%%
+%% @see c_primop/2
+
+-spec is_c_primop(cerl()) -> boolean().
+
+is_c_primop(#c_primop{}) ->
+ true;
+is_c_primop(_) ->
+ false.
+
+
+%% @spec primop_name(cerl()) -> cerl()
+%%
+%% @doc Returns the name subtree of an abstract primitive operation
+%% call.
+%%
+%% @see c_primop/2
+
+-spec primop_name(c_primop()) -> cerl().
+
+primop_name(Node) ->
+ Node#c_primop.name.
+
+
+%% @spec primop_args(cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of argument subtrees of an abstract primitive
+%% operation call.
+%%
+%% @see c_primop/2
+%% @see primop_arity/1
+
+-spec primop_args(c_primop()) -> [cerl()].
+
+primop_args(Node) ->
+ Node#c_primop.args.
+
+
+%% @spec primop_arity(Node::cerl()) -> integer()
+%%
+%% @doc Returns the number of argument subtrees of an abstract
+%% primitive operation call.
+%%
+%% <p>Note: this is equivalent to
+%% <code>length(primop_args(Node))</code>, but potentially more
+%% efficient.</p>
+%%
+%% @see c_primop/2
+%% @see primop_args/1
+
+-spec primop_arity(c_primop()) -> non_neg_integer().
+
+primop_arity(Node) ->
+ length(primop_args(Node)).
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_try(Argument::cerl(), Variables::[cerl()], Body::cerl(),
+%% ExceptionVars::[cerl()], Handler::cerl()) -> cerl()
+%%
+%% @doc Creates an abstract try-expression. If <code>Variables</code> is
+%% <code>[V1, ..., Vn]</code> and <code>ExceptionVars</code> is
+%% <code>[X1, ..., Xm]</code>, the result represents "<code>try
+%% <em>Argument</em> of &lt;<em>V1</em>, ..., <em>Vn</em>&gt; ->
+%% <em>Body</em> catch &lt;<em>X1</em>, ..., <em>Xm</em>&gt; ->
+%% <em>Handler</em></code>". All the <code>Vi</code> and <code>Xi</code>
+%% must have type <code>var</code>.
+%%
+%% @see ann_c_try/6
+%% @see update_c_try/6
+%% @see is_c_try/1
+%% @see try_arg/1
+%% @see try_vars/1
+%% @see try_body/1
+%% @see c_catch/1
+
+-spec c_try(cerl(), [cerl()], cerl(), [cerl()], cerl()) -> c_try().
+
+c_try(Expr, Vs, Body, Evs, Handler) ->
+ #c_try{arg = Expr, vars = Vs, body = Body,
+ evars = Evs, handler = Handler}.
+
+
+%% @spec ann_c_try(As::[term()], Expression::cerl(),
+%% Variables::[cerl()], Body::cerl(),
+%% EVars::[cerl()], Handler::cerl()) -> cerl()
+%% @see c_try/3
+
+-spec ann_c_try([term()], cerl(), [cerl()], cerl(), [cerl()], cerl()) ->
+ c_try().
+
+ann_c_try(As, Expr, Vs, Body, Evs, Handler) ->
+ #c_try{arg = Expr, vars = Vs, body = Body,
+ evars = Evs, handler = Handler, anno = As}.
+
+
+%% @spec update_c_try(Old::cerl(), Expression::cerl(),
+%% Variables::[cerl()], Body::cerl(),
+%% EVars::[cerl()], Handler::cerl()) -> cerl()
+%% @see c_try/3
+
+-spec update_c_try(c_try(), cerl(), [cerl()], cerl(), [cerl()], cerl()) ->
+ c_try().
+
+update_c_try(Node, Expr, Vs, Body, Evs, Handler) ->
+ #c_try{arg = Expr, vars = Vs, body = Body,
+ evars = Evs, handler = Handler, anno = get_ann(Node)}.
+
+
+%% @spec is_c_try(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% try-expression, otherwise <code>false</code>.
+%%
+%% @see c_try/3
+
+-spec is_c_try(cerl()) -> boolean().
+
+is_c_try(#c_try{}) ->
+ true;
+is_c_try(_) ->
+ false.
+
+
+%% @spec try_arg(cerl()) -> cerl()
+%%
+%% @doc Returns the expression subtree of an abstract try-expression.
+%%
+%% @see c_try/3
+
+-spec try_arg(c_try()) -> cerl().
+
+try_arg(Node) ->
+ Node#c_try.arg.
+
+
+%% @spec try_vars(cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of success variable subtrees of an abstract
+%% try-expression.
+%%
+%% @see c_try/3
+
+-spec try_vars(c_try()) -> [cerl()].
+
+try_vars(Node) ->
+ Node#c_try.vars.
+
+
+%% @spec try_body(cerl()) -> cerl()
+%%
+%% @doc Returns the success body subtree of an abstract try-expression.
+%%
+%% @see c_try/3
+
+-spec try_body(c_try()) -> cerl().
+
+try_body(Node) ->
+ Node#c_try.body.
+
+
+%% @spec try_evars(cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of exception variable subtrees of an abstract
+%% try-expression.
+%%
+%% @see c_try/3
+
+-spec try_evars(c_try()) -> [cerl()].
+
+try_evars(Node) ->
+ Node#c_try.evars.
+
+
+%% @spec try_handler(cerl()) -> cerl()
+%%
+%% @doc Returns the exception body subtree of an abstract
+%% try-expression.
+%%
+%% @see c_try/3
+
+-spec try_handler(c_try()) -> cerl().
+
+try_handler(Node) ->
+ Node#c_try.handler.
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec c_catch(Body::cerl()) -> cerl()
+%%
+%% @doc Creates an abstract catch-expression. The result represents
+%% "<code>catch <em>Body</em></code>".
+%%
+%% <p>Note: catch-expressions can be rewritten as try-expressions, and
+%% will eventually be removed from Core Erlang.</p>
+%%
+%% @see ann_c_catch/2
+%% @see update_c_catch/2
+%% @see is_c_catch/1
+%% @see catch_body/1
+%% @see c_try/3
+
+-spec c_catch(cerl()) -> c_catch().
+
+c_catch(Body) ->
+ #c_catch{body = Body}.
+
+
+%% @spec ann_c_catch(As::[term()], Body::cerl()) -> cerl()
+%% @see c_catch/1
+
+-spec ann_c_catch([term()], cerl()) -> c_catch().
+
+ann_c_catch(As, Body) ->
+ #c_catch{body = Body, anno = As}.
+
+
+%% @spec update_c_catch(Old::cerl(), Body::cerl()) -> cerl()
+%% @see c_catch/1
+
+-spec update_c_catch(c_catch(), cerl()) -> c_catch().
+
+update_c_catch(Node, Body) ->
+ #c_catch{body = Body, anno = get_ann(Node)}.
+
+
+%% @spec is_c_catch(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> is an abstract
+%% catch-expression, otherwise <code>false</code>.
+%%
+%% @see c_catch/1
+
+-spec is_c_catch(cerl()) -> boolean().
+
+is_c_catch(#c_catch{}) ->
+ true;
+is_c_catch(_) ->
+ false.
+
+
+%% @spec catch_body(Node::cerl()) -> cerl()
+%%
+%% @doc Returns the body subtree of an abstract catch-expression.
+%%
+%% @see c_catch/1
+
+-spec catch_body(c_catch()) -> cerl().
+
+catch_body(Node) ->
+ Node#c_catch.body.
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec to_records(Tree::cerl()) -> record(record_types())
+%%
+%% @doc Translates an abstract syntax tree to a corresponding explicit
+%% record representation. The records are defined in the file
+%% "<code>cerl.hrl</code>".
+%%
+%% @see type/1
+%% @see from_records/1
+
+-spec to_records(cerl()) -> cerl().
+
+to_records(Node) ->
+ Node.
+
+%% @spec from_records(Tree::record(record_types())) -> cerl()
+%%
+%% record_types() = c_alias | c_apply | c_call | c_case | c_catch |
+%% c_clause | c_cons | c_fun | c_let |
+%% c_letrec | c_lit | c_module | c_primop |
+%% c_receive | c_seq | c_try | c_tuple |
+%% c_values | c_var
+%%
+%% @doc Translates an explicit record representation to a
+%% corresponding abstract syntax tree. The records are defined in the
+%% file "<code>core_parse.hrl</code>".
+%%
+%% @see type/1
+%% @see to_records/1
+
+-spec from_records(cerl()) -> cerl().
+
+from_records(Node) ->
+ Node.
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec is_data(Node::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if <code>Node</code> represents a
+%% data constructor, otherwise <code>false</code>. Data constructors
+%% are cons cells, tuples, and atomic literals.
+%%
+%% @see data_type/1
+%% @see data_es/1
+%% @see data_arity/1
+
+-spec is_data(cerl()) -> boolean().
+
+is_data(#c_literal{}) ->
+ true;
+is_data(#c_cons{}) ->
+ true;
+is_data(#c_tuple{}) ->
+ true;
+is_data(_) ->
+ false.
+
+
+%% @spec data_type(Node::cerl()) -> dtype()
+%%
+%% dtype() = cons | tuple | {atomic, Value}
+%% Value = integer() | float() | atom() | []
+%%
+%% @doc Returns a type descriptor for a data constructor
+%% node. (Cf. <code>is_data/1</code>.) This is mainly useful for
+%% comparing types and for constructing new nodes of the same type
+%% (cf. <code>make_data/2</code>). If <code>Node</code> represents an
+%% integer, floating-point number, atom or empty list, the result is
+%% <code>{atomic, Value}</code>, where <code>Value</code> is the value
+%% of <code>concrete(Node)</code>, otherwise the result is either
+%% <code>cons</code> or <code>tuple</code>.
+%%
+%% <p>Type descriptors can be compared for equality or order (in the
+%% Erlang term order), but remember that floating-point values should
+%% in general never be tested for equality.</p>
+%%
+%% @see is_data/1
+%% @see make_data/2
+%% @see type/1
+%% @see concrete/1
+
+-type value() :: integer() | float() | atom() | [].
+-type dtype() :: 'cons' | 'tuple' | {'atomic', value()}.
+-type c_lct() :: c_literal() | c_cons() | c_tuple().
+
+-spec data_type(c_lct()) -> dtype().
+
+data_type(#c_literal{val = V}) ->
+ case V of
+ [_ | _] ->
+ cons;
+ _ when is_tuple(V) ->
+ tuple;
+ _ ->
+ {atomic, V}
+ end;
+data_type(#c_cons{}) ->
+ cons;
+data_type(#c_tuple{}) ->
+ tuple.
+
+
+%% @spec data_es(Node::cerl()) -> [cerl()]
+%%
+%% @doc Returns the list of subtrees of a data constructor node. If
+%% the arity of the constructor is zero, the result is the empty list.
+%%
+%% <p>Note: if <code>data_type(Node)</code> is <code>cons</code>, the
+%% number of subtrees is exactly two. If <code>data_type(Node)</code>
+%% is <code>{atomic, Value}</code>, the number of subtrees is
+%% zero.</p>
+%%
+%% @see is_data/1
+%% @see data_type/1
+%% @see data_arity/1
+%% @see make_data/2
+
+-spec data_es(c_lct()) -> [cerl()].
+
+data_es(#c_literal{val = V}) ->
+ case V of
+ [Head | Tail] ->
+ [#c_literal{val = Head}, #c_literal{val = Tail}];
+ _ when is_tuple(V) ->
+ make_lit_list(tuple_to_list(V));
+ _ ->
+ []
+ end;
+data_es(#c_cons{hd = H, tl = T}) ->
+ [H, T];
+data_es(#c_tuple{es = Es}) ->
+ Es.
+
+
+%% @spec data_arity(Node::cerl()) -> integer()
+%%
+%% @doc Returns the number of subtrees of a data constructor
+%% node. This is equivalent to <code>length(data_es(Node))</code>, but
+%% potentially more efficient.
+%%
+%% @see is_data/1
+%% @see data_es/1
+
+-spec data_arity(c_lct()) -> non_neg_integer().
+
+data_arity(#c_literal{val = V}) ->
+ case V of
+ [_ | _] ->
+ 2;
+ _ when is_tuple(V) ->
+ tuple_size(V);
+ _ ->
+ 0
+ end;
+data_arity(#c_cons{}) ->
+ 2;
+data_arity(#c_tuple{es = Es}) ->
+ length(Es).
+
+
+%% @spec make_data(Type::dtype(), Elements::[cerl()]) -> cerl()
+%%
+%% @doc Creates a data constructor node with the specified type and
+%% subtrees. (Cf. <code>data_type/1</code>.) An exception is thrown
+%% if the length of <code>Elements</code> is invalid for the given
+%% <code>Type</code>; see <code>data_es/1</code> for arity constraints
+%% on constructor types.
+%%
+%% @see data_type/1
+%% @see data_es/1
+%% @see ann_make_data/3
+%% @see update_data/3
+%% @see make_data_skel/2
+
+-spec make_data(dtype(), [cerl()]) -> c_lct().
+
+make_data(CType, Es) ->
+ ann_make_data([], CType, Es).
+
+
+%% @spec ann_make_data(As::[term()], Type::dtype(),
+%% Elements::[cerl()]) -> cerl()
+%% @see make_data/2
+
+-spec ann_make_data([term()], dtype(), [cerl()]) -> c_lct().
+
+ann_make_data(As, {atomic, V}, []) -> #c_literal{val = V, anno = As};
+ann_make_data(As, cons, [H, T]) -> ann_c_cons(As, H, T);
+ann_make_data(As, tuple, Es) -> ann_c_tuple(As, Es).
+
+
+%% @spec update_data(Old::cerl(), Type::dtype(),
+%% Elements::[cerl()]) -> cerl()
+%% @see make_data/2
+
+-spec update_data(cerl(), dtype(), [cerl()]) -> c_lct().
+
+update_data(Node, CType, Es) ->
+ ann_make_data(get_ann(Node), CType, Es).
+
+
+%% @spec make_data_skel(Type::dtype(), Elements::[cerl()]) -> cerl()
+%%
+%% @doc Like <code>make_data/2</code>, but analogous to
+%% <code>c_tuple_skel/1</code> and <code>c_cons_skel/2</code>.
+%%
+%% @see ann_make_data_skel/3
+%% @see update_data_skel/3
+%% @see make_data/2
+%% @see c_tuple_skel/1
+%% @see c_cons_skel/2
+
+-spec make_data_skel(dtype(), [cerl()]) -> c_lct().
+
+make_data_skel(CType, Es) ->
+ ann_make_data_skel([], CType, Es).
+
+
+%% @spec ann_make_data_skel(As::[term()], Type::dtype(),
+%% Elements::[cerl()]) -> cerl()
+%% @see make_data_skel/2
+
+-spec ann_make_data_skel([term()], dtype(), [cerl()]) -> c_lct().
+
+ann_make_data_skel(As, {atomic, V}, []) -> #c_literal{val = V, anno = As};
+ann_make_data_skel(As, cons, [H, T]) -> ann_c_cons_skel(As, H, T);
+ann_make_data_skel(As, tuple, Es) -> ann_c_tuple_skel(As, Es).
+
+
+%% @spec update_data_skel(Old::cerl(), Type::dtype(),
+%% Elements::[cerl()]) -> cerl()
+%% @see make_data_skel/2
+
+-spec update_data_skel(cerl(), dtype(), [cerl()]) -> c_lct().
+
+update_data_skel(Node, CType, Es) ->
+ ann_make_data_skel(get_ann(Node), CType, Es).
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec subtrees(Node::cerl()) -> [[cerl()]]
+%%
+%% @doc Returns the grouped list of all subtrees of a node. If
+%% <code>Node</code> is a leaf node (cf. <code>is_leaf/1</code>), this
+%% is the empty list, otherwise the result is always a nonempty list,
+%% containing the lists of subtrees of <code>Node</code>, in
+%% left-to-right order as they occur in the printed program text, and
+%% grouped by category. Often, each group contains only a single
+%% subtree.
+%%
+%% <p>Depending on the type of <code>Node</code>, the size of some
+%% groups may be variable (e.g., the group consisting of all the
+%% elements of a tuple), while others always contain the same number
+%% of elements - usually exactly one (e.g., the group containing the
+%% argument expression of a case-expression). Note, however, that the
+%% exact structure of the returned list (for a given node type) should
+%% in general not be depended upon, since it might be subject to
+%% change without notice.</p>
+%%
+%% <p>The function <code>subtrees/1</code> and the constructor functions
+%% <code>make_tree/2</code> and <code>update_tree/2</code> can be a
+%% great help if one wants to traverse a syntax tree, visiting all its
+%% subtrees, but treat nodes of the tree in a uniform way in most or all
+%% cases. Using these functions makes this simple, and also assures that
+%% your code is not overly sensitive to extensions of the syntax tree
+%% data type, because any node types not explicitly handled by your code
+%% can be left to a default case.</p>
+%%
+%% <p>For example:
+%% <pre>
+%% postorder(F, Tree) ->
+%% F(case subtrees(Tree) of
+%% [] -> Tree;
+%% List -> update_tree(Tree,
+%% [[postorder(F, Subtree)
+%% || Subtree &lt;- Group]
+%% || Group &lt;- List])
+%% end).
+%% </pre>
+%% maps the function <code>F</code> on <code>Tree</code> and all its
+%% subtrees, doing a post-order traversal of the syntax tree. (Note
+%% the use of <code>update_tree/2</code> to preserve annotations.) For
+%% a simple function like:
+%% <pre>
+%% f(Node) ->
+%% case type(Node) of
+%% atom -> atom("a_" ++ atom_name(Node));
+%% _ -> Node
+%% end.
+%% </pre>
+%% the call <code>postorder(fun f/1, Tree)</code> will yield a new
+%% representation of <code>Tree</code> in which all atom names have
+%% been extended with the prefix "a_", but nothing else (including
+%% annotations) has been changed.</p>
+%%
+%% @see is_leaf/1
+%% @see make_tree/2
+%% @see update_tree/2
+
+-spec subtrees(cerl()) -> [[cerl()]].
+
+subtrees(T) ->
+ case is_leaf(T) of
+ true ->
+ [];
+ false ->
+ case type(T) of
+ values ->
+ [values_es(T)];
+ binary ->
+ [binary_segments(T)];
+ bitstr ->
+ [[bitstr_val(T)], [bitstr_size(T)],
+ [bitstr_unit(T)], [bitstr_type(T)],
+ [bitstr_flags(T)]];
+ cons ->
+ [[cons_hd(T)], [cons_tl(T)]];
+ tuple ->
+ [tuple_es(T)];
+ 'let' ->
+ [let_vars(T), [let_arg(T)], [let_body(T)]];
+ seq ->
+ [[seq_arg(T)], [seq_body(T)]];
+ apply ->
+ [[apply_op(T)], apply_args(T)];
+ call ->
+ [[call_module(T)], [call_name(T)],
+ call_args(T)];
+ primop ->
+ [[primop_name(T)], primop_args(T)];
+ 'case' ->
+ [[case_arg(T)], case_clauses(T)];
+ clause ->
+ [clause_pats(T), [clause_guard(T)],
+ [clause_body(T)]];
+ alias ->
+ [[alias_var(T)], [alias_pat(T)]];
+ 'fun' ->
+ [fun_vars(T), [fun_body(T)]];
+ 'receive' ->
+ [receive_clauses(T), [receive_timeout(T)],
+ [receive_action(T)]];
+ 'try' ->
+ [[try_arg(T)], try_vars(T), [try_body(T)],
+ try_evars(T), [try_handler(T)]];
+ 'catch' ->
+ [[catch_body(T)]];
+ letrec ->
+ Es = unfold_tuples(letrec_defs(T)),
+ [Es, [letrec_body(T)]];
+ module ->
+ As = unfold_tuples(module_attrs(T)),
+ Es = unfold_tuples(module_defs(T)),
+ [[module_name(T)], module_exports(T), As, Es]
+ end
+ end.
+
+
+%% @spec update_tree(Old::cerl(), Groups::[[cerl()]]) -> cerl()
+%%
+%% @doc Creates a syntax tree with the given subtrees, and the same
+%% type and annotations as the <code>Old</code> node. This is
+%% equivalent to <code>ann_make_tree(get_ann(Node), type(Node),
+%% Groups)</code>, but potentially more efficient.
+%%
+%% @see update_tree/3
+%% @see ann_make_tree/3
+%% @see get_ann/1
+%% @see type/1
+
+-spec update_tree(cerl(), [[cerl()],...]) -> cerl().
+
+update_tree(Node, Gs) ->
+ ann_make_tree(get_ann(Node), type(Node), Gs).
+
+
+%% @spec update_tree(Old::cerl(), Type::ctype(), Groups::[[cerl()]]) ->
+%% cerl()
+%%
+%% @doc Creates a syntax tree with the given type and subtrees, and
+%% the same annotations as the <code>Old</code> node. This is
+%% equivalent to <code>ann_make_tree(get_ann(Node), Type,
+%% Groups)</code>, but potentially more efficient.
+%%
+%% @see update_tree/2
+%% @see ann_make_tree/3
+%% @see get_ann/1
+
+-spec update_tree(cerl(), ctype(), [[cerl()],...]) -> cerl().
+
+update_tree(Node, Type, Gs) ->
+ ann_make_tree(get_ann(Node), Type, Gs).
+
+
+%% @spec make_tree(Type::ctype(), Groups::[[cerl()]]) -> cerl()
+%%
+%% @doc Creates a syntax tree with the given type and subtrees.
+%% <code>Type</code> must be a node type name
+%% (cf. <code>type/1</code>) that does not denote a leaf node type
+%% (cf. <code>is_leaf/1</code>). <code>Groups</code> must be a
+%% <em>nonempty</em> list of groups of syntax trees, representing the
+%% subtrees of a node of the given type, in left-to-right order as
+%% they would occur in the printed program text, grouped by category
+%% as done by <code>subtrees/1</code>.
+%%
+%% <p>The result of <code>ann_make_tree(get_ann(Node), type(Node),
+%% subtrees(Node))</code> (cf. <code>update_tree/2</code>) represents
+%% the same source code text as the original <code>Node</code>,
+%% assuming that <code>subtrees(Node)</code> yields a nonempty
+%% list. However, it does not necessarily have the exact same data
+%% representation as <code>Node</code>.</p>
+%%
+%% @see ann_make_tree/3
+%% @see type/1
+%% @see is_leaf/1
+%% @see subtrees/1
+%% @see update_tree/2
+
+-spec make_tree(ctype(), [[cerl()],...]) -> cerl().
+
+make_tree(Type, Gs) ->
+ ann_make_tree([], Type, Gs).
+
+
+%% @spec ann_make_tree(As::[term()], Type::ctype(),
+%% Groups::[[cerl()]]) -> cerl()
+%%
+%% @doc Creates a syntax tree with the given annotations, type and
+%% subtrees. See <code>make_tree/2</code> for details.
+%%
+%% @see make_tree/2
+
+-spec ann_make_tree([term()], ctype(), [[cerl()],...]) -> cerl().
+
+ann_make_tree(As, values, [Es]) -> ann_c_values(As, Es);
+ann_make_tree(As, binary, [Ss]) -> ann_c_binary(As, Ss);
+ann_make_tree(As, bitstr, [[V],[S],[U],[T],[Fs]]) ->
+ ann_c_bitstr(As, V, S, U, T, Fs);
+ann_make_tree(As, cons, [[H], [T]]) -> ann_c_cons(As, H, T);
+ann_make_tree(As, tuple, [Es]) -> ann_c_tuple(As, Es);
+ann_make_tree(As, 'let', [Vs, [A], [B]]) -> ann_c_let(As, Vs, A, B);
+ann_make_tree(As, seq, [[A], [B]]) -> ann_c_seq(As, A, B);
+ann_make_tree(As, apply, [[Op], Es]) -> ann_c_apply(As, Op, Es);
+ann_make_tree(As, call, [[M], [N], Es]) -> ann_c_call(As, M, N, Es);
+ann_make_tree(As, primop, [[N], Es]) -> ann_c_primop(As, N, Es);
+ann_make_tree(As, 'case', [[A], Cs]) -> ann_c_case(As, A, Cs);
+ann_make_tree(As, clause, [Ps, [G], [B]]) -> ann_c_clause(As, Ps, G, B);
+ann_make_tree(As, alias, [[V], [P]]) -> ann_c_alias(As, V, P);
+ann_make_tree(As, 'fun', [Vs, [B]]) -> ann_c_fun(As, Vs, B);
+ann_make_tree(As, 'receive', [Cs, [T], [A]]) ->
+ ann_c_receive(As, Cs, T, A);
+ann_make_tree(As, 'try', [[E], Vs, [B], Evs, [H]]) ->
+ ann_c_try(As, E, Vs, B, Evs, H);
+ann_make_tree(As, 'catch', [[B]]) -> ann_c_catch(As, B);
+ann_make_tree(As, letrec, [Es, [B]]) ->
+ ann_c_letrec(As, fold_tuples(Es), B);
+ann_make_tree(As, module, [[N], Xs, Es, Ds]) ->
+ ann_c_module(As, N, Xs, fold_tuples(Es), fold_tuples(Ds)).
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec meta(Tree::cerl()) -> cerl()
+%%
+%% @doc Creates a meta-representation of a syntax tree. The result
+%% represents an Erlang expression "<code><em>MetaTree</em></code>"
+%% which, if evaluated, will yield a new syntax tree representing the
+%% same source code text as <code>Tree</code> (although the actual
+%% data representation may be different). The expression represented
+%% by <code>MetaTree</code> is <em>implementation independent</em>
+%% with regard to the data structures used by the abstract syntax tree
+%% implementation.
+%%
+%% <p>Any node in <code>Tree</code> whose node type is
+%% <code>var</code> (cf. <code>type/1</code>), and whose list of
+%% annotations (cf. <code>get_ann/1</code>) contains the atom
+%% <code>meta_var</code>, will remain unchanged in the resulting tree,
+%% except that exactly one occurrence of <code>meta_var</code> is
+%% removed from its annotation list.</p>
+%%
+%% <p>The main use of the function <code>meta/1</code> is to transform
+%% a data structure <code>Tree</code>, which represents a piece of
+%% program code, into a form that is <em>representation independent
+%% when printed</em>. E.g., suppose <code>Tree</code> represents a
+%% variable named "V". Then (assuming a function <code>print/1</code>
+%% for printing syntax trees), evaluating
+%% <code>print(abstract(Tree))</code> - simply using
+%% <code>abstract/1</code> to map the actual data structure onto a
+%% syntax tree representation - would output a string that might look
+%% something like "<code>{var, ..., 'V'}</code>", which is obviously
+%% dependent on the implementation of the abstract syntax trees. This
+%% could e.g. be useful for caching a syntax tree in a file. However,
+%% in some situations like in a program generator generator (with two
+%% "generator"), it may be unacceptable. Using
+%% <code>print(meta(Tree))</code> instead would output a
+%% <em>representation independent</em> syntax tree generating
+%% expression; in the above case, something like
+%% "<code>cerl:c_var('V')</code>".</p>
+%%
+%% <p>The implementation tries to generate compact code with respect
+%% to literals and lists.</p>
+%%
+%% @see abstract/1
+%% @see type/1
+%% @see get_ann/1
+
+-spec meta(cerl()) -> cerl().
+
+meta(Node) ->
+ %% First of all we check for metavariables:
+ case type(Node) of
+ var ->
+ case lists:member(meta_var, get_ann(Node)) of
+ false ->
+ meta_0(var, Node);
+ true ->
+ %% A meta-variable: remove the first found
+ %% 'meta_var' annotation, but otherwise leave
+ %% the node unchanged.
+ set_ann(Node, lists:delete(meta_var, get_ann(Node)))
+ end;
+ Type ->
+ meta_0(Type, Node)
+ end.
+
+meta_0(Type, Node) ->
+ case get_ann(Node) of
+ [] ->
+ meta_1(Type, Node);
+ As ->
+ meta_call(set_ann, [meta_1(Type, Node), abstract(As)])
+ end.
+
+meta_1(literal, Node) ->
+ %% We handle atomic literals separately, to get a bit
+ %% more compact code. For the rest, we use 'abstract'.
+ case concrete(Node) of
+ V when is_atom(V) ->
+ meta_call(c_atom, [Node]);
+ V when is_integer(V) ->
+ meta_call(c_int, [Node]);
+ V when is_float(V) ->
+ meta_call(c_float, [Node]);
+ [] ->
+ meta_call(c_nil, []);
+ _ ->
+ meta_call(abstract, [Node])
+ end;
+meta_1(var, Node) ->
+ %% A normal variable or function name.
+ meta_call(c_var, [abstract(var_name(Node))]);
+meta_1(values, Node) ->
+ meta_call(c_values,
+ [make_list(meta_list(values_es(Node)))]);
+meta_1(binary, Node) ->
+ meta_call(c_binary,
+ [make_list(meta_list(binary_segments(Node)))]);
+meta_1(bitstr, Node) ->
+ meta_call(c_bitstr,
+ [meta(bitstr_val(Node)),
+ meta(bitstr_size(Node)),
+ meta(bitstr_unit(Node)),
+ meta(bitstr_type(Node)),
+ meta(bitstr_flags(Node))]);
+meta_1(cons, Node) ->
+ %% The list is split up if some sublist has annotatations. If
+ %% we get exactly one element, we generate a 'c_cons' call
+ %% instead of 'make_list' to reconstruct the node.
+ case split_list(Node) of
+ {[H], none} ->
+ meta_call(c_cons, [meta(H), meta(c_nil())]);
+ {[H], Node1} ->
+ meta_call(c_cons, [meta(H), meta(Node1)]);
+ {L, none} ->
+ meta_call(make_list, [make_list(meta_list(L))]);
+ {L, Node1} ->
+ meta_call(make_list,
+ [make_list(meta_list(L)), meta(Node1)])
+ end;
+meta_1(tuple, Node) ->
+ meta_call(c_tuple,
+ [make_list(meta_list(tuple_es(Node)))]);
+meta_1('let', Node) ->
+ meta_call(c_let,
+ [make_list(meta_list(let_vars(Node))),
+ meta(let_arg(Node)), meta(let_body(Node))]);
+meta_1(seq, Node) ->
+ meta_call(c_seq,
+ [meta(seq_arg(Node)), meta(seq_body(Node))]);
+meta_1(apply, Node) ->
+ meta_call(c_apply,
+ [meta(apply_op(Node)),
+ make_list(meta_list(apply_args(Node)))]);
+meta_1(call, Node) ->
+ meta_call(c_call,
+ [meta(call_module(Node)), meta(call_name(Node)),
+ make_list(meta_list(call_args(Node)))]);
+meta_1(primop, Node) ->
+ meta_call(c_primop,
+ [meta(primop_name(Node)),
+ make_list(meta_list(primop_args(Node)))]);
+meta_1('case', Node) ->
+ meta_call(c_case,
+ [meta(case_arg(Node)),
+ make_list(meta_list(case_clauses(Node)))]);
+meta_1(clause, Node) ->
+ meta_call(c_clause,
+ [make_list(meta_list(clause_pats(Node))),
+ meta(clause_guard(Node)),
+ meta(clause_body(Node))]);
+meta_1(alias, Node) ->
+ meta_call(c_alias,
+ [meta(alias_var(Node)), meta(alias_pat(Node))]);
+meta_1('fun', Node) ->
+ meta_call(c_fun,
+ [make_list(meta_list(fun_vars(Node))),
+ meta(fun_body(Node))]);
+meta_1('receive', Node) ->
+ meta_call(c_receive,
+ [make_list(meta_list(receive_clauses(Node))),
+ meta(receive_timeout(Node)),
+ meta(receive_action(Node))]);
+meta_1('try', Node) ->
+ meta_call(c_try,
+ [meta(try_arg(Node)),
+ make_list(meta_list(try_vars(Node))),
+ meta(try_body(Node)),
+ make_list(meta_list(try_evars(Node))),
+ meta(try_handler(Node))]);
+meta_1('catch', Node) ->
+ meta_call(c_catch, [meta(catch_body(Node))]);
+meta_1(letrec, Node) ->
+ meta_call(c_letrec,
+ [make_list([c_tuple([meta(N), meta(F)])
+ || {N, F} <- letrec_defs(Node)]),
+ meta(letrec_body(Node))]);
+meta_1(module, Node) ->
+ meta_call(c_module,
+ [meta(module_name(Node)),
+ make_list(meta_list(module_exports(Node))),
+ make_list([c_tuple([meta(A), meta(V)])
+ || {A, V} <- module_attrs(Node)]),
+ make_list([c_tuple([meta(N), meta(F)])
+ || {N, F} <- module_defs(Node)])]).
+
+meta_call(F, As) ->
+ c_call(c_atom(?MODULE), c_atom(F), As).
+
+meta_list([T | Ts]) ->
+ [meta(T) | meta_list(Ts)];
+meta_list([]) ->
+ [].
+
+split_list(Node) ->
+ split_list(set_ann(Node, []), []).
+
+split_list(Node, L) ->
+ A = get_ann(Node),
+ case type(Node) of
+ cons when A =:= [] ->
+ split_list(cons_tl(Node), [cons_hd(Node) | L]);
+ nil when A =:= [] ->
+ {lists:reverse(L), none};
+ _ ->
+ {lists:reverse(L), Node}
+ end.
+
+
+%% ---------------------------------------------------------------------
+
+%% General utilities
+
+is_lit_list([#c_literal{} | Es]) ->
+ is_lit_list(Es);
+is_lit_list([_ | _]) ->
+ false;
+is_lit_list([]) ->
+ true.
+
+lit_list_vals([#c_literal{val = V} | Es]) ->
+ [V | lit_list_vals(Es)];
+lit_list_vals([]) ->
+ [].
+
+-spec make_lit_list([_]) -> [#c_literal{}]. % XXX: cerl() instead of _ ?
+
+make_lit_list([V | Vs]) ->
+ [#c_literal{val = V} | make_lit_list(Vs)];
+make_lit_list([]) ->
+ [].
+
+%% The following tests are the same as done by 'io_lib:char_list' and
+%% 'io_lib:printable_list', respectively, but for a single character.
+
+is_char_value(V) when V >= $\000, V =< $\377 -> true;
+is_char_value(_) -> false.
+
+is_print_char_value(V) when V >= $\040, V =< $\176 -> true;
+is_print_char_value(V) when V >= $\240, V =< $\377 -> true;
+is_print_char_value(V) when V =:= $\b -> true;
+is_print_char_value(V) when V =:= $\d -> true;
+is_print_char_value(V) when V =:= $\e -> true;
+is_print_char_value(V) when V =:= $\f -> true;
+is_print_char_value(V) when V =:= $\n -> true;
+is_print_char_value(V) when V =:= $\r -> true;
+is_print_char_value(V) when V =:= $\s -> true;
+is_print_char_value(V) when V =:= $\t -> true;
+is_print_char_value(V) when V =:= $\v -> true;
+is_print_char_value(V) when V =:= $\" -> true;
+is_print_char_value(V) when V =:= $\' -> true;
+is_print_char_value(V) when V =:= $\\ -> true;
+is_print_char_value(_) -> false.
+
+is_char_list([V | Vs]) when is_integer(V) ->
+ is_char_value(V) andalso is_char_list(Vs);
+is_char_list([]) ->
+ true;
+is_char_list(_) ->
+ false.
+
+is_print_char_list([V | Vs]) when is_integer(V) ->
+ is_print_char_value(V) andalso is_print_char_list(Vs);
+is_print_char_list([]) ->
+ true;
+is_print_char_list(_) ->
+ false.
+
+unfold_tuples([{X, Y} | Ps]) ->
+ [X, Y | unfold_tuples(Ps)];
+unfold_tuples([]) ->
+ [].
+
+fold_tuples([X, Y | Es]) ->
+ [{X, Y} | fold_tuples(Es)];
+fold_tuples([]) ->
+ [].
diff --git a/lib/compiler/src/cerl_clauses.erl b/lib/compiler/src/cerl_clauses.erl
new file mode 100644
index 0000000000..5f111a5e05
--- /dev/null
+++ b/lib/compiler/src/cerl_clauses.erl
@@ -0,0 +1,428 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2001-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+
+%% @doc Utility functions for Core Erlang case/receive clauses.
+%%
+%% <p>Syntax trees are defined in the module <a
+%% href=""><code>cerl</code></a>.</p>
+%%
+%% @type cerl() = cerl:cerl()
+
+-module(cerl_clauses).
+
+-export([any_catchall/1, eval_guard/1, is_catchall/1, match/2,
+ match_list/2, reduce/1, reduce/2]).
+
+-import(cerl, [alias_pat/1, alias_var/1, data_arity/1, data_es/1,
+ data_type/1, clause_guard/1, clause_pats/1, concrete/1,
+ is_data/1, is_c_var/1, let_body/1, letrec_body/1,
+ seq_body/1, try_arg/1, type/1, values_es/1]).
+
+%% ---------------------------------------------------------------------
+
+%% @spec is_catchall(Clause::cerl()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if an abstract clause is a
+%% catch-all, otherwise <code>false</code>. A clause is a catch-all if
+%% all its patterns are variables, and its guard expression always
+%% evaluates to <code>true</code>; cf. <code>eval_guard/1</code>.
+%%
+%% <p>Note: <code>Clause</code> must have type
+%% <code>clause</code>.</p>
+%%
+%% @see eval_guard/1
+%% @see any_catchall/1
+
+-spec is_catchall(cerl:c_clause()) -> boolean().
+
+is_catchall(C) ->
+ case all_vars(clause_pats(C)) of
+ true ->
+ case eval_guard(clause_guard(C)) of
+ {value, true} ->
+ true;
+ _ ->
+ false
+ end;
+ false ->
+ false
+ end.
+
+all_vars([C | Cs]) ->
+ case is_c_var(C) of
+ true ->
+ all_vars(Cs);
+ false ->
+ false
+ end;
+all_vars([]) ->
+ true.
+
+
+%% @spec any_catchall(Clauses::[cerl()]) -> boolean()
+%%
+%% @doc Returns <code>true</code> if any of the abstract clauses in
+%% the list is a catch-all, otherwise <code>false</code>. See
+%% <code>is_catchall/1</code> for details.
+%%
+%% <p>Note: each node in <code>Clauses</code> must have type
+%% <code>clause</code>.</p>
+%%
+%% @see is_catchall/1
+
+-spec any_catchall([cerl:cerl()]) -> boolean().
+
+any_catchall([C | Cs]) ->
+ case is_catchall(C) of
+ true ->
+ true;
+ false ->
+ any_catchall(Cs)
+ end;
+any_catchall([]) ->
+ false.
+
+
+%% @spec eval_guard(Expr::cerl()) -> none | {value, term()}
+%%
+%% @doc Tries to reduce a guard expression to a single constant value,
+%% if possible. The returned value is <code>{value, Term}</code> if the
+%% guard expression <code>Expr</code> always yields the constant value
+%% <code>Term</code>, and is otherwise <code>none</code>.
+%%
+%% <p>Note that although guard expressions should only yield boolean
+%% values, this function does not guarantee that <code>Term</code> is
+%% either <code>true</code> or <code>false</code>. Also note that only
+%% simple constructs like let-expressions are examined recursively;
+%% general constant folding is not performed.</p>
+%%
+%% @see is_catchall/1
+
+%% This function could possibly be improved further, but constant
+%% folding should in general be performed elsewhere.
+
+-spec eval_guard(cerl:cerl()) -> 'none' | {'value', term()}.
+
+eval_guard(E) ->
+ case type(E) of
+ literal ->
+ {value, concrete(E)};
+ values ->
+ case values_es(E) of
+ [E1] ->
+ eval_guard(E1);
+ _ ->
+ none
+ end;
+ 'try' ->
+ eval_guard(try_arg(E));
+ seq ->
+ eval_guard(seq_body(E));
+ 'let' ->
+ eval_guard(let_body(E));
+ 'letrec' ->
+ eval_guard(letrec_body(E));
+ _ ->
+ none
+ end.
+
+
+%% ---------------------------------------------------------------------
+
+-type bindings() :: [{cerl:cerl(), cerl:cerl()}].
+
+%% @spec reduce(Clauses) -> {true, {Clause, Bindings}}
+%% | {false, Clauses}
+%%
+%% @equiv reduce(Cs, [])
+
+-spec reduce([cerl:c_clause()]) ->
+ {'true', {cerl:c_clause(), bindings()}} | {'false', [cerl:c_clause()]}.
+
+reduce(Cs) ->
+ reduce(Cs, []).
+
+%% @spec reduce(Clauses::[Clause], Exprs::[Expr]) ->
+%% {true, {Clause, Bindings}}
+%% | {false, [Clause]}
+%%
+%% Clause = cerl()
+%% Expr = any | cerl()
+%% Bindings = [{cerl(), cerl()}]
+%%
+%% @doc Selects a single clause, if possible, or otherwise reduces the
+%% list of selectable clauses. The input is a list <code>Clauses</code>
+%% of abstract clauses (i.e., syntax trees of type <code>clause</code>),
+%% and a list of switch expressions <code>Exprs</code>. The function
+%% tries to uniquely select a single clause or discard unselectable
+%% clauses, with respect to the switch expressions. All abstract clauses
+%% in the list must have the same number of patterns. If
+%% <code>Exprs</code> is not the empty list, it must have the same
+%% length as the number of patterns in each clause; see
+%% <code>match_list/2</code> for details.
+%%
+%% <p>A clause can only be selected if its guard expression always
+%% yields the atom <code>true</code>, and a clause whose guard
+%% expression always yields the atom <code>false</code> can never be
+%% selected. Other guard expressions are considered to have unknown
+%% value; cf. <code>eval_guard/1</code>.</p>
+%%
+%% <p>If a particular clause can be selected, the function returns
+%% <code>{true, {Clause, Bindings}}</code>, where <code>Clause</code> is
+%% the selected clause and <code>Bindings</code> is a list of pairs
+%% <code>{Var, SubExpr}</code> associating the variables occurring in
+%% the patterns of <code>Clause</code> with the corresponding
+%% subexpressions in <code>Exprs</code>. The list of bindings is given
+%% in innermost-first order; see the <code>match/2</code> function for
+%% details.</p>
+%%
+%% <p>If no clause could be definitely selected, the function returns
+%% <code>{false, NewClauses}</code>, where <code>NewClauses</code> is
+%% the list of entries in <code>Clauses</code> that remain after
+%% eliminating unselectable clauses, preserving the relative order.</p>
+%%
+%% @see eval_guard/1
+%% @see match/2
+%% @see match_list/2
+
+-type expr() :: 'any' | cerl:cerl().
+
+-spec reduce([cerl:c_clause()], [expr()]) ->
+ {'true', {cerl:c_clause(), bindings()}} | {'false', [cerl:c_clause()]}.
+
+reduce(Cs, Es) ->
+ reduce(Cs, Es, []).
+
+reduce([C | Cs], Es, Cs1) ->
+ Ps = clause_pats(C),
+ case match_list(Ps, Es) of
+ none ->
+ %% Here, we know that the current clause cannot possibly be
+ %% selected, so we drop it and visit the rest.
+ reduce(Cs, Es, Cs1);
+ {false, _} ->
+ %% We are not sure if this clause might be selected, so we
+ %% save it and visit the rest.
+ reduce(Cs, Es, [C | Cs1]);
+ {true, Bs} ->
+ case eval_guard(clause_guard(C)) of
+ {value, true} when Cs1 =:= [] ->
+ %% We have a definite match - we return the residual
+ %% expression and signal that a selection has been
+ %% made. All other clauses are dropped.
+ {true, {C, Bs}};
+ {value, true} ->
+ %% Unless one of the previous clauses is selected,
+ %% this clause will definitely be, so we can drop
+ %% the rest.
+ {false, lists:reverse([C | Cs1])};
+ {value, false} ->
+ %% This clause can never be selected, since its
+ %% guard is never 'true', so we drop it.
+ reduce(Cs, Es, Cs1);
+ _ ->
+ %% We are not sure if this clause might be selected
+ %% (or might even cause a crash), so we save it and
+ %% visit the rest.
+ reduce(Cs, Es, [C | Cs1])
+ end
+ end;
+reduce([], _, Cs) ->
+ %% All clauses visited, without a complete match. Signal "not
+ %% reduced" and return the saved clauses, in the correct order.
+ {false, lists:reverse(Cs)}.
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec match(Pattern::cerl(), Expr) ->
+%% none | {true, Bindings} | {false, Bindings}
+%%
+%% Expr = any | cerl()
+%% Bindings = [{cerl(), Expr}]
+%%
+%% @doc Matches a pattern against an expression. The returned value is
+%% <code>none</code> if a match is impossible, <code>{true,
+%% Bindings}</code> if <code>Pattern</code> definitely matches
+%% <code>Expr</code>, and <code>{false, Bindings}</code> if a match is
+%% not definite, but cannot be excluded. <code>Bindings</code> is then
+%% a list of pairs <code>{Var, SubExpr}</code>, associating each
+%% variable in the pattern with either the corresponding subexpression
+%% of <code>Expr</code>, or with the atom <code>any</code> if no
+%% matching subexpression exists. (Recall that variables may not be
+%% repeated in a Core Erlang pattern.) The list of bindings is given
+%% in innermost-first order; this should only be of interest if
+%% <code>Pattern</code> contains one or more alias patterns. If the
+%% returned value is <code>{true, []}</code>, it implies that the
+%% pattern and the expression are syntactically identical.
+%%
+%% <p>Instead of a syntax tree, the atom <code>any</code> can be
+%% passed for <code>Expr</code> (or, more generally, be used for any
+%% subtree of <code>Expr</code>, in as much the abstract syntax tree
+%% implementation allows it); this means that it cannot be decided
+%% whether the pattern will match or not, and the corresponding
+%% variable bindings will all map to <code>any</code>. The typical use
+%% is for producing bindings for <code>receive</code> clauses.</p>
+%%
+%% <p>Note: Binary-syntax patterns are never structurally matched
+%% against binary-syntax expressions by this function.</p>
+%%
+%% <p>Examples:
+%% <ul>
+%% <li>Matching a pattern "<code>{X, Y}</code>" against the
+%% expression "<code>{foo, f(Z)}</code>" yields <code>{true,
+%% Bindings}</code> where <code>Bindings</code> associates
+%% "<code>X</code>" with the subtree "<code>foo</code>" and
+%% "<code>Y</code>" with the subtree "<code>f(Z)</code>".</li>
+%%
+%% <li>Matching pattern "<code>{X, {bar, Y}}</code>" against
+%% expression "<code>{foo, f(Z)}</code>" yields <code>{false,
+%% Bindings}</code> where <code>Bindings</code> associates
+%% "<code>X</code>" with the subtree "<code>foo</code>" and
+%% "<code>Y</code>" with <code>any</code> (because it is not known
+%% if "<code>{foo, Y}</code>" might match the run-time value of
+%% "<code>f(Z)</code>" or not).</li>
+%%
+%% <li>Matching pattern "<code>{foo, bar}</code>" against expression
+%% "<code>{foo, f()}</code>" yields <code>{false, []}</code>,
+%% telling us that there might be a match, but we cannot deduce any
+%% bindings.</li>
+%%
+%% <li>Matching <code>{foo, X = {bar, Y}}</code> against expression
+%% "<code>{foo, {bar, baz}}</code>" yields <code>{true,
+%% Bindings}</code> where <code>Bindings</code> associates
+%% "<code>Y</code>" with "<code>baz</code>", and "<code>X</code>"
+%% with "<code>{bar, baz}</code>".</li>
+%%
+%% <li>Matching a pattern "<code>{X, Y}</code>" against
+%% <code>any</code> yields <code>{false, Bindings}</code> where
+%% <code>Bindings</code> associates both "<code>X</code>" and
+%% "<code>Y</code>" with <code>any</code>.</li>
+%% </ul></p>
+
+-type match_ret() :: 'none' | {'true', bindings()} | {'false', bindings()}.
+
+-spec match(cerl:cerl(), expr()) -> match_ret().
+
+match(P, E) ->
+ match(P, E, []).
+
+match(P, E, Bs) ->
+ case type(P) of
+ var ->
+ %% Variables always match, since they cannot have repeated
+ %% occurrences in a pattern.
+ {true, [{P, E} | Bs]};
+ alias ->
+ %% All variables in P1 will be listed before the alias
+ %% variable in the result.
+ match(alias_pat(P), E, [{alias_var(P), E} | Bs]);
+ binary ->
+ %% The most we can do is to say "definitely no match" if a
+ %% binary pattern is matched against non-binary data.
+ if E =:= any ->
+ {false, Bs};
+ true ->
+ case is_data(E) of
+ true ->
+ none;
+ false ->
+ {false, Bs}
+ end
+ end;
+ _ ->
+ match_1(P, E, Bs)
+ end.
+
+match_1(P, E, Bs) ->
+ case is_data(P) of
+ true when E =:= any ->
+ %% If we don't know the structure of the value of E at this
+ %% point, we just match the subpatterns against 'any', and
+ %% make sure the result is a "maybe".
+ Ps = data_es(P),
+ Es = [any || _ <- Ps],
+ case match_list(Ps, Es, Bs) of
+ {_, Bs1} ->
+ {false, Bs1};
+ none ->
+ none
+ end;
+ true ->
+ %% Test if the expression represents a constructor
+ case is_data(E) of
+ true ->
+ T1 = {data_type(E), data_arity(E)},
+ T2 = {data_type(P), data_arity(P)},
+ %% Note that we must test for exact equality.
+ if T1 =:= T2 ->
+ match_list(data_es(P), data_es(E), Bs);
+ true ->
+ none
+ end;
+ false ->
+ %% We don't know the run-time structure of E, and P
+ %% is not a variable or an alias pattern, so we
+ %% match against 'any' instead.
+ match_1(P, any, Bs)
+ end;
+ false ->
+ %% Strange pattern - give up, but don't say "no match".
+ {false, Bs}
+ end.
+
+
+%% @spec match_list(Patterns::[cerl()], Exprs::[Expr]) ->
+%% none | {true, Bindings} | {false, Bindings}
+%%
+%% Expr = any | cerl()
+%% Bindings = [{cerl(), cerl()}]
+%%
+%% @doc Like <code>match/2</code>, but matching a sequence of patterns
+%% against a sequence of expressions. Passing an empty list for
+%% <code>Exprs</code> is equivalent to passing a list of
+%% <code>any</code> atoms of the same length as <code>Patterns</code>.
+%%
+%% @see match/2
+
+-spec match_list([cerl:cerl()], [expr()]) -> match_ret().
+
+match_list([], []) ->
+ {true, []}; % no patterns always match
+match_list(Ps, []) ->
+ match_list(Ps, [any || _ <- Ps], []);
+match_list(Ps, Es) ->
+ match_list(Ps, Es, []).
+
+match_list([P | Ps], [E | Es], Bs) ->
+ case match(P, E, Bs) of
+ {true, Bs1} ->
+ match_list(Ps, Es, Bs1);
+ {false, Bs1} ->
+ %% Make sure "maybe" is preserved
+ case match_list(Ps, Es, Bs1) of
+ {_, Bs2} ->
+ {false, Bs2};
+ none ->
+ none
+ end;
+ none ->
+ none
+ end;
+match_list([], [], Bs) ->
+ {true, Bs}.
diff --git a/lib/compiler/src/cerl_inline.erl b/lib/compiler/src/cerl_inline.erl
new file mode 100644
index 0000000000..191efa3032
--- /dev/null
+++ b/lib/compiler/src/cerl_inline.erl
@@ -0,0 +1,2717 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2001-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+%%
+%% Core Erlang inliner.
+
+%% =====================================================================
+%%
+%% This is an implementation of the algorithm by Waddell and Dybvig
+%% ("Fast and Effective Procedure Inlining", International Static
+%% Analysis Symposium 1997), adapted to the Core Erlang language.
+%%
+%% Instead of always renaming variables and function variables, this
+%% implementation uses the "no-shadowing strategy" of Peyton Jones and
+%% Marlow ("Secrets of the Glasgow Haskell Compiler Inliner", 1999).
+%%
+%% =====================================================================
+
+%% TODO: inline single-source-reference operands without size limit.
+
+-module(cerl_inline).
+
+-export([core_transform/2, transform/1, transform/2]).
+
+-import(cerl, [abstract/1, alias_pat/1, alias_var/1, apply_args/1,
+ apply_op/1, atom_name/1, atom_val/1, bitstr_val/1,
+ bitstr_size/1, bitstr_unit/1, bitstr_type/1,
+ bitstr_flags/1, binary_segments/1, update_c_alias/3,
+ update_c_apply/3, update_c_binary/2, update_c_bitstr/6,
+ update_c_call/4, update_c_case/3, update_c_catch/2,
+ update_c_clause/4, c_fun/2, c_int/1, c_let/3,
+ update_c_let/4, update_c_letrec/3, update_c_module/5,
+ update_c_primop/3, update_c_receive/4, update_c_seq/3,
+ c_seq/2, update_c_try/6, c_tuple/1, update_c_values/2,
+ c_values/1, c_var/1, call_args/1, call_module/1,
+ call_name/1, case_arity/1, case_arg/1, case_clauses/1,
+ catch_body/1, clause_body/1, clause_guard/1,
+ clause_pats/1, clause_vars/1, concrete/1, cons_hd/1,
+ cons_tl/1, data_arity/1, data_es/1, data_type/1,
+ fun_body/1, fun_vars/1, get_ann/1, int_val/1,
+ is_c_atom/1, is_c_cons/1, is_c_fun/1, is_c_int/1,
+ is_c_list/1, is_c_seq/1, is_c_tuple/1, is_c_var/1,
+ is_data/1, is_literal/1, is_literal_term/1, let_arg/1,
+ let_body/1, let_vars/1, letrec_body/1, letrec_defs/1,
+ list_length/1, list_elements/1, update_data/3,
+ make_list/1, make_data_skel/2, module_attrs/1,
+ module_defs/1, module_exports/1, module_name/1,
+ primop_args/1, primop_name/1, receive_action/1,
+ receive_clauses/1, receive_timeout/1, seq_arg/1,
+ seq_body/1, set_ann/2, try_arg/1, try_body/1, try_vars/1,
+ try_evars/1, try_handler/1, tuple_es/1, tuple_arity/1,
+ type/1, values_es/1, var_name/1]).
+
+-import(erlang, [max/2]).
+-import(lists, [foldl/3, foldr/3, mapfoldl/3, reverse/1]).
+
+%%
+%% Constants
+%%
+
+debug_runtime() -> false.
+debug_counters() -> false.
+
+%% Normal execution times for inlining are between 0.1 and 0.3 seconds
+%% (on the author's current equipment). The default effort limit of 150
+%% is high enough that most normal programs never hit the limit even
+%% once, and for difficult programs, it generally keeps the execution
+%% times below 2-5 seconds. Using an effort counter of 1000 will thus
+%% have no further effect on most programs, but some programs may take
+%% as much as 10 seconds or more. Effort counts larger than 2500 have
+%% never been observed even on very ill-conditioned programs.
+%%
+%% Size limits between 6 and 18 tend to actually shrink the code,
+%% because of the simplifications made possible by inlining. A limit of
+%% 16 seems to be optimal for this purpose, often shrinking the
+%% executable code by up to 10%. Size limits between 18 and 30 generally
+%% give the same code size as if no inlining was done (i.e., code
+%% duplication balances out the simplifications at these levels). A size
+%% limit between 1 and 5 tends to inline small functions and propagate
+%% constants, but does not cause much simplifications do be done, so the
+%% net effect will be a slight increase in code size. For size limits
+%% above 30, the executable code size tends to increase with about 10%
+%% per 100 units, with some variations depending on the sizes of
+%% functions in the source code.
+%%
+%% Typically, about 90% of the maximum speedup achievable is already
+%% reached using a size limit of 30, and 98% is reached at limits around
+%% 100-150; there is rarely any point in letting the code size increase
+%% by more than 10-15%. If too large functions are inlined, cache
+%% effects will slow the program down.
+
+default_effort() -> 150.
+default_size() -> 24.
+default_unroll() -> 1.
+
+%% Base costs/weights for different kinds of expressions. If these are
+%% modified, the size limits above may have to be adjusted.
+
+weight(var) -> 0; % We count no cost for variable accesses.
+weight(values) -> 0; % Value aggregates have no cost in themselves.
+weight(literal) -> 1; % We assume efficient handling of constants.
+weight(data) -> 1; % Base cost; add 1 per element.
+weight(element) -> 1; % Cost of storing/fetching an element.
+weight(argument) -> 1; % Cost of passing a function argument.
+weight('fun') -> 6; % Base cost + average number of free vars.
+weight('let') -> 0; % Count no cost for let-bindings.
+weight(letrec) -> 0; % Like a let-binding.
+weight('case') -> 0; % Case switches have no base cost.
+weight(clause) -> 1; % Count one jump at the end of each clause body.
+weight('receive') -> 9; % Initialization/cleanup cost.
+weight('try') -> 1; % Assume efficient implementation.
+weight('catch') -> 1; % See `try'.
+weight(apply) -> 3; % Average base cost: call/return.
+weight(call) -> 3; % Assume remote-calls as efficient as `apply'.
+weight(primop) -> 2; % Assume more efficient than `apply'.
+weight(binary) -> 4; % Initialisation base cost.
+weight(bitstr) -> 3; % Coding/decoding a value; like a primop.
+weight(module) -> 1. % Like a letrec with a constant body
+
+%% These "reference" structures are used for variables and function
+%% variables. They keep track of the variable name, any bound operand,
+%% and the associated store location.
+
+-record(ref, {name, opnd, loc}).
+
+%% Operand structures contain the operand expression, the renaming and
+%% environment, the state location, and the effort counter at the call
+%% site (cf. `visit').
+
+-record(opnd, {expr, ren, env, loc, effort}).
+
+%% Since expressions are only visited in `effect' context when they are
+%% not bound to a referenced variable, only expressions visited in
+%% 'value' context are cached.
+
+-record(cache, {expr, size}).
+
+%% The context flags for an application structure are kept separate from
+%% the structure itself. Note that the original algorithm had exactly
+%% one operand in each application context structure, while we can have
+%% several, or none.
+
+-record(app, {opnds, ctxt, loc}).
+
+
+%%
+%% Interface functions
+%%
+
+%% Use compile option `{core_transform, inline}' to insert this as a
+%% compilation pass.
+
+-spec core_transform(cerl:cerl(), [compile:option()]) -> cerl:cerl().
+
+core_transform(Code, Opts) ->
+ cerl:to_records(transform(cerl:from_records(Code), Opts)).
+
+-spec transform(cerl:cerl()) -> cerl:cerl().
+
+transform(Tree) ->
+ transform(Tree, []).
+
+-spec transform(cerl:cerl(), [compile:option()]) -> cerl:cerl().
+
+transform(Tree, Opts) ->
+ main(Tree, value, Opts).
+
+main(Tree, Ctxt, Opts) ->
+ %% We spawn a new process to do the work, so we don't have to worry
+ %% about cluttering the process dictionary with debugging info, or
+ %% proper deallocation of ets-tables.
+ Opts1 = Opts ++ [{inline_size, default_size()},
+ {inline_effort, default_effort()},
+ {inline_unroll, default_unroll()}],
+ Reply = self(),
+ Pid = spawn_link(fun () -> start(Reply, Tree, Ctxt, Opts1) end),
+ receive
+ {Pid, Tree1} -> Tree1
+ end.
+
+start(Reply, Tree, Ctxt, Opts) ->
+ init_debug(),
+ case debug_runtime() of
+ %% true ->
+ %% put(inline_start_time,
+ %% element(1, erlang:statistics(runtime)));
+ false ->
+ ok
+ end,
+ Size = max(1, proplists:get_value(inline_size, Opts)),
+ Effort = max(1, proplists:get_value(inline_effort, Opts)),
+ Unroll = max(1, proplists:get_value(inline_unroll, Opts)),
+ case proplists:get_bool(verbose, Opts) of
+ true ->
+ io:fwrite("Inlining: inline_size=~w inline_effort=~w\n",
+ [Size, Effort]);
+ false ->
+ ok
+ end,
+
+ %% Note that the counters of the new state are passive.
+ S = st__new(Effort, Size, Unroll),
+
+%%% Initialization is not needed at present. Note that the code in
+%%% `inline_init' is not up-to-date with this module.
+%%% {Tree1, S1} = inline_init:init(Tree, S),
+%%% {Tree2, _S2} = i(Tree1, Ctxt, S1),
+ {Tree2, _S2} = i(Tree, Ctxt, S),
+ report_debug(),
+ Reply ! {self(), Tree2}.
+
+init_debug() ->
+ case debug_counters() of
+ %% true ->
+ %% put(counter_effort_triggers, 0),
+ %% put(counter_effort_max, 0),
+ %% put(counter_size_triggers, 0),
+ %% put(counter_size_max, 0);
+ false ->
+ ok
+ end.
+
+report_debug() ->
+ case debug_runtime() of
+ %% true ->
+ %% {Time, _} = erlang:statistics(runtime),
+ %% report("Total run time for inlining: ~.2.0f s.\n",
+ %% [(Time - get(inline_start_time))/1000]);
+ false ->
+ ok
+ end,
+ case debug_counters() of
+ %% true ->
+ %% counter_stats();
+ false ->
+ ok
+ end.
+
+%% counter_stats() ->
+%% T1 = get(counter_effort_triggers),
+%% T2 = get(counter_size_triggers),
+%% E = get(counter_effort_max),
+%% S = get(counter_size_max),
+%% M1 = io_lib:fwrite("\tNumber of triggered "
+%% "effort counters: ~p.\n", [T1]),
+%% M2 = io_lib:fwrite("\tNumber of triggered "
+%% "size counters: ~p.\n", [T2]),
+%% M3 = io_lib:fwrite("\tLargest active effort counter: ~p.\n",
+%% [E]),
+%% M4 = io_lib:fwrite("\tLargest active size counter: ~p.\n",
+%% [S]),
+%% report("Counter statistics:\n~s", [[M1, M2, M3, M4]]).
+
+
+%% =====================================================================
+%% The main inlining function
+%%
+%% i(E :: coreErlang(),
+%% Ctxt :: value | effect | #app{}
+%% Ren :: renaming(),
+%% Env :: environment(),
+%% S :: state())
+%% -> {E', S'}
+%%
+%% Note: It is expected that the input source code ('E') does not
+%% contain free variables. If it does, there is a risk of accidental
+%% name capture, in case a generated "new" variable name happens to be
+%% the same as the name of a variable that is free further below in the
+%% tree; the algorithm only consults the current environment to check if
+%% a name already exists.
+%%
+%% The renaming maps names of source-code variable and function
+%% variables to new names as necessary to avoid clashes, according to
+%% the "no-shadowing" strategy. The environment maps *residual-code*
+%% variables and function variables to operands and global information.
+%% Separating the renaming from the environment, and using the
+%% residual-code variables instead of the source-code variables as its
+%% domain, improves the behaviour of the algorithm when code needs to be
+%% traversed more than once.
+%%
+%% Note that there is no such thing as a `test' context for expressions
+%% in (Core) Erlang (see `i_case' below for details).
+
+i(E, Ctxt, S) ->
+ i(E, Ctxt, ren__identity(), env__empty(), S).
+
+i(E, Ctxt, Ren, Env, S0) ->
+ %% Count one unit of effort on each pass.
+ S = count_effort(1, S0),
+ case is_data(E) of
+ true ->
+ i_data(E, Ctxt, Ren, Env, S);
+ false ->
+ case type(E) of
+ var ->
+ i_var(E, Ctxt, Ren, Env, S);
+ values ->
+ i_values(E, Ctxt, Ren, Env, S);
+ 'fun' ->
+ i_fun(E, Ctxt, Ren, Env, S);
+ seq ->
+ i_seq(E, Ctxt, Ren, Env, S);
+ 'let' ->
+ i_let(E, Ctxt, Ren, Env, S);
+ letrec ->
+ i_letrec(E, Ctxt, Ren, Env, S);
+ 'case' ->
+ i_case(E, Ctxt, Ren, Env, S);
+ 'receive' ->
+ i_receive(E, Ctxt, Ren, Env, S);
+ apply ->
+ i_apply(E, Ctxt, Ren, Env, S);
+ call ->
+ i_call(E, Ctxt, Ren, Env, S);
+ primop ->
+ i_primop(E, Ren, Env, S);
+ 'try' ->
+ i_try(E, Ctxt, Ren, Env, S);
+ 'catch' ->
+ i_catch(E, Ctxt, Ren, Env, S);
+ binary ->
+ i_binary(E, Ren, Env, S);
+ module ->
+ i_module(E, Ctxt, Ren, Env, S)
+ end
+ end.
+
+i_data(E, Ctxt, Ren, Env, S) ->
+ case is_literal(E) of
+ true ->
+ %% This is the `(const c)' case of the original algorithm:
+ %% literal terms which (regardless of size) do not need to
+ %% be constructed dynamically at runtime - boldly assuming
+ %% that the compiler/runtime system can handle this.
+ case Ctxt of
+ effect ->
+ %% Reduce useless constants to a simple value.
+ {void(), count_size(weight(literal), S)};
+ _ ->
+ %% (In Erlang, we cannot set all non-`false'
+ %% constants to `true' in a `test' context, like we
+ %% could do in Lisp or C, so the above is the only
+ %% special case to be handled here.)
+ {E, count_size(weight(literal), S)}
+ end;
+ false ->
+ %% Data constructors are like to calls to safe built-in
+ %% functions, for which we can "decide to inline"
+ %% immediately; there is no need to create operand
+ %% structures. In `effect' context, we can simply make a
+ %% sequence of the argument expressions, also visited in
+ %% `effect' context. In all other cases, the arguments are
+ %% visited for value.
+ case Ctxt of
+ effect ->
+ %% Note that this will count the sizes of the
+ %% subexpressions, even though some or all of them
+ %% might be discarded by the sequencing afterwards.
+ {Es1, S1} = mapfoldl(fun (E, S) ->
+ i(E, effect, Ren, Env,
+ S)
+ end,
+ S, data_es(E)),
+ E1 = foldl(fun (E1, E2) -> make_seq(E1, E2) end,
+ void(), Es1),
+ {E1, S1};
+ _ ->
+ {Es1, S1} = mapfoldl(fun (E, S) ->
+ i(E, value, Ren, Env,
+ S)
+ end,
+ S, data_es(E)),
+ %% The total size/cost is the base cost for a data
+ %% constructor plus the cost for storing each
+ %% element.
+ N = weight(data) + length(Es1) * weight(element),
+ S2 = count_size(N, S1),
+ {update_data(E, data_type(E), Es1), S2}
+ end
+ end.
+
+%% This is the `(ref x)' (variable use) case of the original algorithm.
+%% Note that binding occurrences are always handled in the respective
+%% cases of the binding constructs.
+
+i_var(E, Ctxt, Ren, Env, S) ->
+ case Ctxt of
+ effect ->
+ %% Reduce useless variable references to a simple constant.
+ %% This also avoids useless visiting of bound operands.
+ {void(), count_size(weight(literal), S)};
+ _ ->
+ Name = var_name(E),
+ case env__lookup(ren__map(Name, Ren), Env) of
+ {ok, R} ->
+ case R#ref.opnd of
+ undefined ->
+ %% The variable is not associated with an
+ %% argument expression; just residualize it.
+ residualize_var(R, S);
+ Opnd ->
+ i_var_1(R, Opnd, Ctxt, Env, S)
+ end;
+ error ->
+ %% The variable is unbound. (It has not been
+ %% accidentally captured, however, or it would have
+ %% been in the environment.) We leave it as it is,
+ %% without any warning.
+ {E, count_size(weight(var), S)}
+ end
+ end.
+
+%% This first visits the bound operand and then does copy propagation.
+%% Note that we must first set the "inner-pending" flag, and clear the
+%% flag afterwards.
+
+i_var_1(R, Opnd, Ctxt, Env, S) ->
+ %% If the operand is already "inner-pending", it is residualised.
+ %% (In Lisp/C, if the variable might be assigned to, it should also
+ %% be residualised.)
+ L = Opnd#opnd.loc,
+ case st__test_inner_pending(L, S) of
+ true ->
+ residualize_var(R, S);
+ false ->
+ S1 = st__mark_inner_pending(L, S),
+ case catch {ok, visit(Opnd, S1)} of
+ {ok, {E, S2}} ->
+ %% Note that we pass the current environment and
+ %% context to `copy', but not the current renaming.
+ S3 = st__clear_inner_pending(L, S2),
+ copy(R, Opnd, E, Ctxt, Env, S3);
+ {'EXIT', X} ->
+ exit(X);
+ X ->
+ %% If we use destructive update for the
+ %% `inner-pending' flag, we must make sure to clear
+ %% it also if we make a nonlocal return.
+ _S2 = st__clear_inner_pending(Opnd#opnd.loc, S1),
+ throw(X)
+ end
+ end.
+
+%% A multiple-value aggregate `<e1, ..., en>'. This is very much like a
+%% tuple data constructor `{e1, ..., en}'; cf. `i_data' for details.
+
+i_values(E, Ctxt, Ren, Env, S) ->
+ case values_es(E) of
+ [E1] ->
+ %% Single-value aggregates can be dropped; they are simply
+ %% notation.
+ i(E1, Ctxt, Ren, Env, S);
+ Es ->
+ %% In `effect' context, we can simply make a sequence of the
+ %% argument expressions, also visited in `effect' context.
+ %% In all other cases, the arguments are visited for value.
+ case Ctxt of
+ effect ->
+ {Es1, S1} =
+ mapfoldl(fun (E, S) ->
+ i(E, effect, Ren, Env, S)
+ end,
+ S, Es),
+ E1 = foldl(fun (E1, E2) ->
+ make_seq(E1, E2)
+ end,
+ void(), Es1),
+ {E1, S1}; % drop annotations on E
+ _ ->
+ {Es1, S1} = mapfoldl(fun (E, S) ->
+ i(E, value, Ren, Env,
+ S)
+ end,
+ S, Es),
+ %% Aggregating values does not write them to memory,
+ %% so we count no extra cost per element.
+ S2 = count_size(weight(values), S1),
+ {update_c_values(E, Es1), S2}
+ end
+ end.
+
+%% A let-expression `let <v1,...,vn> = e0 in e1' is semantically
+%% equivalent to a case-expression `case e0 of <v1,...,vn> when 'true'
+%% -> e1 end'. As a special case, `let <v> = e0 in e1' is also
+%% equivalent to `apply fun (v) -> e0 (e1)'. However, for efficiency,
+%% and in order to allow the handling of `case' clauses to introduce new
+%% let-expressions without entering an infinite rewrite loop, we handle
+%% these directly.
+
+%%% %% Rewriting a `let' to an equivalent expression.
+%%% i_let(E, Ctxt, Ren, Env, S) ->
+%%% case let_vars(E) of
+%%% [V] ->
+%%% E1 = update_c_apply(E, c_fun([V], let_body(E)), [let_arg(E)]),
+%%% i(E1, Ctxt, Ren, Env, S);
+%%% Vs ->
+%%% C = c_clause(Vs, abstract(true), let_body(E)),
+%%% E1 = update_c_case(E, let_arg(E), [C]),
+%%% i(E1, Ctxt, Ren, Env, S)
+%%% end.
+
+i_let(E, Ctxt, Ren, Env, S) ->
+ case let_vars(E) of
+ [V] ->
+ i_let_1(V, E, Ctxt, Ren, Env, S);
+ Vs ->
+ %% Visit the argument expression in `value' context, to
+ %% simplify it as far as possible.
+ {A, S1} = i(let_arg(E), value, Ren, Env, S),
+ case get_components(length(Vs), result(A)) of
+ {true, As} ->
+ %% Note that only the components of the result of
+ %% `A' are passed on; any effects are hoisted.
+ {E1, S2} = i_let_2(Vs, As, E, Ctxt, Ren, Env, S1),
+ {hoist_effects(A, E1), S2};
+ false ->
+ %% We cannot do anything with this `let', since the
+ %% variables cannot be matched against the argument
+ %% components. Just visit the variables for renaming
+ %% and visit the body for value (cf. `i_fun').
+ {_, Ren1, Env1, S2} = bind_locals(Vs, Ren, Env, S1),
+ Vs1 = i_params(Vs, Ren1, Env1),
+ %% The body is always visited for value here.
+ {B, S3} = i(let_body(E), value, Ren1, Env1, S2),
+ S4 = count_size(weight('let'), S3),
+ {update_c_let(E, Vs1, A, B), S4}
+ end
+ end.
+
+%% Single-variable `let' binding.
+
+i_let_1(V, E, Ctxt, Ren, Env, S) ->
+ %% Make an operand structure for the argument expression, create a
+ %% local binding from the parameter to the operand structure, and
+ %% visit the body. Finally create necessary bindings and/or set
+ %% flags.
+ {Opnd, S1} = make_opnd(let_arg(E), Ren, Env, S),
+ {[R], Ren1, Env1, S2} = bind_locals([V], [Opnd], Ren, Env, S1),
+ {E1, S3} = i(let_body(E), Ctxt, Ren1, Env1, S2),
+ i_let_3([R], [Opnd], E1, S3).
+
+%% Multi-variable `let' binding.
+
+i_let_2(Vs, As, E, Ctxt, Ren, Env, S) ->
+ %% Make operand structures for the argument components. Note that
+ %% since the argument has already been visited at this point, we use
+ %% the identity renaming for the operands.
+ {Opnds, S1} = mapfoldl(fun (E, S) ->
+ make_opnd(E, ren__identity(), Env, S)
+ end,
+ S, As),
+ %% Create local bindings from the parameters to their respective
+ %% operand structures, and visit the body.
+ {Rs, Ren1, Env1, S2} = bind_locals(Vs, Opnds, Ren, Env, S1),
+ {E1, S3} = i(let_body(E), Ctxt, Ren1, Env1, S2),
+ i_let_3(Rs, Opnds, E1, S3).
+
+i_let_3(Rs, Opnds, E, S) ->
+ %% Create necessary bindings and/or set flags.
+ {E1, S1} = make_let_bindings(Rs, E, S),
+
+ %% We must also create evaluation for effect, for any unused
+ %% operands, as after an application expression.
+ residualize_operands(Opnds, E1, S1).
+
+%% A sequence `do e1 e2', written `(seq e1 e2)' in the original
+%% algorithm, where `e1' is evaluated for effect only (since its value
+%% is not used), and `e2' yields the final value. Note that we use
+%% `make_seq' to recompose the sequence after visiting the parts.
+
+i_seq(E, Ctxt, Ren, Env, S) ->
+ {E1, S1} = i(seq_arg(E), effect, Ren, Env, S),
+ {E2, S2} = i(seq_body(E), Ctxt, Ren, Env, S1),
+ %% A sequence has no cost in itself.
+ {make_seq(E1, E2), S2}.
+
+
+%% The `case' switch of Core Erlang is rather different from the boolean
+%% `(if e1 e2 e3)' case of the original algorithm, but the central idea
+%% is the same: if, given the simplified switch expression (which is
+%% visited in `value' context - a boolean `test' context would not be
+%% generally useful), there is a clause which could definitely be
+%% selected, such that no clause before it can possibly be selected,
+%% then we can eliminate all other clauses. (And even if this is not the
+%% case, some clauses can often be eliminated.) Furthermore, if a clause
+%% can be selected, we can replace the case-expression (including the
+%% switch expression) with the body of the clause and a set of zero or
+%% more let-bindings of subexpressions of the switch expression. (In the
+%% simplest case, the switch expression is evaluated only for effect.)
+
+i_case(E, Ctxt, Ren, Env, S) ->
+ %% First visit the switch expression in `value' context, to simplify
+ %% it as far as possible. Note that only the result part is passed
+ %% on to the clause matching below; any effects are hoisted.
+ {A, S1} = i(case_arg(E), value, Ren, Env, S),
+ A1 = result(A),
+
+ %% Propagating an application context into the branches could cause
+ %% the arguments of the application to be evaluated *after* the
+ %% switch expression, but *before* the body of the selected clause.
+ %% Such interleaving is not allowed in general, and it does not seem
+ %% worthwile to make a more powerful transformation here. Therefore,
+ %% the clause bodies are conservatively visited for value if the
+ %% context is `application'.
+ Ctxt1 = safe_context(Ctxt),
+ {E1, S2} = case get_components(case_arity(E), A1) of
+ {true, As} ->
+ i_case_1(As, E, Ctxt1, Ren, Env, S1);
+ false ->
+ i_case_1([], E, Ctxt1, Ren, Env, S1)
+ end,
+ {hoist_effects(A, E1), S2}.
+
+i_case_1(As, E, Ctxt, Ren, Env, S) ->
+ case i_clauses(As, case_clauses(E), Ctxt, Ren, Env, S) of
+ {false, {As1, Vs, Env1, Cs}, S1} ->
+ %% We still have a list of clauses. Sanity check:
+ if Cs =:= [] ->
+ report_warning("empty list of clauses "
+ "in residual program!.\n");
+ true ->
+ ok
+ end,
+ {A, S2} = i(c_values(As1), value, ren__identity(), Env1,
+ S1),
+ {E1, S3} = i_case_2(Cs, A, E, S2),
+ i_case_3(Vs, Env1, E1, S3);
+ {true, {_, Vs, Env1, [C]}, S1} ->
+ %% A single clause was selected; we just take the body.
+ i_case_3(Vs, Env1, clause_body(C), S1)
+ end.
+
+%% Check if all clause bodies are actually equivalent expressions that
+%% do not depent on pattern variables (this sometimes occurs as a
+%% consequence of inlining, e.g., all branches might yield 'true'), and
+%% if so, replace the `case' with a sequence, first evaluating the
+%% clause selection for effect, then evaluating one of the clause bodies
+%% for its value. (Unless the switch contains a catch-all clause, the
+%% clause selection must be evaluated for effect, since there is no
+%% guarantee that any of the clauses will actually match. Assuming that
+%% some clause always matches could make an undefined program produce a
+%% value.) This makes the final size less than what was accounted for
+%% when visiting the clauses, but currently we don't try to adjust for
+%% this.
+
+i_case_2(Cs, A, E, S) ->
+ case equivalent_clauses(Cs) of
+ false ->
+ %% Count the base sizes for the remaining clauses; pattern
+ %% and guard sizes are already counted.
+ N = weight('case') + weight(clause) * length(Cs),
+ S1 = count_size(N, S),
+ {update_c_case(E, A, Cs), S1};
+ true ->
+ case cerl_clauses:any_catchall(Cs) of
+ true ->
+ %% We know that some clause must be selected, so we
+ %% can drop all the testing as well.
+ E1 = make_seq(A, clause_body(hd(Cs))),
+ {E1, S};
+ false ->
+ %% The clause selection must be performed for
+ %% effect.
+ E1 = update_c_case(E, A,
+ set_clause_bodies(Cs, void())),
+ {make_seq(E1, clause_body(hd(Cs))), S}
+ end
+ end.
+
+i_case_3(Vs, Env, E, S) ->
+ %% For the variables bound to the switch expression subexpressions,
+ %% make let bindings or create evaluation for effect.
+ Rs = [env__get(var_name(V), Env) || V <- Vs],
+ {E1, S1} = make_let_bindings(Rs, E, S),
+ Opnds = [R#ref.opnd || R <- Rs],
+ residualize_operands(Opnds, E1, S1).
+
+%% This function takes a sequence of switch expressions `Es' (which can
+%% be the empty list if these are unknown) and a list `Cs' of clauses,
+%% and returns `{Match, {As, Vs, Env1, Cs1}, S1}' where `As' is a list
+%% of residual switch expressions, `Vs' the list of variables used in
+%% the templates, `Env1' the environment for the templates, and `Cs1'
+%% the list of residual clauses. `Match' is `true' if some clause could
+%% be shown to definitely match (in this case, `Cs1' contains exactly
+%% one element), and `false' otherwise. `S1' is the new state. The given
+%% `Ctxt' is the context to be used for visiting the body of clauses.
+%%
+%% Visiting a clause basically amounts to extending the environment for
+%% all variables in the pattern, as for a `fun' (cf. `i_fun'),
+%% propagating match information if possible, and visiting the guard and
+%% body in the new environment.
+%%
+%% To make it cheaper to do handle a set of clauses, and to avoid
+%% unnecessarily exceeding the size limit, we avoid visiting the bodies
+%% of clauses which are subsequently removed, by dividing the visiting
+%% of a clause into two stages: first construct the environment(s) and
+%% visit the pattern (for renaming) and the guard (for value), then
+%% reduce the switch as much as possible, and lastly visit the body.
+
+i_clauses(Cs, Ctxt, Ren, Env, S) ->
+ i_clauses([], Cs, Ctxt, Ren, Env, S).
+
+i_clauses(Es, Cs, Ctxt, Ren, Env, S) ->
+ %% Create templates for the switch expressions.
+ {Ts, {Vs, Env0}} = mapfoldl(fun (E, {Vs, Env}) ->
+ {T, Vs1, Env1} =
+ make_template(E, Env),
+ {T, {Vs1 ++ Vs, Env1}}
+ end,
+ {[], Env}, Es),
+
+ %% Make operand structures for the switch subexpression templates
+ %% (found in `Env0') and add proper ref-structure bindings to the
+ %% environment. Since the subexpressions in general can be
+ %% interdependent (Vs is in reverse-dependency order), the
+ %% environment (and renaming) must be created incrementally. Note
+ %% that since the switch expressions have been visited already, the
+ %% identity renaming is used for the operands.
+ Vs1 = lists:reverse(Vs),
+ {Ren1, Env1, S1} =
+ foldl(fun (V, {Ren, Env, S}) ->
+ E = env__get(var_name(V), Env0),
+ {Opnd, S_1} = make_opnd(E, ren__identity(), Env,
+ S),
+ {_, Ren1, Env1, S_2} = bind_locals([V], [Opnd],
+ Ren, Env, S_1),
+ {Ren1, Env1, S_2}
+ end,
+ {Ren, Env, S}, Vs1),
+
+ %% First we visit the head of each individual clause, renaming
+ %% pattern variables, inserting let-bindings in the guard and body,
+ %% and visiting the guard. The information used for visiting the
+ %% clause body will be prefixed to the clause annotations.
+ {Cs1, S2} = mapfoldl(fun (C, S) ->
+ i_clause_head(C, Ts, Ren1, Env1, S)
+ end,
+ S1, Cs),
+
+ %% Now that the clause guards have been reduced as far as possible,
+ %% we can attempt to reduce the clauses.
+ As = [hd(get_ann(T)) || T <- Ts],
+ case cerl_clauses:reduce(Cs1, Ts) of
+ {false, Cs2} ->
+ %% We still have one or more clauses (with associated
+ %% extended environments). Their bodies have not yet been
+ %% visited, so we do that (in the respective safe
+ %% environments, adding the sizes of the visited heads to
+ %% the current size counter) and return the final list of
+ %% clauses.
+ {Cs3, S3} = mapfoldl(
+ fun (C, S) ->
+ i_clause_body(C, Ctxt, S)
+ end,
+ S2, Cs2),
+ {false, {As, Vs1, Env1, Cs3}, S3};
+ {true, {C, _}} ->
+ %% A clause C could be selected (the bindings have already
+ %% been added to the guard/body). Note that since the clause
+ %% head will probably be discarded, its size is not counted.
+ {C1, Ren2, Env2, _} = get_clause_extras(C),
+ {B, S3} = i(clause_body(C), Ctxt, Ren2, Env2, S2),
+ C2 = update_c_clause(C1, clause_pats(C1), clause_guard(C1), B),
+ {true, {As, Vs1, Env1, [C2]}, S3}
+ end.
+
+%% This visits the head of a clause, renames pattern variables, inserts
+%% let-bindings in the guard and body, and does inlining on the guard
+%% expression. Returns a list of pairs `{NewClause, Data}', where `Data'
+%% is `{Renaming, Environment, Size}' used for visiting the body of the
+%% new clause.
+
+i_clause_head(C, Ts, Ren, Env, S) ->
+ %% Match the templates against the (non-renamed) patterns to get the
+ %% available information about matching subexpressions. We don't
+ %% care at this point whether an exact match/nomatch is detected.
+ Ps = clause_pats(C),
+ Bs = case cerl_clauses:match_list(Ps, Ts) of
+ {_, Bs1} -> Bs1;
+ none -> []
+ end,
+
+ %% The patterns must be visited for renaming; cf. `i_pattern'. We
+ %% use a passive size counter for visiting the patterns and the
+ %% guard (cf. `visit'), because we do not know at this stage whether
+ %% the clause will be kept or not; the final value of the counter is
+ %% included in the returned value below.
+ {_, Ren1, Env1, S1} = bind_locals(clause_vars(C), Ren, Env, S),
+ S2 = new_passive_size(get_size_limit(S1), S1),
+ {Ps1, S3} = mapfoldl(fun (P, S) ->
+ i_pattern(P, Ren1, Env1, Ren, Env, S)
+ end,
+ S2, Ps),
+
+ %% Rewrite guard and body and visit the guard for value. Discard the
+ %% latter size count if the guard turns out to be a constant.
+ G = add_match_bindings(Bs, clause_guard(C)),
+ B = add_match_bindings(Bs, clause_body(C)),
+ {G1, S4} = i(G, value, Ren1, Env1, S3),
+ S5 = case is_literal(G1) of
+ true ->
+ revert_size(S3, S4);
+ false ->
+ S4
+ end,
+
+ %% Revert to the size counter we had on entry to this function. The
+ %% environment and renaming, together with the size of the clause
+ %% head, are prefixed to the annotations for later use.
+ Size = get_size_value(S5),
+ C1 = update_c_clause(C, Ps1, G1, B),
+ {set_clause_extras(C1, Ren1, Env1, Size), revert_size(S, S5)}.
+
+add_match_bindings(Bs, E) ->
+ %% Don't waste time if the variables definitely cannot be used.
+ %% (Most guards are simply `true'.)
+ case is_literal(E) of
+ true ->
+ E;
+ false ->
+ Vs = [V || {V, E} <- Bs, E =/= any],
+ Es = [hd(get_ann(E)) || {_V, E} <- Bs, E =/= any],
+ c_let(Vs, c_values(Es), E)
+ end.
+
+i_clause_body(C0, Ctxt, S) ->
+ {C, Ren, Env, Size} = get_clause_extras(C0),
+ S1 = count_size(Size, S),
+ {B, S2} = i(clause_body(C), Ctxt, Ren, Env, S1),
+ C1 = update_c_clause(C, clause_pats(C), clause_guard(C), B),
+ {C1, S2}.
+
+get_clause_extras(C) ->
+ [{Ren, Env, Size} | As] = get_ann(C),
+ {set_ann(C, As), Ren, Env, Size}.
+
+set_clause_extras(C, Ren, Env, Size) ->
+ As = [{Ren, Env, Size} | get_ann(C)],
+ set_ann(C, As).
+
+%% This is the `(lambda x e)' case of the original algorithm. A
+%% `fun' is like a lambda expression, but with a varying number of
+%% parameters; possibly zero.
+
+i_fun(E, Ctxt, Ren, Env, S) ->
+ case Ctxt of
+ effect ->
+ %% Reduce useless `fun' expressions to a simple constant;
+ %% visiting the body would be a waste of time, and could
+ %% needlessly mark variables as referenced.
+ {void(), count_size(weight(literal), S)};
+ value ->
+ %% Note that the variables are visited as patterns.
+ Vs = fun_vars(E),
+ {_, Ren1, Env1, S1} = bind_locals(Vs, Ren, Env, S),
+ Vs1 = i_params(Vs, Ren1, Env1),
+
+ %% The body is always visited for value.
+ {B, S2} = i(fun_body(E), value, Ren1, Env1, S1),
+
+ %% We don't bother to include the exact number of free
+ %% variables in the cost for creating a fun-value.
+ S3 = count_size(weight('fun'), S2),
+
+ %% Inlining might have duplicated code, so we must remove
+ %% any 'id'-annotations from the original fun-expression.
+ %% (This forces a later stage to invent new id:s.) This is
+ %% necessary as long as fun:s may still need to be
+ %% identified the old way. Function variables that are not
+ %% in application context also have such annotations, but
+ %% the inlining will currently lose all annotations on
+ %% variable references (I think), so that's not a problem.
+ {set_ann(c_fun(Vs1, B), kill_id_anns(get_ann(E))), S3};
+ #app{} ->
+ %% An application of a fun-expression (in the original
+ %% source code) is handled by going directly to `inline'.
+ %% This is never residualised unless there is an arity
+ %% mismatch, so we don't set up new counters here. Note that
+ %% inlining of copy-propagated fun-expressions is done in
+ %% `copy'; not here!
+ inline(E, Ctxt, Ren, Env, S)
+ end.
+
+%% A `letrec' requires a circular environment, but is otherwise like a
+%% `let', i.e. like a direct lambda application. Note that only
+%% fun-expressions (lambda abstractions) may occur in the right-hand
+%% side of each definition.
+
+i_letrec(E, Ctxt, Ren, Env, S) ->
+ %% Note that we pass an empty list for the auto-referenced
+ %% (exported) functions here.
+ {Es, B, _, S1} = i_letrec(letrec_defs(E), letrec_body(E), [], Ctxt,
+ Ren, Env, S),
+
+ %% If no bindings remain, only the body is returned.
+ case Es of
+ [] ->
+ {B, S1}; % drop annotations on E
+ _ ->
+ S2 = count_size(weight(letrec), S1),
+ {update_c_letrec(E, Es, B), S2}
+ end.
+
+%% The major part of this is shared by letrec-expressions and module
+%% definitions alike.
+
+i_letrec(Es, B, Xs, Ctxt, Ren, Env, S) ->
+ %% First, we create operands with dummy renamings and environments,
+ %% and with fresh store locations for cached expressions and operand
+ %% info.
+ {Opnds, S1} = mapfoldl(fun ({_, E}, S) ->
+ make_opnd(E, undefined, undefined, S)
+ end,
+ S, Es),
+
+ %% Then we make recursive bindings for the definitions.
+ {Rs, Ren1, Env1, S2} = bind_recursive([F || {F, _} <- Es],
+ Opnds, Ren, Env, S1),
+
+ %% For the function variables listed in Xs (none for a
+ %% letrec-expression), we must make sure that the corresponding
+ %% operand expressions are visited and that the definitions are
+ %% marked as referenced; we also need to return the possibly renamed
+ %% function variables.
+ {Xs1, S3} =
+ mapfoldl(
+ fun (X, S) ->
+ Name = ren__map(var_name(X), Ren1),
+ case env__lookup(Name, Env1) of
+ {ok, R} ->
+ S_1 = i_letrec_export(R, S),
+ {ref_to_var(R), S_1};
+ error ->
+ %% We just skip any exports that are not
+ %% actually defined here, and generate a
+ %% warning message.
+ {N, A} = var_name(X),
+ report_warning("export `~w'/~w "
+ "not defined.\n", [N, A]),
+ {X, S}
+ end
+ end,
+ S2, Xs),
+
+ %% At last, we can then visit the body.
+ {B1, S4} = i(B, Ctxt, Ren1, Env1, S3),
+
+ %% Finally, we create new letrec-bindings for any and all
+ %% residualised definitions. All referenced functions should have
+ %% been visited; the call to `visit' below is expected to retreive a
+ %% cached expression.
+ Rs1 = keep_referenced(Rs, S4),
+ {Es1, S5} = mapfoldl(fun (R, S) ->
+ {E_1, S_1} = visit(R#ref.opnd, S),
+ {{ref_to_var(R), E_1}, S_1}
+ end,
+ S4, Rs1),
+ {Es1, B1, Xs1, S5}.
+
+%% This visits the operand for a function definition exported by a
+%% `letrec' (which is really a `module' module definition, since normal
+%% letrecs have no export declarations). Only the updated state is
+%% returned. We must handle the "inner-pending" flag when doing this;
+%% cf. `i_var'.
+
+i_letrec_export(R, S) ->
+ Opnd = R#ref.opnd,
+ S1 = st__mark_inner_pending(Opnd#opnd.loc, S),
+ {_, S2} = visit(Opnd, S1),
+ {_, S3} = residualize_var(R, st__clear_inner_pending(Opnd#opnd.loc,
+ S2)),
+ S3.
+
+%% This is the `(call e1 e2)' case of the original algorithm. The only
+%% difference is that we must handle multiple (or no) operand
+%% expressions.
+
+i_apply(E, Ctxt, Ren, Env, S) ->
+ {Opnds, S1} = mapfoldl(fun (E, S) ->
+ make_opnd(E, Ren, Env, S)
+ end,
+ S, apply_args(E)),
+
+ %% Allocate a new app-context location and set up an application
+ %% context structure containing the surrounding context.
+ {L, S2} = st__new_app_loc(S1),
+ Ctxt1 = #app{opnds = Opnds, ctxt = Ctxt, loc = L},
+
+ %% Visit the operator expression in the new call context.
+ {E1, S3} = i(apply_op(E), Ctxt1, Ren, Env, S2),
+
+ %% Check the "inlined" flag to find out what to do next. (The store
+ %% location could be recycled after the flag has been tested, but
+ %% there is no real advantage to that, because in practice, only
+ %% 4-5% of all created store locations will ever be reused, while
+ %% there will be a noticable overhead for managing the free list.)
+ case st__get_app_inlined(L, S3) of
+ true ->
+ %% The application was inlined, so we have the final
+ %% expression in `E1'. We just have to handle any operands
+ %% that need to be residualized for effect only (i.e., those
+ %% the values of which are not used).
+ residualize_operands(Opnds, E1, S3);
+ false ->
+ %% Otherwise, `E1' is the residual operator expression. We
+ %% make sure all operands are visited, and rebuild the
+ %% application.
+ {Es, S4} = mapfoldl(fun (Opnd, S) ->
+ visit_and_count_size(Opnd, S)
+ end,
+ S3, Opnds),
+ N = apply_size(length(Es)),
+ {update_c_apply(E, E1, Es), count_size(N, S4)}
+ end.
+
+apply_size(A) ->
+ weight(apply) + weight(argument) * A.
+
+%% Since it is not the task of this transformation to handle
+%% cross-module inlining, all inter-module calls are handled by visiting
+%% the components (the module and function name, and the arguments of
+%% the call) for value. In `effect' context, if the function itself is
+%% known to be completely effect free, the call can be discarded and the
+%% arguments evaluated for effect. Otherwise, if all the visited
+%% arguments are to constants, and the function is known to be safe to
+%% execute at compile time, then we try to evaluate the call. If
+%% evaluation completes normally, the call is replaced by the result;
+%% otherwise the call is residualised.
+
+i_call(E, Ctxt, Ren, Env, S) ->
+ {M, S1} = i(call_module(E), value, Ren, Env, S),
+ {F, S2} = i(call_name(E), value, Ren, Env, S1),
+ As = call_args(E),
+ Arity = length(As),
+
+ %% Check if the name of the called function is static. If so,
+ %% discard the size counts performed above, since the values will
+ %% not cause any runtime cost.
+ Static = is_c_atom(M) and is_c_atom(F),
+ S3 = case Static of
+ true ->
+ revert_size(S, S2);
+ false ->
+ S2
+ end,
+ case Ctxt of
+ effect when Static =:= true ->
+ case is_safe_call(atom_val(M), atom_val(F), Arity) of
+ true ->
+ %% The result will not be used, and the call is
+ %% effect free, so we create a multiple-value
+ %% aggregate containing the (not yet visited)
+ %% arguments and process that instead.
+ i(c_values(As), effect, Ren, Env, S3);
+ false ->
+ %% We are not allowed to simply discard the call,
+ %% but we can try to evaluate it.
+ i_call_1(Static, M, F, Arity, As, E, Ctxt, Ren, Env,
+ S3)
+ end;
+ _ ->
+ i_call_1(Static, M, F, Arity, As, E, Ctxt, Ren, Env, S3)
+ end.
+
+i_call_1(Static, M, F, Arity, As, E, Ctxt, Ren, Env, S) ->
+ %% Visit the arguments for value.
+ {As1, S1} = mapfoldl(fun (X, A) -> i(X, value, Ren, Env, A) end,
+ S, As),
+ case Static of
+ true ->
+ case erl_bifs:is_pure(atom_val(M), atom_val(F), Arity) of
+ true ->
+ %% It is allowed to evaluate this at compile time.
+ case all_static(As1) of
+ true ->
+ i_call_3(M, F, As1, E, Ctxt, Env, S1);
+ false ->
+ %% See if the call can be rewritten instead.
+ i_call_4(M, F, As1, E, Ctxt, Env, S1)
+ end;
+ false ->
+ i_call_2(M, F, As1, E, S1)
+ end;
+ false ->
+ i_call_2(M, F, As1, E, S1)
+ end.
+
+%% Residualise the call.
+
+i_call_2(M, F, As, E, S) ->
+ N = weight(call) + weight(argument) * length(As),
+ {update_c_call(E, M, F, As), count_size(N, S)}.
+
+%% Attempt to evaluate the call to yield a literal; if that fails, try
+%% to rewrite the expression.
+
+i_call_3(M, F, As, E, Ctxt, Env, S) ->
+ %% Note that we extract the results of argument expessions here; the
+ %% expressions could still be sequences with side effects.
+ Vs = [concrete(result(A)) || A <- As],
+ case catch {ok, apply(atom_val(M), atom_val(F), Vs)} of
+ {ok, V} ->
+ %% Evaluation completed normally - try to turn the result
+ %% back into a syntax tree (representing a literal).
+ case is_literal_term(V) of
+ true ->
+ %% Make a sequence of the arguments (as a
+ %% multiple-value aggregate) and the final value.
+ S1 = count_size(weight(values), S),
+ S2 = count_size(weight(literal), S1),
+ {make_seq(c_values(As), abstract(V)), S2};
+ false ->
+ %% The result could not be represented as a literal.
+ i_call_4(M, F, As, E, Ctxt, Env, S)
+ end;
+ _ ->
+ %% The evaluation attempt did not complete normally.
+ i_call_4(M, F, As, E, Ctxt, Env, S)
+ end.
+
+%% Rewrite the expression, if possible, otherwise residualise it.
+
+i_call_4(M, F, As, E, Ctxt, Env, S) ->
+ case reduce_bif_call(atom_val(M), atom_val(F), As, Env) of
+ false ->
+ %% Nothing more to be done - residualise the call.
+ i_call_2(M, F, As, E, S);
+ {true, E1} ->
+ %% We revisit the result, because the rewriting might have
+ %% opened possibilities for further inlining. Since the
+ %% parts have already been visited once, we use the identity
+ %% renaming here.
+ i(E1, Ctxt, ren__identity(), Env, S)
+ end.
+
+%% For now, we assume that primops cannot be evaluated at compile time,
+%% probably being too special. Also, we have no knowledge about their
+%% side effects.
+
+i_primop(E, Ren, Env, S) ->
+ %% Visit the arguments for value.
+ {As, S1} = mapfoldl(fun (E, S) ->
+ i(E, value, Ren, Env, S)
+ end,
+ S, primop_args(E)),
+ N = weight(primop) + weight(argument) * length(As),
+ {update_c_primop(E, primop_name(E), As), count_size(N, S1)}.
+
+%% This is like having an expression with an extra fun-expression
+%% attached for "exceptional cases"; actually, there are exactly two
+%% parameter variables for the body, but they are easiest handled as if
+%% their number might vary, just as for a `fun'.
+
+i_try(E, Ctxt, Ren, Env, S) ->
+ %% The argument expression is evaluated in `value' context, and the
+ %% surrounding context is propagated into both branches. We do not
+ %% try to recognize cases when the protected expression will
+ %% actually raise an exception. Note that the variables are visited
+ %% as patterns.
+ {A, S1} = i(try_arg(E), value, Ren, Env, S),
+ Vs = try_vars(E),
+ {_, Ren1, Env1, S2} = bind_locals(Vs, Ren, Env, S1),
+ Vs1 = i_params(Vs, Ren1, Env1),
+ {B, S3} = i(try_body(E), Ctxt, Ren1, Env1, S2),
+ case is_safe(A) of
+ true ->
+ %% The `try' wrapper can be dropped in this case. Since the
+ %% expressions have been visited already, the identity
+ %% renaming is used when we revisit the new let-expression.
+ i(c_let(Vs1, A, B), Ctxt, ren__identity(), Env, S3);
+ false ->
+ Evs = try_evars(E),
+ {_, Ren2, Env2, S4} = bind_locals(Evs, Ren, Env, S3),
+ Evs1 = i_params(Evs, Ren2, Env2),
+ {H, S5} = i(try_handler(E), Ctxt, Ren2, Env2, S4),
+ S6 = count_size(weight('try'), S5),
+ {update_c_try(E, A, Vs1, B, Evs1, H), S6}
+ end.
+
+%% A special case of try-expressions:
+
+i_catch(E, Ctxt, Ren, Env, S) ->
+ %% We cannot propagate application contexts into the catch.
+ {E1, S1} = ES1 = i(catch_body(E), safe_context(Ctxt), Ren, Env, S),
+ case is_safe(E1) of
+ true ->
+ %% The `catch' wrapper can be dropped in this case.
+ ES1;
+ false ->
+ S2 = count_size(weight('catch'), S1),
+ {update_c_catch(E, E1), S2}
+ end.
+
+%% A receive-expression is very much like a case-expression, with the
+%% difference that we do not have access to a switch expression, since
+%% the value being switched on is taken from the mailbox. The fact that
+%% the receive-expression may iterate over an arbitrary number of
+%% messages is not of interest to us. All we can do here is to visit its
+%% subexpressions, and possibly eliminate definitely unselectable
+%% clauses.
+
+i_receive(E, Ctxt, Ren, Env, S) ->
+ %% We first visit the expiry expression (for value) and the expiry
+ %% body (in the surrounding context).
+ {T, S1} = i(receive_timeout(E), value, Ren, Env, S),
+ {B, S2} = i(receive_action(E), Ctxt, Ren, Env, S1),
+
+ %% Then we visit the clauses. Note that application contexts may not
+ %% in general be propagated into the branches (and the expiry body),
+ %% because the execution of the `receive' may remove a message from
+ %% the mailbox as a side effect; the situation is thus analogous to
+ %% that in a `case' expression.
+ Ctxt1 = safe_context(Ctxt),
+ case i_clauses(receive_clauses(E), Ctxt1, Ren, Env, S2) of
+ {false, {[], _, _, Cs}, S3} ->
+ %% We still have a list of clauses. If the list is empty,
+ %% and the expiry expression is the integer zero, the
+ %% expression reduces to the expiry body.
+ if Cs =:= [] ->
+ case is_c_int(T) andalso (int_val(T) =:= 0) of
+ true ->
+ {B, S3};
+ false ->
+ i_receive_1(E, Cs, T, B, S3)
+ end;
+ true ->
+ i_receive_1(E, Cs, T, B, S3)
+ end;
+ {true, {_, _, _, Cs}, S3} ->
+ %% Cs is a single clause that will always be matched (if a
+ %% message exists), but we must keep the `receive' statement
+ %% in order to fetch the message from the mailbox.
+ i_receive_1(E, Cs, T, B, S3)
+ end.
+
+i_receive_1(E, Cs, T, B, S) ->
+ %% Here, we just add the base sizes for the receive-expression
+ %% itself and for each remaining clause; cf. `case'.
+ N = weight('receive') + weight(clause) * length(Cs),
+ {update_c_receive(E, Cs, T, B), count_size(N, S)}.
+
+%% A module definition is like a `letrec', with some add-ons (export and
+%% attribute declarations) but without an explicit body. Actually, the
+%% exporting of function names has the same effect as if there was a
+%% body consisting of the list of references to the exported functions.
+%% Thus, the exported functions are exactly those which can be
+%% referenced from outside the module.
+
+i_module(E, Ctxt, Ren, Env, S) ->
+ %% Cf. `i_letrec'. Note that we pass a dummy constant value for the
+ %% "body" parameter.
+ {Es, _, Xs1, S1} = i_letrec(module_defs(E), void(),
+ module_exports(E), Ctxt, Ren, Env, S),
+ %% Sanity check:
+ case Es of
+ [] ->
+ report_warning("no function definitions remaining "
+ "in module `~s'.\n",
+ [atom_name(module_name(E))]);
+ _ ->
+ ok
+ end,
+ E1 = update_c_module(E, module_name(E), Xs1, module_attrs(E), Es),
+ {E1, count_size(weight(module), S1)}.
+
+%% Binary-syntax expressions are too complicated to do anything
+%% interesting with here - that is beyond the scope of this program;
+%% also, their construction could have side effects, so even in effect
+%% context we can't remove them. (We don't bother to identify cases of
+%% "safe" unused binaries which could be removed.)
+
+i_binary(E, Ren, Env, S) ->
+ %% Visit the segments for value.
+ {Es, S1} = mapfoldl(fun (E, S) ->
+ i_bitstr(E, Ren, Env, S)
+ end,
+ S, binary_segments(E)),
+ S2 = count_size(weight(binary), S1),
+ {update_c_binary(E, Es), S2}.
+
+i_bitstr(E, Ren, Env, S) ->
+ %% It is not necessary to visit the Unit, Type and Flags fields,
+ %% since these are always literals.
+ {Val, S1} = i(bitstr_val(E), value, Ren, Env, S),
+ {Size, S2} = i(bitstr_size(E), value, Ren, Env, S1),
+ Unit = bitstr_unit(E),
+ Type = bitstr_type(E),
+ Flags = bitstr_flags(E),
+ S3 = count_size(weight(bitstr), S2),
+ {update_c_bitstr(E, Val, Size, Unit, Type, Flags), S3}.
+
+%% This is a simplified version of `i_pattern', for lists of parameter
+%% variables only. It does not modify the state.
+
+i_params([V | Vs], Ren, Env) ->
+ Name = ren__map(var_name(V), Ren),
+ case env__lookup(Name, Env) of
+ {ok, R} ->
+ [ref_to_var(R) | i_params(Vs, Ren, Env)];
+ error ->
+ report_internal_error("variable `~w' not bound "
+ "in pattern.\n", [Name]),
+ exit(error)
+ end;
+i_params([], _, _) ->
+ [].
+
+%% For ordinary patterns, we just visit to rename variables and count
+%% the size/cost. All occurring binding instances of variables should
+%% already have been added to the renaming and environment; however, to
+%% handle the size expressions of binary-syntax patterns, we must pass
+%% the renaming and environment of the containing expression
+
+i_pattern(E, Ren, Env, Ren0, Env0, S) ->
+ case type(E) of
+ var ->
+ %% Count no size.
+ Name = ren__map(var_name(E), Ren),
+ case env__lookup(Name, Env) of
+ {ok, R} ->
+ {ref_to_var(R), S};
+ error ->
+ report_internal_error("variable `~w' not bound "
+ "in pattern.\n", [Name]),
+ exit(error)
+ end;
+ alias ->
+ %% Count no size.
+ V = alias_var(E),
+ Name = ren__map(var_name(V), Ren),
+ case env__lookup(Name, Env) of
+ {ok, R} ->
+ %% Visit the subpattern and recompose.
+ V1 = ref_to_var(R),
+ {P, S1} = i_pattern(alias_pat(E), Ren, Env, Ren0,
+ Env0, S),
+ {update_c_alias(E, V1, P), S1};
+ error ->
+ report_internal_error("variable `~w' not bound "
+ "in pattern.\n", [Name]),
+ exit(error)
+ end;
+ binary ->
+ {Es, S1} = mapfoldl(fun (E, S) ->
+ i_bitstr_pattern(E, Ren, Env,
+ Ren0, Env0, S)
+ end,
+ S, binary_segments(E)),
+ S2 = count_size(weight(binary), S1),
+ {update_c_binary(E, Es), S2};
+ _ ->
+ case is_literal(E) of
+ true ->
+ {E, count_size(weight(literal), S)};
+ false ->
+ {Es1, S1} = mapfoldl(fun (E, S) ->
+ i_pattern(E, Ren, Env,
+ Ren0, Env0,
+ S)
+ end,
+ S, data_es(E)),
+ %% We assume that in general, the elements of the
+ %% constructor will all be fetched.
+ N = weight(data) + length(Es1) * weight(element),
+ S2 = count_size(N, S1),
+ {update_data(E, data_type(E), Es1), S2}
+ end
+ end.
+
+i_bitstr_pattern(E, Ren, Env, Ren0, Env0, S) ->
+ %% It is not necessary to visit the Unit, Type and Flags fields,
+ %% since these are always literals. The Value field is a limited
+ %% pattern - either a literal or an unbound variable. The Size field
+ %% is a limited expression - either a literal or a variable bound in
+ %% the environment of the containing expression.
+ {Val, S1} = i_pattern(bitstr_val(E), Ren, Env, Ren0, Env0, S),
+ {Size, S2} = i(bitstr_size(E), value, Ren0, Env0, S1),
+ Unit = bitstr_unit(E),
+ Type = bitstr_type(E),
+ Flags = bitstr_flags(E),
+ S3 = count_size(weight(bitstr), S2),
+ {update_c_bitstr(E, Val, Size, Unit, Type, Flags), S3}.
+
+
+%% ---------------------------------------------------------------------
+%% Other central inlining functions
+
+%% The following function assumes that `E' is a fun-expression and the
+%% context is an app-structure. If the inlining could be aborted, a
+%% corresponding catch should be set up before entering the function.
+%%
+%% Note: if the inlined body is some lambda abstraction, and the
+%% surrounding context of the app-context is also an app-context, the
+%% `inlined' flag of the outermost context will be set before that of
+%% the inner context is set. E.g.: `let F = fun (X) -> fun (Y) -> E in
+%% apply apply F(A)(B)' will propagate the body of F, which is a lambda
+%% abstraction, into the outer application context, which will be
+%% inlined to produce expression `E', and the flag of the outer context
+%% will be set. Upon return, the flag of the inner context will also be
+%% set. However, the flags are then tested in innermost-first order.
+%% Thus, if some inlining attempt is aborted, the `inlined' flags of any
+%% nested app-contexts must be cleared.
+%%
+%% This implementation does nothing to handle inlining of calls to
+%% recursive functions in a smart way. This means that as long as the
+%% size and effort counters do not prevent it, the function body will be
+%% inlined (i.e., the first iteration will be unrolled), and the
+%% recursive calls will be residualized.
+
+inline(E, #app{opnds = Opnds, ctxt = Ctxt, loc = L}, Ren, Env, S) ->
+ %% Check that the arities match:
+ Vs = fun_vars(E),
+ if length(Opnds) =/= length(Vs) ->
+ %% Arity mismatch: the call will be residualized
+ {E, S};
+ true ->
+ %% Create local bindings for the parameters to their
+ %% respective operand structures from the app-structure, and
+ %% visit the body in the context saved in the structure.
+ {Rs, Ren1, Env1, S1} = bind_locals(Vs, Opnds, Ren, Env, S),
+ {E1, S2} = i(fun_body(E), Ctxt, Ren1, Env1, S1),
+
+ %% Create necessary bindings and/or set flags.
+ {E2, S3} = make_let_bindings(Rs, E1, S2),
+
+ %% Lastly, flag the application as inlined, since the inlining
+ %% attempt was not aborted before we reached this point.
+ {E2, st__set_app_inlined(L, S3)}
+ end.
+
+%% For the (possibly renamed) argument variables to an inlined call,
+%% either create `let' bindings for them, if they are still referenced
+%% in the residual expression (in C/Lisp, also if they are assigned to),
+%% or otherwise (if they are not referenced or assigned) mark them for
+%% evaluation for side effects.
+
+make_let_bindings([R | Rs], E, S) ->
+ {E1, S1} = make_let_bindings(Rs, E, S),
+ make_let_binding(R, E1, S1);
+make_let_bindings([], E, S) ->
+ {E, S}.
+
+make_let_binding(R, E, S) ->
+ %% The `referenced' flag is conservatively computed. We therefore
+ %% first check some simple cases where parameter R is definitely not
+ %% referenced in the resulting body E.
+ case is_literal(E) of
+ true ->
+ %% A constant contains no variable references.
+ make_let_binding_1(R, E, S);
+ false ->
+ case is_c_var(E) of
+ true ->
+ case var_name(E) =:= R#ref.name of
+ true ->
+ %% The body is simply the parameter variable
+ %% itself. Visit the operand for value and
+ %% substitute the result for the body.
+ visit_and_count_size(R#ref.opnd, S);
+ false ->
+ %% Not the same variable, so the parameter
+ %% is not referenced at all.
+ make_let_binding_1(R, E, S)
+ end;
+ false ->
+ %% Proceed to check the `referenced' flag.
+ case st__get_var_referenced(R#ref.loc, S) of
+ true ->
+ %% The parameter is probably referenced in
+ %% the residual code (although it might not
+ %% be). Visit the operand for value and
+ %% create a let-binding.
+ {E1, S1} = visit_and_count_size(R#ref.opnd,
+ S),
+ S2 = count_size(weight('let'), S1),
+ {c_let([ref_to_var(R)], E1, E), S2};
+ false ->
+ %% The parameter is definitely not
+ %% referenced.
+ make_let_binding_1(R, E, S)
+ end
+ end
+ end.
+
+%% This marks the operand for evaluation for effect.
+
+make_let_binding_1(R, E, S) ->
+ Opnd = R#ref.opnd,
+ {E, st__set_opnd_effect(Opnd#opnd.loc, S)}.
+
+%% Here, `R' is the ref-structure which is the target of the copy
+%% propagation, and `Opnd' is a visited operand structure, to be
+%% propagated through `R' if possible - if not, `R' is residualised.
+%% `Opnd' is normally the operand that `R' is bound to, and `E' is the
+%% result of visiting `Opnd' for value; we pass this as an argument so
+%% we don't have to fetch it multiple times (because we don't have
+%% constant time access).
+%%
+%% We also pass the environment of the site of the variable reference,
+%% for use when inlining a propagated fun-expression. In the original
+%% algorithm by Waddell, the environment used for inlining such cases is
+%% the identity mapping, because the fun-expression body has already
+%% been visited for value, and their algorithm combines renaming of
+%% source-code variables with the looking up of information about
+%% residual-code variables. We, however, need to check the environment
+%% of the call site when creating new non-shadowed variables, but we
+%% must avoid repeated renaming. We therefore separate the renaming and
+%% the environment (as in the renaming algorithm of Peyton-Jones and
+%% Marlow). This also makes our implementation more general, compared to
+%% the original algorithm, because we do not give up on propagating
+%% variables that were free in the fun-body.
+%%
+%% Example:
+%%
+%% let F = fun (X) -> {'foo', X} in
+%% let G = fun (H) -> apply H(F) % F is free in the fun G
+%% in apply G(fun (F) -> apply F(42))
+%% =>
+%% let F = fun (X) -> {'foo', X} in
+%% apply (fun (H) -> apply H(F))(fun (F) -> apply F(42))
+%% =>
+%% let F = fun (X) -> {'foo', X} in
+%% apply (fun (F) -> apply F(42))(F)
+%% =>
+%% let F = fun (X) -> {'foo', X} in
+%% apply F(42)
+%% =>
+%% apply (fun (X) -> {'foo', X})(2)
+%% =>
+%% {'foo', 42}
+%%
+%% The original algorithm would give up at stage 4, because F was free
+%% in the propagated fun-expression. Our version inlines this example
+%% completely.
+
+copy(R, Opnd, E, Ctxt, Env, S) ->
+ case is_c_var(E) of
+ true ->
+ %% The operand reduces to another variable - get its
+ %% ref-structure and attempt to propagate further.
+ copy_var(env__get(var_name(E), Opnd#opnd.env), Ctxt, Env,
+ S);
+ false ->
+ %% Apart from variables and functional values (the latter
+ %% are handled by `copy_1' below), only constant literals
+ %% are copyable in general; other things, including e.g.
+ %% tuples `{foo, X}', could cause duplication of work, and
+ %% are not copy propagated.
+ case is_literal(E) of
+ true ->
+ {E, count_size(weight(literal), S)};
+ false ->
+ copy_1(R, Opnd, E, Ctxt, Env, S)
+ end
+ end.
+
+copy_var(R, Ctxt, Env, S) ->
+ %% (In Lisp or C, if this other variable might be assigned to, we
+ %% should residualize the "parent" instead, so we don't bypass any
+ %% destructive updates.)
+ case R#ref.opnd of
+ undefined ->
+ %% This variable is not bound to an expression, so just
+ %% residualize it.
+ residualize_var(R, S);
+ Opnd ->
+ %% Note that because operands are always visited before
+ %% copied, all copyable operand expressions will be
+ %% propagated through any number of bindings. If `R' was
+ %% bound to a constant literal, we would never have reached
+ %% this point.
+ case st__lookup_opnd_cache(Opnd#opnd.loc, S) of
+ error ->
+ %% The result for this operand is not yet ready
+ %% (which should mean that it is a recursive
+ %% reference). Thus, we must residualise the
+ %% variable.
+ residualize_var(R, S);
+ {ok, #cache{expr = E1}} ->
+ %% The result for the operand is ready, so we can
+ %% proceed to propagate it.
+ copy_1(R, Opnd, E1, Ctxt, Env, S)
+ end
+ end.
+
+copy_1(R, Opnd, E, Ctxt, Env, S) ->
+ %% Fun-expression (lambdas) are a bit special; they are copyable,
+ %% but should preferably not be duplicated, so they should not be
+ %% copy propagated except into application contexts, where they can
+ %% be inlined.
+ case is_c_fun(E) of
+ true ->
+ case Ctxt of
+ #app{} ->
+ %% First test if the operand is "outer-pending"; if
+ %% so, don't inline.
+ case st__test_outer_pending(Opnd#opnd.loc, S) of
+ false ->
+ copy_inline(R, Opnd, E, Ctxt, Env, S);
+ true ->
+ %% Cyclic reference forced inlining to stop
+ %% (avoiding infinite unfolding).
+ residualize_var(R, S)
+ end;
+ _ ->
+ residualize_var(R, S)
+ end;
+ false ->
+ %% We have no other cases to handle here
+ residualize_var(R, S)
+ end.
+
+%% This inlines a function value that was propagated to an application
+%% context. The inlining is done with an identity renaming (since the
+%% expression is already visited) but in the environment of the call
+%% site (which is OK because of the no-shadowing strategy for renaming,
+%% and because the domain of our environments are the residual-program
+%% variables instead of the source-program variables). Note that we must
+%% first set the "outer-pending" flag, and clear it afterwards.
+
+copy_inline(R, Opnd, E, Ctxt, Env, S) ->
+ S1 = st__mark_outer_pending(Opnd#opnd.loc, S),
+ case catch {ok, copy_inline_1(R, E, Ctxt, Env, S1)} of
+ {ok, {E1, S2}} ->
+ {E1, st__clear_outer_pending(Opnd#opnd.loc, S2)};
+ {'EXIT', X} ->
+ exit(X);
+ X ->
+ %% If we use destructive update for the `outer-pending'
+ %% flag, we must make sure to clear it upon a nonlocal
+ %% return.
+ _S2 = st__clear_outer_pending(Opnd#opnd.loc, S1),
+ throw(X)
+ end.
+
+%% If the current effort counter was passive, we use a new active effort
+%% counter with the inherited limit for this particular inlining.
+
+copy_inline_1(R, E, Ctxt, Env, S) ->
+ case effort_is_active(S) of
+ true ->
+ copy_inline_2(R, E, Ctxt, Env, S);
+ false ->
+ S1 = new_active_effort(get_effort_limit(S), S),
+ case catch {ok, copy_inline_2(R, E, Ctxt, Env, S1)} of
+ {ok, {E1, S2}} ->
+ %% Revert to the old effort counter.
+ {E1, revert_effort(S, S2)};
+ {counter_exceeded, effort, _} ->
+ %% Aborted this inlining attempt because too much
+ %% effort was spent. Residualize the variable and
+ %% revert to the previous state.
+ residualize_var(R, S);
+ {'EXIT', X} ->
+ exit(X);
+ X ->
+ throw(X)
+ end
+ end.
+
+%% Regardless of whether the current size counter is active or not, we
+%% use a new active size counter for each inlining. If the current
+%% counter was passive, the new counter gets the inherited size limit;
+%% if it was active, the size limit of the new counter will be equal to
+%% the remaining budget of the current counter (which itself is not
+%% affected by the inlining). This distributes the size budget more
+%% evenly over "inlinings within inlinings", so that the whole size
+%% budget is not spent on the first few call sites (in an inlined
+%% function body) forcing the remaining call sites to be residualised.
+
+copy_inline_2(R, E, Ctxt, Env, S) ->
+ Limit = case size_is_active(S) of
+ true ->
+ get_size_limit(S) - get_size_value(S);
+ false ->
+ get_size_limit(S)
+ end,
+ %% Add the cost of the application to the new size limit, so we
+ %% always inline functions that are small enough, even if `Limit' is
+ %% close to zero at this point. (This is an extension to the
+ %% original algorithm.)
+ S1 = new_active_size(Limit + apply_size(length(Ctxt#app.opnds)), S),
+ case catch {ok, inline(E, Ctxt, ren__identity(), Env, S1)} of
+ {ok, {E1, S2}} ->
+ %% Revert to the old size counter.
+ {E1, revert_size(S, S2)};
+ {counter_exceeded, size, S2} ->
+ %% Aborted this inlining attempt because it got too big.
+ %% Residualize the variable and revert to the old size
+ %% counter. (It is important that we do not also revert the
+ %% effort counter here. Because the effort and size counters
+ %% are always set up together, we know that the effort
+ %% counter returned in S2 is the same that was passed to
+ %% `inline'.)
+ S3 = revert_size(S, S2),
+ %% If we use destructive update for the `inlined' flag, we
+ %% must make sure to clear the flags of any nested
+ %% app-contexts upon aborting; see `inline' for details.
+ S4 = reset_nested_apps(Ctxt, S3), % for effect
+ residualize_var(R, S4);
+ {'EXIT', X} ->
+ exit(X);
+ X ->
+ throw(X)
+ end.
+
+reset_nested_apps(#app{ctxt = Ctxt, loc = L}, S) ->
+ reset_nested_apps(Ctxt, st__clear_app_inlined(L, S));
+reset_nested_apps(_, S) ->
+ S.
+
+
+%% ---------------------------------------------------------------------
+%% Support functions
+
+new_var(Env) ->
+ Name = env__new_vname(Env),
+ c_var(Name).
+
+residualize_var(R, S) ->
+ S1 = count_size(weight(var), S),
+ {ref_to_var(R), st__set_var_referenced(R#ref.loc, S1)}.
+
+%% This function returns the value-producing subexpression of any
+%% expression. (Except for sequencing expressions, this is the
+%% expression itself.)
+
+result(E) ->
+ case is_c_seq(E) of
+ true ->
+ %% Also see `make_seq', which is used in all places to build
+ %% sequences so that they are always nested in the first
+ %% position.
+ seq_body(E);
+ false ->
+ E
+ end.
+
+%% This function rewrites E to `do A1 E' if A is `do A1 A2', and
+%% otherwise returns E unchanged.
+
+hoist_effects(A, E) ->
+ case type(A) of
+ seq -> make_seq(seq_arg(A), E);
+ _ -> E
+ end.
+
+%% This "build sequencing expression" operation assures that sequences
+%% are always nested in the first position, which makes it easy to find
+%% the actual value-producing expression of a sequence (cf. `result').
+
+make_seq(E1, E2) ->
+ case is_safe(E1) of
+ true ->
+ %% The first expression can safely be dropped.
+ E2;
+ false ->
+ %% If `E1' is a sequence whose final expression has no side
+ %% effects, then we can lose *that* expression when we
+ %% compose the new sequence, since its value will not be
+ %% used.
+ E3 = case is_c_seq(E1) of
+ true ->
+ case is_safe(seq_body(E1)) of
+ true ->
+ %% Drop the final expression.
+ seq_arg(E1);
+ false ->
+ E1
+ end;
+ false ->
+ E1
+ end,
+ case is_c_seq(E2) of
+ true ->
+ %% `E2' is a sequence (E2' E2''), so we must
+ %% rearrange the nesting to ((E1, E2') E2''), to
+ %% preserve the invariant. Annotations on `E2' are
+ %% lost.
+ c_seq(c_seq(E3, seq_arg(E2)), seq_body(E2));
+ false ->
+ c_seq(E3, E2)
+ end
+ end.
+
+%% Currently, safe expressions include variables, lambda expressions,
+%% constructors with safe subexpressions (this includes atoms, integers,
+%% empty lists, etc.), seq-, let- and letrec-expressions with safe
+%% subexpressions, try- and catch-expressions with safe subexpressions
+%% and calls to safe functions with safe argument subexpressions.
+%% Binaries seem too tricky to be considered.
+
+is_safe(E) ->
+ case is_data(E) of
+ true ->
+ is_safe_list(data_es(E));
+ false ->
+ case type(E) of
+ var ->
+ true;
+ 'fun' ->
+ true;
+ values ->
+ is_safe_list(values_es(E));
+ 'seq' ->
+ is_safe(seq_arg(E)) andalso is_safe(seq_body(E));
+ 'let' ->
+ is_safe(let_arg(E)) andalso is_safe(let_body(E));
+ letrec ->
+ is_safe(letrec_body(E));
+ 'try' ->
+ %% If the argument expression is not safe, it could
+ %% be modifying the state; thus, even if the body is
+ %% safe, the try-expression as a whole would not be.
+ %% If the argument is safe, the handler is not used.
+ is_safe(try_arg(E)) andalso is_safe(try_body(E));
+ 'catch' ->
+ is_safe(catch_body(E));
+ call ->
+ M = call_module(E),
+ F = call_name(E),
+ case is_c_atom(M) andalso is_c_atom(F) of
+ true ->
+ As = call_args(E),
+ is_safe_list(As) andalso
+ is_safe_call(atom_val(M),
+ atom_val(F),
+ length(As));
+ false ->
+ false
+ end;
+ _ ->
+ false
+ end
+ end.
+
+is_safe_list([E | Es]) ->
+ case is_safe(E) of
+ true ->
+ is_safe_list(Es);
+ false ->
+ false
+ end;
+is_safe_list([]) ->
+ true.
+
+is_safe_call(M, F, A) ->
+ erl_bifs:is_safe(M, F, A).
+
+%% When setting up local variables, we only create new names if we have
+%% to, according to the "no-shadowing" strategy.
+
+make_locals(Vs, Ren, Env) ->
+ make_locals(Vs, [], Ren, Env).
+
+make_locals([V | Vs], As, Ren, Env) ->
+ Name = var_name(V),
+ case env__is_defined(Name, Env) of
+ false ->
+ %% The variable need not be renamed. Just make sure that the
+ %% renaming will map it to itself.
+ Name1 = Name,
+ Ren1 = ren__add_identity(Name, Ren);
+ true ->
+ %% The variable must be renamed to maintain the no-shadowing
+ %% invariant. Do the right thing for function variables.
+ Name1 = case Name of
+ {A, N} ->
+ env__new_fname(A, N, Env);
+ _ ->
+ env__new_vname(Env)
+ end,
+ Ren1 = ren__add(Name, Name1, Ren)
+ end,
+ %% This temporary binding is added for correct new-key generation.
+ Env1 = env__bind(Name1, dummy, Env),
+ make_locals(Vs, [Name1 | As], Ren1, Env1);
+make_locals([], As, Ren, Env) ->
+ {reverse(As), Ren, Env}.
+
+%% This adds let-bindings for the source code variables in `Es' to the
+%% environment `Env'.
+%%
+%% Note that we always assign a new state location for the
+%% residual-program variable, since we cannot know when a location for a
+%% particular variable in the source code can be reused.
+
+bind_locals(Vs, Ren, Env, S) ->
+ Opnds = [undefined || _ <- Vs],
+ bind_locals(Vs, Opnds, Ren, Env, S).
+
+bind_locals(Vs, Opnds, Ren, Env, S) ->
+ {Ns, Ren1, Env1} = make_locals(Vs, Ren, Env),
+ {Rs, Env2, S1} = bind_locals_1(Ns, Opnds, [], Env1, S),
+ {Rs, Ren1, Env2, S1}.
+
+%% Note that the `Vs' are currently not used for anything except the
+%% number of variables. If we were maintaining "source-referenced"
+%% flags, then the flag in the new variable should be initialized to the
+%% current value of the (residual-) referenced-flag of the "parent".
+
+bind_locals_1([N | Ns], [Opnd | Opnds], Rs, Env, S) ->
+ {R, S1} = new_ref(N, Opnd, S),
+ Env1 = env__bind(N, R, Env),
+ bind_locals_1(Ns, Opnds, [R | Rs], Env1, S1);
+bind_locals_1([], [], Rs, Env, S) ->
+ {lists:reverse(Rs), Env, S}.
+
+new_refs(Ns, Opnds, S) ->
+ new_refs(Ns, Opnds, [], S).
+
+new_refs([N | Ns], [Opnd | Opnds], Rs, S) ->
+ {R, S1} = new_ref(N, Opnd, S),
+ new_refs(Ns, Opnds, [R | Rs], S1);
+new_refs([], [], Rs, S) ->
+ {lists:reverse(Rs), S}.
+
+new_ref(N, Opnd, S) ->
+ {L, S1} = st__new_ref_loc(S),
+ {#ref{name = N, opnd = Opnd, loc = L}, S1}.
+
+%% This adds recursive bindings for the source code variables in `Es' to
+%% the environment `Env'. Note that recursive binding of a set of
+%% variables is an atomic operation on the environment - they cannot be
+%% added one at a time.
+
+bind_recursive(Vs, Opnds, Ren, Env, S) ->
+ {Ns, Ren1, Env1} = make_locals(Vs, Ren, Env),
+ {Rs, S1} = new_refs(Ns, Opnds, S),
+
+ %% When this fun-expression is evaluated, it updates the operand
+ %% structure in the ref-structure to contain the recursively defined
+ %% environment and the correct renaming.
+ Fun = fun (R, Env) ->
+ Opnd = R#ref.opnd,
+ R#ref{opnd = Opnd#opnd{ren = Ren1, env = Env}}
+ end,
+ {Rs, Ren1, env__bind_recursive(Ns, Rs, Fun, Env1), S1}.
+
+safe_context(Ctxt) ->
+ case Ctxt of
+ #app{} ->
+ value;
+ _ ->
+ Ctxt
+ end.
+
+%% Note that the name of a variable encodes its type: a "plain" variable
+%% or a function variable. The latter kind also contains an arity number
+%% which should be preserved upon renaming.
+
+ref_to_var(#ref{name = Name}) ->
+ %% If we were maintaining "source-referenced" flags, the annotation
+ %% `add_ann([#source_ref{loc = L}], E)' should also be done here, to
+ %% make the algorithm reapplicable. This is however not necessary
+ %% since there are no destructive variable assignments in Erlang.
+ c_var(Name).
+
+%% Including the effort counter of the call site assures that the cost
+%% of processing an operand via `visit' is charged to the correct
+%% counter. In particular, if the effort counter of the call site was
+%% passive, the operands will also be processed with a passive counter.
+
+make_opnd(E, Ren, Env, S) ->
+ {L, S1} = st__new_opnd_loc(S),
+ C = st__get_effort(S1),
+ Opnd = #opnd{expr = E, ren = Ren, env = Env, loc = L, effort = C},
+ {Opnd, S1}.
+
+keep_referenced(Rs, S) ->
+ [R || R <- Rs, st__get_var_referenced(R#ref.loc, S)].
+
+residualize_operands(Opnds, E, S) ->
+ foldr(fun (Opnd, {E, S}) -> residualize_operand(Opnd, E, S) end,
+ {E, S}, Opnds).
+
+%% This is the only case where an operand expression can be visited in
+%% `effect' context instead of `value' context.
+
+residualize_operand(Opnd, E, S) ->
+ case st__get_opnd_effect(Opnd#opnd.loc, S) of
+ true ->
+ %% The operand has not been visited, so we do that now, but
+ %% in `effect' context. (Waddell's algoritm does some stuff
+ %% here to account specially for the operand size, which
+ %% appears unnecessary.)
+ {E1, S1} = i(Opnd#opnd.expr, effect, Opnd#opnd.ren,
+ Opnd#opnd.env, S),
+ {make_seq(E1, E), S1};
+ false ->
+ {E, S}
+ end.
+
+%% The `visit' function always visits the operand expression in `value'
+%% context (`residualize_operand' visits an unreferenced operand
+%% expression in `effect' context when necessary). A new passive size
+%% counter is used for visiting the operand, the final value of which is
+%% then cached along with the resulting expression.
+%%
+%% Note that the effort counter of the call site, included in the
+%% operand structure, is not a shared object. Thus, the effort budget is
+%% actually reused over all occurrences of the operands of a single
+%% application. This does not appear to be a problem; just a
+%% modification of the algorithm.
+
+visit(Opnd, S) ->
+ {C, S1} = visit_1(Opnd, S),
+ {C#cache.expr, S1}.
+
+visit_and_count_size(Opnd, S) ->
+ {C, S1} = visit_1(Opnd, S),
+ {C#cache.expr, count_size(C#cache.size, S1)}.
+
+visit_1(Opnd, S) ->
+ case st__lookup_opnd_cache(Opnd#opnd.loc, S) of
+ error ->
+ %% Use a new, passive, size counter for visiting operands,
+ %% and use the effort counter of the context of the operand.
+ %% It turns out that if the latter is active, it must be the
+ %% same object as the one currently used, and if it is
+ %% passive, it does not matter if it is the same object as
+ %% any other counter.
+ Effort = Opnd#opnd.effort,
+ Active = counter__is_active(Effort),
+ S1 = case Active of
+ true ->
+ S; % don't change effort counter
+ false ->
+ st__set_effort(Effort, S)
+ end,
+ S2 = new_passive_size(get_size_limit(S1), S1),
+
+ %% Visit the expression and cache the result, along with the
+ %% final value of the size counter.
+ {E, S3} = i(Opnd#opnd.expr, value, Opnd#opnd.ren,
+ Opnd#opnd.env, S2),
+ Size = get_size_value(S3),
+ C = #cache{expr = E, size = Size},
+ S4 = revert_size(S, st__set_opnd_cache(Opnd#opnd.loc, C,
+ S3)),
+ case Active of
+ true ->
+ {C, S4}; % keep using the same effort counter
+ false ->
+ {C, revert_effort(S, S4)}
+ end;
+ {ok, C} ->
+ {C, S}
+ end.
+
+%% Create a pattern matching template for an expression. A template
+%% contains only data constructors (including atomic ones) and
+%% variables, and compound literals are not folded into a single node.
+%% Each node in the template is annotated with the variable which holds
+%% the corresponding subexpression; these are new, unique variables not
+%% existing in the given `Env'. Returns `{Template, Variables, NewEnv}',
+%% where `Variables' is the list of all variables corresponding to nodes
+%% in the template *listed in reverse dependency order*, and `NewEnv' is
+%% `Env' augmented with mappings from the variable names to
+%% subexpressions of `E' (not #ref{} structures!) rewritten so that no
+%% computations are duplicated. `Variables' is guaranteed to be nonempty
+%% - at least the root node will always be bound to a new variable.
+
+make_template(E, Env) ->
+ make_template(E, [], Env).
+
+make_template(E, Vs0, Env0) ->
+ case is_data(E) of
+ true ->
+ {Ts, {Vs1, Env1}} = mapfoldl(
+ fun (E, {Vs0, Env0}) ->
+ {T, Vs1, Env1} =
+ make_template(E, Vs0,
+ Env0),
+ {T, {Vs1, Env1}}
+ end,
+ {Vs0, Env0}, data_es(E)),
+ T = make_data_skel(data_type(E), Ts),
+ E1 = update_data(E, data_type(E),
+ [hd(get_ann(T)) || T <- Ts]),
+ V = new_var(Env1),
+ Env2 = env__bind(var_name(V), E1, Env1),
+ {set_ann(T, [V]), [V | Vs1], Env2};
+ false ->
+ case type(E) of
+ seq ->
+ %% For a sequencing, we can rebind the variable used
+ %% for the body, and pass on the template as it is.
+ {T, Vs1, Env1} = make_template(seq_body(E), Vs0,
+ Env0),
+ V = var_name(hd(get_ann(T))),
+ E1 = update_c_seq(E, seq_arg(E), env__get(V, Env1)),
+ Env2 = env__bind(V, E1, Env1),
+ {T, Vs1, Env2};
+ _ ->
+ V = new_var(Env0),
+ Env1 = env__bind(var_name(V), E, Env0),
+ {set_ann(V, [V]), [V | Vs0], Env1}
+ end
+ end.
+
+%% Two clauses are equivalent if their bodies are equivalent expressions
+%% given that the respective pattern variables are local.
+
+equivalent_clauses([]) ->
+ true;
+equivalent_clauses([C | Cs]) ->
+ Env = cerl_trees:variables(c_values(clause_pats(C))),
+ equivalent_clauses_1(clause_body(C), Cs, Env).
+
+equivalent_clauses_1(E, [C | Cs], Env) ->
+ Env1 = cerl_trees:variables(c_values(clause_pats(C))),
+ case equivalent(E, clause_body(C), ordsets:union(Env, Env1)) of
+ true ->
+ equivalent_clauses_1(E, Cs, Env);
+ false ->
+ false
+ end;
+equivalent_clauses_1(_, [], _Env) ->
+ true.
+
+%% Two expressions are equivalent if and only if they yield the same
+%% value and has the same side effects in the same order. Currently, we
+%% only accept equality between constructors (constants) and nonlocal
+%% variables, since this should cover most cases of interest. If a
+%% variable is locally bound in one expression, it cannot be equivalent
+%% to one with the same name in the other expression, so we need not
+%% keep track of two environments.
+
+equivalent(E1, E2, Env) ->
+ case is_data(E1) of
+ true ->
+ case is_data(E2) of
+ true ->
+ T1 = {data_type(E1), data_arity(E1)},
+ T2 = {data_type(E2), data_arity(E2)},
+ %% Note that we must test for exact equality.
+ T1 =:= T2 andalso
+ equivalent_lists(data_es(E1), data_es(E2), Env);
+ false ->
+ false
+ end;
+ false ->
+ case type(E1) of
+ var ->
+ case is_c_var(E2) of
+ true ->
+ N1 = var_name(E1),
+ N2 = var_name(E2),
+ N1 =:= N2 andalso not ordsets:is_element(N1, Env);
+ false ->
+ false
+ end;
+ _ ->
+ %% Other constructs are not being considered.
+ false
+ end
+ end.
+
+equivalent_lists([E1 | Es1], [E2 | Es2], Env) ->
+ equivalent(E1, E2, Env) and equivalent_lists(Es1, Es2, Env);
+equivalent_lists([], [], _) ->
+ true;
+equivalent_lists(_, _, _) ->
+ false.
+
+%% Return `false' or `{true, EffectExpr, ValueExpr}'. The environment is
+%% passed for new-variable generation.
+
+reduce_bif_call(M, F, As, Env) ->
+ reduce_bif_call_1(M, F, length(As), As, Env).
+
+reduce_bif_call_1(erlang, element, 2, [X, Y], _Env) ->
+ case is_c_int(X) and is_c_tuple(Y) of
+ true ->
+ %% We are free to change the relative evaluation order of
+ %% the elements, so lifting out a particular element is OK.
+ T = list_to_tuple(tuple_es(Y)),
+ N = int_val(X),
+ if is_integer(N), N > 0, N =< tuple_size(T) ->
+ E = element(N, T),
+ Es = tuple_to_list(setelement(N, T, void())),
+ {true, make_seq(c_tuple(Es), E)};
+ true ->
+ false
+ end;
+ false ->
+ false
+ end;
+reduce_bif_call_1(erlang, hd, 1, [X], _Env) ->
+ case is_c_cons(X) of
+ true ->
+ %% Cf. `element/2' above.
+ {true, make_seq(cons_tl(X), cons_hd(X))};
+ false ->
+ false
+ end;
+reduce_bif_call_1(erlang, length, 1, [X], _Env) ->
+ case is_c_list(X) of
+ true ->
+ %% Cf. `erlang:size/1' below.
+ {true, make_seq(X, c_int(list_length(X)))};
+ false ->
+ false
+ end;
+reduce_bif_call_1(erlang, list_to_tuple, 1, [X], _Env) ->
+ case is_c_list(X) of
+ true ->
+ %% This does not actually preserve all the evaluation order
+ %% constraints of the list, but I don't imagine that it will
+ %% be a problem.
+ {true, c_tuple(list_elements(X))};
+ false ->
+ false
+ end;
+reduce_bif_call_1(erlang, setelement, 3, [X, Y, Z], Env) ->
+ case is_c_int(X) and is_c_tuple(Y) of
+ true ->
+ %% Here, unless `Z' is a simple expression, we must bind it
+ %% to a new variable, because in that case, `Z' must be
+ %% evaluated before any part of `Y'.
+ T = list_to_tuple(tuple_es(Y)),
+ N = int_val(X),
+ if is_integer(N), N > 0, N =< tuple_size(T) ->
+ E = element(N, T),
+ case is_simple(Z) of
+ true ->
+ Es = tuple_to_list(setelement(N, T, Z)),
+ {true, make_seq(E, c_tuple(Es))};
+ false ->
+ V = new_var(Env),
+ Es = tuple_to_list(setelement(N, T, V)),
+ E1 = make_seq(E, c_tuple(Es)),
+ {true, c_let([V], Z, E1)}
+ end;
+ true ->
+ false
+ end;
+ false ->
+ false
+ end;
+reduce_bif_call_1(erlang, size, 1, [X], Env) ->
+ case is_c_tuple(X) of
+ true ->
+ reduce_bif_call_1(erlang, tuple_size, 1, [X], Env);
+ false ->
+ false
+ end;
+reduce_bif_call_1(erlang, tl, 1, [X], _Env) ->
+ case is_c_cons(X) of
+ true ->
+ %% Cf. `element/2' above.
+ {true, make_seq(cons_hd(X), cons_tl(X))};
+ false ->
+ false
+ end;
+reduce_bif_call_1(erlang, tuple_size, 1, [X], _Env) ->
+ case is_c_tuple(X) of
+ true ->
+ %% Just evaluate the tuple for effect and use the size (the
+ %% arity) as the result.
+ {true, make_seq(X, c_int(tuple_arity(X)))};
+ false ->
+ false
+ end;
+reduce_bif_call_1(erlang, tuple_to_list, 1, [X], _Env) ->
+ case is_c_tuple(X) of
+ true ->
+ %% This actually introduces slightly stronger constraints on
+ %% the evaluation order of the subexpressions.
+ {true, make_list(tuple_es(X))};
+ false ->
+ false
+ end;
+reduce_bif_call_1(_M, _F, _A, _As, _Env) ->
+ false.
+
+effort_is_active(S) ->
+ counter__is_active(st__get_effort(S)).
+
+size_is_active(S) ->
+ counter__is_active(st__get_size(S)).
+
+get_effort_limit(S) ->
+ counter__limit(st__get_effort(S)).
+
+new_active_effort(Limit, S) ->
+ st__set_effort(counter__new_active(Limit), S).
+
+revert_effort(S1, S2) ->
+ st__set_effort(st__get_effort(S1), S2).
+
+new_active_size(Limit, S) ->
+ st__set_size(counter__new_active(Limit), S).
+
+new_passive_size(Limit, S) ->
+ st__set_size(counter__new_passive(Limit), S).
+
+revert_size(S1, S2) ->
+ st__set_size(st__get_size(S1), S2).
+
+count_effort(N, S) ->
+ C = st__get_effort(S),
+ C1 = counter__add(N, C, effort, S),
+ case debug_counters() of
+ %% true ->
+ %% case counter__is_active(C1) of
+ %% true ->
+ %% V = counter__value(C1),
+ %% case V > get(counter_effort_max) of
+ %% true ->
+ %% put(counter_effort_max, V);
+ %% false ->
+ %% ok
+ %% end;
+ %% false ->
+ %% ok
+ %% end;
+ false ->
+ ok
+ end,
+ st__set_effort(C1, S).
+
+count_size(N, S) ->
+ C = st__get_size(S),
+ C1 = counter__add(N, C, size, S),
+ case debug_counters() of
+ %% true ->
+ %% case counter__is_active(C1) of
+ %% true ->
+ %% V = counter__value(C1),
+ %% case V > get(counter_size_max) of
+ %% true ->
+ %% put(counter_size_max, V);
+ %% false ->
+ %% ok
+ %% end;
+ %% false ->
+ %% ok
+ %% end;
+ false ->
+ ok
+ end,
+ st__set_size(C1, S).
+
+get_size_value(S) ->
+ counter__value(st__get_size(S)).
+
+get_size_limit(S) ->
+ counter__limit(st__get_size(S)).
+
+kill_id_anns([{'id',_} | As]) ->
+ kill_id_anns(As);
+kill_id_anns([A | As]) ->
+ [A | kill_id_anns(As)];
+kill_id_anns([]) ->
+ [].
+
+
+%% =====================================================================
+%% General utilities
+
+%% The atom `ok', is widely used in Erlang for "void" values.
+
+void() -> abstract(ok).
+
+is_simple(E) ->
+ case type(E) of
+ literal -> true;
+ var -> true;
+ 'fun' -> true;
+ _ -> false
+ end.
+
+get_components(N, E) ->
+ case type(E) of
+ values ->
+ Es = values_es(E),
+ if length(Es) =:= N ->
+ {true, Es};
+ true ->
+ false
+ end;
+ _ when N =:= 1 ->
+ {true, [E]};
+ _ ->
+ false
+ end.
+
+all_static(Es) ->
+ lists:all(fun (E) -> is_literal(result(E)) end, Es).
+
+set_clause_bodies([C | Cs], B) ->
+ [update_c_clause(C, clause_pats(C), clause_guard(C), B)
+ | set_clause_bodies(Cs, B)];
+set_clause_bodies([], _) ->
+ [].
+
+%% =====================================================================
+%% Abstract datatype: renaming()
+
+ren__identity() ->
+ dict:new().
+
+ren__add(X, Y, Ren) ->
+ dict:store(X, Y, Ren).
+
+ren__map(X, Ren) ->
+ case dict:find(X, Ren) of
+ {ok, Y} ->
+ Y;
+ error ->
+ X
+ end.
+
+ren__add_identity(X, Ren) ->
+ dict:erase(X, Ren).
+
+
+%% =====================================================================
+%% Abstract datatype: environment()
+
+env__empty() ->
+ rec_env:empty().
+
+env__bind(Key, Val, Env) ->
+ rec_env:bind(Key, Val, Env).
+
+%% `Es' should have type `[{Key, Val}]', and `Fun' should have type
+%% `(Val, Env) -> T', mapping a value together with the recursive
+%% environment itself to some term `T' to be returned when the entry is
+%% looked up.
+
+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__new_vname(Env) ->
+ rec_env:new_key(Env).
+
+env__new_fname(A, N, Env) ->
+ rec_env:new_key(fun (X) ->
+ S = integer_to_list(X),
+ {list_to_atom(atom_to_list(A) ++ "_" ++ S),
+ N}
+ end, Env).
+
+
+%% =====================================================================
+%% Abstract datatype: state()
+
+-record(state, {free, % next free location
+ size, % size counter
+ effort, % effort counter
+ unroll, % inner/outer-pending initial value
+ cache, % operand expression cache
+ var_flags, % flags for variables (#ref-structures)
+ opnd_flags, % flags for operands
+ app_flags}). % flags for #app-structures
+
+%% Note that we do not have a `var_assigned' flag, since there is no
+%% destructive assignment in Erlang. In the original algorithm, the
+%% "residual-referenced"-flags of the previous inlining pass (or
+%% initialization pass) are used as the "source-referenced"-flags for
+%% the subsequent pass. The latter may then be used as a safe
+%% approximation whenever we need to base a decision on whether or not a
+%% particular variable or function variable could be referenced in the
+%% program being generated, and computation of the new
+%% "residual-referenced" flag for that variable is not yet finished. In
+%% the present algorithm, this can only happen in the presence of
+%% variable assignments, which do not exist in Erlang. Therefore, we do
+%% not keep "source-referenced" flags for residual-code references in
+%% our implementation.
+%%
+%% The "inner-pending" flag tells us whether we are already in the
+%% process of visiting a particular operand, and the "outer-pending"
+%% flag whether we are in the process of inlining a propagated
+%% functional value. The "pending flags" are really counters limiting
+%% the number of times an operand may be inlined recursively, causing
+%% loop unrolling. Note that the initial value must be greater than zero
+%% in order for any inlining at all to be done.
+
+%% Flags are stored in ETS-tables, one table for each class. The second
+%% element in each stored tuple is the key (the "label").
+
+-record(var_flags, {lab, referenced = false}).
+-record(opnd_flags, {lab, inner_pending = 1, outer_pending = 1,
+ effect = false}).
+-record(app_flags, {lab, inlined = false}).
+
+st__new(Effort, Size, Unroll) ->
+ EtsOpts = [set, private, {keypos, 2}],
+ #state{free = 0,
+ size = counter__new_passive(Size),
+ effort = counter__new_passive(Effort),
+ unroll = Unroll,
+ cache = dict:new(),
+ var_flags = ets:new(var, EtsOpts),
+ opnd_flags = ets:new(opnd, EtsOpts),
+ app_flags = ets:new(app, EtsOpts)}.
+
+st__new_loc(S) ->
+ N = S#state.free,
+ {N, S#state{free = N + 1}}.
+
+st__get_effort(S) ->
+ S#state.effort.
+
+st__set_effort(C, S) ->
+ S#state{effort = C}.
+
+st__get_size(S) ->
+ S#state.size.
+
+st__set_size(C, S) ->
+ S#state{size = C}.
+
+st__set_var_referenced(L, S) ->
+ T = S#state.var_flags,
+ [F] = ets:lookup(T, L),
+ ets:insert(T, F#var_flags{referenced = true}),
+ S.
+
+st__get_var_referenced(L, S) ->
+ ets:lookup_element(S#state.var_flags, L, #var_flags.referenced).
+
+st__lookup_opnd_cache(L, S) ->
+ dict:find(L, S#state.cache).
+
+%% Note that setting the cache should only be done once.
+
+st__set_opnd_cache(L, C, S) ->
+ S#state{cache = dict:store(L, C, S#state.cache)}.
+
+st__set_opnd_effect(L, S) ->
+ T = S#state.opnd_flags,
+ [F] = ets:lookup(T, L),
+ ets:insert(T, F#opnd_flags{effect = true}),
+ S.
+
+st__get_opnd_effect(L, S) ->
+ ets:lookup_element(S#state.opnd_flags, L, #opnd_flags.effect).
+
+st__set_app_inlined(L, S) ->
+ T = S#state.app_flags,
+ [F] = ets:lookup(T, L),
+ ets:insert(T, F#app_flags{inlined = true}),
+ S.
+
+st__clear_app_inlined(L, S) ->
+ T = S#state.app_flags,
+ [F] = ets:lookup(T, L),
+ ets:insert(T, F#app_flags{inlined = false}),
+ S.
+
+st__get_app_inlined(L, S) ->
+ ets:lookup_element(S#state.app_flags, L, #app_flags.inlined).
+
+%% The pending-flags are initialized by `st__new_opnd_loc' below.
+
+st__test_inner_pending(L, S) ->
+ T = S#state.opnd_flags,
+ P = ets:lookup_element(T, L, #opnd_flags.inner_pending),
+ P =< 0.
+
+st__mark_inner_pending(L, S) ->
+ ets:update_counter(S#state.opnd_flags, L,
+ {#opnd_flags.inner_pending, -1}),
+ S.
+
+st__clear_inner_pending(L, S) ->
+ ets:update_counter(S#state.opnd_flags, L,
+ {#opnd_flags.inner_pending, 1}),
+ S.
+
+st__test_outer_pending(L, S) ->
+ T = S#state.opnd_flags,
+ P = ets:lookup_element(T, L, #opnd_flags.outer_pending),
+ P =< 0.
+
+st__mark_outer_pending(L, S) ->
+ ets:update_counter(S#state.opnd_flags, L,
+ {#opnd_flags.outer_pending, -1}),
+ S.
+
+st__clear_outer_pending(L, S) ->
+ ets:update_counter(S#state.opnd_flags, L,
+ {#opnd_flags.outer_pending, 1}),
+ S.
+
+st__new_app_loc(S) ->
+ V = {L, _S1} = st__new_loc(S),
+ ets:insert(S#state.app_flags, #app_flags{lab = L}),
+ V.
+
+st__new_ref_loc(S) ->
+ V = {L, _S1} = st__new_loc(S),
+ ets:insert(S#state.var_flags, #var_flags{lab = L}),
+ V.
+
+st__new_opnd_loc(S) ->
+ V = {L, _S1} = st__new_loc(S),
+ N = S#state.unroll,
+ ets:insert(S#state.opnd_flags,
+ #opnd_flags{lab = L,
+ inner_pending = N,
+ outer_pending = N}),
+ V.
+
+
+%% =====================================================================
+%% Abstract datatype: counter()
+%%
+%% `counter__add' throws `{counter_exceeded, Type, Data}' if the
+%% resulting counter value would exceed the limit for the counter in
+%% question (`Type' and `Data' are given by the user).
+
+counter__new_passive(Limit) when Limit > 0 ->
+ {0, Limit}.
+
+counter__new_active(Limit) when Limit > 0 ->
+ {Limit, Limit}.
+
+%% Active counters have values > 0 internally; passive counters start at
+%% zero. The 'limit' field is only accessed by the 'counter__limit'
+%% function.
+
+counter__is_active({C, _}) ->
+ C > 0.
+
+counter__limit({_, L}) ->
+ L.
+
+counter__value({N, L}) ->
+ if N > 0 ->
+ L - N;
+ true ->
+ -N
+ end.
+
+counter__add(N, {V, L}, Type, Data) ->
+ N1 = V - N,
+ if V > 0, N1 =< 0 ->
+ case debug_counters() of
+ %% true ->
+ %% case Type of
+ %% effort ->
+ %% put(counter_effort_triggers,
+ %% get(counter_effort_triggers) + 1);
+ %% size ->
+ %% put(counter_size_triggers,
+ %% get(counter_size_triggers) + 1)
+ %% end;
+ false ->
+ ok
+ end,
+ throw({counter_exceeded, Type, Data});
+ true ->
+ {N1, L}
+ end.
+
+
+%% =====================================================================
+%% Reporting
+
+% report_internal_error(S) ->
+% report_internal_error(S, []).
+
+report_internal_error(S, Vs) ->
+ report_error("internal error: " ++ S, Vs).
+
+%% report_error(D) ->
+%% report_error(D, []).
+
+report_error(D, Vs) ->
+ report({error, D}, Vs).
+
+report_warning(D) ->
+ report_warning(D, []).
+
+report_warning(D, Vs) ->
+ report({warning, D}, Vs).
+
+report(D, Vs) ->
+ io:put_chars(format(D, Vs)).
+
+format({error, D}, Vs) ->
+ ["error: ", format(D, Vs)];
+format({warning, D}, Vs) ->
+ ["warning: ", format(D, Vs)];
+format(S, Vs) when is_list(S) ->
+ [io_lib:fwrite(S, Vs), $\n].
+
+
+%% =====================================================================
diff --git a/lib/compiler/src/cerl_trees.erl b/lib/compiler/src/cerl_trees.erl
new file mode 100644
index 0000000000..7a2057713e
--- /dev/null
+++ b/lib/compiler/src/cerl_trees.erl
@@ -0,0 +1,828 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2001-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+
+%% @doc Basic functions on 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_trees).
+
+-export([depth/1, fold/3, free_variables/1, get_label/1, label/1, label/2,
+ map/2, mapfold/3, size/1, variables/1]).
+
+-import(cerl, [alias_pat/1, alias_var/1, ann_c_alias/3, ann_c_apply/3,
+ ann_c_binary/2, ann_c_bitstr/6, ann_c_call/4,
+ ann_c_case/3, ann_c_catch/2, ann_c_clause/4,
+ ann_c_cons_skel/3, ann_c_fun/3, ann_c_let/4,
+ ann_c_letrec/3, ann_c_module/5, ann_c_primop/3,
+ ann_c_receive/4, ann_c_seq/3, ann_c_try/6,
+ ann_c_tuple_skel/2, ann_c_values/2, apply_args/1,
+ apply_op/1, binary_segments/1, bitstr_val/1,
+ bitstr_size/1, bitstr_unit/1, bitstr_type/1,
+ bitstr_flags/1, call_args/1, call_module/1, call_name/1,
+ case_arg/1, case_clauses/1, catch_body/1, clause_body/1,
+ clause_guard/1, clause_pats/1, clause_vars/1, concrete/1,
+ cons_hd/1, cons_tl/1, fun_body/1, fun_vars/1, get_ann/1,
+ let_arg/1, let_body/1, let_vars/1, letrec_body/1,
+ letrec_defs/1, letrec_vars/1, module_attrs/1,
+ module_defs/1, module_exports/1, module_name/1,
+ module_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, subtrees/1, try_arg/1,
+ try_body/1, try_vars/1, try_evars/1, try_handler/1,
+ tuple_es/1, type/1, update_c_alias/3, update_c_apply/3,
+ update_c_binary/2, update_c_bitstr/6, update_c_call/4,
+ update_c_case/3, update_c_catch/2, update_c_clause/4,
+ update_c_cons/3, update_c_cons_skel/3, update_c_fun/3,
+ update_c_let/4, update_c_letrec/3, update_c_module/5,
+ update_c_primop/3, update_c_receive/4, update_c_seq/3,
+ update_c_try/6, update_c_tuple/2, update_c_tuple_skel/2,
+ update_c_values/2, values_es/1, var_name/1]).
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec depth(Tree::cerl()) -> integer()
+%%
+%% @doc Returns the length of the longest path in the tree. A leaf
+%% node has depth zero, the tree representing "<code>{foo,
+%% bar}</code>" has depth one, etc.
+
+-spec depth(cerl:cerl()) -> non_neg_integer().
+
+depth(T) ->
+ case subtrees(T) of
+ [] ->
+ 0;
+ Gs ->
+ 1 + lists:foldl(fun (G, A) -> max(depth_1(G), A) end, 0, Gs)
+ end.
+
+depth_1(Ts) ->
+ lists:foldl(fun (T, A) -> max(depth(T), A) end, 0, Ts).
+
+max(X, Y) when X > Y -> X;
+max(_, Y) -> Y.
+
+
+%% @spec size(Tree::cerl()) -> integer()
+%%
+%% @doc Returns the number of nodes in <code>Tree</code>.
+
+-spec size(cerl:cerl()) -> non_neg_integer().
+
+size(T) ->
+ fold(fun (_, S) -> S + 1 end, 0, T).
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec map(Function, Tree::cerl()) -> cerl()
+%%
+%% Function = (cerl()) -> cerl()
+%%
+%% @doc Maps a function onto the nodes of a tree. This replaces each
+%% node in the tree by the result of applying the given function on
+%% the original node, bottom-up.
+%%
+%% @see mapfold/3
+
+-spec map(fun((cerl:cerl()) -> cerl:cerl()), cerl:cerl()) -> cerl:cerl().
+
+map(F, T) ->
+ F(map_1(F, T)).
+
+map_1(F, T) ->
+ case type(T) of
+ literal ->
+ case concrete(T) of
+ [_ | _] ->
+ update_c_cons(T, map(F, cons_hd(T)),
+ map(F, cons_tl(T)));
+ V when tuple_size(V) > 0 ->
+ update_c_tuple(T, map_list(F, tuple_es(T)));
+ _ ->
+ T
+ end;
+ var ->
+ T;
+ values ->
+ update_c_values(T, map_list(F, values_es(T)));
+ cons ->
+ update_c_cons_skel(T, map(F, cons_hd(T)),
+ map(F, cons_tl(T)));
+ tuple ->
+ update_c_tuple_skel(T, map_list(F, tuple_es(T)));
+ 'let' ->
+ update_c_let(T, map_list(F, let_vars(T)),
+ map(F, let_arg(T)),
+ map(F, let_body(T)));
+ seq ->
+ update_c_seq(T, map(F, seq_arg(T)),
+ map(F, seq_body(T)));
+ apply ->
+ update_c_apply(T, map(F, apply_op(T)),
+ map_list(F, apply_args(T)));
+ call ->
+ update_c_call(T, map(F, call_module(T)),
+ map(F, call_name(T)),
+ map_list(F, call_args(T)));
+ primop ->
+ update_c_primop(T, map(F, primop_name(T)),
+ map_list(F, primop_args(T)));
+ 'case' ->
+ update_c_case(T, map(F, case_arg(T)),
+ map_list(F, case_clauses(T)));
+ clause ->
+ update_c_clause(T, map_list(F, clause_pats(T)),
+ map(F, clause_guard(T)),
+ map(F, clause_body(T)));
+ alias ->
+ update_c_alias(T, map(F, alias_var(T)),
+ map(F, alias_pat(T)));
+ 'fun' ->
+ update_c_fun(T, map_list(F, fun_vars(T)),
+ map(F, fun_body(T)));
+ 'receive' ->
+ update_c_receive(T, map_list(F, receive_clauses(T)),
+ map(F, receive_timeout(T)),
+ map(F, receive_action(T)));
+ 'try' ->
+ update_c_try(T, map(F, try_arg(T)),
+ map_list(F, try_vars(T)),
+ map(F, try_body(T)),
+ map_list(F, try_evars(T)),
+ map(F, try_handler(T)));
+ 'catch' ->
+ update_c_catch(T, map(F, catch_body(T)));
+ binary ->
+ update_c_binary(T, map_list(F, binary_segments(T)));
+ bitstr ->
+ update_c_bitstr(T, map(F, bitstr_val(T)),
+ map(F, bitstr_size(T)),
+ map(F, bitstr_unit(T)),
+ map(F, bitstr_type(T)),
+ map(F, bitstr_flags(T)));
+ letrec ->
+ update_c_letrec(T, map_pairs(F, letrec_defs(T)),
+ map(F, letrec_body(T)));
+ module ->
+ update_c_module(T, map(F, module_name(T)),
+ map_list(F, module_exports(T)),
+ map_pairs(F, module_attrs(T)),
+ map_pairs(F, module_defs(T)))
+ end.
+
+map_list(F, [T | Ts]) ->
+ [map(F, T) | map_list(F, Ts)];
+map_list(_, []) ->
+ [].
+
+map_pairs(F, [{T1, T2} | Ps]) ->
+ [{map(F, T1), map(F, T2)} | map_pairs(F, Ps)];
+map_pairs(_, []) ->
+ [].
+
+
+%% @spec fold(Function, Unit::term(), Tree::cerl()) -> term()
+%%
+%% Function = (cerl(), term()) -> term()
+%%
+%% @doc Does a fold operation over the nodes of the tree. The result
+%% is the value of <code>Function(X1, Function(X2, ... Function(Xn,
+%% Unit) ... ))</code>, where <code>X1, ..., Xn</code> are the nodes
+%% of <code>Tree</code> in a post-order traversal.
+%%
+%% @see mapfold/3
+
+-spec fold(fun((cerl:cerl(), term()) -> term()), term(), cerl:cerl()) -> term().
+
+fold(F, S, T) ->
+ F(T, fold_1(F, S, T)).
+
+fold_1(F, S, T) ->
+ case type(T) of
+ literal ->
+ case concrete(T) of
+ [_ | _] ->
+ fold(F, fold(F, S, cons_hd(T)), cons_tl(T));
+ V when tuple_size(V) > 0 ->
+ fold_list(F, S, tuple_es(T));
+ _ ->
+ S
+ end;
+ var ->
+ S;
+ values ->
+ fold_list(F, S, values_es(T));
+ cons ->
+ fold(F, fold(F, S, cons_hd(T)), cons_tl(T));
+ tuple ->
+ fold_list(F, S, tuple_es(T));
+ 'let' ->
+ fold(F, fold(F, fold_list(F, S, let_vars(T)),
+ let_arg(T)),
+ let_body(T));
+ seq ->
+ fold(F, fold(F, S, seq_arg(T)), seq_body(T));
+ apply ->
+ fold_list(F, fold(F, S, apply_op(T)), apply_args(T));
+ call ->
+ fold_list(F, fold(F, fold(F, S, call_module(T)),
+ call_name(T)),
+ call_args(T));
+ primop ->
+ fold_list(F, fold(F, S, primop_name(T)), primop_args(T));
+ 'case' ->
+ fold_list(F, fold(F, S, case_arg(T)), case_clauses(T));
+ clause ->
+ fold(F, fold(F, fold_list(F, S, clause_pats(T)),
+ clause_guard(T)),
+ clause_body(T));
+ alias ->
+ fold(F, fold(F, S, alias_var(T)), alias_pat(T));
+ 'fun' ->
+ fold(F, fold_list(F, S, fun_vars(T)), fun_body(T));
+ 'receive' ->
+ fold(F, fold(F, fold_list(F, S, receive_clauses(T)),
+ receive_timeout(T)),
+ receive_action(T));
+ 'try' ->
+ fold(F, fold_list(F, fold(F, fold_list(F, fold(F, S, try_arg(T)),
+ try_vars(T)),
+ try_body(T)),
+ try_evars(T)),
+ try_handler(T));
+ 'catch' ->
+ fold(F, S, catch_body(T));
+ binary ->
+ fold_list(F, S, binary_segments(T));
+ bitstr ->
+ fold(F,
+ fold(F,
+ fold(F,
+ fold(F,
+ fold(F, S, bitstr_val(T)),
+ bitstr_size(T)),
+ bitstr_unit(T)),
+ bitstr_type(T)),
+ bitstr_flags(T));
+ letrec ->
+ fold(F, fold_pairs(F, S, letrec_defs(T)), letrec_body(T));
+ module ->
+ fold_pairs(F,
+ fold_pairs(F,
+ fold_list(F,
+ fold(F, S, module_name(T)),
+ module_exports(T)),
+ module_attrs(T)),
+ module_defs(T))
+ end.
+
+fold_list(F, S, [T | Ts]) ->
+ fold_list(F, fold(F, S, T), Ts);
+fold_list(_, S, []) ->
+ S.
+
+fold_pairs(F, S, [{T1, T2} | Ps]) ->
+ fold_pairs(F, fold(F, fold(F, S, T1), T2), Ps);
+fold_pairs(_, S, []) ->
+ S.
+
+
+%% @spec mapfold(Function, Initial::term(), Tree::cerl()) ->
+%% {cerl(), term()}
+%%
+%% Function = (cerl(), term()) -> {cerl(), term()}
+%%
+%% @doc Does a combined map/fold operation on the nodes of the
+%% tree. This is similar to <code>map/2</code>, but also propagates a
+%% value from each application of <code>Function</code> to the next,
+%% starting with the given value <code>Initial</code>, while doing a
+%% post-order traversal of the tree, much like <code>fold/3</code>.
+%%
+%% @see map/2
+%% @see fold/3
+
+-spec mapfold(fun((cerl:cerl(), term()) -> {cerl:cerl(), term()}),
+ term(), cerl:cerl()) -> {cerl:cerl(), term()}.
+
+mapfold(F, S0, T) ->
+ case type(T) of
+ literal ->
+ case concrete(T) of
+ [_ | _] ->
+ {T1, S1} = mapfold(F, S0, cons_hd(T)),
+ {T2, S2} = mapfold(F, S1, cons_tl(T)),
+ F(update_c_cons(T, T1, T2), S2);
+ V when tuple_size(V) > 0 ->
+ {Ts, S1} = mapfold_list(F, S0, tuple_es(T)),
+ F(update_c_tuple(T, Ts), S1);
+ _ ->
+ F(T, S0)
+ end;
+ var ->
+ F(T, S0);
+ values ->
+ {Ts, S1} = mapfold_list(F, S0, values_es(T)),
+ F(update_c_values(T, Ts), S1);
+ cons ->
+ {T1, S1} = mapfold(F, S0, cons_hd(T)),
+ {T2, S2} = mapfold(F, S1, cons_tl(T)),
+ F(update_c_cons_skel(T, T1, T2), S2);
+ tuple ->
+ {Ts, S1} = mapfold_list(F, S0, tuple_es(T)),
+ F(update_c_tuple_skel(T, Ts), S1);
+ 'let' ->
+ {Vs, S1} = mapfold_list(F, S0, let_vars(T)),
+ {A, S2} = mapfold(F, S1, let_arg(T)),
+ {B, S3} = mapfold(F, S2, let_body(T)),
+ F(update_c_let(T, Vs, A, B), S3);
+ seq ->
+ {A, S1} = mapfold(F, S0, seq_arg(T)),
+ {B, S2} = mapfold(F, S1, seq_body(T)),
+ F(update_c_seq(T, A, B), S2);
+ apply ->
+ {E, S1} = mapfold(F, S0, apply_op(T)),
+ {As, S2} = mapfold_list(F, S1, apply_args(T)),
+ F(update_c_apply(T, E, As), S2);
+ call ->
+ {M, S1} = mapfold(F, S0, call_module(T)),
+ {N, S2} = mapfold(F, S1, call_name(T)),
+ {As, S3} = mapfold_list(F, S2, call_args(T)),
+ F(update_c_call(T, M, N, As), S3);
+ primop ->
+ {N, S1} = mapfold(F, S0, primop_name(T)),
+ {As, S2} = mapfold_list(F, S1, primop_args(T)),
+ F(update_c_primop(T, N, As), S2);
+ 'case' ->
+ {A, S1} = mapfold(F, S0, case_arg(T)),
+ {Cs, S2} = mapfold_list(F, S1, case_clauses(T)),
+ F(update_c_case(T, A, Cs), S2);
+ clause ->
+ {Ps, S1} = mapfold_list(F, S0, clause_pats(T)),
+ {G, S2} = mapfold(F, S1, clause_guard(T)),
+ {B, S3} = mapfold(F, S2, clause_body(T)),
+ F(update_c_clause(T, Ps, G, B), S3);
+ alias ->
+ {V, S1} = mapfold(F, S0, alias_var(T)),
+ {P, S2} = mapfold(F, S1, alias_pat(T)),
+ F(update_c_alias(T, V, P), S2);
+ 'fun' ->
+ {Vs, S1} = mapfold_list(F, S0, fun_vars(T)),
+ {B, S2} = mapfold(F, S1, fun_body(T)),
+ F(update_c_fun(T, Vs, B), S2);
+ 'receive' ->
+ {Cs, S1} = mapfold_list(F, S0, receive_clauses(T)),
+ {E, S2} = mapfold(F, S1, receive_timeout(T)),
+ {A, S3} = mapfold(F, S2, receive_action(T)),
+ F(update_c_receive(T, Cs, E, A), S3);
+ 'try' ->
+ {E, S1} = mapfold(F, S0, try_arg(T)),
+ {Vs, S2} = mapfold_list(F, S1, try_vars(T)),
+ {B, S3} = mapfold(F, S2, try_body(T)),
+ {Evs, S4} = mapfold_list(F, S3, try_evars(T)),
+ {H, S5} = mapfold(F, S4, try_handler(T)),
+ F(update_c_try(T, E, Vs, B, Evs, H), S5);
+ 'catch' ->
+ {B, S1} = mapfold(F, S0, catch_body(T)),
+ F(update_c_catch(T, B), S1);
+ binary ->
+ {Ds, S1} = mapfold_list(F, S0, binary_segments(T)),
+ F(update_c_binary(T, Ds), S1);
+ bitstr ->
+ {Val, S1} = mapfold(F, S0, bitstr_val(T)),
+ {Size, S2} = mapfold(F, S1, bitstr_size(T)),
+ {Unit, S3} = mapfold(F, S2, bitstr_unit(T)),
+ {Type, S4} = mapfold(F, S3, bitstr_type(T)),
+ {Flags, S5} = mapfold(F, S4, bitstr_flags(T)),
+ F(update_c_bitstr(T, Val, Size, Unit, Type, Flags), S5);
+ letrec ->
+ {Ds, S1} = mapfold_pairs(F, S0, letrec_defs(T)),
+ {B, S2} = mapfold(F, S1, letrec_body(T)),
+ F(update_c_letrec(T, Ds, B), S2);
+ module ->
+ {N, S1} = mapfold(F, S0, module_name(T)),
+ {Es, S2} = mapfold_list(F, S1, module_exports(T)),
+ {As, S3} = mapfold_pairs(F, S2, module_attrs(T)),
+ {Ds, S4} = mapfold_pairs(F, S3, module_defs(T)),
+ F(update_c_module(T, N, Es, As, Ds), S4)
+ end.
+
+mapfold_list(F, S0, [T | Ts]) ->
+ {T1, S1} = mapfold(F, S0, T),
+ {Ts1, S2} = mapfold_list(F, S1, Ts),
+ {[T1 | Ts1], S2};
+mapfold_list(_, S, []) ->
+ {[], S}.
+
+mapfold_pairs(F, S0, [{T1, T2} | Ps]) ->
+ {T3, S1} = mapfold(F, S0, T1),
+ {T4, S2} = mapfold(F, S1, T2),
+ {Ps1, S3} = mapfold_pairs(F, S2, Ps),
+ {[{T3, T4} | Ps1], S3};
+mapfold_pairs(_, S, []) ->
+ {[], S}.
+
+
+%% ---------------------------------------------------------------------
+
+%% @spec variables(Tree::cerl()) -> [var_name()]
+%%
+%% var_name() = integer() | atom() | {atom(), integer()}
+%%
+%% @doc Returns an ordered-set list of the names of all variables in
+%% the syntax tree. (This includes function name variables.) An
+%% exception is thrown if <code>Tree</code> does not represent a
+%% well-formed Core Erlang syntax tree.
+%%
+%% @see free_variables/1
+
+-spec variables(cerl:cerl()) -> [cerl:var_name()].
+
+variables(T) ->
+ variables(T, false).
+
+
+%% @spec free_variables(Tree::cerl()) -> [var_name()]
+%%
+%% @doc Like <code>variables/1</code>, but only includes variables
+%% that are free in the tree.
+%%
+%% @see variables/1
+
+-spec free_variables(cerl:cerl()) -> [cerl:var_name()].
+
+free_variables(T) ->
+ variables(T, true).
+
+
+%% This is not exported
+
+variables(T, S) ->
+ case type(T) of
+ literal ->
+ [];
+ var ->
+ [var_name(T)];
+ values ->
+ vars_in_list(values_es(T), S);
+ cons ->
+ ordsets:union(variables(cons_hd(T), S),
+ variables(cons_tl(T), S));
+ tuple ->
+ vars_in_list(tuple_es(T), S);
+ 'let' ->
+ Vs = variables(let_body(T), S),
+ Vs1 = var_list_names(let_vars(T)),
+ Vs2 = case S of
+ true ->
+ ordsets:subtract(Vs, Vs1);
+ false ->
+ ordsets:union(Vs, Vs1)
+ end,
+ ordsets:union(variables(let_arg(T), S), Vs2);
+ seq ->
+ ordsets:union(variables(seq_arg(T), S),
+ variables(seq_body(T), S));
+ apply ->
+ ordsets:union(
+ variables(apply_op(T), S),
+ vars_in_list(apply_args(T), S));
+ call ->
+ ordsets:union(variables(call_module(T), S),
+ ordsets:union(
+ variables(call_name(T), S),
+ vars_in_list(call_args(T), S)));
+ primop ->
+ vars_in_list(primop_args(T), S);
+ 'case' ->
+ ordsets:union(variables(case_arg(T), S),
+ vars_in_list(case_clauses(T), S));
+ clause ->
+ Vs = ordsets:union(variables(clause_guard(T), S),
+ variables(clause_body(T), S)),
+ Vs1 = vars_in_list(clause_pats(T), S),
+ case S of
+ true ->
+ ordsets:subtract(Vs, Vs1);
+ false ->
+ ordsets:union(Vs, Vs1)
+ end;
+ alias ->
+ ordsets:add_element(var_name(alias_var(T)),
+ variables(alias_pat(T)));
+ 'fun' ->
+ Vs = variables(fun_body(T), S),
+ Vs1 = var_list_names(fun_vars(T)),
+ case S of
+ true ->
+ ordsets:subtract(Vs, Vs1);
+ false ->
+ ordsets:union(Vs, Vs1)
+ end;
+ 'receive' ->
+ ordsets:union(
+ vars_in_list(receive_clauses(T), S),
+ ordsets:union(variables(receive_timeout(T), S),
+ variables(receive_action(T), S)));
+ 'try' ->
+ Vs = variables(try_body(T), S),
+ Vs1 = var_list_names(try_vars(T)),
+ Vs2 = case S of
+ true ->
+ ordsets:subtract(Vs, Vs1);
+ false ->
+ ordsets:union(Vs, Vs1)
+ end,
+ Vs3 = variables(try_handler(T), S),
+ Vs4 = var_list_names(try_evars(T)),
+ Vs5 = case S of
+ true ->
+ ordsets:subtract(Vs3, Vs4);
+ false ->
+ ordsets:union(Vs3, Vs4)
+ end,
+ ordsets:union(variables(try_arg(T), S),
+ ordsets:union(Vs2, Vs5));
+ 'catch' ->
+ variables(catch_body(T), S);
+ binary ->
+ vars_in_list(binary_segments(T), S);
+ bitstr ->
+ ordsets:union(variables(bitstr_val(T), S),
+ variables(bitstr_size(T), S));
+ letrec ->
+ Vs = vars_in_defs(letrec_defs(T), S),
+ Vs1 = ordsets:union(variables(letrec_body(T), S), Vs),
+ Vs2 = var_list_names(letrec_vars(T)),
+ case S of
+ true ->
+ ordsets:subtract(Vs1, Vs2);
+ false ->
+ ordsets:union(Vs1, Vs2)
+ end;
+ module ->
+ Vs = vars_in_defs(module_defs(T), S),
+ Vs1 = ordsets:union(vars_in_list(module_exports(T), S), Vs),
+ Vs2 = var_list_names(module_vars(T)),
+ case S of
+ true ->
+ ordsets:subtract(Vs1, Vs2);
+ false ->
+ ordsets:union(Vs1, Vs2)
+ end
+ end.
+
+vars_in_list(Ts, S) ->
+ vars_in_list(Ts, S, []).
+
+vars_in_list([T | Ts], S, A) ->
+ vars_in_list(Ts, S, ordsets:union(variables(T, S), A));
+vars_in_list([], _, A) ->
+ A.
+
+%% Note that this function only visits the right-hand side of function
+%% definitions.
+
+vars_in_defs(Ds, S) ->
+ vars_in_defs(Ds, S, []).
+
+vars_in_defs([{_, F} | Ds], S, A) ->
+ vars_in_defs(Ds, S, ordsets:union(variables(F, S), A));
+vars_in_defs([], _, A) ->
+ A.
+
+%% This amounts to insertion sort. Since the lists are generally short,
+%% it is hardly worthwhile to use an asymptotically better sort.
+
+var_list_names(Vs) ->
+ var_list_names(Vs, []).
+
+var_list_names([V | Vs], A) ->
+ var_list_names(Vs, ordsets:add_element(var_name(V), A));
+var_list_names([], A) ->
+ A.
+
+
+%% ---------------------------------------------------------------------
+
+%% label(Tree::cerl()) -> {cerl(), integer()}
+%%
+%% @equiv label(Tree, 0)
+
+-spec label(cerl:cerl()) -> {cerl:cerl(), integer()}.
+
+label(T) ->
+ label(T, 0).
+
+%% @spec label(Tree::cerl(), N::integer()) -> {cerl(), integer()}
+%%
+%% @doc Labels each expression in the tree. A term <code>{label,
+%% L}</code> is prefixed to the annotation list of each expression node,
+%% where L is a unique number for every node, except for variables (and
+%% function name variables) which get the same label if they represent
+%% the same variable. Constant literal nodes are not labeled.
+%%
+%% <p>The returned value is a tuple <code>{NewTree, Max}</code>, where
+%% <code>NewTree</code> is the labeled tree and <code>Max</code> is 1
+%% plus the largest label value used. All previous annotation terms on
+%% the form <code>{label, X}</code> are deleted.</p>
+%%
+%% <p>The values of L used in the tree is a dense range from
+%% <code>N</code> to <code>Max - 1</code>, where <code>N =&lt; Max
+%% =&lt; N + size(Tree)</code>. Note that it is possible that no
+%% labels are used at all, i.e., <code>N = Max</code>.</p>
+%%
+%% <p>Note: All instances of free variables will be given distinct
+%% labels.</p>
+%%
+%% @see label/1
+%% @see size/1
+
+-spec label(cerl:cerl(), integer()) -> {cerl:cerl(), integer()}.
+
+label(T, N) ->
+ label(T, N, dict:new()).
+
+label(T, N, Env) ->
+ case type(T) of
+ literal ->
+ %% Constant literals are not labeled.
+ {T, N};
+ var ->
+ case dict:find(var_name(T), Env) of
+ {ok, L} ->
+ {As, _} = label_ann(T, L),
+ N1 = N;
+ error ->
+ {As, N1} = label_ann(T, N)
+ end,
+ {set_ann(T, As), N1};
+ values ->
+ {Ts, N1} = label_list(values_es(T), N, Env),
+ {As, N2} = label_ann(T, N1),
+ {ann_c_values(As, Ts), N2};
+ cons ->
+ {T1, N1} = label(cons_hd(T), N, Env),
+ {T2, N2} = label(cons_tl(T), N1, Env),
+ {As, N3} = label_ann(T, N2),
+ {ann_c_cons_skel(As, T1, T2), N3};
+ tuple ->
+ {Ts, N1} = label_list(tuple_es(T), N, Env),
+ {As, N2} = label_ann(T, N1),
+ {ann_c_tuple_skel(As, Ts), N2};
+ 'let' ->
+ {A, N1} = label(let_arg(T), N, Env),
+ {Vs, N2, Env1} = label_vars(let_vars(T), N1, Env),
+ {B, N3} = label(let_body(T), N2, Env1),
+ {As, N4} = label_ann(T, N3),
+ {ann_c_let(As, Vs, A, B), N4};
+ seq ->
+ {A, N1} = label(seq_arg(T), N, Env),
+ {B, N2} = label(seq_body(T), N1, Env),
+ {As, N3} = label_ann(T, N2),
+ {ann_c_seq(As, A, B), N3};
+ apply ->
+ {E, N1} = label(apply_op(T), N, Env),
+ {Es, N2} = label_list(apply_args(T), N1, Env),
+ {As, N3} = label_ann(T, N2),
+ {ann_c_apply(As, E, Es), N3};
+ call ->
+ {M, N1} = label(call_module(T), N, Env),
+ {F, N2} = label(call_name(T), N1, Env),
+ {Es, N3} = label_list(call_args(T), N2, Env),
+ {As, N4} = label_ann(T, N3),
+ {ann_c_call(As, M, F, Es), N4};
+ primop ->
+ {F, N1} = label(primop_name(T), N, Env),
+ {Es, N2} = label_list(primop_args(T), N1, Env),
+ {As, N3} = label_ann(T, N2),
+ {ann_c_primop(As, F, Es), N3};
+ 'case' ->
+ {A, N1} = label(case_arg(T), N, Env),
+ {Cs, N2} = label_list(case_clauses(T), N1, Env),
+ {As, N3} = label_ann(T, N2),
+ {ann_c_case(As, A, Cs), N3};
+ clause ->
+ {_, N1, Env1} = label_vars(clause_vars(T), N, Env),
+ {Ps, N2} = label_list(clause_pats(T), N1, Env1),
+ {G, N3} = label(clause_guard(T), N2, Env1),
+ {B, N4} = label(clause_body(T), N3, Env1),
+ {As, N5} = label_ann(T, N4),
+ {ann_c_clause(As, Ps, G, B), N5};
+ alias ->
+ {V, N1} = label(alias_var(T), N, Env),
+ {P, N2} = label(alias_pat(T), N1, Env),
+ {As, N3} = label_ann(T, N2),
+ {ann_c_alias(As, V, P), N3};
+ 'fun' ->
+ {Vs, N1, Env1} = label_vars(fun_vars(T), N, Env),
+ {B, N2} = label(fun_body(T), N1, Env1),
+ {As, N3} = label_ann(T, N2),
+ {ann_c_fun(As, Vs, B), N3};
+ 'receive' ->
+ {Cs, N1} = label_list(receive_clauses(T), N, Env),
+ {E, N2} = label(receive_timeout(T), N1, Env),
+ {A, N3} = label(receive_action(T), N2, Env),
+ {As, N4} = label_ann(T, N3),
+ {ann_c_receive(As, Cs, E, A), N4};
+ 'try' ->
+ {E, N1} = label(try_arg(T), N, Env),
+ {Vs, N2, Env1} = label_vars(try_vars(T), N1, Env),
+ {B, N3} = label(try_body(T), N2, Env1),
+ {Evs, N4, Env2} = label_vars(try_evars(T), N3, Env),
+ {H, N5} = label(try_handler(T), N4, Env2),
+ {As, N6} = label_ann(T, N5),
+ {ann_c_try(As, E, Vs, B, Evs, H), N6};
+ 'catch' ->
+ {B, N1} = label(catch_body(T), N, Env),
+ {As, N2} = label_ann(T, N1),
+ {ann_c_catch(As, B), N2};
+ binary ->
+ {Ds, N1} = label_list(binary_segments(T), N, Env),
+ {As, N2} = label_ann(T, N1),
+ {ann_c_binary(As, Ds), N2};
+ bitstr ->
+ {Val, N1} = label(bitstr_val(T), N, Env),
+ {Size, N2} = label(bitstr_size(T), N1, Env),
+ {Unit, N3} = label(bitstr_unit(T), N2, Env),
+ {Type, N4} = label(bitstr_type(T), N3, Env),
+ {Flags, N5} = label(bitstr_flags(T), N4, Env),
+ {As, N6} = label_ann(T, N5),
+ {ann_c_bitstr(As, Val, Size, Unit, Type, Flags), N6};
+ letrec ->
+ {_, N1, Env1} = label_vars(letrec_vars(T), N, Env),
+ {Ds, N2} = label_defs(letrec_defs(T), N1, Env1),
+ {B, N3} = label(letrec_body(T), N2, Env1),
+ {As, N4} = label_ann(T, N3),
+ {ann_c_letrec(As, Ds, B), N4};
+ module ->
+ %% The module name is not labeled.
+ {_, N1, Env1} = label_vars(module_vars(T), N, Env),
+ {Ts, N2} = label_defs(module_attrs(T), N1, Env1),
+ {Ds, N3} = label_defs(module_defs(T), N2, Env1),
+ {Es, N4} = label_list(module_exports(T), N3, Env1),
+ {As, N5} = label_ann(T, N4),
+ {ann_c_module(As, module_name(T), Es, Ts, Ds), N5}
+ end.
+
+label_list([T | Ts], N, Env) ->
+ {T1, N1} = label(T, N, Env),
+ {Ts1, N2} = label_list(Ts, N1, Env),
+ {[T1 | Ts1], N2};
+label_list([], N, _Env) ->
+ {[], N}.
+
+label_vars([T | Ts], N, Env) ->
+ Env1 = dict:store(var_name(T), N, Env),
+ {As, N1} = label_ann(T, N),
+ T1 = set_ann(T, As),
+ {Ts1, N2, Env2} = label_vars(Ts, N1, Env1),
+ {[T1 | Ts1], N2, Env2};
+label_vars([], N, Env) ->
+ {[], N, Env}.
+
+label_defs([{F, T} | Ds], N, Env) ->
+ {F1, N1} = label(F, N, Env),
+ {T1, N2} = label(T, N1, Env),
+ {Ds1, N3} = label_defs(Ds, N2, Env),
+ {[{F1, T1} | Ds1], N3};
+label_defs([], N, _Env) ->
+ {[], N}.
+
+label_ann(T, N) ->
+ {[{label, N} | filter_labels(get_ann(T))], N + 1}.
+
+filter_labels([{label, _} | As]) ->
+ filter_labels(As);
+filter_labels([A | As]) ->
+ [A | filter_labels(As)];
+filter_labels([]) ->
+ [].
+
+-spec get_label(cerl:cerl()) -> 'top' | integer().
+
+get_label(T) ->
+ case get_ann(T) of
+ [{label, L} | _] -> L;
+ _ -> throw({missing_label, T})
+ end.
diff --git a/lib/compiler/src/compile.erl b/lib/compiler/src/compile.erl
new file mode 100644
index 0000000000..e725083a9f
--- /dev/null
+++ b/lib/compiler/src/compile.erl
@@ -0,0 +1,1400 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1996-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%
+%%
+%% Purpose: Run the Erlang compiler.
+
+-module(compile).
+
+%% High-level interface.
+-export([file/1,file/2,noenv_file/2,format_error/1,iofile/1]).
+-export([forms/1,forms/2,noenv_forms/2]).
+-export([output_generated/1,noenv_output_generated/1]).
+-export([options/0]).
+
+%% Erlc interface.
+-export([compile/3,compile_beam/3,compile_asm/3,compile_core/3]).
+
+-include("erl_compile.hrl").
+-include("core_parse.hrl").
+
+-import(lists, [member/2,reverse/1,reverse/2,keyfind/3,last/1,
+ map/2,flatmap/2,foreach/2,foldr/3,any/2]).
+
+%%----------------------------------------------------------------------
+
+-type option() :: atom() | {atom(), term()} | {'d', atom(), term()}.
+
+-type line() :: integer().
+-type err_info() :: {line(), module(), term()}. %% ErrorDescriptor
+-type errors() :: [{file:filename(), [err_info()]}].
+-type warnings() :: [{file:filename(), [err_info()]}].
+-type mod_ret() :: {'ok', module()}
+ | {'ok', module(), cerl:c_module()} %% with option 'to_core'
+ | {'ok', module(), warnings()}.
+-type bin_ret() :: {'ok', module(), binary()}
+ | {'ok', module(), binary(), warnings()}.
+-type err_ret() :: 'error' | {'error', errors(), warnings()}.
+-type comp_ret() :: mod_ret() | bin_ret() | err_ret().
+
+%%----------------------------------------------------------------------
+
+%%
+%% Exported functions
+%%
+
+
+%% file(FileName)
+%% file(FileName, Options)
+%% Compile the module in file FileName.
+
+-define(DEFAULT_OPTIONS, [verbose,report_errors,report_warnings]).
+
+-spec file(module() | file:filename()) -> comp_ret().
+
+file(File) -> file(File, ?DEFAULT_OPTIONS).
+
+-spec file(module() | file:filename(), [option()]) -> comp_ret().
+
+file(File, Opts) when is_list(Opts) ->
+ do_compile({file,File}, Opts++env_default_opts());
+file(File, Opt) ->
+ file(File, [Opt|?DEFAULT_OPTIONS]).
+
+forms(File) -> forms(File, ?DEFAULT_OPTIONS).
+
+forms(Forms, Opts) when is_list(Opts) ->
+ do_compile({forms,Forms}, [binary|Opts++env_default_opts()]);
+forms(Forms, Opt) when is_atom(Opt) ->
+ forms(Forms, [Opt|?DEFAULT_OPTIONS]).
+
+%% Given a list of compilation options, returns true if compile:file/2
+%% would have generated a Beam file, false otherwise (if only a binary or a
+%% listing file would have been generated).
+
+output_generated(Opts) ->
+ noenv_output_generated(Opts++env_default_opts()).
+
+%%
+%% Variants of the same function that don't consult ERL_COMPILER_OPTIONS
+%% for default options.
+%%
+
+noenv_file(File, Opts) when is_list(Opts) ->
+ do_compile({file,File}, Opts);
+noenv_file(File, Opt) ->
+ noenv_file(File, [Opt|?DEFAULT_OPTIONS]).
+
+noenv_forms(Forms, Opts) when is_list(Opts) ->
+ do_compile({forms,Forms}, [binary|Opts]);
+noenv_forms(Forms, Opt) when is_atom(Opt) ->
+ noenv_forms(Forms, [Opt|?DEFAULT_OPTIONS]).
+
+noenv_output_generated(Opts) ->
+ any(fun ({save_binary,_F}) -> true;
+ (_Other) -> false
+ end, passes(file, expand_opts(Opts))).
+
+%%
+%% Local functions
+%%
+
+-define(pass(P), {P,fun P/1}).
+
+env_default_opts() ->
+ Key = "ERL_COMPILER_OPTIONS",
+ case os:getenv(Key) of
+ false -> [];
+ Str when is_list(Str) ->
+ case erl_scan:string(Str) of
+ {ok,Tokens,_} ->
+ case erl_parse:parse_term(Tokens ++ [{dot, 1}]) of
+ {ok,List} when is_list(List) -> List;
+ {ok,Term} -> [Term];
+ {error,_Reason} ->
+ io:format("Ignoring bad term in ~s\n", [Key]),
+ []
+ end;
+ {error, {_,_,_Reason}, _} ->
+ io:format("Ignoring bad term in ~s\n", [Key]),
+ []
+ end
+ end.
+
+do_compile(Input, Opts0) ->
+ Opts = expand_opts(Opts0),
+ Self = self(),
+ Serv = spawn_link(fun() -> internal(Self, Input, Opts) end),
+ receive
+ {Serv,Rep} -> Rep
+ end.
+
+expand_opts(Opts0) ->
+ %% {debug_info_key,Key} implies debug_info.
+ Opts = case {proplists:get_value(debug_info_key, Opts0),
+ proplists:get_value(encrypt_debug_info, Opts0),
+ proplists:get_bool(debug_info, Opts0)} of
+ {undefined,undefined,_} -> Opts0;
+ {_,_,false} -> [debug_info|Opts0];
+ {_,_,_} -> Opts0
+ end,
+ foldr(fun expand_opt/2, [], Opts).
+
+expand_opt(basic_validation, Os) ->
+ [no_code_generation,to_pp,binary|Os];
+expand_opt(strong_validation, Os) ->
+ [no_code_generation,to_kernel,binary|Os];
+expand_opt(report, Os) ->
+ [report_errors,report_warnings|Os];
+expand_opt(return, Os) ->
+ [return_errors,return_warnings|Os];
+expand_opt(r11, Os) ->
+ [no_stack_trimming,no_binaries,no_constant_pool|Os];
+expand_opt({debug_info_key,_}=O, Os) ->
+ [encrypt_debug_info,O|Os];
+expand_opt(no_binaries=O, Os) ->
+ %%Turn off the entire type optimization pass.
+ [no_topt,O|Os];
+expand_opt(no_float_opt, Os) ->
+ %%Turn off the entire type optimization pass.
+ [no_topt|Os];
+expand_opt(O, Os) -> [O|Os].
+
+%% format_error(ErrorDescriptor) -> string()
+
+format_error(no_native_support) ->
+ "this system is not configured for native-code compilation.";
+format_error(no_crypto) ->
+ "this system is not configured with crypto support.";
+format_error(bad_crypto_key) ->
+ "invalid crypto key.";
+format_error(no_crypto_key) ->
+ "no crypto key supplied.";
+format_error({native, E}) ->
+ io_lib:fwrite("native-code compilation failed with reason: ~P.",
+ [E, 25]);
+format_error({native_crash, E}) ->
+ io_lib:fwrite("native-code compilation crashed with reason: ~P.",
+ [E, 25]);
+format_error({open,E}) ->
+ io_lib:format("open error '~s'", [file:format_error(E)]);
+format_error({epp,E}) ->
+ epp:format_error(E);
+format_error(write_error) ->
+ "error writing file";
+format_error({rename,From,To,Error}) ->
+ io_lib:format("failed to rename ~s to ~s: ~s",
+ [From,To,file:format_error(Error)]);
+format_error({delete_temp,File,Error}) ->
+ io_lib:format("failed to delete temporary file ~s: ~s",
+ [File,file:format_error(Error)]);
+format_error({parse_transform,M,R}) ->
+ io_lib:format("error in parse transform '~s': ~p", [M, R]);
+format_error({core_transform,M,R}) ->
+ io_lib:format("error in core transform '~s': ~p", [M, R]);
+format_error({crash,Pass,Reason}) ->
+ io_lib:format("internal error in ~p;\ncrash reason: ~p", [Pass,Reason]);
+format_error({bad_return,Pass,Reason}) ->
+ io_lib:format("internal error in ~p;\nbad return value: ~p", [Pass,Reason]);
+format_error({module_name,Mod,Filename}) ->
+ io_lib:format("Module name '~s' does not match file name '~s'",
+ [Mod,Filename]).
+
+%% The compile state record.
+-record(compile, {filename="",
+ dir="",
+ base="",
+ ifile="",
+ ofile="",
+ module=[],
+ code=[],
+ core_code=[],
+ abstract_code=[], %Abstract code for debugger.
+ options=[],
+ errors=[],
+ warnings=[]}).
+
+internal(Master, Input, Opts) ->
+ Master ! {self(), try internal(Input, Opts)
+ catch error:Reason -> {error, Reason}
+ end}.
+
+internal({forms,Forms}, Opts) ->
+ Ps = passes(forms, Opts),
+ internal_comp(Ps, "", "", #compile{code=Forms,options=Opts});
+internal({file,File}, Opts) ->
+ Ps = passes(file, Opts),
+ Compile = #compile{options=Opts},
+ case member(from_core, Opts) of
+ true -> internal_comp(Ps, File, ".core", Compile);
+ false ->
+ case member(from_beam, Opts) of
+ true ->
+ internal_comp(Ps, File, ".beam", Compile);
+ false ->
+ case member(from_asm, Opts) orelse member(asm, Opts) of
+ true ->
+ internal_comp(Ps, File, ".S", Compile);
+ false ->
+ internal_comp(Ps, File, ".erl", Compile)
+ end
+ end
+ end.
+
+internal_comp(Passes, File, Suffix, St0) ->
+ Dir = filename:dirname(File),
+ Base = filename:basename(File, Suffix),
+ St1 = St0#compile{filename=File, dir=Dir, base=Base,
+ ifile=erlfile(Dir, Base, Suffix),
+ ofile=objfile(Base, St0)},
+ Run = case member(time, St1#compile.options) of
+ true ->
+ io:format("Compiling ~p\n", [File]),
+ fun run_tc/2;
+ false -> fun({_Name,Fun}, St) -> catch Fun(St) end
+ end,
+ case fold_comp(Passes, Run, St1) of
+ {ok,St2} -> comp_ret_ok(St2);
+ {error,St2} -> comp_ret_err(St2)
+ end.
+
+fold_comp([{delay,Ps0}|Passes], Run, #compile{options=Opts}=St) ->
+ Ps = select_passes(Ps0, Opts) ++ Passes,
+ fold_comp(Ps, Run, St);
+fold_comp([{Name,Test,Pass}|Ps], Run, St) ->
+ case Test(St) of
+ false -> %Pass is not needed.
+ fold_comp(Ps, Run, St);
+ true -> %Run pass in the usual way.
+ fold_comp([{Name,Pass}|Ps], Run, St)
+ end;
+fold_comp([{Name,Pass}|Ps], Run, St0) ->
+ case Run({Name,Pass}, St0) of
+ {ok,St1} -> fold_comp(Ps, Run, St1);
+ {error,_St1} = Error -> Error;
+ {'EXIT',Reason} ->
+ Es = [{St0#compile.ifile,[{none,?MODULE,{crash,Name,Reason}}]}],
+ {error,St0#compile{errors=St0#compile.errors ++ Es}};
+ Other ->
+ Es = [{St0#compile.ifile,[{none,?MODULE,{bad_return,Name,Other}}]}],
+ {error,St0#compile{errors=St0#compile.errors ++ Es}}
+ end;
+fold_comp([], _Run, St) -> {ok,St}.
+
+os_process_size() ->
+ case os:type() of
+ {unix, sunos} ->
+ Size = os:cmd("ps -o vsz -p " ++ os:getpid() ++ " | tail -1"),
+ list_to_integer(lib:nonl(Size));
+ _ ->
+ 0
+ end.
+
+run_tc({Name,Fun}, St) ->
+ Before0 = statistics(runtime),
+ Val = (catch Fun(St)),
+ After0 = statistics(runtime),
+ {Before_c, _} = Before0,
+ {After_c, _} = After0,
+ Mem0 = erts_debug:flat_size(Val)*erlang:system_info(wordsize),
+ Mem = lists:flatten(io_lib:format("~.1f kB", [Mem0/1024])),
+ Sz = lists:flatten(io_lib:format("~.1f MB", [os_process_size()/1024])),
+ io:format(" ~-30s: ~10.2f s ~12s ~10s\n",
+ [Name,(After_c-Before_c) / 1000,Mem,Sz]),
+ Val.
+
+comp_ret_ok(#compile{code=Code,warnings=Warn0,module=Mod,options=Opts}=St) ->
+ Warn = messages_per_file(Warn0),
+ report_warnings(St#compile{warnings = Warn}),
+ Ret1 = case member(binary, Opts) andalso not member(no_code_generation, Opts) of
+ true -> [Code];
+ false -> []
+ end,
+ Ret2 = case member(return_warnings, Opts) of
+ true -> Ret1 ++ [Warn];
+ false -> Ret1
+ end,
+ list_to_tuple([ok,Mod|Ret2]).
+
+comp_ret_err(#compile{warnings=Warn0,errors=Err0,options=Opts}=St) ->
+ Warn = messages_per_file(Warn0),
+ Err = messages_per_file(Err0),
+ report_errors(St#compile{errors=Err}),
+ report_warnings(St#compile{warnings=Warn}),
+ case member(return_errors, Opts) of
+ true -> {error,Err,Warn};
+ false -> error
+ end.
+
+%% messages_per_file([{File,[Message]}]) -> [{File,[Message]}]
+messages_per_file(Ms) ->
+ T = lists:sort([{File,M} || {File,Messages} <- Ms, M <- Messages]),
+ PrioMs = [erl_scan, epp, erl_parse],
+ {Prio0, Rest} =
+ lists:mapfoldl(fun(M, A) ->
+ lists:partition(fun({_,{_,Mod,_}}) -> Mod =:= M;
+ (_) -> false
+ end, A)
+ end, T, PrioMs),
+ Prio = lists:sort(fun({_,{L1,_,_}}, {_,{L2,_,_}}) -> L1 =< L2 end,
+ lists:append(Prio0)),
+ flatmap(fun mpf/1, [Prio, Rest]).
+
+mpf(Ms) ->
+ [{File,[M || {F,M} <- Ms, F =:= File]} ||
+ File <- lists:usort([F || {F,_} <- Ms])].
+
+%% passes(form|file, [Option]) -> [{Name,PassFun}]
+%% Figure out which passes that need to be run.
+
+passes(forms, Opts) ->
+ case member(from_core, Opts) of
+ true ->
+ select_passes(core_passes(), Opts);
+ false ->
+ select_passes(standard_passes(), Opts)
+ end;
+passes(file, Opts) ->
+ case member(from_beam, Opts) of
+ true ->
+ Ps = [?pass(read_beam_file)|binary_passes()],
+ select_passes(Ps, Opts);
+ false ->
+ Ps = case member(from_asm, Opts) orelse member(asm, Opts) of
+ true ->
+ [?pass(beam_consult_asm)|asm_passes()];
+ false ->
+ case member(from_core, Opts) of
+ true ->
+ [?pass(parse_core)|core_passes()];
+ false ->
+ [?pass(parse_module)|standard_passes()]
+ end
+ end,
+ Fs = select_passes(Ps, Opts),
+
+ %% If the last pass saves the resulting binary to a file,
+ %% insert a first pass to remove the file.
+ case last(Fs) of
+ {save_binary,_Fun} -> [?pass(remove_file)|Fs];
+ _Other -> Fs
+ end
+ end.
+
+%% select_passes([Command], Opts) -> [{Name,Function}]
+%% Interpret the lists of commands to return a pure list of passes.
+%%
+%% Command can be one of:
+%%
+%% {pass,Mod} Will be expanded to a call to the external
+%% function Mod:module(Code, Options). This
+%% function must transform the code and return
+%% {ok,NewCode} or {error,Term}.
+%% Example: {pass,beam_codegen}
+%%
+%% {Name,Fun} Name is an atom giving the name of the pass.
+%% Fun is an 'fun' taking one argument: a compile record.
+%% The fun should return {ok,NewCompileRecord} or
+%% {error,NewCompileRecord}.
+%% Note: ?pass(Name) is equvivalent to {Name,fun Name/1}.
+%% Example: ?pass(parse_module)
+%%
+%% {Name,Test,Fun} Like {Name,Fun} above, but the pass will be run
+%% (and listed by the `time' option) only if Test(St)
+%% returns true.
+%%
+%% {src_listing,Ext} Produces an Erlang source listing with the
+%% the file extension Ext. (Ext should not contain
+%% a period.) No more passes will be run.
+%%
+%% {listing,Ext} Produce an listing of the terms in the internal
+%% representation. The extension of the listing
+%% file will be Ext. (Ext should not contain
+%% a period.) No more passes will be run.
+%%
+%% {done,Ext} End compilation at this point. Produce a listing
+%% as with {listing,Ext}, unless 'binary' is
+%% specified, in which case the current
+%% representation of the code is returned without
+%% creating an output file.
+%%
+%% {iff,Flag,Cmd} If the given Flag is given in the option list,
+%% Cmd will be interpreted as a command.
+%% Otherwise, Cmd will be ignored.
+%% Example: {iff,dcg,{listing,"codegen}}
+%%
+%% {unless,Flag,Cmd} If the given Flag is NOT given in the option list,
+%% Cmd will be interpreted as a command.
+%% Otherwise, Cmd will be ignored.
+%% Example: {unless,no_kernopt,{pass,sys_kernopt}}
+%%
+
+select_passes([{pass,Mod}|Ps], Opts) ->
+ F = fun(St) ->
+ case catch Mod:module(St#compile.code, St#compile.options) of
+ {ok,Code} ->
+ {ok,St#compile{code=Code}};
+ {ok,Code,Ws} ->
+ {ok,St#compile{code=Code,warnings=St#compile.warnings++Ws}};
+ {error,Es} ->
+ {error,St#compile{errors=St#compile.errors ++ Es}}
+ end
+ end,
+ [{Mod,F}|select_passes(Ps, Opts)];
+select_passes([{src_listing,Ext}|_], _Opts) ->
+ [{listing,fun (St) -> src_listing(Ext, St) end}];
+select_passes([{listing,Ext}|_], _Opts) ->
+ [{listing,fun (St) -> listing(Ext, St) end}];
+select_passes([{done,Ext}|_], Opts) ->
+ select_passes([{unless,binary,{listing,Ext}}], Opts);
+select_passes([{iff,Flag,Pass}|Ps], Opts) ->
+ select_cond(Flag, true, Pass, Ps, Opts);
+select_passes([{unless,Flag,Pass}|Ps], Opts) ->
+ select_cond(Flag, false, Pass, Ps, Opts);
+select_passes([{_,Fun}=P|Ps], Opts) when is_function(Fun) ->
+ [P|select_passes(Ps, Opts)];
+select_passes([{delay,Passes0}|Ps], Opts) when is_list(Passes0) ->
+ %% Delay evaluation of compiler options and which compiler passes to run.
+ %% Since we must know beforehand whether a listing will be produced, we
+ %% will go through the list of passes and evaluate all conditions that
+ %% select a list pass.
+ case select_list_passes(Passes0, Opts) of
+ {done,Passes} ->
+ [{delay,Passes}];
+ {not_done,Passes} ->
+ [{delay,Passes}|select_passes(Ps, Opts)]
+ end;
+select_passes([{_,Test,Fun}=P|Ps], Opts) when is_function(Test),
+ is_function(Fun) ->
+ [P|select_passes(Ps, Opts)];
+select_passes([], _Opts) ->
+ [];
+select_passes([List|Ps], Opts) when is_list(List) ->
+ case select_passes(List, Opts) of
+ [] -> select_passes(Ps, Opts);
+ Nested ->
+ case last(Nested) of
+ {listing,_Fun} -> Nested;
+ _Other -> Nested ++ select_passes(Ps, Opts)
+ end
+ end.
+
+select_cond(Flag, ShouldBe, Pass, Ps, Opts) ->
+ ShouldNotBe = not ShouldBe,
+ case member(Flag, Opts) of
+ ShouldBe -> select_passes([Pass|Ps], Opts);
+ ShouldNotBe -> select_passes(Ps, Opts)
+ end.
+
+%% select_list_passes([Pass], Opts) -> {done,[Pass]} | {not_done,[Pass]}
+%% Evaluate all conditions having to do with listings in the list of
+%% passes.
+
+select_list_passes(Ps, Opts) ->
+ select_list_passes_1(Ps, Opts, []).
+
+select_list_passes_1([{iff,Flag,{listing,_}=Listing}|Ps], Opts, Acc) ->
+ case member(Flag, Opts) of
+ true -> {done,reverse(Acc, [Listing])};
+ false -> select_list_passes_1(Ps, Opts, Acc)
+ end;
+select_list_passes_1([{iff,Flag,{done,Ext}}|Ps], Opts, Acc) ->
+ case member(Flag, Opts) of
+ false ->
+ select_list_passes_1(Ps, Opts, Acc);
+ true ->
+ {done,case member(binary, Opts) of
+ false -> reverse(Acc, [{listing,Ext}]);
+ true -> reverse(Acc)
+ end}
+ end;
+select_list_passes_1([{iff=Op,Flag,List0}|Ps], Opts, Acc) when is_list(List0) ->
+ case select_list_passes(List0, Opts) of
+ {done,_}=Done -> Done;
+ {not_done,List} -> select_list_passes_1(Ps, Opts, [{Op,Flag,List}|Acc])
+ end;
+select_list_passes_1([{unless=Op,Flag,List0}|Ps], Opts, Acc) when is_list(List0) ->
+ case select_list_passes(List0, Opts) of
+ {done,_}=Done -> Done;
+ {not_done,List} -> select_list_passes_1(Ps, Opts, [{Op,Flag,List}|Acc])
+ end;
+select_list_passes_1([P|Ps], Opts, Acc) ->
+ select_list_passes_1(Ps, Opts, [P|Acc]);
+select_list_passes_1([], _, Acc) ->
+ {not_done,reverse(Acc)}.
+
+%% The standard passes (almost) always run.
+
+standard_passes() ->
+ [?pass(transform_module),
+ {iff,'dpp',{listing,"pp"}},
+ ?pass(lint_module),
+ {iff,'P',{src_listing,"P"}},
+ {iff,'to_pp',{done,"P"}},
+
+ {iff,'dabstr',{listing,"abstr"}},
+ {iff,debug_info,?pass(save_abstract_code)},
+
+ ?pass(expand_module),
+ {iff,'dexp',{listing,"expand"}},
+ {iff,'E',{src_listing,"E"}},
+ {iff,'to_exp',{done,"E"}},
+
+ %% Conversion to Core Erlang.
+ ?pass(core_module),
+ {iff,'dcore',{listing,"core"}},
+ {iff,'to_core0',{done,"core"}}
+ | core_passes()].
+
+core_passes() ->
+ %% Optimization and transforms of Core Erlang code.
+ [{delay,
+ [{unless,no_copt,
+ [{core_old_inliner,fun test_old_inliner/1,fun core_old_inliner/1},
+ {iff,doldinline,{listing,"oldinline"}},
+ ?pass(core_fold_module),
+ {core_inline_module,fun test_core_inliner/1,fun core_inline_module/1},
+ {iff,dinline,{listing,"inline"}},
+ {core_fold_after_inline,fun test_core_inliner/1,fun core_fold_module/1},
+ ?pass(core_transforms)]},
+ {iff,dcopt,{listing,"copt"}},
+ {iff,'to_core',{done,"core"}}]}
+ | kernel_passes()].
+
+kernel_passes() ->
+ %% Destructive setelement/3 optimization and core lint.
+ [{unless,no_constant_pool,?pass(core_dsetel_module)}, %Not safe without constant pool.
+ {iff,dsetel,{listing,"dsetel"}},
+
+ {iff,clint,?pass(core_lint_module)},
+ {iff,core,?pass(save_core_code)},
+
+ %% Kernel Erlang and code generation.
+ ?pass(kernel_module),
+ {iff,dkern,{listing,"kernel"}},
+ {iff,'to_kernel',{done,"kernel"}},
+ {pass,v3_life},
+ {iff,dlife,{listing,"life"}},
+ {pass,v3_codegen},
+ {iff,dcg,{listing,"codegen"}}
+ | asm_passes()].
+
+asm_passes() ->
+ %% Assembly level optimisations.
+ [{delay,
+ [{unless,no_postopt,
+ [{pass,beam_block},
+ {iff,dblk,{listing,"block"}},
+ {unless,no_bopt,{pass,beam_bool}},
+ {iff,dbool,{listing,"bool"}},
+ {unless,no_topt,{pass,beam_type}},
+ {iff,dtype,{listing,"type"}},
+ {pass,beam_dead}, %Must always run since it splits blocks.
+ {iff,ddead,{listing,"dead"}},
+ {unless,no_jopt,{pass,beam_jump}},
+ {iff,djmp,{listing,"jump"}},
+ {unless,no_peep_opt,{pass,beam_peep}},
+ {iff,dpeep,{listing,"peep"}},
+ {pass,beam_clean},
+ {iff,dclean,{listing,"clean"}},
+ {unless,no_bsm_opt,{pass,beam_bsm}},
+ {iff,dbsm,{listing,"bsm"}},
+ {unless,no_stack_trimming,{pass,beam_trim}},
+ {iff,dtrim,{listing,"trim"}},
+ {pass,beam_flatten}]},
+
+ %% If post optimizations are turned off, we still coalesce
+ %% adjacent labels and remove unused labels to keep the
+ %% HiPE compiler happy.
+ {iff,no_postopt,
+ [?pass(beam_unused_labels),
+ {pass,beam_clean}]},
+
+ {iff,dopt,{listing,"optimize"}},
+ {iff,'S',{listing,"S"}},
+ {iff,'to_asm',{done,"S"}}]},
+ {pass,beam_validator},
+ ?pass(beam_asm)
+ | binary_passes()].
+
+binary_passes() ->
+ [{native_compile,fun test_native/1,fun native_compile/1},
+ {unless,binary,?pass(save_binary)}].
+
+%%%
+%%% Compiler passes.
+%%%
+
+%% Remove the target file so we don't have an old one if the compilation fail.
+remove_file(St) ->
+ file:delete(St#compile.ofile),
+ {ok,St}.
+
+-record(asm_module, {module,
+ exports,
+ labels,
+ functions=[],
+ cfun,
+ code,
+ attributes=[]}).
+
+preprocess_asm_forms(Forms) ->
+ R = #asm_module{},
+ R1 = collect_asm(Forms, R),
+ {R1#asm_module.module,
+ {R1#asm_module.module,
+ R1#asm_module.exports,
+ R1#asm_module.attributes,
+ R1#asm_module.functions,
+ R1#asm_module.labels}}.
+
+collect_asm([], R) ->
+ case R#asm_module.cfun of
+ undefined ->
+ R;
+ {A,B,C} ->
+ R#asm_module{functions=R#asm_module.functions++
+ [{function,A,B,C,R#asm_module.code}]}
+ end;
+collect_asm([{module,M} | Rest], R) ->
+ collect_asm(Rest, R#asm_module{module=M});
+collect_asm([{exports,M} | Rest], R) ->
+ collect_asm(Rest, R#asm_module{exports=M});
+collect_asm([{labels,M} | Rest], R) ->
+ collect_asm(Rest, R#asm_module{labels=M});
+collect_asm([{function,A,B,C} | Rest], R) ->
+ R1 = case R#asm_module.cfun of
+ undefined ->
+ R;
+ {A0,B0,C0} ->
+ R#asm_module{functions=R#asm_module.functions++
+ [{function,A0,B0,C0,R#asm_module.code}]}
+ end,
+ collect_asm(Rest, R1#asm_module{cfun={A,B,C}, code=[]});
+collect_asm([{attributes, Attr} | Rest], R) ->
+ collect_asm(Rest, R#asm_module{attributes=Attr});
+collect_asm([X | Rest], R) ->
+ collect_asm(Rest, R#asm_module{code=R#asm_module.code++[X]}).
+
+beam_consult_asm(St) ->
+ case file:consult(St#compile.ifile) of
+ {ok, Forms0} ->
+ {Module, Forms} = preprocess_asm_forms(Forms0),
+ {ok,St#compile{module=Module, code=Forms}};
+ {error,E} ->
+ Es = [{St#compile.ifile,[{none,?MODULE,{open,E}}]}],
+ {error,St#compile{errors=St#compile.errors ++ Es}}
+ end.
+
+read_beam_file(St) ->
+ case file:read_file(St#compile.ifile) of
+ {ok,Beam} ->
+ Infile = St#compile.ifile,
+ case is_too_old(Infile) of
+ true ->
+ {ok,St#compile{module=none,code=none}};
+ false ->
+ Mod0 = filename:rootname(filename:basename(Infile)),
+ Mod = list_to_atom(Mod0),
+ {ok,St#compile{module=Mod,code=Beam,ofile=Infile}}
+ end;
+ {error,E} ->
+ Es = [{St#compile.ifile,[{none,?MODULE,{open,E}}]}],
+ {error,St#compile{errors=St#compile.errors ++ Es}}
+ end.
+
+is_too_old(BeamFile) ->
+ case beam_lib:chunks(BeamFile, ["CInf"]) of
+ {ok,{_,[{"CInf",Term0}]}} ->
+ Term = binary_to_term(Term0),
+ Opts = proplists:get_value(options, Term, []),
+ lists:member(no_new_funs, Opts);
+ _ -> false
+ end.
+
+parse_module(St) ->
+ Opts = St#compile.options,
+ Cwd = ".",
+ IncludePath = [Cwd, St#compile.dir|inc_paths(Opts)],
+ R = epp:parse_file(St#compile.ifile, IncludePath, pre_defs(Opts)),
+ case R of
+ {ok,Forms} ->
+ {ok,St#compile{code=Forms}};
+ {error,E} ->
+ Es = [{St#compile.ifile,[{none,?MODULE,{epp,E}}]}],
+ {error,St#compile{errors=St#compile.errors ++ Es}}
+ end.
+
+parse_core(St) ->
+ case file:read_file(St#compile.ifile) of
+ {ok,Bin} ->
+ case core_scan:string(binary_to_list(Bin)) of
+ {ok,Toks,_} ->
+ case core_parse:parse(Toks) of
+ {ok,Mod} ->
+ Name = (Mod#c_module.name)#c_literal.val,
+ {ok,St#compile{module=Name,code=Mod}};
+ {error,E} ->
+ Es = [{St#compile.ifile,[E]}],
+ {error,St#compile{errors=St#compile.errors ++ Es}}
+ end;
+ {error,E,_} ->
+ Es = [{St#compile.ifile,[E]}],
+ {error,St#compile{errors=St#compile.errors ++ Es}}
+ end;
+ {error,E} ->
+ Es = [{St#compile.ifile,[{none,compile,{open,E}}]}],
+ {error,St#compile{errors=St#compile.errors ++ Es}}
+ end.
+
+compile_options([{attribute,_L,compile,C}|Fs]) when is_list(C) ->
+ C ++ compile_options(Fs);
+compile_options([{attribute,_L,compile,C}|Fs]) ->
+ [C|compile_options(Fs)];
+compile_options([_F|Fs]) -> compile_options(Fs);
+compile_options([]) -> [].
+
+clean_parse_transforms(Fs) ->
+ clean_parse_transforms_1(Fs, []).
+
+clean_parse_transforms_1([{attribute,L,compile,C0}|Fs], Acc) when is_list(C0) ->
+ C = lists:filter(fun({parse_transform,_}) -> false;
+ (_) -> true
+ end, C0),
+ clean_parse_transforms_1(Fs, [{attribute,L,compile,C}|Acc]);
+clean_parse_transforms_1([{attribute,_,compile,{parse_transform,_}}|Fs], Acc) ->
+ clean_parse_transforms_1(Fs, Acc);
+clean_parse_transforms_1([F|Fs], Acc) ->
+ clean_parse_transforms_1(Fs, [F|Acc]);
+clean_parse_transforms_1([], Acc) -> reverse(Acc).
+
+transforms(Os) -> [ M || {parse_transform,M} <- Os ].
+
+transform_module(#compile{options=Opt,code=Code0}=St0) ->
+ %% Extract compile options from code into options field.
+ case transforms(Opt ++ compile_options(Code0)) of
+ [] -> {ok,St0}; %No parse transforms.
+ Ts ->
+ %% Remove parse_transform attributes from the abstract code to
+ %% prevent parse transforms to be run more than once.
+ Code = clean_parse_transforms(Code0),
+ St = St0#compile{code=Code},
+ foldl_transform(St, Ts)
+ end.
+
+foldl_transform(St, [T|Ts]) ->
+ Name = "transform " ++ atom_to_list(T),
+ Fun = fun(S) -> T:parse_transform(S#compile.code, S#compile.options) end,
+ Run = case member(time, St#compile.options) of
+ true -> fun run_tc/2;
+ false -> fun({_Name,F}, S) -> catch F(S) end
+ end,
+ case Run({Name, Fun}, St) of
+ {error,Es,Ws} ->
+ {error,St#compile{warnings=St#compile.warnings ++ Ws,
+ errors=St#compile.errors ++ Es}};
+ {'EXIT',R} ->
+ Es = [{St#compile.ifile,[{none,compile,{parse_transform,T,R}}]}],
+ {error,St#compile{errors=St#compile.errors ++ Es}};
+ Forms ->
+ foldl_transform(St#compile{code=Forms}, Ts)
+ end;
+foldl_transform(St, []) -> {ok,St}.
+
+get_core_transforms(Opts) -> [M || {core_transform,M} <- Opts].
+
+core_transforms(St) ->
+ %% The options field holds the complete list of options at this
+
+ Ts = get_core_transforms(St#compile.options),
+ foldl_core_transforms(St, Ts).
+
+foldl_core_transforms(St, [T|Ts]) ->
+ Name = "core transform " ++ atom_to_list(T),
+ Fun = fun(S) -> T:core_transform(S#compile.code, S#compile.options) end,
+ Run = case member(time, St#compile.options) of
+ true -> fun run_tc/2;
+ false -> fun({_Name,F}, S) -> catch F(S) end
+ end,
+ case Run({Name, Fun}, St) of
+ {'EXIT',R} ->
+ Es = [{St#compile.ifile,[{none,compile,{core_transform,T,R}}]}],
+ {error,St#compile{errors=St#compile.errors ++ Es}};
+ Forms ->
+ foldl_core_transforms(St#compile{code=Forms}, Ts)
+ end;
+foldl_core_transforms(St, []) -> {ok,St}.
+
+%%% Fetches the module name from a list of forms. The module attribute must
+%%% be present.
+get_module([{attribute,_,module,{M,_As}} | _]) -> M;
+get_module([{attribute,_,module,M} | _]) -> M;
+get_module([_ | Rest]) ->
+ get_module(Rest).
+
+%%% A #compile state is returned, where St.base has been filled in
+%%% with the module name from Forms, as a string, in case it wasn't
+%%% set in St (i.e., it was "").
+add_default_base(St, Forms) ->
+ F = St#compile.filename,
+ case F of
+ "" ->
+ M = case get_module(Forms) of
+ PackageModule when is_list(PackageModule) -> last(PackageModule);
+ M0 -> M0
+ end,
+ St#compile{base = atom_to_list(M)};
+ _ ->
+ St
+ end.
+
+lint_module(St) ->
+ case erl_lint:module(St#compile.code,
+ St#compile.ifile, St#compile.options) of
+ {ok,Ws} ->
+ %% Insert name of module as base name, if needed. This is
+ %% for compile:forms to work with listing files.
+ St1 = add_default_base(St, St#compile.code),
+ {ok,St1#compile{warnings=St1#compile.warnings ++ Ws}};
+ {error,Es,Ws} ->
+ {error,St#compile{warnings=St#compile.warnings ++ Ws,
+ errors=St#compile.errors ++ Es}}
+ end.
+
+core_lint_module(St) ->
+ case core_lint:module(St#compile.code, St#compile.options) of
+ {ok,Ws} ->
+ {ok,St#compile{warnings=St#compile.warnings ++ Ws}};
+ {error,Es,Ws} ->
+ {error,St#compile{warnings=St#compile.warnings ++ Ws,
+ errors=St#compile.errors ++ Es}}
+ end.
+
+%% expand_module(State) -> State'
+%% Do the common preprocessing of the input forms.
+
+expand_module(#compile{code=Code,options=Opts0}=St0) ->
+ {Mod,Exp,Forms,Opts1} = sys_pre_expand:module(Code, Opts0),
+ Opts = expand_opts(Opts1),
+ {ok,St0#compile{module=Mod,options=Opts,code={Mod,Exp,Forms}}}.
+
+core_module(#compile{code=Code0,options=Opts}=St) ->
+ case v3_core:module(Code0, Opts) of
+ {ok,Code,Ws} ->
+ {ok,St#compile{code=Code,warnings=St#compile.warnings ++ Ws}};
+ {error,Es,Ws} ->
+ {error,St#compile{warnings=St#compile.warnings ++ Ws,
+ errors=St#compile.errors ++ Es}}
+ end.
+
+core_fold_module(#compile{code=Code0,options=Opts,warnings=Warns}=St) ->
+ {ok,Code,Ws} = sys_core_fold:module(Code0, Opts),
+ {ok,St#compile{code=Code,warnings=Warns ++ Ws}}.
+
+test_old_inliner(#compile{options=Opts}) ->
+ %% The point of this test is to avoid loading the old inliner
+ %% if we know that it will not be used.
+ any(fun({inline,_}) -> true;
+ (_) -> false
+ end, Opts).
+
+test_core_inliner(#compile{options=Opts}) ->
+ case any(fun(no_inline) -> true;
+ (_) -> false
+ end, Opts) of
+ true -> false;
+ false ->
+ any(fun(inline) -> true;
+ (_) -> false
+ end, Opts)
+ end.
+
+core_old_inliner(#compile{code=Code0,options=Opts}=St) ->
+ {ok,Code} = sys_core_inline:module(Code0, Opts),
+ {ok,St#compile{code=Code}}.
+
+core_inline_module(#compile{code=Code0,options=Opts}=St) ->
+ Code = cerl_inline:core_transform(Code0, Opts),
+ {ok,St#compile{code=Code}}.
+
+core_dsetel_module(#compile{code=Code0,options=Opts}=St) ->
+ {ok,Code} = sys_core_dsetel:module(Code0, Opts),
+ {ok,St#compile{code=Code}}.
+
+kernel_module(#compile{code=Code0,options=Opts}=St) ->
+ {ok,Code,Ws} = v3_kernel:module(Code0, Opts),
+ {ok,St#compile{code=Code,warnings=St#compile.warnings ++ Ws}}.
+
+save_abstract_code(#compile{ifile=File}=St) ->
+ case abstract_code(St) of
+ {ok,Code} ->
+ {ok,St#compile{abstract_code=Code}};
+ {error,Es} ->
+ {error,St#compile{errors=St#compile.errors ++ [{File,Es}]}}
+ end.
+
+abstract_code(#compile{code=Code,options=Opts,ofile=OFile}) ->
+ Abstr = erlang:term_to_binary({raw_abstract_v1,Code}, [compressed]),
+ case member(encrypt_debug_info, Opts) of
+ true ->
+ case keyfind(debug_info_key, 1, Opts) of
+ {_,Key} ->
+ encrypt_abs_code(Abstr, Key);
+ false ->
+ %% Note: #compile.module has not been set yet.
+ %% Here is an approximation that should work for
+ %% all valid cases.
+ Module = list_to_atom(filename:rootname(filename:basename(OFile))),
+ Mode = proplists:get_value(crypto_mode, Opts, des3_cbc),
+ case beam_lib:get_crypto_key({debug_info, Mode, Module, OFile}) of
+ error ->
+ {error, [{none,?MODULE,no_crypto_key}]};
+ Key ->
+ encrypt_abs_code(Abstr, {Mode, Key})
+ end
+ end;
+ false ->
+ {ok, Abstr}
+ end.
+
+encrypt_abs_code(Abstr, Key0) ->
+ try
+ {Mode,RealKey} = generate_key(Key0),
+ case start_crypto() of
+ ok -> {ok,encrypt(Mode, RealKey, Abstr)};
+ {error,_}=E -> E
+ end
+ catch
+ error:_ ->
+ {error,[{none,?MODULE,bad_crypto_key}]}
+ end.
+
+start_crypto() ->
+ try crypto:start() of
+ {error,{already_started,crypto}} -> ok;
+ ok -> ok
+ catch
+ error:_ ->
+ {error,[{none,?MODULE,no_crypto}]}
+ end.
+
+generate_key({Mode,String}) when is_atom(Mode), is_list(String) ->
+ {Mode,beam_lib:make_crypto_key(Mode, String)};
+generate_key(String) when is_list(String) ->
+ generate_key({des3_cbc,String}).
+
+encrypt(des3_cbc=Mode, {K1,K2,K3, IVec}, Bin0) ->
+ Bin1 = case byte_size(Bin0) rem 8 of
+ 0 -> Bin0;
+ N -> list_to_binary([Bin0,random_bytes(8-N)])
+ end,
+ Bin = crypto:des3_cbc_encrypt(K1, K2, K3, IVec, Bin1),
+ ModeString = atom_to_list(Mode),
+ list_to_binary([0,length(ModeString),ModeString,Bin]).
+
+random_bytes(N) ->
+ {A,B,C} = now(),
+ random:seed(A, B, C),
+ random_bytes_1(N, []).
+
+random_bytes_1(0, Acc) -> Acc;
+random_bytes_1(N, Acc) -> random_bytes_1(N-1, [random:uniform(255)|Acc]).
+
+save_core_code(St) ->
+ {ok,St#compile{core_code=cerl:from_records(St#compile.code)}}.
+
+beam_unused_labels(#compile{code=Code0}=St) ->
+ Code = beam_jump:module_labels(Code0),
+ {ok,St#compile{code=Code}}.
+
+beam_asm(#compile{ifile=File,code=Code0,abstract_code=Abst,options=Opts0}=St) ->
+ Source = filename:absname(File),
+ Opts1 = lists:map(fun({debug_info_key,_}) -> {debug_info_key,'********'};
+ (Other) -> Other
+ end, Opts0),
+ Opts2 = [O || O <- Opts1, is_informative_option(O)],
+ case beam_asm:module(Code0, Abst, Source, Opts2) of
+ {ok,Code} -> {ok,St#compile{code=Code,abstract_code=[]}}
+ end.
+
+test_native(#compile{options=Opts}) ->
+ %% This test is done late, in case some other option has turned off native.
+ member(native, Opts).
+
+native_compile(#compile{code=none}=St) -> {ok,St};
+native_compile(St) ->
+ case erlang:system_info(hipe_architecture) of
+ undefined ->
+ Ws = [{St#compile.ifile,[{none,compile,no_native_support}]}],
+ {ok,St#compile{warnings=St#compile.warnings ++ Ws}};
+ _ ->
+ native_compile_1(St)
+ end.
+
+native_compile_1(St) ->
+ Opts0 = St#compile.options,
+ IgnoreErrors = member(ignore_native_errors, Opts0),
+ Opts = case keyfind(hipe, 1, Opts0) of
+ {hipe,L} when is_list(L) -> L;
+ {hipe,X} -> [X];
+ _ -> []
+ end,
+ try hipe:compile(St#compile.module,
+ St#compile.core_code,
+ St#compile.code,
+ Opts) of
+ {ok, {_Type,Bin} = T} when is_binary(Bin) ->
+ {ok, embed_native_code(St, T)};
+ {error, R} ->
+ case IgnoreErrors of
+ true ->
+ Ws = [{St#compile.ifile,[{none,?MODULE,{native,R}}]}],
+ {ok, St#compile{warnings=St#compile.warnings ++ Ws}};
+ false ->
+ Es = [{St#compile.ifile,[{none,?MODULE,{native,R}}]}],
+ {error, St#compile{errors=St#compile.errors ++ Es}}
+ end
+ catch
+ error:R ->
+ case IgnoreErrors of
+ true ->
+ Ws = [{St#compile.ifile,[{none,?MODULE,{native_crash,R}}]}],
+ {ok, St#compile{warnings=St#compile.warnings ++ Ws}};
+ false ->
+ exit(R)
+ end
+ end.
+
+embed_native_code(St, {Architecture,NativeCode}) ->
+ {ok, _, Chunks0} = beam_lib:all_chunks(St#compile.code),
+ ChunkName = hipe_unified_loader:chunk_name(Architecture),
+ Chunks1 = lists:keydelete(ChunkName, 1, Chunks0),
+ Chunks = Chunks1 ++ [{ChunkName,NativeCode}],
+ {ok, BeamPlusNative} = beam_lib:build_module(Chunks),
+ St#compile{code=BeamPlusNative}.
+
+%% Returns true if the option is informative and therefore should be included
+%% in the option list of the compiled module.
+
+is_informative_option(beam) -> false;
+is_informative_option(report_warnings) -> false;
+is_informative_option(report_errors) -> false;
+is_informative_option(binary) -> false;
+is_informative_option(verbose) -> false;
+is_informative_option(_) -> true.
+
+save_binary(#compile{code=none}=St) -> {ok,St};
+save_binary(#compile{module=Mod,ofile=Outfile,
+ options=Opts}=St) ->
+ %% Test that the module name and output file name match.
+ %% We must take care to not completely break a packaged module
+ %% (even though packages still is as an experimental, unsupported
+ %% feature) - so we will extract the last part of a packaged
+ %% module name and compare only that.
+ case member(no_error_module_mismatch, Opts) of
+ true ->
+ save_binary_1(St);
+ false ->
+ Base = filename:rootname(filename:basename(Outfile)),
+ case lists:last(packages:split(Mod)) of
+ Base ->
+ save_binary_1(St);
+ _ ->
+ Es = [{St#compile.ofile,
+ [{?MODULE,{module_name,Mod,Base}}]}],
+ {error,St#compile{errors=St#compile.errors ++ Es}}
+ end
+ end.
+
+save_binary_1(St) ->
+ Ofile = St#compile.ofile,
+ Tfile = tmpfile(Ofile), %Temp working file
+ case write_binary(Tfile, St#compile.code, St) of
+ ok ->
+ case file:rename(Tfile, Ofile) of
+ ok ->
+ {ok,St};
+ {error,RenameError} ->
+ Es0 = [{Ofile,[{?MODULE,{rename,Tfile,Ofile,
+ RenameError}}]}],
+ Es = case file:delete(Tfile) of
+ ok -> Es0;
+ {error,DeleteError} ->
+ Es0 ++
+ [{Ofile,
+ [{?MODULE,{delete_temp,Tfile,
+ DeleteError}}]}]
+ end,
+ {error,St#compile{errors=St#compile.errors ++ Es}}
+ end;
+ {error,_Error} ->
+ Es = [{Tfile,[{compile,write_error}]}],
+ {error,St#compile{errors=St#compile.errors ++ Es}}
+ end.
+
+write_binary(Name, Bin, St) ->
+ Opts = case member(compressed, St#compile.options) of
+ true -> [compressed];
+ false -> []
+ end,
+ case file:write_file(Name, Bin, Opts) of
+ ok -> ok;
+ {error,_}=Error -> Error
+ end.
+
+%% report_errors(State) -> ok
+%% report_warnings(State) -> ok
+
+report_errors(St) ->
+ case member(report_errors, St#compile.options) of
+ true ->
+ foreach(fun ({{F,_L},Eds}) -> list_errors(F, Eds);
+ ({F,Eds}) -> list_errors(F, Eds) end,
+ St#compile.errors);
+ false -> ok
+ end.
+
+report_warnings(#compile{options=Opts,warnings=Ws0}) ->
+ case member(report_warnings, Opts) of
+ true ->
+ Ws1 = flatmap(fun({{F,_L},Eds}) -> format_message(F, Eds);
+ ({F,Eds}) -> format_message(F, Eds) end,
+ Ws0),
+ Ws = lists:sort(Ws1),
+ foreach(fun({_,Str}) -> io:put_chars(Str) end, Ws);
+ false -> ok
+ end.
+
+format_message(F, [{{Line,Column}=Loc,Mod,E}|Es]) ->
+ M = {{F,Loc},io_lib:format("~s:~w:~w Warning: ~s\n",
+ [F,Line,Column,Mod:format_error(E)])},
+ [M|format_message(F, Es)];
+format_message(F, [{Line,Mod,E}|Es]) ->
+ M = {{F,{Line,0}},io_lib:format("~s:~w: Warning: ~s\n",
+ [F,Line,Mod:format_error(E)])},
+ [M|format_message(F, Es)];
+format_message(F, [{Mod,E}|Es]) ->
+ M = {none,io_lib:format("~s: Warning: ~s\n", [F,Mod:format_error(E)])},
+ [M|format_message(F, Es)];
+format_message(_, []) -> [].
+
+%% list_errors(File, ErrorDescriptors) -> ok
+
+list_errors(F, [{{Line,Column},Mod,E}|Es]) ->
+ io:fwrite("~s:~w:~w: ~s\n", [F,Line,Column,Mod:format_error(E)]),
+ list_errors(F, Es);
+list_errors(F, [{Line,Mod,E}|Es]) ->
+ io:fwrite("~s:~w: ~s\n", [F,Line,Mod:format_error(E)]),
+ list_errors(F, Es);
+list_errors(F, [{Mod,E}|Es]) ->
+ io:fwrite("~s: ~s\n", [F,Mod:format_error(E)]),
+ list_errors(F, Es);
+list_errors(_F, []) -> ok.
+
+%% erlfile(Dir, Base) -> ErlFile
+%% outfile(Base, Extension, Options) -> OutputFile
+%% objfile(Base, Target, Options) -> ObjFile
+%% tmpfile(ObjFile) -> TmpFile
+%% Work out the correct input and output file names.
+
+iofile(File) when is_atom(File) ->
+ iofile(atom_to_list(File));
+iofile(File) ->
+ {filename:dirname(File), filename:basename(File, ".erl")}.
+
+erlfile(Dir, Base, Suffix) ->
+ filename:join(Dir, Base ++ Suffix).
+
+outfile(Base, Ext, Opts) when is_atom(Ext) ->
+ outfile(Base, atom_to_list(Ext), Opts);
+outfile(Base, Ext, Opts) ->
+ Obase = case keyfind(outdir, 1, Opts) of
+ {outdir, Odir} -> filename:join(Odir, Base);
+ _Other -> Base % Not found or bad format
+ end,
+ Obase ++ "." ++ Ext.
+
+objfile(Base, St) ->
+ outfile(Base, "beam", St#compile.options).
+
+tmpfile(Ofile) ->
+ reverse([$#|tl(reverse(Ofile))]).
+
+%% pre_defs(Options)
+%% inc_paths(Options)
+%% Extract the predefined macros and include paths from the option list.
+
+pre_defs([{d,M,V}|Opts]) ->
+ [{M,V}|pre_defs(Opts)];
+pre_defs([{d,M}|Opts]) ->
+ [M|pre_defs(Opts)];
+pre_defs([_|Opts]) ->
+ pre_defs(Opts);
+pre_defs([]) -> [].
+
+inc_paths(Opts) ->
+ [ P || {i,P} <- Opts, is_list(P) ].
+
+src_listing(Ext, St) ->
+ listing(fun (Lf, {_Mod,_Exp,Fs}) -> do_src_listing(Lf, Fs);
+ (Lf, Fs) -> do_src_listing(Lf, Fs) end,
+ Ext, St).
+
+do_src_listing(Lf, Fs) ->
+ foreach(fun (F) -> io:put_chars(Lf, [erl_pp:form(F),"\n"]) end,
+ Fs).
+
+listing(Ext, St) ->
+ listing(fun(Lf, Fs) -> beam_listing:module(Lf, Fs) end, Ext, St).
+
+listing(LFun, Ext, St) ->
+ Lfile = outfile(St#compile.base, Ext, St#compile.options),
+ case file:open(Lfile, [write,delayed_write]) of
+ {ok,Lf} ->
+ Code = restore_expanded_types(Ext, St#compile.code),
+ LFun(Lf, Code),
+ ok = file:close(Lf),
+ {ok,St};
+ {error,_Error} ->
+ Es = [{Lfile,[{none,compile,write_error}]}],
+ {error,St#compile{errors=St#compile.errors ++ Es}}
+ end.
+
+restore_expanded_types("P", Fs) ->
+ epp:restore_typed_record_fields(Fs);
+restore_expanded_types("E", {M,I,Fs0}) ->
+ Fs1 = restore_expand_module(Fs0),
+ Fs = epp:restore_typed_record_fields(Fs1),
+ {M,I,Fs};
+restore_expanded_types(_Ext, Code) -> Code.
+
+restore_expand_module([{attribute,Line,type,[Type]}|Fs]) ->
+ [{attribute,Line,type,Type}|restore_expand_module(Fs)];
+restore_expand_module([{attribute,Line,opaque,[Type]}|Fs]) ->
+ [{attribute,Line,opaque,Type}|restore_expand_module(Fs)];
+restore_expand_module([{attribute,Line,spec,[Arg]}|Fs]) ->
+ [{attribute,Line,spec,Arg}|restore_expand_module(Fs)];
+restore_expand_module([F|Fs]) ->
+ [F|restore_expand_module(Fs)];
+restore_expand_module([]) -> [].
+
+
+-spec options() -> 'ok'.
+
+options() ->
+ help(standard_passes()).
+
+help([{delay,Ps}|T]) ->
+ help(Ps),
+ help(T);
+help([{iff,Flag,{src_listing,Ext}}|T]) ->
+ io:fwrite("~p - Generate .~s source listing file\n", [Flag,Ext]),
+ help(T);
+help([{iff,Flag,{listing,Ext}}|T]) ->
+ io:fwrite("~p - Generate .~s file\n", [Flag,Ext]),
+ help(T);
+help([{iff,Flag,{Name,Fun}}|T]) when is_function(Fun) ->
+ io:fwrite("~p - Run ~s\n", [Flag,Name]),
+ help(T);
+help([{iff,_Flag,Action}|T]) ->
+ help(Action),
+ help(T);
+help([{unless,Flag,{pass,Pass}}|T]) ->
+ io:fwrite("~p - Skip the ~s pass\n", [Flag,Pass]),
+ help(T);
+help([{unless,no_postopt=Flag,List}|T]) when is_list(List) ->
+ %% Hard-coded knowledge here.
+ io:fwrite("~p - Skip all post optimisation\n", [Flag]),
+ help(List),
+ help(T);
+help([{unless,_Flag,Action}|T]) ->
+ help(Action),
+ help(T);
+help([_|T]) ->
+ help(T);
+help(_) ->
+ ok.
+
+
+%% compile(AbsFileName, Outfilename, Options)
+%% Compile entry point for erl_compile.
+
+compile(File0, _OutFile, Options) ->
+ File = shorten_filename(File0),
+ case file(File, make_erl_options(Options)) of
+ {ok,_Mod} -> ok;
+ Other -> Other
+ end.
+
+compile_beam(File0, _OutFile, Opts) ->
+ File = shorten_filename(File0),
+ case file(File, [from_beam|make_erl_options(Opts)]) of
+ {ok,_Mod} -> ok;
+ Other -> Other
+ end.
+
+compile_asm(File0, _OutFile, Opts) ->
+ File = shorten_filename(File0),
+ case file(File, [asm|make_erl_options(Opts)]) of
+ {ok,_Mod} -> ok;
+ Other -> Other
+ end.
+
+compile_core(File0, _OutFile, Opts) ->
+ File = shorten_filename(File0),
+ case file(File, [from_core|make_erl_options(Opts)]) of
+ {ok,_Mod} -> ok;
+ Other -> Other
+ end.
+
+shorten_filename(Name0) ->
+ {ok,Cwd} = file:get_cwd(),
+ case lists:prefix(Cwd, Name0) of
+ false -> Name0;
+ true ->
+ case lists:nthtail(length(Cwd), Name0) of
+ "/"++N -> N;
+ N -> N
+ end
+ end.
+
+%% Converts generic compiler options to specific options.
+
+make_erl_options(Opts) ->
+ #options{includes=Includes,
+ defines=Defines,
+ outdir=Outdir,
+ warning=Warning,
+ verbose=Verbose,
+ specific=Specific,
+ output_type=OutputType,
+ cwd=Cwd} = Opts,
+ Options = [verbose || Verbose] ++
+ [report_warnings || Warning =/= 0] ++
+ map(fun ({Name,Value}) ->
+ {d,Name,Value};
+ (Name) ->
+ {d,Name}
+ end, Defines) ++
+ case OutputType of
+ undefined -> [];
+ jam -> [jam];
+ beam -> [beam];
+ native -> [native]
+ end,
+ Options ++ [report_errors, {cwd, Cwd}, {outdir, Outdir}|
+ [{i, Dir} || Dir <- Includes]] ++ Specific.
diff --git a/lib/compiler/src/compiler.app.src b/lib/compiler/src/compiler.app.src
new file mode 100644
index 0000000000..b0311365c4
--- /dev/null
+++ b/lib/compiler/src/compiler.app.src
@@ -0,0 +1,66 @@
+% This is an -*- erlang -*- file.
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1997-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%
+
+{application, compiler,
+ [{description, "ERTS CXC 138 10"},
+ {vsn, "%VSN%"},
+ {modules, [
+ beam_asm,
+ beam_block,
+ beam_bool,
+ beam_bsm,
+ beam_clean,
+ beam_dead,
+ beam_dict,
+ beam_disasm,
+ beam_flatten,
+ beam_jump,
+ beam_listing,
+ beam_opcodes,
+ beam_peep,
+ beam_trim,
+ beam_type,
+ beam_utils,
+ beam_validator,
+ cerl,
+ cerl_clauses,
+ cerl_inline,
+ cerl_trees,
+ compile,
+ core_scan,
+ core_lint,
+ core_parse,
+ core_pp,
+ core_lib,
+ erl_bifs,
+ rec_env,
+ sys_core_dsetel,
+ sys_core_fold,
+ sys_core_inline,
+ sys_expand_pmod,
+ sys_pre_attributes,
+ sys_pre_expand,
+ v3_codegen,
+ v3_core,
+ v3_kernel,
+ v3_kernel_pp,
+ v3_life
+ ]},
+ {registered, []},
+ {applications, [kernel, stdlib]},
+ {env, []}]}.
diff --git a/lib/compiler/src/compiler.appup.src b/lib/compiler/src/compiler.appup.src
new file mode 100644
index 0000000000..54a63833e6
--- /dev/null
+++ b/lib/compiler/src/compiler.appup.src
@@ -0,0 +1 @@
+{"%VSN%",[],[]}.
diff --git a/lib/compiler/src/core_lib.erl b/lib/compiler/src/core_lib.erl
new file mode 100644
index 0000000000..824be9ff7f
--- /dev/null
+++ b/lib/compiler/src/core_lib.erl
@@ -0,0 +1,229 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2000-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%
+%%
+%% Purpose: Core Erlang abstract syntax functions.
+
+-module(core_lib).
+
+-export([get_anno/1,set_anno/2]).
+-export([is_literal/1,is_literal_list/1]).
+-export([literal_value/1]).
+-export([make_values/1]).
+-export([is_var_used/2]).
+
+-include("core_parse.hrl").
+
+%%
+%% Generic get/set annotation that should be used only with cerl() structures.
+%%
+-spec get_anno(cerl:cerl()) -> term().
+
+get_anno(C) -> element(2, C).
+
+-spec set_anno(cerl:cerl(), term()) -> cerl:cerl().
+
+set_anno(C, A) -> setelement(2, C, A).
+
+-spec is_literal(cerl:cerl()) -> boolean().
+
+is_literal(#c_literal{}) -> true;
+is_literal(#c_cons{hd=H,tl=T}) ->
+ is_literal(H) andalso is_literal(T);
+is_literal(#c_tuple{es=Es}) -> is_literal_list(Es);
+is_literal(#c_binary{segments=Es}) -> is_lit_bin(Es);
+is_literal(_) -> false.
+
+-spec is_literal_list([cerl:cerl()]) -> boolean().
+
+is_literal_list(Es) -> lists:all(fun is_literal/1, Es).
+
+is_lit_bin(Es) ->
+ lists:all(fun (#c_bitstr{val=E,size=S}) ->
+ is_literal(E) andalso is_literal(S)
+ end, Es).
+
+%% Return the value of LitExpr.
+-spec literal_value(cerl:c_literal() | cerl:c_binary() |
+ cerl:c_cons() | cerl:c_tuple()) -> term().
+
+literal_value(#c_literal{val=V}) -> V;
+literal_value(#c_binary{segments=Es}) ->
+ list_to_binary([literal_value_bin(Bit) || Bit <- Es]);
+literal_value(#c_cons{hd=H,tl=T}) ->
+ [literal_value(H)|literal_value(T)];
+literal_value(#c_tuple{es=Es}) ->
+ list_to_tuple(literal_value_list(Es)).
+
+literal_value_list(Vals) -> [literal_value(V) || V <- Vals].
+
+literal_value_bin(#c_bitstr{val=Val,size=Sz,unit=U,type=T,flags=Fs}) ->
+ %% We will only handle literals constructed by make_literal/1.
+ %% Could be made more general in the future if the need arises.
+ 8 = literal_value(Sz),
+ 1 = literal_value(U),
+ integer = literal_value(T),
+ [unsigned,big] = literal_value(Fs),
+ literal_value(Val).
+
+%% Make a suitable values structure, expr or values, depending on Expr.
+-spec make_values([cerl:cerl()] | cerl:cerl()) -> cerl:cerl().
+
+make_values([E]) -> E;
+make_values([H|_]=Es) -> #c_values{anno=get_anno(H),es=Es};
+make_values([]) -> #c_values{es=[]};
+make_values(E) -> E.
+
+%% Test if the variable VarName is used in Expr.
+-spec is_var_used(cerl:var_name(), cerl:cerl()) -> boolean().
+
+is_var_used(V, B) -> vu_expr(V, B).
+
+vu_expr(V, #c_values{es=Es}) ->
+ vu_expr_list(V, Es);
+vu_expr(V, #c_var{name=V2}) -> V =:= V2;
+vu_expr(V, #c_alias{var=V2,pat=Pat}) ->
+ %% XXX Must handle aliases in expressions because of sys_core_fold:kill_types/2,
+ %% that uses a pattern as if it was an expression.
+ V =:= V2 orelse vu_expr(V, Pat);
+vu_expr(_, #c_literal{}) -> false;
+vu_expr(V, #c_cons{hd=H,tl=T}) ->
+ vu_expr(V, H) orelse vu_expr(V, T);
+vu_expr(V, #c_tuple{es=Es}) ->
+ vu_expr_list(V, Es);
+vu_expr(V, #c_binary{segments=Ss}) ->
+ vu_seg_list(V, Ss);
+vu_expr(V, #c_fun{vars=Vs,body=B}) ->
+ %% Variables in fun shadow previous variables
+ case vu_var_list(V, Vs) of
+ true -> false;
+ false -> vu_expr(V, B)
+ end;
+vu_expr(V, #c_let{vars=Vs,arg=Arg,body=B}) ->
+ case vu_expr(V, Arg) of
+ true -> true;
+ false ->
+ %% Variables in let shadow previous variables.
+ case vu_var_list(V, Vs) of
+ true -> false;
+ false -> vu_expr(V, B)
+ end
+ end;
+vu_expr(V, #c_letrec{defs=Fs,body=B}) ->
+ lists:any(fun ({_,Fb}) -> vu_expr(V, Fb) end, Fs) orelse vu_expr(V, B);
+vu_expr(V, #c_seq{arg=Arg,body=B}) ->
+ vu_expr(V, Arg) orelse vu_expr(V, B);
+vu_expr(V, #c_case{arg=Arg,clauses=Cs}) ->
+ vu_expr(V, Arg) orelse vu_clauses(V, Cs);
+vu_expr(V, #c_receive{clauses=Cs,timeout=T,action=A}) ->
+ vu_clauses(V, Cs) orelse vu_expr(V, T) orelse vu_expr(V, A);
+vu_expr(V, #c_apply{op=Op,args=As}) ->
+ vu_expr_list(V, [Op|As]);
+vu_expr(V, #c_call{module=M,name=N,args=As}) ->
+ vu_expr_list(V, [M,N|As]);
+vu_expr(V, #c_primop{args=As}) -> %Name is an atom
+ vu_expr_list(V, As);
+vu_expr(V, #c_catch{body=B}) ->
+ vu_expr(V, B);
+vu_expr(V, #c_try{arg=E,vars=Vs,body=B,evars=Evs,handler=H}) ->
+ case vu_expr(V, E) of
+ true -> true;
+ false ->
+ %% Variables shadow previous ones.
+ case case vu_var_list(V, Vs) of
+ true -> false;
+ false -> vu_expr(V, B)
+ end of
+ true -> true;
+ false ->
+ case vu_var_list(V, Evs) of
+ true -> false;
+ false -> vu_expr(V, H)
+ end
+ end
+ end.
+
+vu_expr_list(V, Es) ->
+ lists:any(fun(E) -> vu_expr(V, E) end, Es).
+
+vu_seg_list(V, Ss) ->
+ lists:any(fun (#c_bitstr{val=Val,size=Size}) ->
+ vu_expr(V, Val) orelse vu_expr(V, Size)
+ end, Ss).
+
+%% Have to get the pattern results right.
+
+-spec vu_clause(cerl:var_name(), cerl:c_clause()) -> boolean().
+
+vu_clause(V, #c_clause{pats=Ps,guard=G,body=B}) ->
+ case vu_pattern_list(V, Ps) of
+ {true,_Shad} -> true; %It is used
+ {false,true} -> false; %Shadowed
+ {false,false} -> %Not affected
+ %% Neither used nor shadowed. Check guard and body.
+ vu_expr(V, G) orelse vu_expr(V, B)
+ end.
+
+-spec vu_clauses(cerl:var_name(), [cerl:c_clause()]) -> boolean().
+
+vu_clauses(V, Cs) ->
+ lists:any(fun(C) -> vu_clause(V, C) end, Cs).
+
+%% vu_pattern(VarName, Pattern) -> {Used,Shadow}.
+%% vu_pattern_list(VarName, [Pattern]) -> {Used,Shadow}.
+%% Binaries complicate patterns as a variable can both be properly
+%% used, in a bit segment size, and shadow. They can also do both.
+
+%% vu_pattern(V, Pat) -> vu_pattern(V, Pat, {false,false}).
+
+vu_pattern(V, #c_var{name=V2}, {Used,_}) ->
+ {Used,V =:= V2};
+vu_pattern(V, #c_cons{hd=H,tl=T}, St0) ->
+ case vu_pattern(V, H, St0) of
+ {true,_}=St1 -> St1; %Nothing more to know
+ St1 -> vu_pattern(V, T, St1)
+ end;
+vu_pattern(V, #c_tuple{es=Es}, St) ->
+ vu_pattern_list(V, Es, St);
+vu_pattern(V, #c_binary{segments=Ss}, St) ->
+ vu_pat_seg_list(V, Ss, St);
+vu_pattern(V, #c_alias{var=Var,pat=P}, St0) ->
+ case vu_pattern(V, Var, St0) of
+ {true,_}=St1 -> St1;
+ St1 -> vu_pattern(V, P, St1)
+ end;
+vu_pattern(_, _, St) -> St.
+
+vu_pattern_list(V, Ps) -> vu_pattern_list(V, Ps, {false,false}).
+
+vu_pattern_list(V, Ps, St0) ->
+ lists:foldl(fun(P, St) -> vu_pattern(V, P, St) end, St0, Ps).
+
+vu_pat_seg_list(V, Ss, St) ->
+ lists:foldl(fun(_, {true,_}=St0) -> St0;
+ (#c_bitstr{val=Val,size=Size}, St0) ->
+ case vu_pattern(V, Val, St0) of
+ {true,_}=St1 -> St1;
+ {false,Shad} ->
+ {vu_expr(V, Size),Shad}
+ end
+ end, St, Ss).
+
+-spec vu_var_list(cerl:var_name(), [cerl:c_var()]) -> boolean().
+
+vu_var_list(V, Vs) ->
+ lists:any(fun (#c_var{name=V2}) -> V =:= V2 end, Vs).
diff --git a/lib/compiler/src/core_lint.erl b/lib/compiler/src/core_lint.erl
new file mode 100644
index 0000000000..b633f568c9
--- /dev/null
+++ b/lib/compiler/src/core_lint.erl
@@ -0,0 +1,536 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1999-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%
+%%
+%% Purpose : Do necessary checking of Core Erlang code.
+
+%% Check Core module for errors. Seeing this module is used in the
+%% compiler after optimisations we do more checking than would be
+%% necessary after just parsing. Don't check all constructs.
+%%
+%% We check the following:
+%%
+%% All referred functions, called and exported, are defined.
+%% Format of export list.
+%% Format of attributes
+%% Used variables are defined.
+%% Variables in let and funs.
+%% Patterns case clauses.
+%% Values only as multiple values/variables/patterns.
+%% Return same number of values as requested
+%% Correct number of arguments
+%%
+%% Checks to add:
+%%
+%% Consistency of values/variables
+%% Consistency of function return values/calls.
+%%
+%% We keep the names defined variables and functions in a ordered list
+%% of variable names and function name/arity pairs.
+
+-module(core_lint).
+
+-export([module/1,module/2,format_error/1]).
+
+-import(lists, [reverse/1,all/2,foldl/3]).
+-import(ordsets, [add_element/2,is_element/2,union/2]).
+
+-include("core_parse.hrl").
+
+%%-----------------------------------------------------------------------
+%% Types used in this module
+
+-type fa() :: {atom(), arity()}.
+
+-type err_desc() :: 'invalid_attributes' | 'invalid_exports'
+ | {'arg_mismatch', fa()} | {'bittype_unit', fa()}
+ | {'illegal_expr', fa()} | {'illegal_guard', fa()}
+ | {'illegal_pattern', fa()} | {'illegal_try', fa()}
+ | {'not_bs_pattern', fa()} | {'not_pattern', fa()}
+ | {'not_var', fa()} | {'pattern_mismatch', fa()}
+ | {'return_mismatch', fa()} | {'undefined_function', fa()}
+ | {'duplicate_var', cerl:var_name(), fa()}
+ | {'unbound_var', cerl:var_name(), fa()}
+ | {'undefined_function', fa(), fa()}.
+
+-type error() :: {module(), err_desc()}.
+-type warning() :: {module(), term()}.
+
+%%-----------------------------------------------------------------------
+%% Define the lint state record.
+
+-record(lint, {module :: module(), % Current module
+ func :: fa(), % Current function
+ errors = [] :: [error()], % Errors
+ warnings= [] :: [warning()]}). % Warnings
+
+%%----------------------------------------------------------------------
+
+%% format_error(Error)
+%% Return a string describing the error.
+
+-spec format_error(err_desc()) -> [char() | list()].
+
+format_error(invalid_attributes) -> "invalid attributes";
+format_error(invalid_exports) -> "invalid exports";
+format_error({arg_mismatch,{F,A}}) ->
+ io_lib:format("argument count mismatch in ~w/~w", [F,A]);
+format_error({bittype_unit,{F,A}}) ->
+ io_lib:format("unit without size in bit syntax pattern/expression in ~w/~w", [F,A]);
+format_error({illegal_expr,{F,A}}) ->
+ io_lib:format("illegal expression in ~w/~w", [F,A]);
+format_error({illegal_guard,{F,A}}) ->
+ io_lib:format("illegal guard expression in ~w/~w", [F,A]);
+format_error({illegal_pattern,{F,A}}) ->
+ io_lib:format("illegal pattern in ~w/~w", [F,A]);
+format_error({illegal_try,{F,A}}) ->
+ io_lib:format("illegal try expression in ~w/~w", [F,A]);
+format_error({not_bs_pattern,{F,A}}) ->
+ io_lib:format("expecting bit syntax pattern in ~w/~w", [F,A]);
+format_error({not_pattern,{F,A}}) ->
+ io_lib:format("expecting pattern in ~w/~w", [F,A]);
+format_error({not_var,{F,A}}) ->
+ io_lib:format("expecting variable in ~w/~w", [F,A]);
+format_error({pattern_mismatch,{F,A}}) ->
+ io_lib:format("pattern count mismatch in ~w/~w", [F,A]);
+format_error({return_mismatch,{F,A}}) ->
+ io_lib:format("return count mismatch in ~w/~w", [F,A]);
+format_error({undefined_function,{F,A}}) ->
+ io_lib:format("function ~w/~w undefined", [F,A]);
+format_error({duplicate_var,N,{F,A}}) ->
+ io_lib:format("duplicate variable ~s in ~w/~w", [N,F,A]);
+format_error({unbound_var,N,{F,A}}) ->
+ io_lib:format("unbound variable ~s in ~w/~w", [N,F,A]);
+format_error({undefined_function,{F1,A1},{F2,A2}}) ->
+ io_lib:format("undefined function ~w/~w in ~w/~w", [F1,A1,F2,A2]).
+
+-type ret() :: {'ok', [{module(), [warning(),...]}]}
+ | {'error', [{module(), [error(),...]}],
+ [{module(), [warning(),...]}]}.
+
+-spec module(cerl:c_module()) -> ret().
+
+module(M) -> module(M, []).
+
+-spec module(cerl:c_module(), [compile:option()]) -> ret().
+
+module(#c_module{name=M,exports=Es,attrs=As,defs=Ds}, _Opts) ->
+ Defined = defined_funcs(Ds),
+ St0 = #lint{module=M#c_literal.val},
+ St1 = check_exports(Es, St0),
+ St2 = check_attrs(As, St1),
+ St3 = module_defs(Ds, Defined, St2),
+ St4 = check_state(Es, Defined, St3),
+ return_status(St4).
+
+%% defined_funcs([FuncDef]) -> [Fname].
+
+defined_funcs(Fs) ->
+ foldl(fun ({#c_var{name={_I,_A}=IA},_}, Def) ->
+ add_element(IA, Def)
+ end, [], Fs).
+
+%% return_status(State) ->
+%% {ok,[Warning]} | {error,[Error],[Warning]}
+%% Pack errors and warnings properly and return ok | error.
+
+return_status(St) ->
+ Ws = reverse(St#lint.warnings),
+ case reverse(St#lint.errors) of
+ [] -> {ok,[{St#lint.module,Ws}]};
+ Es -> {error,[{St#lint.module,Es}],[{St#lint.module,Ws}]}
+ end.
+
+%% add_error(ErrorDescriptor, State) -> State'
+%% add_warning(ErrorDescriptor, State) -> State'
+%% Note that we don't use line numbers here.
+
+add_error(E, St) -> St#lint{errors=[{?MODULE,E}|St#lint.errors]}.
+
+%%add_warning(W, St) -> St#lint{warnings=[{none,core_lint,W}|St#lint.warnings]}.
+
+check_exports(Es, St) ->
+ case all(fun (#c_var{name={Name,Arity}})
+ when is_atom(Name), is_integer(Arity) -> true;
+ (_) -> false
+ end, Es) of
+ true -> St;
+ false -> add_error(invalid_exports, St)
+ end.
+
+check_attrs(As, St) ->
+ case all(fun ({#c_literal{},V}) -> core_lib:is_literal(V);
+ (_) -> false
+ end, As) of
+ true -> St;
+ false -> add_error(invalid_attributes, St)
+ end.
+
+check_state(Es, Defined, St) ->
+ foldl(fun (#c_var{name={_N,_A}=F}, St1) ->
+ case is_element(F, Defined) of
+ true -> St1;
+ false -> add_error({undefined_function,F}, St)
+ end
+ end, St, Es).
+
+%% module_defs(CoreBody, Defined, State) -> State.
+
+module_defs(B, Def, St) ->
+ %% Set top level function name.
+ foldl(fun (Func, St0) ->
+ {#c_var{name={_F,_A}=FA},_} = Func,
+ St1 = St0#lint{func=FA},
+ function(Func, Def, St1)
+ end, St, B).
+
+%% functions([Fdef], Defined, State) -> State.
+
+functions(Fs, Def, St0) ->
+ foldl(fun (F, St) -> function(F, Def, St) end, St0, Fs).
+
+%% function(CoreFunc, Defined, State) -> State.
+
+function({#c_var{name={_,_}},B}, Def, St) ->
+ %% Body must be a fun!
+ case B of
+ #c_fun{} -> expr(B, Def, any, St);
+ _ -> add_error({illegal_expr,St#lint.func}, St)
+ end.
+
+%% body(Expr, Defined, RetCount, State) -> State.
+
+body(#c_values{es=Es}, Def, Rt, St) ->
+ return_match(Rt, length(Es), expr_list(Es, Def, St));
+body(E, Def, Rt, St0) ->
+ St1 = expr(E, Def, Rt, St0),
+ case is_simple_top(E) of
+ true -> return_match(Rt, 1, St1);
+ false -> St1
+ end.
+
+%% guard(Expr, Defined, State) -> State.
+%% Guards are boolean expressions with test wrapped in a protected.
+
+guard(Expr, Def, St) -> gexpr(Expr, Def, 1, St).
+
+%% guard_list([Expr], Defined, State) -> State.
+
+%% guard_list(Es, Def, St0) ->
+%% foldl(fun (E, St) -> guard(E, Def, St) end, St0, Es).
+
+%% gbody(Expr, Defined, RetCount, State) -> State.
+
+gbody(#c_values{es=Es}, Def, Rt, St) ->
+ return_match(Rt, length(Es), gexpr_list(Es, Def, St));
+gbody(E, Def, Rt, St0) ->
+ St1 = gexpr(E, Def, Rt, St0),
+ case is_simple_top(E) of
+ true -> return_match(Rt, 1, St1);
+ false -> St1
+ end.
+
+gexpr(#c_var{name=N}, Def, _Rt, St) -> expr_var(N, Def, St);
+gexpr(#c_literal{}, _Def, _Rt, St) -> St;
+gexpr(#c_cons{hd=H,tl=T}, Def, _Rt, St) ->
+ gexpr_list([H,T], Def, St);
+gexpr(#c_tuple{es=Es}, Def, _Rt, St) ->
+ gexpr_list(Es, Def, St);
+gexpr(#c_binary{segments=Ss}, Def, _Rt, St) ->
+ gbitstr_list(Ss, Def, St);
+gexpr(#c_seq{arg=Arg,body=B}, Def, Rt, St0) ->
+ St1 = gexpr(Arg, Def, any, St0), %Ignore values
+ gbody(B, Def, Rt, St1);
+gexpr(#c_let{vars=Vs,arg=Arg,body=B}, Def, Rt, St0) ->
+ St1 = gbody(Arg, Def, let_varcount(Vs), St0), %This is a guard body
+ {Lvs,St2} = variable_list(Vs, St1),
+ gbody(B, union(Lvs, Def), Rt, St2);
+gexpr(#c_call{module=#c_literal{val=erlang},
+ name=#c_literal{},
+ args=As}, Def, 1, St) ->
+ gexpr_list(As, Def, St);
+gexpr(#c_primop{name=#c_literal{val=A},args=As}, Def, _Rt, St0) when is_atom(A) ->
+ gexpr_list(As, Def, St0);
+gexpr(#c_try{arg=E,vars=[#c_var{name=X}],body=#c_var{name=X},
+ evars=[#c_var{},#c_var{}],handler=#c_literal{val=false}},
+ Def, Rt, St) ->
+ gbody(E, Def, Rt, St);
+gexpr(#c_case{arg=Arg,clauses=Cs}, Def, Rt, St0) ->
+ PatCount = case_patcount(Cs),
+ St1 = gbody(Arg, Def, PatCount, St0),
+ clauses(Cs, Def, PatCount, Rt, St1);
+gexpr(_Core, _, _, St) ->
+ add_error({illegal_guard,St#lint.func}, St).
+
+%% gexpr_list([Expr], Defined, State) -> State.
+
+gexpr_list(Es, Def, St0) ->
+ foldl(fun (E, St) -> gexpr(E, Def, 1, St) end, St0, Es).
+
+%% gbitstr_list([Elem], Defined, State) -> State.
+
+gbitstr_list(Es, Def, St0) ->
+ foldl(fun (E, St) -> gbitstr(E, Def, St) end, St0, Es).
+
+gbitstr(#c_bitstr{val=V,size=S}, Def, St) ->
+ gexpr_list([V,S], Def, St).
+
+%% expr(Expr, Defined, RetCount, State) -> State.
+
+expr(#c_var{name={_,_}=FA}, Def, _Rt, St) ->
+ expr_fname(FA, Def, St);
+expr(#c_var{name=N}, Def, _Rt, St) -> expr_var(N, Def, St);
+expr(#c_literal{}, _Def, _Rt, St) -> St;
+expr(#c_cons{hd=H,tl=T}, Def, _Rt, St) ->
+ expr_list([H,T], Def, St);
+expr(#c_tuple{es=Es}, Def, _Rt, St) ->
+ expr_list(Es, Def, St);
+expr(#c_binary{segments=Ss}, Def, _Rt, St) ->
+ bitstr_list(Ss, Def, St);
+expr(#c_fun{vars=Vs,body=B}, Def, Rt, St0) ->
+ {Vvs,St1} = variable_list(Vs, St0),
+ return_match(Rt, 1, body(B, union(Vvs, Def), any, St1));
+expr(#c_seq{arg=Arg,body=B}, Def, Rt, St0) ->
+ St1 = expr(Arg, Def, any, St0), %Ignore values
+ body(B, Def, Rt, St1);
+expr(#c_let{vars=Vs,arg=Arg,body=B}, Def, Rt, St0) ->
+ St1 = body(Arg, Def, let_varcount(Vs), St0), %This is a body
+ {Lvs,St2} = variable_list(Vs, St1),
+ body(B, union(Lvs, Def), Rt, St2);
+expr(#c_letrec{defs=Fs,body=B}, Def0, Rt, St0) ->
+ Def1 = union(defined_funcs(Fs), Def0), %All defined stuff
+ St1 = functions(Fs, Def1, St0),
+ body(B, Def1, Rt, St1#lint{func=St0#lint.func});
+expr(#c_case{arg=Arg,clauses=Cs}, Def, Rt, St0) ->
+ Pc = case_patcount(Cs),
+ St1 = body(Arg, Def, Pc, St0),
+ clauses(Cs, Def, Pc, Rt, St1);
+expr(#c_receive{clauses=Cs,timeout=#c_literal{val=infinity},
+ action=#c_literal{}},
+ Def, Rt, St) ->
+ %% If the timeout is 'infinity', the after code can never
+ %% be reached. We don't care if the return count is wrong.
+ clauses(Cs, Def, 1, Rt, St);
+expr(#c_receive{clauses=Cs,timeout=T,action=A}, Def, Rt, St0) ->
+ St1 = expr(T, Def, 1, St0),
+ St2 = body(A, Def, Rt, St1),
+ clauses(Cs, Def, 1, Rt, St2);
+expr(#c_apply{op=Op,args=As}, Def, _Rt, St0) ->
+ St1 = apply_op(Op, Def, length(As), St0),
+ expr_list(As, Def, St1);
+expr(#c_call{module=M,name=N,args=As}, Def, _Rt, St0) ->
+ St1 = expr(M, Def, 1, St0),
+ St2 = expr(N, Def, 1, St1),
+ expr_list(As, Def, St2);
+expr(#c_primop{name=#c_literal{val=A},args=As}, Def, _Rt, St0) when is_atom(A) ->
+ expr_list(As, Def, St0);
+expr(#c_catch{body=B}, Def, Rt, St) ->
+ return_match(Rt, 1, body(B, Def, 1, St));
+expr(#c_try{arg=A,vars=Vs,body=B,evars=Evs,handler=H}, Def, Rt, St0) ->
+ St1 = case Evs of
+ [_, _, _] -> St0;
+ _ -> add_error({illegal_try,St0#lint.func}, St0)
+ end,
+ St2 = body(A, Def, let_varcount(Vs), St1),
+ {Ns,St3} = variable_list(Vs, St2),
+ St4 = body(B, union(Ns, Def), Rt, St3),
+ {Ens,St5} = variable_list(Evs, St4),
+ body(H, union(Ens, Def), Rt, St5);
+expr(_Other, _, _, St) ->
+ %%io:fwrite("clint: ~p~n", [_Other]),
+ add_error({illegal_expr,St#lint.func}, St).
+
+%% expr_list([Expr], Defined, State) -> State.
+
+expr_list(Es, Def, St0) ->
+ foldl(fun (E, St) -> expr(E, Def, 1, St) end, St0, Es).
+
+%% bitstr_list([Elem], Defined, State) -> State.
+
+bitstr_list(Es, Def, St0) ->
+ foldl(fun (E, St) -> bitstr(E, Def, St) end, St0, Es).
+
+bitstr(#c_bitstr{val=V,size=S}, Def, St) ->
+ expr_list([V,S], Def, St).
+
+%% apply_op(Op, Defined, ArgCount, State) -> State.
+%% A apply op is either an fname or an expression.
+
+apply_op(#c_var{name={_I,A}=IA}, Def, Ac, St0) ->
+ St1 = expr_fname(IA, Def, St0),
+ arg_match(Ac, A, St1);
+apply_op(E, Def, _, St) -> expr(E, Def, 1, St). %Hard to check
+
+%% expr_var(VarName, Defined, State) -> State.
+
+expr_var(N, Def, St) ->
+ case is_element(N, Def) of
+ true -> St;
+ false -> add_error({unbound_var,N,St#lint.func}, St)
+ end.
+
+%% expr_fname(Fname, Defined, State) -> State.
+
+expr_fname(Fname, Def, St) ->
+ case is_element(Fname, Def) of
+ true -> St;
+ false -> add_error({undefined_function,Fname,St#lint.func}, St)
+ end.
+
+%% let_varcount([Var]) -> int().
+
+let_varcount([]) -> any; %Ignore values
+let_varcount(Es) -> length(Es).
+
+%% case_patcount([Clause]) -> int().
+
+case_patcount([#c_clause{pats=Ps}|_]) -> length(Ps).
+
+%% clauses([Clause], Defined, PatCount, RetCount, State) -> State.
+
+clauses(Cs, Def, Pc, Rt, St0) ->
+ foldl(fun (C, St) -> clause(C, Def, Pc, Rt, St) end, St0, Cs).
+
+%% clause(Clause, Defined, PatCount, RetCount, State) -> State.
+
+clause(#c_clause{pats=Ps,guard=G,body=B}, Def0, Pc, Rt, St0) ->
+ St1 = pattern_match(Pc, length(Ps), St0),
+ {Pvs,St2} = pattern_list(Ps, Def0, St1),
+ Def1 = union(Pvs, Def0),
+ St3 = guard(G, Def1, St2),
+ body(B, Def1, Rt, St3).
+
+%% variable(Var, [PatVar], State) -> {[VarName],State}.
+
+variable(#c_var{name=N}, Ps, St) ->
+ case is_element(N, Ps) of
+ true -> {[],add_error({duplicate_var,N,St#lint.func}, St)};
+ false -> {[N],St}
+ end;
+variable(_, Def, St) -> {Def,add_error({not_var,St#lint.func}, St)}.
+
+%% variable_list([Var], State) -> {[Var],State}.
+%% variable_list([Var], [PatVar], State) -> {[Var],State}.
+
+variable_list(Vs, St) -> variable_list(Vs, [], St).
+
+variable_list(Vs, Ps, St) ->
+ foldl(fun (V, {Ps0,St0}) ->
+ {Vvs,St1} = variable(V, Ps0, St0),
+ {union(Vvs, Ps0),St1}
+ end, {Ps,St}, Vs).
+
+%% pattern(Pattern, Defined, State) -> {[PatVar],State}.
+%% pattern(Pattern, Defined, [PatVar], State) -> {[PatVar],State}.
+%% Patterns are complicated by sizes in binaries. These are pure
+%% input variables which create no bindings. We, therefore, need to
+%% carry around the original defined variables to get the correct
+%% handling.
+
+%% pattern(P, Def, St) -> pattern(P, Def, [], St).
+
+pattern(#c_var{name=N}, Def, Ps, St) ->
+ pat_var(N, Def, Ps, St);
+pattern(#c_literal{}, _Def, Ps, St) -> {Ps,St};
+pattern(#c_cons{hd=H,tl=T}, Def, Ps, St) ->
+ pattern_list([H,T], Def, Ps, St);
+pattern(#c_tuple{es=Es}, Def, Ps, St) ->
+ pattern_list(Es, Def, Ps, St);
+pattern(#c_binary{segments=Ss}, Def, Ps, St) ->
+ pat_bin(Ss, Def, Ps, St);
+pattern(#c_alias{var=V,pat=P}, Def, Ps, St0) ->
+ {Vvs,St1} = variable(V, Ps, St0),
+ pattern(P, Def, union(Vvs, Ps), St1);
+pattern(_, _, Ps, St) -> {Ps,add_error({not_pattern,St#lint.func}, St)}.
+
+pat_var(N, _Def, Ps, St) ->
+ case is_element(N, Ps) of
+ true -> {Ps,add_error({duplicate_var,N,St#lint.func}, St)};
+ false -> {add_element(N, Ps),St}
+ end.
+
+%% pat_bin_list([Elem], Defined, [PatVar], State) -> {[PatVar],State}.
+
+pat_bin(Es, Def0, Ps0, St0) ->
+ {Ps,_,St} = foldl(fun (E, {Ps,Def,St}) ->
+ pat_segment(E, Def, Ps, St)
+ end, {Ps0,Def0,St0}, Es),
+ {Ps,St}.
+
+pat_segment(#c_bitstr{val=V,size=S,type=T}, Def0, Ps0, St0) ->
+ St1 = pat_bit_expr(S, T, Def0, St0),
+ {Ps,St2} = pattern(V, Def0, Ps0, St1),
+ Def = case V of
+ #c_var{name=Name} -> add_element(Name, Def0);
+ _ -> Def0
+ end,
+ {Ps,Def,St2};
+pat_segment(_, Def, Ps, St) ->
+ {Ps,Def,add_error({not_bs_pattern,St#lint.func}, St)}.
+
+%% pat_bit_expr(SizePat, Type, Defined, State) -> State.
+%% Check the Size pattern, this is an input! Because of optimizations,
+%% we must allow any kind of constant and literal here.
+
+pat_bit_expr(#c_var{name=N}, _, Def, St) -> expr_var(N, Def, St);
+pat_bit_expr(#c_literal{}, _, _, St) -> St;
+pat_bit_expr(#c_binary{}, _, _Def, St) ->
+ %% Literal binaries may be expressed as a bit syntax construction
+ %% expression if such expression is more compact than the literal.
+ %% Example: <<0:100000000>>
+ St;
+pat_bit_expr(_, _, _, St) ->
+ add_error({illegal_expr,St#lint.func}, St).
+
+%% pattern_list([Var], Defined, State) -> {[PatVar],State}.
+%% pattern_list([Var], Defined, [PatVar], State) -> {[PatVar],State}.
+
+pattern_list(Pats, Def, St) -> pattern_list(Pats, Def, [], St).
+
+pattern_list(Pats, Def, Ps0, St0) ->
+ foldl(fun (P, {Ps,St}) -> pattern(P, Def, Ps, St) end, {Ps0,St0}, Pats).
+
+%% pattern_match(Required, Supplied, State) -> State.
+%% Check that the required number of patterns match the supplied.
+
+pattern_match(N, N, St) -> St;
+pattern_match(_Req, _Sup, St) ->
+ add_error({pattern_mismatch,St#lint.func}, St).
+
+%% return_match(Required, Supplied, State) -> State.
+%% Check that the required number of return values match the supplied.
+
+return_match(any, _Sup, St) -> St;
+return_match(N, N, St) -> St;
+return_match(_Req, _Sup, St) ->
+ add_error({return_mismatch,St#lint.func}, St).
+
+%% arg_match(Required, Supplied, State) -> State.
+
+arg_match(N, N, St) -> St;
+arg_match(_Req, _Sup, St) ->
+ add_error({arg_mismatch,St#lint.func}, St).
+
+%% Only check if the top-level is a simple.
+-spec is_simple_top(cerl:cerl()) -> boolean().
+
+is_simple_top(#c_var{}) -> true;
+is_simple_top(#c_cons{}) -> true;
+is_simple_top(#c_tuple{}) -> true;
+is_simple_top(#c_binary{}) -> true;
+is_simple_top(#c_literal{}) -> true;
+is_simple_top(_) -> false.
diff --git a/lib/compiler/src/core_parse.hrl b/lib/compiler/src/core_parse.hrl
new file mode 100644
index 0000000000..0b8f4d8895
--- /dev/null
+++ b/lib/compiler/src/core_parse.hrl
@@ -0,0 +1,98 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1999-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%
+%%
+%% Purpose : Core Erlang syntax trees as records.
+
+%% It would be nice to incorporate some generic functions as well but
+%% this could make including this file difficult.
+
+%% Note: the annotation list is *always* the first record field.
+%% Thus it is possible to define the macros:
+%% -define(get_ann(X), element(2, X)).
+%% -define(set_ann(X, Y), setelement(2, X, Y)).
+
+%% The record definitions appear alphabetically
+
+-record(c_alias, {anno=[], var, % var :: Tree,
+ pat}). % pat :: Tree
+
+-record(c_apply, {anno=[], op, % op :: Tree,
+ args}). % args :: [Tree]
+
+-record(c_binary, {anno=[], segments}). % segments :: [#c_bitstr{}]
+
+-record(c_bitstr, {anno=[], val, % val :: Tree,
+ size, % size :: Tree,
+ unit, % unit :: Tree,
+ type, % type :: Tree,
+ flags}). % flags :: Tree
+
+-record(c_call, {anno=[], module, % module :: Tree,
+ name, % name :: Tree,
+ args}). % args :: [Tree]
+
+-record(c_case, {anno=[], arg, % arg :: Tree,
+ clauses}). % clauses :: [Tree]
+
+-record(c_catch, {anno=[], body}). % body :: Tree
+
+-record(c_clause, {anno=[], pats, % pats :: [Tree],
+ guard, % guard :: Tree,
+ body}). % body :: Tree
+
+-record(c_cons, {anno=[], hd, % hd :: Tree,
+ tl}). % tl :: Tree
+
+-record(c_fun, {anno=[], vars, % vars :: [Tree],
+ body}). % body :: Tree
+
+-record(c_let, {anno=[], vars, % vars :: [Tree],
+ arg, % arg :: Tree,
+ body}). % body :: Tree
+
+-record(c_letrec, {anno=[], defs, % defs :: [#c_def{}],
+ body}). % body :: Tree
+
+-record(c_literal, {anno=[], val}). % val :: literal()
+
+-record(c_module, {anno=[], name, % name :: Tree,
+ exports, % exports :: [Tree],
+ attrs, % attrs :: [#c_def{}],
+ defs}). % defs :: [#c_def{}]
+
+-record(c_primop, {anno=[], name, % name :: Tree,
+ args}). % args :: [Tree]
+
+-record(c_receive, {anno=[], clauses, % clauses :: [Tree],
+ timeout, % timeout :: Tree,
+ action}). % action :: Tree
+
+-record(c_seq, {anno=[], arg, % arg :: Tree,
+ body}). % body :: Tree
+
+-record(c_try, {anno=[], arg, % arg :: Tree,
+ vars, % vars :: [Tree],
+ body, % body :: Tree
+ evars, % evars :: [Tree],
+ handler}). % handler :: Tree
+
+-record(c_tuple, {anno=[], es}). % es :: [Tree]
+
+-record(c_values, {anno=[], es}). % es :: [Tree]
+
+-record(c_var, {anno=[], name :: cerl:var_name()}).
diff --git a/lib/compiler/src/core_parse.yrl b/lib/compiler/src/core_parse.yrl
new file mode 100644
index 0000000000..4e98a8c2da
--- /dev/null
+++ b/lib/compiler/src/core_parse.yrl
@@ -0,0 +1,383 @@
+%% -*-Erlang-*-
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1999-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+%%
+%% Core Erlang YECC parser grammar
+
+%% Have explicit productions for annotated phrases named anno_XXX.
+%% This just does an XXX and adds the annotation.
+
+Nonterminals
+
+module_definition module_export module_attribute module_defs
+exported_names exported_name
+attribute_list attribute
+function_definition function_definitions
+
+constant constants atomic_constant tuple_constant cons_constant tail_constant
+other_pattern atomic_pattern tuple_pattern cons_pattern tail_pattern
+binary_pattern segment_patterns segment_pattern
+
+expression single_expression
+literal literals atomic_literal tuple_literal cons_literal tail_literal
+nil tuple cons tail
+binary segments segment
+
+let_expr let_vars letrec_expr case_expr fun_expr
+function_name
+application_expr call_expr primop_expr arg_list
+receive_expr timeout try_expr
+sequence catch_expr
+variable clause clause_pattern
+
+annotation anno_fun anno_expression anno_expressions
+anno_variable anno_variables anno_pattern anno_patterns
+anno_function_name
+anno_clause anno_clauses.
+
+Terminals
+
+%% Separators
+
+'(' ')' '{' '}' '[' ']' '|' ',' '->' '=' '/' '<' '>' ':' '-|' '#'
+
+%% Keywords (atoms are assumed to always be single-quoted).
+
+'module' 'attributes' 'do' 'let' 'in' 'letrec'
+'apply' 'call' 'primop'
+'case' 'of' 'end' 'when' 'fun' 'try' 'catch' 'receive' 'after'
+
+%% Literal tokens (provided by the tokeniser):
+
+char integer float atom string var.
+
+%% Literal tokens NOT provided by the tokenise:
+
+nil -> '[' ']' : {nil,tok_line('$1')}.
+
+%% Declare the start rule for parsing
+
+Rootsymbol module_definition.
+
+
+%% Grammar
+
+module_definition ->
+ 'module' atom module_export module_attribute module_defs 'end' :
+ #c_module{name=#c_literal{val=tok_val('$2')},exports='$3',
+ attrs='$4',defs='$5'}.
+module_definition ->
+ '(' 'module' atom module_export module_attribute module_defs 'end'
+ '-|' annotation ')' :
+ #c_module{anno='$9',name=tok_val('$3'),exports='$4',
+ attrs='$5',defs='$6'}.
+
+module_export -> '[' ']' : [].
+module_export -> '[' exported_names ']' : '$2'.
+
+exported_names -> exported_name ',' exported_names : ['$1' | '$3'].
+exported_names -> exported_name : ['$1'].
+
+exported_name -> function_name : '$1'.
+
+module_attribute -> 'attributes' '[' ']' : [].
+module_attribute -> 'attributes' '[' attribute_list ']' : '$3'.
+
+attribute_list -> attribute ',' attribute_list : ['$1' | '$3'].
+attribute_list -> attribute : ['$1'].
+
+attribute -> atom '=' literal :
+ {#c_literal{val=tok_val('$1')},'$3'}.
+
+module_defs -> function_definitions : '$1'.
+
+annotation -> '[' ']' : [].
+annotation -> '[' constants ']' : '$2'.
+
+function_definitions ->
+ function_definition function_definitions : ['$1' | '$2'].
+function_definitions ->
+ '$empty' : [].
+
+function_definition ->
+ anno_function_name '=' anno_fun :
+ {'$1','$3'}.
+
+anno_fun -> '(' fun_expr '-|' annotation ')' :
+ core_lib:set_anno('$2', '$4').
+anno_fun -> fun_expr : '$1'.
+
+%% Constant terms for annotations and attributes.
+%% These are represented by straight unabstract Erlang.
+
+constant -> atomic_constant : '$1'.
+constant -> tuple_constant : '$1'.
+constant -> cons_constant : '$1'.
+
+constants -> constant ',' constants : ['$1' | '$3'].
+constants -> constant : ['$1'].
+
+atomic_constant -> char : tok_val('$1').
+atomic_constant -> integer : tok_val('$1').
+atomic_constant -> float : tok_val('$1').
+atomic_constant -> atom : tok_val('$1').
+atomic_constant -> string : tok_val('$1').
+atomic_constant -> nil : [].
+
+tuple_constant -> '{' '}' : {}.
+tuple_constant -> '{' constants '}' : list_to_tuple('$2').
+
+cons_constant -> '[' constant tail_constant : ['$2'|'$3'].
+
+tail_constant -> ']' : [].
+tail_constant -> '|' constant ']' : '$2'.
+tail_constant -> ',' constant tail_constant : ['$2'|'$3'].
+
+%% Patterns
+%% We have to be a little sneaky here as we would like to be able to
+%% do:
+%% V = {a}
+%% ( V = {a} -| <anno> )
+%% ( V -| <anno> ) = {a}
+%% V = ( {a} -| <anno> )
+%% ( ( V -| <anno> ) = ( {a} -| <anno> ) -| <anno> )
+
+anno_pattern -> '(' other_pattern '-|' annotation ')' :
+ core_lib:set_anno('$2', '$4').
+anno_pattern -> other_pattern : '$1'.
+anno_pattern -> anno_variable : '$1'.
+
+anno_patterns -> anno_pattern ',' anno_patterns : ['$1' | '$3'].
+anno_patterns -> anno_pattern : ['$1'].
+
+other_pattern -> atomic_pattern : '$1'.
+other_pattern -> tuple_pattern : '$1'.
+other_pattern -> cons_pattern : '$1'.
+other_pattern -> binary_pattern : '$1'.
+other_pattern -> anno_variable '=' anno_pattern :
+ #c_alias{var='$1',pat='$3'}.
+
+atomic_pattern -> atomic_literal : '$1'.
+
+tuple_pattern -> '{' '}' : c_tuple([]).
+tuple_pattern -> '{' anno_patterns '}' : c_tuple('$2').
+
+cons_pattern -> '[' anno_pattern tail_pattern :
+ #c_cons{hd='$2',tl='$3'}.
+
+tail_pattern -> ']' : #c_literal{val=[]}.
+tail_pattern -> '|' anno_pattern ']' : '$2'.
+tail_pattern -> ',' anno_pattern tail_pattern :
+ #c_cons{hd='$2',tl='$3'}.
+
+binary_pattern -> '#' '{' '}' '#' : #c_binary{segments=[]}.
+binary_pattern -> '#' '{' segment_patterns '}' '#' : #c_binary{segments='$3'}.
+
+segment_patterns -> segment_pattern ',' segment_patterns : ['$1' | '$3'].
+segment_patterns -> segment_pattern : ['$1'].
+
+segment_pattern -> '#' '<' anno_pattern '>' '(' anno_patterns ')':
+ case '$6' of
+ [S,U,T,Fs] ->
+ #c_bitstr{val='$3',size=S,unit=U,type=T,flags=Fs};
+ true ->
+ return_error(tok_line('$1'),
+ "expected 4 arguments in binary segment")
+ end.
+
+variable -> var : #c_var{name=tok_val('$1')}.
+
+anno_variables -> anno_variable ',' anno_variables : ['$1' | '$3'].
+anno_variables -> anno_variable : ['$1'].
+
+anno_variable -> variable : '$1'.
+anno_variable -> '(' variable '-|' annotation ')' :
+ core_lib:set_anno('$2', '$4').
+
+%% Expressions
+%% Must split expressions into two levels as nested value expressions
+%% are illegal.
+
+anno_expression -> expression : '$1'.
+anno_expression -> '(' expression '-|' annotation ')' :
+ core_lib:set_anno('$2', '$4').
+
+anno_expressions -> anno_expression ',' anno_expressions : ['$1' | '$3'].
+anno_expressions -> anno_expression : ['$1'].
+
+expression -> '<' '>' : #c_values{es=[]}.
+expression -> '<' anno_expressions '>' : #c_values{es='$2'}.
+expression -> single_expression : '$1'.
+
+single_expression -> atomic_literal : '$1'.
+single_expression -> tuple : '$1'.
+single_expression -> cons : '$1'.
+single_expression -> binary : '$1'.
+single_expression -> variable : '$1'.
+single_expression -> function_name : '$1'.
+single_expression -> fun_expr : '$1'.
+single_expression -> let_expr : '$1'.
+single_expression -> letrec_expr : '$1'.
+single_expression -> case_expr : '$1'.
+single_expression -> receive_expr : '$1'.
+single_expression -> application_expr : '$1'.
+single_expression -> call_expr : '$1'.
+single_expression -> primop_expr : '$1'.
+single_expression -> try_expr : '$1'.
+single_expression -> sequence : '$1'.
+single_expression -> catch_expr : '$1'.
+
+literal -> atomic_literal : '$1'.
+literal -> tuple_literal : '$1'.
+literal -> cons_literal : '$1'.
+
+literals -> literal ',' literals : ['$1' | '$3'].
+literals -> literal : ['$1'].
+
+atomic_literal -> char : #c_literal{val=tok_val('$1')}.
+atomic_literal -> integer : #c_literal{val=tok_val('$1')}.
+atomic_literal -> float : #c_literal{val=tok_val('$1')}.
+atomic_literal -> atom : #c_literal{val=tok_val('$1')}.
+atomic_literal -> string : #c_literal{val=tok_val('$1')}.
+atomic_literal -> nil : #c_literal{val=[]}.
+
+tuple_literal -> '{' '}' : c_tuple([]).
+tuple_literal -> '{' literals '}' : c_tuple('$2').
+
+cons_literal -> '[' literal tail_literal : c_cons('$2', '$3').
+
+tail_literal -> ']' : #c_literal{val=[]}.
+tail_literal -> '|' literal ']' : '$2'.
+tail_literal -> ',' literal tail_literal : #c_cons{hd='$2',tl='$3'}.
+
+tuple -> '{' '}' : c_tuple([]).
+tuple -> '{' anno_expressions '}' : c_tuple('$2').
+
+cons -> '[' anno_expression tail : c_cons('$2', '$3').
+
+tail -> ']' : #c_literal{val=[]}.
+tail -> '|' anno_expression ']' : '$2'.
+tail -> ',' anno_expression tail : c_cons('$2', '$3').
+
+binary -> '#' '{' '}' '#' : #c_literal{val = <<>>}.
+binary -> '#' '{' segments '}' '#' : #c_binary{segments='$3'}.
+
+segments -> segment ',' segments : ['$1' | '$3'].
+segments -> segment : ['$1'].
+
+segment -> '#' '<' anno_expression '>' '(' anno_expressions ')':
+ case '$6' of
+ [S,U,T,Fs] ->
+ #c_bitstr{val='$3',size=S,unit=U,type=T,flags=Fs};
+ true ->
+ return_error(tok_line('$1'),
+ "expected 4 arguments in binary segment")
+ end.
+
+function_name -> atom '/' integer :
+ #c_var{name={tok_val('$1'),tok_val('$3')}}.
+
+anno_function_name -> function_name : '$1'.
+anno_function_name -> '(' function_name '-|' annotation ')' :
+ core_lib:set_anno('$2', '$4').
+
+let_vars -> anno_variable : ['$1'].
+let_vars -> '<' '>' : [].
+let_vars -> '<' anno_variables '>' : '$2'.
+
+sequence -> 'do' anno_expression anno_expression :
+ #c_seq{arg='$2',body='$3'}.
+
+fun_expr -> 'fun' '(' ')' '->' anno_expression :
+ #c_fun{vars=[],body='$5'}.
+fun_expr -> 'fun' '(' anno_variables ')' '->' anno_expression :
+ #c_fun{vars='$3',body='$6'}.
+
+let_expr -> 'let' let_vars '=' anno_expression 'in' anno_expression :
+ #c_let{vars='$2',arg='$4',body='$6'}.
+
+letrec_expr -> 'letrec' function_definitions 'in' anno_expression :
+ #c_letrec{defs='$2',body='$4'}.
+
+case_expr -> 'case' anno_expression 'of' anno_clauses 'end' :
+ #c_case{arg='$2',clauses='$4'}.
+
+anno_clauses -> anno_clause anno_clauses : ['$1' | '$2'].
+anno_clauses -> anno_clause : ['$1'].
+
+anno_clause -> clause : '$1'.
+anno_clause -> '(' clause '-|' annotation ')' :
+ core_lib:set_anno('$2', '$4').
+
+clause -> clause_pattern 'when' anno_expression '->' anno_expression :
+ #c_clause{pats='$1',guard='$3',body='$5'}.
+
+clause_pattern -> anno_pattern : ['$1'].
+clause_pattern -> '<' '>' : [].
+clause_pattern -> '<' anno_patterns '>' : '$2'.
+
+application_expr -> 'apply' anno_expression arg_list :
+ #c_apply{op='$2',args='$3'}.
+
+call_expr ->
+ 'call' anno_expression ':' anno_expression arg_list :
+ #c_call{module='$2',name='$4',args='$5'}.
+
+primop_expr -> 'primop' anno_expression arg_list :
+ #c_primop{name='$2',args='$3'}.
+
+arg_list -> '(' ')' : [].
+arg_list -> '(' anno_expressions ')' : '$2'.
+
+try_expr ->
+ 'try' anno_expression 'of' let_vars '->' anno_expression
+ 'catch' let_vars '->' anno_expression :
+ Len = length('$8'),
+ if Len =:= 2; Len =:= 3 ->
+ #c_try{arg='$2',vars='$4',body='$6',evars='$8',handler='$10'};
+ true ->
+ return_error(tok_line('$7'),
+ "expected 2 or 3 exception variables in 'try'")
+ end.
+
+catch_expr -> 'catch' anno_expression : #c_catch{body='$2'}.
+
+receive_expr -> 'receive' timeout :
+ {T,A} = '$2',
+ #c_receive{clauses=[],timeout=T,action=A}.
+receive_expr -> 'receive' anno_clauses timeout :
+ {T,A} = '$3',
+ #c_receive{clauses='$2',timeout=T,action=A}.
+
+timeout ->
+ 'after' anno_expression '->' anno_expression : {'$2','$4'}.
+
+%% ====================================================================== %%
+
+
+Erlang code.
+
+%% The following directive is needed for (significantly) faster compilation
+%% of the generated .erl file by the HiPE compiler. Please do not remove.
+-compile([{hipe,[{regalloc,linear_scan}]}]).
+
+-include("core_parse.hrl").
+
+-import(cerl, [c_cons/2,c_tuple/1]).
+
+tok_val(T) -> element(3, T).
+tok_line(T) -> element(2, T).
diff --git a/lib/compiler/src/core_pp.erl b/lib/compiler/src/core_pp.erl
new file mode 100644
index 0000000000..1f91a52be3
--- /dev/null
+++ b/lib/compiler/src/core_pp.erl
@@ -0,0 +1,504 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1999-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%
+%%
+%% Purpose : Core Erlang (naive) prettyprinter
+
+-module(core_pp).
+
+-export([format/1]).
+
+-include("core_parse.hrl").
+
+%% ====================================================================== %%
+%% format(Node) -> Text
+%% Node = coreErlang()
+%% Text = string() | [Text]
+%%
+%% Prettyprint-formats (naively) an abstract Core Erlang syntax
+%% tree.
+
+-record(ctxt, {class = term :: 'clause' | 'def' | 'expr' | 'term',
+ indent = 0 :: integer(),
+ item_indent = 2 :: integer(),
+ body_indent = 4 :: integer(),
+ tab_width = 8 :: non_neg_integer(),
+ line = 0 :: integer()}).
+
+-spec format(cerl:cerl()) -> iolist().
+
+format(Node) ->
+ format(Node, #ctxt{}).
+
+maybe_anno(Node, Fun, Ctxt) ->
+ As = core_lib:get_anno(Node),
+ case get_line(As) of
+ none ->
+ maybe_anno(Node, Fun, Ctxt, As);
+ Line ->
+ if Line > Ctxt#ctxt.line ->
+ [io_lib:format("%% Line ~w",[Line]),
+ nl_indent(Ctxt),
+ maybe_anno(Node, Fun, Ctxt#ctxt{line = Line}, As)
+ ];
+ true ->
+ maybe_anno(Node, Fun, Ctxt, As)
+ end
+ end.
+
+maybe_anno(Node, Fun, Ctxt, As) ->
+ case strip_line(As) of
+ [] ->
+ Fun(Node, Ctxt);
+ List ->
+ Ctxt1 = add_indent(Ctxt, 2),
+ Ctxt2 = add_indent(Ctxt1, 3),
+ ["( ",
+ Fun(Node, Ctxt1),
+ nl_indent(Ctxt1),
+ "-| ",format_anno(List, Ctxt2)," )"
+ ]
+ end.
+
+format_anno([_|_]=List, Ctxt) ->
+ [$[,format_anno_list(List, Ctxt),$]];
+format_anno(Tuple, Ctxt) when is_tuple(Tuple) ->
+ [${,format_anno_list(tuple_to_list(Tuple), Ctxt),$}];
+format_anno(Val, Ctxt) when is_atom(Val) ->
+ format_1(#c_literal{val=Val}, Ctxt);
+format_anno(Val, Ctxt) when is_integer(Val) ->
+ format_1(#c_literal{val=Val}, Ctxt).
+
+format_anno_list([H|[_|_]=T], Ctxt) ->
+ [format_anno(H, Ctxt), $, | format_anno_list(T, Ctxt)];
+format_anno_list([H], Ctxt) ->
+ format_anno(H, Ctxt).
+
+strip_line([A | As]) when is_integer(A) ->
+ strip_line(As);
+strip_line([{file,_File} | As]) ->
+ strip_line(As);
+strip_line([A | As]) ->
+ [A | strip_line(As)];
+strip_line([]) ->
+ [].
+
+get_line([L | _As]) when is_integer(L) ->
+ L;
+get_line([_ | As]) ->
+ get_line(As);
+get_line([]) ->
+ none.
+
+format(Node, Ctxt) ->
+ maybe_anno(Node, fun format_1/2, Ctxt).
+
+format_1(#c_literal{val=[]}, _) -> "[]";
+format_1(#c_literal{val=I}, _) when is_integer(I) -> integer_to_list(I);
+format_1(#c_literal{val=F}, _) when is_float(F) -> float_to_list(F);
+format_1(#c_literal{val=A}, _) when is_atom(A) -> core_atom(A);
+format_1(#c_literal{val=[H|T]}, Ctxt) ->
+ format_1(#c_cons{hd=#c_literal{val=H},tl=#c_literal{val=T}}, Ctxt);
+format_1(#c_literal{val=Tuple}, Ctxt) when is_tuple(Tuple) ->
+ format_1(#c_tuple{es=[#c_literal{val=E} || E <- tuple_to_list(Tuple)]}, Ctxt);
+format_1(#c_literal{anno=A,val=Bitstring}, Ctxt) when is_bitstring(Bitstring) ->
+ Segs = segs_from_bitstring(Bitstring),
+ format_1(#c_binary{anno=A,segments=Segs}, Ctxt);
+format_1(#c_var{name={I,A}}, _) ->
+ [core_atom(I),$/,integer_to_list(A)];
+format_1(#c_var{name=V}, _) ->
+ %% Internal variable names may be:
+ %% - atoms representing proper Erlang variable names, or
+ %% any atoms that may be printed without single-quoting
+ %% - nonnegative integers.
+ %% It is important that when printing variables, no two names
+ %% should ever map to the same string.
+ if is_atom(V) ->
+ S = atom_to_list(V),
+ case S of
+ [C | _] when C >= $A, C =< $Z ->
+ %% Ordinary uppercase-prefixed names are
+ %% printed just as they are.
+ S;
+ [$_ | _] ->
+ %% Already "_"-prefixed names are prefixed
+ %% with "_X", e.g. '_foo' => '_X_foo', to
+ %% avoid generating things like "____foo" upon
+ %% repeated writing and reading of code.
+ %% ("_X_X_X_foo" is better.)
+ [$_, $X | S];
+ _ ->
+ %% Plain atoms are prefixed with a single "_".
+ %% E.g. foo => "_foo".
+ [$_ | S]
+ end;
+ is_integer(V) ->
+ %% Integers are also simply prefixed with "_".
+ [$_ | integer_to_list(V)]
+ end;
+format_1(#c_binary{segments=Segs}, Ctxt) ->
+ ["#{",
+ format_vseq(Segs, "", ",", add_indent(Ctxt, 2),
+ fun format_bitstr/2),
+ "}#"
+ ];
+format_1(#c_tuple{es=Es}, Ctxt) ->
+ [${,
+ format_hseq(Es, ",", add_indent(Ctxt, 1), fun format/2),
+ $}
+ ];
+format_1(#c_cons{hd=H,tl=T}, Ctxt) ->
+ Txt = ["["|format(H, add_indent(Ctxt, 1))],
+ [Txt|format_list_tail(T, add_indent(Ctxt, width(Txt, Ctxt)))];
+format_1(#c_values{es=Es}, Ctxt) ->
+ format_values(Es, Ctxt);
+format_1(#c_alias{var=V,pat=P}, Ctxt) ->
+ Txt = [format(V, Ctxt)|" = "],
+ [Txt|format(P, add_indent(Ctxt, width(Txt, Ctxt)))];
+format_1(#c_let{vars=Vs0,arg=A,body=B}, Ctxt) ->
+ Vs = [core_lib:set_anno(V, []) || V <- Vs0],
+ case is_simple_term(A) of
+ false ->
+ Ctxt1 = add_indent(Ctxt, Ctxt#ctxt.body_indent),
+ ["let ",
+ format_values(Vs, add_indent(Ctxt, 4)),
+ " =",
+ nl_indent(Ctxt1),
+ format(A, Ctxt1),
+ nl_indent(Ctxt),
+ "in "
+ | format(B, add_indent(Ctxt, 4))
+ ];
+ true ->
+ Ctxt1 = add_indent(Ctxt, Ctxt#ctxt.body_indent),
+ ["let ",
+ format_values(Vs, add_indent(Ctxt, 4)),
+ " = ",
+ format(core_lib:set_anno(A, []), Ctxt1),
+ nl_indent(Ctxt),
+ "in "
+ | format(B, add_indent(Ctxt, 4))
+ ]
+ end;
+format_1(#c_letrec{defs=Fs,body=B}, Ctxt) ->
+ Ctxt1 = add_indent(Ctxt, Ctxt#ctxt.body_indent),
+ ["letrec",
+ nl_indent(Ctxt1),
+ format_funcs(Fs, Ctxt1),
+ nl_indent(Ctxt),
+ "in "
+ | format(B, add_indent(Ctxt, 4))
+ ];
+format_1(#c_seq{arg=A,body=B}, Ctxt) ->
+ Ctxt1 = add_indent(Ctxt, 4),
+ ["do ",
+ format(A, Ctxt1),
+ nl_indent(Ctxt1)
+ | format(B, Ctxt1)
+ ];
+format_1(#c_case{arg=A,clauses=Cs}, Ctxt) ->
+ Ctxt1 = add_indent(Ctxt, Ctxt#ctxt.item_indent),
+ ["case ",
+ format(A, add_indent(Ctxt, 5)),
+ " of",
+ nl_indent(Ctxt1),
+ format_clauses(Cs, Ctxt1),
+ nl_indent(Ctxt)
+ | "end"
+ ];
+format_1(#c_receive{clauses=Cs,timeout=T,action=A}, Ctxt) ->
+ Ctxt1 = add_indent(Ctxt, Ctxt#ctxt.item_indent),
+ ["receive",
+ nl_indent(Ctxt1),
+ format_clauses(Cs, Ctxt1),
+ nl_indent(Ctxt),
+ "after ",
+ format(T, add_indent(Ctxt, 6)),
+ " ->",
+ nl_indent(Ctxt1),
+ format(A, Ctxt1)
+ ];
+format_1(#c_fun{vars=Vs,body=B}, Ctxt) ->
+ Ctxt1 = add_indent(Ctxt, Ctxt#ctxt.body_indent),
+ ["fun (",
+ format_hseq(Vs, ",", add_indent(Ctxt, 5), fun format/2),
+ ") ->",
+ nl_indent(Ctxt1)
+ | format(B, Ctxt1)
+ ];
+format_1(#c_apply{op=O,args=As}, Ctxt0) ->
+ Ctxt1 = add_indent(Ctxt0, 6), %"apply "
+ Op = format(O, Ctxt1),
+ Ctxt2 = add_indent(Ctxt0, 4),
+ ["apply ",Op,
+ nl_indent(Ctxt2),
+ $(,format_hseq(As, ", ", add_indent(Ctxt2, 1), fun format/2),$)
+ ];
+format_1(#c_call{module=M,name=N,args=As}, Ctxt0) ->
+ Ctxt1 = add_indent(Ctxt0, 5), %"call "
+ Mod = format(M, Ctxt1),
+ Ctxt2 = add_indent(Ctxt1, width(Mod, Ctxt1)+1),
+ Name = format(N, Ctxt2),
+ Ctxt3 = add_indent(Ctxt0, 4),
+ ["call ",Mod,":",Name,
+ nl_indent(Ctxt3),
+ $(,format_hseq(As, ", ", add_indent(Ctxt3, 1), fun format/2),$)
+ ];
+format_1(#c_primop{name=N,args=As}, Ctxt0) ->
+ Ctxt1 = add_indent(Ctxt0, 7), %"primop "
+ Name = format(N, Ctxt1),
+ Ctxt2 = add_indent(Ctxt0, 4),
+ ["primop ",Name,
+ nl_indent(Ctxt2),
+ $(,format_hseq(As, ", ", add_indent(Ctxt2, 1), fun format/2),$)
+ ];
+format_1(#c_catch{body=B}, Ctxt) ->
+ Ctxt1 = add_indent(Ctxt, Ctxt#ctxt.body_indent),
+ ["catch",
+ nl_indent(Ctxt1),
+ format(B, Ctxt1)
+ ];
+format_1(#c_try{arg=E,vars=Vs,body=B,evars=Evs,handler=H}, Ctxt) ->
+ Ctxt1 = add_indent(Ctxt, Ctxt#ctxt.body_indent),
+ ["try",
+ nl_indent(Ctxt1),
+ format(E, Ctxt1),
+ nl_indent(Ctxt),
+ "of ",
+ format_values(Vs, add_indent(Ctxt, 3)),
+ " ->",
+ nl_indent(Ctxt1),
+ format(B, Ctxt1),
+ nl_indent(Ctxt),
+ "catch ",
+ format_values(Evs, add_indent(Ctxt, 6)),
+ " ->",
+ nl_indent(Ctxt1)
+ | format(H, Ctxt1)
+ ];
+format_1(#c_module{name=N,exports=Es,attrs=As,defs=Ds}, Ctxt) ->
+ Mod = ["module ", format(N, Ctxt)],
+ [Mod," [",
+ format_vseq(Es,
+ "", ",",
+ add_indent(set_class(Ctxt, term), width(Mod, Ctxt)+2),
+ fun format/2),
+ "]",
+ nl_indent(Ctxt),
+ " attributes [",
+ format_vseq(As,
+ "", ",",
+ add_indent(set_class(Ctxt, def), 16),
+ fun format_def/2),
+ "]",
+ nl_indent(Ctxt),
+ format_funcs(Ds, Ctxt),
+ nl_indent(Ctxt)
+ | "end"
+ ];
+format_1(Type, _) ->
+ ["** Unsupported type: ",
+ io_lib:write(Type)
+ | " **"
+ ].
+
+format_funcs(Fs, Ctxt) ->
+ format_vseq(Fs,
+ "", "",
+ set_class(Ctxt, def),
+ fun format_def/2).
+
+format_def({N,V}, Ctxt0) ->
+ Ctxt1 = add_indent(set_class(Ctxt0, expr), Ctxt0#ctxt.body_indent),
+ [format(N, Ctxt0),
+ " =",
+ nl_indent(Ctxt1)
+ | format(V, Ctxt1)
+ ].
+
+
+format_values(Vs, Ctxt) ->
+ [$<,
+ format_hseq(Vs, ",", add_indent(Ctxt, 1), fun format/2),
+ $>].
+
+format_bitstr(#c_bitstr{val=V,size=S,unit=U,type=T,flags=Fs}, Ctxt0) ->
+ Vs = [S, U, T, Fs],
+ Ctxt1 = add_indent(Ctxt0, 2),
+ Val = format(V, Ctxt1),
+ Ctxt2 = add_indent(Ctxt1, width(Val, Ctxt1) + 2),
+ ["#<", Val, ">(", format_hseq(Vs,",", Ctxt2, fun format/2), $)].
+
+format_clauses(Cs, Ctxt) ->
+ format_vseq(Cs, "", "", set_class(Ctxt, clause),
+ fun format_clause/2).
+
+format_clause(Node, Ctxt) ->
+ maybe_anno(Node, fun format_clause_1/2, Ctxt).
+
+format_clause_1(#c_clause{pats=Ps,guard=G,body=B}, Ctxt) ->
+ Ptxt = format_values(Ps, Ctxt),
+ Ctxt2 = add_indent(Ctxt, Ctxt#ctxt.body_indent),
+ [Ptxt,
+ case is_trivial_guard(G) of
+ true ->
+ [" when ",
+ format_guard(G, add_indent(set_class(Ctxt, expr),
+ width(Ptxt, Ctxt) + 6))];
+ false ->
+ [nl_indent(Ctxt2), "when ",
+ format_guard(G, add_indent(Ctxt2, 2))]
+ end++
+ " ->",
+ nl_indent(Ctxt2)
+ | format(B, set_class(Ctxt2, expr))
+ ].
+
+is_trivial_guard(#c_literal{val=Val}) when is_atom(Val) -> true;
+is_trivial_guard(_) -> false.
+
+format_guard(Node, Ctxt) ->
+ maybe_anno(Node, fun format_guard_1/2, Ctxt).
+
+format_guard_1(#c_call{module=M,name=N,args=As}, Ctxt0) ->
+ Ctxt1 = add_indent(Ctxt0, 5), %"call "
+ Mod = format(M, Ctxt1),
+ Ctxt2 = add_indent(Ctxt1, width(Mod, Ctxt1)+1),
+ Name = format(N, Ctxt2),
+ Ctxt3 = add_indent(Ctxt0, 4),
+ ["call ",Mod,":",Name,
+ nl_indent(Ctxt3),
+ $(,format_vseq(As, "",",", add_indent(Ctxt3, 1), fun format_guard/2),$)
+ ];
+format_guard_1(E, Ctxt) -> format_1(E, Ctxt). %Anno already done
+
+%% format_hseq([Thing], Separator, Context, Fun) -> Txt.
+%% Format a sequence horizontally on the same line with Separator between.
+
+format_hseq([H], _, Ctxt, Fun) ->
+ Fun(H, Ctxt);
+format_hseq([H|T], Sep, Ctxt, Fun) ->
+ Txt = [Fun(H, Ctxt)|Sep],
+ Ctxt1 = add_indent(Ctxt, width(Txt, Ctxt)),
+ [Txt|format_hseq(T, Sep, Ctxt1, Fun)];
+format_hseq([], _, _, _) -> "".
+
+%% format_vseq([Thing], LinePrefix, LineSuffix, Context, Fun) -> Txt.
+%% Format a sequence vertically in indented lines adding LinePrefix
+%% to the beginning of each line and LineSuffix to the end of each
+%% line. No prefix on the first line or suffix on the last line.
+
+format_vseq([H], _Pre, _Suf, Ctxt, Fun) ->
+ Fun(H, Ctxt);
+format_vseq([H|T], Pre, Suf, Ctxt, Fun) ->
+ [Fun(H, Ctxt),Suf,nl_indent(Ctxt),Pre|
+ format_vseq(T, Pre, Suf, Ctxt, Fun)];
+format_vseq([], _, _, _, _) -> "".
+
+format_list_tail(#c_literal{anno=[],val=[]}, _) -> "]";
+format_list_tail(#c_cons{anno=[],hd=H,tl=T}, Ctxt) ->
+ Txt = [$,|format(H, Ctxt)],
+ Ctxt1 = add_indent(Ctxt, width(Txt, Ctxt)),
+ [Txt|format_list_tail(T, Ctxt1)];
+format_list_tail(Tail, Ctxt) ->
+ ["|",format(Tail, add_indent(Ctxt, 1)),"]"].
+
+indent(Ctxt) -> indent(Ctxt#ctxt.indent, Ctxt).
+
+indent(N, _) when N =< 0 -> "";
+indent(N, Ctxt) ->
+ T = Ctxt#ctxt.tab_width,
+ string:chars($\t, N div T, string:chars($\s, N rem T)).
+
+nl_indent(Ctxt) -> [$\n|indent(Ctxt)].
+
+
+unindent(T, Ctxt) ->
+ unindent(T, Ctxt#ctxt.indent, Ctxt, []).
+
+unindent(T, N, _, C) when N =< 0 ->
+ [T|C];
+unindent([$\s|T], N, Ctxt, C) ->
+ unindent(T, N - 1, Ctxt, C);
+unindent([$\t|T], N, Ctxt, C) ->
+ Tab = Ctxt#ctxt.tab_width,
+ if N >= Tab ->
+ unindent(T, N - Tab, Ctxt, C);
+ true ->
+ unindent([string:chars($\s, Tab - N)|T], 0, Ctxt, C)
+ end;
+unindent([L|T], N, Ctxt, C) when is_list(L) ->
+ unindent(L, N, Ctxt, [T|C]);
+unindent([H|T], _, _, C) ->
+ [H|[T|C]];
+unindent([], N, Ctxt, [H|T]) ->
+ unindent(H, N, Ctxt, T);
+unindent([], _, _, []) -> [].
+
+
+width(Txt, Ctxt) ->
+ try width(Txt, 0, Ctxt, [])
+ catch error:_ -> exit({bad_text,Txt})
+ end.
+
+width([$\t|T], A, Ctxt, C) ->
+ width(T, A + Ctxt#ctxt.tab_width, Ctxt, C);
+width([$\n|T], _, Ctxt, C) ->
+ width(unindent([T|C], Ctxt), Ctxt);
+width([H|T], A, Ctxt, C) when is_list(H) ->
+ width(H, A, Ctxt, [T|C]);
+width([_|T], A, Ctxt, C) ->
+ width(T, A + 1, Ctxt, C);
+width([], A, Ctxt, [H|T]) ->
+ width(H, A, Ctxt, T);
+width([], A, _, []) -> A.
+
+add_indent(Ctxt, Dx) ->
+ Ctxt#ctxt{indent = Ctxt#ctxt.indent + Dx}.
+
+set_class(Ctxt, Class) ->
+ Ctxt#ctxt{class = Class}.
+
+core_atom(A) -> io_lib:write_string(atom_to_list(A), $').
+
+
+is_simple_term(#c_values{es=Es}) ->
+ length(Es) < 3 andalso lists:all(fun is_simple_term/1, Es);
+is_simple_term(#c_tuple{es=Es}) ->
+ length(Es) < 4 andalso lists:all(fun is_simple_term/1, Es);
+is_simple_term(#c_var{}) -> true;
+is_simple_term(#c_literal{val=[_|_]}) -> false;
+is_simple_term(#c_literal{val=V}) -> not is_tuple(V);
+is_simple_term(_) -> false.
+
+segs_from_bitstring(<<H,T/bitstring>>) ->
+ [#c_bitstr{val=#c_literal{val=H},
+ size=#c_literal{val=8},
+ unit=#c_literal{val=1},
+ type=#c_literal{val=integer},
+ flags=#c_literal{val=[unsigned,big]}}|segs_from_bitstring(T)];
+segs_from_bitstring(<<>>) ->
+ [];
+segs_from_bitstring(Bitstring) ->
+ N = bit_size(Bitstring),
+ <<I:N>> = Bitstring,
+ [#c_bitstr{val=#c_literal{val=I},
+ size=#c_literal{val=N},
+ unit=#c_literal{val=1},
+ type=#c_literal{val=integer},
+ flags=#c_literal{val=[unsigned,big]}}].
+
diff --git a/lib/compiler/src/core_scan.erl b/lib/compiler/src/core_scan.erl
new file mode 100644
index 0000000000..5aab8ae855
--- /dev/null
+++ b/lib/compiler/src/core_scan.erl
@@ -0,0 +1,468 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2000-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%
+%%
+%% Purpose: Scanner for Core Erlang.
+
+%% For handling ISO 8859-1 (Latin-1) we use the following type
+%% information:
+%%
+%% 000 - 037 NUL - US control
+%% 040 - 057 SPC - / punctuation
+%% 060 - 071 0 - 9 digit
+%% 072 - 100 : - @ punctuation
+%% 101 - 132 A - Z uppercase
+%% 133 - 140 [ - ` punctuation
+%% 141 - 172 a - z lowercase
+%% 173 - 176 { - ~ punctuation
+%% 177 DEL control
+%% 200 - 237 control
+%% 240 - 277 NBSP - � punctuation
+%% 300 - 326 � - � uppercase
+%% 327 � punctuation
+%% 330 - 336 � - � uppercase
+%% 337 - 366 � - � lowercase
+%% 367 � punctuation
+%% 370 - 377 � - � lowercase
+%%
+%% Many punctuation characters region have special meaning. Must
+%% watch using � \327, bvery close to x \170
+
+-module(core_scan).
+
+-export([string/1, string/2, format_error/1]).
+
+-import(lists, [reverse/1]).
+
+%% string([Char]) ->
+%% string([Char], StartPos) ->
+%% {ok, [Tok], EndPos} |
+%% {error, {Pos,core_scan,What}, EndPos}
+
+string(Cs) -> string(Cs, 1).
+
+string(Cs, Sp) ->
+ %% Add an 'eof' to always get correct handling.
+ case string_pre_scan(Cs, [], Sp) of
+ {done,_,SoFar,Ep} -> %Got tokens
+ case scan(reverse(SoFar), Sp) of
+ {ok,Toks} -> {ok,Toks,Ep};
+ {error,E} -> {error,E,Ep}
+ end;
+ Other -> Other %An error has occurred
+ end.
+
+%% string_pre_scan(Cs, SoFar0, StartPos) ->
+%% {done,Rest,SoFar,EndPos} | {error,E,EndPos}.
+
+string_pre_scan(Cs, SoFar0, Sp) ->
+ case pre_scan(Cs, SoFar0, Sp) of
+ {done,Rest,SoFar1,Ep} -> %Got complete tokens
+ {done,Rest,SoFar1,Ep};
+ {more,Rest,SoFar1,Ep} -> %Missing end token
+ string_pre_scan(Rest ++ eof, SoFar1, Ep);
+ Other -> Other %An error has occurred
+ end.
+
+%% format_error(Error)
+%% Return a string describing the error.
+
+-spec format_error(term()) -> iolist().
+
+format_error({string,Quote,Head}) ->
+ ["unterminated " ++ string_thing(Quote) ++
+ " starting with " ++ io_lib:write_string(Head,Quote)];
+format_error({illegal,Type}) -> io_lib:fwrite("illegal ~w", [Type]);
+format_error(char) -> "unterminated character";
+format_error(scan) -> "premature end";
+format_error({base,Base}) -> io_lib:fwrite("illegal base '~w'", [Base]);
+format_error(float) -> "bad float";
+format_error(Other) -> io_lib:write(Other).
+
+string_thing($') -> "atom"; %' stupid emacs
+string_thing($") -> "string". %" stupid emacs
+
+%% Re-entrant pre-scanner.
+%%
+%% If the input list of characters is insufficient to build a term the
+%% scanner returns a request for more characters and a continuation to be
+%% used when trying to build a term with more characters. To indicate
+%% end-of-file the input character list should be replaced with 'eof'
+%% as an empty list has meaning.
+%%
+%% When more characters are need inside a comment, string or quoted
+%% atom, which can become rather long, instead of pushing the
+%% characters read so far back onto RestChars to be reread, a special
+%% reentry token is returned indicating the middle of a construct.
+%% The token is the start character as an atom, '%', '"' and '\''.
+
+%% pre_scan([Char], SoFar, StartPos) ->
+%% {done,RestChars,ScannedChars,NewPos} |
+%% {more,RestChars,ScannedChars,NewPos} |
+%% {error,{ErrorPos,core_scan,Description},NewPos}.
+%% Main pre-scan function. It has been split into 2 functions because of
+%% efficiency, with a good indexing compiler it would be unnecessary.
+
+pre_scan([C|Cs], SoFar, Pos) ->
+ pre_scan(C, Cs, SoFar, Pos);
+pre_scan([], SoFar, Pos) ->
+ {more,[],SoFar,Pos};
+pre_scan(eof, SoFar, Pos) ->
+ {done,eof,SoFar,Pos}.
+
+%% pre_scan(Char, [Char], SoFar, Pos)
+
+pre_scan($$, Cs0, SoFar0, Pos) ->
+ case pre_char(Cs0, [$$|SoFar0]) of
+ {Cs,SoFar} ->
+ pre_scan(Cs, SoFar, Pos);
+ more ->
+ {more,[$$|Cs0],SoFar0, Pos};
+ error ->
+ pre_error(char, Pos, Pos)
+ end;
+pre_scan($', Cs, SoFar, Pos) ->
+ pre_string(Cs, $', '\'', Pos, [$'|SoFar], Pos);
+pre_scan({'\'',Sp}, Cs, SoFar, Pos) -> %Re-entering quoted atom
+ pre_string(Cs, $', '\'', Sp, SoFar, Pos);
+pre_scan($", Cs, SoFar, Pos) ->
+ pre_string(Cs, $", '"', Pos, [$"|SoFar], Pos);
+pre_scan({'"',Sp}, Cs, SoFar, Pos) -> %Re-entering string
+ pre_string(Cs, $", '"', Sp, SoFar, Pos);
+pre_scan($%, Cs, SoFar, Pos) ->
+ pre_comment(Cs, SoFar, Pos);
+pre_scan('%', Cs, SoFar, Pos) -> %Re-entering comment
+ pre_comment(Cs, SoFar, Pos);
+pre_scan($\n, Cs, SoFar, Pos) ->
+ pre_scan(Cs, [$\n|SoFar], Pos+1);
+pre_scan(C, Cs, SoFar, Pos) ->
+ pre_scan(Cs, [C|SoFar], Pos).
+
+%% pre_string([Char], Quote, Reent, StartPos, SoFar, Pos)
+
+pre_string([Q|Cs], Q, _, _, SoFar, Pos) ->
+ pre_scan(Cs, [Q|SoFar], Pos);
+pre_string([$\n|Cs], Q, Reent, Sp, SoFar, Pos) ->
+ pre_string(Cs, Q, Reent, Sp, [$\n|SoFar], Pos+1);
+pre_string([$\\|Cs0], Q, Reent, Sp, SoFar0, Pos) ->
+ case pre_escape(Cs0, SoFar0) of
+ {Cs,SoFar} ->
+ pre_string(Cs, Q, Reent, Sp, SoFar, Pos);
+ more ->
+ {more,[{Reent,Sp},$\\|Cs0],SoFar0,Pos};
+ error ->
+ pre_string_error(Q, Sp, SoFar0, Pos)
+ end;
+pre_string([C|Cs], Q, Reent, Sp, SoFar, Pos) ->
+ pre_string(Cs, Q, Reent, Sp, [C|SoFar], Pos);
+pre_string([], _, Reent, Sp, SoFar, Pos) ->
+ {more,[{Reent,Sp}],SoFar,Pos};
+pre_string(eof, Q, _, Sp, SoFar, Pos) ->
+ pre_string_error(Q, Sp, SoFar, Pos).
+
+pre_string_error(Q, Sp, SoFar, Pos) ->
+ S = reverse(string:substr(SoFar, 1, string:chr(SoFar, Q)-1)),
+ pre_error({string,Q,string:substr(S, 1, 16)}, Sp, Pos).
+
+pre_char([C|Cs], SoFar) -> pre_char(C, Cs, SoFar);
+pre_char([], _) -> more;
+pre_char(eof, _) -> error.
+
+pre_char($\\, Cs, SoFar) ->
+ pre_escape(Cs, SoFar);
+pre_char(C, Cs, SoFar) ->
+ {Cs,[C|SoFar]}.
+
+pre_escape([$^|Cs0], SoFar) ->
+ case Cs0 of
+ [C3|Cs] ->
+ {Cs,[C3,$^,$\\|SoFar]};
+ [] -> more;
+ eof -> error
+ end;
+pre_escape([C|Cs], SoFar) ->
+ {Cs,[C,$\\|SoFar]};
+pre_escape([], _) -> more;
+pre_escape(eof, _) -> error.
+
+%% pre_comment([Char], SoFar, Pos)
+%% Comments are replaced by one SPACE.
+
+pre_comment([$\n|Cs], SoFar, Pos) ->
+ pre_scan(Cs, [$\n,$\s|SoFar], Pos+1); %Terminate comment
+pre_comment([_|Cs], SoFar, Pos) ->
+ pre_comment(Cs, SoFar, Pos);
+pre_comment([], SoFar, Pos) ->
+ {more,['%'],SoFar,Pos};
+pre_comment(eof, Sofar, Pos) ->
+ pre_scan(eof, [$\s|Sofar], Pos).
+
+pre_error(E, Epos, Pos) ->
+ {error,{Epos,core_scan,E}, Pos}.
+
+%% scan(CharList, StartPos)
+%% This takes a list of characters and tries to tokenise them.
+%%
+%% The token list is built in reverse order (in a stack) to save appending
+%% and then reversed when all the tokens have been collected. Most tokens
+%% are built in the same way.
+%%
+%% Returns:
+%% {ok,[Tok]}
+%% {error,{ErrorPos,core_scan,What}}
+
+scan(Cs, Pos) ->
+ scan1(Cs, [], Pos).
+
+%% scan1(Characters, TokenStack, Position)
+%% Scan a list of characters into tokens.
+
+scan1([$\n|Cs], Toks, Pos) -> %Skip newline
+ scan1(Cs, Toks, Pos+1);
+scan1([C|Cs], Toks, Pos) when C >= $\000, C =< $\s -> %Skip control chars
+ scan1(Cs, Toks, Pos);
+scan1([C|Cs], Toks, Pos) when C >= $\200, C =< $\240 ->
+ scan1(Cs, Toks, Pos);
+scan1([C|Cs], Toks, Pos) when C >= $a, C =< $z -> %Keywords
+ scan_key_word(C, Cs, Toks, Pos);
+scan1([C|Cs], Toks, Pos) when C >= $�, C =< $�, C /= $� ->
+ scan_key_word(C, Cs, Toks, Pos);
+scan1([C|Cs], Toks, Pos) when C >= $A, C =< $Z -> %Variables
+ scan_variable(C, Cs, Toks, Pos);
+scan1([C|Cs], Toks, Pos) when C >= $�, C =< $�, C /= $� ->
+ scan_variable(C, Cs, Toks, Pos);
+scan1([C|Cs], Toks, Pos) when C >= $0, C =< $9 -> %Numbers
+ scan_number(C, Cs, Toks, Pos);
+scan1([$-,C|Cs], Toks, Pos) when C >= $0, C =< $9 -> %Signed numbers
+ scan_signed_number($-, C, Cs, Toks, Pos);
+scan1([$+,C|Cs], Toks, Pos) when C >= $0, C =< $9 -> %Signed numbers
+ scan_signed_number($+, C, Cs, Toks, Pos);
+scan1([$_|Cs], Toks, Pos) -> %_ variables
+ scan_variable($_, Cs, Toks, Pos);
+scan1([$$|Cs0], Toks, Pos) -> %Character constant
+ {C,Cs,Pos1} = scan_char(Cs0, Pos),
+ scan1(Cs, [{char,Pos,C}|Toks], Pos1);
+scan1([$'|Cs0], Toks, Pos) -> %Atom (always quoted)
+ {S,Cs1,Pos1} = scan_string(Cs0, $', Pos),
+ case catch list_to_atom(S) of
+ A when is_atom(A) ->
+ scan1(Cs1, [{atom,Pos,A}|Toks], Pos1);
+ _Error -> scan_error({illegal,atom}, Pos)
+ end;
+scan1([$"|Cs0], Toks, Pos) -> %String
+ {S,Cs1,Pos1} = scan_string(Cs0, $", Pos),
+ scan1(Cs1, [{string,Pos,S}|Toks], Pos1);
+%% Punctuation characters and operators, first recognise multiples.
+scan1("->" ++ Cs, Toks, Pos) ->
+ scan1(Cs, [{'->',Pos}|Toks], Pos);
+scan1("-|" ++ Cs, Toks, Pos) ->
+ scan1(Cs, [{'-|',Pos}|Toks], Pos);
+scan1([C|Cs], Toks, Pos) -> %Punctuation character
+ P = list_to_atom([C]),
+ scan1(Cs, [{P,Pos}|Toks], Pos);
+scan1([], Toks0, _) ->
+ Toks = reverse(Toks0),
+ {ok,Toks}.
+
+%% scan_key_word(FirstChar, CharList, Tokens, Pos)
+%% scan_variable(FirstChar, CharList, Tokens, Pos)
+
+scan_key_word(C, Cs0, Toks, Pos) ->
+ {Wcs,Cs} = scan_name(Cs0, []),
+ case catch list_to_atom([C|reverse(Wcs)]) of
+ Name when is_atom(Name) ->
+ scan1(Cs, [{Name,Pos}|Toks], Pos);
+ _Error -> scan_error({illegal,atom}, Pos)
+ end.
+
+scan_variable(C, Cs0, Toks, Pos) ->
+ {Wcs,Cs} = scan_name(Cs0, []),
+ case catch list_to_atom([C|reverse(Wcs)]) of
+ Name when is_atom(Name) ->
+ scan1(Cs, [{var,Pos,Name}|Toks], Pos);
+ _Error -> scan_error({illegal,var}, Pos)
+ end.
+
+%% scan_name(Cs) -> lists:splitwith(fun (C) -> name_char(C) end, Cs).
+
+scan_name([C|Cs], Ncs) ->
+ case name_char(C) of
+ true -> scan_name(Cs, [C|Ncs]);
+ false -> {Ncs,[C|Cs]} %Must rebuild here, sigh!
+ end;
+scan_name([], Ncs) ->
+ {Ncs,[]}.
+
+name_char(C) when C >= $a, C =< $z -> true;
+name_char(C) when C >= $�, C =< $�, C /= $� -> true;
+name_char(C) when C >= $A, C =< $Z -> true;
+name_char(C) when C >= $�, C =< $�, C /= $� -> true;
+name_char(C) when C >= $0, C =< $9 -> true;
+name_char($_) -> true;
+name_char($@) -> true;
+name_char(_) -> false.
+
+%% scan_string(CharList, QuoteChar, Pos) -> {StringChars,RestChars,NewPos}.
+
+scan_string(Cs, Q, Pos) ->
+ scan_string(Cs, [], Q, Pos).
+
+scan_string([Q|Cs], Scs, Q, Pos) ->
+ {reverse(Scs),Cs,Pos};
+scan_string([$\n|Cs], Scs, Q, Pos) ->
+ scan_string(Cs, [$\n|Scs], Q, Pos+1);
+scan_string([$\\|Cs0], Scs, Q, Pos) ->
+ {C,Cs,Pos1} = scan_escape(Cs0, Pos),
+ scan_string(Cs, [C|Scs], Q, Pos1);
+scan_string([C|Cs], Scs, Q, Pos) ->
+ scan_string(Cs, [C|Scs], Q, Pos).
+
+%% scan_char(Chars, Pos) -> {Char,RestChars,NewPos}.
+%% Read a single character from a character constant. The pre-scan
+%% phase has checked for errors here.
+
+scan_char([$\\|Cs], Pos) ->
+ scan_escape(Cs, Pos);
+scan_char([$\n|Cs], Pos) -> %Newline
+ {$\n,Cs,Pos+1};
+scan_char([C|Cs], Pos) ->
+ {C,Cs,Pos}.
+
+scan_escape([O1,O2,O3|Cs], Pos) when %\<1-3> octal digits
+ O1 >= $0, O1 =< $7, O2 >= $0, O2 =< $7, O3 >= $0, O3 =< $7 ->
+ Val = (O1*8 + O2)*8 + O3 - 73*$0,
+ {Val,Cs,Pos};
+scan_escape([O1,O2|Cs], Pos) when
+ O1 >= $0, O1 =< $7, O2 >= $0, O2 =< $7 ->
+ Val = (O1*8 + O2) - 9*$0,
+ {Val,Cs,Pos};
+scan_escape([O1|Cs], Pos) when
+ O1 >= $0, O1 =< $7 ->
+ {O1 - $0,Cs,Pos};
+scan_escape([$^,C|Cs], Pos) -> %\^X -> CTL-X
+ Val = C band 31,
+ {Val,Cs,Pos};
+%scan_escape([$\n,C1|Cs],Pos) ->
+% {C1,Cs,Pos+1};
+%scan_escape([C,C1|Cs],Pos) when C >= $\000, C =< $\s ->
+% {C1,Cs,Pos};
+scan_escape([$\n|Cs],Pos) ->
+ {$\n,Cs,Pos+1};
+scan_escape([C0|Cs],Pos) ->
+ C = escape_char(C0),
+ {C,Cs,Pos}.
+
+escape_char($n) -> $\n; %\n = LF
+escape_char($r) -> $\r; %\r = CR
+escape_char($t) -> $\t; %\t = TAB
+escape_char($v) -> $\v; %\v = VT
+escape_char($b) -> $\b; %\b = BS
+escape_char($f) -> $\f; %\f = FF
+escape_char($e) -> $\e; %\e = ESC
+escape_char($s) -> $\s; %\s = SPC
+escape_char($d) -> $\d; %\d = DEL
+escape_char(C) -> C.
+
+%% scan_number(Char, CharList, TokenStack, Pos)
+%% We can handle simple radix notation:
+%% <digit>#<digits> - the digits read in that base
+%% <digits> - the digits in base 10
+%% <digits>.<digits>
+%% <digits>.<digits>E+-<digits>
+%%
+%% Except for explicitly based integers we build a list of all the
+%% characters and then use list_to_integer/1 or list_to_float/1 to
+%% generate the value.
+
+%% SPos == Start position
+%% CPos == Current position
+
+scan_number(C, Cs0, Toks, Pos) ->
+ {Ncs,Cs,Pos1} = scan_integer(Cs0, [C], Pos),
+ scan_after_int(Cs, Ncs, Toks, Pos, Pos1).
+
+scan_signed_number(S, C, Cs0, Toks, Pos) ->
+ {Ncs,Cs,Pos1} = scan_integer(Cs0, [C,S], Pos),
+ scan_after_int(Cs, Ncs, Toks, Pos, Pos1).
+
+scan_integer([C|Cs], Stack, Pos) when C >= $0, C =< $9 ->
+ scan_integer(Cs, [C|Stack], Pos);
+scan_integer(Cs, Stack, Pos) ->
+ {Stack,Cs,Pos}.
+
+scan_after_int([$.,C|Cs0], Ncs0, Toks, SPos, CPos) when C >= $0, C =< $9 ->
+ {Ncs,Cs,CPos1} = scan_integer(Cs0, [C,$.|Ncs0], CPos),
+ scan_after_fraction(Cs, Ncs, Toks, SPos, CPos1);
+scan_after_int([$#|Cs], Ncs, Toks, SPos, CPos) ->
+ case list_to_integer(reverse(Ncs)) of
+ Base when Base >= 2, Base =< 16 ->
+ scan_based_int(Cs, 0, Base, Toks, SPos, CPos);
+ Base ->
+ scan_error({base,Base}, CPos)
+ end;
+scan_after_int(Cs, Ncs, Toks, SPos, CPos) ->
+ N = list_to_integer(reverse(Ncs)),
+ scan1(Cs, [{integer,SPos,N}|Toks], CPos).
+
+scan_based_int([C|Cs], SoFar, Base, Toks, SPos, CPos) when
+ C >= $0, C =< $9, C < Base + $0 ->
+ Next = SoFar * Base + (C - $0),
+ scan_based_int(Cs, Next, Base, Toks, SPos, CPos);
+scan_based_int([C|Cs], SoFar, Base, Toks, SPos, CPos) when
+ C >= $a, C =< $f, C < Base + $a - 10 ->
+ Next = SoFar * Base + (C - $a + 10),
+ scan_based_int(Cs, Next, Base, Toks, SPos, CPos);
+scan_based_int([C|Cs], SoFar, Base, Toks, SPos, CPos) when
+ C >= $A, C =< $F, C < Base + $A - 10 ->
+ Next = SoFar * Base + (C - $A + 10),
+ scan_based_int(Cs, Next, Base, Toks, SPos, CPos);
+scan_based_int(Cs, SoFar, _, Toks, SPos, CPos) ->
+ scan1(Cs, [{integer,SPos,SoFar}|Toks], CPos).
+
+scan_after_fraction([$E|Cs], Ncs, Toks, SPos, CPos) ->
+ scan_exponent(Cs, [$E|Ncs], Toks, SPos, CPos);
+scan_after_fraction([$e|Cs], Ncs, Toks, SPos, CPos) ->
+ scan_exponent(Cs, [$E|Ncs], Toks, SPos, CPos);
+scan_after_fraction(Cs, Ncs, Toks, SPos, CPos) ->
+ case catch list_to_float(reverse(Ncs)) of
+ N when is_float(N) ->
+ scan1(Cs, [{float,SPos,N}|Toks], CPos);
+ _Error -> scan_error({illegal,float}, SPos)
+ end.
+
+%% scan_exponent(CharList, NumberCharStack, TokenStack, StartPos, CurPos)
+%% Generate an error here if E{+|-} not followed by any digits.
+
+scan_exponent([$+|Cs], Ncs, Toks, SPos, CPos) ->
+ scan_exponent1(Cs, [$+|Ncs], Toks, SPos, CPos);
+scan_exponent([$-|Cs], Ncs, Toks, SPos, CPos) ->
+ scan_exponent1(Cs, [$-|Ncs], Toks, SPos, CPos);
+scan_exponent(Cs, Ncs, Toks, SPos, CPos) ->
+ scan_exponent1(Cs, Ncs, Toks, SPos, CPos).
+
+scan_exponent1([C|Cs0], Ncs0, Toks, SPos, CPos) when C >= $0, C =< $9 ->
+ {Ncs,Cs,CPos1} = scan_integer(Cs0, [C|Ncs0], CPos),
+ case catch list_to_float(reverse(Ncs)) of
+ N when is_float(N) ->
+ scan1(Cs, [{float,SPos,N}|Toks], CPos1);
+ _Error -> scan_error({illegal,float}, SPos)
+ end;
+scan_exponent1(_, _, _, _, CPos) ->
+ scan_error(float, CPos).
+
+scan_error(In, Pos) ->
+ {error,{Pos,core_scan,In}}.
diff --git a/lib/compiler/src/erl_bifs.erl b/lib/compiler/src/erl_bifs.erl
new file mode 100644
index 0000000000..e87bb276de
--- /dev/null
+++ b/lib/compiler/src/erl_bifs.erl
@@ -0,0 +1,217 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2001-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%
+%%
+%% Purpose: Information about the Erlang built-in functions.
+
+-module(erl_bifs).
+
+-export([is_pure/3, is_safe/3, is_exit_bif/3]).
+
+%% =====================================================================
+%% is_pure(Module, Name, Arity) -> boolean()
+%%
+%% Module = Name = atom()
+%% Arity = integer()
+%%
+%% Returns `true' if the function `Module:Name/Arity' does not
+%% affect the state, nor depend on the state, although its
+%% evaluation is not guaranteed to complete normally for all input.
+
+-spec is_pure(atom(), atom(), arity()) -> boolean().
+
+is_pure(erlang, '*', 2) -> true;
+is_pure(erlang, '+', 1) -> true; % (even for non-numbers)
+is_pure(erlang, '+', 2) -> true;
+is_pure(erlang, '++', 2) -> true;
+is_pure(erlang, '-', 1) -> true;
+is_pure(erlang, '-', 2) -> true;
+is_pure(erlang, '--', 2) -> true;
+is_pure(erlang, '/', 2) -> true;
+is_pure(erlang, '/=', 2) -> true;
+is_pure(erlang, '<', 2) -> true;
+is_pure(erlang, '=/=', 2) -> true;
+is_pure(erlang, '=:=', 2) -> true;
+is_pure(erlang, '=<', 2) -> true;
+is_pure(erlang, '==', 2) -> true;
+is_pure(erlang, '>', 2) -> true;
+is_pure(erlang, '>=', 2) -> true;
+is_pure(erlang, 'and', 2) -> true;
+is_pure(erlang, 'band', 2) -> true;
+is_pure(erlang, 'bnot', 1) -> true;
+is_pure(erlang, 'bor', 2) -> true;
+is_pure(erlang, 'bsl', 2) -> true;
+is_pure(erlang, 'bsr', 2) -> true;
+is_pure(erlang, 'bxor', 2) -> true;
+is_pure(erlang, 'div', 2) -> true;
+is_pure(erlang, 'not', 1) -> true;
+is_pure(erlang, 'or', 2) -> true;
+is_pure(erlang, 'rem', 2) -> true;
+is_pure(erlang, 'xor', 2) -> true;
+is_pure(erlang, abs, 1) -> true;
+is_pure(erlang, atom_to_binary, 2) -> true;
+is_pure(erlang, atom_to_list, 1) -> true;
+is_pure(erlang, binary_to_atom, 2) -> true;
+is_pure(erlang, binary_to_list, 1) -> true;
+is_pure(erlang, binary_to_list, 3) -> true;
+is_pure(erlang, bit_size, 1) -> true;
+is_pure(erlang, byte_size, 1) -> true;
+is_pure(erlang, concat_binary, 1) -> true;
+is_pure(erlang, element, 2) -> true;
+is_pure(erlang, float, 1) -> true;
+is_pure(erlang, float_to_list, 1) -> true;
+is_pure(erlang, hash, 2) -> false;
+is_pure(erlang, hd, 1) -> true;
+is_pure(erlang, integer_to_list, 1) -> true;
+is_pure(erlang, is_atom, 1) -> true;
+is_pure(erlang, is_boolean, 1) -> true;
+is_pure(erlang, is_binary, 1) -> true;
+is_pure(erlang, is_bitstring, 1) -> true;
+%% erlang:is_builtin/3 depends on the state (i.e. the version of the emulator).
+is_pure(erlang, is_float, 1) -> true;
+is_pure(erlang, is_function, 1) -> true;
+is_pure(erlang, is_integer, 1) -> true;
+is_pure(erlang, is_list, 1) -> true;
+is_pure(erlang, is_number, 1) -> true;
+is_pure(erlang, is_pid, 1) -> true;
+is_pure(erlang, is_port, 1) -> true;
+is_pure(erlang, is_record, 2) -> true;
+is_pure(erlang, is_record, 3) -> true;
+is_pure(erlang, is_reference, 1) -> true;
+is_pure(erlang, is_tuple, 1) -> true;
+is_pure(erlang, length, 1) -> true;
+is_pure(erlang, list_to_atom, 1) -> true;
+is_pure(erlang, list_to_binary, 1) -> true;
+is_pure(erlang, list_to_float, 1) -> true;
+is_pure(erlang, list_to_integer, 1) -> true;
+is_pure(erlang, list_to_pid, 1) -> true;
+is_pure(erlang, list_to_tuple, 1) -> true;
+is_pure(erlang, max, 2) -> true;
+is_pure(erlang, min, 2) -> true;
+is_pure(erlang, phash, 2) -> false;
+is_pure(erlang, pid_to_list, 1) -> true;
+is_pure(erlang, round, 1) -> true;
+is_pure(erlang, setelement, 3) -> true;
+is_pure(erlang, size, 1) -> true;
+is_pure(erlang, split_binary, 2) -> true;
+is_pure(erlang, term_to_binary, 1) -> true;
+is_pure(erlang, tl, 1) -> true;
+is_pure(erlang, trunc, 1) -> true;
+is_pure(erlang, tuple_size, 1) -> true;
+is_pure(erlang, tuple_to_list, 1) -> true;
+is_pure(lists, append, 2) -> true;
+is_pure(lists, subtract, 2) -> true;
+is_pure(math, acos, 1) -> true;
+is_pure(math, acosh, 1) -> true;
+is_pure(math, asin, 1) -> true;
+is_pure(math, asinh, 1) -> true;
+is_pure(math, atan, 1) -> true;
+is_pure(math, atan2, 2) -> true;
+is_pure(math, atanh, 1) -> true;
+is_pure(math, cos, 1) -> true;
+is_pure(math, cosh, 1) -> true;
+is_pure(math, erf, 1) -> true;
+is_pure(math, erfc, 1) -> true;
+is_pure(math, exp, 1) -> true;
+is_pure(math, log, 1) -> true;
+is_pure(math, log10, 1) -> true;
+is_pure(math, pow, 2) -> true;
+is_pure(math, sin, 1) -> true;
+is_pure(math, sinh, 1) -> true;
+is_pure(math, sqrt, 1) -> true;
+is_pure(math, tan, 1) -> true;
+is_pure(math, tanh, 1) -> true;
+is_pure(_, _, _) -> false.
+
+
+%% =====================================================================
+%% is_safe(Module, Name, Arity) -> boolean()
+%%
+%% Module = Name = atom()
+%% Arity = integer()
+%%
+%% Returns `true' if the function `Module:Name/Arity' is completely
+%% effect free, i.e., if its evaluation always completes normally
+%% and does not affect the state (although the value it returns
+%% might depend on the state).
+%%
+%% Note: is_function/2 and is_record/3 are NOT safe: is_function(X, foo)
+%% and is_record(X, foo, bar) will fail.
+
+-spec is_safe(atom(), atom(), arity()) -> boolean().
+
+is_safe(erlang, '/=', 2) -> true;
+is_safe(erlang, '<', 2) -> true;
+is_safe(erlang, '=/=', 2) -> true;
+is_safe(erlang, '=:=', 2) -> true;
+is_safe(erlang, '=<', 2) -> true;
+is_safe(erlang, '==', 2) -> true;
+is_safe(erlang, '>', 2) -> true;
+is_safe(erlang, '>=', 2) -> true;
+is_safe(erlang, date, 0) -> true;
+is_safe(erlang, get, 0) -> true;
+is_safe(erlang, get, 1) -> true;
+is_safe(erlang, get_cookie, 0) -> true;
+is_safe(erlang, get_keys, 1) -> true;
+is_safe(erlang, group_leader, 0) -> true;
+is_safe(erlang, is_alive, 0) -> true;
+is_safe(erlang, is_atom, 1) -> true;
+is_safe(erlang, is_boolean, 1) -> true;
+is_safe(erlang, is_binary, 1) -> true;
+is_safe(erlang, is_bitstring, 1) -> true;
+is_safe(erlang, is_float, 1) -> true;
+is_safe(erlang, is_function, 1) -> true;
+is_safe(erlang, is_integer, 1) -> true;
+is_safe(erlang, is_list, 1) -> true;
+is_safe(erlang, is_number, 1) -> true;
+is_safe(erlang, is_pid, 1) -> true;
+is_safe(erlang, is_port, 1) -> true;
+is_safe(erlang, is_reference, 1) -> true;
+is_safe(erlang, is_tuple, 1) -> true;
+is_safe(erlang, make_ref, 0) -> true;
+is_safe(erlang, max, 2) -> true;
+is_safe(erlang, min, 2) -> true;
+is_safe(erlang, node, 0) -> true;
+is_safe(erlang, nodes, 0) -> true;
+is_safe(erlang, ports, 0) -> true;
+is_safe(erlang, pre_loaded, 0) -> true;
+is_safe(erlang, processes, 0) -> true;
+is_safe(erlang, registered, 0) -> true;
+is_safe(erlang, self, 0) -> true;
+is_safe(erlang, term_to_binary, 1) -> true;
+is_safe(erlang, time, 0) -> true;
+is_safe(error_logger, warning_map, 0) -> true;
+is_safe(_, _, _) -> false.
+
+
+%% =====================================================================
+%% is_exit_bif(Module, Name, Arity) -> boolean()
+%%
+%% Module = Name = atom()
+%% Arity = integer()
+%%
+%% Returns `true' if the function `Module:Name/Arity' never returns
+%% normally, i.e., if it always causes an exception regardless of
+%% its arguments.
+
+-spec is_exit_bif(atom(), atom(), arity()) -> boolean().
+
+is_exit_bif(erlang, exit, 1) -> true;
+is_exit_bif(erlang, throw, 1) -> true;
+is_exit_bif(erlang, error, 1) -> true;
+is_exit_bif(erlang, error, 2) -> true;
+is_exit_bif(_, _, _) -> false.
diff --git a/lib/compiler/src/genop.tab b/lib/compiler/src/genop.tab
new file mode 100644
index 0000000000..6874054495
--- /dev/null
+++ b/lib/compiler/src/genop.tab
@@ -0,0 +1,276 @@
+#
+# %CopyrightBegin%
+#
+# Copyright Ericsson AB 1998-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%
+#
+BEAM_FORMAT_NUMBER=0
+
+#
+# Generic instructions, generated by the compiler. If any of them change number,
+# arity or semantics, the format number above must be bumped.
+#
+
+1: label/1
+2: func_info/3
+3: int_code_end/0
+
+#
+# Function and BIF calls.
+#
+4: call/2
+5: call_last/3
+6: call_only/2
+
+7: call_ext/2
+8: call_ext_last/3
+
+9: bif0/2
+10: bif1/4
+11: bif2/5
+
+#
+# Allocating, deallocating and returning.
+#
+12: allocate/2
+13: allocate_heap/3
+14: allocate_zero/2
+15: allocate_heap_zero/3
+16: test_heap/2
+17: init/1
+18: deallocate/1
+19: return/0
+
+#
+# Sending & receiving.
+#
+20: send/0
+21: remove_message/0
+22: timeout/0
+23: loop_rec/2
+24: loop_rec_end/1
+25: wait/1
+26: wait_timeout/2
+
+#
+# Arithmethic opcodes.
+#
+27: -m_plus/4
+28: -m_minus/4
+29: -m_times/4
+30: -m_div/4
+31: -int_div/4
+32: -int_rem/4
+33: -int_band/4
+34: -int_bor/4
+35: -int_bxor/4
+36: -int_bsl/4
+37: -int_bsr/4
+38: -int_bnot/3
+
+#
+# Comparision operators.
+#
+39: is_lt/3
+40: is_ge/3
+41: is_eq/3
+42: is_ne/3
+43: is_eq_exact/3
+44: is_ne_exact/3
+
+#
+# Type tests.
+#
+45: is_integer/2
+46: is_float/2
+47: is_number/2
+48: is_atom/2
+49: is_pid/2
+50: is_reference/2
+51: is_port/2
+52: is_nil/2
+53: is_binary/2
+54: -is_constant/2
+55: is_list/2
+56: is_nonempty_list/2
+57: is_tuple/2
+58: test_arity/3
+
+#
+# Indexing & jumping.
+#
+59: select_val/3
+60: select_tuple_arity/3
+61: jump/1
+
+#
+# Catch.
+#
+62: catch/2
+63: catch_end/1
+
+#
+# Moving, extracting, modifying.
+#
+64: move/2
+65: get_list/3
+66: get_tuple_element/3
+67: set_tuple_element/3
+
+#
+# Building terms.
+#
+68: put_string/3
+69: put_list/3
+70: put_tuple/2
+71: put/1
+
+#
+# Raising errors.
+#
+72: badmatch/1
+73: if_end/0
+74: case_end/1
+
+#
+# 'fun' support.
+#
+75: call_fun/1
+76: -make_fun/3
+77: is_function/2
+
+#
+# Late additions to R5.
+#
+78: call_ext_only/2
+
+#
+# Binary matching (R7).
+#
+79: -bs_start_match/2
+80: -bs_get_integer/5
+81: -bs_get_float/5
+82: -bs_get_binary/5
+83: -bs_skip_bits/4
+84: -bs_test_tail/2
+85: -bs_save/1
+86: -bs_restore/1
+
+#
+# Binary construction (R7A).
+#
+87: -bs_init/2
+88: -bs_final/2
+89: bs_put_integer/5
+90: bs_put_binary/5
+91: bs_put_float/5
+92: bs_put_string/2
+
+#
+# Binary construction (R7B).
+#
+93: -bs_need_buf/1
+
+#
+# Floating point arithmetic (R8).
+#
+94: fclearerror/0
+95: fcheckerror/1
+96: fmove/2
+97: fconv/2
+98: fadd/4
+99: fsub/4
+100: fmul/4
+101: fdiv/4
+102: fnegate/3
+
+# New fun construction (R8).
+103: make_fun2/1
+
+# Try/catch/raise (R10B).
+104: try/2
+105: try_end/1
+106: try_case/1
+107: try_case_end/1
+108: raise/2
+
+# New instructions in R10B.
+109: bs_init2/6
+110: bs_bits_to_bytes/3
+111: bs_add/5
+112: apply/1
+113: apply_last/2
+114: is_boolean/2
+
+# New instructions in R10B-6.
+115: is_function2/3
+
+# New bit syntax matching in R11B.
+
+116: bs_start_match2/5
+117: bs_get_integer2/7
+118: bs_get_float2/7
+119: bs_get_binary2/7
+120: bs_skip_bits2/5
+121: bs_test_tail2/3
+122: bs_save2/2
+123: bs_restore2/2
+
+# New GC bifs introduced in R11B.
+124: gc_bif1/5
+125: gc_bif2/6
+
+# Experimental new bit_level bifs introduced in R11B.
+# NOT used in R12B.
+126: -bs_final2/2
+127: -bs_bits_to_bytes2/2
+
+# R11B-4
+128: -put_literal/2
+
+# R11B-5
+129: is_bitstr/2
+
+# R12B
+130: bs_context_to_binary/1
+131: bs_test_unit/3
+132: bs_match_string/4
+133: bs_init_writable/0
+134: bs_append/8
+135: bs_private_append/6
+136: trim/2
+137: bs_init_bits/6
+
+# R12B-5
+138: bs_get_utf8/5
+139: bs_skip_utf8/4
+
+140: bs_get_utf16/5
+141: bs_skip_utf16/4
+
+142: bs_get_utf32/5
+143: bs_skip_utf32/4
+
+144: bs_utf8_size/3
+145: bs_put_utf8/3
+
+146: bs_utf16_size/3
+147: bs_put_utf16/3
+
+148: bs_put_utf32/3
+
+# R13B03
+
+149: on_load/0
diff --git a/lib/compiler/src/rec_env.erl b/lib/compiler/src/rec_env.erl
new file mode 100644
index 0000000000..9b73e08ad8
--- /dev/null
+++ b/lib/compiler/src/rec_env.erl
@@ -0,0 +1,640 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2001-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+%%
+%% @author Richard Carlsson <[email protected]>
+%% @copyright 1999-2004 Richard Carlsson
+%% @doc Abstract environments, supporting self-referential bindings and
+%% automatic new-key generation.
+
+%% The current implementation is based on Erlang standard library
+%% dictionaries.
+
+%%% -define(DEBUG, true).
+
+-module(rec_env).
+
+-export([bind/3, bind_list/3, bind_recursive/4, delete/2, empty/0,
+ get/2, is_defined/2, is_empty/1, keys/1, lookup/2, new_key/1,
+ new_key/2, new_keys/2, new_keys/3, size/1, to_list/1]).
+
+-import(erlang, [max/2]).
+
+-ifdef(DEBUG).
+-export([test/1, test_custom/1, test_custom/2]).
+-endif.
+
+-ifdef(DEBUG).
+%% Code for testing:
+%%@hidden
+test(N) ->
+ test_0(integer, N).
+
+%%@hidden
+test_custom(N) ->
+ F = fun (X) -> list_to_atom("X"++integer_to_list(X)) end,
+ test_custom(F, N).
+
+%%@hidden
+test_custom(F, N) ->
+ test_0({custom, F}, N).
+
+test_0(Type, N) ->
+ put(new_key_calls, 0),
+ put(new_key_retries, 0),
+ put(new_key_max, 0),
+ Env = test_1(Type, N, empty()),
+ io:fwrite("\ncalls: ~w.\n", [get(new_key_calls)]),
+ io:fwrite("\nretries: ~w.\n", [get(new_key_retries)]),
+ io:fwrite("\nmax: ~w.\n", [get(new_key_max)]),
+ dict:to_list(element(1,Env)).
+
+test_1(integer = Type, N, Env) when is_integer(N), N > 0 ->
+ Key = new_key(Env),
+ test_1(Type, N - 1, bind(Key, value, Env));
+test_1({custom, F} = Type, N, Env) when is_integer(N), N > 0 ->
+ Key = new_key(F, Env),
+ test_1(Type, N - 1, bind(Key, value, Env));
+test_1(_,0, Env) ->
+ Env.
+-endif.
+
+
+%% Representation:
+%%
+%% environment() = [Mapping]
+%%
+%% Mapping = {map, Dict} | {rec, Dict, Dict}
+%% Dict = dict:dictionary()
+%%
+%% An empty environment is a list containing a single `{map, Dict}'
+%% element - empty lists are not valid environments. To find a key in an
+%% environment, it is searched for in each mapping in the list, in
+%% order, until it the key is found in some mapping, or the end of the
+%% list is reached. In a 'rec' mapping, we keep the original dictionary
+%% together with a version where entries may have been deleted - this
+%% makes it possible to garbage collect the entire 'rec' mapping when
+%% all its entries are unused (for example, by being shadowed by later
+%% definitions).
+
+
+%% =====================================================================
+%% @type environment(). An abstract environment.
+
+-type mapping() :: {'map', dict()} | {'rec', dict(), dict()}.
+-type environment() :: [mapping(),...].
+
+%% =====================================================================
+%% @spec empty() -> environment()
+%%
+%% @doc Returns an empty environment.
+
+-spec empty() -> environment().
+
+empty() ->
+ [{map, dict:new()}].
+
+
+%% =====================================================================
+%% @spec is_empty(Env::environment()) -> boolean()
+%%
+%% @doc Returns <code>true</code> if the environment is empty, otherwise
+%% <code>false</code>.
+
+-spec is_empty(environment()) -> boolean().
+
+is_empty([{map, Dict} | Es]) ->
+ N = dict:size(Dict),
+ if N =/= 0 -> false;
+ Es =:= [] -> true;
+ true -> is_empty(Es)
+ end;
+is_empty([{rec, Dict, _} | Es]) ->
+ N = dict:size(Dict),
+ if N =/= 0 -> false;
+ Es =:= [] -> true;
+ true -> is_empty(Es)
+ end.
+
+
+%% =====================================================================
+%% @spec size(Env::environment()) -> integer()
+%%
+%% @doc Returns the number of entries in an environment.
+
+%% (The name 'size' cannot be used in local calls, since there exists a
+%% built-in function with the same name.)
+
+-spec size(environment()) -> non_neg_integer().
+
+size(Env) ->
+ env_size(Env).
+
+env_size([{map, Dict}]) ->
+ dict:size(Dict);
+env_size([{map, Dict} | Env]) ->
+ dict:size(Dict) + env_size(Env);
+env_size([{rec, Dict, _Dict0} | Env]) ->
+ dict:size(Dict) + env_size(Env).
+
+
+%% =====================================================================
+%% @spec is_defined(Key, Env) -> boolean()
+%%
+%% Key = term()
+%% Env = environment()
+%%
+%% @doc Returns <code>true</code> if <code>Key</code> is bound in the
+%% environment, otherwise <code>false</code>.
+
+-spec is_defined(term(), environment()) -> boolean().
+
+is_defined(Key, [{map, Dict} | Env]) ->
+ case dict:is_key(Key, Dict) of
+ true ->
+ true;
+ false when Env =:= [] ->
+ false;
+ false ->
+ is_defined(Key, Env)
+ end;
+is_defined(Key, [{rec, Dict, _Dict0} | Env]) ->
+ dict:is_key(Key, Dict) orelse is_defined(Key, Env).
+
+
+%% =====================================================================
+%% @spec keys(Env::environment()) -> [term()]
+%%
+%% @doc Returns the ordered list of all keys in the environment.
+
+-spec keys(environment()) -> [term()].
+
+keys(Env) ->
+ lists:sort(keys(Env, [])).
+
+keys([{map, Dict}], S) ->
+ dict:fetch_keys(Dict) ++ S;
+keys([{map, Dict} | Env], S) ->
+ keys(Env, dict:fetch_keys(Dict) ++ S);
+keys([{rec, Dict, _Dict0} | Env], S) ->
+ keys(Env, dict:fetch_keys(Dict) ++ S).
+
+
+%% =====================================================================
+%% @spec to_list(Env) -> [{Key, Value}]
+%%
+%% Env = environment()
+%% Key = term()
+%% Value = term()
+%%
+%% @doc Returns an ordered list of <code>{Key, Value}</code> pairs for
+%% all keys in <code>Env</code>. <code>Value</code> is the same as that
+%% returned by {@link get/2}.
+
+-spec to_list(environment()) -> [{term(), term()}].
+
+to_list(Env) ->
+ lists:sort(to_list(Env, [])).
+
+to_list([{map, Dict}], S) ->
+ dict:to_list(Dict) ++ S;
+to_list([{map, Dict} | Env], S) ->
+ to_list(Env, dict:to_list(Dict) ++ S);
+to_list([{rec, Dict, _Dict0} | Env], S) ->
+ to_list(Env, dict:to_list(Dict) ++ S).
+
+
+%% =====================================================================
+%% @spec bind(Key, Value, Env) -> environment()
+%%
+%% Key = term()
+%% Value = term()
+%% Env = environment()
+%%
+%% @doc Make a nonrecursive entry. This binds <code>Key</code> to
+%% <code>Value</code>. If the key already existed in the environment,
+%% the old entry is replaced.
+
+%% Note that deletion is done to free old bindings so they can be
+%% garbage collected.
+
+-spec bind(term(), term(), environment()) -> environment().
+
+bind(Key, Value, [{map, Dict}]) ->
+ [{map, dict:store(Key, Value, Dict)}];
+bind(Key, Value, [{map, Dict} | Env]) ->
+ [{map, dict:store(Key, Value, Dict)} | delete_any(Key, Env)];
+bind(Key, Value, Env) ->
+ [{map, dict:store(Key, Value, dict:new())} | delete_any(Key, Env)].
+
+
+%% =====================================================================
+%% @spec bind_list(Keys, Values, Env) -> environment()
+%%
+%% Keys = [term()]
+%% Values = [term()]
+%% Env = environment()
+%%
+%% @doc Make N nonrecursive entries. This binds each key in
+%% <code>Keys</code> to the corresponding value in
+%% <code>Values</code>. If some key already existed in the environment,
+%% the previous entry is replaced. If <code>Keys</code> does not have
+%% the same length as <code>Values</code>, an exception is generated.
+
+-spec bind_list([term()], [term()], environment()) -> environment().
+
+bind_list(Ks, Vs, [{map, Dict}]) ->
+ [{map, store_list(Ks, Vs, Dict)}];
+bind_list(Ks, Vs, [{map, Dict} | Env]) ->
+ [{map, store_list(Ks, Vs, Dict)} | delete_list(Ks, Env)];
+bind_list(Ks, Vs, Env) ->
+ [{map, store_list(Ks, Vs, dict:new())} | delete_list(Ks, Env)].
+
+store_list([K | Ks], [V | Vs], Dict) ->
+ store_list(Ks, Vs, dict:store(K, V, Dict));
+store_list([], _, Dict) ->
+ Dict.
+
+delete_list([K | Ks], Env) ->
+ delete_list(Ks, delete_any(K, Env));
+delete_list([], Env) ->
+ Env.
+
+%% By not calling `delete' unless we have to, we avoid unnecessary
+%% rewriting of the data.
+
+delete_any(Key, Env) ->
+ case is_defined(Key, Env) of
+ true ->
+ delete(Key, Env);
+ false ->
+ Env
+ end.
+
+%% =====================================================================
+%% @spec delete(Key, Env) -> environment()
+%%
+%% Key = term()
+%% Env = environment()
+%%
+%% @doc Delete an entry. This removes <code>Key</code> from the
+%% environment.
+
+-spec delete(term(), environment()) -> environment().
+
+delete(Key, [{map, Dict} = E | Env]) ->
+ case dict:is_key(Key, Dict) of
+ true ->
+ [{map, dict:erase(Key, Dict)} | Env];
+ false ->
+ delete_1(Key, Env, E)
+ end;
+delete(Key, [{rec, Dict, Dict0} = E | Env]) ->
+ case dict:is_key(Key, Dict) of
+ true ->
+ %% The Dict0 component must be preserved as it is until all
+ %% keys in Dict have been deleted.
+ Dict1 = dict:erase(Key, Dict),
+ case dict:size(Dict1) of
+ 0 ->
+ Env; % the whole {rec,...} is now garbage
+ _ ->
+ [{rec, Dict1, Dict0} | Env]
+ end;
+ false ->
+ [E | delete(Key, Env)]
+ end.
+
+%% This is just like above, except we pass on the preceding 'map'
+%% mapping in the list to enable merging when removing 'rec' mappings.
+
+delete_1(Key, [{rec, Dict, Dict0} = E | Env], E1) ->
+ case dict:is_key(Key, Dict) of
+ true ->
+ Dict1 = dict:erase(Key, Dict),
+ case dict:size(Dict1) of
+ 0 ->
+ concat(E1, Env);
+ _ ->
+ [E1, {rec, Dict1, Dict0} | Env]
+ end;
+ false ->
+ [E1, E | delete(Key, Env)]
+ end.
+
+concat({map, D1}, [{map, D2} | Env]) ->
+ [dict:merge(fun (_K, V1, _V2) -> V1 end, D1, D2) | Env];
+concat(E1, Env) ->
+ [E1 | Env].
+
+
+%% =====================================================================
+%% @spec bind_recursive(Keys, Values, Fun, Env) -> NewEnv
+%%
+%% Keys = [term()]
+%% Values = [term()]
+%% Fun = (Value, Env) -> term()
+%% Env = environment()
+%% NewEnv = environment()
+%%
+%% @doc Make N recursive entries. This binds each key in
+%% <code>Keys</code> to the value of <code>Fun(Value, NewEnv)</code> for
+%% the corresponding <code>Value</code>. If <code>Keys</code> does not
+%% have the same length as <code>Values</code>, an exception is
+%% generated. If some key already existed in the environment, the old
+%% entry is replaced.
+%%
+%% <p>Note: the function <code>Fun</code> is evaluated each time one of
+%% the stored keys is looked up, but only then.</p>
+%%
+%% <p>Examples:
+%%<pre>
+%% NewEnv = bind_recursive([foo, bar], [1, 2],
+%% fun (V, E) -> V end,
+%% Env)</pre>
+%%
+%% This does nothing interesting; <code>get(foo, NewEnv)</code> yields
+%% <code>1</code> and <code>get(bar, NewEnv)</code> yields
+%% <code>2</code>, but there is more overhead than if the {@link
+%% bind_list/3} function had been used.
+%%
+%% <pre>
+%% NewEnv = bind_recursive([foo, bar], [1, 2],
+%% fun (V, E) -> {V, E} end,
+%% Env)</pre>
+%%
+%% Here, however, <code>get(foo, NewEnv)</code> will yield <code>{1,
+%% NewEnv}</code> and <code>get(bar, NewEnv)</code> will yield <code>{2,
+%% NewEnv}</code>, i.e., the environment <code>NewEnv</code> contains
+%% recursive bindings.</p>
+
+-spec bind_recursive([term()], [term()],
+ fun((term(), environment()) -> term()),
+ environment()) -> environment().
+
+bind_recursive([], [], _, Env) ->
+ Env;
+bind_recursive(Ks, Vs, F, Env) ->
+ F1 = fun (V) ->
+ fun (Dict) -> F(V, [{rec, Dict, Dict} | Env]) end
+ end,
+ Dict = bind_recursive_1(Ks, Vs, F1, dict:new()),
+ [{rec, Dict, Dict} | Env].
+
+bind_recursive_1([K | Ks], [V | Vs], F, Dict) ->
+ bind_recursive_1(Ks, Vs, F, dict:store(K, F(V), Dict));
+bind_recursive_1([], [], _, Dict) ->
+ Dict.
+
+
+%% =====================================================================
+%% @spec lookup(Key, Env) -> error | {ok, Value}
+%%
+%% Key = term()
+%% Env = environment()
+%% Value = term()
+%%
+%% @doc Returns <code>{ok, Value}</code> if <code>Key</code> is bound to
+%% <code>Value</code> in <code>Env</code>, and <code>error</code>
+%% otherwise.
+
+-spec lookup(term(), environment()) -> 'error' | {'ok', term()}.
+
+lookup(Key, [{map, Dict} | Env]) ->
+ case dict:find(Key, Dict) of
+ {ok, _}=Value ->
+ Value;
+ error when Env =:= [] ->
+ error;
+ error ->
+ lookup(Key, Env)
+ end;
+lookup(Key, [{rec, Dict, Dict0} | Env]) ->
+ case dict:find(Key, Dict) of
+ {ok, F} ->
+ {ok, F(Dict0)};
+ error ->
+ lookup(Key, Env)
+ end.
+
+
+%% =====================================================================
+%% @spec get(Key, Env) -> Value
+%%
+%% Key = term()
+%% Env = environment()
+%% Value = term()
+%%
+%% @doc Returns the value that <code>Key</code> is bound to in
+%% <code>Env</code>. Throws <code>{undefined, Key}</code> if the key
+%% does not exist in <code>Env</code>.
+
+-spec get(term(), environment()) -> term().
+
+get(Key, Env) ->
+ case lookup(Key, Env) of
+ {ok, Value} -> Value;
+ error -> throw({undefined, Key})
+ end.
+
+
+%% =====================================================================
+%% The key-generating algorithm could possibly be further improved. The
+%% important thing to keep in mind is, that when we need a new key, we
+%% are generally in mid-traversal of a syntax tree, and existing names
+%% in the tree may be closely grouped and evenly distributed or even
+%% forming a compact range (often having been generated by a "gensym",
+%% or by this very algorithm itself). This means that if we generate an
+%% identifier whose value is too close to those already seen (i.e.,
+%% which are in the environment), it is very probable that we will
+%% shadow a not-yet-seen identifier further down in the tree, the result
+%% being that we induce another later renaming, and end up renaming most
+%% of the identifiers, completely contrary to our intention. We need to
+%% generate new identifiers in a way that avoids such systematic
+%% collisions.
+%%
+%% One way of getting a new key to try when the previous attempt failed
+%% is of course to e.g. add one to the last tried value. However, in
+%% general it's a bad idea to try adjacent identifiers: the percentage
+%% of retries will typically increase a lot, so you may lose big on the
+%% extra lookups while gaining only a little from the quicker
+%% computation.
+%%
+%% We want an initial range that is large enough for most typical cases.
+%% If we start with, say, a range of 10, we might quickly use up most of
+%% the values in the range 1-10 (or 1-100) for new top-level variables -
+%% but as we start traversing the syntax tree, it is quite likely that
+%% exactly those variables will be encountered again (this depends on
+%% how the names in the tree were created), and will then need to be
+%% renamed. If we instead begin with a larger range, it is less likely
+%% that any top-level names that we introduce will shadow names that we
+%% will find in the tree. Of course we cannot know how large is large
+%% enough: for any initial range, there is some syntax tree that uses
+%% all the values in that range, and thus any top-level names introduced
+%% will shadow names in the tree. The point is to avoid this happening
+%% all the time - a range of about 1000 seems enough for most programs.
+%%
+%% The following values have been shown to work well:
+
+-define(MINIMUM_RANGE, 1000).
+-define(START_RANGE_FACTOR, 50).
+-define(MAX_RETRIES, 2). % retries before enlarging range
+-define(ENLARGE_FACTOR, 10). % range enlargment factor
+
+-ifdef(DEBUG).
+%% If you want to use these process dictionary counters, make sure to
+%% initialise them to zero before you call any of the key-generating
+%% functions.
+%%
+%% new_key_calls total number of calls
+%% new_key_retries failed key generation attempts
+%% new_key_max maximum generated integer value
+%%
+-define(measure_calls(),
+ put(new_key_calls, 1 + get(new_key_calls))).
+-define(measure_max_key(N),
+ case N > get(new_key_max) of
+ true ->
+ put(new_key_max, N);
+ false ->
+ ok
+ end).
+-define(measure_retries(N),
+ put(new_key_retries, get(new_key_retries) + N)).
+-else.
+-define(measure_calls(), ok).
+-define(measure_max_key(N), ok).
+-define(measure_retries(N), ok).
+-endif.
+
+
+%% =====================================================================
+%% @spec new_key(Env::environment()) -> integer()
+%%
+%% @doc Returns an integer which is not already used as key in the
+%% environment. New integers are generated using an algorithm which
+%% tries to keep the values randomly distributed within a reasonably
+%% small range relative to the number of entries in the environment.
+%%
+%% <p>This function uses the Erlang standard library module
+%% <code>random</code> to generate new keys.</p>
+%%
+%% <p>Note that only the new key is returned; the environment itself is
+%% not updated by this function.</p>
+
+-spec new_key(environment()) -> integer().
+
+new_key(Env) ->
+ new_key(fun (X) -> X end, Env).
+
+
+%% =====================================================================
+%% @spec new_key(Function, Env) -> term()
+%%
+%% Function = (integer()) -> term()
+%% Env = environment()
+%%
+%% @doc Returns a term which is not already used as key in the
+%% environment. The term is generated by applying <code>Function</code>
+%% to an integer generated as in {@link new_key/1}.
+%%
+%% <p>Note that only the generated term is returned; the environment
+%% itself is not updated by this function.</p>
+
+-spec new_key(fun((integer()) -> term()), environment()) -> term().
+
+new_key(F, Env) ->
+ ?measure_calls(),
+ R = start_range(Env),
+ %% io:fwrite("Start range: ~w.\n", [R]),
+ new_key(R, F, Env).
+
+new_key(R, F, Env) ->
+ new_key(generate(R, R), R, 0, F, Env).
+
+new_key(N, R, T, F, Env) when T < ?MAX_RETRIES ->
+ A = F(N),
+ case is_defined(A, Env) of
+ true ->
+ %% io:fwrite("CLASH: ~w.\n", [A]),
+ new_key(generate(N, R), R, T + 1, F, Env);
+ false ->
+ ?measure_max_key(N),
+ ?measure_retries(T),
+ %% io:fwrite("New: ~w.\n", [N]),
+ A
+ end;
+new_key(N, R, _T, F, Env) ->
+ %% Too many retries - enlarge the range and start over.
+ ?measure_retries((_T + 1)),
+ R1 = trunc(R * ?ENLARGE_FACTOR),
+ %% io:fwrite("**NEW RANGE**: ~w.\n", [R1]),
+ new_key(generate(N, R1), R1, 0, F, Env).
+
+start_range(Env) ->
+ max(env_size(Env) * ?START_RANGE_FACTOR, ?MINIMUM_RANGE).
+
+%% The previous key might or might not be used to compute the next key
+%% to be tried. It is currently not used.
+%%
+%% In order to avoid causing cascading renamings, it is important that
+%% this function does not generate values in order, but
+%% (pseudo-)randomly distributed over the range.
+
+generate(_N, Range) ->
+ random:uniform(Range). % works well
+
+
+%% =====================================================================
+%% @spec new_keys(N, Env) -> [integer()]
+%%
+%% N = integer()
+%% Env = environment()
+%%
+%% @doc Returns a list of <code>N</code> distinct integers that are not
+%% already used as keys in the environment. See {@link new_key/1} for
+%% details.
+
+-spec new_keys(integer(), environment()) -> [integer()].
+
+new_keys(N, Env) when is_integer(N) ->
+ new_keys(N, fun (X) -> X end, Env).
+
+
+%% =====================================================================
+%% @spec new_keys(N, Function, Env) -> [term()]
+%%
+%% N = integer()
+%% Function = (integer()) -> term()
+%% Env = environment()
+%%
+%% @doc Returns a list of <code>N</code> distinct terms that are not
+%% already used as keys in the environment. See {@link new_key/3} for
+%% details.
+
+-spec new_keys(integer(), fun((integer()) -> term()), environment()) -> [term()].
+
+new_keys(N, F, Env) when is_integer(N) ->
+ R = start_range(Env),
+ new_keys(N, [], R, F, Env).
+
+new_keys(N, Ks, R, F, Env) when N > 0 ->
+ Key = new_key(R, F, Env),
+ Env1 = bind(Key, true, Env), % dummy binding
+ new_keys(N - 1, [Key | Ks], R, F, Env1);
+new_keys(0, Ks, _, _, _) ->
+ Ks.
diff --git a/lib/compiler/src/sys_core_dsetel.erl b/lib/compiler/src/sys_core_dsetel.erl
new file mode 100644
index 0000000000..c38eab7b42
--- /dev/null
+++ b/lib/compiler/src/sys_core_dsetel.erl
@@ -0,0 +1,346 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2002-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%
+%%
+%% Purpose : Using dsetelement to make multiple-field record updates
+%% faster.
+
+%% The expansion of record field updates, when more than one field is
+%% updated, but not a majority of the fields, will create a sequence of
+%% calls to 'erlang:setelement(Index, Value, Tuple)' where Tuple in the
+%% first call is the original record tuple, and in the subsequent calls
+%% Tuple is the result of the previous call. Furthermore, all Index
+%% values are constant positive integers, and the first call to
+%% 'setelement' will have the greatest index. Thus all the following
+%% calls do not actually need to test at run-time whether Tuple has type
+%% tuple, nor that the index is within the tuple bounds.
+%%
+%% Since this introduces destructive updates in the Core Erlang code, it
+%% must be done as a last stage before going to lower-level code.
+%%
+%% NOTE: Because there are currently no write barriers in the system,
+%% this kind of optimization can only be done when we are sure that
+%% garbage collection will not be triggered between the creation of the
+%% tuple and the destructive updates - otherwise we might insert
+%% pointers from an older generation to a newer.
+%%
+%% The rewriting is done as follows:
+%%
+%% let X1 = call 'erlang':'setelement(5, Tuple, Value1)
+%% in call 'erlang':'setelement(3, X1, Value2)
+%% =>
+%% let X1 = call 'erlang':'setelement(5, Tuple, Value1)
+%% in do primop dsetelement(3, X1, Value2)
+%% X1
+%% and
+%% let X1 = call 'erlang':'setelement(5, Tuple, Value1)
+%% in let X2 = call 'erlang':'setelement(3, X1, Value2)
+%% in ...
+%% =>
+%% let X2 = call 'erlang':'setelement(5, Tuple, Value1)
+%% in do primop 'dsetelement(3, X2, Value2)
+%% ...
+%% if X1 is used exactly once.
+%% Thus, we need to track variable usage.
+%%
+%% NOTE: This pass must NOT be used if the no_constant_pool option is used.
+%%
+
+-module(sys_core_dsetel).
+
+-export([module/2]).
+
+-include("core_parse.hrl").
+
+-spec module(cerl:c_module(), [compile:option()]) -> {'ok', cerl:c_module()}.
+
+module(M0, _Options) ->
+ M = visit_module(M0),
+ {ok,M}.
+
+visit_module(#c_module{defs=Ds0}=R) ->
+ Env = dict:new(),
+ Ds = visit_module_1(Ds0, Env, []),
+ R#c_module{defs=Ds}.
+
+visit_module_1([{Name,F0}|Fs], Env, Acc) ->
+ try visit(Env, F0) of
+ {F,_} ->
+ visit_module_1(Fs, Env, [{Name,F}|Acc])
+ catch
+ Class:Error ->
+ Stack = erlang:get_stacktrace(),
+ #c_var{name={Func,Arity}} = Name,
+ io:fwrite("Function: ~w/~w\n", [Func,Arity]),
+ erlang:raise(Class, Error, Stack)
+ end;
+visit_module_1([], _, Acc) ->
+ lists:reverse(Acc).
+
+visit(Env, #c_var{name={_,_}}=R) ->
+ %% Ignore local function name.
+ {R, Env};
+visit(Env0, #c_var{name=X}=R) ->
+ %% There should not be any free variables. If there are,
+ %% the next line will cause an exception.
+ {ok, N} = dict:find(X, Env0),
+ {R, dict:store(X, N+1, Env0)};
+visit(Env, #c_literal{}=R) ->
+ {R, Env};
+visit(Env0, #c_tuple{es=Es0}=R) ->
+ {Es1,Env1} = visit_list(Env0, Es0),
+ {R#c_tuple{es=Es1}, Env1};
+visit(Env0, #c_cons{hd=H0,tl=T0}=R) ->
+ {H1,Env1} = visit(Env0, H0),
+ {T1,Env2} = visit(Env1, T0),
+ {R#c_cons{hd=H1,tl=T1}, Env2};
+visit(Env0, #c_binary{segments=Segs}=R) ->
+ Env = visit_bin_segs(Env0, Segs),
+ {R, Env};
+visit(Env0, #c_values{es=Es0}=R) ->
+ {Es1,Env1} = visit_list(Env0, Es0),
+ {R#c_values{es=Es1}, Env1};
+visit(Env0, #c_fun{vars=Vs, body=B0}=R) ->
+ {Xs, Env1} = bind_vars(Vs, Env0),
+ {B1,Env2} = visit(Env1, B0),
+ {R#c_fun{body=B1}, restore_vars(Xs, Env0, Env2)};
+visit(Env0, #c_let{vars=Vs, arg=A0, body=B0}=R) ->
+ {A1,Env1} = visit(Env0, A0),
+ {Xs,Env2} = bind_vars(Vs, Env1),
+ {B1,Env3} = visit(Env2, B0),
+ rewrite(R#c_let{arg=A1,body=B1}, Env3, restore_vars(Xs, Env1, Env3));
+visit(Env0, #c_seq{arg=A0, body=B0}=R) ->
+ {A1,Env1} = visit(Env0, A0),
+ {B1,Env2} = visit(Env1, B0),
+ {R#c_seq{arg=A1,body=B1}, Env2};
+visit(Env0, #c_case{arg=A0,clauses=Cs0}=R) ->
+ {A1,Env1} = visit(Env0, A0),
+ {Cs1,Env2} = visit_list(Env1, Cs0),
+ {R#c_case{arg=A1,clauses=Cs1}, Env2};
+visit(Env0, #c_clause{pats=Ps,guard=G0,body=B0}=R) ->
+ {Vs, Env1} = visit_pats(Ps, Env0),
+ {G1,Env2} = visit(Env1, G0),
+ {B1,Env3} = visit(Env2, B0),
+ {R#c_clause{guard=G1,body=B1}, restore_vars(Vs, Env0, Env3)};
+visit(Env0, #c_receive{clauses=Cs0,timeout=T0,action=A0}=R) ->
+ {T1,Env1} = visit(Env0, T0),
+ {Cs1,Env2} = visit_list(Env1, Cs0),
+ {A1,Env3} = visit(Env2, A0),
+ {R#c_receive{clauses=Cs1,timeout=T1,action=A1}, Env3};
+visit(Env0, #c_apply{op=Op0, args=As0}=R) ->
+ {Op1,Env1} = visit(Env0, Op0),
+ {As1,Env2} = visit_list(Env1, As0),
+ {R#c_apply{op=Op1,args=As1}, Env2};
+visit(Env0, #c_call{module=M0,name=N0,args=As0}=R) ->
+ {M1,Env1} = visit(Env0, M0),
+ {N1,Env2} = visit(Env1, N0),
+ {As1,Env3} = visit_list(Env2, As0),
+ {R#c_call{module=M1,name=N1,args=As1}, Env3};
+visit(Env0, #c_primop{name=N0, args=As0}=R) ->
+ {N1,Env1} = visit(Env0, N0),
+ {As1,Env2} = visit_list(Env1, As0),
+ {R#c_primop{name=N1,args=As1}, Env2};
+visit(Env0, #c_try{arg=E0, vars=Vs, body=B0, evars=Evs, handler=H0}=R) ->
+ {E1,Env1} = visit(Env0, E0),
+ {Xs, Env2} = bind_vars(Vs, Env1),
+ {B1,Env3} = visit(Env2, B0),
+ Env4 = restore_vars(Xs, Env1, Env3),
+ {Ys, Env5} = bind_vars(Evs, Env4),
+ {H1,Env6} = visit(Env5, H0),
+ {R#c_try{arg=E1,body=B1,handler=H1}, restore_vars(Ys, Env4, Env6)};
+visit(Env0, #c_catch{body=B0}=R) ->
+ {B1,Env1} = visit(Env0, B0),
+ {R#c_catch{body=B1}, Env1};
+visit(Env0, #c_letrec{defs=Ds0,body=B0}=R) ->
+ {Xs, Env1} = bind_vars([V || {V,_} <- Ds0], Env0),
+ {Ds1,Env2} = visit_def_list(Env1, Ds0),
+ {B1,Env3} = visit(Env2, B0),
+ {R#c_letrec{defs=Ds1,body=B1}, restore_vars(Xs, Env0, Env3)}.
+%% The following general code for handling modules is slow if a module
+%% contains very many functions. There is special code in visit_module/1
+%% which is much faster.
+%% visit(Env0, #c_module{defs=D0}=R) ->
+%% {R1,Env1} = visit(Env0, #c_letrec{defs=D0,body=#c_nil{}}),
+%% {R#c_module{defs=R1#c_letrec.defs}, Env1};
+
+visit_list(Env, L) ->
+ lists:mapfoldl(fun (E, A) -> visit(A, E) end, Env, L).
+
+visit_def_list(Env, L) ->
+ lists:mapfoldl(fun ({Name,V0}, E0) ->
+ {V1,E1} = visit(E0, V0),
+ {{Name,V1}, E1}
+ end, Env, L).
+
+visit_bin_segs(Env, Segs) ->
+ lists:foldl(fun (#c_bitstr{val=Val,size=Sz}, E0) ->
+ {_, E1} = visit(E0, Val),
+ {_, E2} = visit(E1, Sz),
+ E2
+ end, Env, Segs).
+
+bind_vars(Vs, Env) ->
+ bind_vars(Vs, Env, []).
+
+bind_vars([#c_var{name=X}|Vs], Env0, Xs)->
+ bind_vars(Vs, dict:store(X, 0, Env0), [X|Xs]);
+bind_vars([], Env,Xs) ->
+ {Xs, Env}.
+
+visit_pats(Ps, Env) ->
+ visit_pats(Ps, Env, []).
+
+visit_pats([P|Ps], Env0, Vs0) ->
+ {Vs1, Env1} = visit_pat(Env0, P, Vs0),
+ visit_pats(Ps, Env1, Vs1);
+visit_pats([], Env, Vs) ->
+ {Vs, Env}.
+
+visit_pat(Env0, #c_var{name=V}, Vs) ->
+ {[V|Vs], dict:store(V, 0, Env0)};
+visit_pat(Env0, #c_tuple{es=Es}, Vs) ->
+ visit_pats(Es, Env0, Vs);
+visit_pat(Env0, #c_cons{hd=H,tl=T}, Vs0) ->
+ {Vs1, Env1} = visit_pat(Env0, H, Vs0),
+ visit_pat(Env1, T, Vs1);
+visit_pat(Env0, #c_binary{segments=Segs}, Vs) ->
+ visit_pats(Segs, Env0, Vs);
+visit_pat(Env0, #c_bitstr{val=Val,size=Sz}, Vs0) ->
+ {Vs1, Env1} =
+ case Sz of
+ #c_var{name=V} ->
+ %% We don't tolerate free variables.
+ {ok, N} = dict:find(V, Env0),
+ {Vs0, dict:store(V, N+1, Env0)};
+ _ ->
+ visit_pat(Env0, Sz, Vs0)
+ end,
+ visit_pat(Env1, Val, Vs1);
+visit_pat(Env0, #c_alias{pat=P,var=#c_var{name=V}}, Vs) ->
+ visit_pat(dict:store(V, 0, Env0), P, [V|Vs]);
+visit_pat(Env, #c_literal{}, Vs) ->
+ {Vs, Env}.
+
+restore_vars([V|Vs], Env0, Env1) ->
+ case dict:find(V, Env0) of
+ {ok, N} ->
+ restore_vars(Vs, Env0, dict:store(V, N, Env1));
+ error ->
+ restore_vars(Vs, Env0, dict:erase(V, Env1))
+ end;
+restore_vars([], _, Env1) ->
+ Env1.
+
+
+%% let X1 = call 'erlang':'setelement(5, Tuple, Value1)
+%% in call 'erlang':'setelement(3, X1, Value2)
+%% =>
+%% let X1 = call 'erlang':'setelement(5, Tuple, Value1)
+%% in do primop dsetelement(3, X1, Value2)
+%% X1
+
+rewrite(#c_let{vars=[#c_var{name=X}=V]=Vs,
+ arg=#c_call{module=#c_literal{val='erlang'},
+ name=#c_literal{val='setelement'},
+ args=[#c_literal{val=Index1}, _Tuple, _Val1]
+ }=A,
+ body=#c_call{anno=Banno,module=#c_literal{val='erlang'},
+ name=#c_literal{val='setelement'},
+ args=[#c_literal{val=Index2},
+ #c_var{name=X},
+ Val2]
+ }
+ }=R,
+ _BodyEnv, FinalEnv)
+ when is_integer(Index1), is_integer(Index2), Index2 > 0, Index1 > Index2 ->
+ case is_safe(Val2) of
+ true ->
+ {R#c_let{vars=Vs,
+ arg=A,
+ body=#c_seq{arg=#c_primop{
+ anno=Banno,
+ name=#c_literal{val='dsetelement'},
+ args=[#c_literal{val=Index2},
+ V,
+ Val2]},
+ body=V}
+ },
+ FinalEnv};
+ false ->
+ {R, FinalEnv}
+ end;
+
+%% let X1 = call 'erlang':'setelement(5, Tuple, Value1)
+%% in let X2 = 'erlang':'setelement(3, X1, Value2)
+%% in ...
+%% =>
+%% let X2 = call 'erlang':'setelement(5, Tuple, Value1)
+%% in do primop dsetelement(3, X2, Value2)
+%% ...
+%% if X1 is used exactly once.
+
+rewrite(#c_let{vars=[#c_var{name=X1}],
+ arg=#c_call{module=#c_literal{val='erlang'},
+ name=#c_literal{val='setelement'},
+ args=[#c_literal{val=Index1}, _Tuple, _Val1]
+ }=A,
+ body=#c_let{vars=[#c_var{}=V]=Vs,
+ arg=#c_call{anno=Banno,
+ module=#c_literal{val='erlang'},
+ name=#c_literal{val='setelement'},
+ args=[#c_literal{val=Index2},
+ #c_var{name=X1},
+ Val2]},
+ body=B}
+ }=R,
+ BodyEnv, FinalEnv)
+ when is_integer(Index1), is_integer(Index2), Index2 > 0, Index1 > Index2 ->
+ case is_single_use(X1, BodyEnv) andalso is_safe(Val2) of
+ true ->
+ {R#c_let{vars=Vs,
+ arg=A,
+ body=#c_seq{arg=#c_primop{
+ anno=Banno,
+ name=#c_literal{val='dsetelement'},
+ args=[#c_literal{val=Index2},
+ V,
+ Val2]},
+ body=B}
+ },
+ FinalEnv};
+ false ->
+ {R, FinalEnv}
+ end;
+
+rewrite(R, _, FinalEnv) ->
+ {R, FinalEnv}.
+
+%% is_safe(CoreExpr) -> true|false
+%% Determines whether the Core expression can cause a GC collection at run-time.
+%% Note: Assumes that the constant pool is turned on.
+
+is_safe(#c_var{}) -> true;
+is_safe(#c_literal{}) -> true;
+is_safe(_) -> false.
+
+is_single_use(V, Env) ->
+ case dict:find(V, Env) of
+ {ok, 1} ->
+ true;
+ _ ->
+ false
+ end.
diff --git a/lib/compiler/src/sys_core_fold.erl b/lib/compiler/src/sys_core_fold.erl
new file mode 100644
index 0000000000..068478496b
--- /dev/null
+++ b/lib/compiler/src/sys_core_fold.erl
@@ -0,0 +1,2851 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1999-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%
+%%
+%% Purpose : Constant folding optimisation for Core
+
+%% Propagate atomic values and fold in values of safe calls to
+%% constant arguments. Also detect and remove literals which are
+%% ignored in a 'seq'. Could handle lets better by chasing down
+%% complex 'arg' expressions and finding values.
+%%
+%% Try to optimise case expressions by removing unmatchable or
+%% unreachable clauses. Also change explicit tuple arg into multiple
+%% values and extend clause patterns. We must be careful here not to
+%% generate cases which we know to be safe but later stages will not
+%% recognise as such, e.g. the following is NOT acceptable:
+%%
+%% case 'b' of
+%% <'b'> -> ...
+%% end
+%%
+%% Variable folding is complicated by variable shadowing, for example
+%% in:
+%% 'foo'/1 =
+%% fun (X) ->
+%% let <A> = X
+%% in let <X> = Y
+%% in ... <use A>
+%% If we were to simply substitute X for A then we would be using the
+%% wrong X. Our solution is to rename variables that are the values
+%% of substitutions. We could rename all shadowing variables but do
+%% the minimum. We would then get:
+%% 'foo'/1 =
+%% fun (X) ->
+%% let <A> = X
+%% in let <X1> = Y
+%% in ... <use A>
+%% which is optimised to:
+%% 'foo'/1 =
+%% fun (X) ->
+%% let <X1> = Y
+%% in ... <use X>
+%%
+%% This is done by carefully shadowing variables and substituting
+%% values. See details when defining functions.
+%%
+%% It would be possible to extend to replace repeated evaluation of
+%% "simple" expressions by the value (variable) of the first call.
+%% For example, after a "let Z = X+1" then X+1 would be replaced by Z
+%% where X is valid. The Sub uses the full Core expression as key.
+%% It would complicate handling of patterns as we would have to remove
+%% all values where the key contains pattern variables.
+
+-module(sys_core_fold).
+
+-export([module/2,format_error/1]).
+
+-import(lists, [map/2,foldl/3,foldr/3,mapfoldl/3,all/2,any/2,
+ reverse/1,reverse/2,member/2,nth/2,flatten/1]).
+
+-import(cerl, [ann_c_cons/3,ann_c_tuple/2]).
+
+-include("core_parse.hrl").
+
+%%-define(DEBUG, 1).
+
+-ifdef(DEBUG).
+-define(ASSERT(E),
+ case E of
+ true -> ok;
+ false ->
+ io:format("~p, line ~p: assertion failed\n", [?MODULE,?LINE]),
+ exit(assertion_failed)
+ end).
+-else.
+-define(ASSERT(E), ignore).
+-endif.
+
+%% Variable value info.
+-record(sub, {v=[], %Variable substitutions
+ s=[], %Variables in scope
+ t=[], %Types
+ in_guard=false}). %In guard or not.
+
+-spec module(cerl:c_module(), [compile:option()]) ->
+ {'ok', cerl:c_module(), [_]}.
+
+module(#c_module{defs=Ds0}=Mod, Opts) ->
+ put(bin_opt_info, member(bin_opt_info, Opts)),
+ put(no_inline_list_funcs, not member(inline_list_funcs, Opts)),
+ case get(new_var_num) of
+ undefined -> put(new_var_num, 0);
+ _ -> ok
+ end,
+ init_warnings(),
+ Ds1 = [function_1(D) || D <- Ds0],
+ erase(no_inline_list_funcs),
+ erase(bin_opt_info),
+ {ok,Mod#c_module{defs=Ds1},get_warnings()}.
+
+function_1({#c_var{name={F,Arity}}=Name,B0}) ->
+ try
+ B = expr(B0, value, sub_new()), %This must be a fun!
+ {Name,B}
+ catch
+ Class:Error ->
+ Stack = erlang:get_stacktrace(),
+ io:fwrite("Function: ~w/~w\n", [F,Arity]),
+ erlang:raise(Class, Error, Stack)
+ end.
+
+%% body(Expr, Sub) -> Expr.
+%% body(Expr, Context, Sub) -> Expr.
+%% No special handling of anything except values.
+
+body(Body, Sub) ->
+ body(Body, value, Sub).
+
+body(#c_values{anno=A,es=Es0}, Ctxt, Sub) ->
+ Es1 = expr_list(Es0, Ctxt, Sub),
+ #c_values{anno=A,es=Es1};
+body(E, Ctxt, Sub) ->
+ ?ASSERT(verify_scope(E, Sub)),
+ expr(E, Ctxt, Sub).
+
+%% guard(Expr, Sub) -> Expr.
+%% Do guard expression. We optimize it in the same way as
+%% expressions in function bodies.
+
+guard(Expr, Sub) ->
+ ?ASSERT(verify_scope(Expr, Sub)),
+ expr(Expr, value, Sub#sub{in_guard=true}).
+
+%% opt_guard_try(Expr) -> Expr.
+%%
+opt_guard_try(#c_seq{arg=Arg,body=Body0}=Seq) ->
+ Body = opt_guard_try(Body0),
+ case {Arg,Body} of
+ {#c_call{},#c_literal{val=false}} ->
+ %% We have sequence consisting of a call (evaluted
+ %% for a possible exception only), followed by 'false'.
+ %% Since the sequence is inside a try block that will
+ %% default to 'false' if any exception occurs, not
+ %% evalutating the call will not change the behaviour
+ %% of the guard.
+ Body;
+ {_,_} ->
+ Seq#c_seq{body=Body}
+ end;
+opt_guard_try(#c_case{clauses=Cs}=Term) ->
+ Term#c_case{clauses=opt_guard_try_list(Cs)};
+opt_guard_try(#c_clause{body=B0}=Term) ->
+ Term#c_clause{body=opt_guard_try(B0)};
+opt_guard_try(#c_let{arg=Arg,body=B0}=Term) ->
+ case opt_guard_try(B0) of
+ #c_literal{}=B ->
+ opt_guard_try(#c_seq{arg=Arg,body=B});
+ B ->
+ Term#c_let{body=B}
+ end;
+opt_guard_try(Term) -> Term.
+
+opt_guard_try_list([C|Cs]) ->
+ [opt_guard_try(C)|opt_guard_try_list(Cs)];
+opt_guard_try_list([]) -> [].
+
+%% expr(Expr, Sub) -> Expr.
+%% expr(Expr, Context, Sub) -> Expr.
+
+expr(Expr, Sub) ->
+ expr(Expr, value, Sub).
+
+expr(#c_var{}=V, Ctxt, Sub) ->
+ %% Return void() in effect context to potentially shorten the life time
+ %% of the variable and potentially generate better code
+ %% (for instance, if the variable no longer needs to survive a function
+ %% call, there will be no need to save it in the stack frame).
+ case Ctxt of
+ effect -> void();
+ value -> sub_get_var(V, Sub)
+ end;
+expr(#c_literal{val=Val}=L, Ctxt, _Sub) ->
+ case Ctxt of
+ effect ->
+ case Val of
+ [] ->
+ %% Keep as [] - might give slightly better code.
+ L;
+ _ when is_atom(Val) ->
+ %% For cleanliness replace with void().
+ void();
+ _ ->
+ %% Warn and replace with void().
+ add_warning(L, useless_building),
+ void()
+ end;
+ value -> L
+ end;
+expr(#c_cons{anno=Anno,hd=H0,tl=T0}=Cons, Ctxt, Sub) ->
+ H1 = expr(H0, Ctxt, Sub),
+ T1 = expr(T0, Ctxt, Sub),
+ case Ctxt of
+ effect ->
+ add_warning(Cons, useless_building),
+ expr(make_effect_seq([H1,T1], Sub), Ctxt, Sub);
+ value ->
+ ann_c_cons(Anno, H1, T1)
+ end;
+expr(#c_tuple{anno=Anno,es=Es0}=Tuple, Ctxt, Sub) ->
+ Es = expr_list(Es0, Ctxt, Sub),
+ case Ctxt of
+ effect ->
+ add_warning(Tuple, useless_building),
+ expr(make_effect_seq(Es, Sub), Ctxt, Sub);
+ value ->
+ ann_c_tuple(Anno, Es)
+ end;
+expr(#c_binary{segments=Ss}=Bin0, Ctxt, Sub) ->
+ %% Warn for useless building, but always build the binary
+ %% anyway to preserve a possible exception.
+ case Ctxt of
+ effect -> add_warning(Bin0, useless_building);
+ value -> ok
+ end,
+ Bin1 = Bin0#c_binary{segments=bitstr_list(Ss, Sub)},
+ Bin = bin_un_utf(Bin1),
+ eval_binary(Bin);
+expr(#c_fun{}=Fun, effect, _) ->
+ %% A fun is created, but not used. Warn, and replace with the void value.
+ add_warning(Fun, useless_building),
+ void();
+expr(#c_fun{vars=Vs0,body=B0}=Fun, Ctxt0, Sub0) ->
+ {Vs1,Sub1} = pattern_list(Vs0, Sub0),
+ Ctxt = case Ctxt0 of
+ {letrec,Ctxt1} -> Ctxt1;
+ value -> value
+ end,
+ B1 = body(B0, Ctxt, Sub1),
+ Fun#c_fun{vars=Vs1,body=B1};
+expr(#c_seq{arg=Arg0,body=B0}=Seq0, Ctxt, Sub) ->
+ %% Optimise away pure literal arg as its value is ignored.
+ B1 = body(B0, Ctxt, Sub),
+ Arg = body(Arg0, effect, Sub),
+ case will_fail(Arg) of
+ true ->
+ Arg;
+ false ->
+ %% Arg cannot be "values" here - only a single value
+ %% make sense here.
+ case is_safe_simple(Arg, Sub) of
+ true -> B1;
+ false -> Seq0#c_seq{arg=Arg,body=B1}
+ end
+ end;
+expr(#c_let{}=Let, Ctxt, Sub) ->
+ case simplify_let(Let, Sub) of
+ impossible ->
+ %% The argument for the let is "simple", i.e. has no
+ %% complex structures such as let or seq that can be entered.
+ ?ASSERT(verify_scope(Let, Sub)),
+ opt_simple_let(Let, Ctxt, Sub);
+ Expr ->
+ %% The let body was successfully moved into the let argument.
+ %% Now recursively re-process the new expression.
+ expr(Expr, Ctxt, sub_new_preserve_types(Sub))
+ end;
+expr(#c_letrec{defs=Fs0,body=B0}=Letrec, Ctxt, Sub) ->
+ Fs1 = map(fun ({Name,Fb}) ->
+ {Name,expr(Fb, {letrec,Ctxt}, Sub)}
+ end, Fs0),
+ B1 = body(B0, value, Sub),
+ Letrec#c_letrec{defs=Fs1,body=B1};
+expr(#c_case{}=Case0, Ctxt, Sub) ->
+ case opt_bool_case(Case0) of
+ #c_case{arg=Arg0,clauses=Cs0}=Case1 ->
+ Arg1 = body(Arg0, value, Sub),
+ {Arg2,Cs1} = case_opt(Arg1, Cs0),
+ Cs2 = clauses(Arg2, Cs1, Case1, Ctxt, Sub),
+ Case = eval_case(Case1#c_case{arg=Arg2,clauses=Cs2}, Sub),
+ bsm_an(Case);
+ Other ->
+ expr(Other, Ctxt, Sub)
+ end;
+expr(#c_receive{clauses=Cs0,timeout=T0,action=A0}=Recv, Ctxt, Sub) ->
+ Cs1 = clauses(#c_var{name='_'}, Cs0, Recv, Ctxt, Sub), %This is all we know
+ T1 = expr(T0, value, Sub),
+ A1 = body(A0, Ctxt, Sub),
+ Recv#c_receive{clauses=Cs1,timeout=T1,action=A1};
+expr(#c_apply{op=Op0,args=As0}=App, _, Sub) ->
+ Op1 = expr(Op0, value, Sub),
+ As1 = expr_list(As0, value, Sub),
+ App#c_apply{op=Op1,args=As1};
+expr(#c_call{module=M0,name=N0}=Call0, Ctxt, Sub) ->
+ M1 = expr(M0, value, Sub),
+ N1 = expr(N0, value, Sub),
+ Call = Call0#c_call{module=M1,name=N1},
+ case useless_call(Ctxt, Call) of
+ no -> call(Call, M1, N1, Sub);
+ {yes,Seq} -> expr(Seq, Ctxt, Sub)
+ end;
+expr(#c_primop{args=As0}=Prim, _, Sub) ->
+ As1 = expr_list(As0, value, Sub),
+ Prim#c_primop{args=As1};
+expr(#c_catch{body=B0}=Catch, _, Sub) ->
+ %% We can remove catch if the value is simple
+ B1 = body(B0, value, Sub),
+ case is_safe_simple(B1, Sub) of
+ true -> B1;
+ false -> Catch#c_catch{body=B1}
+ end;
+expr(#c_try{arg=E0,vars=[#c_var{name=X}],body=#c_var{name=X},
+ handler=#c_literal{val=false}=False}=Try, _, Sub) ->
+ %% Since guard may call expr/2, we must do some optimization of
+ %% the kind of try's that occur in guards.
+ E1 = body(E0, value, Sub),
+ case will_fail(E1) of
+ false ->
+ %% Remove any calls that are evaluated for effect only.
+ E2 = opt_guard_try(E1),
+
+ %% We can remove try/catch if the expression is an
+ %% expression that cannot fail.
+ case is_safe_bool_expr(E2, Sub) orelse is_safe_simple(E2, Sub) of
+ true -> E2;
+ false -> Try#c_try{arg=E2}
+ end;
+ true ->
+ %% Expression will always fail.
+ False
+ end;
+expr(#c_try{anno=A,arg=E0,vars=Vs0,body=B0,evars=Evs0,handler=H0}=Try, _, Sub0) ->
+ %% Here is the general try/catch construct outside of guards.
+ %% We can remove try if the value is simple and replace it with a let.
+ E1 = body(E0, value, Sub0),
+ {Vs1,Sub1} = pattern_list(Vs0, Sub0),
+ B1 = body(B0, value, Sub1),
+ case is_safe_simple(E1, Sub0) of
+ true ->
+ expr(#c_let{anno=A,vars=Vs1,arg=E1,body=B1}, value, Sub0);
+ false ->
+ {Evs1,Sub2} = pattern_list(Evs0, Sub0),
+ H1 = body(H0, value, Sub2),
+ Try#c_try{arg=E1,vars=Vs1,body=B1,evars=Evs1,handler=H1}
+ end.
+
+expr_list(Es, Ctxt, Sub) ->
+ [expr(E, Ctxt, Sub) || E <- Es].
+
+bitstr_list(Es, Sub) ->
+ [bitstr(E, Sub) || E <- Es].
+
+bitstr(#c_bitstr{val=Val,size=Size}=BinSeg, Sub) ->
+ BinSeg#c_bitstr{val=expr(Val, Sub),size=expr(Size, value, Sub)}.
+
+%% is_safe_simple(Expr, Sub) -> true | false.
+%% A safe simple cannot fail with badarg and is safe to use
+%% in a guard.
+%%
+%% Currently, we don't attempt to check binaries because they
+%% are difficult to check.
+
+is_safe_simple(#c_var{}, _) -> true;
+is_safe_simple(#c_cons{hd=H,tl=T}, Sub) ->
+ is_safe_simple(H, Sub) andalso is_safe_simple(T, Sub);
+is_safe_simple(#c_tuple{es=Es}, Sub) -> is_safe_simple_list(Es, Sub);
+is_safe_simple(#c_literal{}, _) -> true;
+is_safe_simple(#c_call{module=#c_literal{val=erlang},
+ name=#c_literal{val=Name},
+ args=Args}, Sub) when is_atom(Name) ->
+ NumArgs = length(Args),
+ case erl_internal:bool_op(Name, NumArgs) of
+ true ->
+ %% Boolean operators are safe if the arguments are boolean.
+ all(fun(#c_var{name=V}) -> is_boolean_type(V, Sub);
+ (#c_literal{val=Lit}) -> is_boolean(Lit);
+ (_) -> false
+ end, Args);
+ false ->
+ %% We need a rather complicated test to ensure that
+ %% we only allow safe calls that are allowed in a guard.
+ %% (Note that is_function/2 is a type test, but is not safe.)
+ erl_bifs:is_safe(erlang, Name, NumArgs) andalso
+ (erl_internal:comp_op(Name, NumArgs) orelse
+ erl_internal:new_type_test(Name, NumArgs))
+ end;
+is_safe_simple(_, _) -> false.
+
+is_safe_simple_list(Es, Sub) -> all(fun(E) -> is_safe_simple(E, Sub) end, Es).
+
+%% will_fail(Expr) -> true|false.
+%% Determine whether the expression will fail with an exception.
+%% Return true if the expression always will fail with an exception,
+%% i.e. never return normally.
+
+will_fail(#c_let{arg=A,body=B}) ->
+ will_fail(A) orelse will_fail(B);
+will_fail(#c_call{module=#c_literal{val=Mod},name=#c_literal{val=Name},args=Args}) ->
+ erl_bifs:is_exit_bif(Mod, Name, length(Args));
+will_fail(#c_primop{name=#c_literal{val=match_fail},args=[_]}) -> true;
+will_fail(_) -> false.
+
+%% bin_un_utf(#c_binary{}) -> #c_binary{}
+%% Convert any literal UTF-8/16/32 literals to byte-sized
+%% integer fields.
+
+bin_un_utf(#c_binary{anno=Anno,segments=Ss}=Bin) ->
+ Bin#c_binary{segments=bin_un_utf_1(Ss, Anno)}.
+
+bin_un_utf_1([#c_bitstr{val=#c_literal{},type=#c_literal{val=utf8}}=H|T],
+ Anno) ->
+ bin_un_utf_eval(H, Anno) ++ bin_un_utf_1(T, Anno);
+bin_un_utf_1([#c_bitstr{val=#c_literal{},type=#c_literal{val=utf16}}=H|T],
+ Anno) ->
+ bin_un_utf_eval(H, Anno) ++ bin_un_utf_1(T, Anno);
+bin_un_utf_1([#c_bitstr{val=#c_literal{},type=#c_literal{val=utf32}}=H|T],
+ Anno) ->
+ bin_un_utf_eval(H, Anno) ++ bin_un_utf_1(T, Anno);
+bin_un_utf_1([H|T], Anno) ->
+ [H|bin_un_utf_1(T, Anno)];
+bin_un_utf_1([], _) -> [].
+
+bin_un_utf_eval(Bitstr, Anno) ->
+ Segments = [Bitstr],
+ case eval_binary(#c_binary{anno=Anno,segments=Segments}) of
+ #c_literal{anno=Anno,val=Bytes} when is_binary(Bytes) ->
+ [#c_bitstr{anno=Anno,
+ val=#c_literal{anno=Anno,val=B},
+ size=#c_literal{anno=Anno,val=8},
+ unit=#c_literal{anno=Anno,val=1},
+ type=#c_literal{anno=Anno,val=integer},
+ flags=#c_literal{anno=Anno,val=[unsigned,big]}} ||
+ B <- binary_to_list(Bytes)];
+ _ ->
+ Segments
+ end.
+
+%% eval_binary(#c_binary{}) -> #c_binary{} | #c_literal{}
+%% Evaluate a binary at compile time if possible to create
+%% a binary literal.
+
+eval_binary(#c_binary{anno=Anno,segments=Ss}=Bin) ->
+ try
+ #c_literal{anno=Anno,val=eval_binary_1(Ss, <<>>)}
+ catch
+ throw:impossible ->
+ Bin;
+ throw:{badarg,Warning} ->
+ add_warning(Bin, Warning),
+ #c_call{module=#c_literal{val=erlang},
+ name=#c_literal{val=error},
+ args=[#c_literal{val=badarg}]}
+ end.
+
+eval_binary_1([#c_bitstr{val=#c_literal{val=Val},size=#c_literal{val=Sz},
+ unit=#c_literal{val=Unit},type=#c_literal{val=Type},
+ flags=#c_literal{val=Flags}}|Ss], Acc0) ->
+ Endian = case member(big, Flags) of
+ true ->
+ big;
+ false ->
+ case member(little, Flags) of
+ true -> little;
+ false -> throw(impossible) %Native endian.
+ end
+ end,
+
+ %% Make sure that the size is reasonable.
+ case Type of
+ binary when is_bitstring(Val) ->
+ if
+ Sz =:= all ->
+ ok;
+ Sz*Unit =< bit_size(Val) ->
+ ok;
+ true ->
+ %% Field size is greater than the actual binary - will fail.
+ throw({badarg,embedded_binary_size})
+ end;
+ integer when is_integer(Val) ->
+ %% Estimate the number of bits needed to to hold the integer
+ %% literal. Check whether the field size is reasonable in
+ %% proportion to the number of bits needed.
+ if
+ Sz*Unit =< 256 ->
+ %% Don't be cheap - always accept fields up to this size.
+ ok;
+ true ->
+ case count_bits(Val) of
+ BitsNeeded when 2*BitsNeeded >= Sz*Unit ->
+ ok;
+ _ ->
+ %% More than about half of the field size will be
+ %% filled out with zeroes - not acceptable.
+ throw(impossible)
+ end
+ end;
+ float when is_float(Val) ->
+ %% Bad float size.
+ case Sz*Unit of
+ 32 -> ok;
+ 64 -> ok;
+ _ -> throw(impossible)
+ end;
+ utf8 -> ok;
+ utf16 -> ok;
+ utf32 -> ok;
+ _ ->
+ throw(impossible)
+ end,
+
+ %% Evaluate the field.
+ try eval_binary_2(Acc0, Val, Sz, Unit, Type, Endian) of
+ Acc -> eval_binary_1(Ss, Acc)
+ catch
+ error:_ ->
+ throw(impossible)
+ end;
+eval_binary_1([], Acc) -> Acc;
+eval_binary_1(_, _) -> throw(impossible).
+
+eval_binary_2(Acc, Val, Size, Unit, integer, little) ->
+ <<Acc/bitstring,Val:(Size*Unit)/little>>;
+eval_binary_2(Acc, Val, Size, Unit, integer, big) ->
+ <<Acc/bitstring,Val:(Size*Unit)/big>>;
+eval_binary_2(Acc, Val, _Size, _Unit, utf8, _) ->
+ try
+ <<Acc/bitstring,Val/utf8>>
+ catch
+ error:_ ->
+ throw({badarg,bad_unicode})
+ end;
+eval_binary_2(Acc, Val, _Size, _Unit, utf16, big) ->
+ try
+ <<Acc/bitstring,Val/big-utf16>>
+ catch
+ error:_ ->
+ throw({badarg,bad_unicode})
+ end;
+eval_binary_2(Acc, Val, _Size, _Unit, utf16, little) ->
+ try
+ <<Acc/bitstring,Val/little-utf16>>
+ catch
+ error:_ ->
+ throw({badarg,bad_unicode})
+ end;
+eval_binary_2(Acc, Val, _Size, _Unit, utf32, big) ->
+ try
+ <<Acc/bitstring,Val/big-utf32>>
+ catch
+ error:_ ->
+ throw({badarg,bad_unicode})
+ end;
+eval_binary_2(Acc, Val, _Size, _Unit, utf32, little) ->
+ try
+ <<Acc/bitstring,Val/little-utf32>>
+ catch
+ error:_ ->
+ throw({badarg,bad_unicode})
+ end;
+eval_binary_2(Acc, Val, Size, Unit, float, little) ->
+ <<Acc/bitstring,Val:(Size*Unit)/little-float>>;
+eval_binary_2(Acc, Val, Size, Unit, float, big) ->
+ <<Acc/bitstring,Val:(Size*Unit)/big-float>>;
+eval_binary_2(Acc, Val, all, Unit, binary, _) ->
+ case bit_size(Val) of
+ Size when Size rem Unit =:= 0 ->
+ <<Acc/bitstring,Val:Size/bitstring>>;
+ Size ->
+ throw({badarg,{embedded_unit,Unit,Size}})
+ end;
+eval_binary_2(Acc, Val, Size, Unit, binary, _) ->
+ <<Acc/bitstring,Val:(Size*Unit)/bitstring>>.
+
+%% Count the number of bits approximately needed to store Int.
+%% (We don't need an exact result for this purpose.)
+
+count_bits(Int) ->
+ count_bits_1(abs(Int), 64).
+
+count_bits_1(0, Bits) -> Bits;
+count_bits_1(Int, Bits) -> count_bits_1(Int bsr 64, Bits+64).
+
+%% useless_call(Context, #c_call{}) -> no | {yes,Expr}
+%% Check whether the function is called only for effect,
+%% and if the function either has no effect whatsoever or
+%% the only effect is an exception. Generate appropriate
+%% warnings. If the call is "useless" (has no effect),
+%% a rewritten expression consisting of a sequence of
+%% the arguments only is returned.
+
+useless_call(effect, #c_call{module=#c_literal{val=Mod},
+ name=#c_literal{val=Name},
+ args=Args}=Call) ->
+ A = length(Args),
+ case erl_bifs:is_safe(Mod, Name, A) of
+ false ->
+ case erl_bifs:is_pure(Mod, Name, A) of
+ true -> add_warning(Call, result_ignored);
+ false -> ok
+ end,
+ no;
+ true ->
+ add_warning(Call, {no_effect,{Mod,Name,A}}),
+ {yes,make_effect_seq(Args, sub_new())}
+ end;
+useless_call(_, _) -> no.
+
+%% make_effect_seq([Expr], Sub) -> #c_seq{}|void()
+%% Convert a list of epressions evaluated in effect context to a chain of
+%% #c_seq{}. The body in the innermost #c_seq{} will be void().
+%% Anything that will not have any effect will be thrown away.
+
+make_effect_seq([H|T], Sub) ->
+ case is_safe_simple(H, Sub) of
+ true -> make_effect_seq(T, Sub);
+ false -> #c_seq{arg=H,body=make_effect_seq(T, Sub)}
+ end;
+make_effect_seq([], _) -> void().
+
+%% Handling remote calls. The module/name fields have been processed.
+
+call(#c_call{args=As}=Call, #c_literal{val=M}=M0, #c_literal{val=N}=N0, Sub) ->
+ case get(no_inline_list_funcs) of
+ true ->
+ call_0(Call, M0, N0, As, Sub);
+ false ->
+ call_1(Call, M, N, As, Sub)
+ end;
+call(#c_call{args=As}=Call, M, N, Sub) ->
+ call_0(Call, M, N, As, Sub).
+
+call_0(Call, M, N, As0, Sub) ->
+ As1 = expr_list(As0, value, Sub),
+ fold_call(Call#c_call{args=As1}, M, N, As1, Sub).
+
+%% We inline some very common higher order list operations.
+%% We use the same evaluation order as the library function.
+
+call_1(_Call, lists, all, [Arg1,Arg2], Sub) ->
+ Loop = #c_var{name={'lists^all',1}},
+ F = #c_var{name='F'},
+ Xs = #c_var{name='Xs'},
+ X = #c_var{name='X'},
+ Err1 = #c_tuple{es=[#c_literal{val='case_clause'}, X]},
+ CC1 = #c_clause{pats=[#c_literal{val=true}], guard=#c_literal{val=true},
+ body=#c_apply{op=Loop, args=[Xs]}},
+ CC2 = #c_clause{pats=[#c_literal{val=false}], guard=#c_literal{val=true},
+ body=#c_literal{val=false}},
+ CC3 = #c_clause{pats=[X], guard=#c_literal{val=true},
+ body=#c_primop{name=#c_literal{val='match_fail'},
+ args=[Err1]}},
+ C1 = #c_clause{pats=[#c_cons{hd=X, tl=Xs}], guard=#c_literal{val=true},
+ body=#c_case{arg=#c_apply{op=F, args=[X]},
+ clauses = [CC1, CC2, CC3]}},
+ C2 = #c_clause{pats=[#c_literal{val=[]}], guard=#c_literal{val=true},
+ body=#c_literal{val=true}},
+ Err2 = #c_tuple{es=[#c_literal{val='function_clause'}, Xs]},
+ C3 = #c_clause{pats=[Xs], guard=#c_literal{val=true},
+ body=#c_primop{name=#c_literal{val='match_fail'},
+ args=[Err2]}},
+ Fun = #c_fun{vars=[Xs],
+ body=#c_case{arg=Xs, clauses=[C1, C2, C3]}},
+ L = #c_var{name='L'},
+ expr(#c_let{vars=[F, L], arg=#c_values{es=[Arg1, Arg2]},
+ body=#c_letrec{defs=[{Loop,Fun}],
+ body=#c_apply{op=Loop, args=[L]}}},
+ Sub);
+call_1(_Call, lists, any, [Arg1,Arg2], Sub) ->
+ Loop = #c_var{name={'lists^any',1}},
+ F = #c_var{name='F'},
+ Xs = #c_var{name='Xs'},
+ X = #c_var{name='X'},
+ Err1 = #c_tuple{es=[#c_literal{val='case_clause'}, X]},
+ CC1 = #c_clause{pats=[#c_literal{val=true}], guard=#c_literal{val=true},
+ body=#c_literal{val=true}},
+ CC2 = #c_clause{pats=[#c_literal{val=false}], guard=#c_literal{val=true},
+ body=#c_apply{op=Loop, args=[Xs]}},
+ CC3 = #c_clause{pats=[X], guard=#c_literal{val=true},
+ body=#c_primop{name=#c_literal{val='match_fail'},
+ args=[Err1]}},
+ C1 = #c_clause{pats=[#c_cons{hd=X, tl=Xs}], guard=#c_literal{val=true},
+ body=#c_case{arg=#c_apply{op=F, args=[X]},
+ clauses = [CC1, CC2, CC3]}},
+ C2 = #c_clause{pats=[#c_literal{val=[]}], guard=#c_literal{val=true},
+ body=#c_literal{val=false}},
+ Err2 = #c_tuple{es=[#c_literal{val='function_clause'}, Xs]},
+ C3 = #c_clause{pats=[Xs], guard=#c_literal{val=true},
+ body=#c_primop{name=#c_literal{val='match_fail'},
+ args=[Err2]}},
+ Fun = #c_fun{vars=[Xs],
+ body=#c_case{arg=Xs, clauses=[C1, C2, C3]}},
+ L = #c_var{name='L'},
+ expr(#c_let{vars=[F, L], arg=#c_values{es=[Arg1, Arg2]},
+ body=#c_letrec{defs=[{Loop,Fun}],
+ body=#c_apply{op=Loop, args=[L]}}},
+ Sub);
+call_1(_Call, lists, foreach, [Arg1,Arg2], Sub) ->
+ Loop = #c_var{name={'lists^foreach',1}},
+ F = #c_var{name='F'},
+ Xs = #c_var{name='Xs'},
+ X = #c_var{name='X'},
+ C1 = #c_clause{pats=[#c_cons{hd=X, tl=Xs}], guard=#c_literal{val=true},
+ body=#c_seq{arg=#c_apply{op=F, args=[X]},
+ body=#c_apply{op=Loop, args=[Xs]}}},
+ C2 = #c_clause{pats=[#c_literal{val=[]}], guard=#c_literal{val=true},
+ body=#c_literal{val=ok}},
+ Err = #c_tuple{es=[#c_literal{val='function_clause'}, Xs]},
+ C3 = #c_clause{pats=[Xs], guard=#c_literal{val=true},
+ body=#c_primop{name=#c_literal{val='match_fail'},
+ args=[Err]}},
+ Fun = #c_fun{vars=[Xs],
+ body=#c_case{arg=Xs, clauses=[C1, C2, C3]}},
+ L = #c_var{name='L'},
+ expr(#c_let{vars=[F, L], arg=#c_values{es=[Arg1, Arg2]},
+ body=#c_letrec{defs=[{Loop,Fun}],
+ body=#c_apply{op=Loop, args=[L]}}},
+ Sub);
+call_1(_Call, lists, map, [Arg1,Arg2], Sub) ->
+ Loop = #c_var{name={'lists^map',1}},
+ F = #c_var{name='F'},
+ Xs = #c_var{name='Xs'},
+ X = #c_var{name='X'},
+ H = #c_var{name='H'},
+ C1 = #c_clause{pats=[#c_cons{hd=X, tl=Xs}], guard=#c_literal{val=true},
+ body=#c_let{vars=[H], arg=#c_apply{op=F, args=[X]},
+ body=#c_cons{hd=H,
+ tl=#c_apply{op=Loop,
+ args=[Xs]}}}},
+ C2 = #c_clause{pats=[#c_literal{val=[]}], guard=#c_literal{val=true},
+ body=#c_literal{val=[]}},
+ Err = #c_tuple{es=[#c_literal{val='function_clause'}, Xs]},
+ C3 = #c_clause{pats=[Xs], guard=#c_literal{val=true},
+ body=#c_primop{name=#c_literal{val='match_fail'},
+ args=[Err]}},
+ Fun = #c_fun{vars=[Xs],
+ body=#c_case{arg=Xs, clauses=[C1, C2, C3]}},
+ L = #c_var{name='L'},
+ expr(#c_let{vars=[F, L], arg=#c_values{es=[Arg1, Arg2]},
+ body=#c_letrec{defs=[{Loop,Fun}],
+ body=#c_apply{op=Loop, args=[L]}}},
+ Sub);
+call_1(_Call, lists, flatmap, [Arg1,Arg2], Sub) ->
+ Loop = #c_var{name={'lists^flatmap',1}},
+ F = #c_var{name='F'},
+ Xs = #c_var{name='Xs'},
+ X = #c_var{name='X'},
+ H = #c_var{name='H'},
+ C1 = #c_clause{pats=[#c_cons{hd=X, tl=Xs}], guard=#c_literal{val=true},
+ body=#c_let{vars=[H],
+ arg=#c_apply{op=F, args=[X]},
+ body=#c_call{module=#c_literal{val=erlang},
+ name=#c_literal{val='++'},
+ args=[H,
+ #c_apply{op=Loop,
+ args=[Xs]}]}}},
+ C2 = #c_clause{pats=[#c_literal{val=[]}], guard=#c_literal{val=true},
+ body=#c_literal{val=[]}},
+ Err = #c_tuple{es=[#c_literal{val='function_clause'}, Xs]},
+ C3 = #c_clause{pats=[Xs], guard=#c_literal{val=true},
+ body=#c_primop{name=#c_literal{val='match_fail'},
+ args=[Err]}},
+ Fun = #c_fun{vars=[Xs],
+ body=#c_case{arg=Xs, clauses=[C1, C2, C3]}},
+ L = #c_var{name='L'},
+ expr(#c_let{vars=[F, L], arg=#c_values{es=[Arg1, Arg2]},
+ body=#c_letrec{defs=[{Loop,Fun}],
+ body=#c_apply{op=Loop, args=[L]}}},
+ Sub);
+call_1(_Call, lists, filter, [Arg1,Arg2], Sub) ->
+ Loop = #c_var{name={'lists^filter',1}},
+ F = #c_var{name='F'},
+ Xs = #c_var{name='Xs'},
+ X = #c_var{name='X'},
+ B = #c_var{name='B'},
+ Err1 = #c_tuple{es=[#c_literal{val='case_clause'}, X]},
+ CC1 = #c_clause{pats=[#c_literal{val=true}], guard=#c_literal{val=true},
+ body=#c_cons{hd=X, tl=Xs}},
+ CC2 = #c_clause{pats=[#c_literal{val=false}], guard=#c_literal{val=true},
+ body=Xs},
+ CC3 = #c_clause{pats=[X], guard=#c_literal{val=true},
+ body=#c_primop{name=#c_literal{val='match_fail'},
+ args=[Err1]}},
+ Case = #c_case{arg=B, clauses = [CC1, CC2, CC3]},
+ C1 = #c_clause{pats=[#c_cons{hd=X, tl=Xs}], guard=#c_literal{val=true},
+ body=#c_let{vars=[B],
+ arg=#c_apply{op=F, args=[X]},
+ body=#c_let{vars=[Xs],
+ arg=#c_apply{op=Loop,
+ args=[Xs]},
+ body=Case}}},
+ C2 = #c_clause{pats=[#c_literal{val=[]}], guard=#c_literal{val=true},
+ body=#c_literal{val=[]}},
+ Err2 = #c_tuple{es=[#c_literal{val='function_clause'}, Xs]},
+ C3 = #c_clause{pats=[Xs], guard=#c_literal{val=true},
+ body=#c_primop{name=#c_literal{val='match_fail'},
+ args=[Err2]}},
+ Fun = #c_fun{vars=[Xs],
+ body=#c_case{arg=Xs, clauses=[C1, C2, C3]}},
+ L = #c_var{name='L'},
+ expr(#c_let{vars=[F, L], arg=#c_values{es=[Arg1, Arg2]},
+ body=#c_letrec{defs=[{Loop,Fun}],
+ body=#c_apply{op=Loop, args=[L]}}},
+ Sub);
+call_1(_Call, lists, foldl, [Arg1,Arg2,Arg3], Sub) ->
+ Loop = #c_var{name={'lists^foldl',2}},
+ F = #c_var{name='F'},
+ Xs = #c_var{name='Xs'},
+ X = #c_var{name='X'},
+ A = #c_var{name='A'},
+ C1 = #c_clause{pats=[#c_cons{hd=X, tl=Xs}], guard=#c_literal{val=true},
+ body=#c_apply{op=Loop,
+ args=[Xs, #c_apply{op=F, args=[X, A]}]}},
+ C2 = #c_clause{pats=[#c_literal{val=[]}], guard=#c_literal{val=true}, body=A},
+ Err = #c_tuple{es=[#c_literal{val='function_clause'}, Xs]},
+ C3 = #c_clause{pats=[Xs], guard=#c_literal{val=true},
+ body=#c_primop{name=#c_literal{val='match_fail'},
+ args=[Err]}},
+ Fun = #c_fun{vars=[Xs, A],
+ body=#c_case{arg=Xs, clauses=[C1, C2, C3]}},
+ L = #c_var{name='L'},
+ expr(#c_let{vars=[F, A, L], arg=#c_values{es=[Arg1, Arg2, Arg3]},
+ body=#c_letrec{defs=[{Loop,Fun}],
+ body=#c_apply{op=Loop, args=[L, A]}}},
+ Sub);
+call_1(_Call, lists, foldr, [Arg1,Arg2,Arg3], Sub) ->
+ Loop = #c_var{name={'lists^foldr',2}},
+ F = #c_var{name='F'},
+ Xs = #c_var{name='Xs'},
+ X = #c_var{name='X'},
+ A = #c_var{name='A'},
+ C1 = #c_clause{pats=[#c_cons{hd=X, tl=Xs}], guard=#c_literal{val=true},
+ body=#c_apply{op=F, args=[X, #c_apply{op=Loop,
+ args=[Xs, A]}]}},
+ C2 = #c_clause{pats=[#c_literal{val=[]}], guard=#c_literal{val=true}, body=A},
+ Err = #c_tuple{es=[#c_literal{val='function_clause'}, Xs]},
+ C3 = #c_clause{pats=[Xs], guard=#c_literal{val=true},
+ body=#c_primop{name=#c_literal{val='match_fail'},
+ args=[Err]}},
+ Fun = #c_fun{vars=[Xs, A],
+ body=#c_case{arg=Xs, clauses=[C1, C2, C3]}},
+ L = #c_var{name='L'},
+ expr(#c_let{vars=[F, A, L], arg=#c_values{es=[Arg1, Arg2, Arg3]},
+ body=#c_letrec{defs=[{Loop,Fun}],
+ body=#c_apply{op=Loop, args=[L, A]}}},
+ Sub);
+call_1(_Call, lists, mapfoldl, [Arg1,Arg2,Arg3], Sub) ->
+ Loop = #c_var{name={'lists^mapfoldl',2}},
+ F = #c_var{name='F'},
+ Xs = #c_var{name='Xs'},
+ X = #c_var{name='X'},
+ Avar = #c_var{name='A'},
+ Match =
+ fun (A, P, E) ->
+ C1 = #c_clause{pats=[P], guard=#c_literal{val=true}, body=E},
+ Err = #c_tuple{es=[#c_literal{val='badmatch'}, X]},
+ C2 = #c_clause{pats=[X], guard=#c_literal{val=true},
+ body=#c_primop{name=#c_literal{val='match_fail'},
+ args=[Err]}},
+ #c_case{arg=A, clauses=[C1, C2]}
+ end,
+ C1 = #c_clause{pats=[#c_cons{hd=X, tl=Xs}], guard=#c_literal{val=true},
+ body=Match(#c_apply{op=F, args=[X, Avar]},
+ #c_tuple{es=[X, Avar]},
+%%% Tuple passing version
+ Match(#c_apply{op=Loop, args=[Xs, Avar]},
+ #c_tuple{es=[Xs, Avar]},
+ #c_tuple{es=[#c_cons{hd=X, tl=Xs}, Avar]})
+%%% Multiple-value version
+%%% #c_let{vars=[Xs,A],
+%%% %% The tuple here will be optimised
+%%% %% away later; no worries.
+%%% arg=#c_apply{op=Loop, args=[Xs, A]},
+%%% body=#c_values{es=[#c_cons{hd=X, tl=Xs},
+%%% A]}}
+ )},
+ C2 = #c_clause{pats=[#c_literal{val=[]}], guard=#c_literal{val=true},
+%%% Tuple passing version
+ body=#c_tuple{es=[#c_literal{val=[]}, Avar]}},
+%%% Multiple-value version
+%%% body=#c_values{es=[#c_literal{val=[]}, A]}},
+ Err = #c_tuple{es=[#c_literal{val='function_clause'}, Xs]},
+ C3 = #c_clause{pats=[Xs], guard=#c_literal{val=true},
+ body=#c_primop{name=#c_literal{val='match_fail'},
+ args=[Err]}},
+ Fun = #c_fun{vars=[Xs, Avar],
+ body=#c_case{arg=Xs, clauses=[C1, C2, C3]}},
+ L = #c_var{name='L'},
+ expr(#c_let{vars=[F, Avar, L], arg=#c_values{es=[Arg1, Arg2, Arg3]},
+ body=#c_letrec{defs=[{Loop,Fun}],
+%%% Tuple passing version
+ body=#c_apply{op=Loop, args=[L, Avar]}}},
+%%% Multiple-value version
+%%% body=#c_let{vars=[Xs, A],
+%%% arg=#c_apply{op=Loop,
+%%% args=[L, A]},
+%%% body=#c_tuple{es=[Xs, A]}}}},
+ Sub);
+call_1(_Call, lists, mapfoldr, [Arg1,Arg2,Arg3], Sub) ->
+ Loop = #c_var{name={'lists^mapfoldr',2}},
+ F = #c_var{name='F'},
+ Xs = #c_var{name='Xs'},
+ X = #c_var{name='X'},
+ Avar = #c_var{name='A'},
+ Match =
+ fun (A, P, E) ->
+ C1 = #c_clause{pats=[P], guard=#c_literal{val=true}, body=E},
+ Err = #c_tuple{es=[#c_literal{val='badmatch'}, X]},
+ C2 = #c_clause{pats=[X], guard=#c_literal{val=true},
+ body=#c_primop{name=#c_literal{val='match_fail'},
+ args=[Err]}},
+ #c_case{arg=A, clauses=[C1, C2]}
+ end,
+ C1 = #c_clause{pats=[#c_cons{hd=X, tl=Xs}], guard=#c_literal{val=true},
+%%% Tuple passing version
+ body=Match(#c_apply{op=Loop, args=[Xs, Avar]},
+ #c_tuple{es=[Xs, Avar]},
+ Match(#c_apply{op=F, args=[X, Avar]},
+ #c_tuple{es=[X, Avar]},
+ #c_tuple{es=[#c_cons{hd=X, tl=Xs}, Avar]}))
+%%% Multiple-value version
+%%% body=#c_let{vars=[Xs,A],
+%%% %% The tuple will be optimised away
+%%% arg=#c_apply{op=Loop, args=[Xs, A]},
+%%% body=Match(#c_apply{op=F, args=[X, A]},
+%%% #c_tuple{es=[X, A]},
+%%% #c_values{es=[#c_cons{hd=X, tl=Xs},
+%%% A]})}
+ },
+ C2 = #c_clause{pats=[#c_literal{val=[]}], guard=#c_literal{val=true},
+%%% Tuple passing version
+ body=#c_tuple{es=[#c_literal{val=[]}, Avar]}},
+%%% Multiple-value version
+%%% body=#c_values{es=[#c_literal{val=[]}, A]}},
+ Err = #c_tuple{es=[#c_literal{val='function_clause'}, Xs]},
+ C3 = #c_clause{pats=[Xs], guard=#c_literal{val=true},
+ body=#c_primop{name=#c_literal{val='match_fail'},
+ args=[Err]}},
+ Fun = #c_fun{vars=[Xs, Avar],
+ body=#c_case{arg=Xs, clauses=[C1, C2, C3]}},
+ L = #c_var{name='L'},
+ expr(#c_let{vars=[F, Avar, L], arg=#c_values{es=[Arg1, Arg2, Arg3]},
+ body=#c_letrec{defs=[{Loop,Fun}],
+%%% Tuple passing version
+ body=#c_apply{op=Loop, args=[L, Avar]}}},
+%%% Multiple-value version
+%%% body=#c_let{vars=[Xs, A],
+%%% arg=#c_apply{op=Loop,
+%%% args=[L, A]},
+%%% body=#c_tuple{es=[Xs, A]}}}},
+ Sub);
+call_1(#c_call{module=M, name=N}=Call, _, _, As, Sub) ->
+ call_0(Call, M, N, As, Sub).
+
+%% fold_call(Call, Mod, Name, Args, Sub) -> Expr.
+%% Try to safely evaluate the call. Just try to evaluate arguments,
+%% do the call and convert return values to literals. If this
+%% succeeds then use the new value, otherwise just fail and use
+%% original call. Do this at every level.
+%%
+%% We attempt to evaluate calls to certain BIFs even if the
+%% arguments are not literals. For instance, we evaluate length/1
+%% if the shape of the list is known, and element/2 and setelement/3
+%% if the position is constant and the shape of the tuple is known.
+%%
+fold_call(Call, #c_literal{val=M}, #c_literal{val=F}, Args, Sub) ->
+ fold_call_1(Call, M, F, Args, Sub);
+fold_call(Call, _M, _N, _Args, _Sub) -> Call.
+
+fold_call_1(Call, erlang, apply, [Mod,Func,Args], _) ->
+ simplify_apply(Call, Mod, Func, Args);
+fold_call_1(Call, Mod, Name, Args, Sub) ->
+ NumArgs = length(Args),
+ case erl_bifs:is_pure(Mod, Name, NumArgs) of
+ false -> Call; %Not pure - keep call.
+ true -> fold_call_2(Call, Mod, Name, Args, Sub)
+ end.
+
+fold_call_2(Call, Module, Name, Args0, Sub) ->
+ try
+ Args = [core_lib:literal_value(A) || A <- Args0],
+ try apply(Module, Name, Args) of
+ Val ->
+ case cerl:is_literal_term(Val) of
+ true ->
+ #c_literal{val=Val};
+ false ->
+ %% Successful evaluation, but it was not
+ %% possible to express the computed value as a literal.
+ Call
+ end
+ catch
+ error:Reason ->
+ %% Evaluation of the function failed. Warn and replace
+ %% the call with a call to erlang:error/1.
+ eval_failure(Call, Reason)
+ end
+ catch
+ error:_ ->
+ %% There was at least one non-literal argument.
+ fold_non_lit_args(Call, Module, Name, Args0, Sub)
+ end.
+
+%% fold_non_lit_args(Call, Module, Name, Args, Sub) -> Expr.
+%% Attempt to evaluate some pure BIF calls with one or more
+%% non-literals arguments.
+%%
+fold_non_lit_args(Call, erlang, is_boolean, [Arg], Sub) ->
+ eval_is_boolean(Call, Arg, Sub);
+fold_non_lit_args(Call, erlang, element, [Arg1,Arg2], Sub) ->
+ eval_element(Call, Arg1, Arg2, Sub);
+fold_non_lit_args(Call, erlang, length, [Arg], _) ->
+ eval_length(Call, Arg);
+fold_non_lit_args(Call, erlang, '++', [Arg1,Arg2], _) ->
+ eval_append(Call, Arg1, Arg2);
+fold_non_lit_args(Call, lists, append, [Arg1,Arg2], _) ->
+ eval_append(Call, Arg1, Arg2);
+fold_non_lit_args(Call, erlang, setelement, [Arg1,Arg2,Arg3], _) ->
+ eval_setelement(Call, Arg1, Arg2, Arg3);
+fold_non_lit_args(Call, erlang, N, Args, Sub) ->
+ NumArgs = length(Args),
+ case erl_internal:comp_op(N, NumArgs) of
+ true ->
+ eval_rel_op(Call, N, Args, Sub);
+ false ->
+ case erl_internal:bool_op(N, NumArgs) of
+ true ->
+ eval_bool_op(Call, N, Args, Sub);
+ false ->
+ Call
+ end
+ end;
+fold_non_lit_args(Call, _, _, _, _) -> Call.
+
+%% Evaluate a relational operation using type information.
+eval_rel_op(Call, Op, [#c_var{name=V},#c_var{name=V}], _) ->
+ Bool = erlang:Op(same, same),
+ #c_literal{anno=core_lib:get_anno(Call),val=Bool};
+eval_rel_op(Call, '=:=', [#c_var{name=V}=Var,#c_literal{val=true}], Sub) ->
+ %% BoolVar =:= true ==> BoolVar
+ case is_boolean_type(V, Sub) of
+ true -> Var;
+ false -> Call
+ end;
+eval_rel_op(Call, '==', Ops, _Sub) ->
+ case is_exact_eq_ok(Ops) of
+ true ->
+ Name = #c_literal{anno=core_lib:get_anno(Call),val='=:='},
+ Call#c_call{name=Name};
+ false ->
+ Call
+ end;
+eval_rel_op(Call, '/=', Ops, _Sub) ->
+ case is_exact_eq_ok(Ops) of
+ true ->
+ Name = #c_literal{anno=core_lib:get_anno(Call),val='=/='},
+ Call#c_call{name=Name};
+ false ->
+ Call
+ end;
+eval_rel_op(Call, _, _, _) -> Call.
+
+is_exact_eq_ok([#c_literal{val=Lit}|_]) ->
+ is_non_numeric(Lit);
+is_exact_eq_ok([_|T]) ->
+ is_exact_eq_ok(T);
+is_exact_eq_ok([]) -> false.
+
+is_non_numeric([H|T]) ->
+ is_non_numeric(H) andalso is_non_numeric(T);
+is_non_numeric(Tuple) when is_tuple(Tuple) ->
+ is_non_numeric_tuple(Tuple, tuple_size(Tuple));
+is_non_numeric(Num) when is_number(Num) ->
+ false;
+is_non_numeric(_) -> true.
+
+is_non_numeric_tuple(Tuple, El) when El >= 1 ->
+ is_non_numeric(element(El, Tuple)) andalso
+ is_non_numeric_tuple(Tuple, El-1);
+is_non_numeric_tuple(_Tuple, 0) -> true.
+
+%% Evaluate a bool op using type information. We KNOW that
+%% there must be at least one non-literal argument (i.e.
+%% there is no need to handle the case that all argments
+%% are literal).
+eval_bool_op(Call, 'and', [#c_literal{val=true},#c_var{name=V}=Res], Sub) ->
+ case is_boolean_type(V, Sub) of
+ true -> Res;
+ false-> Call
+ end;
+eval_bool_op(Call, 'and', [#c_var{name=V}=Res,#c_literal{val=true}], Sub) ->
+ case is_boolean_type(V, Sub) of
+ true -> Res;
+ false-> Call
+ end;
+eval_bool_op(Call, 'and', [#c_literal{val=false}=Res,#c_var{name=V}], Sub) ->
+ case is_boolean_type(V, Sub) of
+ true -> Res;
+ false-> Call
+ end;
+eval_bool_op(Call, 'and', [#c_var{name=V},#c_literal{val=false}=Res], Sub) ->
+ case is_boolean_type(V, Sub) of
+ true -> Res;
+ false-> Call
+ end;
+eval_bool_op(Call, _, _, _) -> Call.
+
+%% Evaluate is_boolean/1 using type information.
+eval_is_boolean(Call, #c_var{name=V}, Sub) ->
+ case is_boolean_type(V, Sub) of
+ true -> #c_literal{val=true};
+ false -> Call
+ end;
+eval_is_boolean(_, #c_cons{}, _) ->
+ #c_literal{val=false};
+eval_is_boolean(_, #c_tuple{}, _) ->
+ #c_literal{val=false};
+eval_is_boolean(Call, _, _) ->
+ Call.
+
+%% eval_length(Call, List) -> Val.
+%% Evaluates the length for the prefix of List which has a known
+%% shape.
+%%
+eval_length(Call, Core) -> eval_length(Call, Core, 0).
+
+eval_length(Call, #c_literal{val=Val}, Len0) ->
+ try
+ Len = Len0 + length(Val),
+ #c_literal{anno=Call#c_call.anno,val=Len}
+ catch
+ _:_ ->
+ eval_failure(Call, badarg)
+ end;
+eval_length(Call, #c_cons{tl=T}, Len) ->
+ eval_length(Call, T, Len+1);
+eval_length(Call, _List, 0) ->
+ Call; %Could do nothing
+eval_length(Call, List, Len) ->
+ A = Call#c_call.anno,
+ #c_call{anno=A,
+ module=#c_literal{anno=A,val=erlang},
+ name=#c_literal{anno=A,val='+'},
+ args=[#c_literal{anno=A,val=Len},Call#c_call{args=[List]}]}.
+
+%% eval_append(Call, FirstList, SecondList) -> Val.
+%% Evaluates the constant part of '++' expression.
+%%
+eval_append(Call, #c_literal{val=Cs1}=S1, #c_literal{val=Cs2}) ->
+ try
+ S1#c_literal{val=Cs1 ++ Cs2}
+ catch error:badarg ->
+ eval_failure(Call, badarg)
+ end;
+eval_append(Call, #c_literal{val=Cs}, List) when length(Cs) =< 4 ->
+ Anno = Call#c_call.anno,
+ foldr(fun (C, L) ->
+ ann_c_cons(Anno, #c_literal{val=C}, L)
+ end, List, Cs);
+eval_append(Call, #c_cons{anno=Anno,hd=H,tl=T}, List) ->
+ ann_c_cons(Anno, H, eval_append(Call, T, List));
+eval_append(Call, X, Y) ->
+ Call#c_call{args=[X,Y]}. %Rebuild call arguments.
+
+%% eval_element(Call, Pos, Tuple, Types) -> Val.
+%% Evaluates element/2 if the position Pos is a literal and
+%% the shape of the tuple Tuple is known.
+%%
+eval_element(Call, #c_literal{val=Pos}, #c_tuple{es=Es}, _Types) when is_integer(Pos) ->
+ if
+ 1 =< Pos, Pos =< length(Es) ->
+ lists:nth(Pos, Es);
+ true ->
+ eval_failure(Call, badarg)
+ end;
+%% eval_element(Call, #c_literal{val=Pos}, #c_var{name=V}, Types)
+%% when is_integer(Pos) ->
+%% case orddict:find(V, Types#sub.t) of
+%% {ok,#c_tuple{es=Elements}} ->
+%% if
+%% 1 =< Pos, Pos =< length(Elements) ->
+%% lists:nth(Pos, Elements);
+%% true ->
+%% eval_failure(Call, badarg)
+%% end;
+%% error ->
+%% Call
+%% end;
+eval_element(Call, Pos, Tuple, _Types) ->
+ case is_not_integer(Pos) orelse is_not_tuple(Tuple) of
+ true ->
+ eval_failure(Call, badarg);
+ false ->
+ Call
+ end.
+
+%% is_not_integer(Core) -> true | false.
+%% Returns true if Core is definitely not an integer.
+
+is_not_integer(#c_literal{val=Val}) when not is_integer(Val) -> true;
+is_not_integer(#c_tuple{}) -> true;
+is_not_integer(#c_cons{}) -> true;
+is_not_integer(_) -> false.
+
+%% is_not_tuple(Core) -> true | false.
+%% Returns true if Core is definitely not a tuple.
+
+is_not_tuple(#c_literal{val=Val}) when not is_tuple(Val) -> true;
+is_not_tuple(#c_cons{}) -> true;
+is_not_tuple(_) -> false.
+
+%% eval_setelement(Call, Pos, Tuple, NewVal) -> Core.
+%% Evaluates setelement/3 if position Pos is an integer
+%% the shape of the tuple Tuple is known.
+%%
+eval_setelement(Call, Pos, Tuple, NewVal) ->
+ try
+ eval_setelement_1(Pos, Tuple, NewVal)
+ catch
+ error:_ ->
+ Call
+ end.
+
+eval_setelement_1(#c_literal{val=Pos}, #c_tuple{anno=A,es=Es}, NewVal)
+ when is_integer(Pos) ->
+ ann_c_tuple(A, eval_setelement_2(Pos, Es, NewVal));
+eval_setelement_1(#c_literal{val=Pos}, #c_literal{anno=A,val=Es0}, NewVal)
+ when is_integer(Pos) ->
+ Es = [#c_literal{anno=A,val=E} || E <- tuple_to_list(Es0)],
+ ann_c_tuple(A, eval_setelement_2(Pos, Es, NewVal)).
+
+eval_setelement_2(1, [_|T], NewVal) ->
+ [NewVal|T];
+eval_setelement_2(Pos, [H|T], NewVal) when Pos > 1 ->
+ [H|eval_setelement_2(Pos-1, T, NewVal)].
+
+%% eval_failure(Call, Reason) -> Core.
+%% Warn for a call that will fail and replace the call with
+%% a call to erlang:error(Reason).
+%%
+eval_failure(Call, Reason) ->
+ add_warning(Call, {eval_failure,Reason}),
+ #c_call{module=#c_literal{val=erlang},
+ name=#c_literal{val=error},
+ args=[#c_literal{val=Reason}]}.
+
+%% simplify_apply(Call0, Mod, Func, Args) -> Call
+%% Simplify an apply/3 to a call if the number of arguments
+%% are known at compile time.
+
+simplify_apply(Call, Mod, Func, Args) ->
+ case is_atom_or_var(Mod) andalso is_atom_or_var(Func) of
+ true -> simplify_apply_1(Args, Call, Mod, Func, []);
+ false -> Call
+ end.
+
+simplify_apply_1(#c_literal{val=MoreArgs0}, Call, Mod, Func, Args)
+ when length(MoreArgs0) >= 0 ->
+ MoreArgs = [#c_literal{val=Arg} || Arg <- MoreArgs0],
+ Call#c_call{module=Mod,name=Func,args=reverse(Args, MoreArgs)};
+simplify_apply_1(#c_cons{hd=Arg,tl=T}, Call, Mod, Func, Args) ->
+ simplify_apply_1(T, Call, Mod, Func, [Arg|Args]);
+simplify_apply_1(_, Call, _, _, _) -> Call.
+
+is_atom_or_var(#c_literal{val=Atom}) when is_atom(Atom) -> true;
+is_atom_or_var(#c_var{}) -> true;
+is_atom_or_var(_) -> false.
+
+%% clause(Clause, Cepxr, Context, Sub) -> Clause.
+
+clause(#c_clause{pats=Ps0,guard=G0,body=B0}=Cl, Cexpr, Ctxt, Sub0) ->
+ {Ps1,Sub1} = pattern_list(Ps0, Sub0),
+ Sub2 = update_types(Cexpr, Ps1, Sub1),
+ GSub = case {Cexpr,Ps1} of
+ {#c_var{name='_'},_} ->
+ %% In a 'receive', Cexpr is the variable '_', which represents the
+ %% message being matched. We must NOT do any extra substiutions.
+ Sub2;
+ {#c_var{},[#c_var{}=Var]} ->
+ %% The idea here is to optimize expressions such as
+ %%
+ %% case A of A -> ...
+ %%
+ %% to get rid of the extra guard test that the compiler
+ %% added when converting to the Core Erlang representation:
+ %%
+ %% case A of NewVar when A =:= NewVar -> ...
+ %%
+ %% By replacing NewVar with A everywhere in the guard
+ %% expression, we get
+ %%
+ %% case A of NewVar when A =:= A -> ...
+ %%
+ %% which by constant-expression evaluation is reduced to
+ %%
+ %% case A of NewVar when true -> ...
+ %%
+ sub_set_var(Var, Cexpr, Sub2);
+ _ ->
+ Sub2
+ end,
+ G1 = guard(G0, GSub),
+ B1 = body(B0, Ctxt, Sub2),
+ Cl#c_clause{pats=Ps1,guard=G1,body=B1}.
+
+%% let_substs(LetVars, LetArg, Sub) -> {[Var],[Val],Sub}.
+%% Add suitable substitutions to Sub of variables in LetVars. First
+%% remove variables in LetVars from Sub, then fix subs. N.B. must
+%% work out new subs in parallel and then apply them to subs. Return
+%% the unsubstituted variables and values.
+
+let_substs(Vs0, As0, Sub0) ->
+ {Vs1,Sub1} = pattern_list(Vs0, Sub0),
+ {Vs2,As1,Ss} = let_substs_1(Vs1, As0, Sub1),
+ Sub2 = scope_add([V || #c_var{name=V} <- Vs2], Sub1),
+ {Vs2,As1,
+ foldl(fun ({V,S}, Sub) -> sub_set_name(V, S, Sub) end, Sub2, Ss)}.
+
+let_substs_1(Vs, #c_values{es=As}, Sub) ->
+ let_subst_list(Vs, As, Sub);
+let_substs_1([V], A, Sub) -> let_subst_list([V], [A], Sub);
+let_substs_1(Vs, A, _) -> {Vs,A,[]}.
+
+let_subst_list([V|Vs0], [A|As0], Sub) ->
+ {Vs1,As1,Ss} = let_subst_list(Vs0, As0, Sub),
+ case is_subst(A) of
+ true -> {Vs1,As1,sub_subst_var(V, A, Sub) ++ Ss};
+ false -> {[V|Vs1],[A|As1],Ss}
+ end;
+let_subst_list([], [], _) -> {[],[],[]}.
+
+%% pattern(Pattern, InSub) -> {Pattern,OutSub}.
+%% pattern(Pattern, InSub, OutSub) -> {Pattern,OutSub}.
+%% Variables occurring in Pattern will shadow so they must be removed
+%% from Sub. If they occur as a value in Sub then we create a new
+%% variable and then add a substitution for that.
+%%
+%% Patterns are complicated by sizes in binaries. These are pure
+%% input variables which create no bindings. We, therefore, need to
+%% carry around the original substitutions to get the correct
+%% handling.
+
+%%pattern(Pat, Sub) -> pattern(Pat, Sub, Sub).
+
+pattern(#c_var{name=V0}=Pat, Isub, Osub) ->
+ case sub_is_val(Pat, Isub) of
+ true ->
+ V1 = make_var_name(),
+ Pat1 = #c_var{name=V1},
+ {Pat1,sub_set_var(Pat, Pat1, scope_add([V1], Osub))};
+ false ->
+ {Pat,sub_del_var(Pat, scope_add([V0], Osub))}
+ end;
+pattern(#c_literal{}=Pat, _, Osub) -> {Pat,Osub};
+pattern(#c_cons{anno=Anno,hd=H0,tl=T0}, Isub, Osub0) ->
+ {H1,Osub1} = pattern(H0, Isub, Osub0),
+ {T1,Osub2} = pattern(T0, Isub, Osub1),
+ {ann_c_cons(Anno, H1, T1),Osub2};
+pattern(#c_tuple{anno=Anno,es=Es0}, Isub, Osub0) ->
+ {Es1,Osub1} = pattern_list(Es0, Isub, Osub0),
+ {ann_c_tuple(Anno, Es1),Osub1};
+pattern(#c_binary{segments=V0}=Pat, Isub, Osub0) ->
+ {V1,Osub1} = bin_pattern_list(V0, Isub, Osub0),
+ {Pat#c_binary{segments=V1},Osub1};
+pattern(#c_alias{var=V0,pat=P0}=Pat, Isub, Osub0) ->
+ {V1,Osub1} = pattern(V0, Isub, Osub0),
+ {P1,Osub2} = pattern(P0, Isub, Osub1),
+ Osub = update_types(V1, [P1], Osub2),
+ {Pat#c_alias{var=V1,pat=P1},Osub}.
+
+bin_pattern_list(Ps0, Isub, Osub0) ->
+ {Ps,{_,Osub}} = mapfoldl(fun bin_pattern/2, {Isub,Osub0}, Ps0),
+ {Ps,Osub}.
+
+bin_pattern(#c_bitstr{val=E0,size=Size0}=Pat, {Isub0,Osub0}) ->
+ Size1 = expr(Size0, Isub0),
+ {E1,Osub} = pattern(E0, Isub0, Osub0),
+ Isub = case E0 of
+ #c_var{} -> sub_set_var(E0, E1, Isub0);
+ _ -> Isub0
+ end,
+ {Pat#c_bitstr{val=E1,size=Size1},{Isub,Osub}}.
+
+pattern_list(Ps, Sub) -> pattern_list(Ps, Sub, Sub).
+
+pattern_list(Ps0, Isub, Osub0) ->
+ mapfoldl(fun (P, Osub) -> pattern(P, Isub, Osub) end, Osub0, Ps0).
+
+%% is_subst(Expr) -> true | false.
+%% Test whether an expression is a suitable substitution.
+
+is_subst(#c_var{name={_,_}}) ->
+ %% Funs must not be duplicated (which will happen if the variable
+ %% is used more than once), because the funs will not be equal
+ %% (their "index" fields will be different).
+ false;
+is_subst(#c_var{}) -> true;
+is_subst(#c_literal{}) -> true;
+is_subst(_) -> false.
+
+%% sub_new() -> #sub{}.
+%% sub_get_var(Var, #sub{}) -> Value.
+%% sub_set_var(Var, Value, #sub{}) -> #sub{}.
+%% sub_set_name(Name, Value, #sub{}) -> #sub{}.
+%% sub_del_var(Var, #sub{}) -> #sub{}.
+%% sub_subst_var(Var, Value, #sub{}) -> [{Name,Value}].
+%% sub_is_val(Var, #sub{}) -> boolean().
+%% sub_subst_scope(#sub{}) -> #sub{}
+%%
+%% We use the variable name as key so as not have problems with
+%% annotations. When adding a new substitute we fold substitute
+%% chains so we never have to search more than once. Use orddict so
+%% we know the format.
+%%
+%% sub_subst_scope/1 adds dummy substitutions for all variables
+%% in the scope in order to force renaming if variables in the
+%% scope occurs as pattern variables.
+
+sub_new() -> #sub{v=orddict:new(),s=gb_trees:empty(),t=[]}.
+
+sub_new(#sub{}=Sub) ->
+ Sub#sub{v=orddict:new(),t=[]}.
+
+sub_new_preserve_types(#sub{}=Sub) ->
+ Sub#sub{v=orddict:new()}.
+
+sub_get_var(#c_var{name=V}=Var, #sub{v=S}) ->
+ case orddict:find(V, S) of
+ {ok,Val} -> Val;
+ error -> Var
+ end.
+
+sub_set_var(#c_var{name=V}, Val, Sub) ->
+ sub_set_name(V, Val, Sub).
+
+sub_set_name(V, Val, #sub{v=S,s=Scope,t=Tdb0}=Sub) ->
+ Tdb1 = kill_types(V, Tdb0),
+ Tdb = copy_type(V, Val, Tdb1),
+ Sub#sub{v=orddict:store(V, Val, S),s=gb_sets:add(V, Scope),t=Tdb}.
+
+sub_del_var(#c_var{name=V}, #sub{v=S,t=Tdb}=Sub) ->
+ Sub#sub{v=orddict:erase(V, S),t=kill_types(V, Tdb)}.
+
+sub_subst_var(#c_var{name=V}, Val, #sub{v=S0}) ->
+ %% Fold chained substitutions.
+ [{V,Val}] ++ [ {K,Val} || {K,#c_var{name=V1}} <- S0, V1 =:= V].
+
+sub_subst_scope(#sub{v=S0,s=Scope}=Sub) ->
+ S = [{-1,#c_var{name=Sv}} || Sv <- gb_sets:to_list(Scope)]++S0,
+ Sub#sub{v=S}.
+
+sub_is_val(#c_var{name=V}, #sub{v=S}) ->
+ v_is_value(V, S).
+
+v_is_value(Var, Sub) ->
+ any(fun ({_,#c_var{name=Val}}) when Val =:= Var -> true;
+ (_) -> false
+ end, Sub).
+
+%% clauses(E, [Clause], TopLevel, Context, Sub) -> [Clause].
+%% Trim the clauses by removing all clauses AFTER the first one which
+%% is guaranteed to match. Also remove all trivially false clauses.
+
+clauses(E, Cs0, TopLevel, Ctxt, Sub) ->
+ Cs = clauses_1(E, Cs0, Ctxt, Sub),
+
+ %% Here we want to warn if no clauses whatsoever will ever
+ %% match, because that is probably a mistake.
+ case all(fun is_compiler_generated/1, Cs) andalso
+ any(fun(C) -> not is_compiler_generated(C) end, Cs0) of
+ true ->
+ %% The original list of clauses did contain at least one
+ %% user-specified clause, but none of them will match.
+ %% That is probably a mistake.
+ add_warning(TopLevel, no_clause_match);
+ false ->
+ %% Either there were user-specified clauses left in
+ %% the transformed clauses, or else none of the original
+ %% clauses were user-specified to begin with (as in 'andalso').
+ ok
+ end,
+
+ Cs.
+
+clauses_1(E, [C0|Cs], Ctxt, Sub) ->
+ #c_clause{pats=Ps,guard=G} = C1 = clause(C0, E, Ctxt, Sub),
+ %%ok = io:fwrite("~w: ~p~n", [?LINE,{E,Ps}]),
+ case {will_match(E, Ps),will_succeed(G)} of
+ {yes,yes} ->
+ Line = get_line(core_lib:get_anno(C1)),
+ case core_lib:is_literal(E) of
+ false ->
+ shadow_warning(Cs, Line);
+ true ->
+ %% If the case expression is a literal,
+ %% it is probably OK that some clauses don't match.
+ %% It is a probably some sort of debug macro.
+ ok
+ end,
+ [C1]; %Skip the rest
+ {no,_Suc} ->
+ clauses_1(E, Cs, Ctxt, Sub); %Skip this clause
+ {_Mat,no} ->
+ add_warning(C1, nomatch_guard),
+ clauses_1(E, Cs, Ctxt, Sub); %Skip this clause
+ {_Mat,_Suc} ->
+ [C1|clauses_1(E, Cs, Ctxt, Sub)]
+ end;
+clauses_1(_, [], _, _) -> [].
+
+shadow_warning([C|Cs], none) ->
+ add_warning(C, nomatch_shadow),
+ shadow_warning(Cs, none);
+shadow_warning([C|Cs], Line) ->
+ add_warning(C, {nomatch_shadow, Line}),
+ shadow_warning(Cs, Line);
+shadow_warning([], _) -> ok.
+
+%% will_succeed(Guard) -> yes | maybe | no.
+%% Test if we know whether a guard will succeed/fail or just don't
+%% know. Be VERY conservative!
+
+will_succeed(#c_literal{val=true}) -> yes;
+will_succeed(#c_literal{val=false}) -> no;
+will_succeed(_Guard) -> maybe.
+
+%% will_match(Expr, [Pattern]) -> yes | maybe | no.
+%% Test if we know whether a match will succeed/fail or just don't
+%% know. Be conservative.
+
+will_match(#c_values{es=Es}, Ps) ->
+ will_match_list(Es, Ps, yes);
+will_match(E, [P]) ->
+ will_match_1(E, P).
+
+will_match_1(_E, #c_var{}) -> yes; %Will always match
+will_match_1(E, #c_alias{pat=P}) -> %Pattern decides
+ will_match_1(E, P);
+will_match_1(#c_var{}, _P) -> maybe;
+will_match_1(#c_tuple{es=Es}, #c_tuple{es=Ps}) ->
+ will_match_list(Es, Ps, yes);
+will_match_1(#c_literal{val=Lit}, P) ->
+ will_match_lit(Lit, P);
+will_match_1(_, _) -> maybe.
+
+will_match_list([E|Es], [P|Ps], M) ->
+ case will_match_1(E, P) of
+ yes -> will_match_list(Es, Ps, M);
+ maybe -> will_match_list(Es, Ps, maybe);
+ no -> no
+ end;
+will_match_list([], [], M) -> M.
+
+will_match_lit(Cons, #c_cons{hd=Hp,tl=Tp}) ->
+ case Cons of
+ [H|T] ->
+ case will_match_lit(H, Hp) of
+ yes -> will_match_lit(T, Tp);
+ Other -> Other
+ end;
+ _ ->
+ no
+ end;
+will_match_lit(Tuple, #c_tuple{es=Es}) ->
+ case is_tuple(Tuple) andalso tuple_size(Tuple) =:= length(Es) of
+ true -> will_match_lit_list(tuple_to_list(Tuple), Es);
+ false -> no
+ end;
+will_match_lit(Bin, #c_binary{}) ->
+ case is_bitstring(Bin) of
+ true -> maybe;
+ false -> no
+ end;
+will_match_lit(_, #c_var{}) ->
+ yes;
+will_match_lit(Lit, #c_alias{pat=P}) ->
+ will_match_lit(Lit, P);
+will_match_lit(Lit1, #c_literal{val=Lit2}) ->
+ case Lit1 =:= Lit2 of
+ true -> yes;
+ false -> no
+ end.
+
+will_match_lit_list([H|T], [P|Ps]) ->
+ case will_match_lit(H, P) of
+ yes -> will_match_lit_list(T, Ps);
+ Other -> Other
+ end;
+will_match_lit_list([], []) -> yes.
+
+%% opt_bool_case(CoreExpr) - CoreExpr'.
+%% Do various optimizations to case statement that has a
+%% boolean case expression.
+%%
+%% We start with some simple optimizations and normalization
+%% to facilitate later optimizations.
+%%
+%% If the case expression can only return a boolean
+%% (or fail), we can remove any clause that cannot
+%% possibly match 'true' or 'false'. Also, any clause
+%% following both 'true' and 'false' clause can
+%% be removed. If successful, we will end up this:
+%%
+%% case BoolExpr of case BoolExpr of
+%% true -> false ->
+%% ...; ...;
+%% false -> OR true ->
+%% ... ...
+%% end. end.
+%%
+%% We give up if there are clauses with guards, or if there
+%% is a variable clause that matches anything.
+%%
+opt_bool_case(#c_case{arg=Arg}=Case0) ->
+ case is_bool_expr(Arg) of
+ false ->
+ Case0;
+ true ->
+ try opt_bool_clauses(Case0) of
+ Case ->
+ opt_bool_not(Case)
+ catch
+ impossible ->
+ Case0
+ end
+ end;
+opt_bool_case(Core) -> Core.
+
+opt_bool_clauses(#c_case{clauses=Cs}=Case) ->
+ Case#c_case{clauses=opt_bool_clauses(Cs, false, false)}.
+
+opt_bool_clauses(Cs, true, true) ->
+ %% We have now seen clauses that match both true and false.
+ %% Any remaining clauses cannot possibly match.
+ case Cs of
+ [_|_] ->
+ shadow_warning(Cs, none),
+ [];
+ [] ->
+ []
+ end;
+opt_bool_clauses([#c_clause{pats=[#c_literal{val=Lit}],
+ guard=#c_literal{val=true},
+ body=B}=C0|Cs], SeenT, SeenF) ->
+ case is_boolean(Lit) of
+ false ->
+ %% Not a boolean - this clause can't match.
+ add_warning(C0, nomatch_clause_type),
+ opt_bool_clauses(Cs, SeenT, SeenF);
+ true ->
+ %% This clause will match.
+ C = C0#c_clause{body=opt_bool_case(B)},
+ case Lit of
+ false -> [C|opt_bool_clauses(Cs, SeenT, true)];
+ true -> [C|opt_bool_clauses(Cs, true, SeenF)]
+ end
+ end;
+opt_bool_clauses([#c_clause{pats=Ps,guard=#c_literal{val=true}}=C|Cs], SeenT, SeenF) ->
+ case Ps of
+ [#c_var{}] ->
+ %% Will match a boolean.
+ throw(impossible);
+ [#c_alias{}] ->
+ %% Might match a boolean.
+ throw(impossible);
+ _ ->
+ %% The clause cannot possible match a boolean.
+ %% We can remove it.
+ add_warning(C, nomatch_clause_type),
+ opt_bool_clauses(Cs, SeenT, SeenF)
+ end;
+opt_bool_clauses([_|_], _, _) ->
+ %% A clause with a guard. Give up.
+ throw(impossible).
+%% We intentionally do not have a clause that match an empty
+%% list. An empty list would indicate that the clauses do not
+%% match all possible values for the case expression, which
+%% means that the Core Erlang program is illegal. We prefer to
+%% crash on such illegal input, rather than producing code that will
+%% fail mysteriously at run time.
+
+
+%% opt_bool_not(Case) -> CoreExpr.
+%% Try to eliminate one or more calls to 'not' at the top level
+%% of the case expression.
+%%
+%% We KNOW that the case expression is guaranteed to return
+%% a boolean and that there are exactly two clauses: one that
+%% matches 'true' and one that matches 'false'.
+%%
+%% case not Expr of case Expr of
+%% true -> false ->
+%% ...; ...;
+%% false -> ==> true ->
+%% ... ...;
+%% end. NewVar ->
+%% erlang:error(badarg)
+%% end.
+%%
+%% We add the extra match-all clause at the end only if Expr is
+%% not guaranteed to evaluate to a boolean.
+
+opt_bool_not(#c_case{arg=Arg,clauses=Cs0}=Case0) ->
+ case Arg of
+ #c_call{module=#c_literal{val=erlang},
+ name=#c_literal{val='not'},
+ args=[Expr]} ->
+ Cs = opt_bool_not(Expr, Cs0),
+ Case = Case0#c_case{arg=Expr,clauses=Cs},
+ opt_bool_not(Case);
+ _ ->
+ opt_bool_case_redundant(Case0)
+ end.
+
+opt_bool_not(Expr, Cs) ->
+ Tail = case is_bool_expr(Expr) of
+ false ->
+ [#c_clause{anno=[compiler_generated],
+ pats=[#c_var{name=cor_variable}],
+ guard=#c_literal{val=true},
+ body=#c_call{module=#c_literal{val=erlang},
+ name=#c_literal{val=error},
+ args=[#c_literal{val=badarg}]}}];
+ true -> []
+ end,
+ [opt_bool_not_invert(C) || C <- Cs] ++ Tail.
+
+opt_bool_not_invert(#c_clause{pats=[#c_literal{val=Bool}]}=C) ->
+ C#c_clause{pats=[#c_literal{val=not Bool}]}.
+
+%% opt_bool_case_redundant(Core) -> Core'.
+%% If the sole purpose of the case is to verify that the case
+%% expression is indeed boolean, we do not need the case
+%% (since we have already verified that the case expression is
+%% boolean).
+%%
+%% case BoolExpr of
+%% true -> true ==> BoolExpr
+%% false -> false
+%% end.
+%%
+opt_bool_case_redundant(#c_case{arg=Arg,clauses=Cs}=Case) ->
+ case all(fun opt_bool_case_redundant_1/1, Cs) of
+ true -> Arg;
+ false -> opt_bool_case_guard(Case)
+ end.
+
+opt_bool_case_redundant_1(#c_clause{pats=[#c_literal{val=B}],
+ body=#c_literal{val=B}}) ->
+ true;
+opt_bool_case_redundant_1(_) -> false.
+
+%% opt_bool_case_guard(Case) -> Case'.
+%% Move a boolean case expression into the guard if we are sure that
+%% it cannot fail.
+%%
+%% case SafeBoolExpr of case <> of
+%% true -> TrueClause; ==> <> when SafeBoolExpr -> TrueClause;
+%% false -> FalseClause <> when true -> FalseClause
+%% end. end.
+%%
+%% Generally, evaluting a boolean expression in a guard should
+%% be faster than evaulating it in the body.
+%%
+opt_bool_case_guard(#c_case{arg=#c_literal{}}=Case) ->
+ %% It is not necessary to move a literal case expression into the
+ %% guard, because it will be handled quite well in other
+ %% optimizations, and moving the literal into the guard will
+ %% cause some extra warnings, for instance for this code
+ %%
+ %% case true of
+ %% true -> ...;
+ %% false -> ...
+ %% end.
+ %%
+ Case;
+opt_bool_case_guard(#c_case{arg=Arg,clauses=Cs0}=Case) ->
+ case is_safe_bool_expr(Arg, sub_new()) of
+ false ->
+ Case;
+ true ->
+ Cs = opt_bool_case_guard(Arg, Cs0),
+ Case#c_case{arg=#c_values{anno=core_lib:get_anno(Arg),es=[]},
+ clauses=Cs}
+ end.
+
+opt_bool_case_guard(Arg, [#c_clause{pats=[#c_literal{val=true}]}=Tc,Fc]) ->
+ [Tc#c_clause{pats=[],guard=Arg},Fc#c_clause{pats=[]}];
+opt_bool_case_guard(Arg, [#c_clause{pats=[#c_literal{val=false}]}=Fc,Tc]) ->
+ [Tc#c_clause{pats=[],guard=Arg},Fc#c_clause{pats=[]}].
+
+%% eval_case(Case) -> #c_case{} | #c_let{}.
+%% If possible, evaluate a case at compile time. We know that the
+%% last clause is guaranteed to match so if there is only one clause
+%% with a pattern containing only variables then rewrite to a let.
+
+eval_case(#c_case{arg=#c_var{name=V},
+ clauses=[#c_clause{pats=[P],guard=G,body=B}|_]}=Case,
+ #sub{t=Tdb}=Sub) ->
+ case orddict:find(V, Tdb) of
+ {ok,Type} ->
+ case {will_match_type(P, Type),will_succeed(G)} of
+ {yes,yes} ->
+ {Ps,Es} = remove_non_vars(P, Type),
+ expr(#c_let{vars=Ps,arg=#c_values{es=Es},body=B},
+ sub_new(Sub));
+ {_,_} ->
+ eval_case_1(Case, Sub)
+ end;
+ error -> eval_case_1(Case, Sub)
+ end;
+eval_case(Case, Sub) -> eval_case_1(Case, Sub).
+
+eval_case_1(#c_case{arg=E,clauses=[#c_clause{pats=Ps,body=B}]}=Case, Sub) ->
+ case is_var_pat(Ps) of
+ true -> expr(#c_let{vars=Ps,arg=E,body=B}, sub_new(Sub));
+ false -> eval_case_2(E, Ps, B, Case)
+ end;
+eval_case_1(Case, _) -> Case.
+
+eval_case_2(E, [P], B, Case) ->
+ %% Recall that there is only one clause and that it is guaranteed to match.
+ %% If E and P are literals, they must be the same literal and the body
+ %% can be used directly as there are no variables that need to be bound.
+ %% Otherwise, P could be an alias meaning that two or more variables
+ %% would be bound to E. We don't bother to optimize that case as it
+ %% is rather uncommon.
+ case core_lib:is_literal(E) andalso core_lib:is_literal(P) of
+ false -> Case;
+ true -> B
+ end;
+eval_case_2(_, _, _, Case) -> Case.
+
+is_var_pat(Ps) ->
+ all(fun (#c_var{}) -> true;
+ (_Pat) -> false
+ end, Ps).
+
+will_match_type(#c_tuple{es=Es}, #c_tuple{es=Ps}) ->
+ will_match_list_type(Es, Ps);
+will_match_type(#c_literal{val=Atom}, #c_literal{val=Atom}) -> yes;
+will_match_type(#c_var{}, #c_var{}) -> yes;
+will_match_type(#c_var{}, #c_alias{}) -> yes;
+will_match_type(_, _) -> no.
+
+will_match_list_type([E|Es], [P|Ps]) ->
+ case will_match_type(E, P) of
+ yes -> will_match_list_type(Es, Ps);
+ no -> no
+ end;
+will_match_list_type([], []) -> yes;
+will_match_list_type(_, _) -> no. %Different length
+
+remove_non_vars(Ps0, Es0) ->
+ {Ps,Es} = remove_non_vars(Ps0, Es0, [], []),
+ {reverse(Ps),reverse(Es)}.
+
+remove_non_vars(#c_tuple{es=Ps}, #c_tuple{es=Es}, Pacc, Eacc) ->
+ remove_non_vars_list(Ps, Es, Pacc, Eacc);
+remove_non_vars(#c_var{}=Var, #c_alias{var=Evar}, Pacc, Eacc) ->
+ {[Var|Pacc],[Evar|Eacc]};
+remove_non_vars(#c_var{}=Var, #c_var{}=Evar, Pacc, Eacc) ->
+ {[Var|Pacc],[Evar|Eacc]};
+remove_non_vars(P, E, Pacc, Eacc) ->
+ true = core_lib:is_literal(P) andalso core_lib:is_literal(E), %Assertion.
+ {Pacc,Eacc}.
+
+remove_non_vars_list([P|Ps], [E|Es], Pacc0, Eacc0) ->
+ {Pacc,Eacc} = remove_non_vars(P, E, Pacc0, Eacc0),
+ remove_non_vars_list(Ps, Es, Pacc, Eacc);
+remove_non_vars_list([], [], Pacc, Eacc) ->
+ {Pacc,Eacc}.
+
+%% case_opt(CaseArg, [Clause]) -> {CaseArg,[Clause]}.
+%% Try and optimise case by avoid building a tuple in
+%% the case expression. Instead of building a tuple
+%% in the case expression, combine the elements into
+%% multiple "values". If a clause refers to the tuple
+%% in the case expression (that was not built), introduce
+%% a let into the guard and/or body to build the tuple.
+%%
+%% case {Expr1,Expr2} of case <Expr1,Expr2> of
+%% {P1,P2} -> ... <P1,P2> -> ...
+%% . ==> .
+%% . .
+%% . .
+%% Var -> <Var1,Var2> ->
+%% ... Var ... let <Var> = {Var1,Var2}
+%% in ... Var ...
+%% . .
+%% . .
+%% . .
+%% end. end.
+%%
+case_opt(#c_tuple{anno=A,es=Es}, Cs0) ->
+ Cs1 = case_opt_cs(Cs0, length(Es)),
+ {core_lib:set_anno(core_lib:make_values(Es), A),Cs1};
+case_opt(Arg, Cs) -> {Arg,Cs}.
+
+case_opt_cs([#c_clause{pats=Ps0,guard=G,body=B}=C|Cs], Arity) ->
+ case case_tuple_pat(Ps0, Arity) of
+ {ok,Ps1,Avs} ->
+ Flet = fun ({V,Pat}, Body) -> letify(V, Pat, Body) end,
+ [C#c_clause{pats=Ps1,
+ guard=foldl(Flet, G, Avs),
+ body=foldl(Flet, B, Avs)}|case_opt_cs(Cs, Arity)];
+ error -> %Can't match
+ add_warning(C, nomatch_clause_type),
+ case_opt_cs(Cs, Arity)
+ end;
+case_opt_cs([], _) -> [].
+
+%% case_tuple_pat([Pattern], Arity) -> {ok,[Pattern],[{AliasVar,Pat}]} | error.
+
+case_tuple_pat([#c_tuple{es=Ps}], Arity) when length(Ps) =:= Arity ->
+ {ok,Ps,[]};
+case_tuple_pat([#c_literal{val=T}], Arity) when tuple_size(T) =:= Arity ->
+ Ps = [#c_literal{val=E} || E <- tuple_to_list(T)],
+ {ok,Ps,[]};
+case_tuple_pat([#c_var{anno=A}=V], Arity) ->
+ Vars = make_vars(A, 1, Arity),
+ {ok,Vars,[{V,#c_tuple{es=Vars}}]};
+case_tuple_pat([#c_alias{var=V,pat=P}], Arity) ->
+ case case_tuple_pat([P], Arity) of
+ {ok,Ps,Avs} -> {ok,Ps,[{V,#c_tuple{es=unalias_pat_list(Ps)}}|Avs]};
+ error -> error
+ end;
+case_tuple_pat(_, _) -> error.
+
+%% unalias_pat(Pattern) -> Pattern.
+%% Remove all the aliases in a pattern but using the alias variables
+%% instead of the values. We KNOW they will be bound.
+
+unalias_pat(#c_alias{var=V}) -> V;
+unalias_pat(#c_cons{anno=Anno,hd=H0,tl=T0}) ->
+ H1 = unalias_pat(H0),
+ T1 = unalias_pat(T0),
+ ann_c_cons(Anno, H1, T1);
+unalias_pat(#c_tuple{anno=Anno,es=Ps}) ->
+ ann_c_tuple(Anno, unalias_pat_list(Ps));
+unalias_pat(Atomic) -> Atomic.
+
+unalias_pat_list(Ps) -> [unalias_pat(P) || P <- Ps].
+
+make_vars(A, I, Max) when I =< Max ->
+ [make_var(A)|make_vars(A, I+1, Max)];
+make_vars(_, _, _) -> [].
+
+make_var(A) ->
+ #c_var{anno=A,name=make_var_name()}.
+
+make_var_name() ->
+ N = get(new_var_num),
+ put(new_var_num, N+1),
+ list_to_atom("fol"++integer_to_list(N)).
+
+letify(#c_var{name=Vname}=Var, Val, Body) ->
+ case core_lib:is_var_used(Vname, Body) of
+ true ->
+ A = element(2, Body),
+ #c_let{anno=A,vars=[Var],arg=Val,body=Body};
+ false -> Body
+ end.
+
+%% opt_case_in_let(LetExpr) -> LetExpr'
+
+opt_case_in_let(#c_let{vars=Vs,arg=Arg,body=B}=Let) ->
+ opt_case_in_let_0(Vs, Arg, B, Let).
+
+opt_case_in_let_0([#c_var{name=V}], Arg,
+ #c_case{arg=#c_var{name=V},clauses=Cs}=Case, Let) ->
+ case opt_case_in_let_1(V, Arg, Cs) of
+ impossible ->
+ case is_simple_case_arg(Arg) andalso
+ not core_lib:is_var_used(V, Case#c_case{arg=#c_literal{val=nil}}) of
+ true ->
+ opt_bool_case(Case#c_case{arg=Arg});
+ false ->
+ Let
+ end;
+ Expr -> Expr
+ end;
+opt_case_in_let_0(_, _, _, Let) -> Let.
+
+opt_case_in_let_1(V, Arg, Cs) ->
+ try
+ opt_case_in_let_2(V, Arg, Cs)
+ catch
+ _:_ -> impossible
+ end.
+
+opt_case_in_let_2(V, Arg0,
+ [#c_clause{pats=[#c_tuple{es=Es}],
+ guard=#c_literal{val=true},body=B}|_]) ->
+
+ %% In {V1,V2,...} = case E of P -> ... {Val1,Val2,...}; ... end.
+ %% avoid building tuples, by converting tuples to multiple values.
+ %% (The optimisation is not done if the built tuple is used or returned.)
+
+ true = all(fun (#c_var{}) -> true;
+ (_) -> false end, Es), %Only variables in tuple
+ false = core_lib:is_var_used(V, B), %Built tuple must not be used.
+ Arg1 = tuple_to_values(Arg0, length(Es)), %Might fail.
+ #c_let{vars=Es,arg=Arg1,body=B};
+opt_case_in_let_2(_, Arg, Cs) ->
+ %% simplify_bool_case(Case0) -> Case
+ %% Remove unecessary cases like
+ %%
+ %% case BoolExpr of
+ %% true -> true;
+ %% false -> false;
+ %% ....
+ %% end
+ %%
+ %% where BoolExpr is an expression that can only return true
+ %% or false (or throw an exception).
+
+ true = is_bool_case(Cs) andalso is_bool_expr(Arg),
+ Arg.
+
+is_bool_case([A,B|_]) ->
+ (is_bool_clause(true, A) andalso is_bool_clause(false, B))
+ orelse (is_bool_clause(false, A) andalso is_bool_clause(true, B)).
+
+is_bool_clause(Bool, #c_clause{pats=[#c_literal{val=Bool}],
+ guard=#c_literal{val=true},
+ body=#c_literal{val=Bool}}) ->
+ true;
+is_bool_clause(_, _) -> false.
+
+%% is_simple_case_arg(Expr) -> true|false
+%% Determine whether the Expr is simple enough to be worth
+%% substituting into a case argument. (Common substitutions
+%% of variables and literals are assumed to have been already
+%% handled by the caller.)
+
+is_simple_case_arg(#c_cons{}) -> true;
+is_simple_case_arg(#c_tuple{}) -> true;
+is_simple_case_arg(#c_call{}) -> true;
+is_simple_case_arg(#c_apply{}) -> true;
+is_simple_case_arg(_) -> false.
+
+%% is_bool_expr(Core) -> true|false
+%% Check whether the Core expression is guaranteed to return
+%% a boolean IF IT RETURNS AT ALL.
+%%
+is_bool_expr(Core) ->
+ is_bool_expr(Core, sub_new()).
+
+%% is_bool_expr(Core, Sub) -> true|false
+%% Check whether the Core expression is guaranteed to return
+%% a boolean IF IT RETURNS AT ALL. Uses type information
+%% to be able to identify more expressions as booleans.
+%%
+is_bool_expr(#c_call{module=#c_literal{val=erlang},
+ name=#c_literal{val=Name},args=Args}=Call, _) ->
+ NumArgs = length(Args),
+ erl_internal:comp_op(Name, NumArgs) orelse
+ erl_internal:new_type_test(Name, NumArgs) orelse
+ erl_internal:bool_op(Name, NumArgs) orelse
+ will_fail(Call);
+is_bool_expr(#c_try{arg=E,vars=[#c_var{name=X}],body=#c_var{name=X},
+ handler=#c_literal{val=false}}, Sub) ->
+ is_bool_expr(E, Sub);
+is_bool_expr(#c_case{clauses=Cs}, Sub) ->
+ is_bool_expr_list(Cs, Sub);
+is_bool_expr(#c_clause{body=B}, Sub) ->
+ is_bool_expr(B, Sub);
+is_bool_expr(#c_let{vars=[V],arg=Arg,body=B}, Sub0) ->
+ Sub = case is_bool_expr(Arg, Sub0) of
+ true -> update_types(V, [#c_literal{val=true}], Sub0);
+ false -> Sub0
+ end,
+ is_bool_expr(B, Sub);
+is_bool_expr(#c_let{body=B}, Sub) ->
+ %% Binding of multiple variables.
+ is_bool_expr(B, Sub);
+is_bool_expr(#c_literal{val=Bool}, _) when is_boolean(Bool) ->
+ true;
+is_bool_expr(#c_var{name=V}, Sub) ->
+ is_boolean_type(V, Sub);
+is_bool_expr(_, _) -> false.
+
+is_bool_expr_list([C|Cs], Sub) ->
+ is_bool_expr(C, Sub) andalso is_bool_expr_list(Cs, Sub);
+is_bool_expr_list([], _) -> true.
+
+%% is_safe_bool_expr(Core) -> true|false
+%% Check whether the Core expression ALWAYS returns a boolean
+%% (i.e. it cannot fail). Also make sure that the expression
+%% is suitable for a guard (no calls to non-guard BIFs, local
+%% functions, or is_record/2).
+%%
+is_safe_bool_expr(Core, Sub) ->
+ is_safe_bool_expr_1(Core, Sub, gb_sets:empty()).
+
+is_safe_bool_expr_1(#c_call{module=#c_literal{val=erlang},
+ name=#c_literal{val=is_record},
+ args=[_,_]},
+ _Sub, _BoolVars) ->
+ %% The is_record/2 BIF is NOT allowed in guards.
+ %%
+ %% NOTE: Calls like is_record(Expr, LiteralTag), where LiteralTag
+ %% is a literal atom referring to a defined record, have already
+ %% been rewritten to is_record(Expr, LiteralTag, TupleSize).
+ false;
+is_safe_bool_expr_1(#c_call{module=#c_literal{val=erlang},
+ name=#c_literal{val=Name},args=Args},
+ Sub, BoolVars) ->
+ NumArgs = length(Args),
+ case (erl_internal:comp_op(Name, NumArgs) orelse
+ erl_internal:new_type_test(Name, NumArgs)) andalso
+ is_safe_simple_list(Args, Sub) of
+ true ->
+ true;
+ false ->
+ %% Boolean operators are safe if all arguments are boolean.
+ erl_internal:bool_op(Name, NumArgs) andalso
+ is_safe_bool_expr_list(Args, Sub, BoolVars)
+ end;
+is_safe_bool_expr_1(#c_let{vars=Vars,arg=Arg,body=B}, Sub, BoolVars) ->
+ case is_safe_simple(Arg, Sub) of
+ true ->
+ case {is_safe_bool_expr_1(Arg, Sub, BoolVars),Vars} of
+ {true,[#c_var{name=V}]} ->
+ is_safe_bool_expr_1(B, Sub, gb_sets:add(V, BoolVars));
+ {false,_} ->
+ is_safe_bool_expr_1(B, Sub, BoolVars)
+ end;
+ false -> false
+ end;
+is_safe_bool_expr_1(#c_literal{val=Val}, _Sub, _) ->
+ is_boolean(Val);
+is_safe_bool_expr_1(#c_var{name=V}, _Sub, BoolVars) ->
+ gb_sets:is_element(V, BoolVars);
+is_safe_bool_expr_1(_, _, _) -> false.
+
+is_safe_bool_expr_list([C|Cs], Sub, BoolVars) ->
+ case is_safe_bool_expr_1(C, Sub, BoolVars) of
+ true -> is_safe_bool_expr_list(Cs, Sub, BoolVars);
+ false -> false
+ end;
+is_safe_bool_expr_list([], _, _) -> true.
+
+%% tuple_to_values(Expr, TupleArity) -> Expr'
+%% Convert tuples in return position of arity TupleArity to values.
+%% Throws an exception for constructs that are not handled.
+
+tuple_to_values(#c_tuple{es=Es}, Arity) when length(Es) =:= Arity ->
+ core_lib:make_values(Es);
+tuple_to_values(#c_literal{val=Tuple}=Lit, Arity) when tuple_size(Tuple) =:= Arity ->
+ Es = [Lit#c_literal{val=E} || E <- tuple_to_list(Tuple)],
+ core_lib:make_values(Es);
+tuple_to_values(#c_case{clauses=Cs0}=Case, Arity) ->
+ Cs1 = [tuple_to_values(E, Arity) || E <- Cs0],
+ Case#c_case{clauses=Cs1};
+tuple_to_values(#c_seq{body=B0}=Seq, Arity) ->
+ Seq#c_seq{body=tuple_to_values(B0, Arity)};
+tuple_to_values(#c_let{body=B0}=Let, Arity) ->
+ Let#c_let{body=tuple_to_values(B0, Arity)};
+tuple_to_values(#c_receive{clauses=Cs0,timeout=Timeout,action=A0}=Rec, Arity) ->
+ Cs = [tuple_to_values(E, Arity) || E <- Cs0],
+ A = case Timeout of
+ #c_literal{val=infinity} -> A0;
+ _ -> tuple_to_values(A0, Arity)
+ end,
+ Rec#c_receive{clauses=Cs,action=A};
+tuple_to_values(#c_clause{body=B0}=Clause, Arity) ->
+ B = tuple_to_values(B0, Arity),
+ Clause#c_clause{body=B};
+tuple_to_values(Expr, _) ->
+ case will_fail(Expr) of
+ true -> Expr;
+ false -> erlang:error({not_handled,Expr})
+ end.
+
+%% simplify_let(Let, Sub) -> Expr | impossible
+%% If the argument part of an let contains a complex expression, such
+%% as a let or a sequence, move the original let body into the complex
+%% expression.
+
+simplify_let(#c_let{arg=Arg0}=Let0, Sub) ->
+ Arg = opt_bool_case(Arg0),
+ Let = Let0#c_let{arg=Arg},
+ move_let_into_expr(Let, Arg, Sub).
+
+move_let_into_expr(#c_let{vars=InnerVs0,body=InnerBody0}=Inner,
+ #c_let{vars=OuterVs0,arg=Arg0,body=OuterBody0}=Outer, Sub0) ->
+ %%
+ %% let <InnerVars> = let <OuterVars> = <Arg>
+ %% in <OuterBody>
+ %% in <InnerBody>
+ %%
+ %% ==>
+ %%
+ %% let <OuterVars> = <Arg>
+ %% in let <InnerVars> = <OuterBody>
+ %% in <InnerBody>
+ %%
+ Arg = body(Arg0, Sub0),
+ ScopeSub0 = sub_subst_scope(Sub0#sub{t=[]}),
+ {OuterVs,ScopeSub} = pattern_list(OuterVs0, ScopeSub0),
+
+ OuterBody = body(OuterBody0, ScopeSub),
+
+ {InnerVs,Sub} = pattern_list(InnerVs0, Sub0),
+ InnerBody = body(InnerBody0, Sub),
+ Outer#c_let{vars=OuterVs,arg=Arg,
+ body=Inner#c_let{vars=InnerVs,arg=OuterBody,body=InnerBody}};
+move_let_into_expr(#c_let{vars=Lvs0,body=Lbody0}=Let,
+ #c_case{arg=Cexpr0,clauses=[Ca0,Cb0|Cs]}=Case, Sub0) ->
+ %% Test if there are no more clauses than Ca0 and Cb0, or if
+ %% Cb0 is guaranteed to match.
+ TwoClauses = Cs =:= [] orelse
+ case Cb0 of
+ #c_clause{pats=[#c_var{}],guard=#c_literal{val=true}} -> true;
+ _ -> false
+ end,
+ case {TwoClauses,is_failing_clause(Ca0),is_failing_clause(Cb0)} of
+ {true,false,true} ->
+ %% let <Lvars> = case <Case-expr> of
+ %% <Cvars> -> <Clause-body>;
+ %% <OtherCvars> -> erlang:error(...)
+ %% end
+ %% in <Let-body>
+ %%
+ %% ==>
+ %%
+ %% case <Case-expr> of
+ %% <Cvars> ->
+ %% let <Lvars> = <Clause-body>
+ %% in <Let-body>;
+ %% <OtherCvars> -> erlang:error(...)
+ %% end
+
+ Cexpr = body(Cexpr0, Sub0),
+ CaVars0 = Ca0#c_clause.pats,
+ G0 = Ca0#c_clause.guard,
+ B0 = Ca0#c_clause.body,
+ ScopeSub0 = sub_subst_scope(Sub0#sub{t=[]}),
+ {CaVars,ScopeSub} = pattern_list(CaVars0, ScopeSub0),
+ G = guard(G0, ScopeSub),
+
+ B1 = body(B0, ScopeSub),
+
+ {Lvs,B2,Sub1} = let_substs(Lvs0, B1, Sub0),
+ Sub2 = Sub1#sub{s=gb_sets:union(ScopeSub#sub.s,
+ Sub1#sub.s)},
+ Lbody = body(Lbody0, Sub2),
+ B = Let#c_let{vars=Lvs,arg=core_lib:make_values(B2),body=Lbody},
+
+ Ca = Ca0#c_clause{pats=CaVars,guard=G,body=B},
+ Cb = clause(Cb0, Cexpr, value, Sub0),
+ Case#c_case{arg=Cexpr,clauses=[Ca,Cb]};
+ {_,_,_} -> impossible
+ end;
+move_let_into_expr(_Let, _Expr, _Sub) -> impossible.
+
+is_failing_clause(#c_clause{body=B}) ->
+ will_fail(B).
+
+scope_add(Vs, #sub{s=Scope0}=Sub) ->
+ Scope = foldl(fun(V, S) when is_integer(V); is_atom(V) ->
+ gb_sets:add(V, S)
+ end, Scope0, Vs),
+ Sub#sub{s=Scope}.
+
+%% opt_simple_let(#c_let{}, Context, Sub) -> CoreTerm
+%% Optimize a let construct that does not contain any lets in
+%% in its argument.
+
+opt_simple_let(#c_let{arg=Arg0}=Let, Ctxt, Sub0) ->
+ Arg = body(Arg0, value, Sub0), %This is a body
+ case will_fail(Arg) of
+ true -> Arg;
+ false -> opt_simple_let_1(Let, Arg, Ctxt, Sub0)
+ end.
+
+opt_simple_let_1(#c_let{vars=Vs0,body=B0}=Let, Arg0, Ctxt, Sub0) ->
+ %% Optimise let and add new substitutions.
+ {Vs,Args,Sub1} = let_substs(Vs0, Arg0, Sub0),
+ BodySub = case {Vs,Args} of
+ {[V],[A]} ->
+ case is_bool_expr(A, Sub0) of
+ true ->
+ update_types(V, [#c_literal{val=true}], Sub1);
+ false ->
+ Sub1
+ end;
+ {_,_} -> Sub1
+ end,
+ B = body(B0, Ctxt, BodySub),
+ Arg = core_lib:make_values(Args),
+ opt_simple_let_2(Let, Vs, Arg, B, Ctxt, Sub1).
+
+opt_simple_let_2(Let0, Vs0, Arg0, Body0, effect, Sub) ->
+ case {Vs0,Arg0,Body0} of
+ {[],#c_values{es=[]},Body} ->
+ %% No variables left (because of substitutions).
+ Body;
+ {[_|_],Arg,#c_literal{}} ->
+ %% The body is a literal. That means that we can ignore
+ %% it and that the return value is Arg revisited in
+ %% effect context.
+ body(Arg, effect, sub_new_preserve_types(Sub));
+ {Vs,Arg,Body} ->
+ %% Since we are in effect context, there is a chance
+ %% that the body no longer references the variables.
+ %% In that case we can construct a sequence and visit
+ %% that in effect context:
+ %% let <Var> = Arg in BodyWithoutVar ==> seq Arg BodyWithoutVar
+ case is_any_var_used(Vs, Body) of
+ false ->
+ expr(#c_seq{arg=Arg,body=Body}, effect, sub_new_preserve_types(Sub));
+ true ->
+ Let = Let0#c_let{vars=Vs,arg=Arg,body=Body},
+ opt_case_in_let_arg(opt_case_in_let(Let), effect, Sub)
+ end
+ end;
+opt_simple_let_2(Let, Vs0, Arg0, Body, value, Sub) ->
+ case {Vs0,Arg0,Body} of
+ {[#c_var{name=N1}],Arg,#c_var{name=N2}} ->
+ case N1 =:= N2 of
+ true ->
+ %% let <Var> = Arg in <Var> ==> Arg
+ Arg;
+ false ->
+ %% let <Var> = Arg in <OtherVar> ==> seq Arg OtherVar
+ expr(#c_seq{arg=Arg,body=Body}, value, sub_new_preserve_types(Sub))
+ end;
+ {[],#c_values{es=[]},_} ->
+ %% No variables left.
+ Body;
+ {_,Arg,#c_literal{}} ->
+ %% The variable is not used in the body. The argument
+ %% can be evaluated in effect context to simplify it.
+ expr(#c_seq{arg=Arg,body=Body}, value, sub_new_preserve_types(Sub));
+ {Vs,Arg,Body} ->
+ opt_case_in_let_arg(
+ opt_case_in_let(Let#c_let{vars=Vs,arg=Arg,body=Body}),
+ value, Sub)
+ end.
+
+%% In guards only, rewrite a case in a let argument like
+%%
+%% let <Var> = case <> of
+%% <> when AnyGuard -> Literal1;
+%% <> when AnyGuard -> Literal2
+%% end
+%% in LetBody
+%%
+%% to
+%%
+%% case <> of
+%% <> when AnyGuard ->
+%% let <Var> = Literal1 in LetBody
+%% <> when 'true' ->
+%% let <Var> = Literal2 in LetBody
+%% end
+%%
+%% In the worst case, the size of the code could increase.
+%% In practice, though, substituting the literals into
+%% LetBody and doing constant folding will decrease the code
+%% size. (Doing this transformation outside of guards could
+%% lead to a substantational increase in code size.)
+%%
+opt_case_in_let_arg(#c_let{arg=#c_case{}=Case}=Let, Ctxt,
+ #sub{in_guard=true}=Sub) ->
+ opt_case_in_let_arg_1(Let, Case, Ctxt, Sub);
+opt_case_in_let_arg(Let, _, _) -> Let.
+
+opt_case_in_let_arg_1(Let0, #c_case{arg=#c_values{es=[]},
+ clauses=Cs}=Case0, Ctxt, Sub) ->
+ Let = mark_compiler_generated(Let0),
+ case Cs of
+ [#c_clause{body=#c_literal{}=BodyA}=Ca0,
+ #c_clause{body=#c_literal{}=BodyB}=Cb0] ->
+ Ca = Ca0#c_clause{body=Let#c_let{arg=BodyA}},
+ Cb = Cb0#c_clause{body=Let#c_let{arg=BodyB}},
+ Case = Case0#c_case{clauses=[Ca,Cb]},
+ expr(Case, Ctxt, sub_new_preserve_types(Sub));
+ _ -> Let
+ end;
+opt_case_in_let_arg_1(Let, _, _, _) -> Let.
+
+is_any_var_used([#c_var{name=V}|Vs], Expr) ->
+ case core_lib:is_var_used(V, Expr) of
+ false -> is_any_var_used(Vs, Expr);
+ true -> true
+ end;
+is_any_var_used([], _) -> false.
+
+is_boolean_type(V, #sub{t=Tdb}) ->
+ case orddict:find(V, Tdb) of
+ {ok,bool} -> true;
+ _ -> false
+ end.
+
+%% update_types(Expr, Pattern, Sub) -> Sub'
+%% Update the type database.
+update_types(Expr, Pat, #sub{t=Tdb0}=Sub) ->
+ Tdb = update_types_1(Expr, Pat, Tdb0),
+ Sub#sub{t=Tdb}.
+
+update_types_1(#c_var{name=V,anno=Anno}, Pat, Types) ->
+ case member(reuse_for_context, Anno) of
+ true ->
+ %% If a variable has been marked for reuse of binary context,
+ %% optimizations based on type information are unsafe.
+ kill_types(V, Types);
+ false ->
+ update_types_2(V, Pat, Types)
+ end;
+update_types_1(_, _, Types) -> Types.
+
+update_types_2(V, [#c_tuple{}=P], Types) ->
+ orddict:store(V, P, Types);
+update_types_2(V, [#c_literal{val=Bool}], Types) when is_boolean(Bool) ->
+ orddict:store(V, bool, Types);
+update_types_2(_, _, Types) -> Types.
+
+%% kill_types(V, Tdb) -> Tdb'
+%% Kill any entries that references the variable,
+%% either in the key or in the value.
+
+kill_types(V, [{V,_}|Tdb]) ->
+ kill_types(V, Tdb);
+kill_types(V, [{_,#c_tuple{}=Tuple}=Entry|Tdb]) ->
+ case core_lib:is_var_used(V, Tuple) of
+ false -> [Entry|kill_types(V, Tdb)];
+ true -> kill_types(V, Tdb)
+ end;
+kill_types(V, [{_,Atom}=Entry|Tdb]) when is_atom(Atom) ->
+ [Entry|kill_types(V, Tdb)];
+kill_types(_, []) -> [].
+
+%% copy_type(DestVar, SrcVar, Tdb) -> Tdb'
+%% If the SrcVar has a type, assign it to DestVar.
+%%
+copy_type(V, #c_var{name=Src}, Tdb) ->
+ case orddict:find(Src, Tdb) of
+ {ok,Type} -> orddict:store(V, Type, Tdb);
+ error -> Tdb
+ end;
+copy_type(_, _, Tdb) -> Tdb.
+
+%% The atom `ok', is widely used in Erlang for "void" values.
+
+void() -> #c_literal{val=ok}.
+
+%%%
+%%% Annotate bit syntax matching to faciliate optimization in further passes.
+%%%
+
+bsm_an(#c_case{arg=#c_var{}=V}=Case) ->
+ bsm_an_1([V], Case);
+bsm_an(#c_case{arg=#c_values{es=Es}}=Case) ->
+ bsm_an_1(Es, Case);
+bsm_an(Other) -> Other.
+
+bsm_an_1(Vs, #c_case{clauses=Cs}=Case) ->
+ case bsm_leftmost(Cs) of
+ none -> Case;
+ Pos -> bsm_an_2(Vs, Cs, Case, Pos)
+ end.
+
+bsm_an_2(Vs, Cs, Case, Pos) ->
+ case bsm_nonempty(Cs, Pos) of
+ true -> bsm_an_3(Vs, Cs, Case, Pos);
+ false -> Case
+ end.
+
+bsm_an_3(Vs, Cs, Case, Pos) ->
+ try
+ bsm_ensure_no_partition(Cs, Pos),
+ bsm_do_an(Vs, Pos, Cs, Case)
+ catch
+ throw:{problem,Where,What} ->
+ add_bin_opt_info(Where, What),
+ Case
+ end.
+
+bsm_do_an(Vs0, Pos, Cs0, Case) ->
+ case nth(Pos, Vs0) of
+ #c_var{name=Vname}=V0 ->
+ Cs = bsm_do_an_var(Vname, Pos, Cs0, []),
+ V = bsm_annotate_for_reuse(V0),
+ Bef = lists:sublist(Vs0, Pos-1),
+ Aft = lists:nthtail(Pos, Vs0),
+ case Bef ++ [V|Aft] of
+ [_] ->
+ Case#c_case{arg=V,clauses=Cs};
+ Vs ->
+ Case#c_case{arg=#c_values{es=Vs},clauses=Cs}
+ end;
+ _ ->
+ Case
+ end.
+
+bsm_do_an_var(V, S, [#c_clause{pats=Ps,guard=G,body=B0}=C0|Cs], Acc) ->
+ case nth(S, Ps) of
+ #c_var{name=VarName} ->
+ case core_lib:is_var_used(V, G) of
+ true -> bsm_problem(C0, orig_bin_var_used_in_guard);
+ false -> ok
+ end,
+ case core_lib:is_var_used(VarName, G) of
+ true -> bsm_problem(C0, bin_var_used_in_guard);
+ false -> ok
+ end,
+ B1 = bsm_maybe_ctx_to_binary(VarName, B0),
+ B = bsm_maybe_ctx_to_binary(V, B1),
+ C = C0#c_clause{body=B},
+ bsm_do_an_var(V, S, Cs, [C|Acc]);
+ #c_alias{}=P ->
+ case bsm_could_match_binary(P) of
+ false ->
+ bsm_do_an_var(V, S, Cs, [C0|Acc]);
+ true ->
+ bsm_problem(C0, bin_opt_alias)
+ end;
+ P ->
+ case bsm_could_match_binary(P) andalso bsm_is_var_used(V, G, B0) of
+ false ->
+ bsm_do_an_var(V, S, Cs, [C0|Acc]);
+ true ->
+ bsm_problem(C0, bin_var_used)
+ end
+ end;
+bsm_do_an_var(_, _, [], Acc) -> reverse(Acc).
+
+bsm_annotate_for_reuse(#c_var{anno=Anno}=Var) ->
+ case member(reuse_for_context, Anno) of
+ false -> Var#c_var{anno=[reuse_for_context|Anno]};
+ true -> Var
+ end.
+
+bsm_is_var_used(V, G, B) ->
+ core_lib:is_var_used(V, G) orelse core_lib:is_var_used(V, B).
+
+bsm_maybe_ctx_to_binary(V, B) ->
+ case core_lib:is_var_used(V, B) andalso not previous_ctx_to_binary(V, B) of
+ false ->
+ B;
+ true ->
+ #c_seq{arg=#c_primop{name=#c_literal{val=bs_context_to_binary},
+ args=[#c_var{name=V}]},
+ body=B}
+ end.
+
+previous_ctx_to_binary(V, #c_seq{arg=#c_primop{name=Name,args=As}}) ->
+ case {Name,As} of
+ {#c_literal{val=bs_context_to_binary},[#c_var{name=V}]} ->
+ true;
+ {_,_} ->
+ false
+ end;
+previous_ctx_to_binary(_, _) -> false.
+
+%% bsm_leftmost(Cs) -> none | ArgumentNumber
+%% Find the leftmost argument that does binary matching. Return
+%% the number of the argument (1-N).
+
+bsm_leftmost(Cs) ->
+ bsm_leftmost_1(Cs, none).
+
+bsm_leftmost_1([#c_clause{pats=Ps}|Cs], Pos) ->
+ bsm_leftmost_2(Ps, Cs, 1, Pos);
+bsm_leftmost_1([], Pos) -> Pos.
+
+bsm_leftmost_2(_, Cs, Pos, Pos) ->
+ bsm_leftmost_1(Cs, Pos);
+bsm_leftmost_2([#c_binary{}|_], Cs, N, _) ->
+ bsm_leftmost_1(Cs, N);
+bsm_leftmost_2([_|Ps], Cs, N, Pos) ->
+ bsm_leftmost_2(Ps, Cs, N+1, Pos);
+bsm_leftmost_2([], Cs, _, Pos) ->
+ bsm_leftmost_1(Cs, Pos).
+
+%% bsm_notempty(Cs, Pos) -> true|false
+%% Check if at least one of the clauses matches a non-empty
+%% binary in the given argumet position.
+%%
+bsm_nonempty([#c_clause{pats=Ps}|Cs], Pos) ->
+ case nth(Pos, Ps) of
+ #c_binary{segments=[_|_]} ->
+ true;
+ _ ->
+ bsm_nonempty(Cs, Pos)
+ end;
+bsm_nonempty([], _ ) -> false.
+
+%% bsm_ensure_no_partition(Cs, Pos) -> ok (exception if problem)
+%% We must make sure that binary matching is not partitioned between
+%% variables like this:
+%% foo(<<...>>) -> ...
+%% foo(Var) when ... -> ...
+%% foo(<<...>>) ->
+%% If there is such partition, we are not allowed to reuse the binary variable
+%% for the match context. Also, arguments to the left of the argument that
+%% is matched against a binary, are only allowed to be simple variables, not
+%% used in guards. The reason is that we must know that the binary is only
+%% matched in one place.
+
+bsm_ensure_no_partition(Cs, Pos) ->
+ bsm_ensure_no_partition_1(Cs, Pos, before).
+
+%% Loop through each clause.
+bsm_ensure_no_partition_1([#c_clause{pats=Ps,guard=G}|Cs], Pos, State0) ->
+ State = bsm_ensure_no_partition_2(Ps, Pos, G, simple_vars, State0),
+ bsm_ensure_no_partition_1(Cs, Pos, State);
+bsm_ensure_no_partition_1([], _, _) -> ok.
+
+%% Loop through each pattern for this clause.
+bsm_ensure_no_partition_2([#c_binary{}=Where|_], 1, _, Vstate, State) ->
+ case State of
+ before when Vstate =:= simple_vars -> within;
+ before -> bsm_problem(Where, Vstate);
+ within when Vstate =:= simple_vars -> within;
+ within -> bsm_problem(Where, Vstate);
+ 'after' -> bsm_problem(Where, bin_partition)
+ end;
+bsm_ensure_no_partition_2([#c_alias{}=Alias|_], 1, N, Vstate, State) ->
+ %% Retrieve the real pattern that the alias refers to and check that.
+ P = bsm_real_pattern(Alias),
+ bsm_ensure_no_partition_2([P], 1, N, Vstate, State);
+bsm_ensure_no_partition_2([_|_], 1, _, _Vstate, before=State) ->
+ %% No binary matching yet - therefore no partition.
+ State;
+bsm_ensure_no_partition_2([P|_], 1, _, Vstate, State) ->
+ case bsm_could_match_binary(P) of
+ false ->
+ %% If clauses can be freely arranged (Vstate =:= simple_vars),
+ %% a clause that cannot match a binary will not partition the clause.
+ %% Example:
+ %%
+ %% a(Var, <<>>) -> ...
+ %% a(Var, []) -> ...
+ %% a(Var, <<B>>) -> ...
+ %%
+ %% But if the clauses can't be freely rearranged, as in
+ %%
+ %% b(Var, <<>>) -> ...
+ %% b(1, 2) -> ...
+ %%
+ %% we do have a problem.
+ %%
+ case Vstate of
+ simple_vars -> State;
+ _ -> bsm_problem(P, Vstate)
+ end;
+ true ->
+ %% The pattern P *may* match a binary, so we must update the state.
+ %% (P must be a variable.)
+ case State of
+ within -> 'after';
+ 'after' -> 'after'
+ end
+ end;
+bsm_ensure_no_partition_2([#c_var{name=V}|Ps], N, G, Vstate, S) ->
+ case core_lib:is_var_used(V, G) of
+ false ->
+ bsm_ensure_no_partition_2(Ps, N-1, G, Vstate, S);
+ true ->
+ bsm_ensure_no_partition_2(Ps, N-1, G, bin_left_var_used_in_guard, S)
+ end;
+bsm_ensure_no_partition_2([_|Ps], N, G, _, S) ->
+ bsm_ensure_no_partition_2(Ps, N-1, G, bin_argument_order, S).
+
+bsm_could_match_binary(#c_alias{pat=P}) -> bsm_could_match_binary(P);
+bsm_could_match_binary(#c_cons{}) -> false;
+bsm_could_match_binary(#c_tuple{}) -> false;
+bsm_could_match_binary(#c_literal{val=Lit}) -> is_bitstring(Lit);
+bsm_could_match_binary(_) -> true.
+
+bsm_real_pattern(#c_alias{pat=P}) -> bsm_real_pattern(P);
+bsm_real_pattern(P) -> P.
+
+bsm_problem(Where, What) ->
+ throw({problem,Where,What}).
+
+%%%
+%%% Handling of warnings.
+%%%
+
+mark_compiler_generated(Term) ->
+ cerl_trees:map(fun mark_compiler_generated_1/1, Term).
+
+mark_compiler_generated_1(#c_call{anno=Anno}=Term) ->
+ Term#c_call{anno=[compiler_generated|Anno--[compiler_generated]]};
+mark_compiler_generated_1(Term) -> Term.
+
+init_warnings() ->
+ put({?MODULE,warnings}, []).
+
+add_bin_opt_info(Core, Term) ->
+ case get(bin_opt_info) of
+ true -> add_warning(Core, Term);
+ false -> ok
+ end.
+
+add_warning(Core, Term) ->
+ Anno = core_lib:get_anno(Core),
+ case lists:member(compiler_generated, Anno) of
+ true -> ok;
+ false ->
+ case get_line(Anno) of
+ Line when Line >= 0 -> %Must be positive.
+ File = get_file(Anno),
+ Key = {?MODULE,warnings},
+ case get(Key) of
+ [{File,[{Line,?MODULE,Term}]}|_] ->
+ ok; %We already have
+ %an identical warning.
+ Ws ->
+ put(Key, [{File,[{Line,?MODULE,Term}]}|Ws])
+ end;
+ _ -> ok %Compiler-generated code.
+ end
+ end.
+
+get_line([Line|_]) when is_integer(Line) -> Line;
+get_line([_|T]) -> get_line(T);
+get_line([]) -> none.
+
+get_file([{file,File}|_]) -> File;
+get_file([_|T]) -> get_file(T);
+get_file([]) -> "no_file". % should not happen
+
+is_compiler_generated(Core) ->
+ Anno = core_lib:get_anno(Core),
+ case lists:member(compiler_generated, Anno) of
+ true -> true;
+ false ->
+ case get_line(Anno) of
+ Line when Line >= 0 -> false;
+ _ -> true
+ end
+ end.
+
+get_warnings() ->
+ ordsets:from_list((erase({?MODULE,warnings}))).
+
+-type error() :: 'bad_unicode' | 'bin_argument_order'
+ | 'bin_left_var_used_in_guard' | 'bin_opt_alias'
+ | 'bin_partition' | 'bin_var_used' | 'bin_var_used_in_guard'
+ | 'embedded_binary_size' | 'nomatch_clause_type'
+ | 'nomatch_guard' | 'nomatch_shadow' | 'no_clause_match'
+ | 'orig_bin_var_used_in_guard' | 'result_ignored'
+ | 'useless_building'
+ | {'eval_failure', term()}
+ | {'no_effect', {'erlang',atom(),arity()}}
+ | {'nomatch_shadow', integer()}
+ | {'embedded_unit', _, _}.
+
+-spec format_error(error()) -> nonempty_string().
+
+format_error({eval_failure,Reason}) ->
+ flatten(io_lib:format("this expression will fail with a '~p' exception", [Reason]));
+format_error(embedded_binary_size) ->
+ "binary construction will fail with a 'badarg' exception "
+ "(field size for binary/bitstring greater than actual size)";
+format_error({embedded_unit,Unit,Size}) ->
+ M = io_lib:format("binary construction will fail with a 'badarg' exception "
+ "(size ~p cannot be evenly divided by unit ~p)", [Size,Unit]),
+ flatten(M);
+format_error(bad_unicode) ->
+ "binary construction will fail with a 'badarg' exception "
+ "(invalid Unicode code point in a utf8/utf16/utf32 segment)";
+format_error({nomatch_shadow,Line}) ->
+ M = io_lib:format("this clause cannot match because a previous clause at line ~p "
+ "always matches", [Line]),
+ flatten(M);
+format_error(nomatch_shadow) ->
+ "this clause cannot match because a previous clause always matches";
+format_error(nomatch_guard) ->
+ "the guard for this clause evaluates to 'false'";
+format_error(no_clause_match) ->
+ "no clause will ever match";
+format_error(nomatch_clause_type) ->
+ "this clause cannot match because of different types/sizes";
+format_error({no_effect,{erlang,F,A}}) ->
+ {Fmt,Args} = case erl_internal:comp_op(F, A) of
+ true ->
+ {"use of operator ~p has no effect",[F]};
+ false ->
+ case erl_internal:bif(F, A) of
+ false ->
+ {"the call to erlang:~p/~p has no effect",[F,A]};
+ true ->
+ {"the call to ~p/~p has no effect",[F,A]}
+ end
+ end,
+ flatten(io_lib:format(Fmt, Args));
+format_error(result_ignored) ->
+ "the result of the expression is ignored";
+format_error(useless_building) ->
+ "a term is constructed, but never used";
+format_error(bin_opt_alias) ->
+ "INFO: the '=' operator will prevent delayed sub binary optimization";
+format_error(bin_partition) ->
+ "INFO: non-consecutive clauses that match binaries "
+ "will prevent delayed sub binary optimization";
+format_error(bin_left_var_used_in_guard) ->
+ "INFO: a variable to the left of the binary pattern is used in a guard; "
+ "will prevent delayed sub binary optimization";
+format_error(bin_argument_order) ->
+ "INFO: matching anything else but a plain variable to the left of "
+ "binary pattern will prevent delayed sub binary optimization; "
+ "SUGGEST changing argument order";
+format_error(bin_var_used) ->
+ "INFO: using a matched out sub binary will prevent "
+ "delayed sub binary optimization";
+format_error(orig_bin_var_used_in_guard) ->
+ "INFO: using the original binary variable in a guard will prevent "
+ "delayed sub binary optimization";
+format_error(bin_var_used_in_guard) ->
+ "INFO: using a matched out sub binary in a guard will prevent "
+ "delayed sub binary optimization".
+
+-ifdef(DEBUG).
+%% In order for simplify_let/2 to work correctly, the list of
+%% in-scope variables must always be a superset of the free variables
+%% in the current expression (otherwise we might fail to rename a variable
+%% when needed and get a name capture bug).
+
+verify_scope(E, #sub{s=Scope}) ->
+ Free0 = cerl_trees:free_variables(E),
+ Free = [V || V <- Free0, not is_tuple(V)], %Ignore function names.
+ case ordsets:is_subset(Free, gb_sets:to_list(Scope)) of
+ true -> true;
+ false ->
+ io:format("~p\n", [E]),
+ io:format("~p\n", [Free]),
+ io:format("~p\n", [gb_sets:to_list(Scope)]),
+ false
+ end.
+-endif.
diff --git a/lib/compiler/src/sys_core_inline.erl b/lib/compiler/src/sys_core_inline.erl
new file mode 100644
index 0000000000..c8d75b80c6
--- /dev/null
+++ b/lib/compiler/src/sys_core_inline.erl
@@ -0,0 +1,212 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2000-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%
+%%
+%% Purpose : Function inlining optimisation for Core.
+
+%% This simple function inliner works in two stages:
+%%
+%% 1. First it extracts all the inlineable functions, either given
+%% explicitly or of light enough weight, and inlines them with
+%% themselves. This inlining only uses lighter functions to save
+%% recursion and a real code explosion.
+%%
+%% 2. Run through the rest of the functions inlining all calls to
+%% inlineable functions.
+%%
+%% The weight function is VERY simple, we count the number of nodes in
+%% the function body. We would like to remove non-exported,
+%% inlineable functions but this is not trivial as they may be
+%% (mutually) recursive.
+%%
+%% This module will catch many access functions and allow code to use
+%% extra functions for clarity which are then explicitly inlined for
+%% speed with a compile attribute. See the example below.
+%%
+%% It is not clear that inlining will give you very much.
+
+-module(sys_core_inline).
+
+%%-compile({inline,{match_fail_fun,0}}).
+
+-export([module/2]).
+
+-import(lists, [member/2,map/2,foldl/3,mapfoldl/3]).
+
+-include("core_parse.hrl").
+
+%% Inline status.
+-record(inline, {exports=[],thresh=0,inline=[]}).
+
+%% General function info.
+-record(fstat, {func :: atom(), %Function name
+ arity :: byte(), % arity
+ def, %Original definition
+ weight=0, %Weight
+ inline=false :: boolean(), %Inline func flag
+ modified=false :: boolean()}). %Mod flag
+
+%% Inlineable function info.
+-record(ifun, {func :: atom(), %Function name
+ arity :: byte(), % arity
+ vars, %Fun vars
+ body, % body
+ weight}). %Weight
+
+-spec module(#c_module{}, [_]) -> {'ok', #c_module{}}.
+
+module(#c_module{exports=Es,defs=Ds0}=Mod, Opts) ->
+ case inline_option(Opts) of
+ {Thresh,Fs} when is_integer(Thresh), Thresh > 0; Fs =/= [] ->
+ case proplists:get_bool(verbose, Opts) of
+ true ->
+ io:format("Old inliner: threshold=~p functions=~p\n",
+ [Thresh,Fs]);
+ false -> ok
+ end,
+ Ds1 = inline(Ds0, #inline{exports=Es,thresh=Thresh,inline=Fs}),
+ {ok,Mod#c_module{defs=Ds1}};
+ _Other -> {ok,Mod}
+ end.
+
+inline_option(Opts) ->
+ foldl(fun ({inline,{_,_}=Val}, {T,Fs}) ->
+ {T,[Val|Fs]};
+ ({inline,Val}, {T,Fs}) when is_list(Val) ->
+ {T,Val ++ Fs};
+ ({inline,Val}, {_,Fs}) when is_integer(Val) ->
+ {Val,Fs};
+ (_Opt, {_,_}=Def) -> Def
+ end, {0,[]}, Opts).
+
+%% inline([Func], Stat) -> [Func].
+%% Here we do all the work.
+
+inline(Fs0, St0) ->
+ %% Generate list of augmented functions.
+ Fs1 = map(fun ({#c_var{name={F,A}},#c_fun{body=B}}=Def) ->
+ Weight = cerl_trees:fold(fun weight_func/2, 0, B),
+ #fstat{func=F,arity=A,def=Def,weight=Weight}
+ end, Fs0),
+ %% Get inlineable functions, and inline them with themselves.
+ {Fs2,Is0} = mapfoldl(fun (Fst, Ifs) ->
+ case is_inlineable(Fst, St0#inline.thresh,
+ St0#inline.inline) of
+ true ->
+ {_,Ffun} = Fst#fstat.def,
+ If = #ifun{func=Fst#fstat.func,
+ arity=Fst#fstat.arity,
+ vars=Ffun#c_fun.vars,
+ body=Ffun#c_fun.body,
+ weight=Fst#fstat.weight},
+ {Fst#fstat{inline=true},[If|Ifs]};
+ false -> {Fst,Ifs}
+ end
+ end, [], Fs1),
+ Is1 = map(fun (#ifun{body=B}=If) ->
+ If#ifun{body=cerl_trees:map(match_fail_fun(), B)}
+ end, Is0),
+ Is2 = [inline_inline(If, Is1) || If <- Is1],
+ %% We would like to remove inlined, non-exported functions here,
+ %% but this can be difficult as they may be recursive.
+ %% Use fixed inline functions on all functions.
+ Fs = [inline_func(F, Is2) || F <- Fs2],
+ %% Regenerate module body.
+ [Def || #fstat{def=Def} <- Fs].
+
+%% is_inlineable(Fstat, Thresh, [Inline]) -> boolean().
+
+is_inlineable(#fstat{weight=W}, Thresh, _Ofs) when W =< Thresh -> true;
+is_inlineable(#fstat{func=F,arity=A}, _Thresh, Ofs) ->
+ member({F,A}, Ofs).
+
+%% inline_inline(Ifun, [Inline]) -> Ifun.
+%% Try to inline calls in an inlineable function. To save us from a
+%% to great code explosion we only inline functions "smaller" than
+%% ourselves.
+
+inline_inline(#ifun{body=B,weight=Iw}=If, Is) ->
+ Inline = fun (#c_apply{op=#c_var{name={F,A}},args=As}=Call) ->
+ case find_inl(F, A, Is) of
+ #ifun{vars=Vs,body=B2,weight=W} when W < Iw ->
+ #c_let{vars=Vs,
+ arg=core_lib:make_values(As),
+ body=kill_id_anns(B2)};
+ _Other -> Call
+ end;
+ (Core) -> Core
+ end,
+ If#ifun{body=cerl_trees:map(Inline, B)}.
+
+%% inline_func(Fstat, [Inline]) -> Fstat.
+%% Try to inline calls in a normal function. Here we inline anything
+%% in the inline list.
+
+inline_func(#fstat{def={Name,F0}}=Fstat, Is) ->
+ Inline = fun (#c_apply{op=#c_var{name={F,A}},args=As}=Call, Mod) ->
+ case find_inl(F, A, Is) of
+ #ifun{vars=Vs,body=B} ->
+ {#c_let{vars=Vs,
+ arg=core_lib:make_values(As),
+ body=kill_id_anns(B)},
+ true}; %Have modified
+ _Other -> {Call,Mod}
+ end;
+ (Core, Mod) -> {Core,Mod}
+ end,
+ {F1,Mod} = cerl_trees:mapfold(Inline, false, F0),
+ Fstat#fstat{def={Name,F1},modified=Mod}.
+
+weight_func(_Core, Acc) -> Acc + 1.
+
+%% match_fail_fun() -> fun/1.
+%% Return a function to use with map to fix inlineable functions
+%% function_clause match_fail (if they have one).
+
+match_fail_fun() ->
+ fun (#c_primop{name=#c_literal{val=match_fail},
+ args=[#c_tuple{es=[#c_literal{val=function_clause}|As]}]}=P) ->
+ Fail = #c_tuple{es=[#c_literal{val=case_clause},
+ #c_tuple{es=As}]},
+ P#c_primop{args=[Fail]};
+ (Other) -> Other
+ end.
+
+%% find_inl(Func, Arity, [Inline]) -> #ifun{} | no.
+
+find_inl(F, A, [#ifun{func=F,arity=A}=If|_]) -> If;
+find_inl(F, A, [_|Is]) -> find_inl(F, A, Is);
+find_inl(_, _, []) -> no.
+
+%% kill_id_anns(Body) -> Body'
+
+kill_id_anns(Body) ->
+ cerl_trees:map(fun(#c_fun{anno=A0}=CFun) ->
+ A = kill_id_anns_1(A0),
+ CFun#c_fun{anno=A};
+ (Expr) ->
+ %% Mark everything as compiler generated to suppress
+ %% bogus warnings.
+ A = [compiler_generated|core_lib:get_anno(Expr)],
+ core_lib:set_anno(Expr, A)
+ end, Body).
+
+kill_id_anns_1([{'id',_}|As]) ->
+ kill_id_anns_1(As);
+kill_id_anns_1([A|As]) ->
+ [A|kill_id_anns_1(As)];
+kill_id_anns_1([]) -> [].
diff --git a/lib/compiler/src/sys_expand_pmod.erl b/lib/compiler/src/sys_expand_pmod.erl
new file mode 100644
index 0000000000..dbd5c1ec2f
--- /dev/null
+++ b/lib/compiler/src/sys_expand_pmod.erl
@@ -0,0 +1,423 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2004-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+%%
+-module(sys_expand_pmod).
+
+%% Expand function definition forms of parameterized module. We assume
+%% all record definitions, imports, queries, etc., have been expanded
+%% away. Any calls on the form 'foo(...)' must be calls to local
+%% functions. Auto-generated functions (module_info,...) have not yet
+%% been added to the function definitions, but are listed in 'defined'
+%% and 'exports'. The automatic 'new/N' function is neither added to the
+%% definitions nor to the 'exports'/'defines' lists yet.
+
+-export([forms/4]).
+
+-record(pmod, {parameters, exports, defined, predef}).
+
+%% TODO: more abstract handling of predefined/static functions.
+
+forms(Fs0, Ps, Es0, Ds0) ->
+ PreDef = [{module_info,0},{module_info,1}],
+ forms(Fs0, Ps, Es0, Ds0, PreDef).
+
+forms(Fs0, Ps, Es0, Ds0, PreDef) ->
+ St0 = #pmod{parameters=Ps,exports=Es0,defined=Ds0, predef=PreDef},
+ {Fs1, St1} = forms(Fs0, St0),
+ Es1 = update_function_names(Es0, St1),
+ Ds1 = update_function_names(Ds0, St1),
+ Fs2 = update_forms(Fs1, St1),
+ {Fs2,Es1,Ds1}.
+
+%% This is extremely simplistic for now; all functions get an extra
+%% parameter, whether they need it or not, except for static functions.
+
+update_function_names(Es, St) ->
+ [update_function_name(E, St) || E <- Es].
+
+update_function_name(E={F,A}, St) when F =/= new ->
+ case ordsets:is_element(E, St#pmod.predef) of
+ true -> E;
+ false -> {F, A + 1}
+ end;
+update_function_name(E, _St) ->
+ E.
+
+update_forms([{function,L,N,A,Cs}|Fs],St) when N =/= new ->
+ [{function,L,N,A+1,Cs}|update_forms(Fs,St)];
+update_forms([F|Fs],St) ->
+ [F|update_forms(Fs,St)];
+update_forms([],_St) ->
+ [].
+
+%% Process the program forms.
+
+forms([F0|Fs0],St0) ->
+ {F1,St1} = form(F0,St0),
+ {Fs1,St2} = forms(Fs0,St1),
+ {[F1|Fs1],St2};
+forms([], St0) ->
+ {[], St0}.
+
+%% Only function definitions are of interest here. State is not updated.
+form({function,Line,Name0,Arity0,Clauses0},St) when Name0 =/= new ->
+ {Name,Arity,Clauses} = function(Name0, Arity0, Clauses0, St),
+ {{function,Line,Name,Arity,Clauses},St};
+%% Pass anything else through
+form(F,St) -> {F,St}.
+
+function(Name, Arity, Clauses0, St) ->
+ Clauses1 = clauses(Clauses0,St),
+ {Name,Arity,Clauses1}.
+
+clauses([C|Cs],St) ->
+ {clause,L,H,G,B} = clause(C,St),
+ T = {tuple,L,[{var,L,V} || V <- ['_'|St#pmod.parameters]]},
+ [{clause,L,H++[{match,L,T,{var,L,'THIS'}}],G,B}|clauses(Cs,St)];
+clauses([],_St) -> [].
+
+clause({clause,Line,H0,G0,B0},St) ->
+ H1 = head(H0,St),
+ G1 = guard(G0,St),
+ B1 = exprs(B0,St),
+ {clause,Line,H1,G1,B1}.
+
+head(Ps,St) -> patterns(Ps,St).
+
+patterns([P0|Ps],St) ->
+ P1 = pattern(P0,St),
+ [P1|patterns(Ps,St)];
+patterns([],_St) -> [].
+
+string_to_conses([], _Line, Tail) ->
+ Tail;
+string_to_conses([E|Rest], Line, Tail) ->
+ {cons, Line, {integer, Line, E}, string_to_conses(Rest, Line, Tail)}.
+
+pattern({var,_Line,_V}=Var,_St) -> Var;
+pattern({match,Line,L0,R0},St) ->
+ L1 = pattern(L0,St),
+ R1 = pattern(R0,St),
+ {match,Line,L1,R1};
+pattern({integer,_Line,_I}=Integer,_St) -> Integer;
+pattern({char,_Line,_C}=Char,_St) -> Char;
+pattern({float,_Line,_F}=Float,_St) -> Float;
+pattern({atom,_Line,_A}=Atom,_St) -> Atom;
+pattern({string,_Line,_S}=String,_St) -> String;
+pattern({nil,_Line}=Nil,_St) -> Nil;
+pattern({cons,Line,H0,T0},St) ->
+ H1 = pattern(H0,St),
+ T1 = pattern(T0,St),
+ {cons,Line,H1,T1};
+pattern({tuple,Line,Ps0},St) ->
+ Ps1 = pattern_list(Ps0,St),
+ {tuple,Line,Ps1};
+pattern({bin,Line,Fs},St) ->
+ Fs2 = pattern_grp(Fs,St),
+ {bin,Line,Fs2};
+pattern({op,_Line,'++',{nil,_},R},St) ->
+ pattern(R,St);
+pattern({op,_Line,'++',{cons,Li,{char,_C2,_I}=Char,T},R},St) ->
+ pattern({cons,Li,Char,{op,Li,'++',T,R}},St);
+pattern({op,_Line,'++',{cons,Li,{integer,_L2,_I}=Integer,T},R},St) ->
+ pattern({cons,Li,Integer,{op,Li,'++',T,R}},St);
+pattern({op,_Line,'++',{string,Li,L},R},St) ->
+ pattern(string_to_conses(L, Li, R),St);
+pattern({op,_Line,_Op,_A}=Op4,_St) -> Op4;
+pattern({op,_Line,_Op,_L,_R}=Op5,_St) -> Op5.
+
+pattern_grp([{bin_element,L1,E1,S1,T1} | Fs],St) ->
+ S2 = case S1 of
+ default ->
+ default;
+ _ ->
+ expr(S1,St)
+ end,
+ T2 = case T1 of
+ default ->
+ default;
+ _ ->
+ bit_types(T1)
+ end,
+ [{bin_element,L1,expr(E1,St),S2,T2} | pattern_grp(Fs,St)];
+pattern_grp([],_St) ->
+ [].
+
+bit_types([]) ->
+ [];
+bit_types([Atom | Rest]) when is_atom(Atom) ->
+ [Atom | bit_types(Rest)];
+bit_types([{Atom, Integer} | Rest]) when is_atom(Atom), is_integer(Integer) ->
+ [{Atom, Integer} | bit_types(Rest)].
+
+pattern_list([P0|Ps],St) ->
+ P1 = pattern(P0,St),
+ [P1|pattern_list(Ps,St)];
+pattern_list([],_St) -> [].
+
+guard([G0|Gs],St) when is_list(G0) ->
+ [guard0(G0,St) | guard(Gs,St)];
+guard(L,St) ->
+ guard0(L,St).
+
+guard0([G0|Gs],St) ->
+ G1 = guard_test(G0,St),
+ [G1|guard0(Gs,St)];
+guard0([],_St) -> [].
+
+guard_test(Expr={call,Line,{atom,La,F},As0},St) ->
+ case erl_internal:type_test(F, length(As0)) of
+ true ->
+ As1 = gexpr_list(As0,St),
+ {call,Line,{atom,La,F},As1};
+ _ ->
+ gexpr(Expr,St)
+ end;
+guard_test(Any,St) ->
+ gexpr(Any,St).
+
+gexpr({var,_L,_V}=Var,_St) -> Var;
+% %% alternative implementation of accessing module parameters
+% case index(V,St#pmod.parameters) of
+% N when N > 0 ->
+% {call,L,{remote,L,{atom,L,erlang},{atom,L,element}},
+% [{integer,L,N+1},{var,L,'THIS'}]};
+% _ ->
+% Var
+% end;
+gexpr({integer,_Line,_I}=Integer,_St) -> Integer;
+gexpr({char,_Line,_C}=Char,_St) -> Char;
+gexpr({float,_Line,_F}=Float,_St) -> Float;
+gexpr({atom,_Line,_A}=Atom,_St) -> Atom;
+gexpr({string,_Line,_S}=String,_St) -> String;
+gexpr({nil,_Line}=Nil,_St) -> Nil;
+gexpr({cons,Line,H0,T0},St) ->
+ H1 = gexpr(H0,St),
+ T1 = gexpr(T0,St),
+ {cons,Line,H1,T1};
+gexpr({tuple,Line,Es0},St) ->
+ Es1 = gexpr_list(Es0,St),
+ {tuple,Line,Es1};
+gexpr({call,Line,{atom,_La,F}=Atom,As0},St) ->
+ true = erl_internal:guard_bif(F, length(As0)),
+ As1 = gexpr_list(As0,St),
+ {call,Line,Atom,As1};
+%% Pre-expansion generated calls to erlang:is_record/3 must also be handled
+gexpr({call,Line,{remote,La,{atom,Lb,erlang},{atom,Lc,is_record}},[_,_,_]=As0},St) ->
+ As1 = gexpr_list(As0,St),
+ {call,Line,{remote,La,{atom,Lb,erlang},{atom,Lc,is_record}},As1};
+%% Guard BIFs can be remote, but only in the module erlang...
+gexpr({call,Line,{remote,La,{atom,Lb,erlang},{atom,Lc,F}},As0},St) ->
+ A = length(As0),
+ true =
+ erl_internal:guard_bif(F, A) orelse erl_internal:arith_op(F, A) orelse
+ erl_internal:comp_op(F, A) orelse erl_internal:bool_op(F, A),
+ As1 = gexpr_list(As0,St),
+ {call,Line,{remote,La,{atom,Lb,erlang},{atom,Lc,F}},As1};
+%% Unfortunately, writing calls as {M,F}(...) is also allowed.
+gexpr({call,Line,{tuple,La,[{atom,Lb,erlang},{atom,Lc,F}]},As0},St) ->
+ A = length(As0),
+ true =
+ erl_internal:guard_bif(F, A) orelse erl_internal:arith_op(F, A) orelse
+ erl_internal:comp_op(F, A) orelse erl_internal:bool_op(F, A),
+ As1 = gexpr_list(As0,St),
+ {call,Line,{tuple,La,[{atom,Lb,erlang},{atom,Lc,F}]},As1};
+gexpr({bin,Line,Fs},St) ->
+ Fs2 = pattern_grp(Fs,St),
+ {bin,Line,Fs2};
+gexpr({op,Line,Op,A0},St) ->
+ true = erl_internal:arith_op(Op, 1) orelse erl_internal:bool_op(Op, 1),
+ A1 = gexpr(A0,St),
+ {op,Line,Op,A1};
+gexpr({op,Line,Op,L0,R0},St) ->
+ true =
+ Op =:= 'andalso' orelse Op =:= 'orelse' orelse
+ erl_internal:arith_op(Op, 2) orelse
+ erl_internal:bool_op(Op, 2) orelse erl_internal:comp_op(Op, 2),
+ L1 = gexpr(L0,St),
+ R1 = gexpr(R0,St),
+ {op,Line,Op,L1,R1}.
+
+gexpr_list([E0|Es],St) ->
+ E1 = gexpr(E0,St),
+ [E1|gexpr_list(Es,St)];
+gexpr_list([],_St) -> [].
+
+exprs([E0|Es],St) ->
+ E1 = expr(E0,St),
+ [E1|exprs(Es,St)];
+exprs([],_St) -> [].
+
+expr({var,_L,_V}=Var,_St) ->
+ Var;
+% case index(V,St#pmod.parameters) of
+% N when N > 0 ->
+% {call,L,{remote,L,{atom,L,erlang},{atom,L,element}},
+% [{integer,L,N+1},{var,L,'THIS'}]};
+% _ ->
+% Var
+% end;
+expr({integer,_Line,_I}=Integer,_St) -> Integer;
+expr({float,_Line,_F}=Float,_St) -> Float;
+expr({atom,_Line,_A}=Atom,_St) -> Atom;
+expr({string,_Line,_S}=String,_St) -> String;
+expr({char,_Line,_C}=Char,_St) -> Char;
+expr({nil,_Line}=Nil,_St) -> Nil;
+expr({cons,Line,H0,T0},St) ->
+ H1 = expr(H0,St),
+ T1 = expr(T0,St),
+ {cons,Line,H1,T1};
+expr({lc,Line,E0,Qs0},St) ->
+ Qs1 = lc_quals(Qs0,St),
+ E1 = expr(E0,St),
+ {lc,Line,E1,Qs1};
+expr({tuple,Line,Es0},St) ->
+ Es1 = expr_list(Es0,St),
+ {tuple,Line,Es1};
+expr({block,Line,Es0},St) ->
+ Es1 = exprs(Es0,St),
+ {block,Line,Es1};
+expr({'if',Line,Cs0},St) ->
+ Cs1 = icr_clauses(Cs0,St),
+ {'if',Line,Cs1};
+expr({'case',Line,E0,Cs0},St) ->
+ E1 = expr(E0,St),
+ Cs1 = icr_clauses(Cs0,St),
+ {'case',Line,E1,Cs1};
+expr({'receive',Line,Cs0},St) ->
+ Cs1 = icr_clauses(Cs0,St),
+ {'receive',Line,Cs1};
+expr({'receive',Line,Cs0,To0,ToEs0},St) ->
+ To1 = expr(To0,St),
+ ToEs1 = exprs(ToEs0,St),
+ Cs1 = icr_clauses(Cs0,St),
+ {'receive',Line,Cs1,To1,ToEs1};
+expr({'try',Line,Es0,Scs0,Ccs0,As0},St) ->
+ Es1 = exprs(Es0,St),
+ Scs1 = icr_clauses(Scs0,St),
+ Ccs1 = icr_clauses(Ccs0,St),
+ As1 = exprs(As0,St),
+ {'try',Line,Es1,Scs1,Ccs1,As1};
+expr({'fun',Line,Body,Info},St) ->
+ case Body of
+ {clauses,Cs0} ->
+ Cs1 = fun_clauses(Cs0,St),
+ {'fun',Line,{clauses,Cs1},Info};
+ {function,F,A} = Function ->
+ {F1,A1} = update_function_name({F,A},St),
+ if A1 =:= A ->
+ {'fun',Line,Function,Info};
+ true ->
+ %% Must rewrite local fun-name to a fun that does a
+ %% call with the extra THIS parameter.
+ As = make_vars(A, Line),
+ As1 = As ++ [{var,Line,'THIS'}],
+ Call = {call,Line,{atom,Line,F1},As1},
+ Cs = [{clause,Line,As,[],[Call]}],
+ {'fun',Line,{clauses,Cs},Info}
+ end;
+ {function,_M,_F,_A} = Fun4 -> %This is an error in lint!
+ {'fun',Line,Fun4,Info}
+ end;
+expr({call,Lc,{atom,_,instance}=Name,As0},St) ->
+ %% All local functions 'instance(...)' are static by definition,
+ %% so they do not take a 'THIS' argument when called
+ As1 = expr_list(As0,St),
+ {call,Lc,Name,As1};
+expr({call,Lc,{atom,_,new}=Name,As0},St) ->
+ %% All local functions 'new(...)' are static by definition,
+ %% so they do not take a 'THIS' argument when called
+ As1 = expr_list(As0,St),
+ {call,Lc,Name,As1};
+expr({call,Lc,{atom,_,module_info}=Name,As0},St)
+ when length(As0) =:= 0; length(As0) =:= 1 ->
+ %% The module_info/0 and module_info/1 functions are also static.
+ As1 = expr_list(As0,St),
+ {call,Lc,Name,As1};
+expr({call,Lc,{atom,_Lf,_F}=Atom,As0},St) ->
+ %% Local function call - needs THIS parameter.
+ As1 = expr_list(As0,St),
+ {call,Lc,Atom,As1 ++ [{var,0,'THIS'}]};
+expr({call,Line,F0,As0},St) ->
+ %% Other function call
+ F1 = expr(F0,St),
+ As1 = expr_list(As0,St),
+ {call,Line,F1,As1};
+expr({'catch',Line,E0},St) ->
+ E1 = expr(E0,St),
+ {'catch',Line,E1};
+expr({match,Line,P0,E0},St) ->
+ E1 = expr(E0,St),
+ P1 = pattern(P0,St),
+ {match,Line,P1,E1};
+expr({bin,Line,Fs},St) ->
+ Fs2 = pattern_grp(Fs,St),
+ {bin,Line,Fs2};
+expr({op,Line,Op,A0},St) ->
+ A1 = expr(A0,St),
+ {op,Line,Op,A1};
+expr({op,Line,Op,L0,R0},St) ->
+ L1 = expr(L0,St),
+ R1 = expr(R0,St),
+ {op,Line,Op,L1,R1};
+%% The following are not allowed to occur anywhere!
+expr({remote,Line,M0,F0},St) ->
+ M1 = expr(M0,St),
+ F1 = expr(F0,St),
+ {remote,Line,M1,F1}.
+
+expr_list([E0|Es],St) ->
+ E1 = expr(E0,St),
+ [E1|expr_list(Es,St)];
+expr_list([],_St) -> [].
+
+icr_clauses([C0|Cs],St) ->
+ C1 = clause(C0,St),
+ [C1|icr_clauses(Cs,St)];
+icr_clauses([],_St) -> [].
+
+lc_quals([{generate,Line,P0,E0}|Qs],St) ->
+ E1 = expr(E0,St),
+ P1 = pattern(P0,St),
+ [{generate,Line,P1,E1}|lc_quals(Qs,St)];
+lc_quals([E0|Qs],St) ->
+ E1 = expr(E0,St),
+ [E1|lc_quals(Qs,St)];
+lc_quals([],_St) -> [].
+
+fun_clauses([C0|Cs],St) ->
+ C1 = clause(C0,St),
+ [C1|fun_clauses(Cs,St)];
+fun_clauses([],_St) -> [].
+
+%% %% Return index from 1 upwards, or 0 if not in the list.
+%%
+%% index(X,Ys) -> index(X,Ys,1).
+%%
+%% index(X,[X|Ys],A) -> A;
+%% index(X,[Y|Ys],A) -> index(X,Ys,A+1);
+%% index(X,[],A) -> 0.
+
+make_vars(N, L) ->
+ make_vars(1, N, L).
+
+make_vars(N, M, L) when N =< M ->
+ V = list_to_atom("X"++integer_to_list(N)),
+ [{var,L,V} | make_vars(N + 1, M, L)];
+make_vars(_, _, _) ->
+ [].
diff --git a/lib/compiler/src/sys_pre_attributes.erl b/lib/compiler/src/sys_pre_attributes.erl
new file mode 100644
index 0000000000..a6b7274b07
--- /dev/null
+++ b/lib/compiler/src/sys_pre_attributes.erl
@@ -0,0 +1,213 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1998-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%
+%%
+%% Purpose : Transform Erlang compiler attributes
+
+-module(sys_pre_attributes).
+
+-export([parse_transform/2]).
+
+-define(OPTION_TAG, attributes).
+
+-record(state, {forms,
+ pre_ops = [],
+ post_ops = [],
+ options}).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Inserts, deletes and replaces Erlang compiler attributes.
+%%
+%% Valid options are:
+%%
+%% {attribute, insert, AttrName, NewAttrVal}
+%% {attribute, replace, AttrName, NewAttrVal} % replace first occurrence
+%% {attribute, delete, AttrName}
+%%
+%% The transformation is performed in two passes:
+%%
+%% pre_transform
+%% -------------
+%% Searches for attributes in the list of Forms in order to
+%% delete or replace them. 'delete' will delete all occurrences
+%% of attributes with the given name. 'replace' will replace the
+%% first occurrence of the attribute. This pass is will only be
+%% performed if there are replace or delete operations stated
+%% as options.
+%%
+%% post_transform
+%% -------------
+%% Looks up the module attribute and inserts the new attributes
+%% directly after. This pass will only be performed if there are
+%% any attributes left to be inserted after pre_transform. The left
+%% overs will be those replace operations that not has been performed
+%% due to that the pre_transform pass did not find the attribute plus
+%% all insert operations.
+
+parse_transform(Forms, Options) ->
+ S = #state{forms = Forms, options = Options},
+ S2 = init_transform(S),
+ report_verbose("Pre options: ~p~n", [S2#state.pre_ops], S2),
+ report_verbose("Post options: ~p~n", [S2#state.post_ops], S2),
+ S3 = pre_transform(S2),
+ S4 = post_transform(S3),
+ S4#state.forms.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Computes the lists of pre_ops and post_ops that are
+%% used in the real transformation.
+init_transform(S) ->
+ case S#state.options of
+ Options when is_list(Options) ->
+ init_transform(Options, S);
+ Option ->
+ init_transform([Option], S)
+ end.
+
+init_transform([{attribute, insert, Name, Val} | Tail], S) ->
+ Op = {insert, Name, Val},
+ PostOps = [Op | S#state.post_ops],
+ init_transform(Tail, S#state{post_ops = PostOps});
+init_transform([{attribute, replace, Name, Val} | Tail], S) ->
+ Op = {replace, Name, Val},
+ PreOps = [Op | S#state.pre_ops],
+ PostOps = [Op | S#state.post_ops],
+ init_transform(Tail, S#state{pre_ops = PreOps, post_ops = PostOps});
+init_transform([{attribute, delete, Name} | Tail], S) ->
+ Op = {delete, Name},
+ PreOps = [Op | S#state.pre_ops],
+ init_transform(Tail, S#state{pre_ops = PreOps});
+init_transform([], S) ->
+ S;
+init_transform([_ | T], S) ->
+ init_transform(T, S);
+init_transform(BadOpt, S) ->
+ report_error("Illegal option (ignored): ~p~n", [BadOpt], S),
+ S.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Handle delete and perhaps replace
+
+pre_transform(#state{pre_ops = []} = S) ->
+ S;
+pre_transform(S) ->
+ pre_transform(S#state.forms, [], S).
+
+pre_transform([H | T], Acc, S) ->
+ case H of
+ {attribute, Line, Name, Val} ->
+ case lists:keyfind(Name, 2, S#state.pre_ops) of
+ false ->
+ pre_transform(T, [H | Acc], S);
+
+ {replace, Name, NewVal} ->
+ report_warning("Replace attribute ~p: ~p -> ~p~n",
+ [Name, Val, NewVal],
+ S),
+ New = {attribute, Line, Name, NewVal},
+ Pre = lists:keydelete(Name, 2, S#state.pre_ops),
+ Post = lists:keydelete(Name, 2, S#state.post_ops),
+ S2 = S#state{pre_ops = Pre, post_ops = Post},
+ if
+ Pre == [] ->
+ %% No need to search the rest of the Forms
+ Forms = lists:reverse(Acc, [New | T]),
+ S2#state{forms = Forms};
+ true ->
+ pre_transform(T, [New | Acc], S2)
+ end;
+
+ {delete, Name} ->
+ report_warning("Delete attribute ~p: ~p~n",
+ [Name, Val],
+ S),
+ pre_transform(T, Acc, S)
+ end;
+ _Any ->
+ pre_transform(T, [H | Acc], S)
+ end;
+pre_transform([], Acc, S) ->
+ S#state{forms = lists:reverse(Acc)}.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Handle insert and perhaps replace
+
+post_transform(#state{post_ops = []} = S) ->
+ S;
+post_transform(S) ->
+ post_transform(S#state.forms, [], S).
+
+post_transform([H | T], Acc, S) ->
+ case H of
+ {attribute, Line, module, _Val} = Attribute ->
+ Acc2 = lists:reverse([Attribute | Acc]),
+ Forms = Acc2 ++ attrs(S#state.post_ops, Line, S) ++ T,
+ S#state{forms = Forms, post_ops = []};
+ _Any ->
+ post_transform(T, [H | Acc], S)
+ end;
+post_transform([], Acc, S) ->
+ S#state{forms = lists:reverse(Acc)}.
+
+attrs([{replace, Name, NewVal} | T], Line, S) ->
+ report_verbose("Insert attribute ~p: ~p~n", [Name, NewVal], S),
+ [{attribute, Line, Name, NewVal} | attrs(T, Line, S)];
+attrs([{insert, Name, NewVal} | T], Line, S) ->
+ report_verbose("Insert attribute ~p: ~p~n", [Name, NewVal], S),
+ [{attribute, Line, Name, NewVal} | attrs(T, Line, S)];
+attrs([], _, _) ->
+ [].
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Report functions.
+%%
+%% Errors messages are controlled with the 'report_errors' compiler option
+%% Warning messages are controlled with the 'report_warnings' compiler option
+%% Verbose messages are controlled with the 'verbose' compiler option
+
+report_error(Format, Args, S) ->
+ case is_error(S) of
+ true ->
+ io:format("~p: * ERROR * " ++ Format, [?MODULE | Args]);
+ false ->
+ ok
+ end.
+
+report_warning(Format, Args, S) ->
+ case is_warning(S) of
+ true ->
+ io:format("~p: * WARNING * " ++ Format, [?MODULE | Args]);
+ false ->
+ ok
+ end.
+
+report_verbose(Format, Args, S) ->
+ case is_verbose(S) of
+ true ->
+ io:format("~p: " ++ Format, [?MODULE | Args]);
+ false ->
+ ok
+ end.
+
+is_error(S) ->
+ lists:member(report_errors, S#state.options) or is_verbose(S).
+
+is_warning(S) ->
+ lists:member(report_warnings, S#state.options) or is_verbose(S).
+
+is_verbose(S) ->
+ lists:member(verbose, S#state.options).
diff --git a/lib/compiler/src/sys_pre_expand.erl b/lib/compiler/src/sys_pre_expand.erl
new file mode 100644
index 0000000000..78dd73e0a2
--- /dev/null
+++ b/lib/compiler/src/sys_pre_expand.erl
@@ -0,0 +1,687 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1996-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%
+%%
+%% Purpose : Expand some source Erlang constructions. This is part of the
+%% pre-processing phase.
+
+%% N.B. Although structs (tagged tuples) are not yet allowed in the
+%% language there is code included in pattern/2 and expr/3 (commented out)
+%% that handles them by transforming them to tuples.
+
+-module(sys_pre_expand).
+
+%% Main entry point.
+-export([module/2]).
+
+-import(ordsets, [from_list/1,add_element/2,union/2]).
+-import(lists, [member/2,foldl/3,foldr/3]).
+
+-compile({nowarn_deprecated_function, {erlang,hash,2}}).
+
+-include("../include/erl_bits.hrl").
+
+-record(expand, {module=[], %Module name
+ parameters=undefined, %Module parameters
+ package="", %Module package
+ exports=[], %Exports
+ imports=[], %Imports
+ mod_imports, %Module Imports
+ compile=[], %Compile flags
+ attributes=[], %Attributes
+ defined=[], %Defined functions
+ vcount=0, %Variable counter
+ func=[], %Current function
+ arity=[], %Arity for current function
+ fcount=0, %Local fun count
+ fun_index=0, %Global index for funs
+ bitdefault,
+ bittypes
+ }).
+
+%% module(Forms, CompileOptions)
+%% {ModuleName,Exports,TransformedForms,CompileOptions'}
+%% Expand the forms in one module. N.B.: the lists of predefined
+%% exports and imports are really ordsets!
+%% CompileOptions is augmented with options from -compile attributes.
+
+module(Fs0, Opts0) ->
+
+ %% Expand records. Normalise guard tests.
+ Fs = erl_expand_records:module(Fs0, Opts0),
+
+ Opts = compiler_options(Fs) ++ Opts0,
+
+ %% Set pre-defined exported functions.
+ PreExp = [{module_info,0},{module_info,1}],
+
+ %% Set pre-defined module imports.
+ PreModImp = [{erlang,erlang},{packages,packages}],
+
+ %% Build initial expand record.
+ St0 = #expand{exports=PreExp,
+ mod_imports=dict:from_list(PreModImp),
+ compile=Opts,
+ defined=PreExp,
+ bitdefault = erl_bits:system_bitdefault(),
+ bittypes = erl_bits:system_bittypes()
+ },
+ %% Expand the functions.
+ {Tfs,St1} = forms(Fs, define_functions(Fs, St0)),
+ {Efs,St2} = expand_pmod(Tfs, St1),
+ %% Get the correct list of exported functions.
+ Exports = case member(export_all, St2#expand.compile) of
+ true -> St2#expand.defined;
+ false -> St2#expand.exports
+ end,
+ %% Generate all functions from stored info.
+ {Ats,St3} = module_attrs(St2#expand{exports = Exports}),
+ {Mfs,St4} = module_predef_funcs(St3),
+ {St4#expand.module, St4#expand.exports, Ats ++ Efs ++ Mfs,
+ St4#expand.compile}.
+
+compiler_options(Forms) ->
+ lists:flatten([C || {attribute,_,compile,C} <- Forms]).
+
+expand_pmod(Fs0, St0) ->
+ case St0#expand.parameters of
+ undefined ->
+ {Fs0,St0};
+ Ps0 ->
+ Base = get_base(St0#expand.attributes),
+ Ps = if is_atom(Base) ->
+ ['BASE' | Ps0];
+ true ->
+ Ps0
+ end,
+ {Fs1,Xs,Ds} = sys_expand_pmod:forms(Fs0, Ps,
+ St0#expand.exports,
+ St0#expand.defined),
+ St1 = St0#expand{exports=Xs, defined=Ds},
+ {Fs2,St2} = add_instance(Ps, Fs1, St1),
+ {Fs3,St3} = ensure_new(Base, Ps0, Fs2, St2),
+ {Fs3,St3#expand{attributes = [{abstract, [true]}
+ | St3#expand.attributes]}}
+ end.
+
+get_base(As) ->
+ case lists:keyfind(extends, 1, As) of
+ {extends,[Base]} when is_atom(Base) ->
+ Base;
+ _ ->
+ []
+ end.
+
+ensure_new(Base, Ps, Fs, St) ->
+ case has_new(Fs) of
+ true ->
+ {Fs, St};
+ false ->
+ add_new(Base, Ps, Fs, St)
+ end.
+
+has_new([{function,_L,new,_A,_Cs} | _Fs]) ->
+ true;
+has_new([_ | Fs]) ->
+ has_new(Fs);
+has_new([]) ->
+ false.
+
+add_new(Base, Ps, Fs, St) ->
+ Vs = [{var,0,V} || V <- Ps],
+ As = if is_atom(Base) ->
+ [{call,0,{remote,0,{atom,0,Base},{atom,0,new}},Vs} | Vs];
+ true ->
+ Vs
+ end,
+ Body = [{call,0,{atom,0,instance},As}],
+ add_func(new, Vs, Body, Fs, St).
+
+add_instance(Ps, Fs, St) ->
+ Vs = [{var,0,V} || V <- Ps],
+ AbsMod = [{tuple,0,[{atom,0,St#expand.module}|Vs]}],
+ add_func(instance, Vs, AbsMod, Fs, St).
+
+add_func(Name, Args, Body, Fs, St) ->
+ A = length(Args),
+ F = {function,0,Name,A,[{clause,0,Args,[],Body}]},
+ NA = {Name,A},
+ {[F|Fs],St#expand{exports=add_element(NA, St#expand.exports),
+ defined=add_element(NA, St#expand.defined)}}.
+
+%% define_function(Form, State) -> State.
+%% Add function to defined if form is a function.
+
+define_functions(Forms, #expand{defined=Predef}=St) ->
+ Fs = foldl(fun({function,_,N,A,_Cs}, Acc) -> [{N,A}|Acc];
+ (_, Acc) -> Acc
+ end, Predef, Forms),
+ St#expand{defined=ordsets:from_list(Fs)}.
+
+module_attrs(St) ->
+ {[{attribute,0,Name,Val} || {Name,Val} <- St#expand.attributes],St}.
+
+module_predef_funcs(St) ->
+ PreDef = [{module_info,0},{module_info,1}],
+ PreExp = PreDef,
+ {[{function,0,module_info,0,
+ [{clause,0,[],[],
+ [{call,0,{remote,0,{atom,0,erlang},{atom,0,get_module_info}},
+ [{atom,0,St#expand.module}]}]}]},
+ {function,0,module_info,1,
+ [{clause,0,[{var,0,'X'}],[],
+ [{call,0,{remote,0,{atom,0,erlang},{atom,0,get_module_info}},
+ [{atom,0,St#expand.module},{var,0,'X'}]}]}]}],
+ St#expand{defined=union(from_list(PreDef), St#expand.defined),
+ exports=union(from_list(PreExp), St#expand.exports)}}.
+
+%% forms(Forms, State) ->
+%% {TransformedForms,State'}
+%% Process the forms. Attributes are lost and just affect the state.
+%% Ignore uninteresting forms like eof and type.
+
+forms([{attribute,_,file,_File}=F|Fs0], St0) ->
+ {Fs,St1} = forms(Fs0, St0),
+ {[F|Fs],St1};
+forms([{attribute,_,Name,Val}|Fs0], St0) ->
+ St1 = attribute(Name, Val, St0),
+ forms(Fs0, St1);
+forms([{function,L,N,A,Cs}|Fs0], St0) ->
+ {Ff,St1} = function(L, N, A, Cs, St0),
+ {Fs,St2} = forms(Fs0, St1),
+ {[Ff|Fs],St2};
+forms([_|Fs], St) -> forms(Fs, St);
+forms([], St) -> {[],St}.
+
+%% attribute(Attribute, Value, State) -> State'.
+%% Process an attribute, this just affects the state.
+
+attribute(module, {Module, As}, St) ->
+ M = package_to_string(Module),
+ St#expand{module=list_to_atom(M),
+ package = packages:strip_last(M),
+ parameters=As};
+attribute(module, Module, St) ->
+ M = package_to_string(Module),
+ St#expand{module=list_to_atom(M),
+ package = packages:strip_last(M)};
+attribute(export, Es, St) ->
+ St#expand{exports=union(from_list(Es), St#expand.exports)};
+attribute(import, Is, St) ->
+ import(Is, St);
+attribute(compile, C, St) when is_list(C) ->
+ St#expand{compile=St#expand.compile ++ C};
+attribute(compile, C, St) ->
+ St#expand{compile=St#expand.compile ++ [C]};
+attribute(Name, Val, St) when is_list(Val) ->
+ St#expand{attributes=St#expand.attributes ++ [{Name,Val}]};
+attribute(Name, Val, St) ->
+ St#expand{attributes=St#expand.attributes ++ [{Name,[Val]}]}.
+
+function(L, N, A, Cs0, St0) ->
+ {Cs,St} = clauses(Cs0, St0#expand{func=N,arity=A,fcount=0}),
+ {{function,L,N,A,Cs},St}.
+
+%% clauses([Clause], State) ->
+%% {[TransformedClause],State}.
+%% Expand function clauses.
+
+clauses([{clause,Line,H0,G0,B0}|Cs0], St0) ->
+ {H,St1} = head(H0, St0),
+ {G,St2} = guard(G0, St1),
+ {B,St3} = exprs(B0, St2),
+ {Cs,St4} = clauses(Cs0, St3),
+ {[{clause,Line,H,G,B}|Cs],St4};
+clauses([], St) -> {[],St}.
+
+%% head(HeadPatterns, State) ->
+%% {TransformedPatterns,Variables,UsedVariables,State'}
+
+head(As, St) -> pattern_list(As, St).
+
+%% pattern(Pattern, State) ->
+%% {TransformedPattern,State'}
+%%
+
+pattern({var,_,'_'}=Var, St) -> %Ignore anonymous variable.
+ {Var,St};
+pattern({var,_,_}=Var, St) ->
+ {Var,St};
+pattern({char,_,_}=Char, St) ->
+ {Char,St};
+pattern({integer,_,_}=Int, St) ->
+ {Int,St};
+pattern({float,_,_}=Float, St) ->
+ {Float,St};
+pattern({atom,_,_}=Atom, St) ->
+ {Atom,St};
+pattern({string,_,_}=String, St) ->
+ {String,St};
+pattern({nil,_}=Nil, St) ->
+ {Nil,St};
+pattern({cons,Line,H,T}, St0) ->
+ {TH,St1} = pattern(H, St0),
+ {TT,St2} = pattern(T, St1),
+ {{cons,Line,TH,TT},St2};
+pattern({tuple,Line,Ps}, St0) ->
+ {TPs,St1} = pattern_list(Ps, St0),
+ {{tuple,Line,TPs},St1};
+%%pattern({struct,Line,Tag,Ps}, St0) ->
+%% {TPs,TPsvs,St1} = pattern_list(Ps, St0),
+%% {{tuple,Line,[{atom,Line,Tag}|TPs]},TPsvs,St1};
+pattern({record_field,_,_,_}=M, St) ->
+ {expand_package(M, St),St}; % must be a package name
+pattern({bin,Line,Es0}, St0) ->
+ {Es1,St1} = pattern_bin(Es0, St0),
+ {{bin,Line,Es1},St1};
+pattern({op,_,'++',{nil,_},R}, St) ->
+ pattern(R, St);
+pattern({op,_,'++',{cons,Li,H,T},R}, St) ->
+ pattern({cons,Li,H,{op,Li,'++',T,R}}, St);
+pattern({op,_,'++',{string,Li,L},R}, St) ->
+ pattern(string_to_conses(Li, L, R), St);
+pattern({match,Line,Pat1, Pat2}, St0) ->
+ {TH,St1} = pattern(Pat2, St0),
+ {TT,St2} = pattern(Pat1, St1),
+ {{match,Line,TT,TH},St2};
+%% Compile-time pattern expressions, including unary operators.
+pattern({op,Line,Op,A}, St) ->
+ {erl_eval:partial_eval({op,Line,Op,A}),St};
+pattern({op,Line,Op,L,R}, St) ->
+ {erl_eval:partial_eval({op,Line,Op,L,R}),St}.
+
+pattern_list([P0|Ps0], St0) ->
+ {P,St1} = pattern(P0, St0),
+ {Ps,St2} = pattern_list(Ps0, St1),
+ {[P|Ps],St2};
+pattern_list([], St) -> {[],St}.
+
+%% guard(Guard, State) ->
+%% {TransformedGuard,State'}
+%% Transform a list of guard tests. We KNOW that this has been checked
+%% and what the guards test are. Use expr for transforming the guard
+%% expressions.
+
+guard([G0|Gs0], St0) ->
+ {G,St1} = guard_tests(G0, St0),
+ {Gs,St2} = guard(Gs0, St1),
+ {[G|Gs],St2};
+guard([], St) -> {[],St}.
+
+guard_tests([Gt0|Gts0], St0) ->
+ {Gt1,St1} = guard_test(Gt0, St0),
+ {Gts1,St2} = guard_tests(Gts0, St1),
+ {[Gt1|Gts1],St2};
+guard_tests([], St) -> {[],St}.
+
+guard_test(Test, St) ->
+ expr(Test, St).
+
+%% exprs(Expressions, State) ->
+%% {TransformedExprs,State'}
+
+exprs([E0|Es0], St0) ->
+ {E,St1} = expr(E0, St0),
+ {Es,St2} = exprs(Es0, St1),
+ {[E|Es],St2};
+exprs([], St) -> {[],St}.
+
+%% expr(Expression, State) ->
+%% {TransformedExpression,State'}
+
+expr({var,_,_}=Var, St) ->
+ {Var,St};
+expr({char,_,_}=Char, St) ->
+ {Char,St};
+expr({integer,_,_}=Int, St) ->
+ {Int,St};
+expr({float,_,_}=Float, St) ->
+ {Float,St};
+expr({atom,_,_}=Atom, St) ->
+ {Atom,St};
+expr({string,_,_}=String, St) ->
+ {String,St};
+expr({nil,_}=Nil, St) ->
+ {Nil,St};
+expr({cons,Line,H0,T0}, St0) ->
+ {H,St1} = expr(H0, St0),
+ {T,St2} = expr(T0, St1),
+ {{cons,Line,H,T},St2};
+expr({lc,Line,E0,Qs0}, St0) ->
+ {Qs1,St1} = lc_tq(Line, Qs0, St0),
+ {E1,St2} = expr(E0, St1),
+ {{lc,Line,E1,Qs1},St2};
+expr({bc,Line,E0,Qs0}, St0) ->
+ {Qs1,St1} = lc_tq(Line, Qs0, St0),
+ {E1,St2} = expr(E0, St1),
+ {{bc,Line,E1,Qs1},St2};
+expr({tuple,Line,Es0}, St0) ->
+ {Es1,St1} = expr_list(Es0, St0),
+ {{tuple,Line,Es1},St1};
+%%expr({struct,Line,Tag,Es0}, Vs, St0) ->
+%% {Es1,Esvs,Esus,St1} = expr_list(Es0, Vs, St0),
+%% {{tuple,Line,[{atom,Line,Tag}|Es1]},Esvs,Esus,St1};
+expr({record_field,_,_,_}=M, St) ->
+ {expand_package(M, St),St}; % must be a package name
+expr({bin,Line,Es0}, St0) ->
+ {Es1,St1} = expr_bin(Es0, St0),
+ {{bin,Line,Es1},St1};
+expr({block,Line,Es0}, St0) ->
+ {Es,St1} = exprs(Es0, St0),
+ {{block,Line,Es},St1};
+expr({'if',Line,Cs0}, St0) ->
+ {Cs,St1} = icr_clauses(Cs0, St0),
+ {{'if',Line,Cs},St1};
+expr({'case',Line,E0,Cs0}, St0) ->
+ {E,St1} = expr(E0, St0),
+ {Cs,St2} = icr_clauses(Cs0, St1),
+ {{'case',Line,E,Cs},St2};
+expr({'receive',Line,Cs0}, St0) ->
+ {Cs,St1} = icr_clauses(Cs0, St0),
+ {{'receive',Line,Cs},St1};
+expr({'receive',Line,Cs0,To0,ToEs0}, St0) ->
+ {To,St1} = expr(To0, St0),
+ {ToEs,St2} = exprs(ToEs0, St1),
+ {Cs,St3} = icr_clauses(Cs0, St2),
+ {{'receive',Line,Cs,To,ToEs},St3};
+expr({'fun',Line,Body}, St) ->
+ fun_tq(Line, Body, St);
+expr({call,Line,{atom,La,N},As0}, St0) ->
+ {As,St1} = expr_list(As0, St0),
+ Ar = length(As),
+ case erl_internal:bif(N, Ar) of
+ true ->
+ {{call,Line,{remote,La,{atom,La,erlang},{atom,La,N}},As},St1};
+ false ->
+ case imported(N, Ar, St1) of
+ {yes,Mod} ->
+ {{call,Line,{remote,La,{atom,La,Mod},{atom,La,N}},As},St1};
+ no ->
+ {{call,Line,{atom,La,N},As},St1}
+ end
+ end;
+expr({call,Line,{record_field,_,_,_}=M,As0}, St0) ->
+ expr({call,Line,expand_package(M, St0),As0}, St0);
+expr({call,Line,{remote,Lr,M,F},As0}, St0) ->
+ M1 = expand_package(M, St0),
+ {[M2,F1|As1],St1} = expr_list([M1,F|As0], St0),
+ {{call,Line,{remote,Lr,M2,F1},As1},St1};
+expr({call,Line,{tuple,_,[{atom,_,_}=M,{atom,_,_}=F]},As}, St) ->
+ %% Rewrite {Mod,Function}(Args...) to Mod:Function(Args...).
+ expr({call,Line,{remote,Line,M,F},As}, St);
+expr({call,Line,F,As0}, St0) ->
+ {[Fun1|As1],St1} = expr_list([F|As0], St0),
+ {{call,Line,Fun1,As1},St1};
+expr({'try',Line,Es0,Scs0,Ccs0,As0}, St0) ->
+ {Es1,St1} = exprs(Es0, St0),
+ {Scs1,St2} = icr_clauses(Scs0, St1),
+ {Ccs1,St3} = icr_clauses(Ccs0, St2),
+ {As1,St4} = exprs(As0, St3),
+ {{'try',Line,Es1,Scs1,Ccs1,As1},St4};
+expr({'catch',Line,E0}, St0) ->
+ %% Catch exports no new variables.
+ {E,St1} = expr(E0, St0),
+ {{'catch',Line,E},St1};
+expr({match,Line,P0,E0}, St0) ->
+ {E,St1} = expr(E0, St0),
+ {P,St2} = pattern(P0, St1),
+ {{match,Line,P,E},St2};
+expr({op,Line,Op,A0}, St0) ->
+ {A,St1} = expr(A0, St0),
+ {{op,Line,Op,A},St1};
+expr({op,Line,Op,L0,R0}, St0) ->
+ {L,St1} = expr(L0, St0),
+ {R,St2} = expr(R0, St1),
+ {{op,Line,Op,L,R},St2}.
+
+expr_list([E0|Es0], St0) ->
+ {E,St1} = expr(E0, St0),
+ {Es,St2} = expr_list(Es0, St1),
+ {[E|Es],St2};
+expr_list([], St) -> {[],St}.
+
+%% icr_clauses([Clause], State) -> {[TransformedClause],State'}
+%% Be very careful here to return the variables that are really used
+%% and really new.
+
+icr_clauses([], St) -> {[],St};
+icr_clauses(Clauses, St) -> icr_clauses2(Clauses, St).
+
+icr_clauses2([{clause,Line,H0,G0,B0}|Cs0], St0) ->
+ {H,St1} = head(H0, St0),
+ {G,St2} = guard(G0, St1),
+ {B,St3} = exprs(B0, St2),
+ {Cs,St4} = icr_clauses2(Cs0, St3),
+ {[{clause,Line,H,G,B}|Cs],St4};
+icr_clauses2([], St) -> {[],St}.
+
+%% lc_tq(Line, Qualifiers, State) ->
+%% {[TransQual],State'}
+
+lc_tq(Line, [{generate,Lg,P0,G0} | Qs0], St0) ->
+ {G1,St1} = expr(G0, St0),
+ {P1,St2} = pattern(P0, St1),
+ {Qs1,St3} = lc_tq(Line, Qs0, St2),
+ {[{generate,Lg,P1,G1} | Qs1],St3};
+
+lc_tq(Line, [{b_generate,Lg,P0,G0}|Qs0], St0) ->
+ {G1,St1} = expr(G0, St0),
+ {P1,St2} = pattern(P0, St1),
+ {Qs1,St3} = lc_tq(Line, Qs0, St2),
+ {[{b_generate,Lg,P1,G1}|Qs1],St3};
+lc_tq(Line, [F0 | Qs0], St0) ->
+ case erl_lint:is_guard_test(F0) of
+ true ->
+ {F1,St1} = guard_test(F0, St0),
+ {Qs1,St2} = lc_tq(Line, Qs0, St1),
+ {[F1|Qs1],St2};
+ false ->
+ {F1,St1} = expr(F0, St0),
+ {Qs1,St2} = lc_tq(Line, Qs0, St1),
+ {[F1 | Qs1],St2}
+ end;
+lc_tq(_Line, [], St0) ->
+ {[],St0}.
+
+
+%% fun_tq(Line, Body, State) ->
+%% {Fun,State'}
+%% Transform an "explicit" fun {'fun', Line, {clauses, Cs}} into an
+%% extended form {'fun', Line, {clauses, Cs}, Info}, unless it is the
+%% name of a BIF (erl_lint has checked that it is not an import).
+%% Process the body sequence directly to get the new and used variables.
+%% "Implicit" funs {'fun', Line, {function, F, A}} are not changed.
+
+fun_tq(Lf, {function,F,A}=Function, St0) ->
+ {As,St1} = new_vars(A, Lf, St0),
+ Cs = [{clause,Lf,As,[],[{call,Lf,{atom,Lf,F},As}]}],
+ case erl_internal:bif(F, A) of
+ true ->
+ fun_tq(Lf, {clauses,Cs}, St1);
+ false ->
+ Index = St0#expand.fun_index,
+ Uniq = erlang:hash(Cs, (1 bsl 27)-1),
+ {Fname,St2} = new_fun_name(St1),
+ {{'fun',Lf,Function,{Index,Uniq,Fname}},
+ St2#expand{fun_index=Index+1}}
+ end;
+fun_tq(L, {function,M,F,A}, St) ->
+ {{call,L,{remote,L,{atom,L,erlang},{atom,L,make_fun}},
+ [{atom,L,M},{atom,L,F},{integer,L,A}]},St};
+fun_tq(Lf, {clauses,Cs0}, St0) ->
+ Uniq = erlang:hash(Cs0, (1 bsl 27)-1),
+ {Cs1,St1} = fun_clauses(Cs0, St0),
+ Index = St1#expand.fun_index,
+ {Fname,St2} = new_fun_name(St1),
+ {{'fun',Lf,{clauses,Cs1},{Index,Uniq,Fname}},
+ St2#expand{fun_index=Index+1}}.
+
+fun_clauses([{clause,L,H0,G0,B0}|Cs0], St0) ->
+ {H,St1} = head(H0, St0),
+ {G,St2} = guard(G0, St1),
+ {B,St3} = exprs(B0, St2),
+ {Cs,St4} = fun_clauses(Cs0, St3),
+ {[{clause,L,H,G,B}|Cs],St4};
+fun_clauses([], St) -> {[],St}.
+
+%% new_fun_name(State) -> {FunName,State}.
+
+new_fun_name(#expand{func=F,arity=A,fcount=I}=St) ->
+ Name = "-" ++ atom_to_list(F) ++ "/" ++ integer_to_list(A)
+ ++ "-fun-" ++ integer_to_list(I) ++ "-",
+ {list_to_atom(Name),St#expand{fcount=I+1}}.
+
+%% pattern_bin([Element], State) -> {[Element],[Variable],[UsedVar],State}.
+
+pattern_bin(Es0, St) ->
+ Es1 = bin_expand_strings(Es0),
+ foldr(fun (E, Acc) -> pattern_element(E, Acc) end, {[],St}, Es1).
+
+pattern_element({bin_element,Line,Expr0,Size0,Type0}, {Es,St0}) ->
+ {Expr1,St1} = pattern(Expr0, St0),
+ {Size1,St2} = pat_bit_size(Size0, St1),
+ {Size,Type} = make_bit_type(Line, Size1, Type0),
+ Expr = coerce_to_float(Expr1, Type0),
+ {[{bin_element,Line,Expr,Size,Type}|Es],St2}.
+
+pat_bit_size(default, St) -> {default,St};
+pat_bit_size({atom,_La,all}=All, St) -> {All,St};
+pat_bit_size({var,_Lv,_V}=Var, St) -> {Var,St};
+pat_bit_size(Size, St) ->
+ Line = element(2, Size),
+ {value,Sz,_} = erl_eval:expr(Size, erl_eval:new_bindings()),
+ {{integer,Line,Sz},St}.
+
+make_bit_type(Line, default, Type0) ->
+ case erl_bits:set_bit_type(default, Type0) of
+ {ok,all,Bt} -> {{atom,Line,all},erl_bits:as_list(Bt)};
+ {ok,undefined,Bt} -> {{atom,Line,undefined},erl_bits:as_list(Bt)};
+ {ok,Size,Bt} -> {{integer,Line,Size},erl_bits:as_list(Bt)}
+ end;
+make_bit_type(_Line, Size, Type0) -> %Integer or 'all'
+ {ok,Size,Bt} = erl_bits:set_bit_type(Size, Type0),
+ {Size,erl_bits:as_list(Bt)}.
+
+coerce_to_float({integer,L,I}=E, [float|_]) ->
+ try
+ {float,L,float(I)}
+ catch
+ error:badarg -> E;
+ error:badarith -> E
+ end;
+coerce_to_float(E, _) -> E.
+
+%% expr_bin([Element], State) -> {[Element],State}.
+
+expr_bin(Es0, St) ->
+ Es1 = bin_expand_strings(Es0),
+ foldr(fun (E, Acc) -> bin_element(E, Acc) end, {[],St}, Es1).
+
+bin_element({bin_element,Line,Expr,Size,Type}, {Es,St0}) ->
+ {Expr1,St1} = expr(Expr, St0),
+ {Size1,St2} = if Size == default -> {default,St1};
+ true -> expr(Size, St1)
+ end,
+ {Size2,Type1} = make_bit_type(Line, Size1, Type),
+ {[{bin_element,Line,Expr1,Size2,Type1}|Es],St2}.
+
+bin_expand_strings(Es) ->
+ foldr(fun ({bin_element,Line,{string,_,S},Sz,Ts}, Es1) ->
+ foldr(fun (C, Es2) ->
+ [{bin_element,Line,{char,Line,C},Sz,Ts}|Es2]
+ end, Es1, S);
+ (E, Es1) -> [E|Es1]
+ end, [], Es).
+
+%% new_var_name(State) -> {VarName,State}.
+
+new_var_name(St) ->
+ C = St#expand.vcount,
+ {list_to_atom("pre" ++ integer_to_list(C)),St#expand{vcount=C+1}}.
+
+%% new_var(Line, State) -> {Var,State}.
+
+new_var(L, St0) ->
+ {New,St1} = new_var_name(St0),
+ {{var,L,New},St1}.
+
+%% new_vars(Count, Line, State) -> {[Var],State}.
+%% Make Count new variables.
+
+new_vars(N, L, St) -> new_vars(N, L, St, []).
+
+new_vars(N, L, St0, Vs) when N > 0 ->
+ {V,St1} = new_var(L, St0),
+ new_vars(N-1, L, St1, [V|Vs]);
+new_vars(0, _L, St, Vs) -> {Vs,St}.
+
+string_to_conses(Line, Cs, Tail) ->
+ foldr(fun (C, T) -> {cons,Line,{char,Line,C},T} end, Tail, Cs).
+
+
+%% In syntax trees, module/package names are atoms or lists of atoms.
+
+package_to_string(A) when is_atom(A) -> atom_to_list(A);
+package_to_string(L) when is_list(L) -> packages:concat(L).
+
+expand_package({atom,L,A} = M, St) ->
+ case dict:find(A, St#expand.mod_imports) of
+ {ok, A1} ->
+ {atom,L,A1};
+ error ->
+ case packages:is_segmented(A) of
+ true ->
+ M;
+ false ->
+ M1 = packages:concat(St#expand.package, A),
+ {atom,L,list_to_atom(M1)}
+ end
+ end;
+expand_package(M, _St) ->
+ case erl_parse:package_segments(M) of
+ error ->
+ M;
+ M1 ->
+ {atom,element(2,M),list_to_atom(package_to_string(M1))}
+ end.
+
+%% import(Line, Imports, State) ->
+%% State'
+%% imported(Name, Arity, State) ->
+%% {yes,Module} | no
+%% Handle import declarations and test for imported functions. No need to
+%% check when building imports as code is correct.
+
+import({Mod0,Fs}, St) ->
+ Mod = list_to_atom(package_to_string(Mod0)),
+ Mfs = from_list(Fs),
+ St#expand{imports=add_imports(Mod, Mfs, St#expand.imports)};
+import(Mod0, St) ->
+ Mod = package_to_string(Mod0),
+ Key = list_to_atom(packages:last(Mod)),
+ St#expand{mod_imports=dict:store(Key, list_to_atom(Mod),
+ St#expand.mod_imports)}.
+
+add_imports(Mod, [F|Fs], Is) ->
+ add_imports(Mod, Fs, orddict:store(F, Mod, Is));
+add_imports(_, [], Is) -> Is.
+
+imported(F, A, St) ->
+ case orddict:find({F,A}, St#expand.imports) of
+ {ok,Mod} -> {yes,Mod};
+ error -> no
+ end.
diff --git a/lib/compiler/src/v3_codegen.erl b/lib/compiler/src/v3_codegen.erl
new file mode 100644
index 0000000000..83113d1652
--- /dev/null
+++ b/lib/compiler/src/v3_codegen.erl
@@ -0,0 +1,2051 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1999-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%
+%%
+%% Purpose : Code generator for Beam.
+
+%% The following assumptions have been made:
+%%
+%% 1. Matches, i.e. things with {match,M,Ret} wrappers, only return
+%% values; no variables are exported. If the match would have returned
+%% extra variables then these have been transformed to multiple return
+%% values.
+%%
+%% 2. All BIF's called in guards are gc-safe so there is no need to
+%% put thing on the stack in the guard. While this would in principle
+%% work it would be difficult to keep track of the stack depth when
+%% trimming.
+%%
+%% The code generation uses variable lifetime information added by
+%% the v3_life module to save variables, allocate registers and
+%% move registers to the stack when necessary.
+%%
+%% We try to use a consistent variable name scheme throughout. The
+%% StackReg record is always called Bef,Int<n>,Aft.
+
+-module(v3_codegen).
+
+%% The main interface.
+-export([module/2]).
+
+-import(lists, [member/2,keymember/3,keysort/2,keydelete/3,
+ append/1,map/2,flatmap/2,filter/2,foldl/3,foldr/3,mapfoldl/3,
+ sort/1,reverse/1,reverse/2]).
+-import(v3_life, [vdb_find/2]).
+
+%%-compile([export_all]).
+
+-include("v3_life.hrl").
+
+%% Main codegen structure.
+-record(cg, {lcount=1, %Label counter
+ finfo, %Function info label
+ bfail, %Fail label for BIFs
+ break, %Break label
+ recv, %Receive label
+ is_top_block, %Boolean: top block or not
+ functable=gb_trees:empty(), %Gb tree of local functions:
+ % {{Name,Arity},Label}
+ in_catch=false, %Inside a catch or not.
+ need_frame, %Need a stack frame.
+ ultimate_failure %Label for ultimate match failure.
+ }).
+
+%% Stack/register state record.
+-record(sr, {reg=[], %Register table
+ stk=[], %Stack table
+ res=[]}). %Reserved regs: [{reserved,I,V}]
+
+module({Mod,Exp,Attr,Forms}, Options) ->
+ put(?MODULE, Options),
+ {Fs,St} = functions(Forms, {atom,Mod}),
+ erase(?MODULE),
+ {ok,{Mod,Exp,Attr,Fs,St#cg.lcount}}.
+
+functions(Forms, AtomMod) ->
+ mapfoldl(fun (F, St) -> function(F, AtomMod, St) end, #cg{lcount=1}, Forms).
+
+function({function,Name,Arity,Asm0,Vb,Vdb}, AtomMod, St0) ->
+ try
+ {Asm,EntryLabel,St} = cg_fun(Vb, Asm0, Vdb, AtomMod, {Name,Arity}, St0),
+ Func = {function,Name,Arity,EntryLabel,Asm},
+ {Func,St}
+ catch
+ Class:Error ->
+ Stack = erlang:get_stacktrace(),
+ io:fwrite("Function: ~w/~w\n", [Name,Arity]),
+ erlang:raise(Class, Error, Stack)
+ end.
+
+%% cg_fun([Lkexpr], [HeadVar], Vdb, State) -> {[Ainstr],State}
+
+cg_fun(Les, Hvs, Vdb, AtomMod, NameArity, St0) ->
+ {Fi,St1} = new_label(St0), %FuncInfo label
+ {Fl,St2} = local_func_label(NameArity, St1),
+
+ %%
+ %% The pattern matching compiler (in v3_kernel) no longer
+ %% provides its own catch-all clause, because the
+ %% call to erlang:exit/1 caused problem when cases were
+ %% used in guards. Therefore, there may be tests that
+ %% cannot fail (providing that there is not a bug in a
+ %% previous optimzation pass), but still need to provide
+ %% a label (there are instructions, such as is_tuple/2,
+ %% that do not allow {f,0}).
+ %%
+ %% We will generate an ultimate failure label and put it
+ %% at the end of function, followed by an 'if_end' instruction.
+ %% Note that and 'if_end' instruction does not need any
+ %% live x registers, so it will always be safe to jump to
+ %% it. (We never ever expect the jump to be taken, and in
+ %% must functions there will never be any references to
+ %% the label in the first place.)
+ %%
+
+ {UltimateMatchFail,St3} = new_label(St2),
+
+ %% Create initial stack/register state, clear unused arguments.
+ Bef = clear_dead(#sr{reg=foldl(fun ({var,V}, Reg) ->
+ put_reg(V, Reg)
+ end, [], Hvs),
+ stk=[]}, 0, Vdb),
+ {B,_Aft,St} = cg_list(Les, 0, Vdb, Bef,
+ St3#cg{bfail=0,
+ finfo=Fi,
+ ultimate_failure=UltimateMatchFail,
+ is_top_block=true}),
+ {Name,Arity} = NameArity,
+ Asm = [{label,Fi},{func_info,AtomMod,{atom,Name},Arity},
+ {label,Fl}|B++[{label,UltimateMatchFail},if_end]],
+ {Asm,Fl,St}.
+
+%% cg(Lkexpr, Vdb, StackReg, State) -> {[Ainstr],StackReg,State}.
+%% Generate code for a kexpr.
+%% Split function into two steps for clarity, not efficiency.
+
+cg(Le, Vdb, Bef, St) ->
+ cg(Le#l.ke, Le, Vdb, Bef, St).
+
+cg({block,Es}, Le, Vdb, Bef, St) ->
+ block_cg(Es, Le, Vdb, Bef, St);
+cg({match,M,Rs}, Le, Vdb, Bef, St) ->
+ match_cg(M, Rs, Le, Vdb, Bef, St);
+cg({guard_match,M,Rs}, Le, Vdb, Bef, St) ->
+ guard_match_cg(M, Rs, Le, Vdb, Bef, St);
+cg({match_fail,F}, Le, Vdb, Bef, St) ->
+ match_fail_cg(F, Le, Vdb, Bef, St);
+cg({call,Func,As,Rs}, Le, Vdb, Bef, St) ->
+ call_cg(Func, As, Rs, Le, Vdb, Bef, St);
+cg({enter,Func,As}, Le, Vdb, Bef, St) ->
+ enter_cg(Func, As, Le, Vdb, Bef, St);
+cg({bif,Bif,As,Rs}, Le, Vdb, Bef, St) ->
+ bif_cg(Bif, As, Rs, Le, Vdb, Bef, St);
+cg({gc_bif,Bif,As,Rs}, Le, Vdb, Bef, St) ->
+ gc_bif_cg(Bif, As, Rs, Le, Vdb, Bef, St);
+cg({receive_loop,Te,Rvar,Rm,Tes,Rs}, Le, Vdb, Bef, St) ->
+ recv_loop_cg(Te, Rvar, Rm, Tes, Rs, Le, Vdb, Bef, St);
+cg(receive_next, Le, Vdb, Bef, St) ->
+ recv_next_cg(Le, Vdb, Bef, St);
+cg(receive_accept, _Le, _Vdb, Bef, St) -> {[remove_message],Bef,St};
+cg({'try',Ta,Vs,Tb,Evs,Th,Rs}, Le, Vdb, Bef, St) ->
+ try_cg(Ta, Vs, Tb, Evs, Th, Rs, Le, Vdb, Bef, St);
+cg({try_enter,Ta,Vs,Tb,Evs,Th}, Le, Vdb, Bef, St) ->
+ try_enter_cg(Ta, Vs, Tb, Evs, Th, Le, Vdb, Bef, St);
+cg({'catch',Cb,R}, Le, Vdb, Bef, St) ->
+ catch_cg(Cb, R, Le, Vdb, Bef, St);
+cg({set,Var,Con}, Le, Vdb, Bef, St) ->
+ set_cg(Var, Con, Le, Vdb, Bef, St);
+cg({return,Rs}, Le, Vdb, Bef, St) -> return_cg(Rs, Le, Vdb, Bef, St);
+cg({break,Bs}, Le, Vdb, Bef, St) -> break_cg(Bs, Le, Vdb, Bef, St);
+cg({guard_break,Bs,N}, Le, Vdb, Bef, St) ->
+ guard_break_cg(Bs, N, Le, Vdb, Bef, St);
+cg({need_heap,H}, _Le, _Vdb, Bef, St) ->
+ {[{test_heap,H,max_reg(Bef#sr.reg)}],Bef,St}.
+
+%% cg_list([Kexpr], FirstI, Vdb, StackReg, St) -> {[Ainstr],StackReg,St}.
+
+cg_list(Kes, I, Vdb, Bef, St0) ->
+ {Keis,{Aft,St1}} =
+ flatmapfoldl(fun (Ke, {Inta,Sta}) ->
+ {Keis,Intb,Stb} = cg(Ke, Vdb, Inta, Sta),
+ {Keis,{Intb,Stb}}
+ end, {Bef,St0}, need_heap(Kes, I)),
+ {Keis,Aft,St1}.
+
+%% need_heap([Lkexpr], I, St) -> [Lkexpr].
+%% Insert need_heap instructions in Kexpr list. Try to be smart and
+%% collect them together as much as possible.
+
+need_heap(Kes0, I) ->
+ {Kes,H} = need_heap_0(reverse(Kes0), 0, []),
+
+ %% Prepend need_heap if necessary.
+ need_heap_need(I, H) ++ Kes.
+
+need_heap_0([Ke|Kes], H0, Acc) ->
+ {Ns,H} = need_heap_1(Ke, H0),
+ need_heap_0(Kes, H, [Ke|Ns]++Acc);
+need_heap_0([], H, Acc) ->
+ {Acc,H}.
+
+need_heap_1(#l{ke={set,_,{binary,_}},i=I}, H) ->
+ {need_heap_need(I, H),0};
+need_heap_1(#l{ke={set,_,Val}}, H) ->
+ %% Just pass through adding to needed heap.
+ {[],H + case Val of
+ {cons,_} -> 2;
+ {tuple,Es} -> 1 + length(Es);
+ {string,S} -> 2 * length(S);
+ _Other -> 0
+ end};
+need_heap_1(#l{ke={bif,dsetelement,_As,_Rs},i=I}, H) ->
+ {need_heap_need(I, H),0};
+need_heap_1(#l{ke={bif,{make_fun,_,_,_,_},_As,_Rs},i=I}, H) ->
+ {need_heap_need(I, H),0};
+need_heap_1(#l{ke={bif,bs_init_writable,_As,_Rs},i=I}, H) ->
+ {need_heap_need(I, H),0};
+need_heap_1(#l{ke={bif,_Bif,_As,_Rs}}, H) ->
+ {[],H};
+need_heap_1(#l{i=I}, H) ->
+ {need_heap_need(I, H),0}.
+
+need_heap_need(_I, 0) -> [];
+need_heap_need(I, H) -> [#l{ke={need_heap,H},i=I}].
+
+%% match_cg(Match, [Ret], Le, Vdb, StackReg, State) ->
+%% {[Ainstr],StackReg,State}.
+%% Generate code for a match. First save all variables on the stack
+%% that are to survive after the match. We leave saved variables in
+%% their registers as they might actually be in the right place.
+
+match_cg(M, Rs, Le, Vdb, Bef, St0) ->
+ I = Le#l.i,
+ {Sis,Int0} = adjust_stack(Bef, I, I+1, Vdb),
+ {B,St1} = new_label(St0),
+ {Mis,Int1,St2} = match_cg(M, St0#cg.ultimate_failure,
+ Int0, St1#cg{break=B}),
+ %% Put return values in registers.
+ Reg = load_vars(Rs, Int1#sr.reg),
+ {Sis ++ Mis ++ [{label,B}],
+ clear_dead(Int1#sr{reg=Reg}, I, Vdb),
+ St2#cg{break=St1#cg.break}}.
+
+guard_match_cg(M, Rs, Le, Vdb, Bef, St0) ->
+ I = Le#l.i,
+ {B,St1} = new_label(St0),
+ #cg{bfail=Fail} = St1,
+ {Mis,Aft,St2} = match_cg(M, Fail, Bef, St1#cg{break=B}),
+ %% Update the register descriptors for the return registers.
+ Reg = guard_match_regs(Aft#sr.reg, Rs),
+ {Mis ++ [{label,B}],
+ clear_dead(Aft#sr{reg=Reg}, I, Vdb),
+ St2#cg{break=St1#cg.break}}.
+
+guard_match_regs([{I,gbreakvar}|Rs], [{var,V}|Vs]) ->
+ [{I,V}|guard_match_regs(Rs, Vs)];
+guard_match_regs([R|Rs], Vs) ->
+ [R|guard_match_regs(Rs, Vs)];
+guard_match_regs([], []) -> [].
+
+
+%% match_cg(Match, Fail, StackReg, State) -> {[Ainstr],StackReg,State}.
+%% Generate code for a match tree. N.B. there is no need pass Vdb
+%% down as each level which uses this takes its own internal Vdb not
+%% the outer one.
+
+match_cg(Le, Fail, Bef, St) ->
+ match_cg(Le#l.ke, Le, Fail, Bef, St).
+
+match_cg({alt,F,S}, _Le, Fail, Bef, St0) ->
+ {Tf,St1} = new_label(St0),
+ {Fis,Faft,St2} = match_cg(F, Tf, Bef, St1),
+ {Sis,Saft,St3} = match_cg(S, Fail, Bef, St2),
+ Aft = sr_merge(Faft, Saft),
+ {Fis ++ [{label,Tf}] ++ Sis,Aft,St3};
+match_cg({select,{var,Vname}=V,Scs0}, #l{a=Anno}, Fail, Bef, St) ->
+ ReuseForContext = member(reuse_for_context, Anno) andalso
+ find_reg(Vname, Bef#sr.reg) =/= error,
+ Scs = case ReuseForContext of
+ false -> Scs0;
+ true -> bsm_rename_ctx(Scs0, Vname)
+ end,
+ match_fmf(fun (S, F, Sta) ->
+ select_cg(S, V, F, Fail, Bef, Sta) end,
+ Fail, St, Scs);
+match_cg({guard,Gcs}, _Le, Fail, Bef, St) ->
+ match_fmf(fun (G, F, Sta) -> guard_clause_cg(G, F, Bef, Sta) end,
+ Fail, St, Gcs);
+match_cg({block,Es}, Le, _Fail, Bef, St) ->
+ %% Must clear registers and stack of dead variables.
+ Int = clear_dead(Bef, Le#l.i, Le#l.vdb),
+ block_cg(Es, Le, Int, St).
+
+%% match_fail_cg(FailReason, Le, Vdb, StackReg, State) ->
+%% {[Ainstr],StackReg,State}.
+%% Generate code for the match_fail "call". N.B. there is no generic
+%% case for when the fail value has been created elsewhere.
+
+match_fail_cg({function_clause,As}, Le, Vdb, Bef, St) ->
+ %% Must have the args in {x,0}, {x,1},...
+ {Sis,Int} = cg_setup_call(As, Bef, Le#l.i, Vdb),
+ {Sis ++ [{jump,{f,St#cg.finfo}}],
+ Int#sr{reg=clear_regs(Int#sr.reg)},St};
+match_fail_cg({badmatch,Term}, Le, Vdb, Bef, St) ->
+ R = cg_reg_arg(Term, Bef),
+ Int0 = clear_dead(Bef, Le#l.i, Vdb),
+ {Sis,Int} = adjust_stack(Int0, Le#l.i, Le#l.i+1, Vdb),
+ {Sis ++ [{badmatch,R}],
+ Int#sr{reg=clear_regs(Int0#sr.reg)},St};
+match_fail_cg({case_clause,Reason}, Le, Vdb, Bef, St) ->
+ R = cg_reg_arg(Reason, Bef),
+ Int0 = clear_dead(Bef, Le#l.i, Vdb),
+ {Sis,Int} = adjust_stack(Int0, Le#l.i, Le#l.i+1, Vdb),
+ {Sis++[{case_end,R}],
+ Int#sr{reg=clear_regs(Bef#sr.reg)},St};
+match_fail_cg(if_clause, Le, Vdb, Bef, St) ->
+ Int0 = clear_dead(Bef, Le#l.i, Vdb),
+ {Sis,Int1} = adjust_stack(Int0, Le#l.i, Le#l.i+1, Vdb),
+ {Sis++[if_end],Int1#sr{reg=clear_regs(Int1#sr.reg)},St};
+match_fail_cg({try_clause,Reason}, Le, Vdb, Bef, St) ->
+ R = cg_reg_arg(Reason, Bef),
+ Int0 = clear_dead(Bef, Le#l.i, Vdb),
+ {Sis,Int} = adjust_stack(Int0, Le#l.i, Le#l.i+1, Vdb),
+ {Sis ++ [{try_case_end,R}],
+ Int#sr{reg=clear_regs(Int0#sr.reg)},St}.
+
+%% bsm_rename_ctx([Clause], Var) -> [Clause]
+%% We know from an annotation that the register for a binary can
+%% be reused for the match context because the two are not truly
+%% alive at the same time (even though the conservative life time
+%% information calculated by v3_life says so).
+%%
+%% The easiest way to have those variables share the same register is
+%% to rename the variable with the shortest life-span (the match
+%% context) to the variable for the binary (which can have a very
+%% long life-time because it is locked during matching). We KNOW that
+%% the match state variable will only be alive during the matching.
+%%
+%% We must also remove all information about the match context
+%% variable from all life-time information databases (Vdb).
+
+bsm_rename_ctx([#l{ke={type_clause,binary,
+ [#l{ke={val_clause,{binary,{var,Old}},Ke0}}=L2]}}=L1|Cs], New) ->
+ Ke = bsm_rename_ctx(Ke0, Old, New, false),
+ [L1#l{ke={type_clause,binary,
+ [L2#l{ke={val_clause,{binary,{var,New}},Ke}}]}}|bsm_rename_ctx(Cs, New)];
+bsm_rename_ctx([C|Cs], New) ->
+ [C|bsm_rename_ctx(Cs, New)];
+bsm_rename_ctx([], _) -> [].
+
+%% bsm_rename_ctx(Ke, OldName, NewName, InProt) -> Ke'
+%% Rename and clear OldName from life-time information. We must
+%% recurse into any block contained in a protected, but it would
+%% only complicatate things to recurse into blocks not in a protected
+%% (the match context variable is not live inside them).
+
+bsm_rename_ctx(#l{ke={select,{var,V},Cs0}}=L, Old, New, InProt) ->
+ Cs = bsm_rename_ctx_list(Cs0, Old, New, InProt),
+ L#l{ke={select,{var,bsm_rename_var(V, Old, New)},Cs}};
+bsm_rename_ctx(#l{ke={type_clause,Type,Cs0}}=L, Old, New, InProt) ->
+ Cs = bsm_rename_ctx_list(Cs0, Old, New, InProt),
+ L#l{ke={type_clause,Type,Cs}};
+bsm_rename_ctx(#l{ke={val_clause,{bin_end,V},Ke0}}=L, Old, New, InProt) ->
+ Ke = bsm_rename_ctx(Ke0, Old, New, InProt),
+ L#l{ke={val_clause,{bin_end,bsm_rename_var(V, Old, New)},Ke}};
+bsm_rename_ctx(#l{ke={val_clause,{bin_seg,V,Sz,U,Type,Fl,Vs},Ke0}}=L,
+ Old, New, InProt) ->
+ Ke = bsm_rename_ctx(Ke0, Old, New, InProt),
+ L#l{ke={val_clause,{bin_seg,bsm_rename_var(V, Old, New),Sz,U,Type,Fl,Vs},Ke}};
+bsm_rename_ctx(#l{ke={val_clause,{bin_int,V,Sz,U,Fl,Val,Vs},Ke0}}=L,
+ Old, New, InProt) ->
+ Ke = bsm_rename_ctx(Ke0, Old, New, InProt),
+ L#l{ke={val_clause,{bin_int,bsm_rename_var(V, Old, New),Sz,U,Fl,Val,Vs},Ke}};
+bsm_rename_ctx(#l{ke={val_clause,Val,Ke0}}=L, Old, New, InProt) ->
+ Ke = bsm_rename_ctx(Ke0, Old, New, InProt),
+ L#l{ke={val_clause,Val,Ke}};
+bsm_rename_ctx(#l{ke={alt,F0,S0}}=L, Old, New, InProt) ->
+ F = bsm_rename_ctx(F0, Old, New, InProt),
+ S = bsm_rename_ctx(S0, Old, New, InProt),
+ L#l{ke={alt,F,S}};
+bsm_rename_ctx(#l{ke={guard,Gcs0}}=L, Old, New, InProt) ->
+ Gcs = bsm_rename_ctx_list(Gcs0, Old, New, InProt),
+ L#l{ke={guard,Gcs}};
+bsm_rename_ctx(#l{ke={guard_clause,G0,B0}}=L, Old, New, InProt) ->
+ G = bsm_rename_ctx(G0, Old, New, InProt),
+ B = bsm_rename_ctx(B0, Old, New, InProt),
+ %% A guard clause may cause unsaved variables to be saved on the stack.
+ %% Since the match state variable Old is an alias for New (uses the
+ %% same register), it is neither in the stack nor register descriptor
+ %% lists and we would crash when we didn't find it unless we remove
+ %% it from the database.
+ bsm_forget_var(L#l{ke={guard_clause,G,B}}, Old);
+bsm_rename_ctx(#l{ke={protected,Ts0,Rs}}=L, Old, New, _InProt) ->
+ InProt = true,
+ Ts = bsm_rename_ctx_list(Ts0, Old, New, InProt),
+ bsm_forget_var(L#l{ke={protected,Ts,Rs}}, Old);
+bsm_rename_ctx(#l{ke={match,Ms0,Rs}}=L, Old, New, InProt) ->
+ Ms = bsm_rename_ctx(Ms0, Old, New, InProt),
+ L#l{ke={match,Ms,Rs}};
+bsm_rename_ctx(#l{ke={guard_match,Ms0,Rs}}=L, Old, New, InProt) ->
+ Ms = bsm_rename_ctx(Ms0, Old, New, InProt),
+ L#l{ke={guard_match,Ms,Rs}};
+bsm_rename_ctx(#l{ke={test,_,_}}=L, _, _, _) -> L;
+bsm_rename_ctx(#l{ke={bif,_,_,_}}=L, _, _, _) -> L;
+bsm_rename_ctx(#l{ke={gc_bif,_,_,_}}=L, _, _, _) -> L;
+bsm_rename_ctx(#l{ke={set,_,_}}=L, _, _, _) -> L;
+bsm_rename_ctx(#l{ke={block,_}}=L, Old, _, false) ->
+ %% This block is not inside a protected. The match context variable cannot
+ %% possibly be live inside the block.
+ bsm_forget_var(L, Old);
+bsm_rename_ctx(#l{ke={block,Bl0}}=L, Old, New, true) ->
+ %% A block in a protected. We must recursively rename the variable
+ %% inside the block.
+ Bl = bsm_rename_ctx_list(Bl0, Old, New, true),
+ bsm_forget_var(L#l{ke={block,Bl}}, Old);
+bsm_rename_ctx(#l{ke={guard_break,Bs,Locked0}}=L0, Old, _New, _InProt) ->
+ Locked = Locked0 -- [Old],
+ L = L0#l{ke={guard_break,Bs,Locked}},
+ bsm_forget_var(L, Old).
+
+bsm_rename_ctx_list([C|Cs], Old, New, InProt) ->
+ [bsm_rename_ctx(C, Old, New, InProt)|
+ bsm_rename_ctx_list(Cs, Old, New, InProt)];
+bsm_rename_ctx_list([], _, _, _) -> [].
+
+bsm_rename_var(Old, Old, New) -> New;
+bsm_rename_var(V, _, _) -> V.
+
+%% bsm_forget_var(#l{}, Variable) -> #l{}
+%% Remove a variable from the variable life-time database.
+
+bsm_forget_var(#l{vdb=Vdb}=L, V) ->
+ L#l{vdb=keydelete(V, 1, Vdb)}.
+
+%% block_cg([Kexpr], Le, Vdb, StackReg, St) -> {[Ainstr],StackReg,St}.
+%% block_cg([Kexpr], Le, StackReg, St) -> {[Ainstr],StackReg,St}.
+
+block_cg(Es, Le, _Vdb, Bef, St) ->
+ block_cg(Es, Le, Bef, St).
+
+block_cg(Es, Le, Bef, #cg{is_top_block=false}=St) ->
+ cg_block(Es, Le#l.i, Le#l.vdb, Bef, St);
+block_cg(Es, Le, Bef, St0) ->
+ {Is0,Aft,St} = cg_block(Es, Le#l.i, Le#l.vdb, Bef,
+ St0#cg{is_top_block=false,need_frame=false}),
+ Is = top_level_block(Is0, Aft, max_reg(Bef#sr.reg), St),
+ {Is,Aft,St#cg{is_top_block=true}}.
+
+cg_block([], _I, _Vdb, Bef, St0) ->
+ {[],Bef,St0};
+cg_block(Kes0, I, Vdb, Bef, St0) ->
+ {Kes2,Int1,St1} =
+ case basic_block(Kes0) of
+ {Kes1,LastI,Args,Rest} ->
+ Ke = hd(Kes1),
+ Fb = Ke#l.i,
+ cg_basic_block(Kes1, Fb, LastI, Args, Vdb, Bef, St0);
+ {Kes1,Rest} ->
+ cg_list(Kes1, I, Vdb, Bef, St0)
+ end,
+ {Kes3,Int2,St2} = cg_block(Rest, I, Vdb, Int1, St1),
+ {Kes2 ++ Kes3,Int2,St2}.
+
+basic_block(Kes) -> basic_block(Kes, []).
+
+basic_block([Le|Les], Acc) ->
+ case collect_block(Le#l.ke) of
+ include -> basic_block(Les, [Le|Acc]);
+ {block_end,As} ->
+ case Acc of
+ [] ->
+ %% If the basic block does not contain any set instructions,
+ %% it serves no useful purpose to do basic block optimizations.
+ {[Le],Les};
+ _ ->
+ {reverse(Acc, [Le]),Le#l.i,As,Les}
+ end;
+ no_block -> {reverse(Acc, [Le]),Les}
+ end.
+
+collect_block({set,_,{binary,_}}) -> no_block;
+collect_block({set,_,_}) -> include;
+collect_block({call,{var,_}=Var,As,_Rs}) -> {block_end,As++[Var]};
+collect_block({call,Func,As,_Rs}) -> {block_end,As++func_vars(Func)};
+collect_block({enter,{var,_}=Var,As})-> {block_end,As++[Var]};
+collect_block({enter,Func,As}) -> {block_end,As++func_vars(Func)};
+collect_block({return,Rs}) -> {block_end,Rs};
+collect_block({break,Bs}) -> {block_end,Bs};
+collect_block(_) -> no_block.
+
+func_vars({remote,M,F}) when element(1, M) =:= var;
+ element(1, F) =:= var ->
+ [M,F];
+func_vars(_) -> [].
+
+%% cg_basic_block([Kexpr], FirstI, LastI, As, Vdb, StackReg, State) ->
+%% {[Ainstr],StackReg,State}.
+
+cg_basic_block(Kes, Fb, Lf, As, Vdb, Bef, St0) ->
+ Res = make_reservation(As, 0),
+ Regs0 = reserve(Res, Bef#sr.reg, Bef#sr.stk),
+ Stk = extend_stack(Bef, Lf, Lf+1, Vdb),
+ Int0 = Bef#sr{reg=Regs0,stk=Stk,res=Res},
+ X0_v0 = x0_vars(As, Fb, Lf, Vdb),
+ {Keis,{Aft,_,St1}} =
+ flatmapfoldl(fun(Ke, St) -> cg_basic_block(Ke, St, Lf, Vdb) end,
+ {Int0,X0_v0,St0}, need_heap(Kes, Fb)),
+ {Keis,Aft,St1}.
+
+cg_basic_block(#l{ke={need_heap,_}}=Ke, {Inta,X0v,Sta}, _Lf, Vdb) ->
+ {Keis,Intb,Stb} = cg(Ke, Vdb, Inta, Sta),
+ {Keis, {Intb,X0v,Stb}};
+cg_basic_block(Ke, {Inta,X0_v1,Sta}, Lf, Vdb) ->
+ {Sis,Intb} = save_carefully(Inta, Ke#l.i, Lf+1, Vdb),
+ {X0_v2,Intc} = allocate_x0(X0_v1, Ke#l.i, Intb),
+ Intd = reserve(Intc),
+ {Keis,Inte,Stb} = cg(Ke, Vdb, Intd, Sta),
+ {Sis ++ Keis, {Inte,X0_v2,Stb}}.
+
+make_reservation([], _) -> [];
+make_reservation([{var,V}|As], I) -> [{I,V}|make_reservation(As, I+1)];
+make_reservation([A|As], I) -> [{I,A}|make_reservation(As, I+1)].
+
+reserve(Sr) -> Sr#sr{reg=reserve(Sr#sr.res, Sr#sr.reg, Sr#sr.stk)}.
+
+reserve([{I,V}|Rs], [free|Regs], Stk) -> [{reserved,I,V}|reserve(Rs, Regs, Stk)];
+reserve([{I,V}|Rs], [{I,V}|Regs], Stk) -> [{I,V}|reserve(Rs, Regs, Stk)];
+reserve([{I,V}|Rs], [{I,Var}|Regs], Stk) ->
+ case on_stack(Var, Stk) of
+ true -> [{reserved,I,V}|reserve(Rs, Regs, Stk)];
+ false -> [{I,Var}|reserve(Rs, Regs, Stk)]
+ end;
+reserve([{I,V}|Rs], [{reserved,I,_}|Regs], Stk) ->
+ [{reserved,I,V}|reserve(Rs, Regs, Stk)];
+%reserve([{I,V}|Rs], [Other|Regs], Stk) -> [Other|reserve(Rs, Regs, Stk)];
+reserve([{I,V}|Rs], [], Stk) -> [{reserved,I,V}|reserve(Rs, [], Stk)];
+reserve([], Regs, _) -> Regs.
+
+extend_stack(Bef, Fb, Lf, Vdb) ->
+ Stk0 = clear_dead_stk(Bef#sr.stk, Fb, Vdb),
+ Saves = [V || {V,F,L} <- Vdb,
+ F < Fb,
+ L >= Lf,
+ not on_stack(V, Stk0)],
+ Stk1 = foldl(fun (V, Stk) -> put_stack(V, Stk) end, Stk0, Saves),
+ Bef#sr.stk ++ lists:duplicate(length(Stk1) - length(Bef#sr.stk), free).
+
+save_carefully(Bef, Fb, Lf, Vdb) ->
+ Stk = Bef#sr.stk,
+ %% New variables that are in use but not on stack.
+ New = [VFL || {V,F,L} = VFL <- Vdb,
+ F < Fb,
+ L >= Lf,
+ not on_stack(V, Stk)],
+ Saves = [V || {V,_,_} <- keysort(2, New)],
+ save_carefully(Saves, Bef, []).
+
+save_carefully([], Bef, Acc) -> {reverse(Acc),Bef};
+save_carefully([V|Vs], Bef, Acc) ->
+ case put_stack_carefully(V, Bef#sr.stk) of
+ error -> {reverse(Acc),Bef};
+ Stk1 ->
+ SrcReg = fetch_reg(V, Bef#sr.reg),
+ Move = {move,SrcReg,fetch_stack(V, Stk1)},
+ {x,_} = SrcReg, %Assertion - must be X register.
+ save_carefully(Vs, Bef#sr{stk=Stk1}, [Move|Acc])
+ end.
+
+x0_vars([], _Fb, _Lf, _Vdb) -> [];
+x0_vars([{var,V}|_], Fb, _Lf, Vdb) ->
+ {V,F,_L} = VFL = vdb_find(V, Vdb),
+ x0_vars1([VFL], Fb, F, Vdb);
+x0_vars([X0|_], Fb, Lf, Vdb) ->
+ x0_vars1([{X0,Lf,Lf}], Fb, Lf, Vdb).
+
+x0_vars1(X0, Fb, Xf, Vdb) ->
+ Vs0 = [VFL || {_V,F,L}=VFL <- Vdb,
+ F >= Fb,
+ L < Xf],
+ Vs1 = keysort(3, Vs0),
+ keysort(2, X0++Vs1).
+
+allocate_x0([], _, Bef) -> {[],Bef#sr{res=[]}};
+allocate_x0([{_,_,L}|Vs], I, Bef) when L =< I ->
+ allocate_x0(Vs, I, Bef);
+allocate_x0([{V,_F,_L}=VFL|Vs], _, Bef) ->
+ {[VFL|Vs],Bef#sr{res=reserve_x0(V, Bef#sr.res)}}.
+
+reserve_x0(V, [_|Res]) -> [{0,V}|Res];
+reserve_x0(V, []) -> [{0,V}].
+
+top_level_block(Keis, #sr{stk=[]}, _MaxRegs, #cg{need_frame=false}) ->
+ Keis;
+top_level_block(Keis, Bef, MaxRegs, _St) ->
+ %% This top block needs an allocate instruction before it, and a
+ %% deallocate instruction before each return.
+ FrameSz = length(Bef#sr.stk),
+ MaxY = FrameSz-1,
+ Keis1 = flatmap(fun ({call_only,Arity,Func}) ->
+ [{call_last,Arity,Func,FrameSz}];
+ ({call_ext_only,Arity,Func}) ->
+ [{call_ext_last,Arity,Func,FrameSz}];
+ ({apply_only,Arity}) ->
+ [{apply_last,Arity,FrameSz}];
+ (return) ->
+ [{deallocate,FrameSz},return];
+ (Tuple) when is_tuple(Tuple) ->
+ [turn_yregs(tuple_size(Tuple), Tuple, MaxY)];
+ (Other) ->
+ [Other]
+ end, Keis),
+ [{allocate_zero,FrameSz,MaxRegs}|Keis1].
+
+%% turn_yregs(Size, Tuple, MaxY) -> Tuple'
+%% Renumber y register so that {y,0} becomes {y,FrameSize-1},
+%% {y,FrameSize-1} becomes {y,0} and so on. This is to make nested
+%% catches work. The code generation algorithm gives a lower register
+%% number to the outer catch, which is wrong.
+
+turn_yregs(0, Tp, _) -> Tp;
+turn_yregs(El, Tp, MaxY) when element(1, element(El, Tp)) =:= yy ->
+ turn_yregs(El-1, setelement(El, Tp, {y,MaxY-element(2, element(El, Tp))}), MaxY);
+turn_yregs(El, Tp, MaxY) when is_list(element(El, Tp)) ->
+ New = map(fun ({yy,YY}) -> {y,MaxY-YY};
+ (Other) -> Other end, element(El, Tp)),
+ turn_yregs(El-1, setelement(El, Tp, New), MaxY);
+turn_yregs(El, Tp, MaxY) ->
+ turn_yregs(El-1, Tp, MaxY).
+
+%% select_cg(Sclause, V, TypeFail, ValueFail, StackReg, State) ->
+%% {Is,StackReg,State}.
+%% Selecting type and value needs two failure labels, TypeFail is the
+%% label to jump to of the next type test when this type fails, and
+%% ValueFail is the label when this type is correct but the value is
+%% wrong. These are different as in the second case there is no need
+%% to try the next type, it will always fail.
+
+select_cg(#l{ke={type_clause,cons,[S]}}, {var,V}, Tf, Vf, Bef, St) ->
+ select_cons(S, V, Tf, Vf, Bef, St);
+select_cg(#l{ke={type_clause,nil,[S]}}, {var,V}, Tf, Vf, Bef, St) ->
+ select_nil(S, V, Tf, Vf, Bef, St);
+select_cg(#l{ke={type_clause,binary,[S]}}, {var,V}, Tf, Vf, Bef, St) ->
+ select_binary(S, V, Tf, Vf, Bef, St);
+select_cg(#l{ke={type_clause,bin_seg,S}}, {var,V}, Tf, _Vf, Bef, St) ->
+ select_bin_segs(S, V, Tf, Bef, St);
+select_cg(#l{ke={type_clause,bin_int,S}}, {var,V}, Tf, _Vf, Bef, St) ->
+ select_bin_segs(S, V, Tf, Bef, St);
+select_cg(#l{ke={type_clause,bin_end,[S]}}, {var,V}, Tf, _Vf, Bef, St) ->
+ select_bin_end(S, V, Tf, Bef, St);
+select_cg(#l{ke={type_clause,Type,Scs}}, {var,V}, Tf, Vf, Bef, St0) ->
+ {Vis,{Aft,St1}} =
+ mapfoldl(fun (S, {Int,Sta}) ->
+ {Val,Is,Inta,Stb} = select_val(S, V, Vf, Bef, Sta),
+ {{Is,[Val]},{sr_merge(Int, Inta),Stb}}
+ end, {void,St0}, Scs),
+ OptVls = combine(lists:sort(combine(Vis))),
+ {Vls,Sis,St2} = select_labels(OptVls, St1, [], []),
+ {select_val_cg(Type, fetch_var(V, Bef), Vls, Tf, Vf, Sis), Aft, St2}.
+
+select_val_cg(tuple, R, [Arity,{f,Lbl}], Tf, Vf, [{label,Lbl}|Sis]) ->
+ [{test,is_tuple,{f,Tf},[R]},{test,test_arity,{f,Vf},[R,Arity]}|Sis];
+select_val_cg(tuple, R, Vls, Tf, Vf, Sis) ->
+ [{test,is_tuple,{f,Tf},[R]},{select_tuple_arity,R,{f,Vf},{list,Vls}}|Sis];
+select_val_cg(Type, R, [Val, {f,Lbl}], Fail, Fail, [{label,Lbl}|Sis]) ->
+ [{test,is_eq_exact,{f,Fail},[R,{Type,Val}]}|Sis];
+select_val_cg(Type, R, [Val, {f,Lbl}], Tf, Vf, [{label,Lbl}|Sis]) ->
+ [{test,select_type_test(Type),{f,Tf},[R]},
+ {test,is_eq_exact,{f,Vf},[R,{Type,Val}]}|Sis];
+select_val_cg(Type, R, Vls0, Tf, Vf, Sis) ->
+ Vls1 = map(fun ({f,_Lbl} = F) -> F;
+ (Value) -> {Type,Value}
+ end, Vls0),
+ [{test,select_type_test(Type),{f,Tf},[R]}, {select_val,R,{f,Vf},{list,Vls1}}|Sis].
+
+select_type_test(integer) -> is_integer;
+select_type_test(atom) -> is_atom;
+select_type_test(float) -> is_float.
+
+combine([{Is,Vs1}, {Is,Vs2}|Vis]) -> combine([{Is,Vs1 ++ Vs2}|Vis]);
+combine([V|Vis]) -> [V|combine(Vis)];
+combine([]) -> [].
+
+select_labels([{Is,Vs}|Vis], St0, Vls, Sis) ->
+ {Lbl,St1} = new_label(St0),
+ select_labels(Vis, St1, add_vls(Vs, Lbl, Vls), [[{label,Lbl}|Is]|Sis]);
+select_labels([], St, Vls, Sis) ->
+ {Vls,append(Sis),St}.
+
+add_vls([V|Vs], Lbl, Acc) ->
+ add_vls(Vs, Lbl, [V, {f,Lbl}|Acc]);
+add_vls([], _, Acc) -> Acc.
+
+select_cons(#l{ke={val_clause,{cons,Es},B},i=I,vdb=Vdb}, V, Tf, Vf, Bef, St0) ->
+ {Eis,Int,St1} = select_extract_cons(V, Es, I, Vdb, Bef, St0),
+ {Bis,Aft,St2} = match_cg(B, Vf, Int, St1),
+ {[{test,is_nonempty_list,{f,Tf},[fetch_var(V, Bef)]}] ++ Eis ++ Bis,Aft,St2}.
+
+select_nil(#l{ke={val_clause,nil,B}}, V, Tf, Vf, Bef, St0) ->
+ {Bis,Aft,St1} = match_cg(B, Vf, Bef, St0),
+ {[{test,is_nil,{f,Tf},[fetch_var(V, Bef)]}] ++ Bis,Aft,St1}.
+
+select_binary(#l{ke={val_clause,{binary,{var,V}},B},i=I,vdb=Vdb},
+ V, Tf, Vf, Bef, St0) ->
+ Int0 = clear_dead(Bef#sr{reg=Bef#sr.reg}, I, Vdb),
+ {Bis,Aft,St1} = match_cg(B, Vf, Int0, St0),
+ CtxReg = fetch_var(V, Int0),
+ Live = max_reg(Bef#sr.reg),
+ {[{test,bs_start_match2,{f,Tf},Live,[CtxReg,V],CtxReg},
+ {bs_save2,CtxReg,{V,V}}|Bis],
+ Aft,St1};
+select_binary(#l{ke={val_clause,{binary,{var,Ivar}},B},i=I,vdb=Vdb},
+ V, Tf, Vf, Bef, St0) ->
+ Regs = put_reg(Ivar, Bef#sr.reg),
+ Int0 = clear_dead(Bef#sr{reg=Regs}, I, Vdb),
+ {Bis,Aft,St1} = match_cg(B, Vf, Int0, St0),
+ CtxReg = fetch_var(Ivar, Int0),
+ Live = max_reg(Bef#sr.reg),
+ {[{test,bs_start_match2,{f,Tf},Live,[fetch_var(V, Bef),Ivar],CtxReg},
+ {bs_save2,CtxReg,{Ivar,Ivar}}|Bis],
+ Aft,St1}.
+
+%% New instructions for selection of binary segments.
+
+select_bin_segs(Scs, Ivar, Tf, Bef, St) ->
+ match_fmf(fun(S, Fail, Sta) ->
+ select_bin_seg(S, Ivar, Fail, Bef, Sta) end,
+ Tf, St, Scs).
+
+select_bin_seg(#l{ke={val_clause,{bin_seg,Ctx,Size,U,T,Fs0,Es},B},i=I,vdb=Vdb,a=A},
+ Ivar, Fail, Bef, St0) ->
+ Fs = [{anno,A}|Fs0],
+ {Mis,Int,St1} = select_extract_bin(Es, Size, U, T, Fs, Fail,
+ I, Vdb, Bef, Ctx, B, St0),
+ {Bis,Aft,St2} = match_cg(B, Fail, Int, St1),
+ CtxReg = fetch_var(Ctx, Bef),
+ Is = if
+ Mis =:= [] ->
+ %% No bs_restore2 instruction needed if no match instructions.
+ Bis;
+ true ->
+ [{bs_restore2,CtxReg,{Ctx,Ivar}}|Mis++Bis]
+ end,
+ {Is,Aft,St2};
+select_bin_seg(#l{ke={val_clause,{bin_int,Ctx,Sz,U,Fs,Val,Es},B},i=I,vdb=Vdb},
+ Ivar, Fail, Bef, St0) ->
+ {Mis,Int,St1} = select_extract_int(Es, Val, Sz, U, Fs, Fail,
+ I, Vdb, Bef, Ctx, St0),
+ {Bis,Aft,St2} = match_cg(B, Fail, Int, St1),
+ CtxReg = fetch_var(Ctx, Bef),
+ {[{bs_restore2,CtxReg,{Ctx,Ivar}}|Mis] ++ Bis,Aft,St2}.
+
+select_extract_int([{var,Tl}], Val, {integer,Sz}, U, Fs, Vf,
+ I, Vdb, Bef, Ctx, St) ->
+ Bits = U*Sz,
+ Bin = case member(big, Fs) of
+ true ->
+ <<Val:Bits>>;
+ false ->
+ true = member(little, Fs), %Assertion.
+ <<Val:Bits/little>>
+ end,
+ Bits = bit_size(Bin), %Assertion.
+ CtxReg = fetch_var(Ctx, Bef),
+ Is = if
+ Bits =:= 0 ->
+ [{bs_save2,CtxReg,{Ctx,Tl}}];
+ true ->
+ [{test,bs_match_string,{f,Vf},[CtxReg,Bin]},
+ {bs_save2,CtxReg,{Ctx,Tl}}]
+ end,
+ {Is,clear_dead(Bef, I, Vdb),St}.
+
+select_extract_bin([{var,Hd},{var,Tl}], Size0, Unit, Type, Flags, Vf,
+ I, Vdb, Bef, Ctx, _Body, St) ->
+ SizeReg = get_bin_size_reg(Size0, Bef),
+ {Es,Aft} =
+ case vdb_find(Hd, Vdb) of
+ {_,_,Lhd} when Lhd =< I ->
+ %% The extracted value will not be used.
+ CtxReg = fetch_var(Ctx, Bef),
+ Live = max_reg(Bef#sr.reg),
+ Skip = build_skip_instr(Type, Vf, CtxReg, Live,
+ SizeReg, Unit, Flags),
+ {[Skip,{bs_save2,CtxReg,{Ctx,Tl}}],Bef};
+ {_,_,_} ->
+ Reg = put_reg(Hd, Bef#sr.reg),
+ Int1 = Bef#sr{reg=Reg},
+ Rhd = fetch_reg(Hd, Reg),
+ CtxReg = fetch_reg(Ctx, Reg),
+ Live = max_reg(Bef#sr.reg),
+ {[build_bs_instr(Type, Vf, CtxReg, Live, SizeReg,
+ Unit, Flags, Rhd),
+ {bs_save2,CtxReg,{Ctx,Tl}}],Int1}
+ end,
+ {Es,clear_dead(Aft, I, Vdb),St};
+select_extract_bin([{var,Hd}], Size0, Unit, binary, Flags, Vf,
+ I, Vdb, Bef, Ctx, Body, St) ->
+ SizeReg = get_bin_size_reg(Size0, Bef),
+ {Es,Aft} =
+ case vdb_find(Hd, Vdb) of
+ {_,_,Lhd} when Lhd =< I ->
+ CtxReg = fetch_var(Ctx, Bef),
+ {case SizeReg =:= {atom,all} andalso is_context_unused(Body) of
+ true when Unit =:= 1 ->
+ [];
+ true ->
+ [{test,bs_test_unit,{f,Vf},[CtxReg,Unit]}];
+ false ->
+ [{test,bs_skip_bits2,{f,Vf},
+ [CtxReg,SizeReg,Unit,{field_flags,Flags}]}]
+ end,Bef};
+ {_,_,_} ->
+ case is_context_unused(Body) of
+ false ->
+ Reg = put_reg(Hd, Bef#sr.reg),
+ Int1 = Bef#sr{reg=Reg},
+ Rhd = fetch_reg(Hd, Reg),
+ CtxReg = fetch_reg(Ctx, Reg),
+ Name = bs_get_binary2,
+ Live = max_reg(Bef#sr.reg),
+ {[{test,Name,{f,Vf},Live,
+ [CtxReg,SizeReg,Unit,{field_flags,Flags}],Rhd}],
+ Int1};
+ true ->
+ %% Since the matching context will not be used again,
+ %% we can reuse its register. Reusing the register
+ %% opens some interesting optimizations in the
+ %% run-time system.
+
+ Reg0 = Bef#sr.reg,
+ CtxReg = fetch_reg(Ctx, Reg0),
+ Reg = replace_reg_contents(Ctx, Hd, Reg0),
+ Int1 = Bef#sr{reg=Reg},
+ Name = bs_get_binary2,
+ Live = max_reg(Int1#sr.reg),
+ {[{test,Name,{f,Vf},Live,
+ [CtxReg,SizeReg,Unit,{field_flags,Flags}],CtxReg}],
+ Int1}
+ end
+ end,
+ {Es,clear_dead(Aft, I, Vdb),St}.
+
+%% is_context_unused(Ke) -> true | false
+%% Simple heurististic to determine whether the code that follows will
+%% use the current matching context again. (The information of liveness
+%% calculcated by v3_life is too conservative to be useful for this purpose.)
+%% 'true' means that the code that follows will definitely not use the context
+%% again (because it is a block, not guard or matching code); 'false' that we
+%% are not sure (there is either a guard, or more matching, either which may
+%% reference the context again).
+
+is_context_unused(#l{ke=Ke}) -> is_context_unused(Ke);
+is_context_unused({block,_}) -> true;
+is_context_unused(_) -> false.
+
+select_bin_end(#l{ke={val_clause,{bin_end,Ctx},B}},
+ Ivar, Tf, Bef, St0) ->
+ {Bis,Aft,St2} = match_cg(B, Tf, Bef, St0),
+ CtxReg = fetch_var(Ctx, Bef),
+ {[{bs_restore2,CtxReg,{Ctx,Ivar}},
+ {test,bs_test_tail2,{f,Tf},[CtxReg,0]}|Bis],Aft,St2}.
+
+get_bin_size_reg({var,V}, Bef) ->
+ fetch_var(V, Bef);
+get_bin_size_reg(Literal, _Bef) ->
+ Literal.
+
+build_bs_instr(Type, Vf, CtxReg, Live, SizeReg, Unit, Flags, Rhd) ->
+ {Format,Name} = case Type of
+ integer -> {plain,bs_get_integer2};
+ float -> {plain,bs_get_float2};
+ binary -> {plain,bs_get_binary2};
+ utf8 -> {utf,bs_get_utf8};
+ utf16 -> {utf,bs_get_utf16};
+ utf32 -> {utf,bs_get_utf32}
+ end,
+ case Format of
+ plain ->
+ {test,Name,{f,Vf},Live,
+ [CtxReg,SizeReg,Unit,{field_flags,Flags}],Rhd};
+ utf ->
+ {test,Name,{f,Vf},Live,
+ [CtxReg,{field_flags,Flags}],Rhd}
+ end.
+
+build_skip_instr(Type, Vf, CtxReg, Live, SizeReg, Unit, Flags) ->
+ {Format,Name} = case Type of
+ utf8 -> {utf,bs_skip_utf8};
+ utf16 -> {utf,bs_skip_utf16};
+ utf32 -> {utf,bs_skip_utf32};
+ _ -> {plain,bs_skip_bits2}
+ end,
+ case Format of
+ plain ->
+ {test,Name,{f,Vf},[CtxReg,SizeReg,Unit,{field_flags,Flags}]};
+ utf ->
+ {test,Name,{f,Vf},[CtxReg,Live,{field_flags,Flags}]}
+ end.
+
+select_val(#l{ke={val_clause,{tuple,Es},B},i=I,vdb=Vdb}, V, Vf, Bef, St0) ->
+ {Eis,Int,St1} = select_extract_tuple(V, Es, I, Vdb, Bef, St0),
+ {Bis,Aft,St2} = match_cg(B, Vf, Int, St1),
+ {length(Es),Eis ++ Bis,Aft,St2};
+select_val(#l{ke={val_clause,{_,Val},B}}, _V, Vf, Bef, St0) ->
+ {Bis,Aft,St1} = match_cg(B, Vf, Bef, St0),
+ {Val,Bis,Aft,St1}.
+
+%% select_extract_tuple(Src, [V], I, Vdb, StackReg, State) ->
+%% {[E],StackReg,State}.
+%% Extract tuple elements, but only if they do not immediately die.
+
+select_extract_tuple(Src, Vs, I, Vdb, Bef, St) ->
+ F = fun ({var,V}, {Int0,Elem}) ->
+ case vdb_find(V, Vdb) of
+ {V,_,L} when L =< I -> {[], {Int0,Elem+1}};
+ _Other ->
+ Reg1 = put_reg(V, Int0#sr.reg),
+ Int1 = Int0#sr{reg=Reg1},
+ Rsrc = fetch_var(Src, Int1),
+ {[{get_tuple_element,Rsrc,Elem,fetch_reg(V, Reg1)}],
+ {Int1,Elem+1}}
+ end
+ end,
+ {Es,{Aft,_}} = flatmapfoldl(F, {Bef,0}, Vs),
+ {Es,Aft,St}.
+
+select_extract_cons(Src, [{var,Hd}, {var,Tl}], I, Vdb, Bef, St) ->
+ {Es,Aft} = case {vdb_find(Hd, Vdb), vdb_find(Tl, Vdb)} of
+ {{_,_,Lhd}, {_,_,Ltl}} when Lhd =< I, Ltl =< I ->
+ %% Both head and tail are dead. No need to generate
+ %% any instruction.
+ {[], Bef};
+ _ ->
+ %% At least one of head and tail will be used,
+ %% but we must always fetch both. We will call
+ %% clear_dead/2 to allow reuse of the register
+ %% in case only of them is used.
+
+ Reg0 = put_reg(Tl, put_reg(Hd, Bef#sr.reg)),
+ Int0 = Bef#sr{reg=Reg0},
+ Rsrc = fetch_var(Src, Int0),
+ Rhd = fetch_reg(Hd, Reg0),
+ Rtl = fetch_reg(Tl, Reg0),
+ Int1 = clear_dead(Int0, I, Vdb),
+ {[{get_list,Rsrc,Rhd,Rtl}], Int1}
+ end,
+ {Es,Aft,St}.
+
+
+guard_clause_cg(#l{ke={guard_clause,G,B},vdb=Vdb}, Fail, Bef, St0) ->
+ {Gis,Int,St1} = guard_cg(G, Fail, Vdb, Bef, St0),
+ {Bis,Aft,St} = match_cg(B, Fail, Int, St1),
+ {Gis ++ Bis,Aft,St}.
+
+%% guard_cg(Guard, Fail, Vdb, StackReg, State) ->
+%% {[Ainstr],StackReg,State}.
+%% A guard is a boolean expression of tests. Tests return true or
+%% false. A fault in a test causes the test to return false. Tests
+%% never return the boolean, instead we generate jump code to go to
+%% the correct exit point. Primops and tests all go to the next
+%% instruction on success or jump to a failure label.
+
+guard_cg(#l{ke={protected,Ts,Rs},i=I,vdb=Pdb}, Fail, _Vdb, Bef, St) ->
+ protected_cg(Ts, Rs, Fail, I, Pdb, Bef, St);
+guard_cg(#l{ke={block,Ts},i=I,vdb=Bdb}, Fail, _Vdb, Bef, St) ->
+ guard_cg_list(Ts, Fail, I, Bdb, Bef, St);
+guard_cg(#l{ke={test,Test,As},i=I,vdb=_Tdb}, Fail, Vdb, Bef, St) ->
+ test_cg(Test, As, Fail, I, Vdb, Bef, St);
+guard_cg(G, _Fail, Vdb, Bef, St) ->
+ %%ok = io:fwrite("cg ~w: ~p~n", [?LINE,{G,Fail,Vdb,Bef}]),
+ {Gis,Aft,St1} = cg(G, Vdb, Bef, St),
+ %%ok = io:fwrite("cg ~w: ~p~n", [?LINE,{Aft}]),
+ {Gis,Aft,St1}.
+
+%% protected_cg([Kexpr], [Ret], Fail, I, Vdb, Bef, St) -> {[Ainstr],Aft,St}.
+%% Do a protected. Protecteds without return values are just done
+%% for effect, the return value is not checked, success passes on to
+%% the next instruction and failure jumps to Fail. If there are
+%% return values then these must be set to 'false' on failure,
+%% control always passes to the next instruction.
+
+protected_cg(Ts, [], Fail, I, Vdb, Bef, St0) ->
+ %% Protect these calls, revert when done.
+ {Tis,Aft,St1} = guard_cg_list(Ts, Fail, I, Vdb, Bef,
+ St0#cg{bfail=Fail}),
+ {Tis,Aft,St1#cg{bfail=St0#cg.bfail}};
+protected_cg(Ts, Rs, _Fail, I, Vdb, Bef, St0) ->
+ {Pfail,St1} = new_label(St0),
+ {Psucc,St2} = new_label(St1),
+ {Tis,Aft,St3} = guard_cg_list(Ts, Pfail, I, Vdb, Bef,
+ St2#cg{bfail=Pfail}),
+ %%ok = io:fwrite("cg ~w: ~p~n", [?LINE,{Rs,I,Vdb,Aft}]),
+ %% Set return values to false.
+ Mis = map(fun ({var,V}) -> {move,{atom,false},fetch_var(V, Aft)} end, Rs),
+ {Tis ++ [{jump,{f,Psucc}},
+ {label,Pfail}] ++ Mis ++ [{label,Psucc}],
+ Aft,St3#cg{bfail=St0#cg.bfail}}.
+
+%% test_cg(TestName, Args, Fail, I, Vdb, Bef, St) -> {[Ainstr],Aft,St}.
+%% Generate test instruction. Use explicit fail label here.
+
+test_cg(Test, As, Fail, I, Vdb, Bef, St) ->
+ Args = cg_reg_args(As, Bef),
+ Aft = clear_dead(Bef, I, Vdb),
+ {[beam_utils:bif_to_test(Test, Args, {f,Fail})],Aft,St}.
+
+%% guard_cg_list([Kexpr], Fail, I, Vdb, StackReg, St) ->
+%% {[Ainstr],StackReg,St}.
+
+guard_cg_list(Kes, Fail, I, Vdb, Bef, St0) ->
+ {Keis,{Aft,St1}} =
+ flatmapfoldl(fun (Ke, {Inta,Sta}) ->
+ {Keis,Intb,Stb} =
+ guard_cg(Ke, Fail, Vdb, Inta, Sta),
+ {Keis,{Intb,Stb}}
+ end, {Bef,St0}, need_heap(Kes, I)),
+ {Keis,Aft,St1}.
+
+%% match_fmf(Fun, LastFail, State, [Clause]) -> {Is,Aft,State}.
+%% This is a special flatmapfoldl for match code gen where we
+%% generate a "failure" label for each clause. The last clause uses
+%% an externally generated failure label, LastFail. N.B. We do not
+%% know or care how the failure labels are used.
+
+match_fmf(F, LastFail, St, [H]) ->
+ F(H, LastFail, St);
+match_fmf(F, LastFail, St0, [H|T]) ->
+ {Fail,St1} = new_label(St0),
+ {R,Aft1,St2} = F(H, Fail, St1),
+ {Rs,Aft2,St3} = match_fmf(F, LastFail, St2, T),
+ {R ++ [{label,Fail}] ++ Rs,sr_merge(Aft1, Aft2),St3}.
+
+%% call_cg(Func, [Arg], [Ret], Le, Vdb, StackReg, State) ->
+%% {[Ainstr],StackReg,State}.
+%% enter_cg(Func, [Arg], Le, Vdb, Bef, St) -> {[Ainstr],Aft,St}.
+%% Call and enter first put the arguments into registers and save any
+%% other registers, then clean up and compress the stack and set the
+%% frame size. Finally the actual call is made. Call then needs the
+%% return values filled in.
+
+call_cg({var,_V} = Var, As, Rs, Le, Vdb, Bef, St0) ->
+ {Sis,Int} = cg_setup_call(As++[Var], Bef, Le#l.i, Vdb),
+ %% Put return values in registers.
+ Reg = load_vars(Rs, clear_regs(Int#sr.reg)),
+ %% Build complete code and final stack/register state.
+ Arity = length(As),
+ {Frees,Aft} = free_dead(clear_dead(Int#sr{reg=Reg}, Le#l.i, Vdb)),
+ {Sis ++ Frees ++ [{call_fun,Arity}],Aft,
+ need_stack_frame(St0)};
+call_cg({remote,Mod,Name}, As, Rs, Le, Vdb, Bef, St0)
+ when element(1, Mod) =:= var;
+ element(1, Name) =:= var ->
+ {Sis,Int} = cg_setup_call(As++[Mod,Name], Bef, Le#l.i, Vdb),
+ %% Put return values in registers.
+ Reg = load_vars(Rs, clear_regs(Int#sr.reg)),
+ %% Build complete code and final stack/register state.
+ Arity = length(As),
+ Call = {apply,Arity},
+ St = need_stack_frame(St0),
+ %%{Call,St1} = build_call(Func, Arity, St0),
+ {Frees,Aft} = free_dead(clear_dead(Int#sr{reg=Reg}, Le#l.i, Vdb)),
+ {Sis ++ Frees ++ [Call],Aft,St};
+call_cg(Func, As, Rs, Le, Vdb, Bef, St0) ->
+ case St0 of
+ #cg{bfail=Fail} when Fail =/= 0 ->
+ %% Inside a guard. The only allowed function call is to
+ %% erlang:error/1,2. We will generate the following code:
+ %%
+ %% jump FailureLabel
+ %% move {atom,ok} DestReg
+ %%
+ %% The 'move' instruction will never be executed, but we
+ %% generate it anyway in case the beam_validator is run
+ %% on unoptimized code.
+ {remote,{atom,erlang},{atom,error}} = Func, %Assertion.
+ [{var,DestVar}] = Rs,
+ Int0 = clear_dead(Bef, Le#l.i, Vdb),
+ Reg = put_reg(DestVar, Int0#sr.reg),
+ Int = Int0#sr{reg=Reg},
+ Dst = fetch_reg(DestVar, Reg),
+ {[{jump,{f,Fail}},{move,{atom,ok},Dst}],
+ clear_dead(Int, Le#l.i, Vdb),St0};
+ #cg{} ->
+ %% Ordinary function call in a function body.
+ {Sis,Int} = cg_setup_call(As, Bef, Le#l.i, Vdb),
+ %% Put return values in registers.
+ Reg = load_vars(Rs, clear_regs(Int#sr.reg)),
+ %% Build complete code and final stack/register state.
+ Arity = length(As),
+ {Call,St1} = build_call(Func, Arity, St0),
+ {Frees,Aft} = free_dead(clear_dead(Int#sr{reg=Reg}, Le#l.i, Vdb)),
+ {Sis ++ Frees ++ Call,Aft,St1}
+ end.
+
+build_call({remote,{atom,erlang},{atom,'!'}}, 2, St0) ->
+ {[send],need_stack_frame(St0)};
+build_call({remote,{atom,Mod},{atom,Name}}, Arity, St0) ->
+ {[{call_ext,Arity,{extfunc,Mod,Name,Arity}}],need_stack_frame(St0)};
+build_call(Name, Arity, St0) when is_atom(Name) ->
+ {Lbl,St1} = local_func_label(Name, Arity, need_stack_frame(St0)),
+ {[{call,Arity,{f,Lbl}}],St1}.
+
+free_dead(#sr{stk=Stk0}=Aft) ->
+ {Instr,Stk} = free_dead(Stk0, 0, [], []),
+ {Instr,Aft#sr{stk=Stk}}.
+
+free_dead([dead|Stk], Y, Instr, StkAcc) ->
+ %% Note: kill/1 is equivalent to init/1 (translated by beam_asm).
+ %% We use kill/1 to help further optimisation passes.
+ free_dead(Stk, Y+1, [{kill,{yy,Y}}|Instr], [free|StkAcc]);
+free_dead([Any|Stk], Y, Instr, StkAcc) ->
+ free_dead(Stk, Y+1, Instr, [Any|StkAcc]);
+free_dead([], _, Instr, StkAcc) -> {Instr,reverse(StkAcc)}.
+
+enter_cg({var,_V} = Var, As, Le, Vdb, Bef, St0) ->
+ {Sis,Int} = cg_setup_call(As++[Var], Bef, Le#l.i, Vdb),
+ %% Build complete code and final stack/register state.
+ Arity = length(As),
+ {Sis ++ [{call_fun,Arity},return],
+ clear_dead(Int#sr{reg=clear_regs(Int#sr.reg)}, Le#l.i, Vdb),
+ need_stack_frame(St0)};
+enter_cg({remote,Mod,Name}, As, Le, Vdb, Bef, St0)
+ when element(1, Mod) =:= var;
+ element(1, Name) =:= var ->
+ {Sis,Int} = cg_setup_call(As++[Mod,Name], Bef, Le#l.i, Vdb),
+ %% Build complete code and final stack/register state.
+ Arity = length(As),
+ Call = {apply_only,Arity},
+ St = need_stack_frame(St0),
+ {Sis ++ [Call],
+ clear_dead(Int#sr{reg=clear_regs(Int#sr.reg)}, Le#l.i, Vdb),
+ St};
+enter_cg(Func, As, Le, Vdb, Bef, St0) ->
+ {Sis,Int} = cg_setup_call(As, Bef, Le#l.i, Vdb),
+ %% Build complete code and final stack/register state.
+ Arity = length(As),
+ {Call,St1} = build_enter(Func, Arity, St0),
+ {Sis ++ Call,
+ clear_dead(Int#sr{reg=clear_regs(Int#sr.reg)}, Le#l.i, Vdb),
+ St1}.
+
+build_enter({remote,{atom,erlang},{atom,'!'}}, 2, St0) ->
+ {[send,return],need_stack_frame(St0)};
+build_enter({remote,{atom,Mod},{atom,Name}}, Arity, St0) ->
+ St1 = case trap_bif(Mod, Name, Arity) of
+ true -> need_stack_frame(St0);
+ false -> St0
+ end,
+ {[{call_ext_only,Arity,{extfunc,Mod,Name,Arity}}],St1};
+build_enter(Name, Arity, St0) when is_atom(Name) ->
+ {Lbl,St1} = local_func_label(Name, Arity, St0),
+ {[{call_only,Arity,{f,Lbl}}],St1}.
+
+%% local_func_label(Name, Arity, State) -> {Label,State'}
+%% local_func_label({Name,Arity}, State) -> {Label,State'}
+%% Get the function entry label for a local function.
+
+local_func_label(Name, Arity, St) ->
+ local_func_label({Name,Arity}, St).
+
+local_func_label(Key, #cg{functable=Tab}=St0) ->
+ case gb_trees:lookup(Key, Tab) of
+ {value,Label} ->
+ {Label,St0};
+ none ->
+ {Label,St} = new_label(St0),
+ {Label,St#cg{functable=gb_trees:insert(Key, Label, Tab)}}
+ end.
+
+%% need_stack_frame(State) -> State'
+%% Make a note in the state that this function will need a stack frame.
+
+need_stack_frame(#cg{need_frame=true}=St) -> St;
+need_stack_frame(St) -> St#cg{need_frame=true}.
+
+%% trap_bif(Mod, Name, Arity) -> true|false
+%% Trap bifs that need a stack frame.
+
+trap_bif(erlang, link, 1) -> true;
+trap_bif(erlang, unlink, 1) -> true;
+trap_bif(erlang, monitor_node, 2) -> true;
+trap_bif(erlang, group_leader, 2) -> true;
+trap_bif(erlang, exit, 2) -> true;
+trap_bif(_, _, _) -> false.
+
+%% bif_cg(Bif, [Arg], [Ret], Le, Vdb, StackReg, State) ->
+%% {[Ainstr],StackReg,State}.
+
+bif_cg(bs_context_to_binary=Instr, [Src0], [], Le, Vdb, Bef, St0) ->
+ [Src] = cg_reg_args([Src0], Bef),
+ {[{Instr,Src}],clear_dead(Bef, Le#l.i, Vdb), St0};
+bif_cg(dsetelement, [Index0,Tuple0,New0], _Rs, Le, Vdb, Bef, St0) ->
+ [New,Tuple,{integer,Index1}] = cg_reg_args([New0,Tuple0,Index0], Bef),
+ Index = Index1-1,
+ {[{set_tuple_element,New,Tuple,Index}],
+ clear_dead(Bef, Le#l.i, Vdb), St0};
+bif_cg({make_fun,Func,Arity,Index,Uniq}, As, Rs, Le, Vdb, Bef, St0) ->
+ %% This behaves more like a function call.
+ {Sis,Int} = cg_setup_call(As, Bef, Le#l.i, Vdb),
+ Reg = load_vars(Rs, clear_regs(Int#sr.reg)),
+ {FuncLbl,St1} = local_func_label(Func, Arity, St0),
+ MakeFun = {make_fun2,{f,FuncLbl},Index,Uniq,length(As)},
+ {Sis ++ [MakeFun],
+ clear_dead(Int#sr{reg=Reg}, Le#l.i, Vdb),
+ St1};
+bif_cg(bs_init_writable=I, As, Rs, Le, Vdb, Bef, St) ->
+ %% This behaves like a function call.
+ {Sis,Int} = cg_setup_call(As, Bef, Le#l.i, Vdb),
+ Reg = load_vars(Rs, clear_regs(Int#sr.reg)),
+ {Sis++[I],clear_dead(Int#sr{reg=Reg}, Le#l.i, Vdb),St};
+bif_cg(Bif, As, [{var,V}], Le, Vdb, Bef, St0) ->
+ Ars = cg_reg_args(As, Bef),
+
+ %% If we are inside a catch and in a body (not in guard) and the
+ %% BIF may fail, we must save everything that will be alive after
+ %% the catch (because the code after the code assumes that all
+ %% variables that are live are stored on the stack).
+ %%
+ %% Currently, we are somewhat pessimistic in
+ %% that we save any variable that will be live after this BIF call.
+
+ {Sis,Int0} = case St0#cg.in_catch andalso
+ St0#cg.bfail =:= 0 andalso
+ not erl_bifs:is_safe(erlang, Bif, length(As)) of
+ true -> adjust_stack(Bef, Le#l.i, Le#l.i+1, Vdb);
+ false -> {[],Bef}
+ end,
+ Int1 = clear_dead(Int0, Le#l.i, Vdb),
+ Reg = put_reg(V, Int1#sr.reg),
+ Int = Int1#sr{reg=Reg},
+ Dst = fetch_reg(V, Reg),
+ BifFail = {f,St0#cg.bfail},
+ {Sis++[{bif,Bif,BifFail,Ars,Dst}],
+ clear_dead(Int, Le#l.i, Vdb), St0}.
+
+
+%% gc_bif_cg(Bif, [Arg], [Ret], Le, Vdb, StackReg, State) ->
+%% {[Ainstr],StackReg,State}.
+
+gc_bif_cg(Bif, As, [{var,V}], Le, Vdb, Bef, St0) ->
+ Ars = cg_reg_args(As, Bef),
+
+ %% If we are inside a catch and in a body (not in guard) and the
+ %% BIF may fail, we must save everything that will be alive after
+ %% the catch (because the code after the code assumes that all
+ %% variables that are live are stored on the stack).
+ %%
+ %% Currently, we are somewhat pessimistic in
+ %% that we save any variable that will be live after this BIF call.
+
+ {Sis,Int0} =
+ case St0#cg.in_catch andalso St0#cg.bfail =:= 0 of
+ true -> adjust_stack(Bef, Le#l.i, Le#l.i+1, Vdb);
+ false -> {[],Bef}
+ end,
+
+ Int1 = clear_dead(Int0, Le#l.i, Vdb),
+ Reg = put_reg(V, Int1#sr.reg),
+ Int = Int1#sr{reg=Reg},
+ Dst = fetch_reg(V, Reg),
+ BifFail = {f,St0#cg.bfail},
+ {Sis++[{gc_bif,Bif,BifFail,max_reg(Bef#sr.reg),Ars,Dst}],
+ clear_dead(Int, Le#l.i, Vdb), St0}.
+
+%% recv_loop_cg(TimeOut, ReceiveVar, ReceiveMatch, TimeOutExprs,
+%% [Ret], Le, Vdb, Bef, St) -> {[Ainstr],Aft,St}.
+
+recv_loop_cg(Te, Rvar, Rm, Tes, Rs, Le, Vdb, Bef, St0) ->
+ {Sis,Int0} = adjust_stack(Bef, Le#l.i, Le#l.i, Vdb),
+ Int1 = Int0#sr{reg=clear_regs(Int0#sr.reg)},
+ %% Get labels.
+ {Rl,St1} = new_label(St0),
+ {Tl,St2} = new_label(St1),
+ {Bl,St3} = new_label(St2),
+ St4 = St3#cg{break=Bl,recv=Rl}, %Set correct receive labels
+ {Ris,Raft,St5} = cg_recv_mesg(Rvar, Rm, Tl, Int1, St4),
+ {Wis,Taft,St6} = cg_recv_wait(Te, Tes, Le#l.i, Int1, St5),
+ Int2 = sr_merge(Raft, Taft), %Merge stack/registers
+ Reg = load_vars(Rs, Int2#sr.reg),
+ {Sis ++ Ris ++ [{label,Tl}] ++ Wis ++ [{label,Bl}],
+ clear_dead(Int2#sr{reg=Reg}, Le#l.i, Vdb),
+ St6#cg{break=St0#cg.break,recv=St0#cg.recv}}.
+
+%% cg_recv_mesg( ) -> {[Ainstr],Aft,St}.
+
+cg_recv_mesg({var,R}, Rm, Tl, Bef, St0) ->
+ Int0 = Bef#sr{reg=put_reg(R, Bef#sr.reg)},
+ Ret = fetch_reg(R, Int0#sr.reg),
+ %% Int1 = clear_dead(Int0, I, Rm#l.vdb),
+ Int1 = Int0,
+ {Mis,Int2,St1} = match_cg(Rm, none, Int1, St0),
+ {[{label,St1#cg.recv},{loop_rec,{f,Tl},Ret}|Mis],Int2,St1}.
+
+%% cg_recv_wait(Te, Tes, I, Vdb, Int2, St3) -> {[Ainstr],Aft,St}.
+
+cg_recv_wait({atom,infinity}, Tes, I, Bef, St0) ->
+ %% We know that the 'after' body will never be executed.
+ %% But to keep the stack and register information up to date,
+ %% we will generate the code for the 'after' body, and then discard it.
+ Int1 = clear_dead(Bef, I, Tes#l.vdb),
+ {_,Int2,St1} = cg_block(Tes#l.ke, Tes#l.i, Tes#l.vdb,
+ Int1#sr{reg=clear_regs(Int1#sr.reg)}, St0),
+ {[{wait,{f,St1#cg.recv}}],Int2,St1};
+cg_recv_wait({integer,0}, Tes, _I, Bef, St0) ->
+ {Tis,Int,St1} = cg_block(Tes#l.ke, Tes#l.i, Tes#l.vdb, Bef, St0),
+ {[timeout|Tis],Int,St1};
+cg_recv_wait(Te, Tes, I, Bef, St0) ->
+ Reg = cg_reg_arg(Te, Bef),
+ %% Must have empty registers here! Bug if anything in registers.
+ Int0 = clear_dead(Bef, I, Tes#l.vdb),
+ {Tis,Int,St1} = cg_block(Tes#l.ke, Tes#l.i, Tes#l.vdb,
+ Int0#sr{reg=clear_regs(Int0#sr.reg)}, St0),
+ {[{wait_timeout,{f,St1#cg.recv},Reg},timeout] ++ Tis,Int,St1}.
+
+%% recv_next_cg(Le, Vdb, StackReg, St) -> {[Ainstr],StackReg,St}.
+%% Use adjust stack to clear stack, but only need it for Aft.
+
+recv_next_cg(Le, Vdb, Bef, St) ->
+ {Sis,Aft} = adjust_stack(Bef, Le#l.i, Le#l.i+1, Vdb),
+ {[{loop_rec_end,{f,St#cg.recv}}] ++ Sis,Aft,St}. %Joke
+
+%% try_cg(TryBlock, [BodyVar], TryBody, [ExcpVar], TryHandler, [Ret],
+%% Le, Vdb, StackReg, St) -> {[Ainstr],StackReg,St}.
+
+try_cg(Ta, Vs, Tb, Evs, Th, Rs, Le, Vdb, Bef, St0) ->
+ {B,St1} = new_label(St0), %Body label
+ {H,St2} = new_label(St1), %Handler label
+ {E,St3} = new_label(St2), %End label
+ TryTag = Ta#l.i,
+ Int1 = Bef#sr{stk=put_catch(TryTag, Bef#sr.stk)},
+ TryReg = fetch_stack({catch_tag,TryTag}, Int1#sr.stk),
+ {Ais,Int2,St4} = cg(Ta, Vdb, Int1, St3#cg{break=B,in_catch=true}),
+ Int3 = Int2#sr{stk=drop_catch(TryTag, Int2#sr.stk)},
+ St5 = St4#cg{break=E,in_catch=St3#cg.in_catch},
+ {Bis,Baft,St6} = cg(Tb, Vdb, Int3#sr{reg=load_vars(Vs, Int3#sr.reg)}, St5),
+ {His,Haft,St7} = cg(Th, Vdb, Int3#sr{reg=load_vars(Evs, Int3#sr.reg)}, St6),
+ Int4 = sr_merge(Baft, Haft), %Merge stack/registers
+ Aft = Int4#sr{reg=load_vars(Rs, Int4#sr.reg)},
+ {[{'try',TryReg,{f,H}}] ++ Ais ++
+ [{label,B},{try_end,TryReg}] ++ Bis ++
+ [{label,H},{try_case,TryReg}] ++ His ++
+ [{label,E}],
+ clear_dead(Aft, Le#l.i, Vdb),
+ St7#cg{break=St0#cg.break}}.
+
+try_enter_cg(Ta, Vs, Tb, Evs, Th, Le, Vdb, Bef, St0) ->
+ {B,St1} = new_label(St0), %Body label
+ {H,St2} = new_label(St1), %Handler label
+ TryTag = Ta#l.i,
+ Int1 = Bef#sr{stk=put_catch(TryTag, Bef#sr.stk)},
+ TryReg = fetch_stack({catch_tag,TryTag}, Int1#sr.stk),
+ {Ais,Int2,St3} = cg(Ta, Vdb, Int1, St2#cg{break=B,in_catch=true}),
+ Int3 = Int2#sr{stk=drop_catch(TryTag, Int2#sr.stk)},
+ St4 = St3#cg{in_catch=St2#cg.in_catch},
+ {Bis,Baft,St5} = cg(Tb, Vdb, Int3#sr{reg=load_vars(Vs, Int3#sr.reg)}, St4),
+ {His,Haft,St6} = cg(Th, Vdb, Int3#sr{reg=load_vars(Evs, Int3#sr.reg)}, St5),
+ Int4 = sr_merge(Baft, Haft), %Merge stack/registers
+ Aft = Int4,
+ {[{'try',TryReg,{f,H}}] ++ Ais ++
+ [{label,B},{try_end,TryReg}] ++ Bis ++
+ [{label,H},{try_case,TryReg}] ++ His,
+ clear_dead(Aft, Le#l.i, Vdb),
+ St6#cg{break=St0#cg.break}}.
+
+%% catch_cg(CatchBlock, Ret, Le, Vdb, Bef, St) -> {[Ainstr],Aft,St}.
+
+catch_cg(C, {var,R}, Le, Vdb, Bef, St0) ->
+ {B,St1} = new_label(St0),
+ CatchTag = Le#l.i,
+ Int1 = Bef#sr{stk=put_catch(CatchTag, Bef#sr.stk)},
+ CatchReg = fetch_stack({catch_tag,CatchTag}, Int1#sr.stk),
+ {Cis,Int2,St2} = cg_block(C, Le#l.i, Le#l.vdb, Int1,
+ St1#cg{break=B,in_catch=true}),
+ [] = Int2#sr.reg, %Assertion.
+ Aft = Int2#sr{reg=[{0,R}],stk=drop_catch(CatchTag, Int2#sr.stk)},
+ {[{'catch',CatchReg,{f,B}}] ++ Cis ++
+ [{label,B},{catch_end,CatchReg}],
+ clear_dead(Aft, Le#l.i, Vdb),
+ St2#cg{break=St1#cg.break,in_catch=St1#cg.in_catch}}.
+
+%% set_cg([Var], Constr, Le, Vdb, Bef, St) -> {[Ainstr],Aft,St}.
+%% We have to be careful how a 'set' works. First the structure is
+%% built, then it is filled and finally things can be cleared. The
+%% annotation must reflect this and make sure that the return
+%% variable is allocated first.
+%%
+%% put_list for constructing a cons is an atomic instruction
+%% which can safely resuse one of the source registers as target.
+%% Also binaries can reuse a source register as target.
+
+set_cg([{var,R}], {cons,Es}, Le, Vdb, Bef, St) ->
+ [S1,S2] = map(fun ({var,V}) -> fetch_var(V, Bef);
+ (Other) -> Other
+ end, Es),
+ Int0 = clear_dead(Bef, Le#l.i, Vdb),
+ Int1 = Int0#sr{reg=put_reg(R, Int0#sr.reg)},
+ Ret = fetch_reg(R, Int1#sr.reg),
+ {[{put_list,S1,S2,Ret}], Int1, St};
+set_cg([{var,R}], {binary,Segs}, Le, Vdb, Bef,
+ #cg{in_catch=InCatch, bfail=Bfail}=St) ->
+ Int0 = Bef#sr{reg=put_reg(R, Bef#sr.reg)},
+ Target = fetch_reg(R, Int0#sr.reg),
+ Fail = {f,Bfail},
+ Temp = find_scratch_reg(Int0#sr.reg),
+ PutCode = cg_bin_put(Segs, Fail, Bef),
+ {Sis,Int1} =
+ case InCatch of
+ true -> adjust_stack(Int0, Le#l.i, Le#l.i+1, Vdb);
+ false -> {[],Int0}
+ end,
+ MaxRegs = max_reg(Bef#sr.reg),
+ Aft = clear_dead(Int1, Le#l.i, Vdb),
+ Code = cg_binary(PutCode, Target, Temp, Fail, MaxRegs, Le#l.a),
+ {Sis++Code,Aft,St};
+set_cg([{var,R}], Con, Le, Vdb, Bef, St) ->
+ %% Find a place for the return register first.
+ Int = Bef#sr{reg=put_reg(R, Bef#sr.reg)},
+ Ret = fetch_reg(R, Int#sr.reg),
+ Ais = case Con of
+ {tuple,Es} ->
+ [{put_tuple,length(Es),Ret}] ++ cg_build_args(Es, Bef);
+ {var,V} -> % Normally removed by kernel optimizer.
+ [{move,fetch_var(V, Int),Ret}];
+ {string,Str} = String ->
+ [{put_string,length(Str),String,Ret}];
+ Other ->
+ [{move,Other,Ret}]
+ end,
+ {Ais,clear_dead(Int, Le#l.i, Vdb),St};
+set_cg([], {binary,Segs}, Le, Vdb, Bef, St) ->
+ Fail = {f,St#cg.bfail},
+ Target = find_scratch_reg(Bef#sr.reg),
+ Temp = find_scratch_reg(put_reg(Target, Bef#sr.reg)),
+ PutCode = cg_bin_put(Segs, Fail, Bef),
+ MaxRegs = max_reg(Bef#sr.reg),
+ Code = cg_binary(PutCode, Target, Temp, Fail, MaxRegs, Le#l.a),
+ Aft = clear_dead(Bef, Le#l.i, Vdb),
+ {Code,Aft,St};
+set_cg([], _, Le, Vdb, Bef, St) ->
+ %% This should have been stripped by compiler, just cleanup.
+ {[],clear_dead(Bef, Le#l.i, Vdb), St}.
+
+
+%%%
+%%% Code generation for constructing binaries.
+%%%
+
+cg_binary([{bs_put_binary,Fail,{atom,all},U,_Flags,Src}|PutCode],
+ Target, Temp, Fail, MaxRegs, Anno) ->
+ Live = cg_live(Target, MaxRegs),
+ SzCode = cg_bitstr_size(PutCode, Target, Temp, Fail, Live),
+ BinFlags = {field_flags,[]},
+ Code = SzCode ++
+ [case member(single_use, Anno) of
+ true ->
+ {bs_private_append,Fail,Target,U,Src,BinFlags,Target};
+ false ->
+ {bs_append,Fail,Target,0,MaxRegs,U,Src,BinFlags,Target}
+ end] ++ PutCode,
+ cg_bin_opt(Code);
+cg_binary(PutCode, Target, Temp, Fail, MaxRegs, _Anno) ->
+ Live = cg_live(Target, MaxRegs),
+ {InitOp,SzCode} = cg_binary_size(PutCode, Target, Temp, Fail, Live),
+
+ Code = SzCode ++ [{InitOp,Fail,Target,0,MaxRegs,
+ {field_flags,[]},Target}|PutCode],
+ cg_bin_opt(Code).
+
+cg_live({x,X}, MaxRegs) when X =:= MaxRegs -> MaxRegs+1;
+cg_live({x,X}, MaxRegs) when X < MaxRegs -> MaxRegs.
+
+%% Generate code that calculate the size of the bitstr to be
+%% built in BITS.
+
+cg_bitstr_size(PutCode, Target, Temp, Fail, Live) ->
+ {Bits,Es} = cg_bitstr_size_1(PutCode, 0, []),
+ reverse(cg_gen_binsize(Es, Target, Temp, Fail, Live,
+ [{move,{integer,Bits},Target}])).
+
+cg_bitstr_size_1([{bs_put_utf8,_,_,Src}|Next], Bits, Acc) ->
+ cg_bitstr_size_1(Next, Bits, [{'*',{bs_utf8_size,Src},8}|Acc]);
+cg_bitstr_size_1([{bs_put_utf16,_,_,Src}|Next], Bits, Acc) ->
+ cg_bitstr_size_1(Next, Bits, [{'*',{bs_utf16_size,Src},8}|Acc]);
+cg_bitstr_size_1([{bs_put_utf32,_,_,_}|Next], Bits, Acc) ->
+ cg_bitstr_size_1(Next, Bits+32, Acc);
+cg_bitstr_size_1([{_,_,S,U,_,Src}|Next], Bits, Acc) ->
+ case S of
+ {integer,N} -> cg_bitstr_size_1(Next, Bits+N*U, Acc);
+ {atom,all} -> cg_bitstr_size_1(Next, Bits, [{bit_size,Src}|Acc]);
+ _ when U =:= 1 -> cg_bitstr_size_1(Next, Bits, [S|Acc]);
+ _ -> cg_bitstr_size_1(Next, Bits, [{'*',S,U}|Acc])
+ end;
+cg_bitstr_size_1([], Bits, Acc) -> {Bits,Acc}.
+
+%% Generate code that calculate the size of the bitstr to be
+%% built in BYTES or BITS (depending on what is easiest).
+
+cg_binary_size(PutCode, Target, Temp, Fail, Live) ->
+ {InitInstruction,Szs} = cg_binary_size_1(PutCode, 0, []),
+ SizeExpr = reverse(cg_gen_binsize(Szs, Target, Temp, Fail, Live, [{move,{integer,0},Target}])),
+ {InitInstruction,SizeExpr}.
+
+cg_binary_size_1([{bs_put_utf8,_Fail,_Flags,Src}|T], Bits, Acc) ->
+ cg_binary_size_1(T, Bits, [{8,{bs_utf8_size,Src}}|Acc]);
+cg_binary_size_1([{bs_put_utf16,_Fail,_Flags,Src}|T], Bits, Acc) ->
+ cg_binary_size_1(T, Bits, [{8,{bs_utf16_size,Src}}|Acc]);
+cg_binary_size_1([{bs_put_utf32,_Fail,_Flags,_Src}|T], Bits, Acc) ->
+ cg_binary_size_1(T, Bits+32, Acc);
+cg_binary_size_1([{_Put,_Fail,S,U,_Flags,Src}|T], Bits, Acc) ->
+ cg_binary_size_2(S, U, Src, T, Bits, Acc);
+cg_binary_size_1([], Bits, Acc) ->
+ Bytes = Bits div 8,
+ RemBits = Bits rem 8,
+ Sizes0 = sort([{1,{integer,RemBits}},{8,{integer,Bytes}}|Acc]),
+ Sizes = filter(fun({_,{integer,0}}) -> false;
+ (_) -> true end, Sizes0),
+ case Sizes of
+ [{1,_}|_] ->
+ {bs_init_bits,cg_binary_bytes_to_bits(Sizes, [])};
+ [{8,_}|_] ->
+ {bs_init2,[E || {8,E} <- Sizes]}
+ end.
+
+cg_binary_size_2({integer,N}, U, _, Next, Bits, Acc) ->
+ cg_binary_size_1(Next, Bits+N*U, Acc);
+cg_binary_size_2({atom,all}, U, E, Next, Bits, Acc) ->
+ if
+ U rem 8 =:= 0 ->
+ cg_binary_size_1(Next, Bits, [{8,{byte_size,E}}|Acc]);
+ true ->
+ cg_binary_size_1(Next, Bits, [{1,{bit_size,E}}|Acc])
+ end;
+cg_binary_size_2(Reg, 1, _, Next, Bits, Acc) ->
+ cg_binary_size_1(Next, Bits, [{1,Reg}|Acc]);
+cg_binary_size_2(Reg, 8, _, Next, Bits, Acc) ->
+ cg_binary_size_1(Next, Bits, [{8,Reg}|Acc]);
+cg_binary_size_2(Reg, U, _, Next, Bits, Acc) ->
+ cg_binary_size_1(Next, Bits, [{1,{'*',Reg,U}}|Acc]).
+
+cg_binary_bytes_to_bits([{8,{integer,N}}|T], Acc) ->
+ cg_binary_bytes_to_bits(T, [{integer,8*N}|Acc]);
+cg_binary_bytes_to_bits([{8,{byte_size,Reg}}|T], Acc) ->
+ cg_binary_bytes_to_bits(T, [{bit_size,Reg}|Acc]);
+cg_binary_bytes_to_bits([{8,Reg}|T], Acc) ->
+ cg_binary_bytes_to_bits(T, [{'*',Reg,8}|Acc]);
+cg_binary_bytes_to_bits([{1,Sz}|T], Acc) ->
+ cg_binary_bytes_to_bits(T, [Sz|Acc]);
+cg_binary_bytes_to_bits([], Acc) ->
+ cg_binary_bytes_to_bits_1(sort(Acc)).
+
+cg_binary_bytes_to_bits_1([{integer,I},{integer,J}|T]) ->
+ cg_binary_bytes_to_bits_1([{integer,I+J}|T]);
+cg_binary_bytes_to_bits_1([H|T]) ->
+ [H|cg_binary_bytes_to_bits_1(T)];
+cg_binary_bytes_to_bits_1([]) -> [].
+
+cg_gen_binsize([{'*',{bs_utf8_size,Src},B}|T], Target, Temp, Fail, Live, Acc) ->
+ Size = {bs_utf8_size,Fail,Src,Temp},
+ Add = {bs_add,Fail,[Target,Temp,B],Target},
+ cg_gen_binsize(T, Target, Temp, Fail, Live,
+ [Add,Size|Acc]);
+cg_gen_binsize([{'*',{bs_utf16_size,Src},B}|T], Target, Temp, Fail, Live, Acc) ->
+ Size = {bs_utf16_size,Fail,Src,Temp},
+ Add = {bs_add,Fail,[Target,Temp,B],Target},
+ cg_gen_binsize(T, Target, Temp, Fail, Live,
+ [Add,Size|Acc]);
+cg_gen_binsize([{'*',A,B}|T], Target, Temp, Fail, Live, Acc) ->
+ cg_gen_binsize(T, Target, Temp, Fail, Live,
+ [{bs_add,Fail,[Target,A,B],Target}|Acc]);
+cg_gen_binsize([{bit_size,B}|T], Target, Temp, Fail, Live, Acc) ->
+ cg_gen_binsize([Temp|T], Target, Temp, Fail, Live,
+ [{gc_bif,bit_size,Fail,Live,[B],Temp}|Acc]);
+cg_gen_binsize([{byte_size,B}|T], Target, Temp, Fail, Live, Acc) ->
+ cg_gen_binsize([Temp|T], Target, Temp, Fail, Live,
+ [{gc_bif,byte_size,Fail,Live,[B],Temp}|Acc]);
+cg_gen_binsize([{bs_utf8_size,B}|T], Target, Temp, Fail, Live, Acc) ->
+ cg_gen_binsize([Temp|T], Target, Temp, Fail, Live,
+ [{bs_utf8_size,Fail,B,Temp}|Acc]);
+cg_gen_binsize([{bs_utf16_size,B}|T], Target, Temp, Fail, Live, Acc) ->
+ cg_gen_binsize([Temp|T], Target, Temp, Fail, Live,
+ [{bs_utf16_size,Fail,B,Temp}|Acc]);
+cg_gen_binsize([E0|T], Target, Temp, Fail, Live, Acc) ->
+ cg_gen_binsize(T, Target, Temp, Fail, Live,
+ [{bs_add,Fail,[Target,E0,1],Target}|Acc]);
+cg_gen_binsize([], _, _, _, _, Acc) -> Acc.
+
+
+%% cg_bin_opt(Code0) -> Code
+%% Optimize the size calculations for binary construction.
+
+cg_bin_opt([{move,Size,D},{bs_append,Fail,D,Extra,Regs0,U,Bin,Flags,D}|Is]) ->
+ Regs = cg_bo_newregs(Regs0, D),
+ cg_bin_opt([{bs_append,Fail,Size,Extra,Regs,U,Bin,Flags,D}|Is]);
+cg_bin_opt([{move,Size,D},{bs_private_append,Fail,D,U,Bin,Flags,D}|Is]) ->
+ cg_bin_opt([{bs_private_append,Fail,Size,U,Bin,Flags,D}|Is]);
+cg_bin_opt([{move,{integer,0},D},{bs_add,_,[D,{integer,_}=S,1],Dst}|Is]) ->
+ cg_bin_opt([{move,S,Dst}|Is]);
+cg_bin_opt([{move,{integer,0},D},{bs_add,Fail,[D,S,U],Dst}|Is]) ->
+ cg_bin_opt([{bs_add,Fail,[{integer,0},S,U],Dst}|Is]);
+cg_bin_opt([{move,{integer,Bytes},D},{Op,Fail,D,Extra,Regs0,Flags,D}|Is])
+ when Op =:= bs_init2; Op =:= bs_init_bits ->
+ Regs = cg_bo_newregs(Regs0, D),
+ cg_bin_opt([{Op,Fail,Bytes,Extra,Regs,Flags,D}|Is]);
+cg_bin_opt([{move,Src1,Dst},{bs_add,Fail,[Dst,Src2,U],Dst}|Is]) ->
+ cg_bin_opt([{bs_add,Fail,[Src1,Src2,U],Dst}|Is]);
+cg_bin_opt([I|Is]) ->
+ [I|cg_bin_opt(Is)];
+cg_bin_opt([]) -> [].
+
+cg_bo_newregs(R, {x,X}) when R-1 =:= X -> R-1;
+cg_bo_newregs(R, _) -> R.
+
+%% Common for new and old binary code generation.
+
+cg_bin_put({bin_seg,[],S0,U,T,Fs,[E0,Next]}, Fail, Bef) ->
+ S1 = case S0 of
+ {var,Sv} -> fetch_var(Sv, Bef);
+ _ -> S0
+ end,
+ E1 = case E0 of
+ {var,V} -> fetch_var(V, Bef);
+ Other -> Other
+ end,
+ {Format,Op} = case T of
+ integer -> {plain,bs_put_integer};
+ utf8 -> {utf,bs_put_utf8};
+ utf16 -> {utf,bs_put_utf16};
+ utf32 -> {utf,bs_put_utf32};
+ binary -> {plain,bs_put_binary};
+ float -> {plain,bs_put_float}
+ end,
+ case Format of
+ plain ->
+ [{Op,Fail,S1,U,{field_flags,Fs},E1}|cg_bin_put(Next, Fail, Bef)];
+ utf ->
+ [{Op,Fail,{field_flags,Fs},E1}|cg_bin_put(Next, Fail, Bef)]
+ end;
+cg_bin_put({bin_end,[]}, _, _) -> [].
+
+cg_build_args(As, Bef) ->
+ map(fun ({var,V}) -> {put,fetch_var(V, Bef)};
+ (Other) -> {put,Other}
+ end, As).
+
+%% return_cg([Val], Le, Vdb, Bef, St) -> {[Ainstr],Aft,St}.
+%% break_cg([Val], Le, Vdb, Bef, St) -> {[Ainstr],Aft,St}.
+%% These are very simple, just put return/break values in registers
+%% from 0, then return/break. Use the call setup to clean up stack,
+%% but must clear registers to ensure sr_merge works correctly.
+
+return_cg(Rs, Le, Vdb, Bef, St) ->
+ {Ms,Int} = cg_setup_call(Rs, Bef, Le#l.i, Vdb),
+ {Ms ++ [return],Int#sr{reg=clear_regs(Int#sr.reg)},St}.
+
+break_cg(Bs, Le, Vdb, Bef, St) ->
+ {Ms,Int} = cg_setup_call(Bs, Bef, Le#l.i, Vdb),
+ {Ms ++ [{jump,{f,St#cg.break}}],
+ Int#sr{reg=clear_regs(Int#sr.reg)},St}.
+
+guard_break_cg(Bs, Locked, #l{i=I}, Vdb, #sr{reg=Reg0}=Bef, St) ->
+ RegLocked = get_locked_regs(Reg0, Locked),
+ #sr{reg=Reg1} = Int = clear_dead(Bef#sr{reg=RegLocked}, I, Vdb),
+ Reg2 = trim_free(Reg1),
+ NumLocked = length(Reg2),
+ Moves0 = gen_moves(Bs, Bef, NumLocked, []),
+ Moves = order_moves(Moves0, find_scratch_reg(RegLocked)),
+ {BreakVars,_} = mapfoldl(fun(_, RegNum) ->
+ {{RegNum,gbreakvar},RegNum+1}
+ end, length(Reg2), Bs),
+ Reg = Reg2 ++ BreakVars,
+ Aft = Int#sr{reg=Reg},
+ {Moves ++ [{jump,{f,St#cg.break}}],Aft,St}.
+
+get_locked_regs([R|Rs0], Preserve) ->
+ case {get_locked_regs(Rs0, Preserve),R} of
+ {[],{_,V}} ->
+ case lists:member(V, Preserve) of
+ true -> [R];
+ false -> []
+ end;
+ {[],_} ->
+ [];
+ {Rs,_} ->
+ [R|Rs]
+ end;
+get_locked_regs([], _) -> [].
+
+%% cg_reg_arg(Arg0, Info) -> Arg
+%% cg_reg_args([Arg0], Info) -> [Arg]
+%% Convert argument[s] into registers. Literal values are returned unchanged.
+
+cg_reg_args(As, Bef) -> [cg_reg_arg(A, Bef) || A <- As].
+
+cg_reg_arg({var,V}, Bef) -> fetch_var(V, Bef);
+cg_reg_arg(Literal, _) -> Literal.
+
+%% cg_setup_call([Arg], Bef, Cur, Vdb) -> {[Instr],Aft}.
+%% Do the complete setup for a call/enter.
+
+cg_setup_call(As, Bef, I, Vdb) ->
+ {Ms,Int0} = cg_call_args(As, Bef, I, Vdb),
+ %% Have set up arguments, can now clean up, compress and save to stack.
+ Int1 = Int0#sr{stk=clear_dead_stk(Int0#sr.stk, I, Vdb),res=[]},
+ {Sis,Int2} = adjust_stack(Int1, I, I+1, Vdb),
+ {Ms ++ Sis,Int2}.
+
+%% cg_call_args([Arg], SrState) -> {[Instr],SrState}.
+%% Setup the arguments to a call/enter/bif. Put the arguments into
+%% consecutive registers starting at {x,0} moving any data which
+%% needs to be saved. Return a modified SrState structure with the
+%% new register contents. N.B. the resultant register info will
+%% contain non-variable values when there are non-variable values.
+%%
+%% This routine is complicated by unsaved values in x registers.
+%% We'll move away any unsaved values that are in the registers
+%% to be overwritten by the arguments.
+
+cg_call_args(As, Bef, I, Vdb) ->
+ Regs0 = load_arg_regs(Bef#sr.reg, As),
+ Unsaved = unsaved_registers(Regs0, Bef#sr.stk, I, I+1, Vdb),
+ {UnsavedMoves,Regs} = move_unsaved(Unsaved, Bef#sr.reg, Regs0),
+ Moves0 = gen_moves(As, Bef),
+ Moves = order_moves(Moves0, find_scratch_reg(Regs)),
+ {UnsavedMoves ++ Moves,Bef#sr{reg=Regs}}.
+
+%% load_arg_regs([Reg], Arguments) -> [Reg]
+%% Update the register descriptor to include the arguments (from {x,0}
+%% and upwards). Values in argument register are overwritten.
+%% Values in x registers above the arguments are preserved.
+
+load_arg_regs(Regs, As) -> load_arg_regs(Regs, As, 0).
+
+load_arg_regs([_|Rs], [{var,V}|As], I) -> [{I,V}|load_arg_regs(Rs, As, I+1)];
+load_arg_regs([_|Rs], [A|As], I) -> [{I,A}|load_arg_regs(Rs, As, I+1)];
+load_arg_regs([], [{var,V}|As], I) -> [{I,V}|load_arg_regs([], As, I+1)];
+load_arg_regs([], [A|As], I) -> [{I,A}|load_arg_regs([], As, I+1)];
+load_arg_regs(Rs, [], _) -> Rs.
+
+%% Returns the variables must be saved and are currently in the
+%% x registers that are about to be overwritten by the arguments.
+
+unsaved_registers(Regs, Stk, Fb, Lf, Vdb) ->
+ [V || {V,F,L} <- Vdb,
+ F < Fb,
+ L >= Lf,
+ not on_stack(V, Stk),
+ not in_reg(V, Regs)].
+
+in_reg(V, Regs) -> keymember(V, 2, Regs).
+
+%% Move away unsaved variables from the registers that are to be
+%% overwritten by the arguments.
+move_unsaved(Vs, OrigRegs, NewRegs) ->
+ move_unsaved(Vs, OrigRegs, NewRegs, []).
+
+move_unsaved([V|Vs], OrigRegs, NewRegs0, Acc) ->
+ NewRegs = put_reg(V, NewRegs0),
+ Src = fetch_reg(V, OrigRegs),
+ Dst = fetch_reg(V, NewRegs),
+ move_unsaved(Vs, OrigRegs, NewRegs, [{move,Src,Dst}|Acc]);
+move_unsaved([], _, Regs, Acc) -> {Acc,Regs}.
+
+%% gen_moves(As, Sr)
+%% Generate the basic move instruction to move the arguments
+%% to their proper registers. The list will be sorted on
+%% destinations. (I.e. the move to {x,0} will be first --
+%% see the comment to order_moves/2.)
+
+gen_moves(As, Sr) -> gen_moves(As, Sr, 0, []).
+
+gen_moves([{var,V}|As], Sr, I, Acc) ->
+ case fetch_var(V, Sr) of
+ {x,I} -> gen_moves(As, Sr, I+1, Acc);
+ Reg -> gen_moves(As, Sr, I+1, [{move,Reg,{x,I}}|Acc])
+ end;
+gen_moves([A|As], Sr, I, Acc) ->
+ gen_moves(As, Sr, I+1, [{move,A,{x,I}}|Acc]);
+gen_moves([], _, _, Acc) -> lists:keysort(3, Acc).
+
+%% order_moves([Move], ScratchReg) -> [Move]
+%% Orders move instruction so that source registers are not
+%% destroyed before they are used. If there are cycles
+%% (such as {move,{x,0},{x,1}}, {move,{x,1},{x,1}}),
+%% the scratch register is used to break up the cycle.
+%% If possible, the first move of the input list is placed
+%% last in the result list (to make the move to {x,0} occur
+%% just before the call to allow the Beam loader to coalesce
+%% the instructions).
+
+order_moves(Ms, Scr) -> order_moves(Ms, Scr, []).
+
+order_moves([{move,_,_}=M|Ms0], ScrReg, Acc0) ->
+ {Chain,Ms} = collect_chain(Ms0, [M], ScrReg),
+ Acc = reverse(Chain, Acc0),
+ order_moves(Ms, ScrReg, Acc);
+order_moves([], _, Acc) -> Acc.
+
+collect_chain(Ms, Path, ScrReg) ->
+ collect_chain(Ms, Path, [], ScrReg).
+
+collect_chain([{move,Src,Same}=M|Ms0], [{move,Same,_}|_]=Path, Others, ScrReg) ->
+ case lists:keyfind(Src, 3, Path) of
+ false ->
+ collect_chain(reverse(Others, Ms0), [M|Path], [], ScrReg);
+ _ -> % We have a cycle.
+ {break_up_cycle(M, Path, ScrReg),reverse(Others, Ms0)}
+ end;
+collect_chain([M|Ms], Path, Others, ScrReg) ->
+ collect_chain(Ms, Path, [M|Others], ScrReg);
+collect_chain([], Path, Others, _) ->
+ {Path,Others}.
+
+break_up_cycle({move,Src,_}=M, Path, ScrReg) ->
+ [{move,ScrReg,Src},M|break_up_cycle1(Src, Path, ScrReg)].
+
+break_up_cycle1(Dst, [{move,Src,Dst}|Path], ScrReg) ->
+ [{move,Src,ScrReg}|Path];
+break_up_cycle1(Dst, [M|Path], LastMove) ->
+ [M|break_up_cycle1(Dst, Path, LastMove)].
+
+%% clear_dead(Sr, Until, Vdb) -> Aft.
+%% Remove all variables in Sr which have died AT ALL so far.
+
+clear_dead(Sr, Until, Vdb) ->
+ Sr#sr{reg=clear_dead_reg(Sr, Until, Vdb),
+ stk=clear_dead_stk(Sr#sr.stk, Until, Vdb)}.
+
+clear_dead_reg(Sr, Until, Vdb) ->
+ Reg = map(fun ({_I,V} = IV) ->
+ case vdb_find(V, Vdb) of
+ {V,_,L} when L > Until -> IV;
+ _ -> free %Remove anything else
+ end;
+ ({reserved,_I,_V} = Reserved) -> Reserved;
+ (free) -> free
+ end, Sr#sr.reg),
+ reserve(Sr#sr.res, Reg, Sr#sr.stk).
+
+clear_dead_stk(Stk, Until, Vdb) ->
+ map(fun ({V} = T) ->
+ case vdb_find(V, Vdb) of
+ {V,_,L} when L > Until -> T;
+ _ -> dead %Remove anything else
+ end;
+ (free) -> free;
+ (dead) -> dead
+ end, Stk).
+
+%% sr_merge(Sr1, Sr2) -> Sr.
+%% Merge two stack/register states keeping the longest of both stack
+%% and register. Perform consistency check on both, elements must be
+%% the same. Allow frame size 'void' to make easy creation of
+%% "empty" frame.
+
+sr_merge(#sr{reg=R1,stk=S1,res=[]}, #sr{reg=R2,stk=S2,res=[]}) ->
+ #sr{reg=longest(R1, R2),stk=longest(S1, S2),res=[]};
+sr_merge(void, S2) -> S2#sr{res=[]}.
+
+longest([H|T1], [H|T2]) -> [H|longest(T1, T2)];
+longest([dead|T1], [free|T2]) -> [dead|longest(T1, T2)];
+longest([free|T1], [dead|T2]) -> [dead|longest(T1, T2)];
+longest([dead|_] = L, []) -> L;
+longest([], [dead|_] = L) -> L;
+longest([free|_] = L, []) -> L;
+longest([], [free|_] = L) -> L;
+longest([], []) -> [].
+
+trim_free([R|Rs0]) ->
+ case {trim_free(Rs0),R} of
+ {[],free} -> [];
+ {Rs,R} -> [R|Rs]
+ end;
+trim_free([]) -> [].
+
+%% adjust_stack(Bef, FirstBefore, LastFrom, Vdb) -> {[Ainstr],Aft}.
+%% Do complete stack adjustment by compressing stack and adding
+%% variables to be saved. Try to optimise ordering on stack by
+%% having reverse order to their lifetimes.
+%%
+%% In Beam, there is a fixed stack frame and no need to do stack compression.
+
+adjust_stack(Bef, Fb, Lf, Vdb) ->
+ Stk0 = Bef#sr.stk,
+ {Stk1,Saves} = save_stack(Stk0, Fb, Lf, Vdb),
+ {saves(Saves, Bef#sr.reg, Stk1),
+ Bef#sr{stk=Stk1}}.
+
+%% save_stack(Stack, FirstBefore, LastFrom, Vdb) -> {[SaveVar],NewStack}.
+%% Save variables which are used past current point and which are not
+%% already on the stack.
+
+save_stack(Stk0, Fb, Lf, Vdb) ->
+ %% New variables that are in use but not on stack.
+ New = [VFL || {V,F,L} = VFL <- Vdb,
+ F < Fb,
+ L >= Lf,
+ not on_stack(V, Stk0)],
+ %% Add new variables that are not just dropped immediately.
+ %% N.B. foldr works backwards from the end!!
+ Saves = [V || {V,_,_} <- keysort(3, New)],
+ Stk1 = foldr(fun (V, Stk) -> put_stack(V, Stk) end, Stk0, Saves),
+ {Stk1,Saves}.
+
+%% saves([SaveVar], Reg, Stk) -> [{move,Reg,Stk}].
+%% Generate move instructions to save variables onto stack. The
+%% stack/reg info used is that after the new stack has been made.
+
+saves(Ss, Reg, Stk) ->
+ [{move,fetch_reg(V, Reg),fetch_stack(V, Stk)} || V <- Ss].
+
+%% fetch_var(VarName, StkReg) -> r{R} | sp{Sp}.
+%% find_var(VarName, StkReg) -> ok{r{R} | sp{Sp}} | error.
+%% Fetch/find a variable in either the registers or on the
+%% stack. Fetch KNOWS it's there.
+
+fetch_var(V, Sr) ->
+ case find_reg(V, Sr#sr.reg) of
+ {ok,R} -> R;
+ error -> fetch_stack(V, Sr#sr.stk)
+ end.
+
+% find_var(V, Sr) ->
+% case find_reg(V, Sr#sr.reg) of
+% {ok,R} -> {ok,R};
+% error ->
+% case find_stack(V, Sr#sr.stk) of
+% {ok,S} -> {ok,S};
+% error -> error
+% end
+% end.
+
+load_vars(Vs, Regs) ->
+ foldl(fun ({var,V}, Rs) -> put_reg(V, Rs) end, Regs, Vs).
+
+%% put_reg(Val, Regs) -> Regs.
+%% free_reg(Val, Regs) -> Regs.
+%% find_reg(Val, Regs) -> ok{r{R}} | error.
+%% fetch_reg(Val, Regs) -> r{R}.
+%% Functions to interface the registers.
+%% put_reg puts a value into a free register,
+%% load_reg loads a value into a fixed register
+%% free_reg frees a register containing a specific value.
+
+% put_regs(Vs, Rs) -> foldl(fun put_reg/2, Rs, Vs).
+
+put_reg(V, Rs) -> put_reg_1(V, Rs, 0).
+
+put_reg_1(V, [free|Rs], I) -> [{I,V}|Rs];
+put_reg_1(V, [{reserved,I,V}|Rs], I) -> [{I,V}|Rs];
+put_reg_1(V, [R|Rs], I) -> [R|put_reg_1(V, Rs, I+1)];
+put_reg_1(V, [], I) -> [{I,V}].
+
+% free_reg(V, [{I,V}|Rs]) -> [free|Rs];
+% free_reg(V, [R|Rs]) -> [R|free_reg(V, Rs)];
+% free_reg(V, []) -> [].
+
+fetch_reg(V, [{I,V}|_]) -> {x,I};
+fetch_reg(V, [_|SRs]) -> fetch_reg(V, SRs).
+
+find_reg(V, [{I,V}|_]) -> {ok,{x,I}};
+find_reg(V, [_|SRs]) -> find_reg(V, SRs);
+find_reg(_, []) -> error.
+
+%% For the bit syntax, we need a scratch register if we are constructing
+%% a binary that will not be used.
+
+find_scratch_reg(Rs) -> find_scratch_reg(Rs, 0).
+
+find_scratch_reg([free|_], I) -> {x,I};
+find_scratch_reg([_|Rs], I) -> find_scratch_reg(Rs, I+1);
+find_scratch_reg([], I) -> {x,I}.
+
+%%copy_reg(Val, R, Regs) -> load_reg(Val, R, Regs).
+%%move_reg(Val, R, Regs) -> load_reg(Val, R, free_reg(Val, Regs)).
+
+replace_reg_contents(Old, New, [{I,Old}|Rs]) -> [{I,New}|Rs];
+replace_reg_contents(Old, New, [R|Rs]) -> [R|replace_reg_contents(Old, New, Rs)].
+
+%%clear_regs(Regs) -> map(fun (R) -> free end, Regs).
+clear_regs(_) -> [].
+
+max_reg(Regs) ->
+ foldl(fun ({I,_}, _) -> I;
+ (_, Max) -> Max end,
+ -1, Regs) + 1.
+
+%% put_stack(Val, [{Val}]) -> [{Val}].
+%% fetch_stack(Var, Stk) -> sp{S}.
+%% find_stack(Var, Stk) -> ok{sp{S}} | error.
+%% Functions to interface the stack.
+
+put_stack(Val, []) -> [{Val}];
+put_stack(Val, [dead|Stk]) -> [{Val}|Stk];
+put_stack(Val, [free|Stk]) -> [{Val}|Stk];
+put_stack(Val, [NotFree|Stk]) -> [NotFree|put_stack(Val, Stk)].
+
+put_stack_carefully(Val, Stk0) ->
+ case catch put_stack_carefully1(Val, Stk0) of
+ error -> error;
+ Stk1 when is_list(Stk1) -> Stk1
+ end.
+
+put_stack_carefully1(_, []) -> throw(error);
+put_stack_carefully1(Val, [dead|Stk]) -> [{Val}|Stk];
+put_stack_carefully1(Val, [free|Stk]) -> [{Val}|Stk];
+put_stack_carefully1(Val, [NotFree|Stk]) ->
+ [NotFree|put_stack_carefully1(Val, Stk)].
+
+fetch_stack(Var, Stk) -> fetch_stack(Var, Stk, 0).
+
+fetch_stack(V, [{V}|_], I) -> {yy,I};
+fetch_stack(V, [_|Stk], I) -> fetch_stack(V, Stk, I+1).
+
+% find_stack(Var, Stk) -> find_stack(Var, Stk, 0).
+
+% find_stack(V, [{V}|Stk], I) -> {ok,{yy,I}};
+% find_stack(V, [O|Stk], I) -> find_stack(V, Stk, I+1);
+% find_stack(V, [], I) -> error.
+
+on_stack(V, Stk) -> keymember(V, 1, Stk).
+
+%% put_catch(CatchTag, Stack) -> Stack'
+%% drop_catch(CatchTag, Stack) -> Stack'
+%% Special interface for putting and removing catch tags, to ensure that
+%% catches nest properly. Also used for try tags.
+
+put_catch(Tag, Stk0) -> put_catch(Tag, reverse(Stk0), []).
+
+put_catch(Tag, [], Stk) ->
+ put_stack({catch_tag,Tag}, Stk);
+put_catch(Tag, [{{catch_tag,_}}|_]=RevStk, Stk) ->
+ reverse(RevStk, put_stack({catch_tag,Tag}, Stk));
+put_catch(Tag, [Other|Stk], Acc) ->
+ put_catch(Tag, Stk, [Other|Acc]).
+
+drop_catch(Tag, [{{catch_tag,Tag}}|Stk]) -> [free|Stk];
+drop_catch(Tag, [Other|Stk]) -> [Other|drop_catch(Tag, Stk)].
+
+%% new_label(St) -> {L,St}.
+
+new_label(#cg{lcount=Next}=St) ->
+ {Next,St#cg{lcount=Next+1}}.
+
+flatmapfoldl(F, Accu0, [Hd|Tail]) ->
+ {R,Accu1} = F(Hd, Accu0),
+ {Rs,Accu2} = flatmapfoldl(F, Accu1, Tail),
+ {R++Rs,Accu2};
+flatmapfoldl(_, Accu, []) -> {[],Accu}.
diff --git a/lib/compiler/src/v3_core.erl b/lib/compiler/src/v3_core.erl
new file mode 100644
index 0000000000..a39a3c538f
--- /dev/null
+++ b/lib/compiler/src/v3_core.erl
@@ -0,0 +1,2136 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1999-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%
+%%
+%% Purpose : Transform normal Erlang to Core Erlang
+
+%% At this stage all preprocessing has been done. All that is left are
+%% "pure" Erlang functions.
+%%
+%% Core transformation is done in three stages:
+%%
+%% 1. Flatten expressions into an internal core form without doing
+%% matching.
+%%
+%% 2. Step "forwards" over the icore code annotating each "top-level"
+%% thing with variable usage. Detect bound variables in matching
+%% and replace with explicit guard test. Annotate "internal-core"
+%% expressions with variables they use and create. Convert matches
+%% to cases when not pure assignments.
+%%
+%% 3. Step "backwards" over icore code using variable usage
+%% annotations to change implicit exported variables to explicit
+%% returns.
+%%
+%% To ensure the evaluation order we ensure that all arguments are
+%% safe. A "safe" is basically a core_lib simple with VERY restricted
+%% binaries.
+%%
+%% We have to be very careful with matches as these create variables.
+%% While we try not to flatten things more than necessary we must make
+%% sure that all matches are at the top level. For this we use the
+%% type "novars" which are non-match expressions. Cases and receives
+%% can also create problems due to exports variables so they are not
+%% "novars" either. I.e. a novars will not export variables.
+%%
+%% Annotations in the #iset, #iletrec, and all other internal records
+%% is kept in a record, #a, not in a list as in proper core. This is
+%% easier and faster and creates no problems as we have complete control
+%% over all annotations.
+%%
+%% On output, the annotation for most Core Erlang terms will contain
+%% the source line number. A few terms will be marked with the atom
+%% atom 'compiler_generated', to indicate that the compiler has generated
+%% them and that no warning should be generated if they are optimized
+%% away.
+%%
+%%
+%% In this translation:
+%%
+%% call ops are safes
+%% call arguments are safes
+%% match arguments are novars
+%% case arguments are novars
+%% receive timeouts are novars
+%% let/set arguments are expressions
+%% fun is not a safe
+
+-module(v3_core).
+
+-export([module/2,format_error/1]).
+
+-import(lists, [reverse/1,reverse/2,map/2,member/2,foldl/3,foldr/3,mapfoldl/3,
+ splitwith/2,keyfind/3,sort/1,foreach/2]).
+-import(ordsets, [add_element/2,del_element/2,is_element/2,
+ union/1,union/2,intersection/2,subtract/2]).
+-import(cerl, [ann_c_cons/3,ann_c_cons_skel/3,ann_c_tuple/2,c_tuple/1]).
+
+-include("core_parse.hrl").
+
+%% Internal core expressions and help functions.
+%% N.B. annotations fields in place as normal Core expressions.
+
+-record(a, {us=[],ns=[],anno=[]}). %Internal annotation
+
+-record(iapply, {anno=#a{},op,args}).
+-record(ibinary, {anno=#a{},segments}). %Not used in patterns.
+-record(icall, {anno=#a{},module,name,args}).
+-record(icase, {anno=#a{},args,clauses,fc}).
+-record(icatch, {anno=#a{},body}).
+-record(iclause, {anno=#a{},pats,pguard=[],guard,body}).
+-record(ifun, {anno=#a{},id,vars,clauses,fc}).
+-record(iletrec, {anno=#a{},defs,body}).
+-record(imatch, {anno=#a{},pat,guard=[],arg,fc}).
+-record(iprimop, {anno=#a{},name,args}).
+-record(iprotect, {anno=#a{},body}).
+-record(ireceive1, {anno=#a{},clauses}).
+-record(ireceive2, {anno=#a{},clauses,timeout,action}).
+-record(iset, {anno=#a{},var,arg}).
+-record(itry, {anno=#a{},args,vars,body,evars,handler}).
+
+-type iapply() :: #iapply{}.
+-type ibinary() :: #ibinary{}.
+-type icall() :: #icall{}.
+-type icase() :: #icase{}.
+-type icatch() :: #icatch{}.
+-type iclause() :: #iclause{}.
+-type ifun() :: #ifun{}.
+-type iletrec() :: #iletrec{}.
+-type imatch() :: #imatch{}.
+-type iprimop() :: #iprimop{}.
+-type iprotect() :: #iprotect{}.
+-type ireceive1() :: #ireceive1{}.
+-type ireceive2() :: #ireceive2{}.
+-type iset() :: #iset{}.
+-type itry() :: #itry{}.
+
+-type i() :: iapply() | ibinary() | icall() | icase() | icatch()
+ | iclause() | ifun() | iletrec() | imatch() | iprimop()
+ | iprotect() | ireceive1() | ireceive2() | iset() | itry().
+
+-type error() :: {file:filename(), [{integer(), module(), term()}]}.
+-type warning() :: {file:filename(), [{integer(), module(), term()}]}.
+
+-record(core, {vcount=0 :: non_neg_integer(), %Variable counter
+ fcount=0 :: non_neg_integer(), %Function counter
+ in_guard=false :: boolean(), %In guard or not.
+ opts :: [compile:option()], %Options.
+ es=[] :: [error()], %Errors.
+ ws=[] :: [warning()], %Warnings.
+ file=[{file,""}]}). %File
+
+%% XXX: The following type declarations do not belong in this module
+-type fa() :: {atom(), arity()}.
+-type attribute() :: atom().
+-type form() :: {function, integer(), atom(), arity(), _}
+ | {attribute, integer(), attribute(), _}.
+
+-spec module({module(), [fa()], [form()]}, [compile:option()]) ->
+ {'ok',cerl:c_module(),[warning()]} | {'error',[error()],[warning()]}.
+
+module({Mod,Exp,Forms}, Opts) ->
+ Cexp = map(fun ({_N,_A} = NA) -> #c_var{name=NA} end, Exp),
+ {Kfs0,As0,Es,Ws,_File} = foldl(fun (F, Acc) ->
+ form(F, Acc, Opts)
+ end, {[],[],[],[],[]}, Forms),
+ Kfs = reverse(Kfs0),
+ As = reverse(As0),
+ case Es of
+ [] ->
+ {ok,#c_module{name=#c_literal{val=Mod},exports=Cexp,attrs=As,defs=Kfs},Ws};
+ _ ->
+ {error,Es,Ws}
+ end.
+
+form({function,_,_,_,_}=F0, {Fs,As,Es0,Ws0,File}, Opts) ->
+ {F,Es,Ws} = function(F0, Es0, Ws0, File, Opts),
+ {[F|Fs],As,Es,Ws,File};
+form({attribute,_,file,{File,_Line}}, {Fs,As,Es,Ws,_}, _Opts) ->
+ {Fs,As,Es,Ws,File};
+form({attribute,_,_,_}=F, {Fs,As,Es,Ws,File}, _Opts) ->
+ {Fs,[attribute(F)|As],Es,Ws,File}.
+
+attribute({attribute,_,Name,Val}) ->
+ {#c_literal{val=Name},#c_literal{val=Val}}.
+
+function({function,_,Name,Arity,Cs0}, Es0, Ws0, File, Opts) ->
+ %%ok = io:fwrite("~p - ", [{Name,Arity}]),
+ St0 = #core{vcount=0,opts=Opts,es=Es0,ws=Ws0,file=[{file,File}]},
+ {B0,St1} = body(Cs0, Name, Arity, St0),
+ %%ok = io:fwrite("1", []),
+ %%ok = io:fwrite("~w:~p~n", [?LINE,B0]),
+ {B1,St2} = ubody(B0, St1),
+ %%ok = io:fwrite("2", []),
+ %%ok = io:fwrite("~w:~p~n", [?LINE,B1]),
+ {B2,#core{es=Es,ws=Ws}} = cbody(B1, St2),
+ %%ok = io:fwrite("3~n", []),
+ %%ok = io:fwrite("~w:~p~n", [?LINE,B2]),
+ {{#c_var{name={Name,Arity}},B2},Es,Ws}.
+
+body(Cs0, Name, Arity, St0) ->
+ Anno = lineno_anno(element(2, hd(Cs0)), St0),
+ {Args,St1} = new_vars(Anno, Arity, St0),
+ {Cs1,St2} = clauses(Cs0, St1),
+ {Ps,St3} = new_vars(Arity, St2), %Need new variables here
+ Fc = function_clause(Ps, {Name,Arity}),
+ {#ifun{anno=#a{anno=Anno},id=[],vars=Args,clauses=Cs1,fc=Fc},St3}.
+
+%% clause(Clause, State) -> {Cclause,State} | noclause.
+%% clauses([Clause], State) -> {[Cclause],State}.
+%% Convert clauses. Trap bad pattern aliases and remove clause from
+%% clause list.
+
+clauses([C0|Cs0], St0) ->
+ case clause(C0, St0) of
+ {noclause,St} -> clauses(Cs0, St);
+ {C,St1} ->
+ {Cs,St2} = clauses(Cs0, St1),
+ {[C|Cs],St2}
+ end;
+clauses([], St) -> {[],St}.
+
+clause({clause,Lc,H0,G0,B0}, St0) ->
+ try head(H0, St0) of
+ H1 ->
+ {G1,St1} = guard(G0, St0),
+ {B1,St2} = exprs(B0, St1),
+ Anno = lineno_anno(Lc, St2),
+ {#iclause{anno=#a{anno=Anno},pats=H1,guard=G1,body=B1},St2}
+ catch
+ throw:nomatch ->
+ St = add_warning(Lc, nomatch, St0),
+ {noclause,St}; %Bad pattern
+ throw:no_binaries ->
+ St = add_error(Lc, no_binaries, St0),
+ {noclause,St}
+ end.
+
+clause_arity({clause,_,H0,_,_}) -> length(H0).
+
+%% head([P], State) -> [P].
+
+head(Ps, St) -> pattern_list(Ps, St).
+
+%% guard([Expr], State) -> {[Cexpr],State}.
+%% Build an explict and/or tree of guard alternatives, then traverse
+%% top-level and/or tree and "protect" inner tests.
+
+guard([], St) -> {[],St};
+guard(Gs0, St0) ->
+ Gs1 = foldr(fun (Gt0, Rhs) ->
+ Gt1 = guard_tests(Gt0),
+ L = element(2, Gt1),
+ {op,L,'or',Gt1,Rhs}
+ end, guard_tests(last(Gs0)), first(Gs0)),
+ {Gs,St} = gexpr_top(Gs1, St0#core{in_guard=true}),
+ {Gs,St#core{in_guard=false}}.
+
+guard_tests(Gs) ->
+ L = element(2, hd(Gs)),
+ {protect,L,foldr(fun (G, Rhs) -> {op,L,'and',G,Rhs} end, last(Gs), first(Gs))}.
+
+%% gexpr_top(Expr, State) -> {Cexpr,State}.
+%% Generate an internal core expression of a guard test. Explicitly
+%% handle outer boolean expressions and "protect" inner tests in a
+%% reasonably smart way.
+
+gexpr_top(E0, St0) ->
+ {E1,Eps0,Bools,St1} = gexpr(E0, [], St0),
+ {E,Eps,St} = force_booleans(Bools, E1, Eps0, St1),
+ {Eps++[E],St}.
+
+%% gexpr(Expr, Bools, State) -> {Cexpr,[PreExp],Bools,State}.
+%% Generate an internal core expression of a guard test.
+
+gexpr({protect,Line,Arg}, Bools0, St0) ->
+ case gexpr(Arg, [], St0) of
+ {E0,[],Bools,St1} ->
+ {E,Eps,St} = force_booleans(Bools, E0, [], St1),
+ {E,Eps,Bools0,St};
+ {E0,Eps0,Bools,St1} ->
+ {E,Eps,St} = force_booleans(Bools, E0, Eps0, St1),
+ Anno = lineno_anno(Line, St),
+ {#iprotect{anno=#a{anno=Anno},body=Eps++[E]},[],Bools0,St}
+ end;
+gexpr({op,L,'andalso',E1,E2}, Bools, St0) ->
+ {#c_var{name=V0},St} = new_var(L, St0),
+ V = {var,L,V0},
+ False = {atom,L,false},
+ E = make_bool_switch_guard(L, E1, V, E2, False),
+ gexpr(E, Bools, St);
+gexpr({op,L,'orelse',E1,E2}, Bools, St0) ->
+ {#c_var{name=V0},St} = new_var(L, St0),
+ V = {var,L,V0},
+ True = {atom,L,true},
+ E = make_bool_switch_guard(L, E1, V, True, E2),
+ gexpr(E, Bools, St);
+gexpr({op,Line,Op,L,R}=Call, Bools0, St0) ->
+ case erl_internal:bool_op(Op, 2) of
+ true ->
+ {Le,Lps,Bools1,St1} = gexpr(L, Bools0, St0),
+ {Ll,Llps,St2} = force_safe(Le, St1),
+ {Re,Rps,Bools,St3} = gexpr(R, Bools1, St2),
+ {Rl,Rlps,St4} = force_safe(Re, St3),
+ Anno = lineno_anno(Line, St4),
+ {#icall{anno=#a{anno=Anno}, %Must have an #a{}
+ module=#c_literal{anno=Anno,val=erlang},
+ name=#c_literal{anno=Anno,val=Op},
+ args=[Ll,Rl]},Lps ++ Llps ++ Rps ++ Rlps,Bools,St4};
+ false ->
+ gexpr_test(Call, Bools0, St0)
+ end;
+gexpr({op,Line,Op,A}=Call, Bools0, St0) ->
+ case Op of
+ 'not' ->
+ {Ae0,Aps,Bools,St1} = gexpr(A, Bools0, St0),
+ case Ae0 of
+ #icall{module=#c_literal{val=erlang},
+ name=#c_literal{val='=:='},
+ args=[E,#c_literal{val=true}]}=EqCall ->
+ %%
+ %% Doing the following transformation
+ %% not(Expr =:= true) ==> Expr =:= false
+ %% will help eliminating redundant is_boolean/1 tests.
+ %%
+ Ae = EqCall#icall{args=[E,#c_literal{val=false}]},
+ {Al,Alps,St2} = force_safe(Ae, St1),
+ {Al,Aps ++ Alps,Bools,St2};
+ Ae ->
+ {Al,Alps,St2} = force_safe(Ae, St1),
+ Anno = lineno_anno(Line, St2),
+ {#icall{anno=#a{anno=Anno}, %Must have an #a{}
+ module=#c_literal{anno=Anno,val=erlang},
+ name=#c_literal{anno=Anno,val=Op},
+ args=[Al]},Aps ++ Alps,Bools,St2}
+ end;
+ _ ->
+ gexpr_test(Call, Bools0, St0)
+ end;
+gexpr(E0, Bools, St0) ->
+ gexpr_test(E0, Bools, St0).
+
+%% gexpr_test(Expr, Bools, State) -> {Cexpr,[PreExp],Bools,State}.
+%% Generate a guard test. At this stage we must be sure that we have
+%% a proper boolean value here so wrap things with an true test if we
+%% don't know, i.e. if it is not a comparison or a type test.
+
+gexpr_test({atom,L,true}, Bools, St0) ->
+ {#c_literal{anno=lineno_anno(L, St0),val=true},[],Bools,St0};
+gexpr_test({atom,L,false}, Bools, St0) ->
+ {#c_literal{anno=lineno_anno(L, St0),val=false},[],Bools,St0};
+gexpr_test(E0, Bools0, St0) ->
+ {E1,Eps0,St1} = expr(E0, St0),
+ %% Generate "top-level" test and argument calls.
+ case E1 of
+ #icall{anno=Anno,module=#c_literal{val=erlang},name=#c_literal{val=N},args=As} ->
+ Ar = length(As),
+ case erl_internal:type_test(N, Ar) orelse
+ erl_internal:comp_op(N, Ar) of
+ true -> {E1,Eps0,Bools0,St1};
+ false ->
+ Lanno = Anno#a.anno,
+ {New,St2} = new_var(Lanno, St1),
+ Bools = [New|Bools0],
+ {#icall{anno=Anno, %Must have an #a{}
+ module=#c_literal{anno=Lanno,val=erlang},
+ name=#c_literal{anno=Lanno,val='=:='},
+ args=[New,#c_literal{anno=Lanno,val=true}]},
+ Eps0 ++ [#iset{anno=Anno,var=New,arg=E1}],Bools,St2}
+ end;
+ _ ->
+ Anno = get_ianno(E1),
+ Lanno = get_lineno_anno(E1),
+ case is_simple(E1) of
+ true ->
+ Bools = [E1|Bools0],
+ {#icall{anno=Anno, %Must have an #a{}
+ module=#c_literal{anno=Lanno,val=erlang},
+ name=#c_literal{anno=Lanno,val='=:='},
+ args=[E1,#c_literal{anno=Lanno,val=true}]},Eps0,Bools,St1};
+ false ->
+ {New,St2} = new_var(Lanno, St1),
+ Bools = [New|Bools0],
+ {#icall{anno=Anno, %Must have an #a{}
+ module=#c_literal{anno=Lanno,val=erlang},
+ name=#c_literal{anno=Lanno,val='=:='},
+ args=[New,#c_literal{anno=Lanno,val=true}]},
+ Eps0 ++ [#iset{anno=Anno,var=New,arg=E1}],Bools,St2}
+ end
+ end.
+
+force_booleans(Vs0, E, Eps, St) ->
+ Vs1 = [set_anno(V, []) || V <- Vs0],
+ Vs = unforce(E, Eps, Vs1),
+ force_booleans_1(Vs, E, Eps, St).
+
+force_booleans_1([], E, Eps, St) ->
+ {E,Eps,St};
+force_booleans_1([V|Vs], E0, Eps0, St0) ->
+ {E1,Eps1,St1} = force_safe(E0, St0),
+ Lanno = element(2, V),
+ Anno = #a{anno=Lanno},
+ Call = #icall{anno=Anno,module=#c_literal{anno=Lanno,val=erlang},
+ name=#c_literal{anno=Lanno,val=is_boolean},
+ args=[V]},
+ {New,St} = new_var(Lanno, St1),
+ Iset = #iset{anno=Anno,var=New,arg=Call},
+ Eps = Eps0 ++ Eps1 ++ [Iset],
+ E = #icall{anno=Anno,
+ module=#c_literal{anno=Lanno,val=erlang},name=#c_literal{anno=Lanno,val='and'},
+ args=[E1,New]},
+ force_booleans_1(Vs, E, Eps, St).
+
+
+%% unforce(Expr, PreExprList, BoolExprList) -> BoolExprList'.
+%% Filter BoolExprList. BoolExprList is a list of simple expressions
+%% (variables or literals) of which we are not sure whether they are booleans.
+%%
+%% The basic idea for filtering is the following transformation
+%%
+%% (E =:= Bool) and is_boolean(E) ==> E =:= Bool
+%%
+%% where E is an arbitrary expression and Bool is 'true' or 'false'.
+%%
+%% The transformation is still valid if there are other expressions joined
+%% by 'and' operations:
+%%
+%% E1 and (E2 =:= true) and E3 and is_boolean(E) ==> E1 and (E2 =:= true) and E3
+%%
+%% but expressions such as
+%%
+%% not (E =:= true) and is_boolean(E)
+%%
+%% cannot be transformed in this way (such expressions are the reason for
+%% adding the is_boolean/1 test in the first place).
+%%
+unforce(_, _, []) ->
+ [];
+unforce(E, Eps, Vs) ->
+ Tree = unforce_tree(Eps++[E], gb_trees:empty()),
+ unforce(Tree, Vs).
+
+unforce_tree([#iset{var=#c_var{name=V},arg=Arg0}|Es], D0) ->
+ Arg = unforce_tree_subst(Arg0, D0),
+ D = gb_trees:insert(V, Arg, D0),
+ unforce_tree(Es, D);
+unforce_tree([#icall{}=Call], D) ->
+ unforce_tree_subst(Call, D);
+unforce_tree([Top], _) -> Top.
+
+unforce_tree_subst(#icall{module=#c_literal{val=erlang},
+ name=#c_literal{val='=:='},
+ args=[_Expr,#c_literal{val=Bool}]}=Call, _)
+ when is_boolean(Bool) ->
+ %% We have erlang:'=:='(Expr, Bool). We must not expand this call any more
+ %% or we will not recognize is_boolean(Expr) later.
+ Call;
+unforce_tree_subst(#icall{args=Args0}=Call, D) ->
+ Args = map(fun(#c_var{name=V}=Var) ->
+ case gb_trees:lookup(V, D) of
+ {value,Val} -> Val;
+ none -> Var
+ end;
+ (Expr) -> Expr
+ end, Args0),
+ Call#icall{args=Args};
+unforce_tree_subst(Expr, _) -> Expr.
+
+unforce(#icall{module=#c_literal{val=erlang},
+ name=#c_literal{val=Name},
+ args=Args}, Vs0) ->
+ case {Name,Args} of
+ {'and',[Arg1,Arg2]} ->
+ Vs = unforce(Arg1, Vs0),
+ unforce(Arg2, Vs);
+ {'=:=',[E,#c_literal{val=Bool}]} when is_boolean(Bool) ->
+ Vs0 -- [set_anno(E, [])];
+ {_,_} ->
+ %% Give up.
+ Vs0
+ end;
+unforce(_, Vs) -> Vs.
+
+%% exprs([Expr], State) -> {[Cexpr],State}.
+%% Flatten top-level exprs.
+
+exprs([E0|Es0], St0) ->
+ {E1,Eps,St1} = expr(E0, St0),
+ {Es1,St2} = exprs(Es0, St1),
+ {Eps ++ [E1] ++ Es1,St2};
+exprs([], St) -> {[],St}.
+
+%% expr(Expr, State) -> {Cexpr,[PreExp],State}.
+%% Generate an internal core expression.
+
+expr({var,L,V}, St) -> {#c_var{anno=lineno_anno(L, St),name=V},[],St};
+expr({char,L,C}, St) -> {#c_literal{anno=lineno_anno(L, St),val=C},[],St};
+expr({integer,L,I}, St) -> {#c_literal{anno=lineno_anno(L, St),val=I},[],St};
+expr({float,L,F}, St) -> {#c_literal{anno=lineno_anno(L, St),val=F},[],St};
+expr({atom,L,A}, St) -> {#c_literal{anno=lineno_anno(L, St),val=A},[],St};
+expr({nil,L}, St) -> {#c_literal{anno=lineno_anno(L, St),val=[]},[],St};
+expr({string,L,S}, St) -> {#c_literal{anno=lineno_anno(L, St),val=S},[],St};
+expr({cons,L,H0,T0}, St0) ->
+ {H1,Hps,St1} = safe(H0, St0),
+ {T1,Tps,St2} = safe(T0, St1),
+ A = lineno_anno(L, St2),
+ {ann_c_cons(A, H1, T1),Hps ++ Tps,St2};
+expr({lc,L,E,Qs}, St) ->
+ lc_tq(L, E, Qs, #c_literal{anno=lineno_anno(L, St),val=[]}, St);
+expr({bc,L,E,Qs}, St) ->
+ bc_tq(L, E, Qs, {nil,L}, St);
+expr({tuple,L,Es0}, St0) ->
+ {Es1,Eps,St1} = safe_list(Es0, St0),
+ A = lineno_anno(L, St1),
+ {ann_c_tuple(A, Es1),Eps,St1};
+expr({bin,L,Es0}, #core{opts=Opts}=St0) ->
+ St1 = case member(no_binaries, Opts) of
+ false -> St0;
+ true -> add_error(L, no_binaries, St0)
+ end,
+ try expr_bin(Es0, lineno_anno(L, St1), St1) of
+ {_,_,_}=Res -> Res
+ catch
+ throw:bad_binary ->
+ St2 = add_warning(L, bad_binary, St1),
+ LineAnno = lineno_anno(L, St2),
+ As = [#c_literal{anno=LineAnno,val=badarg}],
+ {#icall{anno=#a{anno=LineAnno}, %Must have an #a{}
+ module=#c_literal{anno=LineAnno,val=erlang},
+ name=#c_literal{anno=LineAnno,val=error},
+ args=As},[],St2}
+ end;
+expr({block,_,Es0}, St0) ->
+ %% Inline the block directly.
+ {Es1,St1} = exprs(first(Es0), St0),
+ {E1,Eps,St2} = expr(last(Es0), St1),
+ {E1,Es1 ++ Eps,St2};
+expr({'if',L,Cs0}, St0) ->
+ {Cs1,St1} = clauses(Cs0, St0),
+ Fc = fail_clause([], #c_literal{val=if_clause}),
+ Lanno = lineno_anno(L, St1),
+ {#icase{anno=#a{anno=Lanno},args=[],clauses=Cs1,fc=Fc},[],St1};
+expr({'case',L,E0,Cs0}, St0) ->
+ {E1,Eps,St1} = novars(E0, St0),
+ {Cs1,St2} = clauses(Cs0, St1),
+ {Fpat,St3} = new_var(St2),
+ Fc = fail_clause([Fpat], c_tuple([#c_literal{val=case_clause},Fpat])),
+ Lanno = lineno_anno(L, St3),
+ {#icase{anno=#a{anno=Lanno},args=[E1],clauses=Cs1,fc=Fc},Eps,St3};
+expr({'receive',L,Cs0}, St0) ->
+ {Cs1,St1} = clauses(Cs0, St0),
+ {#ireceive1{anno=#a{anno=lineno_anno(L, St1)},clauses=Cs1}, [], St1};
+expr({'receive',L,Cs0,Te0,Tes0}, St0) ->
+ {Te1,Teps,St1} = novars(Te0, St0),
+ {Tes1,St2} = exprs(Tes0, St1),
+ {Cs1,St3} = clauses(Cs0, St2),
+ {#ireceive2{anno=#a{anno=lineno_anno(L, St3)},
+ clauses=Cs1,timeout=Te1,action=Tes1},Teps,St3};
+expr({'try',L,Es0,[],Ecs,[]}, St0) ->
+ %% 'try ... catch ... end'
+ {Es1,St1} = exprs(Es0, St0),
+ {V,St2} = new_var(St1), %This name should be arbitrary
+ {Evs,Hs,St3} = try_exception(Ecs, St2),
+ Lanno = lineno_anno(L, St3),
+ {#itry{anno=#a{anno=Lanno},args=Es1,vars=[V],body=[V],
+ evars=Evs,handler=Hs},
+ [],St3};
+expr({'try',L,Es0,Cs0,Ecs,[]}, St0) ->
+ %% 'try ... of ... catch ... end'
+ {Es1,St1} = exprs(Es0, St0),
+ {V,St2} = new_var(St1), %This name should be arbitrary
+ {Cs1,St3} = clauses(Cs0, St2),
+ {Fpat,St4} = new_var(St3),
+ Fc = fail_clause([Fpat], c_tuple([#c_literal{val=try_clause},Fpat])),
+ {Evs,Hs,St5} = try_exception(Ecs, St4),
+ Lanno = lineno_anno(L, St1),
+ {#itry{anno=#a{anno=lineno_anno(L, St5)},args=Es1,
+ vars=[V],body=[#icase{anno=#a{anno=Lanno},args=[V],clauses=Cs1,fc=Fc}],
+ evars=Evs,handler=Hs},
+ [],St5};
+expr({'try',L,Es0,[],[],As0}, St0) ->
+ %% 'try ... after ... end'
+ {Es1,St1} = exprs(Es0, St0),
+ {As1,St2} = exprs(As0, St1),
+ {Evs,Hs0,St3} = try_after(As1, St2),
+ %% We must kill the id for any funs in the duplicated after body,
+ %% to avoid getting two local functions having the same name.
+ Hs = kill_id_anns(Hs0),
+ {V,St4} = new_var(St3), % (must not exist in As1)
+ %% TODO: this duplicates the 'after'-code; should lift to function.
+ Lanno = lineno_anno(L, St4),
+ {#itry{anno=#a{anno=Lanno},args=Es1,vars=[V],body=As1++[V],
+ evars=Evs,handler=Hs},
+ [],St4};
+expr({'try',L,Es,Cs,Ecs,As}, St0) ->
+ %% 'try ... [of ...] [catch ...] after ... end'
+ expr({'try',L,[{'try',L,Es,Cs,Ecs,[]}],[],[],As}, St0);
+expr({'catch',L,E0}, St0) ->
+ {E1,Eps,St1} = expr(E0, St0),
+ Lanno = lineno_anno(L, St1),
+ {#icatch{anno=#a{anno=Lanno},body=Eps ++ [E1]},[],St1};
+expr({'fun',L,{function,F,A},{_,_,_}=Id}, St) ->
+ Lanno = lineno_anno(L, St),
+ {#c_var{anno=Lanno++[{id,Id}],name={F,A}},[],St};
+expr({'fun',L,{clauses,Cs},Id}, St) ->
+ fun_tq(Id, Cs, L, St);
+expr({call,L,{remote,_,M,F},As0}, St0) ->
+ {[M1,F1|As1],Aps,St1} = safe_list([M,F|As0], St0),
+ Lanno = lineno_anno(L, St1),
+ {#icall{anno=#a{anno=Lanno},module=M1,name=F1,args=As1},Aps,St1};
+expr({call,Lc,{atom,Lf,F},As0}, St0) ->
+ {As1,Aps,St1} = safe_list(As0, St0),
+ Op = #c_var{anno=lineno_anno(Lf, St1),name={F,length(As1)}},
+ {#iapply{anno=#a{anno=lineno_anno(Lc, St1)},op=Op,args=As1},Aps,St1};
+expr({call,L,FunExp,As0}, St0) ->
+ {Fun,Fps,St1} = safe(FunExp, St0),
+ {As1,Aps,St2} = safe_list(As0, St1),
+ Lanno = lineno_anno(L, St2),
+ {#iapply{anno=#a{anno=Lanno},op=Fun,args=As1},Fps ++ Aps,St2};
+expr({match,L,P0,E0}, St0) ->
+ %% First fold matches together to create aliases.
+ {P1,E1} = fold_match(E0, P0),
+ {E2,Eps,St1} = novars(E1, St0),
+ P2 = try
+ pattern(P1, St1)
+ catch
+ throw:Thrown ->
+ Thrown
+ end,
+ {Fpat,St2} = new_var(St1),
+ Fc = fail_clause([Fpat], c_tuple([#c_literal{val=badmatch},Fpat])),
+ Lanno = lineno_anno(L, St2),
+ case P2 of
+ nomatch ->
+ St = add_warning(L, nomatch, St2),
+ {#icase{anno=#a{anno=Lanno},
+ args=[E2],clauses=[],fc=Fc},Eps,St};
+ no_binaries ->
+ St = add_error(L, no_binaries, St2),
+ {#icase{anno=#a{anno=Lanno},
+ args=[E2],clauses=[],fc=Fc},Eps,St};
+ Other when not is_atom(Other) ->
+ {#imatch{anno=#a{anno=Lanno},pat=P2,arg=E2,fc=Fc},Eps,St2}
+ end;
+expr({op,_,'++',{lc,Llc,E,Qs},More}, St0) ->
+ %% Optimise '++' here because of the list comprehension algorithm.
+ %%
+ %% To avoid achieving quadratic complexity if there is a chain of
+ %% list comprehensions without generators combined with '++', force
+ %% evaluation of More now. Evaluating More here could also reduce the
+ %% number variables in the environment for letrec.
+ {Mc,Mps,St1} = safe(More, St0),
+ {Y,Yps,St} = lc_tq(Llc, E, Qs, Mc, St1),
+ {Y,Mps++Yps,St};
+expr({op,L,'andalso',E1,E2}, St0) ->
+ {#c_var{name=V0},St} = new_var(L, St0),
+ V = {var,L,V0},
+ False = {atom,L,false},
+ E = make_bool_switch(L, E1, V, E2, False, St0),
+ expr(E, St);
+expr({op,L,'orelse',E1,E2}, St0) ->
+ {#c_var{name=V0},St} = new_var(L, St0),
+ V = {var,L,V0},
+ True = {atom,L,true},
+ E = make_bool_switch(L, E1, V, True, E2, St0),
+ expr(E, St);
+expr({op,L,Op,A0}, St0) ->
+ {A1,Aps,St1} = safe(A0, St0),
+ LineAnno = lineno_anno(L, St1),
+ {#icall{anno=#a{anno=LineAnno}, %Must have an #a{}
+ module=#c_literal{anno=LineAnno,val=erlang},
+ name=#c_literal{anno=LineAnno,val=Op},args=[A1]},Aps,St1};
+expr({op,L,Op,L0,R0}, St0) ->
+ {As,Aps,St1} = safe_list([L0,R0], St0),
+ LineAnno = lineno_anno(L, St1),
+ {#icall{anno=#a{anno=LineAnno}, %Must have an #a{}
+ module=#c_literal{anno=LineAnno,val=erlang},
+ name=#c_literal{anno=LineAnno,val=Op},args=As},Aps,St1}.
+
+make_bool_switch(L, E, V, T, F, #core{in_guard=true}) ->
+ make_bool_switch_guard(L, E, V, T, F);
+make_bool_switch(L, E, V, T, F, #core{}) ->
+ make_bool_switch_body(L, E, V, T, F).
+
+make_bool_switch_body(L, E, V, T, F) ->
+ NegL = neg_line(abs_line(L)),
+ Error = {tuple,NegL,[{atom,NegL,badarg},V]},
+ {'case',NegL,E,
+ [{clause,NegL,[{atom,NegL,true}],[],[T]},
+ {clause,NegL,[{atom,NegL,false}],[],[F]},
+ {clause,NegL,[V],[],
+ [{call,NegL,{remote,NegL,{atom,NegL,erlang},{atom,NegL,error}},
+ [Error]}]}]}.
+
+make_bool_switch_guard(_, E, _, {atom,_,true}, {atom,_,false}) -> E;
+make_bool_switch_guard(L, E, V, T, F) ->
+ NegL = neg_line(abs_line(L)),
+ {'case',NegL,E,
+ [{clause,NegL,[{atom,NegL,true}],[],[T]},
+ {clause,NegL,[{atom,NegL,false}],[],[F]},
+ {clause,NegL,[V],[],[V]}
+ ]}.
+
+
+%% try_exception([ExcpClause], St) -> {[ExcpVar],Handler,St}.
+
+try_exception(Ecs0, St0) ->
+ %% Note that Tag is not needed for rethrow - it is already in Info.
+ {Evs,St1} = new_vars(3, St0), % Tag, Value, Info
+ {Ecs1,St2} = clauses(Ecs0, St1),
+ [_,Value,Info] = Evs,
+ Ec = #iclause{anno=#a{anno=[compiler_generated]},
+ pats=[c_tuple(Evs)],guard=[#c_literal{val=true}],
+ body=[#iprimop{anno=#a{}, %Must have an #a{}
+ name=#c_literal{val=raise},
+ args=[Info,Value]}]},
+ Hs = [#icase{anno=#a{},args=[c_tuple(Evs)],clauses=Ecs1,fc=Ec}],
+ {Evs,Hs,St2}.
+
+try_after(As, St0) ->
+ %% See above.
+ {Evs,St1} = new_vars(3, St0), % Tag, Value, Info
+ [_,Value,Info] = Evs,
+ B = As ++ [#iprimop{anno=#a{}, %Must have an #a{}
+ name=#c_literal{val=raise},
+ args=[Info,Value]}],
+ Ec = #iclause{anno=#a{anno=[compiler_generated]},
+ pats=[c_tuple(Evs)],guard=[#c_literal{val=true}],
+ body=B},
+ Hs = [#icase{anno=#a{},args=[c_tuple(Evs)],clauses=[],fc=Ec}],
+ {Evs,Hs,St1}.
+
+%% expr_bin([ArgExpr], St) -> {[Arg],[PreExpr],St}.
+%% Flatten the arguments of a bin. Do this straight left to right!
+%% Note that ibinary needs to have its annotation wrapped in a #a{}
+%% record whereas c_literal should not have a wrapped annotation
+
+expr_bin(Es0, Anno, St0) ->
+ case constant_bin(Es0) of
+ error ->
+ {Es,Eps,St} = expr_bin_1(Es0, St0),
+ {#ibinary{anno=#a{anno=Anno},segments=Es},Eps,St};
+ Bin ->
+ {#c_literal{anno=Anno,val=Bin},[],St0}
+ end.
+
+%% constant_bin([{bin_element,_,_,_,_}]) -> binary() | error
+%% If the binary construction is truly constant (no variables,
+%% no native fields), and does not contain fields whose expansion
+%% become huge (such as <<0:100000000>>), evaluate and return the binary;
+%% otherwise return 'error'.
+
+constant_bin(Es) ->
+ try
+ constant_bin_1(Es)
+ catch
+ error -> error
+ end.
+
+constant_bin_1(Es) ->
+ verify_suitable_fields(Es),
+ EmptyBindings = erl_eval:new_bindings(),
+ EvalFun = fun({integer,_,I}, B) -> {value,I,B};
+ ({char,_,C}, B) -> {value,C,B};
+ ({float,_,F}, B) -> {value,F,B};
+ ({atom,_,undefined}, B) -> {value,undefined,B}
+ end,
+ case catch eval_bits:expr_grp(Es, EmptyBindings, EvalFun) of
+ {value,Bin,EmptyBindings} ->
+ Bin;
+ _ ->
+ error
+ end.
+
+%% verify_suitable_fields([{bin_element,_,Sz,Opts}=E|Es]) ->
+
+verify_suitable_fields([{bin_element,_,Val,SzTerm,Opts}|Es]) ->
+ case member(big, Opts) orelse member(little, Opts) of
+ true -> ok;
+ false -> throw(error) %Native endian.
+ end,
+ {unit,Unit} = keyfind(unit, 1, Opts),
+ case {SzTerm,Val} of
+ {{atom,_,undefined},{char,_,_}} ->
+ %% UTF-8/16/32.
+ ok;
+ {{atom,_,undefined},{integer,_,_}} ->
+ %% UTF-8/16/32.
+ ok;
+ {{integer,_,Sz},_} when Sz*Unit =< 256 ->
+ %% Don't be cheap - always accept fields up to this size.
+ ok;
+ {{integer,_,Sz0},{integer,_,Int}} ->
+ %% Estimate the number of bits needed to to hold the integer
+ %% literal. Check whether the field size is reasonable in
+ %% proportion to the number of bits needed.
+ Sz = Sz0*Unit,
+ case count_bits(Int) of
+ BitsNeeded when 2*BitsNeeded >= Sz ->
+ ok;
+ _ ->
+ %% More than about half of the field size will be
+ %% filled out with zeroes - not acceptable.
+ throw(error)
+ end;
+ {_,_} ->
+ %% Reject anything else. There are either variables,
+ %% or a float with a huge size or an embedded binary.
+ throw(error)
+ end,
+ verify_suitable_fields(Es);
+verify_suitable_fields([]) -> ok.
+
+%% Count the number of bits approximately needed to store Int.
+%% (We don't need an exact result for this purpose.)
+
+count_bits(Int) ->
+ count_bits_1(abs_line(Int), 64).
+
+count_bits_1(0, Bits) -> Bits;
+count_bits_1(Int, Bits) -> count_bits_1(Int bsr 64, Bits+64).
+
+expr_bin_1(Es, St) ->
+ foldr(fun (E, {Ces,Esp,St0}) ->
+ {Ce,Ep,St1} = bitstr(E, St0),
+ {[Ce|Ces],Ep ++ Esp,St1}
+ end, {[],[],St}, Es).
+
+bitstr({bin_element,_,E0,Size0,[Type,{unit,Unit}|Flags]}, St0) ->
+ {E1,Eps,St1} = safe(E0, St0),
+ {Size1,Eps2,St2} = safe(Size0, St1),
+ case {Type,E1} of
+ {_,#c_var{}} -> ok;
+ {integer,#c_literal{val=I}} when is_integer(I) -> ok;
+ {utf8,#c_literal{val=I}} when is_integer(I) -> ok;
+ {utf16,#c_literal{val=I}} when is_integer(I) -> ok;
+ {utf32,#c_literal{val=I}} when is_integer(I) -> ok;
+ {float,#c_literal{val=V}} when is_number(V) -> ok;
+ {binary,#c_literal{val=V}} when is_bitstring(V) -> ok;
+ {_,_} ->
+ throw(bad_binary)
+ end,
+ {#c_bitstr{val=E1,size=Size1,
+ unit=#c_literal{val=Unit},
+ type=#c_literal{val=Type},
+ flags=#c_literal{val=Flags}},
+ Eps ++ Eps2,St2}.
+
+%% fun_tq(Id, [Clauses], Line, State) -> {Fun,[PreExp],State}.
+
+fun_tq({_,_,Name}=Id, Cs0, L, St0) ->
+ Arity = clause_arity(hd(Cs0)),
+ {Cs1,St1} = clauses(Cs0, St0),
+ {Args,St2} = new_vars(Arity, St1),
+ {Ps,St3} = new_vars(Arity, St2), %Need new variables here
+ Fc = function_clause(Ps, {Name,Arity}),
+ Fun = #ifun{anno=#a{anno=lineno_anno(L, St3)},
+ id=[{id,Id}], %We KNOW!
+ vars=Args,clauses=Cs1,fc=Fc},
+ {Fun,[],St3}.
+
+%% lc_tq(Line, Exp, [Qualifier], Mc, State) -> {LetRec,[PreExp],State}.
+%% This TQ from Simon PJ pp 127-138.
+%% This gets a bit messy as we must transform all directly here. We
+%% recognise guard tests and try to fold them together and join to a
+%% preceding generators, this should give us better and more compact
+%% code.
+
+lc_tq(Line, E, [{generate,Lg,P,G}|Qs0], Mc, St0) ->
+ {Gs,Qs1} = splitwith(fun is_guard_test/1, Qs0),
+ {Name,St1} = new_fun_name("lc", St0),
+ {Head,St2} = new_var(St1),
+ {Tname,St3} = new_var_name(St2),
+ LA = lineno_anno(Line, St3),
+ LAnno = #a{anno=LA},
+ Tail = #c_var{anno=LA,name=Tname},
+ {Arg,St4} = new_var(St3),
+ {Nc,[],St5} = expr({call,Lg,{atom,Lg,Name},[{var,Lg,Tname}]}, St4),
+ {Guardc,St6} = lc_guard_tests(Gs, St5), %These are always flat!
+ {Lc,Lps,St7} = lc_tq(Line, E, Qs1, Nc, St6),
+ {Pc,St8} = list_gen_pattern(P, Line, St7),
+ {Gc,Gps,St9} = safe(G, St8), %Will be a function argument!
+ Fc = function_clause([Arg], LA, {Name,1}),
+
+ %% Avoid constructing a default clause if the list comprehension
+ %% only has a variable as generator and there are no guard
+ %% tests. In other words, if the comprehension is equivalent to
+ %% lists:map/2.
+ Cs0 = case {Guardc, Pc} of
+ {[], #c_var{}} ->
+ [#iclause{anno=LAnno,
+ pats=[#c_literal{anno=LA,val=[]}],guard=[],
+ body=[Mc]}];
+ _ ->
+ [#iclause{anno=#a{anno=[compiler_generated|LA]},
+ pats=[ann_c_cons(LA, Head, Tail)],
+ guard=[],
+ body=[Nc]},
+ #iclause{anno=LAnno,
+ pats=[#c_literal{anno=LA,val=[]}],guard=[],
+ body=[Mc]}]
+ end,
+ Cs = case Pc of
+ nomatch -> Cs0;
+ _ ->
+ [#iclause{anno=LAnno,
+ pats=[ann_c_cons(LA, Pc, Tail)],
+ guard=Guardc,
+ body=Lps ++ [Lc]}|Cs0]
+ end,
+ Fun = #ifun{anno=LAnno,id=[],vars=[Arg],clauses=Cs,fc=Fc},
+ {#iletrec{anno=LAnno,defs=[{{Name,1},Fun}],
+ body=Gps ++ [#iapply{anno=LAnno,
+ op=#c_var{anno=LA,name={Name,1}},
+ args=[Gc]}]},
+ [],St9};
+lc_tq(Line, E, [{b_generate,Lg,P,G}|Qs0], Mc, St0) ->
+ {Gs,Qs1} = splitwith(fun is_guard_test/1, Qs0),
+ {Name,St1} = new_fun_name("blc", St0),
+ {Tname,St2} = new_var_name(St1),
+ LA = lineno_anno(Line, St2),
+ LAnno = #a{anno=LA},
+ HeadBinPattern = pattern(P,St2),
+ #c_binary{segments=Ps} = HeadBinPattern,
+ {EPs,St3} = emasculate_segments(Ps,St2),
+ Tail = #c_var{anno=LA,name=Tname},
+ TailSegment = #c_bitstr{val=Tail,size=#c_literal{val=all},
+ unit=#c_literal{val=1},
+ type=#c_literal{val=binary},
+ flags=#c_literal{val=[big,unsigned]}},
+ Pattern = HeadBinPattern#c_binary{segments=Ps ++ [TailSegment]},
+ EPattern = HeadBinPattern#c_binary{segments=EPs ++ [TailSegment]},
+ {Arg,St4} = new_var(St3),
+ {Guardc,St5} = lc_guard_tests(Gs, St4), %These are always flat!
+ {Nc,[],St6} = expr({call,Lg,{atom,Lg,Name},[{var,Lg,Tname}]}, St5),
+ {Bc,Bps,St7} = lc_tq(Line, E, Qs1, Nc, St6),
+ {Gc,Gps,St10} = safe(G, St7), %Will be a function argument!
+ Fc = function_clause([Arg], LA, {Name,1}),
+ Cs = [#iclause{anno=#a{anno=[compiler_generated|LA]},
+ pats=[Pattern],
+ guard=Guardc,
+ body=Bps ++ [Bc]},
+ #iclause{anno=#a{anno=[compiler_generated|LA]},
+ pats=[EPattern],
+ guard=[],
+ body=[#iapply{anno=LAnno,
+ op=#c_var{anno=LA,name={Name,1}},
+ args=[Tail]}]},
+ #iclause{anno=LAnno,
+ pats=[#c_binary{anno=LA, segments=[TailSegment]}],guard=[],
+ body=[Mc]}],
+ Fun = #ifun{anno=LAnno,id=[],vars=[Arg],clauses=Cs,fc=Fc},
+ {#iletrec{anno=LAnno,defs=[{{Name,1},Fun}],
+ body=Gps ++ [#iapply{anno=LAnno,
+ op=#c_var{anno=LA,name={Name,1}},
+ args=[Gc]}]},
+ [],St10};
+lc_tq(Line, E, [Fil0|Qs0], Mc, St0) ->
+ %% Special case sequences guard tests.
+ LA = lineno_anno(Line, St0),
+ LAnno = #a{anno=LA},
+ case is_guard_test(Fil0) of
+ true ->
+ {Gs0,Qs1} = splitwith(fun is_guard_test/1, Qs0),
+ {Lc,Lps,St1} = lc_tq(Line, E, Qs1, Mc, St0),
+ {Gs,St2} = lc_guard_tests([Fil0|Gs0], St1), %These are always flat!
+ {#icase{anno=LAnno,
+ args=[],
+ clauses=[#iclause{anno=LAnno,pats=[],
+ guard=Gs,body=Lps ++ [Lc]}],
+ fc=#iclause{anno=LAnno,pats=[],guard=[],body=[Mc]}},
+ [],St2};
+ false ->
+ {Lc,Lps,St1} = lc_tq(Line, E, Qs0, Mc, St0),
+ {Fpat,St2} = new_var(St1),
+ Fc = fail_clause([Fpat], c_tuple([#c_literal{val=case_clause},Fpat])),
+ %% Do a novars little optimisation here.
+ {Filc,Fps,St3} = novars(Fil0, St2),
+ {#icase{anno=LAnno,
+ args=[Filc],
+ clauses=[#iclause{anno=LAnno,
+ pats=[#c_literal{anno=LA,val=true}],
+ guard=[],
+ body=Lps ++ [Lc]},
+ #iclause{anno=LAnno#a{anno=[compiler_generated|LA]},
+ pats=[#c_literal{anno=LA,val=false}],
+ guard=[],
+ body=[Mc]}],
+ fc=Fc},
+ Fps,St3}
+ end;
+lc_tq(Line, E0, [], Mc0, St0) ->
+ {H1,Hps,St1} = safe(E0, St0),
+ {T1,Tps,St} = force_safe(Mc0, St1),
+ Anno = lineno_anno(Line, St),
+ E = ann_c_cons(Anno, H1, T1),
+ {set_anno(E, [compiler_generated|Anno]),Hps ++ Tps,St}.
+
+%% bc_tq(Line, Exp, [Qualifier], More, State) -> {LetRec,[PreExp],State}.
+%% This TQ from Gustafsson ERLANG'05.
+%% This gets a bit messy as we must transform all directly here. We
+%% recognise guard tests and try to fold them together and join to a
+%% preceding generators, this should give us better and more compact
+%% code.
+%% More could be transformed before calling bc_tq.
+
+bc_tq(Line, Exp, Qualifiers, _, St0) ->
+ {BinVar,St1} = new_var(St0),
+ {Sz,SzPre,St2} = bc_initial_size(Exp, Qualifiers, St1),
+ {E,BcPre,St} = bc_tq1(Line, Exp, Qualifiers, BinVar, St2),
+ Pre = SzPre ++
+ [#iset{var=BinVar,
+ arg=#iprimop{name=#c_literal{val=bs_init_writable},
+ args=[Sz]}}] ++ BcPre,
+ {E,Pre,St}.
+
+bc_tq1(Line, E, [{generate,Lg,P,G}|Qs0], AccExpr, St0) ->
+ {Gs,Qs1} = splitwith(fun is_guard_test/1, Qs0),
+ {Name,St1} = new_fun_name("lbc", St0),
+ LA = lineno_anno(Line, St1),
+ {[Head,Tail,AccVar],St2} = new_vars(LA, 3, St1),
+ LAnno = #a{anno=LA},
+ {Arg,St3} = new_var(St2),
+ NewMore = {call,Lg,{atom,Lg,Name},[{var,Lg,Tail#c_var.name},
+ {var,Lg,AccVar#c_var.name}]},
+ {Guardc,St4} = lc_guard_tests(Gs, St3), %These are always flat!
+ {Lc,Lps,St5} = bc_tq1(Line, E, Qs1, AccVar, St4),
+ {Nc,Nps,St6} = expr(NewMore, St5),
+ {Pc,St7} = list_gen_pattern(P, Line, St6),
+ {Gc,Gps,St8} = safe(G, St7), %Will be a function argument!
+ Fc = function_clause([Arg,AccVar], LA, {Name,2}),
+ Cs0 = case {Guardc, Pc} of
+ {[], #c_var{}} ->
+ [#iclause{anno=LAnno,
+ pats=[#c_literal{anno=LA,val=[]},AccVar],guard=[],
+ body=[AccVar]}];
+ _ ->
+ [#iclause{anno=#a{anno=[compiler_generated|LA]},
+ pats=[ann_c_cons(LA, Head, Tail),AccVar],
+ guard=[],
+ body=Nps ++ [Nc]},
+ #iclause{anno=LAnno,
+ pats=[#c_literal{anno=LA,val=[]},AccVar],guard=[],
+ body=[AccVar]}]
+ end,
+ Cs = case Pc of
+ nomatch -> Cs0;
+ _ ->
+ Body = Lps ++ Nps ++ [#iset{var=AccVar,arg=Lc},Nc],
+ [#iclause{anno=LAnno,
+ pats=[ann_c_cons(LA,Pc,Tail),AccVar],
+ guard=Guardc,
+ body=Body}|Cs0]
+ end,
+ Fun = #ifun{anno=LAnno,id=[],vars=[Arg,AccVar],clauses=Cs,fc=Fc},
+ {#iletrec{anno=LAnno,defs=[{{Name,2},Fun}],
+ body=Gps ++ [#iapply{anno=LAnno,
+ op=#c_var{anno=LA,name={Name,2}},
+ args=[Gc,AccExpr]}]},
+ [],St8};
+bc_tq1(Line, E, [{b_generate,Lg,P,G}|Qs0], AccExpr, St0) ->
+ {Gs,Qs1} = splitwith(fun is_guard_test/1, Qs0),
+ {Name,St1} = new_fun_name("lbc", St0),
+ LA = lineno_anno(Line, St1),
+ {[Tail,AccVar],St2} = new_vars(LA, 2, St1),
+ LAnno = #a{anno=LA},
+ HeadBinPattern = pattern(P, St2),
+ #c_binary{segments=Ps} = HeadBinPattern,
+ {EPs,St3} = emasculate_segments(Ps, St2),
+ TailSegment = #c_bitstr{val=Tail,size=#c_literal{val=all},
+ unit=#c_literal{val=1},
+ type=#c_literal{val=binary},
+ flags=#c_literal{val=[big,unsigned]}},
+ Pattern = HeadBinPattern#c_binary{segments=Ps ++ [TailSegment]},
+ EPattern = HeadBinPattern#c_binary{segments=EPs ++ [TailSegment]},
+ {Arg,St4} = new_var(St3),
+ NewMore = {call,Lg,{atom,Lg,Name},[{var,Lg,Tail#c_var.name},
+ {var,Lg,AccVar#c_var.name}]},
+ {Guardc,St5} = lc_guard_tests(Gs, St4), %These are always flat!
+ {Bc,Bps,St6} = bc_tq1(Line, E, Qs1, AccVar, St5),
+ {Nc,Nps,St7} = expr(NewMore, St6),
+ {Gc,Gps,St8} = safe(G, St7), %Will be a function argument!
+ Fc = function_clause([Arg,AccVar], LA, {Name,2}),
+ Body = Bps ++ Nps ++ [#iset{var=AccVar,arg=Bc},Nc],
+ Cs = [#iclause{anno=LAnno,
+ pats=[Pattern,AccVar],
+ guard=Guardc,
+ body=Body},
+ #iclause{anno=#a{anno=[compiler_generated|LA]},
+ pats=[EPattern,AccVar],
+ guard=[],
+ body=Nps ++ [Nc]},
+ #iclause{anno=LAnno,
+ pats=[#c_binary{anno=LA,segments=[TailSegment]},AccVar],
+ guard=[],
+ body=[AccVar]}],
+ Fun = #ifun{anno=LAnno,id=[],vars=[Arg,AccVar],clauses=Cs,fc=Fc},
+ {#iletrec{anno=LAnno,defs=[{{Name,2},Fun}],
+ body=Gps ++ [#iapply{anno=LAnno,
+ op=#c_var{anno=LA,name={Name,2}},
+ args=[Gc,AccExpr]}]},
+ [],St8};
+bc_tq1(Line, E, [Fil0|Qs0], AccVar, St0) ->
+ %% Special case sequences guard tests.
+ LA = lineno_anno(Line, St0),
+ LAnno = #a{anno=LA},
+ case is_guard_test(Fil0) of
+ true ->
+ {Gs0,Qs1} = splitwith(fun is_guard_test/1, Qs0),
+ {Bc,Bps,St1} = bc_tq1(Line, E, Qs1, AccVar, St0),
+ {Gs,St} = lc_guard_tests([Fil0|Gs0], St1), %These are always flat!
+ {#icase{anno=LAnno,
+ args=[],
+ clauses=[#iclause{anno=LAnno,
+ pats=[],
+ guard=Gs,body=Bps ++ [Bc]}],
+ fc=#iclause{anno=LAnno,pats=[],guard=[],body=[AccVar]}},
+ [],St};
+ false ->
+ {Bc,Bps,St1} = bc_tq1(Line, E, Qs0, AccVar, St0),
+ {Fpat,St2} = new_var(St1),
+ Fc = fail_clause([Fpat], c_tuple([#c_literal{val=case_clause},Fpat])),
+ %% Do a novars little optimisation here.
+ {Filc,Fps,St} = novars(Fil0, St2),
+ {#icase{anno=LAnno,
+ args=[Filc],
+ clauses=[#iclause{anno=LAnno,
+ pats=[#c_literal{anno=LA,val=true}],
+ guard=[],
+ body=Bps ++ [Bc]},
+ #iclause{anno=LAnno#a{anno=[compiler_generated|LA]},
+ pats=[#c_literal{anno=LA,val=false}],
+ guard=[],
+ body=[AccVar]}],
+ fc=Fc},
+ Fps,St}
+ end;
+bc_tq1(_, {bin,Bl,Elements}, [], AccVar, St0) ->
+ {E,Pre,St} = expr({bin,Bl,[{bin_element,Bl,
+ {var,Bl,AccVar#c_var.name},
+ {atom,Bl,all},
+ [binary,{unit,1}]}|Elements]}, St0),
+ #a{anno=A} = Anno0 = get_anno(E),
+ Anno = Anno0#a{anno=[compiler_generated,single_use|A]},
+ %%Anno = Anno0#a{anno=[compiler_generated|A]},
+ {set_anno(E, Anno),Pre,St}.
+
+emasculate_segments(Segs, St) ->
+ emasculate_segments(Segs, St, []).
+
+emasculate_segments([#c_bitstr{val=#c_var{}}=B|Rest], St, Acc) ->
+ emasculate_segments(Rest, St, [B|Acc]);
+emasculate_segments([B|Rest], St0, Acc) ->
+ {Var,St1} = new_var(St0),
+ emasculate_segments(Rest, St1, [B#c_bitstr{val=Var}|Acc]);
+emasculate_segments([], St, Acc) ->
+ {lists:reverse(Acc),St}.
+
+lc_guard_tests([], St) -> {[],St};
+lc_guard_tests(Gs0, St0) ->
+ Gs1 = guard_tests(Gs0),
+ {Gs,St} = gexpr_top(Gs1, St0#core{in_guard=true}),
+ {Gs,St#core{in_guard=false}}.
+
+list_gen_pattern(P0, Line, St) ->
+ try
+ {pattern(P0, St),St}
+ catch
+ nomatch -> {nomatch,add_warning(Line, nomatch, St)}
+ end.
+
+%%%
+%%% Generate code to calculate the initial size for
+%%% the result binary in a binary comprehension.
+%%%
+
+bc_initial_size(E, Q, St0) ->
+ try
+ {ElemSzExpr,ElemSzPre,St1} = bc_elem_size(E, St0),
+ {V,St2} = new_var(St1),
+ {GenSzExpr,GenSzPre,St3} = bc_gen_size(Q, St2),
+ case ElemSzExpr of
+ #c_literal{val=ElemSz} when ElemSz rem 8 =:= 0 ->
+ NumBytesExpr = #c_literal{val=ElemSz div 8},
+ BytesExpr = [#iset{var=V,
+ arg=bc_mul(GenSzExpr, NumBytesExpr)}],
+ {V,ElemSzPre++GenSzPre++BytesExpr,St3};
+ _ ->
+ {[BitsV,PlusSevenV],St} = new_vars(2, St3),
+ BitsExpr = #iset{var=BitsV,arg=bc_mul(GenSzExpr, ElemSzExpr)},
+ PlusSevenExpr = #iset{var=PlusSevenV,
+ arg=bc_add(BitsV, #c_literal{val=7})},
+ Expr = #iset{var=V,
+ arg=bc_bsr(PlusSevenV, #c_literal{val=3})},
+ {V,ElemSzPre++GenSzPre++
+ [BitsExpr,PlusSevenExpr,Expr],St}
+ end
+ catch
+ throw:impossible ->
+ {#c_literal{val=256},[],St0}
+ end.
+
+bc_elem_size({bin,_,El}, St0) ->
+ case bc_elem_size_1(El, 0, []) of
+ {Bits,[]} ->
+ {#c_literal{val=Bits},[],St0};
+ {Bits,Vars0} ->
+ [{U,V0}|Pairs] = sort(Vars0),
+ F = bc_elem_size_combine(Pairs, U, [V0], []),
+ bc_mul_pairs(F, #c_literal{val=Bits}, [], St0)
+ end.
+
+bc_elem_size_1([{bin_element,_,_,{integer,_,N},Flags}|Es], Bits, Vars) ->
+ {unit,U} = keyfind(unit, 1, Flags),
+ bc_elem_size_1(Es, Bits+U*N, Vars);
+bc_elem_size_1([{bin_element,_,_,{var,_,Var},Flags}|Es], Bits, Vars) ->
+ {unit,U} = keyfind(unit, 1, Flags),
+ bc_elem_size_1(Es, Bits, [{U,#c_var{name=Var}}|Vars]);
+bc_elem_size_1([_|_], _, _) ->
+ throw(impossible);
+bc_elem_size_1([], Bits, Vars) ->
+ {Bits,Vars}.
+
+bc_elem_size_combine([{U,V}|T], U, UVars, Acc) ->
+ bc_elem_size_combine(T, U, [V|UVars], Acc);
+bc_elem_size_combine([{U,V}|T], OldU, UVars, Acc) ->
+ bc_elem_size_combine(T, U, [V], [{OldU,UVars}|Acc]);
+bc_elem_size_combine([], U, Uvars, Acc) ->
+ [{U,Uvars}|Acc].
+
+bc_mul_pairs([{U,L0}|T], E0, Pre, St0) ->
+ {AddExpr,AddPre,St1} = bc_add_list(L0, St0),
+ {[V1,V2],St} = new_vars(2, St1),
+ Set1 = #iset{var=V1,arg=bc_mul(AddExpr, #c_literal{val=U})},
+ Set2 = #iset{var=V2,arg=bc_add(V1, E0)},
+ bc_mul_pairs(T, V2, [Set2,Set1|reverse(AddPre, Pre)], St);
+bc_mul_pairs([], E, Pre, St) ->
+ {E,reverse(Pre),St}.
+
+bc_add_list([V], St) ->
+ {V,[],St};
+bc_add_list([H|T], St) ->
+ bc_add_list_1(T, [], H, St).
+
+bc_add_list_1([H|T], Pre, E, St0) ->
+ {Var,St} = new_var(St0),
+ Set = #iset{var=Var,arg=bc_add(H, E)},
+ bc_add_list_1(T, [Set|Pre], Var, St);
+bc_add_list_1([], Pre, E, St) ->
+ {E,reverse(Pre),St}.
+
+bc_gen_size(Q, St) ->
+ bc_gen_size_1(Q, #c_literal{val=1}, [], St).
+
+bc_gen_size_1([{generate,L,El,Gen}|Qs], E0, Pre0, St0) ->
+ bc_verify_non_filtering(El),
+ case Gen of
+ {var,_,ListVar} ->
+ Lanno = lineno_anno(L, St0),
+ {LenVar,St1} = new_var(St0),
+ Set = #iset{var=LenVar,
+ arg=#icall{anno=#a{anno=Lanno},
+ module=#c_literal{val=erlang},
+ name=#c_literal{val=length},
+ args=[#c_var{name=ListVar}]}},
+ {E,Pre,St} = bc_gen_size_mul(E0, LenVar, [Set|Pre0], St1),
+ bc_gen_size_1(Qs, E, Pre, St);
+ _ ->
+ %% The only expressions we handle is literal lists.
+ Len = bc_list_length(Gen, 0),
+ {E,Pre,St} = bc_gen_size_mul(E0, #c_literal{val=Len}, Pre0, St0),
+ bc_gen_size_1(Qs, E, Pre, St)
+ end;
+bc_gen_size_1([{b_generate,_,El,Gen}|Qs], E0, Pre0, St0) ->
+ bc_verify_non_filtering(El),
+ {MatchSzExpr,Pre1,St1} = bc_elem_size(El, St0),
+ Pre2 = reverse(Pre1, Pre0),
+ {ResVar,St2} = new_var(St1),
+ {BitSizeExpr,Pre3,St3} = bc_gen_bit_size(Gen, Pre2, St2),
+ Div = #iset{var=ResVar,arg=bc_div(BitSizeExpr,
+ MatchSzExpr)},
+ Pre4 = [Div|Pre3],
+ {E,Pre,St} = bc_gen_size_mul(E0, ResVar, Pre4, St3),
+ bc_gen_size_1(Qs, E, Pre, St);
+bc_gen_size_1([], E, Pre, St) ->
+ {E,reverse(Pre),St};
+bc_gen_size_1(_, _, _, _) ->
+ throw(impossible).
+
+bc_gen_bit_size({var,L,V}, Pre0, St0) ->
+ Lanno = lineno_anno(L, St0),
+ {SzVar,St} = new_var(St0),
+ Pre = [#iset{var=SzVar,
+ arg=#icall{anno=#a{anno=Lanno},
+ module=#c_literal{val=erlang},
+ name=#c_literal{val=bit_size},
+ args=[#c_var{name=V}]}}|Pre0],
+ {SzVar,Pre,St};
+bc_gen_bit_size({bin,_,_}=Bin, Pre, St) ->
+ {#c_literal{val=bc_bin_size(Bin)},Pre,St};
+bc_gen_bit_size(_, _, _) ->
+ throw(impossible).
+
+bc_verify_non_filtering({bin,_,Els}) ->
+ foreach(fun({bin_element,_,{var,_,_},_,_}) -> ok;
+ (_) -> throw(impossible)
+ end, Els);
+bc_verify_non_filtering({var,_,_}) ->
+ ok;
+bc_verify_non_filtering(_) ->
+ throw(impossible).
+
+bc_list_length({string,_,Str}, Len) ->
+ Len + length(Str);
+bc_list_length({cons,_,_,T}, Len) ->
+ bc_list_length(T, Len+1);
+bc_list_length({nil,_}, Len) ->
+ Len;
+bc_list_length(_, _) ->
+ throw(impossible).
+
+bc_bin_size({bin,_,Els}) ->
+ bc_bin_size_1(Els, 0).
+
+bc_bin_size_1([{bin_element,_,_,{integer,_,Sz},Flags}|Els], N) ->
+ {unit,U} = keyfind(unit, 1, Flags),
+ bc_bin_size_1(Els, N+U*Sz);
+bc_bin_size_1([], N) -> N;
+bc_bin_size_1(_, _) -> throw(impossible).
+
+bc_gen_size_mul(#c_literal{val=1}, E, Pre, St) ->
+ {E,Pre,St};
+bc_gen_size_mul(E1, E2, Pre, St0) ->
+ {V,St} = new_var(St0),
+ {V,[#iset{var=V,arg=bc_mul(E1, E2)}|Pre],St}.
+
+bc_mul(E1, #c_literal{val=1}) ->
+ E1;
+bc_mul(E1, E2) ->
+ #icall{module=#c_literal{val=erlang},
+ name=#c_literal{val='*'},
+ args=[E1,E2]}.
+
+bc_div(E1, E2) ->
+ #icall{module=#c_literal{val=erlang},
+ name=#c_literal{val='div'},
+ args=[E1,E2]}.
+
+bc_add(E1, #c_literal{val=0}) ->
+ E1;
+bc_add(E1, E2) ->
+ #icall{module=#c_literal{val=erlang},
+ name=#c_literal{val='+'},
+ args=[E1,E2]}.
+
+bc_bsr(E1, E2) ->
+ #icall{module=#c_literal{val=erlang},
+ name=#c_literal{val='bsr'},
+ args=[E1,E2]}.
+
+%% is_guard_test(Expression) -> true | false.
+%% Test if a general expression is a guard test. Use erl_lint here
+%% as it now allows sys_pre_expand transformed source.
+
+is_guard_test(E) -> erl_lint:is_guard_test(E).
+
+%% novars(Expr, State) -> {Novars,[PreExpr],State}.
+%% Generate a novars expression, basically a call or a safe. At this
+%% level we do not need to do a deep check.
+
+novars(E0, St0) ->
+ {E1,Eps,St1} = expr(E0, St0),
+ {Se,Sps,St2} = force_novars(E1, St1),
+ {Se,Eps ++ Sps,St2}.
+
+force_novars(#iapply{}=App, St) -> {App,[],St};
+force_novars(#icall{}=Call, St) -> {Call,[],St};
+force_novars(#ifun{}=Fun, St) -> {Fun,[],St}; %These are novars too
+force_novars(#ibinary{}=Bin, St) -> {Bin,[],St};
+force_novars(Ce, St) ->
+ force_safe(Ce, St).
+
+%% safe(Expr, State) -> {Safe,[PreExpr],State}.
+%% Generate an internal safe expression. These are simples without
+%% binaries which can fail. At this level we do not need to do a
+%% deep check. Must do special things with matches here.
+
+safe(E0, St0) ->
+ {E1,Eps,St1} = expr(E0, St0),
+ {Se,Sps,St2} = force_safe(E1, St1),
+ {Se,Eps ++ Sps,St2}.
+
+safe_list(Es, St) ->
+ foldr(fun (E, {Ces,Esp,St0}) ->
+ {Ce,Ep,St1} = safe(E, St0),
+ {[Ce|Ces],Ep ++ Esp,St1}
+ end, {[],[],St}, Es).
+
+force_safe(#imatch{pat=P,arg=E}=Imatch, St0) ->
+ {Le,Lps0,St1} = force_safe(E, St0),
+ Lps = Lps0 ++ [Imatch#imatch{arg=Le}],
+
+ %% Make sure we don't duplicate the expression E. sys_core_fold
+ %% will usually optimize away the duplicate expression, but may
+ %% generate a warning while doing so.
+ case Le of
+ #c_var{} ->
+ %% Le is a variable.
+ %% Thus: P = Le, Le. (Traditional, since the V2 compiler.)
+ {Le,Lps,St1};
+ _ ->
+ %% Le is not a variable.
+ %% Thus: NewVar = P = Le, NewVar. (New for R12B-1.)
+ %%
+ %% Note: It is tempting to rewrite V = Le to V = Le, V,
+ %% but that will generate extra warnings in sys_core_fold
+ %% for this expression:
+ %%
+ %% [{X,Y} || {X,_} <- E, (Y = X) =:= (Y = 1 + 1)]
+ %%
+ %% (There will be a 'case Y =:= Y of...' which will generate
+ %% a warning.)
+ {V,St2} = new_var(St1),
+ {V,Lps0 ++ [Imatch#imatch{pat=#c_alias{var=V,pat=P},arg=Le}],St2}
+ end;
+force_safe(Ce, St0) ->
+ case is_safe(Ce) of
+ true -> {Ce,[],St0};
+ false ->
+ {V,St1} = new_var(St0),
+ {V,[#iset{var=V,arg=Ce}],St1}
+ end.
+
+is_safe(#c_cons{}) -> true;
+is_safe(#c_tuple{}) -> true;
+is_safe(#c_var{}) -> true;
+is_safe(#c_literal{}) -> true;
+is_safe(_) -> false.
+
+%% fold_match(MatchExpr, Pat) -> {MatchPat,Expr}.
+%% Fold nested matches into one match with aliased patterns.
+
+fold_match({match,L,P0,E0}, P) ->
+ {P1,E1} = fold_match(E0, P),
+ {{match,L,P0,P1},E1};
+fold_match(E, P) -> {P,E}.
+
+%% pattern(Pattern, State) -> CorePat.
+%% Transform a pattern by removing line numbers. We also normalise
+%% aliases in patterns to standard form, {alias,Pat,[Var]}.
+
+pattern({var,L,V}, St) -> #c_var{anno=lineno_anno(L, St),name=V};
+pattern({char,L,C}, St) -> #c_literal{anno=lineno_anno(L, St),val=C};
+pattern({integer,L,I}, St) -> #c_literal{anno=lineno_anno(L, St),val=I};
+pattern({float,L,F}, St) -> #c_literal{anno=lineno_anno(L, St),val=F};
+pattern({atom,L,A}, St) -> #c_literal{anno=lineno_anno(L, St),val=A};
+pattern({string,L,S}, St) -> #c_literal{anno=lineno_anno(L, St),val=S};
+pattern({nil,L}, St) -> #c_literal{anno=lineno_anno(L, St),val=[]};
+pattern({cons,L,H,T}, St) ->
+ ann_c_cons(lineno_anno(L, St), pattern(H, St), pattern(T, St));
+pattern({tuple,L,Ps}, St) ->
+ ann_c_tuple(lineno_anno(L, St), pattern_list(Ps, St));
+pattern({bin,L,Ps}, #core{opts=Opts}=St) ->
+ case member(no_binaries, Opts) of
+ false ->
+ %% We don't create a #ibinary record here, since there is
+ %% no need to hold any used/new annotations in a pattern.
+ #c_binary{anno=lineno_anno(L, St),segments=pat_bin(Ps, St)};
+ true ->
+ throw(no_binaries)
+ end;
+pattern({match,_,P1,P2}, St) ->
+ pat_alias(pattern(P1, St), pattern(P2, St)).
+
+%% pat_bin([BinElement], State) -> [BinSeg].
+
+pat_bin(Ps, St) -> [pat_segment(P, St) || P <- Ps].
+
+pat_segment({bin_element,_,Term,Size,[Type,{unit,Unit}|Flags]}, St) ->
+ #c_bitstr{val=pattern(Term, St),size=pattern(Size, St),
+ unit=#c_literal{val=Unit},
+ type=#c_literal{val=Type},
+ flags=#c_literal{val=Flags}}.
+
+%% pat_alias(CorePat, CorePat) -> AliasPat.
+%% Normalise aliases. Trap bad aliases by throwing 'nomatch'.
+
+pat_alias(#c_var{name=V1}, P2) -> #c_alias{var=#c_var{name=V1},pat=P2};
+pat_alias(P1, #c_var{name=V2}) -> #c_alias{var=#c_var{name=V2},pat=P1};
+pat_alias(#c_cons{}=Cons, #c_literal{anno=A,val=[H|T]}=S) ->
+ pat_alias(Cons, ann_c_cons_skel(A, #c_literal{anno=A,val=H},
+ S#c_literal{val=T}));
+pat_alias(#c_literal{anno=A,val=[H|T]}=S, #c_cons{}=Cons) ->
+ pat_alias(ann_c_cons_skel(A, #c_literal{anno=A,val=H},
+ S#c_literal{val=T}), Cons);
+pat_alias(#c_cons{anno=Anno,hd=H1,tl=T1}, #c_cons{hd=H2,tl=T2}) ->
+ ann_c_cons(Anno, pat_alias(H1, H2), pat_alias(T1, T2));
+pat_alias(#c_tuple{anno=Anno,es=Es1}, #c_literal{val=T}) when is_tuple(T) ->
+ Es2 = [#c_literal{val=E} || E <- tuple_to_list(T)],
+ ann_c_tuple(Anno, pat_alias_list(Es1, Es2));
+pat_alias(#c_literal{anno=Anno,val=T}, #c_tuple{es=Es2}) when is_tuple(T) ->
+ Es1 = [#c_literal{val=E} || E <- tuple_to_list(T)],
+ ann_c_tuple(Anno, pat_alias_list(Es1, Es2));
+pat_alias(#c_tuple{anno=Anno,es=Es1}, #c_tuple{es=Es2}) ->
+ ann_c_tuple(Anno, pat_alias_list(Es1, Es2));
+pat_alias(#c_alias{var=V1,pat=P1},
+ #c_alias{var=V2,pat=P2}) ->
+ if V1 =:= V2 -> #c_alias{var=V1,pat=pat_alias(P1, P2)};
+ true -> #c_alias{var=V1,pat=#c_alias{var=V2,pat=pat_alias(P1, P2)}}
+ end;
+pat_alias(#c_alias{var=V1,pat=P1}, P2) ->
+ #c_alias{var=V1,pat=pat_alias(P1, P2)};
+pat_alias(P1, #c_alias{var=V2,pat=P2}) ->
+ #c_alias{var=V2,pat=pat_alias(P1, P2)};
+pat_alias(P1, P2) ->
+ case {set_anno(P1, []),set_anno(P2, [])} of
+ {P,P} -> P;
+ _ -> throw(nomatch)
+ end.
+
+%% pat_alias_list([A1], [A2]) -> [A].
+
+pat_alias_list([A1|A1s], [A2|A2s]) ->
+ [pat_alias(A1, A2)|pat_alias_list(A1s, A2s)];
+pat_alias_list([], []) -> [];
+pat_alias_list(_, _) -> throw(nomatch).
+
+%% pattern_list([P], State) -> [P].
+
+pattern_list(Ps, St) -> [pattern(P, St) || P <- Ps].
+
+%% first([A]) -> [A].
+%% last([A]) -> A.
+
+first([_]) -> [];
+first([H|T]) -> [H|first(T)].
+
+last([L]) -> L;
+last([_|T]) -> last(T).
+
+%% make_vars([Name]) -> [{Var,Name}].
+
+make_vars(Vs) -> [ #c_var{name=V} || V <- Vs ].
+
+%% new_fun_name(Type, State) -> {FunName,State}.
+
+new_fun_name(Type, #core{fcount=C}=St) ->
+ {list_to_atom(Type ++ "$^" ++ integer_to_list(C)),St#core{fcount=C+1}}.
+
+%% new_var_name(State) -> {VarName,State}.
+
+new_var_name(#core{vcount=C}=St) ->
+ {list_to_atom("cor" ++ integer_to_list(C)),St#core{vcount=C + 1}}.
+
+%% new_var(State) -> {{var,Name},State}.
+%% new_var(LineAnno, State) -> {{var,Name},State}.
+
+new_var(St) ->
+ new_var([], St).
+
+new_var(Anno, St0) ->
+ {New,St} = new_var_name(St0),
+ {#c_var{anno=Anno,name=New},St}.
+
+%% new_vars(Count, State) -> {[Var],State}.
+%% new_vars(Anno, Count, State) -> {[Var],State}.
+%% Make Count new variables.
+
+new_vars(N, St) -> new_vars_1(N, [], St, []).
+new_vars(Anno, N, St) -> new_vars_1(N, Anno, St, []).
+
+new_vars_1(N, Anno, St0, Vs) when N > 0 ->
+ {V,St1} = new_var(Anno, St0),
+ new_vars_1(N-1, Anno, St1, [V|Vs]);
+new_vars_1(0, _, St, Vs) -> {Vs,St}.
+
+function_clause(Ps, Name) ->
+ fail_clause(Ps, c_tuple([#c_literal{anno=[{name,Name}],
+ val=function_clause}|Ps])).
+function_clause(Ps, Anno, Name) ->
+ fail_clause(Ps, ann_c_tuple(Anno,
+ [#c_literal{anno=[{name,Name}],
+ val=function_clause}|Ps])).
+
+fail_clause(Pats, A) ->
+ #iclause{anno=#a{anno=[compiler_generated]},
+ pats=Pats,guard=[],
+ body=[#iprimop{anno=#a{},name=#c_literal{val=match_fail},args=[A]}]}.
+
+ubody(B, St) -> uexpr(B, [], St).
+
+%% uclauses([Lclause], [KnownVar], State) -> {[Lclause],State}.
+
+uclauses(Lcs, Ks, St0) ->
+ mapfoldl(fun (Lc, St) -> uclause(Lc, Ks, St) end, St0, Lcs).
+
+%% uclause(Lclause, [KnownVar], State) -> {Lclause,State}.
+
+uclause(Cl0, Ks, St0) ->
+ {Cl1,_Pvs,Used,New,St1} = uclause(Cl0, Ks, Ks, St0),
+ A0 = get_ianno(Cl1),
+ A = A0#a{us=Used,ns=New},
+ {Cl1#iclause{anno=A},St1}.
+
+uclause(#iclause{anno=Anno,pats=Ps0,guard=G0,body=B0}, Pks, Ks0, St0) ->
+ {Ps1,Pg,Pvs,Pus,St1} = upattern_list(Ps0, Pks, St0),
+ Pu = union(Pus, intersection(Pvs, Ks0)),
+ Pn = subtract(Pvs, Pu),
+ Ks1 = union(Pn, Ks0),
+ {G1,St2} = uguard(Pg, G0, Ks1, St1),
+ Gu = used_in_any(G1),
+ Gn = new_in_any(G1),
+ Ks2 = union(Gn, Ks1),
+ {B1,St3} = uexprs(B0, Ks2, St2),
+ Used = intersection(union([Pu,Gu,used_in_any(B1)]), Ks0),
+ New = union([Pn,Gn,new_in_any(B1)]),
+ {#iclause{anno=Anno,pats=Ps1,guard=G1,body=B1},Pvs,Used,New,St3}.
+
+%% uguard([Test], [Kexpr], [KnownVar], State) -> {[Kexpr],State}.
+%% Build a guard expression list by folding in the equality tests.
+
+uguard([], [], _, St) -> {[],St};
+uguard(Pg, [], Ks, St) ->
+ %% No guard, so fold together equality tests.
+ uguard(first(Pg), [last(Pg)], Ks, St);
+uguard(Pg, Gs0, Ks, St0) ->
+ %% Gs0 must contain at least one element here.
+ {Gs3,St5} = foldr(fun (T, {Gs1,St1}) ->
+ {L,St2} = new_var(St1),
+ {R,St3} = new_var(St2),
+ {[#iset{var=L,arg=T}] ++ first(Gs1) ++
+ [#iset{var=R,arg=last(Gs1)},
+ #icall{anno=#a{}, %Must have an #a{}
+ module=#c_literal{val=erlang},
+ name=#c_literal{val='and'},
+ args=[L,R]}],
+ St3}
+ end, {Gs0,St0}, Pg),
+ %%ok = io:fwrite("core ~w: ~p~n", [?LINE,Gs3]),
+ uexprs(Gs3, Ks, St5).
+
+%% uexprs([Kexpr], [KnownVar], State) -> {[Kexpr],State}.
+
+uexprs([#imatch{anno=A,pat=P0,arg=Arg,fc=Fc}|Les], Ks, St0) ->
+ %% Optimise for simple set of unbound variable.
+ case upattern(P0, Ks, St0) of
+ {#c_var{},[],_Pvs,_Pus,_} ->
+ %% Throw our work away and just set to iset.
+ uexprs([#iset{var=P0,arg=Arg}|Les], Ks, St0);
+ _Other ->
+ %% Throw our work away and set to icase.
+ if
+ Les =:= [] ->
+ %% Need to explicitly return match "value", make
+ %% safe for efficiency.
+ {La0,Lps,St1} = force_safe(Arg, St0),
+ La = mark_compiler_generated(La0),
+ Mc = #iclause{anno=A,pats=[P0],guard=[],body=[La]},
+ uexprs(Lps ++ [#icase{anno=A,
+ args=[La0],clauses=[Mc],fc=Fc}], Ks, St1);
+ true ->
+ Mc = #iclause{anno=A,pats=[P0],guard=[],body=Les},
+ uexprs([#icase{anno=A,args=[Arg],
+ clauses=[Mc],fc=Fc}], Ks, St0)
+ end
+ end;
+uexprs([Le0|Les0], Ks, St0) ->
+ {Le1,St1} = uexpr(Le0, Ks, St0),
+ {Les1,St2} = uexprs(Les0, union((get_anno(Le1))#a.ns, Ks), St1),
+ {[Le1|Les1],St2};
+uexprs([], _, St) -> {[],St}.
+
+%% Mark a "safe" as compiler-generated.
+mark_compiler_generated(#c_cons{anno=A,hd=H,tl=T}) ->
+ ann_c_cons([compiler_generated|A], mark_compiler_generated(H),
+ mark_compiler_generated(T));
+mark_compiler_generated(#c_tuple{anno=A,es=Es0}) ->
+ Es = [mark_compiler_generated(E) || E <- Es0],
+ ann_c_tuple([compiler_generated|A], Es);
+mark_compiler_generated(#c_var{anno=A}=Var) ->
+ Var#c_var{anno=[compiler_generated|A]};
+mark_compiler_generated(#c_literal{anno=A}=Lit) ->
+ Lit#c_literal{anno=[compiler_generated|A]}.
+
+uexpr(#iset{anno=A,var=V,arg=A0}, Ks, St0) ->
+ {A1,St1} = uexpr(A0, Ks, St0),
+ {#iset{anno=A#a{us=del_element(V#c_var.name, (get_anno(A1))#a.us),
+ ns=add_element(V#c_var.name, (get_anno(A1))#a.ns)},
+ var=V,arg=A1},St1};
+%% imatch done in uexprs.
+uexpr(#iletrec{anno=A,defs=Fs0,body=B0}, Ks, St0) ->
+ %%ok = io:fwrite("~w: ~p~n", [?LINE,{Fs0,B0}]),
+ {Fs1,St1} = mapfoldl(fun ({Name,F0}, S0) ->
+ {F1,S1} = uexpr(F0, Ks, S0),
+ {{Name,F1},S1}
+ end, St0, Fs0),
+ {B1,St2} = uexprs(B0, Ks, St1),
+ Used = used_in_any(map(fun ({_,F}) -> F end, Fs1) ++ B1),
+ {#iletrec{anno=A#a{us=Used,ns=[]},defs=Fs1,body=B1},St2};
+uexpr(#icase{anno=A,args=As0,clauses=Cs0,fc=Fc0}, Ks, St0) ->
+ %% As0 will never generate new variables.
+ {As1,St1} = uexpr_list(As0, Ks, St0),
+ {Cs1,St2} = uclauses(Cs0, Ks, St1),
+ {Fc1,St3} = uclause(Fc0, Ks, St2),
+ Used = union(used_in_any(As1), used_in_any(Cs1)),
+ New = new_in_all(Cs1),
+ {#icase{anno=A#a{us=Used,ns=New},args=As1,clauses=Cs1,fc=Fc1},St3};
+uexpr(#ifun{anno=A,id=Id,vars=As,clauses=Cs0,fc=Fc0}, Ks0, St0) ->
+ Avs = lit_list_vars(As),
+ Ks1 = union(Avs, Ks0),
+ {Cs1,St1} = ufun_clauses(Cs0, Ks1, St0),
+ {Fc1,St2} = ufun_clause(Fc0, Ks1, St1),
+ Used = subtract(intersection(used_in_any(Cs1), Ks0), Avs),
+ {#ifun{anno=A#a{us=Used,ns=[]},id=Id,vars=As,clauses=Cs1,fc=Fc1},St2};
+uexpr(#iapply{anno=A,op=Op,args=As}, _, St) ->
+ Used = union(lit_vars(Op), lit_list_vars(As)),
+ {#iapply{anno=A#a{us=Used},op=Op,args=As},St};
+uexpr(#iprimop{anno=A,name=Name,args=As}, _, St) ->
+ Used = lit_list_vars(As),
+ {#iprimop{anno=A#a{us=Used},name=Name,args=As},St};
+uexpr(#icall{anno=A,module=Mod,name=Name,args=As}, _, St) ->
+ Used = union([lit_vars(Mod),lit_vars(Name),lit_list_vars(As)]),
+ {#icall{anno=A#a{us=Used},module=Mod,name=Name,args=As},St};
+uexpr(#itry{anno=A,args=As0,vars=Vs,body=Bs0,evars=Evs,handler=Hs0}, Ks, St0) ->
+ %% Note that we export only from body and exception.
+ {As1,St1} = uexprs(As0, Ks, St0),
+ {Bs1,St2} = uexprs(Bs0, Ks, St1),
+ {Hs1,St3} = uexprs(Hs0, Ks, St2),
+ Used = intersection(used_in_any(Bs1++Hs1++As1), Ks),
+ New = new_in_all(Bs1++Hs1),
+ {#itry{anno=A#a{us=Used,ns=New},
+ args=As1,vars=Vs,body=Bs1,evars=Evs,handler=Hs1},St3};
+uexpr(#icatch{anno=A,body=Es0}, Ks, St0) ->
+ {Es1,St1} = uexprs(Es0, Ks, St0),
+ {#icatch{anno=A#a{us=used_in_any(Es1)},body=Es1},St1};
+uexpr(#ireceive1{anno=A,clauses=Cs0}, Ks, St0) ->
+ {Cs1,St1} = uclauses(Cs0, Ks, St0),
+ {#ireceive1{anno=A#a{us=used_in_any(Cs1),ns=new_in_all(Cs1)},
+ clauses=Cs1},St1};
+uexpr(#ireceive2{anno=A,clauses=Cs0,timeout=Te0,action=Tes0}, Ks, St0) ->
+ %% Te0 will never generate new variables.
+ {Te1,St1} = uexpr(Te0, Ks, St0),
+ {Cs1,St2} = uclauses(Cs0, Ks, St1),
+ {Tes1,St3} = uexprs(Tes0, Ks, St2),
+ Used = union([used_in_any(Cs1),used_in_any(Tes1),(get_anno(Te1))#a.us]),
+ New = case Cs1 of
+ [] -> new_in_any(Tes1);
+ _ -> intersection(new_in_all(Cs1), new_in_any(Tes1))
+ end,
+ {#ireceive2{anno=A#a{us=Used,ns=New},
+ clauses=Cs1,timeout=Te1,action=Tes1},St3};
+uexpr(#iprotect{anno=A,body=Es0}, Ks, St0) ->
+ {Es1,St1} = uexprs(Es0, Ks, St0),
+ Used = used_in_any(Es1),
+ {#iprotect{anno=A#a{us=Used},body=Es1},St1}; %No new variables escape!
+uexpr(#ibinary{anno=A,segments=Ss}, _, St) ->
+ Used = bitstr_vars(Ss),
+ {#ibinary{anno=A#a{us=Used},segments=Ss},St};
+uexpr(#c_literal{}=Lit, _, St) ->
+ Anno = get_anno(Lit),
+ {set_anno(Lit, #a{us=[],anno=Anno}),St};
+uexpr(Lit, _, St) ->
+ true = is_simple(Lit), %Sanity check!
+ Vs = lit_vars(Lit),
+ Anno = get_anno(Lit),
+ {set_anno(Lit, #a{us=Vs,anno=Anno}),St}.
+
+uexpr_list(Les0, Ks, St0) ->
+ mapfoldl(fun (Le, St) -> uexpr(Le, Ks, St) end, St0, Les0).
+
+%% ufun_clauses([Lclause], [KnownVar], State) -> {[Lclause],State}.
+
+ufun_clauses(Lcs, Ks, St0) ->
+ mapfoldl(fun (Lc, St) -> ufun_clause(Lc, Ks, St) end, St0, Lcs).
+
+%% ufun_clause(Lclause, [KnownVar], State) -> {Lclause,State}.
+
+ufun_clause(Cl0, Ks, St0) ->
+ {Cl1,Pvs,Used,_,St1} = uclause(Cl0, [], Ks, St0),
+ A0 = get_ianno(Cl1),
+ A = A0#a{us=subtract(intersection(Used, Ks), Pvs),ns=[]},
+ {Cl1#iclause{anno=A},St1}.
+
+%% upattern(Pat, [KnownVar], State) ->
+%% {Pat,[GuardTest],[NewVar],[UsedVar],State}.
+
+upattern(#c_var{name='_'}, _, St0) ->
+ {New,St1} = new_var_name(St0),
+ {#c_var{name=New},[],[New],[],St1};
+upattern(#c_var{name=V}=Var, Ks, St0) ->
+ case is_element(V, Ks) of
+ true ->
+ {N,St1} = new_var_name(St0),
+ New = #c_var{name=N},
+ Test = #icall{anno=#a{us=add_element(N, [V])},
+ module=#c_literal{val=erlang},
+ name=#c_literal{val='=:='},
+ args=[New,Var]},
+ %% Test doesn't need protecting.
+ {New,[Test],[N],[],St1};
+ false -> {Var,[],[V],[],St0}
+ end;
+upattern(#c_cons{hd=H0,tl=T0}=Cons, Ks, St0) ->
+ {H1,Hg,Hv,Hu,St1} = upattern(H0, Ks, St0),
+ {T1,Tg,Tv,Tu,St2} = upattern(T0, union(Hv, Ks), St1),
+ {Cons#c_cons{hd=H1,tl=T1},Hg ++ Tg,union(Hv, Tv),union(Hu, Tu),St2};
+upattern(#c_tuple{es=Es0}=Tuple, Ks, St0) ->
+ {Es1,Esg,Esv,Eus,St1} = upattern_list(Es0, Ks, St0),
+ {Tuple#c_tuple{es=Es1},Esg,Esv,Eus,St1};
+upattern(#c_binary{segments=Es0}=Bin, Ks, St0) ->
+ {Es1,Esg,Esv,Eus,St1} = upat_bin(Es0, Ks, St0),
+ {Bin#c_binary{segments=Es1},Esg,Esv,Eus,St1};
+upattern(#c_alias{var=V0,pat=P0}=Alias, Ks, St0) ->
+ {V1,Vg,Vv,Vu,St1} = upattern(V0, Ks, St0),
+ {P1,Pg,Pv,Pu,St2} = upattern(P0, union(Vv, Ks), St1),
+ {Alias#c_alias{var=V1,pat=P1},Vg ++ Pg,union(Vv, Pv),union(Vu, Pu),St2};
+upattern(Other, _, St) -> {Other,[],[],[],St}. %Constants
+
+%% upattern_list([Pat], [KnownVar], State) ->
+%% {[Pat],[GuardTest],[NewVar],[UsedVar],State}.
+
+upattern_list([P0|Ps0], Ks, St0) ->
+ {P1,Pg,Pv,Pu,St1} = upattern(P0, Ks, St0),
+ {Ps1,Psg,Psv,Psu,St2} = upattern_list(Ps0, union(Pv, Ks), St1),
+ {[P1|Ps1],Pg ++ Psg,union(Pv, Psv),union(Pu, Psu),St2};
+upattern_list([], _, St) -> {[],[],[],[],St}.
+
+%% upat_bin([Pat], [KnownVar], State) ->
+%% {[Pat],[GuardTest],[NewVar],[UsedVar],State}.
+upat_bin(Es0, Ks, St0) ->
+ upat_bin(Es0, Ks, [], St0).
+
+%% upat_bin([Pat], [KnownVar], [LocalVar], State) ->
+%% {[Pat],[GuardTest],[NewVar],[UsedVar],State}.
+upat_bin([P0|Ps0], Ks, Bs, St0) ->
+ {P1,Pg,Pv,Pu,Bs1,St1} = upat_element(P0, Ks, Bs, St0),
+ {Ps1,Psg,Psv,Psu,St2} = upat_bin(Ps0, union(Pv, Ks), Bs1, St1),
+ {[P1|Ps1],Pg ++ Psg,union(Pv, Psv),union(Pu, Psu),St2};
+upat_bin([], _, _, St) -> {[],[],[],[],St}.
+
+
+%% upat_element(Segment, [KnownVar], [LocalVar], State) ->
+%% {Segment,[GuardTest],[NewVar],[UsedVar],[LocalVar],State}
+upat_element(#c_bitstr{val=H0,size=Sz}=Seg, Ks, Bs, St0) ->
+ {H1,Hg,Hv,[],St1} = upattern(H0, Ks, St0),
+ Bs1 = case H0 of
+ #c_var{name=Hname} ->
+ case H1 of
+ #c_var{name=Hname} ->
+ Bs;
+ #c_var{name=Other} ->
+ [{Hname, Other}|Bs]
+ end;
+ _ ->
+ Bs
+ end,
+ {Sz1, Us} = case Sz of
+ #c_var{name=Vname} ->
+ rename_bitstr_size(Vname, Bs);
+ _Other -> {Sz, []}
+ end,
+ {Seg#c_bitstr{val=H1, size=Sz1},Hg,Hv,Us,Bs1,St1}.
+
+rename_bitstr_size(V, [{V, N}|_]) ->
+ New = #c_var{name=N},
+ {New, [N]};
+rename_bitstr_size(V, [_|Rest]) ->
+ rename_bitstr_size(V, Rest);
+rename_bitstr_size(V, []) ->
+ Old = #c_var{name=V},
+ {Old, [V]}.
+
+used_in_any(Les) ->
+ foldl(fun (Le, Ns) -> union((get_anno(Le))#a.us, Ns) end,
+ [], Les).
+
+new_in_any(Les) ->
+ foldl(fun (Le, Ns) -> union((get_anno(Le))#a.ns, Ns) end,
+ [], Les).
+
+new_in_all([Le|Les]) ->
+ foldl(fun (L, Ns) -> intersection((get_anno(L))#a.ns, Ns) end,
+ (get_anno(Le))#a.ns, Les);
+new_in_all([]) -> [].
+
+%% The AfterVars are the variables which are used afterwards. We need
+%% this to work out which variables are actually exported and used
+%% from case/receive. In subblocks/clauses the AfterVars of the block
+%% are just the exported variables.
+
+cbody(B0, St0) ->
+ {B1,_,_,St1} = cexpr(B0, [], St0),
+ {B1,St1}.
+
+%% cclause(Lclause, [AfterVar], State) -> {Cclause,State}.
+%% The AfterVars are the exported variables.
+
+cclause(#iclause{anno=#a{anno=Anno},pats=Ps,guard=G0,body=B0}, Exp, St0) ->
+ {B1,_Us1,St1} = cexprs(B0, Exp, St0),
+ {G1,St2} = cguard(G0, St1),
+ {#c_clause{anno=Anno,pats=Ps,guard=G1,body=B1},St2}.
+
+cclauses(Lcs, Es, St0) ->
+ mapfoldl(fun (Lc, St) -> cclause(Lc, Es, St) end, St0, Lcs).
+
+cguard([], St) -> {#c_literal{val=true},St};
+cguard(Gs, St0) ->
+ {G,_,St1} = cexprs(Gs, [], St0),
+ {G,St1}.
+
+%% cexprs([Lexpr], [AfterVar], State) -> {Cexpr,[AfterVar],State}.
+%% Must be sneaky here at the last expr when combining exports for the
+%% whole sequence and exports for that expr.
+
+cexprs([#iset{var=#c_var{name=Name}=Var}=Iset], As, St) ->
+ %% Make return value explicit, and make Var true top level.
+ cexprs([Iset,Var#c_var{anno=#a{us=[Name]}}], As, St);
+cexprs([Le], As, St0) ->
+ {Ce,Es,Us,St1} = cexpr(Le, As, St0),
+ Exp = make_vars(As), %The export variables
+ if
+ Es =:= [] -> {core_lib:make_values([Ce|Exp]),union(Us, As),St1};
+ true ->
+ {R,St2} = new_var(St1),
+ {#c_let{anno=get_lineno_anno(Ce),
+ vars=[R|make_vars(Es)],arg=Ce,
+ body=core_lib:make_values([R|Exp])},
+ union(Us, As),St2}
+ end;
+cexprs([#iset{anno=#a{anno=A},var=V,arg=A0}|Les], As0, St0) ->
+ {Ces,As1,St1} = cexprs(Les, As0, St0),
+ {A1,Es,Us,St2} = cexpr(A0, As1, St1),
+ {#c_let{anno=A,vars=[V|make_vars(Es)],arg=A1,body=Ces},
+ union(Us, As1),St2};
+cexprs([Le|Les], As0, St0) ->
+ {Ces,As1,St1} = cexprs(Les, As0, St0),
+ {Ce,Es,Us,St2} = cexpr(Le, As1, St1),
+ if
+ Es =:= [] ->
+ {#c_seq{arg=Ce,body=Ces},union(Us, As1),St2};
+ true ->
+ {R,St3} = new_var(St2),
+ {#c_let{vars=[R|make_vars(Es)],arg=Ce,body=Ces},
+ union(Us, As1),St3}
+ end.
+
+%% cexpr(Lexpr, [AfterVar], State) -> {Cexpr,[ExpVar],[UsedVar],State}.
+
+cexpr(#iletrec{anno=A,defs=Fs0,body=B0}, As, St0) ->
+ {Fs1,{_,St1}} = mapfoldl(fun ({{_Name,_Arity}=NA,F0}, {Used,S0}) ->
+ {F1,[],Us,S1} = cexpr(F0, [], S0),
+ {{#c_var{name=NA},F1},
+ {union(Us, Used),S1}}
+ end, {[],St0}, Fs0),
+ Exp = intersection(A#a.ns, As),
+ {B1,_Us,St2} = cexprs(B0, Exp, St1),
+ {#c_letrec{anno=A#a.anno,defs=Fs1,body=B1},Exp,A#a.us,St2};
+cexpr(#icase{anno=A,args=Largs,clauses=Lcs,fc=Lfc}, As, St0) ->
+ Exp = intersection(A#a.ns, As), %Exports
+ {Cargs,St1} = foldr(fun (La, {Cas,Sta}) ->
+ {Ca,[],_Us1,Stb} = cexpr(La, As, Sta),
+ {[Ca|Cas],Stb}
+ end, {[],St0}, Largs),
+ {Ccs,St2} = cclauses(Lcs, Exp, St1),
+ {Cfc,St3} = cclause(Lfc, [], St2), %Never exports
+ {#c_case{anno=A#a.anno,
+ arg=core_lib:make_values(Cargs),clauses=Ccs ++ [Cfc]},
+ Exp,A#a.us,St3};
+cexpr(#ireceive1{anno=A,clauses=Lcs}, As, St0) ->
+ Exp = intersection(A#a.ns, As), %Exports
+ {Ccs,St1} = cclauses(Lcs, Exp, St0),
+ {#c_receive{anno=A#a.anno,
+ clauses=Ccs,
+ timeout=#c_literal{val=infinity},action=#c_literal{val=true}},
+ Exp,A#a.us,St1};
+cexpr(#ireceive2{anno=A,clauses=Lcs,timeout=Lto,action=Les}, As, St0) ->
+ Exp = intersection(A#a.ns, As), %Exports
+ {Cto,[],_Us1,St1} = cexpr(Lto, As, St0),
+ {Ccs,St2} = cclauses(Lcs, Exp, St1),
+ {Ces,_Us2,St3} = cexprs(Les, Exp, St2),
+ {#c_receive{anno=A#a.anno,
+ clauses=Ccs,timeout=Cto,action=Ces},
+ Exp,A#a.us,St3};
+cexpr(#itry{anno=A,args=La,vars=Vs,body=Lb,evars=Evs,handler=Lh}, As, St0) ->
+ Exp = intersection(A#a.ns, As), %Exports
+ {Ca,_Us1,St1} = cexprs(La, [], St0),
+ {Cb,_Us2,St2} = cexprs(Lb, Exp, St1),
+ {Ch,_Us3,St3} = cexprs(Lh, Exp, St2),
+ {#c_try{anno=A#a.anno,arg=Ca,vars=Vs,body=Cb,evars=Evs,handler=Ch},
+ Exp,A#a.us,St3};
+cexpr(#icatch{anno=A,body=Les}, _As, St0) ->
+ {Ces,_Us1,St1} = cexprs(Les, [], St0), %Never export!
+ {#c_catch{body=Ces},[],A#a.us,St1};
+cexpr(#ifun{anno=A,id=Id,vars=Args,clauses=Lcs,fc=Lfc}, _As, St0) ->
+ {Ccs,St1} = cclauses(Lcs, [], St0), %NEVER export!
+ {Cfc,St2} = cclause(Lfc, [], St1),
+ Anno = A#a.anno,
+ {#c_fun{anno=Id++Anno,vars=Args,
+ body=#c_case{anno=Anno,
+ arg=set_anno(core_lib:make_values(Args), Anno),
+ clauses=Ccs ++ [Cfc]}},
+ [],A#a.us,St2};
+cexpr(#iapply{anno=A,op=Op,args=Args}, _As, St) ->
+ {#c_apply{anno=A#a.anno,op=Op,args=Args},[],A#a.us,St};
+cexpr(#icall{anno=A,module=Mod,name=Name,args=Args}, _As, St) ->
+ {#c_call{anno=A#a.anno,module=Mod,name=Name,args=Args},[],A#a.us,St};
+cexpr(#iprimop{anno=A,name=Name,args=Args}, _As, St) ->
+ {#c_primop{anno=A#a.anno,name=Name,args=Args},[],A#a.us,St};
+cexpr(#iprotect{anno=A,body=Es}, _As, St0) ->
+ {Ce,_,St1} = cexprs(Es, [], St0),
+ V = #c_var{name='Try'}, %The names are arbitrary
+ Vs = [#c_var{name='T'},#c_var{name='R'}],
+ {#c_try{anno=A#a.anno,arg=Ce,vars=[V],body=V,
+ evars=Vs,handler=#c_literal{val=false}},
+ [],A#a.us,St1};
+cexpr(#ibinary{anno=#a{anno=Anno,us=Us},segments=Segs}, _As, St) ->
+ {#c_binary{anno=Anno,segments=Segs},[],Us,St};
+cexpr(#c_literal{}=Lit, _As, St) ->
+ Anno = get_anno(Lit),
+ Vs = Anno#a.us,
+ {set_anno(Lit, Anno#a.anno),[],Vs,St};
+cexpr(Lit, _As, St) ->
+ true = is_simple(Lit), %Sanity check!
+ Anno = get_anno(Lit),
+ Vs = Anno#a.us,
+ %%Vs = lit_vars(Lit),
+ {set_anno(Lit, Anno#a.anno),[],Vs,St}.
+
+%% Kill the id annotations for any fun inside the expression.
+%% Necessary when duplicating code in try ... after.
+
+kill_id_anns(#ifun{clauses=Cs0}=Fun) ->
+ Cs = kill_id_anns(Cs0),
+ Fun#ifun{clauses=Cs,id=[]};
+kill_id_anns(#a{}=A) ->
+ %% Optimization: Don't waste time searching for funs inside annotations.
+ A;
+kill_id_anns([H|T]) ->
+ [kill_id_anns(H)|kill_id_anns(T)];
+kill_id_anns([]) -> [];
+kill_id_anns(Tuple) when is_tuple(Tuple) ->
+ L0 = tuple_to_list(Tuple),
+ L = kill_id_anns(L0),
+ list_to_tuple(L);
+kill_id_anns(Other) -> Other.
+
+%% lit_vars(Literal) -> [Var].
+
+lit_vars(Lit) -> lit_vars(Lit, []).
+
+lit_vars(#c_cons{hd=H,tl=T}, Vs) -> lit_vars(H, lit_vars(T, Vs));
+lit_vars(#c_tuple{es=Es}, Vs) -> lit_list_vars(Es, Vs);
+lit_vars(#c_var{name=V}, Vs) -> add_element(V, Vs);
+lit_vars(_, Vs) -> Vs. %These are atomic
+
+% lit_bin_vars(Segs, Vs) ->
+% foldl(fun (#c_bitstr{val=V,size=S}, Vs0) ->
+% lit_vars(V, lit_vars(S, Vs0))
+% end, Vs, Segs).
+
+lit_list_vars(Ls) -> lit_list_vars(Ls, []).
+
+lit_list_vars(Ls, Vs) ->
+ foldl(fun (L, Vs0) -> lit_vars(L, Vs0) end, Vs, Ls).
+
+bitstr_vars(Segs) ->
+ bitstr_vars(Segs, []).
+
+bitstr_vars(Segs, Vs) ->
+ foldl(fun (#c_bitstr{val=V,size=S}, Vs0) ->
+ lit_vars(V, lit_vars(S, Vs0))
+ end, Vs, Segs).
+
+lineno_anno(L, St) ->
+ {line, Line} = erl_parse:get_attribute(L, line),
+ [Line] ++ St#core.file.
+
+get_ianno(Ce) ->
+ case get_anno(Ce) of
+ #a{}=A -> A;
+ A when is_list(A) -> #a{anno=A}
+ end.
+
+get_lineno_anno(Ce) ->
+ case get_anno(Ce) of
+ #a{anno=A} -> A;
+ A when is_list(A) -> A
+ end.
+
+location(L) ->
+ {location,Location} = erl_parse:get_attribute(L, location),
+ Location.
+
+abs_line(L) ->
+ erl_parse:set_line(L, fun(Line) -> abs(Line) end).
+
+neg_line(L) ->
+ erl_parse:set_line(L, fun(Line) -> -abs(Line) end).
+
+%%
+%% The following three functions are used both with cerl:cerl() and with i()'s
+%%
+-spec get_anno(cerl:cerl() | i()) -> term().
+
+get_anno(C) -> element(2, C).
+
+-spec set_anno(cerl:cerl() | i(), term()) -> cerl:cerl().
+
+set_anno(C, A) -> setelement(2, C, A).
+
+-spec is_simple(cerl:cerl() | i()) -> boolean().
+
+is_simple(#c_var{}) -> true;
+is_simple(#c_literal{}) -> true;
+is_simple(#c_cons{hd=H,tl=T}) ->
+ is_simple(H) andalso is_simple(T);
+is_simple(#c_tuple{es=Es}) -> is_simple_list(Es);
+is_simple(#c_binary{segments=Es}) -> is_simp_bin(Es);
+is_simple(_) -> false.
+
+-spec is_simple_list([cerl:cerl()]) -> boolean().
+
+is_simple_list(Es) -> lists:all(fun is_simple/1, Es).
+
+-spec is_simp_bin([cerl:cerl()]) -> boolean().
+
+is_simp_bin(Es) ->
+ lists:all(fun (#c_bitstr{val=E,size=S}) ->
+ is_simple(E) andalso is_simple(S)
+ end, Es).
+
+%%%
+%%% Handling of warnings.
+%%%
+
+-type err_desc() :: 'bad_binary' | 'no_binaries' | 'nomatch'.
+
+-spec format_error(err_desc()) -> nonempty_string().
+
+format_error(nomatch) ->
+ "pattern cannot possibly match";
+format_error(bad_binary) ->
+ "binary construction will fail because of a type mismatch";
+format_error(no_binaries) ->
+ "bit syntax is not allowed to be used when compatibility with a previous "
+ "version has been requested".
+
+add_warning(Line, Term, #core{ws=Ws,file=[{file,File}]}=St) when Line >= 0 ->
+ St#core{ws=[{File,[{location(Line),?MODULE,Term}]}|Ws]};
+add_warning(_, _, St) -> St.
+
+add_error(Line, Term, #core{es=Es,file=[{file,File}]}=St) ->
+ St#core{es=[{File,[{location(abs_line(Line)),?MODULE,Term}]}|Es]}.
diff --git a/lib/compiler/src/v3_kernel.erl b/lib/compiler/src/v3_kernel.erl
new file mode 100644
index 0000000000..8568071e57
--- /dev/null
+++ b/lib/compiler/src/v3_kernel.erl
@@ -0,0 +1,1924 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1999-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%
+%%
+%% Purpose : Transform Core Erlang to Kernel Erlang
+
+%% Kernel erlang is like Core Erlang with a few significant
+%% differences:
+%%
+%% 1. It is flat! There are no nested calls or sub-blocks.
+%%
+%% 2. All variables are unique in a function. There is no scoping, or
+%% rather the scope is the whole function.
+%%
+%% 3. Pattern matching (in cases and receives) has been compiled.
+%%
+%% 4. The annotations contain variable usages. Seeing we have to work
+%% this out anyway for funs we might as well pass it on for free to
+%% later passes.
+%%
+%% 5. All remote-calls are to statically named m:f/a. Meta-calls are
+%% passed via erlang:apply/3.
+%%
+%% The translation is done in two passes:
+%%
+%% 1. Basic translation, translate variable/function names, flatten
+%% completely, pattern matching compilation.
+%%
+%% 2. Fun-lifting (lambda-lifting), variable usage annotation and
+%% last-call handling.
+%%
+%% All new Kexprs are created in the first pass, they are just
+%% annotated in the second.
+%%
+%% Functions and BIFs
+%%
+%% Functions are "call"ed or "enter"ed if it is a last call, their
+%% return values may be ignored. BIFs are things which are known to
+%% be internal by the compiler and can only be called, their return
+%% values cannot be ignored.
+%%
+%% Letrec's are handled rather naively. All the functions in one
+%% letrec are handled as one block to find the free variables. While
+%% this is not optimal it reflects how letrec's often are used. We
+%% don't have to worry about variable shadowing and nested letrec's as
+%% this is handled in the variable/function name translation. There
+%% is a little bit of trickery to ensure letrec transformations fit
+%% into the scheme of things.
+%%
+%% To ensure unique variable names we use a variable substitution
+%% table and keep the set of all defined variables. The nested
+%% scoping of Core means that we must also nest the substitution
+%% tables, but the defined set must be passed through to match the
+%% flat structure of Kernel and to make sure variables with the same
+%% name from different scopes get different substitutions.
+%%
+%% We also use these substitutions to handle the variable renaming
+%% necessary in pattern matching compilation.
+%%
+%% The pattern matching compilation assumes that the values of
+%% different types don't overlap. This means that as there is no
+%% character type yet in the machine all characters must be converted
+%% to integers!
+
+-module(v3_kernel).
+
+-export([module/2,format_error/1]).
+
+-import(lists, [map/2,foldl/3,foldr/3,mapfoldl/3,splitwith/2,member/2,keymember/3]).
+-import(ordsets, [add_element/2,del_element/2,union/2,union/1,subtract/2]).
+
+-compile({nowarn_deprecated_function, {erlang,hash,2}}).
+
+-include("core_parse.hrl").
+-include("v3_kernel.hrl").
+
+-define(EXPENSIVE_BINARY_LIMIT, 256).
+
+%% These are not defined in v3_kernel.hrl.
+get_kanno(Kthing) -> element(2, Kthing).
+set_kanno(Kthing, Anno) -> setelement(2, Kthing, Anno).
+copy_anno(Kdst, Ksrc) ->
+ Anno = get_kanno(Ksrc),
+ set_kanno(Kdst, Anno).
+
+%% Internal kernel expressions and help functions.
+%% N.B. the annotation field is ALWAYS the first field!
+
+-record(ivalues, {anno=[],args}).
+-record(ifun, {anno=[],vars,body}).
+-record(iset, {anno=[],vars,arg,body}).
+-record(iletrec, {anno=[],defs}).
+-record(ialias, {anno=[],vars,pat}).
+-record(iclause, {anno=[],isub,osub,pats,guard,body}).
+-record(ireceive_accept, {anno=[],arg}).
+-record(ireceive_next, {anno=[],arg}).
+
+-type warning() :: term(). % XXX: REFINE
+
+%% State record for kernel translator.
+-record(kern, {func, %Current host function
+ ff, %Current function
+ vcount=0, %Variable counter
+ fcount=0, %Fun counter
+ ds=[], %Defined variables
+ funs=[], %Fun functions
+ free=[], %Free variables
+ ws=[] :: [warning()], %Warnings.
+ lit, %Constant pool for literals.
+ guard_refc=0}). %> 0 means in guard
+
+-spec module(cerl:c_module(), [compile:option()]) ->
+ {'ok', #k_mdef{}, [warning()]}.
+
+module(#c_module{anno=A,name=M,exports=Es,attrs=As,defs=Fs}, Options) ->
+ Lit = case member(no_constant_pool, Options) of
+ true -> no;
+ false -> dict:new()
+ end,
+ St0 = #kern{lit=Lit},
+ {Kfs,St} = mapfoldl(fun function/2, St0, Fs),
+ Kes = map(fun (#c_var{name={_,_}=Fname}) -> Fname end, Es),
+ Kas = map(fun ({#c_literal{val=N},V}) ->
+ {N,core_lib:literal_value(V)} end, As),
+ {ok,#k_mdef{anno=A,name=M#c_literal.val,exports=Kes,attributes=Kas,
+ body=Kfs ++ St#kern.funs},lists:sort(St#kern.ws)}.
+
+function({#c_var{name={F,Arity}=FA},Body}, St0) ->
+ try
+ St1 = St0#kern{func=FA,ff=undefined,vcount=0,fcount=0,ds=sets:new()},
+ {#ifun{anno=Ab,vars=Kvs,body=B0},[],St2} = expr(Body, new_sub(), St1),
+ {B1,_,St3} = ubody(B0, return, St2),
+ %%B1 = B0, St3 = St2, %Null second pass
+ {#k_fdef{anno=#k{us=[],ns=[],a=Ab},
+ func=F,arity=Arity,vars=Kvs,body=B1},St3}
+ catch
+ Class:Error ->
+ Stack = erlang:get_stacktrace(),
+ io:fwrite("Function: ~w/~w\n", [F,Arity]),
+ erlang:raise(Class, Error, Stack)
+ end.
+
+
+%% body(Cexpr, Sub, State) -> {Kexpr,[PreKepxr],State}.
+%% Do the main sequence of a body. A body ends in an atomic value or
+%% values. Must check if vector first so do expr.
+
+body(#c_values{anno=A,es=Ces}, Sub, St0) ->
+ %% Do this here even if only in bodies.
+ {Kes,Pe,St1} = atomic_list(Ces, Sub, St0),
+ %%{Kes,Pe,St1} = expr_list(Ces, Sub, St0),
+ {#ivalues{anno=A,args=Kes},Pe,St1};
+body(#ireceive_next{anno=A}, _, St) ->
+ {#k_receive_next{anno=A},[],St};
+body(Ce, Sub, St0) ->
+ expr(Ce, Sub, St0).
+
+%% guard(Cexpr, Sub, State) -> {Kexpr,State}.
+%% We handle guards almost as bodies. The only special thing we
+%% must do is to make the final Kexpr a #k_test{}.
+%% Also, we wrap the entire guard in a try/catch which is
+%% not strictly needed, but makes sure that every 'bif' instruction
+%% will get a proper failure label.
+
+guard(G0, Sub, St0) ->
+ {G1,St1} = wrap_guard(G0, St0),
+ {Ge0,Pre,St2} = expr(G1, Sub, St1),
+ {Ge,St} = gexpr_test(Ge0, St2),
+ {pre_seq(Pre, Ge),St}.
+
+%% Wrap the entire guard in a try/catch if needed.
+
+wrap_guard(#c_try{}=Try, St) -> {Try,St};
+wrap_guard(Core, St0) ->
+ {VarName,St} = new_var_name(St0),
+ Var = #c_var{name=VarName},
+ Try = #c_try{arg=Core,vars=[Var],body=Var,evars=[],handler=#c_literal{val=false}},
+ {Try,St}.
+
+%% gexpr_test(Kexpr, State) -> {Kexpr,State}.
+%% Builds the final boolean test from the last Kexpr in a guard test.
+%% Must enter try blocks and isets and find the last Kexpr in them.
+%% This must end in a recognised BEAM test!
+
+gexpr_test(#k_bif{anno=A,op=#k_remote{mod=#k_atom{val=erlang},
+ name=#k_atom{val=F},arity=Ar}=Op,
+ args=Kargs}=Ke, St) ->
+ %% Either convert to test if ok, or add test.
+ %% At this stage, erlang:float/1 is not a type test. (It should
+ %% have been converted to erlang:is_float/1.)
+ case erl_internal:new_type_test(F, Ar) orelse
+ erl_internal:comp_op(F, Ar) of
+ true -> {#k_test{anno=A,op=Op,args=Kargs},St};
+ false -> gexpr_test_add(Ke, St) %Add equality test
+ end;
+gexpr_test(#k_try{arg=B0,vars=[#k_var{name=X}],body=#k_var{name=X},
+ handler=#k_atom{val=false}}=Try, St0) ->
+ {B,St} = gexpr_test(B0, St0),
+ %%ok = io:fwrite("~w: ~p~n", [?LINE,{B0,B}]),
+ {Try#k_try{arg=B},St};
+gexpr_test(#iset{body=B0}=Iset, St0) ->
+ {B1,St1} = gexpr_test(B0, St0),
+ {Iset#iset{body=B1},St1};
+gexpr_test(Ke, St) -> gexpr_test_add(Ke, St). %Add equality test
+
+gexpr_test_add(Ke, St0) ->
+ Test = #k_remote{mod=#k_atom{val='erlang'},
+ name=#k_atom{val='=:='},
+ arity=2},
+ {Ae,Ap,St1} = force_atomic(Ke, St0),
+ {pre_seq(Ap, #k_test{anno=get_kanno(Ke),
+ op=Test,args=[Ae,#k_atom{val='true'}]}),St1}.
+
+%% expr(Cexpr, Sub, State) -> {Kexpr,[PreKexpr],State}.
+%% Convert a Core expression, flattening it at the same time.
+
+expr(#c_var{anno=A,name={_Name,Arity}}=Fname, Sub, St) ->
+ %% A local in an expression.
+ %% For now, these are wrapped into a fun by reverse
+ %% etha-conversion, but really, there should be exactly one
+ %% such "lambda function" for each escaping local name,
+ %% instead of one for each occurrence as done now.
+ Vs = [#c_var{name=list_to_atom("V" ++ integer_to_list(V))} ||
+ V <- integers(1, Arity)],
+ Fun = #c_fun{anno=A,vars=Vs,body=#c_apply{op=Fname,args=Vs}},
+ expr(Fun, Sub, St);
+expr(#c_var{anno=A,name=V}, Sub, St) ->
+ {#k_var{anno=A,name=get_vsub(V, Sub)},[],St};
+expr(#c_literal{anno=A,val=Lit}, Sub, #kern{lit=no}=St) ->
+ %% No constant pools for compatibility with a previous version.
+ %% Fully expand the literal.
+ Core = expand_literal(Lit, A),
+ expr(Core, Sub, St);
+expr(#c_literal{}=Lit, Sub, St) ->
+ Core = handle_literal(Lit),
+ expr(Core, Sub, St);
+expr(#k_literal{val=Val0}=Klit, _Sub, #kern{lit=Literals0}=St) ->
+ %% Share identical literals to save some space and time during compilation.
+ case dict:find(Val0, Literals0) of
+ {ok,Val} ->
+ {Klit#k_literal{val=Val},[],St};
+ error ->
+ Literals = dict:store(Val0, Val0, Literals0),
+ {Klit,[],St#kern{lit=Literals}}
+ end;
+expr(#k_nil{}=V, _Sub, St) ->
+ {V,[],St};
+expr(#k_int{}=V, _Sub, St) ->
+ {V,[],St};
+expr(#k_float{}=V, _Sub, St) ->
+ {V,[],St};
+expr(#k_atom{}=V, _Sub, St) ->
+ {V,[],St};
+expr(#k_string{}=V, _Sub, St) ->
+ %% Only for compatibility with a previous version.
+ {V,[],St};
+expr(#c_cons{anno=A,hd=Ch,tl=Ct}, Sub, St0) ->
+ %% Do cons in two steps, first the expressions left to right, then
+ %% any remaining literals right to left.
+ {Kh0,Hp0,St1} = expr(Ch, Sub, St0),
+ {Kt0,Tp0,St2} = expr(Ct, Sub, St1),
+ {Kt1,Tp1,St3} = force_atomic(Kt0, St2),
+ {Kh1,Hp1,St4} = force_atomic(Kh0, St3),
+ {#k_cons{anno=A,hd=Kh1,tl=Kt1},Hp0 ++ Tp0 ++ Tp1 ++ Hp1,St4};
+expr(#c_tuple{anno=A,es=Ces}, Sub, St0) ->
+ {Kes,Ep,St1} = atomic_list(Ces, Sub, St0),
+ {#k_tuple{anno=A,es=Kes},Ep,St1};
+expr(#c_binary{anno=A,segments=Cv}, Sub, St0) ->
+ try atomic_bin(Cv, Sub, St0) of
+ {Kv,Ep,St1} ->
+ {#k_binary{anno=A,segs=Kv},Ep,St1}
+ catch
+ throw:bad_element_size ->
+ Erl = #c_literal{val=erlang},
+ Name = #c_literal{val=error},
+ Args = [#c_literal{val=badarg}],
+ Error = #c_call{module=Erl,name=Name,args=Args},
+ expr(Error, Sub, St0)
+ end;
+expr(#c_fun{anno=A,vars=Cvs,body=Cb}, Sub0, #kern{ff=OldFF,func=Func}=St0) ->
+ FA = case OldFF of
+ undefined ->
+ Func;
+ _ ->
+ case lists:keyfind(id, 1, A) of
+ {id,{_,_,Name}} -> Name;
+ _ ->
+ case lists:keyfind(letrec_name, 1, A) of
+ {letrec_name,Name} -> Name;
+ _ -> unknown_fun
+ end
+ end
+ end,
+ {Kvs,Sub1,St1} = pattern_list(Cvs, Sub0, St0#kern{ff=FA}),
+ %%ok = io:fwrite("~w: ~p~n", [?LINE,{{Cvs,Sub0,St0},{Kvs,Sub1,St1}}]),
+ {Kb,Pb,St2} = body(Cb, Sub1, St1#kern{ff=FA}),
+ {#ifun{anno=A,vars=Kvs,body=pre_seq(Pb, Kb)},[],St2#kern{ff=OldFF}};
+expr(#c_seq{arg=Ca,body=Cb}, Sub, St0) ->
+ {Ka,Pa,St1} = body(Ca, Sub, St0),
+ {Kb,Pb,St2} = body(Cb, Sub, St1),
+ {Kb,Pa ++ [Ka] ++ Pb,St2};
+expr(#c_let{anno=A,vars=Cvs,arg=Ca,body=Cb}, Sub0, St0) ->
+ %%ok = io:fwrite("~w: ~p~n", [?LINE,{Cvs,Sub0,St0}]),
+ {Ka,Pa,St1} = body(Ca, Sub0, St0),
+ {Kps,Sub1,St2} = pattern_list(Cvs, Sub0, St1),
+ %%ok = io:fwrite("~w: ~p~n", [?LINE,{Kps,Sub1,St1,St2}]),
+ %% Break known multiple values into separate sets.
+ Sets = case Ka of
+ #ivalues{args=Kas} ->
+ foldr2(fun (V, Val, Sb) ->
+ [#iset{vars=[V],arg=Val}|Sb] end,
+ [], Kps, Kas);
+ _Other ->
+ [#iset{anno=A,vars=Kps,arg=Ka}]
+ end,
+ {Kb,Pb,St3} = body(Cb, Sub1, St2),
+ {Kb,Pa ++ Sets ++ Pb,St3};
+expr(#c_letrec{anno=A,defs=Cfs,body=Cb}, Sub0, St0) ->
+ %% Make new function names and store substitution.
+ {Fs0,{Sub1,St1}} =
+ mapfoldl(fun ({#c_var{name={F,Ar}},B0}, {Sub,S0}) ->
+ {N,St1} = new_fun_name(atom_to_list(F)
+ ++ "/" ++
+ integer_to_list(Ar),
+ S0),
+ B = set_kanno(B0, [{letrec_name,N}]),
+ {{N,B},{set_fsub(F, Ar, N, Sub),St1}}
+ end, {Sub0,St0}, Cfs),
+ %% Run translation on functions and body.
+ {Fs1,St2} = mapfoldl(fun ({N,Fd0}, S1) ->
+ {Fd1,[],St2} = expr(Fd0, Sub1, S1#kern{ff=N}),
+ Fd = set_kanno(Fd1, A),
+ {{N,Fd},St2}
+ end, St1, Fs0),
+ {Kb,Pb,St3} = body(Cb, Sub1, St2#kern{ff=St1#kern.ff}),
+ {Kb,[#iletrec{anno=A,defs=Fs1}|Pb],St3};
+expr(#c_case{arg=Ca,clauses=Ccs}, Sub, St0) ->
+ {Ka,Pa,St1} = body(Ca, Sub, St0), %This is a body!
+ {Kvs,Pv,St2} = match_vars(Ka, St1), %Must have variables here!
+ {Km,St3} = kmatch(Kvs, Ccs, Sub, St2),
+ Match = flatten_seq(build_match(Kvs, Km)),
+ {last(Match),Pa ++ Pv ++ first(Match),St3};
+expr(#c_receive{anno=A,clauses=Ccs0,timeout=Ce,action=Ca}, Sub, St0) ->
+ {Ke,Pe,St1} = atomic(Ce, Sub, St0), %Force this to be atomic!
+ {Rvar,St2} = new_var(St1),
+ %% Need to massage accept clauses and add reject clause before matching.
+ Ccs1 = map(fun (#c_clause{anno=Banno,body=B0}=C) ->
+ B1 = #c_seq{arg=#ireceive_accept{anno=A},body=B0},
+ C#c_clause{anno=Banno,body=B1}
+ end, Ccs0),
+ {Mpat,St3} = new_var_name(St2),
+ Rc = #c_clause{anno=[compiler_generated|A],
+ pats=[#c_var{name=Mpat}],guard=#c_literal{anno=A,val=true},
+ body=#ireceive_next{anno=A}},
+ {Km,St4} = kmatch([Rvar], Ccs1 ++ [Rc], Sub, add_var_def(Rvar, St3)),
+ {Ka,Pa,St5} = body(Ca, Sub, St4),
+ {#k_receive{anno=A,var=Rvar,body=Km,timeout=Ke,action=pre_seq(Pa, Ka)},
+ Pe,St5};
+expr(#c_apply{anno=A,op=Cop,args=Cargs}, Sub, St) ->
+ c_apply(A, Cop, Cargs, Sub, St);
+expr(#c_call{anno=A,module=#c_literal{val=erlang},name=#c_literal{val=is_record},
+ args=[_,Tag,Sz]=Args0}, Sub, St0) ->
+ {Args,Ap,St} = atomic_list(Args0, Sub, St0),
+ Remote = #k_remote{mod=#k_atom{val=erlang},name=#k_atom{val=is_record},arity=3},
+ case {Tag,Sz} of
+ {#c_literal{val=Atom},#c_literal{val=Int}}
+ when is_atom(Atom), is_integer(Int) ->
+ %% Tag and size are literals. Make it a BIF, which will actually
+ %% be expanded out in a later pass.
+ {#k_bif{anno=A,op=Remote,args=Args},Ap,St};
+ {_,_} ->
+ %% (Only in bodies.) Make it into an actual call to the BIF.
+ {#k_call{anno=A,op=Remote,args=Args},Ap,St}
+ end;
+expr(#c_call{anno=A,module=M0,name=F0,args=Cargs}, Sub, St0) ->
+ Ar = length(Cargs),
+ {Type,St1} = case call_type(M0, F0, Ar) of
+ error ->
+ %% Invalid call (e.g. M:42/3). Issue a warning,
+ %% and let the generated code use the old explict apply.
+ {old_apply,add_warning(get_line(A), bad_call, A, St0)};
+ Type0 ->
+ {Type0,St0}
+ end,
+
+ case Type of
+ old_apply ->
+ Call = #c_call{anno=A,
+ module=#c_literal{val=erlang},
+ name=#c_literal{val=apply},
+ args=[M0,F0,make_list(Cargs)]},
+ expr(Call, Sub, St1);
+ _ ->
+ {[M1,F1|Kargs],Ap,St} = atomic_list([M0,F0|Cargs], Sub, St1),
+ Call = case Type of
+ bif ->
+ #k_bif{anno=A,op=#k_remote{mod=M1,name=F1,arity=Ar},
+ args=Kargs};
+ call ->
+ #k_call{anno=A,op=#k_remote{mod=M1,name=F1,arity=Ar},
+ args=Kargs};
+ apply ->
+ #k_call{anno=A,op=#k_remote{mod=M1,name=F1,arity=Ar},
+ args=Kargs}
+ end,
+ {Call,Ap,St}
+ end;
+expr(#c_primop{anno=A,name=#c_literal{val=match_fail},args=Cargs0}, Sub, St0) ->
+ Cargs = translate_match_fail(Cargs0, Sub, St0),
+ %% This special case will disappear.
+ {Kargs,Ap,St} = atomic_list(Cargs, Sub, St0),
+ Ar = length(Cargs),
+ Call = #k_call{anno=A,op=#k_internal{name=match_fail,arity=Ar},args=Kargs},
+ {Call,Ap,St};
+expr(#c_primop{anno=A,name=#c_literal{val=N},args=Cargs}, Sub, St0) ->
+ {Kargs,Ap,St1} = atomic_list(Cargs, Sub, St0),
+ Ar = length(Cargs),
+ {#k_bif{anno=A,op=#k_internal{name=N,arity=Ar},args=Kargs},Ap,St1};
+expr(#c_try{anno=A,arg=Ca,vars=Cvs,body=Cb,evars=Evs,handler=Ch}, Sub0, St0) ->
+ %% The normal try expression. The body and exception handler
+ %% variables behave as let variables.
+ {Ka,Pa,St1} = body(Ca, Sub0, St0),
+ {Kcvs,Sub1,St2} = pattern_list(Cvs, Sub0, St1),
+ {Kb,Pb,St3} = body(Cb, Sub1, St2),
+ {Kevs,Sub2,St4} = pattern_list(Evs, Sub0, St3),
+ {Kh,Ph,St5} = body(Ch, Sub2, St4),
+ {#k_try{anno=A,arg=pre_seq(Pa, Ka),
+ vars=Kcvs,body=pre_seq(Pb, Kb),
+ evars=Kevs,handler=pre_seq(Ph, Kh)},[],St5};
+expr(#c_catch{anno=A,body=Cb}, Sub, St0) ->
+ {Kb,Pb,St1} = body(Cb, Sub, St0),
+ {#k_catch{anno=A,body=pre_seq(Pb, Kb)},[],St1};
+%% Handle internal expressions.
+expr(#ireceive_accept{anno=A}, _Sub, St) -> {#k_receive_accept{anno=A},[],St}.
+
+%% Translate a function_clause to case_clause if it has been moved into
+%% another function.
+translate_match_fail([#c_tuple{es=[#c_literal{anno=A0,
+ val=function_clause}|As]}]=Args,
+ Sub,
+ #kern{ff=FF}) ->
+ A = case A0 of
+ [{name,{Func0,Arity0}}] ->
+ [{name,{get_fsub(Func0, Arity0, Sub),Arity0}}];
+ _ ->
+ A0
+ end,
+ case {A,FF} of
+ {[{name,Same}],Same} ->
+ %% Still in the correct function.
+ Args;
+ {[{name,{F,_}}],F} ->
+ %% Still in the correct function.
+ Args;
+ _ ->
+ %% Inlining has probably moved the function_clause into another
+ %% function (where it will not work correctly).
+ %% Rewrite to a case_clause.
+ [#c_tuple{es=[#c_literal{val=case_clause},#c_tuple{es=As}]}]
+ end;
+translate_match_fail(Args, _, _) -> Args.
+
+%% call_type(Module, Function, Arity) -> call | bif | apply | error.
+%% Classify the call.
+call_type(#c_literal{val=M}, #c_literal{val=F}, Ar) when is_atom(M), is_atom(F) ->
+ case is_remote_bif(M, F, Ar) of
+ false -> call;
+ true -> bif
+ end;
+call_type(#c_var{}, #c_literal{val=A}, _) when is_atom(A) -> apply;
+call_type(#c_literal{val=A}, #c_var{}, _) when is_atom(A) -> apply;
+call_type(#c_var{}, #c_var{}, _) -> apply;
+call_type(_, _, _) -> error.
+
+%% match_vars(Kexpr, State) -> {[Kvar],[PreKexpr],State}.
+%% Force return from body into a list of variables.
+
+match_vars(#ivalues{args=As}, St) ->
+ foldr(fun (Ka, {Vs,Vsp,St0}) ->
+ {V,Vp,St1} = force_variable(Ka, St0),
+ {[V|Vs],Vp ++ Vsp,St1}
+ end, {[],[],St}, As);
+match_vars(Ka, St0) ->
+ {V,Vp,St1} = force_variable(Ka, St0),
+ {[V],Vp,St1}.
+
+%% c_apply(A, Op, [Carg], Sub, State) -> {Kexpr,[PreKexpr],State}.
+%% Transform application, detect which are guaranteed to be bifs.
+
+c_apply(A, #c_var{anno=Ra,name={F0,Ar}}, Cargs, Sub, St0) ->
+ {Kargs,Ap,St1} = atomic_list(Cargs, Sub, St0),
+ F1 = get_fsub(F0, Ar, Sub), %Has it been rewritten
+ {#k_call{anno=A,op=#k_local{anno=Ra,name=F1,arity=Ar},args=Kargs},
+ Ap,St1};
+c_apply(A, Cop, Cargs, Sub, St0) ->
+ {Kop,Op,St1} = variable(Cop, Sub, St0),
+ {Kargs,Ap,St2} = atomic_list(Cargs, Sub, St1),
+ {#k_call{anno=A,op=Kop,args=Kargs},Op ++ Ap,St2}.
+
+flatten_seq(#iset{anno=A,vars=Vs,arg=Arg,body=B}) ->
+ [#iset{anno=A,vars=Vs,arg=Arg}|flatten_seq(B)];
+flatten_seq(Ke) -> [Ke].
+
+pre_seq([#iset{anno=A,vars=Vs,arg=Arg,body=B}|Ps], K) ->
+ B = undefined, %Assertion.
+ #iset{anno=A,vars=Vs,arg=Arg,body=pre_seq(Ps, K)};
+pre_seq([P|Ps], K) ->
+ #iset{vars=[],arg=P,body=pre_seq(Ps, K)};
+pre_seq([], K) -> K.
+
+%% atomic(Cexpr, Sub, State) -> {Katomic,[PreKexpr],State}.
+%% Convert a Core expression making sure the result is an atomic
+%% literal.
+
+atomic(Ce, Sub, St0) ->
+ {Ke,Kp,St1} = expr(Ce, Sub, St0),
+ {Ka,Ap,St2} = force_atomic(Ke, St1),
+ {Ka,Kp ++ Ap,St2}.
+
+force_atomic(Ke, St0) ->
+ case is_atomic(Ke) of
+ true -> {Ke,[],St0};
+ false ->
+ {V,St1} = new_var(St0),
+ {V,[#iset{vars=[V],arg=Ke}],St1}
+ end.
+
+% force_atomic_list(Kes, St) ->
+% foldr(fun (Ka, {As,Asp,St0}) ->
+% {A,Ap,St1} = force_atomic(Ka, St0),
+% {[A|As],Ap ++ Asp,St1}
+% end, {[],[],St}, Kes).
+
+atomic_bin([#c_bitstr{anno=A,val=E0,size=S0,unit=U0,type=T,flags=Fs0}|Es0],
+ Sub, St0) ->
+ {E,Ap1,St1} = atomic(E0, Sub, St0),
+ {S1,Ap2,St2} = atomic(S0, Sub, St1),
+ validate_bin_element_size(S1),
+ U1 = core_lib:literal_value(U0),
+ Fs1 = core_lib:literal_value(Fs0),
+ {Es,Ap3,St3} = atomic_bin(Es0, Sub, St2),
+ {#k_bin_seg{anno=A,size=S1,
+ unit=U1,
+ type=core_lib:literal_value(T),
+ flags=Fs1,
+ seg=E,next=Es},
+ Ap1++Ap2++Ap3,St3};
+atomic_bin([], _Sub, St) -> {#k_bin_end{},[],St}.
+
+validate_bin_element_size(#k_var{}) -> ok;
+validate_bin_element_size(#k_int{val=V}) when V >= 0 -> ok;
+validate_bin_element_size(#k_atom{val=all}) -> ok;
+validate_bin_element_size(#k_atom{val=undefined}) -> ok;
+validate_bin_element_size(_) -> throw(bad_element_size).
+
+%% atomic_list([Cexpr], Sub, State) -> {[Kexpr],[PreKexpr],State}.
+
+atomic_list(Ces, Sub, St) ->
+ foldr(fun (Ce, {Kes,Esp,St0}) ->
+ {Ke,Ep,St1} = atomic(Ce, Sub, St0),
+ {[Ke|Kes],Ep ++ Esp,St1}
+ end, {[],[],St}, Ces).
+
+%% is_atomic(Kexpr) -> boolean().
+%% Is a Kexpr atomic? Strings are NOT considered atomic!
+
+is_atomic(#k_literal{}) -> true;
+is_atomic(#k_int{}) -> true;
+is_atomic(#k_float{}) -> true;
+is_atomic(#k_atom{}) -> true;
+%%is_atomic(#k_char{}) -> true; %No characters
+%%is_atomic(#k_string{}) -> true;
+is_atomic(#k_nil{}) -> true;
+is_atomic(#k_var{}) -> true;
+is_atomic(_) -> false.
+
+%% variable(Cexpr, Sub, State) -> {Kvar,[PreKexpr],State}.
+%% Convert a Core expression making sure the result is a variable.
+
+variable(Ce, Sub, St0) ->
+ {Ke,Kp,St1} = expr(Ce, Sub, St0),
+ {Kv,Vp,St2} = force_variable(Ke, St1),
+ {Kv,Kp ++ Vp,St2}.
+
+force_variable(#k_var{}=Ke, St) -> {Ke,[],St};
+force_variable(Ke, St0) ->
+ {V,St1} = new_var(St0),
+ {V,[#iset{vars=[V],arg=Ke}],St1}.
+
+%% pattern(Cpat, Isub, Osub, State) -> {Kpat,Sub,State}.
+%% Convert patterns. Variables shadow so rename variables that are
+%% already defined.
+%%
+%% Patterns are complicated by sizes in binaries. These are pure
+%% input variables which create no bindings. We, therefore, need to
+%% carry around the original substitutions to get the correct
+%% handling.
+
+pattern(#c_var{anno=A,name=V}, _Isub, Osub, St0) ->
+ case sets:is_element(V, St0#kern.ds) of
+ true ->
+ {New,St1} = new_var_name(St0),
+ {#k_var{anno=A,name=New},
+ set_vsub(V, New, Osub),
+ St1#kern{ds=sets:add_element(New, St1#kern.ds)}};
+ false ->
+ {#k_var{anno=A,name=V},Osub,
+ St0#kern{ds=sets:add_element(V, St0#kern.ds)}}
+ end;
+pattern(#c_literal{anno=A,val=Val}, _Isub, Osub, St) ->
+ {#k_literal{anno=A,val=Val},Osub,St};
+pattern(#c_cons{anno=A,hd=Ch,tl=Ct}, Isub, Osub0, St0) ->
+ {Kh,Osub1,St1} = pattern(Ch, Isub, Osub0, St0),
+ {Kt,Osub2,St2} = pattern(Ct, Isub, Osub1, St1),
+ {#k_cons{anno=A,hd=Kh,tl=Kt},Osub2,St2};
+pattern(#c_tuple{anno=A,es=Ces}, Isub, Osub0, St0) ->
+ {Kes,Osub1,St1} = pattern_list(Ces, Isub, Osub0, St0),
+ {#k_tuple{anno=A,es=Kes},Osub1,St1};
+pattern(#c_binary{anno=A,segments=Cv}, Isub, Osub0, St0) ->
+ {Kv,Osub1,St1} = pattern_bin(Cv, Isub, Osub0, St0),
+ {#k_binary{anno=A,segs=Kv},Osub1,St1};
+pattern(#c_alias{anno=A,var=Cv,pat=Cp}, Isub, Osub0, St0) ->
+ {Cvs,Cpat} = flatten_alias(Cp),
+ {Kvs,Osub1,St1} = pattern_list([Cv|Cvs], Isub, Osub0, St0),
+ {Kpat,Osub2,St2} = pattern(Cpat, Isub, Osub1, St1),
+ {#ialias{anno=A,vars=Kvs,pat=Kpat},Osub2,St2}.
+
+flatten_alias(#c_alias{var=V,pat=P}) ->
+ {Vs,Pat} = flatten_alias(P),
+ {[V|Vs],Pat};
+flatten_alias(Pat) -> {[],Pat}.
+
+pattern_bin(Es, Isub, Osub0, St0) ->
+ {Kbin,{_,Osub},St} = pattern_bin_1(Es, Isub, Osub0, St0),
+ {Kbin,Osub,St}.
+
+pattern_bin_1([#c_bitstr{anno=A,val=E0,size=S0,unit=U,type=T,flags=Fs}|Es0],
+ Isub0, Osub0, St0) ->
+ {S1,[],St1} = expr(S0, Isub0, St0),
+ S = case S1 of
+ #k_int{} -> S1;
+ #k_var{} -> S1;
+ #k_atom{} -> S1;
+ _ ->
+ %% Bad size (coming from an optimization or Core Erlang
+ %% source code) - replace it with a known atom because
+ %% a literal or bit syntax construction can cause further
+ %% problems.
+ #k_atom{val=bad_size}
+ end,
+ U0 = core_lib:literal_value(U),
+ Fs0 = core_lib:literal_value(Fs),
+ %%ok= io:fwrite("~w: ~p~n", [?LINE,{B0,S,U0,Fs0}]),
+ {E,Osub1,St2} = pattern(E0, Isub0, Osub0, St1),
+ Isub1 = case E0 of
+ #c_var{name=V} ->
+ set_vsub(V, E#k_var.name, Isub0);
+ _ -> Isub0
+ end,
+ {Es,{Isub,Osub},St3} = pattern_bin_1(Es0, Isub1, Osub1, St2),
+ {#k_bin_seg{anno=A,size=S,
+ unit=U0,
+ type=core_lib:literal_value(T),
+ flags=Fs0,
+ seg=E,next=Es},
+ {Isub,Osub},St3};
+pattern_bin_1([], Isub, Osub, St) -> {#k_bin_end{},{Isub,Osub},St}.
+
+%% pattern_list([Cexpr], Sub, State) -> {[Kexpr],Sub,State}.
+
+pattern_list(Ces, Sub, St) ->
+ pattern_list(Ces, Sub, Sub, St).
+
+pattern_list(Ces, Isub, Osub, St) ->
+ foldr(fun (Ce, {Kes,Osub0,St0}) ->
+ {Ke,Osub1,St1} = pattern(Ce, Isub, Osub0, St0),
+ {[Ke|Kes],Osub1,St1}
+ end, {[],Osub,St}, Ces).
+
+%% new_sub() -> Subs.
+%% set_vsub(Name, Sub, Subs) -> Subs.
+%% subst_vsub(Name, Sub, Subs) -> Subs.
+%% get_vsub(Name, Subs) -> SubName.
+%% Add/get substitute Sub for Name to VarSub. Use orddict so we know
+%% the format is a list {Name,Sub} pairs. When adding a new
+%% substitute we fold substitute chains so we never have to search
+%% more than once.
+
+new_sub() -> orddict:new().
+
+get_vsub(V, Vsub) ->
+ case orddict:find(V, Vsub) of
+ {ok,Val} -> Val;
+ error -> V
+ end.
+
+set_vsub(V, S, Vsub) ->
+ orddict:store(V, S, Vsub).
+
+subst_vsub(V, S, Vsub0) ->
+ %% Fold chained substitutions.
+ Vsub1 = orddict:map(fun (_, V1) when V1 =:= V -> S;
+ (_, V1) -> V1
+ end, Vsub0),
+ orddict:store(V, S, Vsub1).
+
+get_fsub(F, A, Fsub) ->
+ case orddict:find({F,A}, Fsub) of
+ {ok,Val} -> Val;
+ error -> F
+ end.
+
+set_fsub(F, A, S, Fsub) ->
+ orddict:store({F,A}, S, Fsub).
+
+new_fun_name(St) ->
+ new_fun_name("anonymous", St).
+
+%% new_fun_name(Type, State) -> {FunName,State}.
+
+new_fun_name(Type, #kern{func={F,Arity},fcount=C}=St) ->
+ Name = "-" ++ atom_to_list(F) ++ "/" ++ integer_to_list(Arity) ++
+ "-" ++ Type ++ "-" ++ integer_to_list(C) ++ "-",
+ {list_to_atom(Name),St#kern{fcount=C+1}}.
+
+%% new_var_name(State) -> {VarName,State}.
+
+new_var_name(#kern{vcount=C}=St) ->
+ {list_to_atom("ker" ++ integer_to_list(C)),St#kern{vcount=C+1}}.
+
+%% new_var(State) -> {#k_var{},State}.
+
+new_var(St0) ->
+ {New,St1} = new_var_name(St0),
+ {#k_var{name=New},St1}.
+
+%% new_vars(Count, State) -> {[#k_var{}],State}.
+%% Make Count new variables.
+
+new_vars(N, St) -> new_vars(N, St, []).
+
+new_vars(N, St0, Vs) when N > 0 ->
+ {V,St1} = new_var(St0),
+ new_vars(N-1, St1, [V|Vs]);
+new_vars(0, St, Vs) -> {Vs,St}.
+
+make_vars(Vs) -> [ #k_var{name=V} || V <- Vs ].
+
+add_var_def(V, St) ->
+ St#kern{ds=sets:add_element(V#k_var.name, St#kern.ds)}.
+
+%%add_vars_def(Vs, St) ->
+%% Ds = foldl(fun (#k_var{name=V}, Ds) -> add_element(V, Ds) end,
+%% St#kern.ds, Vs),
+%% St#kern{ds=Ds}.
+
+%% is_remote_bif(Mod, Name, Arity) -> true | false.
+%% Test if function is really a BIF.
+
+is_remote_bif(erlang, get, 1) -> true;
+is_remote_bif(erlang, N, A) ->
+ case erl_internal:guard_bif(N, A) of
+ true -> true;
+ false ->
+ try erl_internal:op_type(N, A) of
+ arith -> true;
+ bool -> true;
+ comp -> true;
+ list -> false;
+ send -> false
+ catch
+ _:_ -> false % not an op
+ end
+ end;
+is_remote_bif(_, _, _) -> false.
+
+%% bif_vals(Name, Arity) -> integer().
+%% bif_vals(Mod, Name, Arity) -> integer().
+%% Determine how many return values a BIF has. Provision for BIFs to
+%% return multiple values. Only used in bodies where a BIF may be
+%% called for effect only.
+
+bif_vals(dsetelement, 3) -> 0;
+bif_vals(bs_context_to_binary, 1) -> 0;
+bif_vals(_, _) -> 1.
+
+bif_vals(_, _, _) -> 1.
+
+%% foldr2(Fun, Acc, List1, List2) -> Acc.
+%% Fold over two lists.
+
+foldr2(Fun, Acc0, [E1|L1], [E2|L2]) ->
+ Acc1 = Fun(E1, E2, Acc0),
+ foldr2(Fun, Acc1, L1, L2);
+foldr2(_, Acc, [], []) -> Acc.
+
+%% first([A]) -> [A].
+%% last([A]) -> A.
+
+last([L]) -> L;
+last([_|T]) -> last(T).
+
+first([_]) -> [];
+first([H|T]) -> [H|first(T)].
+
+%% This code implements the algorithm for an optimizing compiler for
+%% pattern matching given "The Implementation of Functional
+%% Programming Languages" by Simon Peyton Jones. The code is much
+%% longer as the meaning of constructors is different from the book.
+%%
+%% In Erlang many constructors can have different values, e.g. 'atom'
+%% or 'integer', whereas in the original algorithm thse would be
+%% different constructors. Our view makes it easier in later passes to
+%% handle indexing over each type.
+%%
+%% Patterns are complicated by having alias variables. The form of a
+%% pattern is Pat | {alias,Pat,[AliasVar]}. This is hidden by access
+%% functions to pattern arguments but the code must be aware of it.
+%%
+%% The compilation proceeds in two steps:
+%%
+%% 1. The patterns in the clauses to converted to lists of kernel
+%% patterns. The Core clause is now hybrid, this is easier to work
+%% with. Remove clauses with trivially false guards, this simplifies
+%% later passes. Add locally defined vars and variable subs to each
+%% clause for later use.
+%%
+%% 2. The pattern matching is optimised. Variable substitutions are
+%% added to the VarSub structure and new variables are made visible.
+%% The guard and body are then converted to Kernel form.
+
+%% kmatch([Var], [Clause], Sub, State) -> {Kexpr,State}.
+
+kmatch(Us, Ccs, Sub, St0) ->
+ {Cs,St1} = match_pre(Ccs, Sub, St0), %Convert clauses
+ Def = fail,
+%% Def = #k_call{anno=[compiler_generated],
+%% op=#k_remote{mod=#k_atom{val=erlang},
+%% name=#k_atom{val=exit},
+%% arity=1},
+%% args=[#k_atom{val=kernel_match_error}]},
+ match(Us, Cs, Def, St1). %Do the match.
+
+%% match_pre([Cclause], Sub, State) -> {[Clause],State}.
+%% Must be careful not to generate new substitutions here now!
+%% Remove clauses with trivially false guards which will never
+%% succeed.
+
+match_pre(Cs, Sub0, St) ->
+ foldr(fun (#c_clause{anno=A,pats=Ps,guard=G,body=B}, {Cs0,St0}) ->
+ {Kps,Osub1,St1} = pattern_list(Ps, Sub0, St0),
+ {[#iclause{anno=A,isub=Sub0,osub=Osub1,
+ pats=Kps,guard=G,body=B}|
+ Cs0],St1}
+ end, {[],St}, Cs).
+
+%% match([Var], [Clause], Default, State) -> {MatchExpr,State}.
+
+match([_U|_Us] = L, Cs, Def, St0) ->
+ %%ok = io:format("match ~p~n", [Cs]),
+ Pcss = partition(Cs),
+ foldr(fun (Pcs, {D,St}) -> match_varcon(L, Pcs, D, St) end,
+ {Def,St0}, Pcss);
+match([], Cs, Def, St) ->
+ match_guard(Cs, Def, St).
+
+%% match_guard([Clause], Default, State) -> {IfExpr,State}.
+%% Build a guard to handle guards. A guard *ALWAYS* fails if no
+%% clause matches, there will be a surrounding 'alt' to catch the
+%% failure. Drop redundant cases, i.e. those after a true guard.
+
+match_guard(Cs0, Def0, St0) ->
+ {Cs1,Def1,St1} = match_guard_1(Cs0, Def0, St0),
+ {build_alt(build_guard(Cs1), Def1),St1}.
+
+match_guard_1([#iclause{anno=A,osub=Osub,guard=G,body=B}|Cs0], Def0, St0) ->
+ case is_true_guard(G) of
+ true ->
+ %% The true clause body becomes the default.
+ {Kb,Pb,St1} = body(B, Osub, St0),
+ Line = get_line(A),
+ St2 = maybe_add_warning(Cs0, Line, St1),
+ St = maybe_add_warning(Def0, Line, St2),
+ {[],pre_seq(Pb, Kb),St};
+ false ->
+ {Kg,St1} = guard(G, Osub, St0),
+ {Kb,Pb,St2} = body(B, Osub, St1),
+ {Cs1,Def1,St3} = match_guard_1(Cs0, Def0, St2),
+ {[#k_guard_clause{guard=Kg,body=pre_seq(Pb, Kb)}|Cs1],
+ Def1,St3}
+ end;
+match_guard_1([], Def, St) -> {[],Def,St}.
+
+maybe_add_warning([C|_], Line, St) ->
+ maybe_add_warning(C, Line, St);
+maybe_add_warning([], _Line, St) -> St;
+maybe_add_warning(fail, _Line, St) -> St;
+maybe_add_warning(Ke, MatchLine, St) ->
+ case get_kanno(Ke) of
+ [compiler_generated|_] -> St;
+ Anno ->
+ Line = get_line(Anno),
+ Warn = case MatchLine of
+ none -> nomatch_shadow;
+ _ -> {nomatch_shadow,MatchLine}
+ end,
+ add_warning(Line, Warn, Anno, St)
+ end.
+
+get_line([Line|_]) when is_integer(Line) -> Line;
+get_line([_|T]) -> get_line(T);
+get_line([]) -> none.
+
+get_file([{file,File}|_]) -> File;
+get_file([_|T]) -> get_file(T);
+get_file([]) -> "no_file". % should not happen
+
+%% is_true_guard(Guard) -> boolean().
+%% Test if a guard is trivially true.
+
+is_true_guard(#c_literal{val=true}) -> true;
+is_true_guard(_) -> false.
+
+%% partition([Clause]) -> [[Clause]].
+%% Partition a list of clauses into groups which either contain
+%% clauses with a variable first argument, or with a "constructor".
+
+partition([C1|Cs]) ->
+ V1 = is_var_clause(C1),
+ {More,Rest} = splitwith(fun (C) -> is_var_clause(C) =:= V1 end, Cs),
+ [[C1|More]|partition(Rest)];
+partition([]) -> [].
+
+%% match_varcon([Var], [Clause], Def, [Var], Sub, State) ->
+%% {MatchExpr,State}.
+
+match_varcon(Us, [C|_]=Cs, Def, St) ->
+ case is_var_clause(C) of
+ true -> match_var(Us, Cs, Def, St);
+ false -> match_con(Us, Cs, Def, St)
+ end.
+
+%% match_var([Var], [Clause], Def, State) -> {MatchExpr,State}.
+%% Build a call to "select" from a list of clauses all containing a
+%% variable as the first argument. We must rename the variable in
+%% each clause to be the match variable as these clause will share
+%% this variable and may have different names for it. Rename aliases
+%% as well.
+
+match_var([U|Us], Cs0, Def, St) ->
+ Cs1 = map(fun (#iclause{isub=Isub0,osub=Osub0,pats=[Arg|As]}=C) ->
+ Vs = [arg_arg(Arg)|arg_alias(Arg)],
+ Osub1 = foldl(fun (#k_var{name=V}, Acc) ->
+ subst_vsub(V, U#k_var.name, Acc)
+ end, Osub0, Vs),
+ Isub1 = foldl(fun (#k_var{name=V}, Acc) ->
+ subst_vsub(V, U#k_var.name, Acc)
+ end, Isub0, Vs),
+ C#iclause{isub=Isub1,osub=Osub1,pats=As}
+ end, Cs0),
+ match(Us, Cs1, Def, St).
+
+%% match_con(Variables, [Clause], Default, State) -> {SelectExpr,State}.
+%% Build call to "select" from a list of clauses all containing a
+%% constructor/constant as first argument. Group the constructors
+%% according to type, the order is really irrelevant but tries to be
+%% smart.
+
+match_con(Us, Cs0, Def, #kern{lit=no}=St) ->
+ %% No constant pool (for compatibility with R11B).
+ %% We must expand literals.
+ Cs = [expand_pat_lit_clause(C, true) || C <- Cs0],
+ match_con_1(Us, Cs, Def, St);
+match_con(Us, [C], Def, St) ->
+ %% There is only one clause. We can keep literal tuples and
+ %% lists, but we must convert []/integer/float/atom literals
+ %% to the proper record (#k_nil{} and so on).
+ Cs = [expand_pat_lit_clause(C, false)],
+ match_con_1(Us, Cs, Def, St);
+match_con(Us, Cs0, Def, St) ->
+ %% More than one clause. Remove literals at the top level.
+ Cs = [expand_pat_lit_clause(C, true) || C <- Cs0],
+ match_con_1(Us, Cs, Def, St).
+
+match_con_1([U|_Us] = L, Cs, Def, St0) ->
+ %% Extract clauses for different constructors (types).
+ %%ok = io:format("match_con ~p~n", [Cs]),
+ Ttcs = select_types([k_binary], Cs) ++ select_bin_con(Cs) ++
+ select_types([k_cons,k_tuple,k_atom,k_float,k_int,k_nil,k_literal], Cs),
+ %%ok = io:format("ttcs = ~p~n", [Ttcs]),
+ {Scs,St1} =
+ mapfoldl(fun ({T,Tcs}, St) ->
+ {[S|_]=Sc,S1} = match_value(L, T, Tcs, fail, St),
+ %%ok = io:format("match_con type2 ~p~n", [T]),
+ Anno = get_kanno(S),
+ {#k_type_clause{anno=Anno,type=T,values=Sc},S1} end,
+ St0, Ttcs),
+ {build_alt_1st_no_fail(build_select(U, Scs), Def),St1}.
+
+select_types(Types, Cs) ->
+ [{T,Tcs} || T <- Types, begin Tcs = select(T, Cs), Tcs =/= [] end].
+
+expand_pat_lit_clause(#iclause{pats=[#ialias{pat=#k_literal{anno=A,val=Val}}=Alias|Ps]}=C, B) ->
+ P = case B of
+ true -> expand_pat_lit(Val, A);
+ false -> literal(Val, A)
+ end,
+ C#iclause{pats=[Alias#ialias{pat=P}|Ps]};
+expand_pat_lit_clause(#iclause{pats=[#k_literal{anno=A,val=Val}|Ps]}=C, B) ->
+ P = case B of
+ true -> expand_pat_lit(Val, A);
+ false -> literal(Val, A)
+ end,
+ C#iclause{pats=[P|Ps]};
+expand_pat_lit_clause(#iclause{pats=[#k_binary{anno=A,segs=#k_bin_end{}}|Ps]}=C, B) ->
+ case B of
+ true ->
+ C;
+ false ->
+ P = #k_literal{anno=A,val = <<>>},
+ C#iclause{pats=[P|Ps]}
+ end;
+expand_pat_lit_clause(C, _) -> C.
+
+expand_pat_lit([H|T], A) ->
+ #k_cons{anno=A,hd=literal(H, A),tl=literal(T, A)};
+expand_pat_lit(Tuple, A) when is_tuple(Tuple) ->
+ #k_tuple{anno=A,es=[literal(E, A) || E <- tuple_to_list(Tuple)]};
+expand_pat_lit(Lit, A) ->
+ literal(Lit, A).
+
+literal([], A) ->
+ #k_nil{anno=A};
+literal(Val, A) when is_integer(Val) ->
+ #k_int{anno=A,val=Val};
+literal(Val, A) when is_float(Val) ->
+ #k_float{anno=A,val=Val};
+literal(Val, A) when is_atom(Val) ->
+ #k_atom{anno=A,val=Val};
+literal(Val, A) when is_list(Val); is_tuple(Val) ->
+ #k_literal{anno=A,val=Val}.
+
+%% select_bin_con([Clause]) -> [{Type,[Clause]}].
+%% Extract clauses for the k_bin_seg constructor. As k_bin_seg
+%% matching can overlap, the k_bin_seg constructors cannot be
+%% reordered, only grouped.
+
+select_bin_con(Cs0) ->
+ Cs1 = lists:filter(fun (C) ->
+ Con = clause_con(C),
+ (Con =:= k_bin_seg) or (Con =:= k_bin_end)
+ end, Cs0),
+ select_bin_con_1(Cs1).
+
+select_bin_con_1(Cs) ->
+ try
+ select_bin_int(Cs)
+ catch
+ throw:not_possible ->
+ select_bin_con_2(Cs)
+ end.
+
+select_bin_con_2([C1|Cs]) ->
+ Con = clause_con(C1),
+ {More,Rest} = splitwith(fun (C) -> clause_con(C) =:= Con end, Cs),
+ [{Con,[C1|More]}|select_bin_con_2(Rest)];
+select_bin_con_2([]) -> [].
+
+%% select_bin_int([Clause]) -> {k_bin_int,[Clause]}
+%% If the first pattern in each clause selects the same integer,
+%% rewrite all clauses to use #k_bin_int{} (which will later to
+%% translated to a bs_match_string/4 instruction).
+%%
+%% If it is not possible to do this rewrite, a 'not_possible'
+%% exception is thrown.
+
+select_bin_int([#iclause{pats=[#k_bin_seg{anno=A,type=integer,
+ size=#k_int{val=Bits0}=Sz,unit=U,
+ flags=Fl,seg=#k_literal{val=Val},
+ next=N}|Ps]}=C|Cs0])
+ when is_integer(Val) ->
+ Bits = U * Bits0,
+ if
+ Bits > 1024 -> throw(not_possible); %Expands the code too much.
+ true -> ok
+ end,
+ select_assert_match_possible(Bits, Val, Fl),
+ P = #k_bin_int{anno=A,size=Sz,unit=U,flags=Fl,val=Val,next=N},
+ select_assert_match_possible(Bits, Val, Fl),
+ case member(native, Fl) of
+ true -> throw(not_possible);
+ false -> ok
+ end,
+ Cs = select_bin_int_1(Cs0, Bits, Fl, Val),
+ [{k_bin_int,[C#iclause{pats=[P|Ps]}|Cs]}];
+select_bin_int([#iclause{pats=[#k_bin_seg{anno=A,type=utf8,
+ flags=[unsigned,big]=Fl,
+ seg=#k_literal{val=Val0},
+ next=N}|Ps]}=C|Cs0])
+ when is_integer(Val0) ->
+ {Val,Bits} = select_utf8(Val0),
+ P = #k_bin_int{anno=A,size=#k_int{val=Bits},unit=1,
+ flags=Fl,val=Val,next=N},
+ Cs = select_bin_int_1(Cs0, Bits, Fl, Val),
+ [{k_bin_int,[C#iclause{pats=[P|Ps]}|Cs]}];
+select_bin_int(_) -> throw(not_possible).
+
+select_bin_int_1([#iclause{pats=[#k_bin_seg{anno=A,type=integer,
+ size=#k_int{val=Bits0}=Sz,
+ unit=U,
+ flags=Fl,seg=#k_literal{val=Val},
+ next=N}|Ps]}=C|Cs],
+ Bits, Fl, Val) when is_integer(Val) ->
+ if
+ Bits0*U =:= Bits -> ok;
+ true -> throw(not_possible)
+ end,
+ P = #k_bin_int{anno=A,size=Sz,unit=U,flags=Fl,val=Val,next=N},
+ [C#iclause{pats=[P|Ps]}|select_bin_int_1(Cs, Bits, Fl, Val)];
+select_bin_int_1([#iclause{pats=[#k_bin_seg{anno=A,type=utf8,
+ flags=Fl,
+ seg=#k_literal{val=Val0},
+ next=N}|Ps]}=C|Cs],
+ Bits, Fl, Val) when is_integer(Val0) ->
+ case select_utf8(Val0) of
+ {Val,Bits} -> ok;
+ {_,_} -> throw(not_possible)
+ end,
+ P = #k_bin_int{anno=A,size=#k_int{val=Bits},unit=1,
+ flags=[unsigned,big],val=Val,next=N},
+ [C#iclause{pats=[P|Ps]}|select_bin_int_1(Cs, Bits, Fl, Val)];
+select_bin_int_1([], _, _, _) -> [];
+select_bin_int_1(_, _, _, _) -> throw(not_possible).
+
+select_assert_match_possible(Sz, Val, Fs) ->
+ EmptyBindings = erl_eval:new_bindings(),
+ MatchFun = fun({integer,_,_}, NewV, Bs) when NewV =:= Val ->
+ {match,Bs}
+ end,
+ EvalFun = fun({integer,_,S}, B) -> {value,S,B} end,
+ Expr = [{bin_element,0,{integer,0,Val},{integer,0,Sz},[{unit,1}|Fs]}],
+ {value,Bin,EmptyBindings} = eval_bits:expr_grp(Expr, EmptyBindings, EvalFun),
+ try
+ {match,_} = eval_bits:match_bits(Expr, Bin,
+ EmptyBindings,
+ EmptyBindings,
+ MatchFun, EvalFun),
+ ok % this is just an assertion (i.e., no return value)
+ catch
+ throw:nomatch ->
+ throw(not_possible)
+ end.
+
+select_utf8(Val0) ->
+ try
+ Bin = <<Val0/utf8>>,
+ Size = bit_size(Bin),
+ <<Val:Size>> = Bin,
+ {Val,Size}
+ catch
+ error:_ ->
+ throw(not_possible)
+ end.
+
+%% select(Con, [Clause]) -> [Clause].
+
+select(T, Cs) -> [ C || C <- Cs, clause_con(C) =:= T ].
+
+%% match_value([Var], Con, [Clause], Default, State) -> {SelectExpr,State}.
+%% At this point all the clauses have the same constructor, we must
+%% now separate them according to value.
+
+match_value(Us, T, Cs0, Def, St0) ->
+ Css = group_value(T, Cs0),
+ %%ok = io:format("match_value ~p ~p~n", [T, Css]),
+ mapfoldl(fun (Cs, St) -> match_clause(Us, Cs, Def, St) end, St0, Css).
+
+%% group_value([Clause]) -> [[Clause]].
+%% Group clauses according to value. Here we know that
+%% 1. Some types are singled valued
+%% 2. The clauses in bin_segs cannot be reordered only grouped
+%% 3. Other types are disjoint and can be reordered
+
+group_value(k_cons, Cs) -> [Cs]; %These are single valued
+group_value(k_nil, Cs) -> [Cs];
+group_value(k_binary, Cs) -> [Cs];
+group_value(k_bin_end, Cs) -> [Cs];
+group_value(k_bin_seg, Cs) ->
+ group_bin_seg(Cs);
+group_value(k_bin_int, Cs) ->
+ [Cs];
+group_value(_, Cs) ->
+ %% group_value(Cs).
+ Cd = foldl(fun (C, Gcs0) -> dict:append(clause_val(C), C, Gcs0) end,
+ dict:new(), Cs),
+ dict:fold(fun (_, Vcs, Css) -> [Vcs|Css] end, [], Cd).
+
+group_bin_seg([C1|Cs]) ->
+ V1 = clause_val(C1),
+ {More,Rest} = splitwith(fun (C) -> clause_val(C) == V1 end, Cs),
+ [[C1|More]|group_bin_seg(Rest)];
+group_bin_seg([]) -> [].
+
+%% Profiling shows that this quadratic implementation account for a big amount
+%% of the execution time if there are many values.
+% group_value([C|Cs]) ->
+% V = clause_val(C),
+% Same = [ Cv || Cv <- Cs, clause_val(Cv) == V ], %Same value
+% Rest = [ Cv || Cv <- Cs, clause_val(Cv) /= V ], % and all the rest
+% [[C|Same]|group_value(Rest)];
+% group_value([]) -> [].
+
+%% match_clause([Var], [Clause], Default, State) -> {Clause,State}.
+%% At this point all the clauses have the same "value". Build one
+%% select clause for this value and continue matching. Rename
+%% aliases as well.
+
+match_clause([U|Us], [C|_]=Cs0, Def, St0) ->
+ Anno = get_kanno(C),
+ {Match0,Vs,St1} = get_match(get_con(Cs0), St0),
+ Match = sub_size_var(Match0, Cs0),
+ {Cs1,St2} = new_clauses(Cs0, U, St1),
+ {B,St3} = match(Vs ++ Us, Cs1, Def, St2),
+ {#k_val_clause{anno=Anno,val=Match,body=B},St3}.
+
+sub_size_var(#k_bin_seg{size=#k_var{name=Name}=Kvar}=BinSeg, [#iclause{isub=Sub}|_]) ->
+ BinSeg#k_bin_seg{size=Kvar#k_var{name=get_vsub(Name, Sub)}};
+sub_size_var(#k_bin_int{size=#k_var{name=Name}=Kvar}=BinSeg, [#iclause{isub=Sub}|_]) ->
+ BinSeg#k_bin_int{size=Kvar#k_var{name=get_vsub(Name, Sub)}};
+sub_size_var(K, _) -> K.
+
+get_con([C|_]) -> arg_arg(clause_arg(C)). %Get the constructor
+
+get_match(#k_cons{}, St0) ->
+ {[H,T]=L,St1} = new_vars(2, St0),
+ {#k_cons{hd=H,tl=T},L,St1};
+get_match(#k_binary{}, St0) ->
+ {[V]=Mes,St1} = new_vars(1, St0),
+ {#k_binary{segs=V},Mes,St1};
+get_match(#k_bin_seg{size=#k_atom{val=all},next={k_bin_end,[]}}=Seg, St0) ->
+ {[S]=Vars,St1} = new_vars(1, St0),
+ {Seg#k_bin_seg{seg=S,next=[]},Vars,St1};
+get_match(#k_bin_seg{}=Seg, St0) ->
+ {[S,N0],St1} = new_vars(2, St0),
+ N = set_kanno(N0, [no_usage]),
+ {Seg#k_bin_seg{seg=S,next=N},[S,N],St1};
+get_match(#k_bin_int{}=BinInt, St0) ->
+ {N0,St1} = new_var(St0),
+ N = set_kanno(N0, [no_usage]),
+ {BinInt#k_bin_int{next=N},[N],St1};
+get_match(#k_tuple{es=Es}, St0) ->
+ {Mes,St1} = new_vars(length(Es), St0),
+ {#k_tuple{es=Mes},Mes,St1};
+get_match(M, St) ->
+ {M,[],St}.
+
+new_clauses(Cs0, U, St) ->
+ Cs1 = map(fun (#iclause{isub=Isub0,osub=Osub0,pats=[Arg|As]}=C) ->
+ Head = case arg_arg(Arg) of
+ #k_cons{hd=H,tl=T} -> [H,T|As];
+ #k_tuple{es=Es} -> Es ++ As;
+ #k_binary{segs=E} -> [E|As];
+ #k_bin_seg{size=#k_atom{val=all},
+ seg=S,next={k_bin_end,[]}} ->
+ [S|As];
+ #k_bin_seg{seg=S,next=N} ->
+ [S,N|As];
+ #k_bin_int{next=N} ->
+ [N|As];
+ _Other -> As
+ end,
+ Vs = arg_alias(Arg),
+ Osub1 = foldl(fun (#k_var{name=V}, Acc) ->
+ subst_vsub(V, U#k_var.name, Acc)
+ end, Osub0, Vs),
+ Isub1 = foldl(fun (#k_var{name=V}, Acc) ->
+ subst_vsub(V, U#k_var.name, Acc)
+ end, Isub0, Vs),
+ C#iclause{isub=Isub1,osub=Osub1,pats=Head}
+ end, Cs0),
+ {Cs1,St}.
+
+%% build_guard([GuardClause]) -> GuardExpr.
+
+build_guard([]) -> fail;
+build_guard(Cs) -> #k_guard{clauses=Cs}.
+
+%% build_select(Var, [ConClause]) -> SelectExpr.
+
+build_select(V, [Tc|_]=Tcs) ->
+ copy_anno(#k_select{var=V,types=Tcs}, Tc).
+
+%% build_alt(First, Then) -> AltExpr.
+%% Build an alt, attempt some simple optimisation.
+
+build_alt(fail, Then) -> Then;
+build_alt(First,Then) -> build_alt_1st_no_fail(First, Then).
+
+build_alt_1st_no_fail(First, fail) -> First;
+build_alt_1st_no_fail(First, Then) ->
+ copy_anno(#k_alt{first=First,then=Then}, First).
+
+%% build_match([MatchVar], MatchExpr) -> Kexpr.
+%% Build a match expr if there is a match.
+
+build_match(Us, #k_alt{}=Km) -> copy_anno(#k_match{vars=Us,body=Km}, Km);
+build_match(Us, #k_select{}=Km) -> copy_anno(#k_match{vars=Us,body=Km}, Km);
+build_match(Us, #k_guard{}=Km) -> copy_anno(#k_match{vars=Us,body=Km}, Km);
+build_match(_, Km) -> Km.
+
+%% clause_arg(Clause) -> FirstArg.
+%% clause_con(Clause) -> Constructor.
+%% clause_val(Clause) -> Value.
+%% is_var_clause(Clause) -> boolean().
+
+clause_arg(#iclause{pats=[Arg|_]}) -> Arg.
+
+clause_con(C) -> arg_con(clause_arg(C)).
+
+clause_val(C) -> arg_val(clause_arg(C)).
+
+is_var_clause(C) -> clause_con(C) =:= k_var.
+
+%% arg_arg(Arg) -> Arg.
+%% arg_alias(Arg) -> Aliases.
+%% arg_con(Arg) -> Constructor.
+%% arg_val(Arg) -> Value.
+%% These are the basic functions for obtaining fields in an argument.
+
+arg_arg(#ialias{pat=Con}) -> Con;
+arg_arg(Con) -> Con.
+
+arg_alias(#ialias{vars=As}) -> As;
+arg_alias(_Con) -> [].
+
+arg_con(Arg) ->
+ case arg_arg(Arg) of
+ #k_literal{} -> k_literal;
+ #k_int{} -> k_int;
+ #k_float{} -> k_float;
+ #k_atom{} -> k_atom;
+ #k_nil{} -> k_nil;
+ #k_cons{} -> k_cons;
+ #k_tuple{} -> k_tuple;
+ #k_binary{} -> k_binary;
+ #k_bin_end{} -> k_bin_end;
+ #k_bin_int{} -> k_bin_int;
+ #k_bin_seg{} -> k_bin_seg;
+ #k_var{} -> k_var
+ end.
+
+arg_val(Arg) ->
+ case arg_arg(Arg) of
+ #k_literal{val=Lit} -> Lit;
+ #k_int{val=I} -> I;
+ #k_float{val=F} -> F;
+ #k_atom{val=A} -> A;
+ #k_nil{} -> 0;
+ #k_cons{} -> 2;
+ #k_tuple{es=Es} -> length(Es);
+ #k_bin_seg{size=S,unit=U,type=T,flags=Fs} ->
+ {set_kanno(S, []),U,T,Fs};
+ #k_bin_int{} ->
+ 0;
+ #k_bin_end{} -> 0;
+ #k_binary{} -> 0
+ end.
+
+%% ubody_used_vars(Expr, State) -> [UsedVar]
+%% Return all used variables for the body sequence. Much more
+%% efficient than using ubody/3 if the body contains nested letrecs.
+ubody_used_vars(Expr, St) ->
+ {_,Used,_} = ubody(Expr, return, St#kern{funs=ignore}),
+ Used.
+
+%% ubody(Expr, Break, State) -> {Expr,[UsedVar],State}.
+%% Tag the body sequence with its used variables. These bodies
+%% either end with a #k_break{}, or with #k_return{} or an expression
+%% which itself can return, #k_enter{}, #k_match{} ... .
+
+ubody(#iset{vars=[],arg=#iletrec{}=Let,body=B0}, Br, St0) ->
+ %% An iletrec{} should never be last.
+ St = iletrec_funs(Let, St0),
+ ubody(B0, Br, St);
+ubody(#iset{anno=A,vars=Vs,arg=E0,body=B0}, Br, St0) ->
+ {E1,Eu,St1} = uexpr(E0, {break,Vs}, St0),
+ {B1,Bu,St2} = ubody(B0, Br, St1),
+ Ns = lit_list_vars(Vs),
+ Used = union(Eu, subtract(Bu, Ns)), %Used external vars
+ {#k_seq{anno=#k{us=Used,ns=Ns,a=A},arg=E1,body=B1},Used,St2};
+ubody(#ivalues{anno=A,args=As}, return, St) ->
+ Au = lit_list_vars(As),
+ {#k_return{anno=#k{us=Au,ns=[],a=A},args=As},Au,St};
+ubody(#ivalues{anno=A,args=As}, {break,_Vbs}, St) ->
+ Au = lit_list_vars(As),
+ if St#kern.guard_refc > 0 ->
+ {#k_guard_break{anno=#k{us=Au,ns=[],a=A},args=As},Au,St};
+ true ->
+ {#k_break{anno=#k{us=Au,ns=[],a=A},args=As},Au,St}
+ end;
+ubody(#ivalues{anno=A,args=As}, {guard_break,_Vbs}, St) ->
+ Au = lit_list_vars(As),
+ {#k_guard_break{anno=#k{us=Au,ns=[],a=A},args=As},Au,St};
+ubody(E, return, St0) ->
+ %% Enterable expressions need no trailing return.
+ case is_enter_expr(E) of
+ true -> uexpr(E, return, St0);
+ false ->
+ {Ea,Pa,St1} = force_atomic(E, St0),
+ ubody(pre_seq(Pa, #ivalues{args=[Ea]}), return, St1)
+ end;
+ubody(E, {break,_Rs} = Break, St0) ->
+ %%ok = io:fwrite("ubody ~w:~p~n", [?LINE,{E,Br}]),
+ %% Exiting expressions need no trailing break.
+ case is_exit_expr(E) of
+ true -> uexpr(E, return, St0);
+ false ->
+ {Ea,Pa,St1} = force_atomic(E, St0),
+ ubody(pre_seq(Pa, #ivalues{args=[Ea]}), Break, St1)
+ end;
+ubody(E, {guard_break,_Rs} = GuardBreak, St0) ->
+ %%ok = io:fwrite("ubody ~w:~p~n", [?LINE,{E,Br}]),
+ %% Exiting expressions need no trailing break.
+ {Ea,Pa,St1} = force_atomic(E, St0),
+ ubody(pre_seq(Pa, #ivalues{args=[Ea]}), GuardBreak, St1).
+
+iletrec_funs(#iletrec{defs=Fs}, St0) ->
+ %% Use union of all free variables.
+ %% First just work out free variables for all functions.
+ Free = foldl(fun ({_,#ifun{vars=Vs,body=Fb0}}, Free0) ->
+ Fbu = ubody_used_vars(Fb0, St0),
+ Ns = lit_list_vars(Vs),
+ Free1 = subtract(Fbu, Ns),
+ union(Free1, Free0)
+ end, [], Fs),
+ FreeVs = make_vars(Free),
+ %% Add this free info to State.
+ St1 = foldl(fun ({N,#ifun{vars=Vs}}, Lst) ->
+ store_free(N, length(Vs), FreeVs, Lst)
+ end, St0, Fs),
+ iletrec_funs_gen(Fs, FreeVs, St1).
+
+%% Now regenerate local functions to use free variable information.
+iletrec_funs_gen(_, _, #kern{funs=ignore}=St) ->
+ %% Optimization: The ultimate caller is only interested in the used variables,
+ %% not the updated state. Makes a difference if there are nested letrecs.
+ St;
+iletrec_funs_gen(Fs, FreeVs, St) ->
+ foldl(fun ({N,#ifun{anno=Fa,vars=Vs,body=Fb0}}, Lst0) ->
+ Arity0 = length(Vs),
+ {Fb1,_,Lst1} = ubody(Fb0, return, Lst0#kern{ff={N,Arity0}}),
+ Arity = Arity0 + length(FreeVs),
+ Fun = #k_fdef{anno=#k{us=[],ns=[],a=Fa},
+ func=N,arity=Arity,
+ vars=Vs ++ FreeVs,body=Fb1},
+ Lst1#kern{funs=[Fun|Lst1#kern.funs]}
+ end, St, Fs).
+
+
+%% is_exit_expr(Kexpr) -> boolean().
+%% Test whether Kexpr always exits and never returns.
+
+is_exit_expr(#k_call{op=#k_internal{name=match_fail,arity=1}}) -> true;
+is_exit_expr(#k_receive_next{}) -> true;
+is_exit_expr(_) -> false.
+
+%% is_enter_expr(Kexpr) -> boolean().
+%% Test whether Kexpr is "enterable", i.e. can handle return from
+%% within itself without extra #k_return{}.
+
+is_enter_expr(#k_try{}) -> true;
+is_enter_expr(#k_call{}) -> true;
+is_enter_expr(#k_match{}) -> true;
+is_enter_expr(#k_receive{}) -> true;
+is_enter_expr(#k_receive_next{}) -> true;
+is_enter_expr(_) -> false.
+
+%% uguard(Expr, State) -> {Expr,[UsedVar],State}.
+%% Tag the guard sequence with its used variables.
+
+uguard(#k_try{anno=A,arg=B0,vars=[#k_var{name=X}],body=#k_var{name=X},
+ handler=#k_atom{val=false}}=Try, St0) ->
+ {B1,Bu,St1} = uguard(B0, St0),
+ {Try#k_try{anno=#k{us=Bu,ns=[],a=A},arg=B1},Bu,St1};
+uguard(T, St) ->
+ %%ok = io:fwrite("~w: ~p~n", [?LINE,T]),
+ uguard_test(T, St).
+
+%% uguard_test(Expr, State) -> {Test,[UsedVar],State}.
+%% At this stage tests are just expressions which don't return any
+%% values.
+
+uguard_test(T, St) -> uguard_expr(T, [], St).
+
+uguard_expr(#iset{anno=A,vars=Vs,arg=E0,body=B0}, Rs, St0) ->
+ Ns = lit_list_vars(Vs),
+ {E1,Eu,St1} = uguard_expr(E0, Vs, St0),
+ {B1,Bu,St2} = uguard_expr(B0, Rs, St1),
+ Used = union(Eu, subtract(Bu, Ns)),
+ {#k_seq{anno=#k{us=Used,ns=Ns,a=A},arg=E1,body=B1},Used,St2};
+uguard_expr(#k_try{anno=A,arg=B0,vars=[#k_var{name=X}],body=#k_var{name=X},
+ handler=#k_atom{val=false}}=Try, Rs, St0) ->
+ {B1,Bu,St1} = uguard_expr(B0, Rs, St0),
+ {Try#k_try{anno=#k{us=Bu,ns=lit_list_vars(Rs),a=A},arg=B1,ret=Rs},
+ Bu,St1};
+uguard_expr(#k_test{anno=A,op=Op,args=As}=Test, Rs, St) ->
+ [] = Rs, %Sanity check
+ Used = union(op_vars(Op), lit_list_vars(As)),
+ {Test#k_test{anno=#k{us=Used,ns=lit_list_vars(Rs),a=A}},
+ Used,St};
+uguard_expr(#k_bif{anno=A,op=Op,args=As}=Bif, Rs, St) ->
+ Used = union(op_vars(Op), lit_list_vars(As)),
+ {Bif#k_bif{anno=#k{us=Used,ns=lit_list_vars(Rs),a=A},ret=Rs},
+ Used,St};
+uguard_expr(#ivalues{anno=A,args=As}, Rs, St) ->
+ Sets = foldr2(fun (V, Arg, Rhs) ->
+ #iset{anno=A,vars=[V],arg=Arg,body=Rhs}
+ end, #k_atom{val=true}, Rs, As),
+ uguard_expr(Sets, [], St);
+uguard_expr(#k_match{anno=A,vars=Vs,body=B0}, Rs, St0) ->
+ %% Experimental support for andalso/orelse in guards.
+ Br = {guard_break,Rs},
+ {B1,Bu,St1} = umatch(B0, Br, St0),
+ {#k_guard_match{anno=#k{us=Bu,ns=lit_list_vars(Rs),a=A},
+ vars=Vs,body=B1,ret=Rs},Bu,St1};
+uguard_expr(Lit, Rs, St) ->
+ %% Transform literals to puts here.
+ Used = lit_vars(Lit),
+ {#k_put{anno=#k{us=Used,ns=lit_list_vars(Rs),a=get_kanno(Lit)},
+ arg=Lit,ret=Rs},Used,St}.
+
+%% uexpr(Expr, Break, State) -> {Expr,[UsedVar],State}.
+%% Tag an expression with its used variables.
+%% Break = return | {break,[RetVar]}.
+
+uexpr(#k_call{anno=A,op=#k_local{name=F,arity=Ar}=Op,args=As0}=Call, Br, St) ->
+ Free = get_free(F, Ar, St),
+ As1 = As0 ++ Free, %Add free variables LAST!
+ Used = lit_list_vars(As1),
+ {case Br of
+ {break,Rs} ->
+ Call#k_call{anno=#k{us=Used,ns=lit_list_vars(Rs),a=A},
+ op=Op#k_local{arity=Ar + length(Free)},
+ args=As1,ret=Rs};
+ return ->
+ #k_enter{anno=#k{us=Used,ns=[],a=A},
+ op=Op#k_local{arity=Ar + length(Free)},
+ args=As1}
+ end,Used,St};
+uexpr(#k_call{anno=A,op=Op,args=As}=Call, {break,Rs}, St) ->
+ Used = union(op_vars(Op), lit_list_vars(As)),
+ {Call#k_call{anno=#k{us=Used,ns=lit_list_vars(Rs),a=A},ret=Rs},
+ Used,St};
+uexpr(#k_call{anno=A,op=Op,args=As}, return, St) ->
+ Used = union(op_vars(Op), lit_list_vars(As)),
+ {#k_enter{anno=#k{us=Used,ns=[],a=A},op=Op,args=As},
+ Used,St};
+uexpr(#k_bif{anno=A,op=Op,args=As}=Bif, {break,Rs}, St0) ->
+ Used = union(op_vars(Op), lit_list_vars(As)),
+ {Brs,St1} = bif_returns(Op, Rs, St0),
+ {Bif#k_bif{anno=#k{us=Used,ns=lit_list_vars(Brs),a=A},ret=Brs},
+ Used,St1};
+uexpr(#k_match{anno=A,vars=Vs0,body=B0}, Br, St0) ->
+ Vs = handle_reuse_annos(Vs0, St0),
+ Rs = break_rets(Br),
+ {B1,Bu,St1} = umatch(B0, Br, St0),
+ if St0#kern.guard_refc > 0 ->
+ {#k_guard_match{anno=#k{us=Bu,ns=lit_list_vars(Rs),a=A},
+ vars=Vs,body=B1,ret=Rs},Bu,St1};
+ true ->
+ {#k_match{anno=#k{us=Bu,ns=lit_list_vars(Rs),a=A},
+ vars=Vs,body=B1,ret=Rs},Bu,St1}
+ end;
+uexpr(#k_receive{anno=A,var=V,body=B0,timeout=T,action=A0}, Br, St0) ->
+ Rs = break_rets(Br),
+ Tu = lit_vars(T), %Timeout is atomic
+ {B1,Bu,St1} = umatch(B0, Br, St0),
+ {A1,Au,St2} = ubody(A0, Br, St1),
+ Used = del_element(V#k_var.name, union(Bu, union(Tu, Au))),
+ {#k_receive{anno=#k{us=Used,ns=lit_list_vars(Rs),a=A},
+ var=V,body=B1,timeout=T,action=A1,ret=Rs},
+ Used,St2};
+uexpr(#k_receive_accept{anno=A}, _, St) ->
+ {#k_receive_accept{anno=#k{us=[],ns=[],a=A}},[],St};
+uexpr(#k_receive_next{anno=A}, _, St) ->
+ {#k_receive_next{anno=#k{us=[],ns=[],a=A}},[],St};
+uexpr(#k_try{anno=A,arg=A0,vars=Vs,body=B0,evars=Evs,handler=H0},
+ {break,Rs0}, St0) ->
+ {Avs,St1} = new_vars(length(Vs), St0), %Need dummy names here
+ {A1,Au,St2} = ubody(A0, {break,Avs}, St1), %Must break to clean up here!
+ {B1,Bu,St3} = ubody(B0, {break,Rs0}, St2),
+ {H1,Hu,St4} = ubody(H0, {break,Rs0}, St3),
+ %% Guarantee ONE return variable.
+ NumNew = if
+ Rs0 =:= [] -> 1;
+ true -> 0
+ end,
+ {Ns,St5} = new_vars(NumNew, St4),
+ Rs1 = Rs0 ++ Ns,
+ Used = union([Au,subtract(Bu, lit_list_vars(Vs)),
+ subtract(Hu, lit_list_vars(Evs))]),
+ {#k_try{anno=#k{us=Used,ns=lit_list_vars(Rs1),a=A},
+ arg=A1,vars=Vs,body=B1,evars=Evs,handler=H1,ret=Rs1},
+ Used,St5};
+uexpr(#k_try{anno=A,arg=A0,vars=Vs,body=B0,evars=Evs,handler=H0},
+ return, St0) ->
+ {Avs,St1} = new_vars(length(Vs), St0), %Need dummy names here
+ {A1,Au,St2} = ubody(A0, {break,Avs}, St1), %Must break to clean up here!
+ {B1,Bu,St3} = ubody(B0, return, St2),
+ {H1,Hu,St4} = ubody(H0, return, St3),
+ NumNew = 1,
+ {Ns,St5} = new_vars(NumNew, St4),
+ Used = union([Au,subtract(Bu, lit_list_vars(Vs)),
+ subtract(Hu, lit_list_vars(Evs))]),
+ {#k_try_enter{anno=#k{us=Used,ns=Ns,a=A},
+ arg=A1,vars=Vs,body=B1,evars=Evs,handler=H1},
+ Used,St5};
+uexpr(#k_catch{anno=A,body=B0}, {break,Rs0}, St0) ->
+ {Rb,St1} = new_var(St0),
+ {B1,Bu,St2} = ubody(B0, {break,[Rb]}, St1),
+ %% Guarantee ONE return variable.
+ {Ns,St3} = new_vars(1 - length(Rs0), St2),
+ Rs1 = Rs0 ++ Ns,
+ {#k_catch{anno=#k{us=Bu,ns=lit_list_vars(Rs1),a=A},body=B1,ret=Rs1},Bu,St3};
+uexpr(#ifun{anno=A,vars=Vs,body=B0}=IFun, {break,Rs}, St0) ->
+ {B1,Bu,St1} = ubody(B0, return, St0), %Return out of new function
+ Ns = lit_list_vars(Vs),
+ Free = subtract(Bu, Ns), %Free variables in fun
+ Fvs = make_vars(Free),
+ Arity = length(Vs) + length(Free),
+ {{Index,Uniq,Fname}, St3} =
+ case lists:keyfind(id, 1, A) of
+ {id,Id} ->
+ {Id, St1};
+ false ->
+ %% No id annotation. Must invent one.
+ I = St1#kern.fcount,
+ U = erlang:hash(IFun, (1 bsl 27)-1),
+ {N, St2} = new_fun_name(St1),
+ {{I,U,N}, St2}
+ end,
+ Fun = #k_fdef{anno=#k{us=[],ns=[],a=A},func=Fname,arity=Arity,
+ vars=Vs ++ Fvs,body=B1},
+ {#k_bif{anno=#k{us=Free,ns=lit_list_vars(Rs),a=A},
+ op=#k_internal{name=make_fun,arity=length(Free)+3},
+ args=[#k_atom{val=Fname},#k_int{val=Arity},
+ #k_int{val=Index},#k_int{val=Uniq}|Fvs],
+ ret=Rs},
+ Free,add_local_function(Fun, St3)};
+uexpr(Lit, {break,Rs}, St) ->
+ %% Transform literals to puts here.
+ %%ok = io:fwrite("uexpr ~w:~p~n", [?LINE,Lit]),
+ Used = lit_vars(Lit),
+ {#k_put{anno=#k{us=Used,ns=lit_list_vars(Rs),a=get_kanno(Lit)},
+ arg=Lit,ret=Rs},Used,St}.
+
+add_local_function(_, #kern{funs=ignore}=St) -> St;
+add_local_function(F, #kern{funs=Funs}=St) -> St#kern{funs=[F|Funs]}.
+
+%% handle_reuse_annos([#k_var{}], State) -> State.
+%% In general, it is only safe to reuse a variable for a match context
+%% if the original value of the variable will no longer be needed.
+%%
+%% If a variable has been bound in an outer letrec and is therefore
+%% free in the current function, the variable may still be used.
+%% We don't bother to check whether the variable is actually used,
+%% but simply clears the 'reuse_for_context' annotation for any variable
+%% that is free.
+handle_reuse_annos(Vs, St) ->
+ [handle_reuse_anno(V, St) || V <- Vs].
+
+handle_reuse_anno(#k_var{anno=A}=V, St) ->
+ case member(reuse_for_context, A) of
+ false -> V;
+ true -> handle_reuse_anno_1(V, St)
+ end.
+
+handle_reuse_anno_1(#k_var{anno=Anno,name=Vname}=V, #kern{ff={F,A}}=St) ->
+ FreeVs = get_free(F, A, St),
+ case keymember(Vname, #k_var.name, FreeVs) of
+ true -> V#k_var{anno=Anno--[reuse_for_context]};
+ false -> V
+ end;
+handle_reuse_anno_1(V, _St) -> V.
+
+%% get_free(Name, Arity, State) -> [Free].
+%% store_free(Name, Arity, [Free], State) -> State.
+
+get_free(F, A, St) ->
+ case orddict:find({F,A}, St#kern.free) of
+ {ok,Val} -> Val;
+ error -> []
+ end.
+
+store_free(F, A, Free, St) ->
+ St#kern{free=orddict:store({F,A}, Free, St#kern.free)}.
+
+break_rets({break,Rs}) -> Rs;
+break_rets(return) -> [].
+
+%% bif_returns(Op, [Ret], State) -> {[Ret],State}.
+
+bif_returns(#k_remote{mod=M,name=N,arity=Ar}, Rs, St0) ->
+ %%ok = io:fwrite("uexpr ~w:~p~n", [?LINE,{M,N,Ar,Rs}]),
+ {Ns,St1} = new_vars(bif_vals(M, N, Ar) - length(Rs), St0),
+ {Rs ++ Ns,St1};
+bif_returns(#k_internal{name=N,arity=Ar}, Rs, St0) ->
+ %%ok = io:fwrite("uexpr ~w:~p~n", [?LINE,{N,Ar,Rs}]),
+ {Ns,St1} = new_vars(bif_vals(N, Ar) - length(Rs), St0),
+ {Rs ++ Ns,St1}.
+
+%% umatch(Match, Break, State) -> {Match,[UsedVar],State}.
+%% Tag a match expression with its used variables.
+
+umatch(#k_alt{anno=A,first=F0,then=T0}, Br, St0) ->
+ {F1,Fu,St1} = umatch(F0, Br, St0),
+ {T1,Tu,St2} = umatch(T0, Br, St1),
+ Used = union(Fu, Tu),
+ {#k_alt{anno=#k{us=Used,ns=[],a=A},first=F1,then=T1},
+ Used,St2};
+umatch(#k_select{anno=A,var=V0,types=Ts0}, Br, St0) ->
+ V = handle_reuse_anno(V0, St0),
+ {Ts1,Tus,St1} = umatch_list(Ts0, Br, St0),
+ Used = case member(no_usage, get_kanno(V)) of
+ true -> Tus;
+ false -> add_element(V#k_var.name, Tus)
+ end,
+ {#k_select{anno=#k{us=Used,ns=[],a=A},var=V,types=Ts1},Used,St1};
+umatch(#k_type_clause{anno=A,type=T,values=Vs0}, Br, St0) ->
+ {Vs1,Vus,St1} = umatch_list(Vs0, Br, St0),
+ {#k_type_clause{anno=#k{us=Vus,ns=[],a=A},type=T,values=Vs1},Vus,St1};
+umatch(#k_val_clause{anno=A,val=P0,body=B0}, Br, St0) ->
+ {U0,Ps} = pat_vars(P0),
+ P = set_kanno(P0, #k{us=U0,ns=Ps,a=get_kanno(P0)}),
+ {B1,Bu,St1} = umatch(B0, Br, St0),
+ Used = union(U0, subtract(Bu, Ps)),
+ {#k_val_clause{anno=#k{us=Used,ns=[],a=A},val=P,body=B1},
+ Used,St1};
+umatch(#k_guard{anno=A,clauses=Gs0}, Br, St0) ->
+ {Gs1,Gus,St1} = umatch_list(Gs0, Br, St0),
+ {#k_guard{anno=#k{us=Gus,ns=[],a=A},clauses=Gs1},Gus,St1};
+umatch(#k_guard_clause{anno=A,guard=G0,body=B0}, Br, St0) ->
+ %%ok = io:fwrite("~w: ~p~n", [?LINE,G0]),
+ {G1,Gu,St1} = uguard(G0, St0#kern{guard_refc=St0#kern.guard_refc+1}),
+ %%ok = io:fwrite("~w: ~p~n", [?LINE,G1]),
+ {B1,Bu,St2} = umatch(B0, Br, St1#kern{guard_refc=St1#kern.guard_refc-1}),
+ Used = union(Gu, Bu),
+ {#k_guard_clause{anno=#k{us=Used,ns=[],a=A},guard=G1,body=B1},Used,St2};
+umatch(B0, Br, St0) -> ubody(B0, Br, St0).
+
+umatch_list(Ms0, Br, St) ->
+ foldr(fun (M0, {Ms1,Us,Sta}) ->
+ {M1,Mu,Stb} = umatch(M0, Br, Sta),
+ {[M1|Ms1],union(Mu, Us),Stb}
+ end, {[],[],St}, Ms0).
+
+%% op_vars(Op) -> [VarName].
+
+op_vars(#k_remote{mod=Mod,name=Name}) ->
+ ordsets:from_list([V || #k_var{name=V} <- [Mod,Name]]);
+op_vars(#k_internal{}) -> [];
+op_vars(Atomic) -> lit_vars(Atomic).
+
+%% lit_vars(Literal) -> [VarName].
+%% Return the variables in a literal.
+
+lit_vars(#k_var{name=N}) -> [N];
+lit_vars(#k_int{}) -> [];
+lit_vars(#k_float{}) -> [];
+lit_vars(#k_atom{}) -> [];
+%%lit_vars(#k_char{}) -> [];
+lit_vars(#k_string{}) -> [];
+lit_vars(#k_nil{}) -> [];
+lit_vars(#k_cons{hd=H,tl=T}) ->
+ union(lit_vars(H), lit_vars(T));
+lit_vars(#k_binary{segs=V}) -> lit_vars(V);
+lit_vars(#k_bin_end{}) -> [];
+lit_vars(#k_bin_seg{size=Size,seg=S,next=N}) ->
+ union(lit_vars(Size), union(lit_vars(S), lit_vars(N)));
+lit_vars(#k_tuple{es=Es}) ->
+ lit_list_vars(Es);
+lit_vars(#k_literal{}) -> [].
+
+lit_list_vars(Ps) ->
+ foldl(fun (P, Vs) -> union(lit_vars(P), Vs) end, [], Ps).
+
+%% pat_vars(Pattern) -> {[UsedVarName],[NewVarName]}.
+%% Return variables in a pattern. All variables are new variables
+%% except those in the size field of binary segments.
+
+pat_vars(#k_var{name=N}) -> {[],[N]};
+%%pat_vars(#k_char{}) -> {[],[]};
+%%pat_vars(#k_string{}) -> {[],[]};
+pat_vars(#k_literal{}) -> {[],[]};
+pat_vars(#k_int{}) -> {[],[]};
+pat_vars(#k_float{}) -> {[],[]};
+pat_vars(#k_atom{}) -> {[],[]};
+pat_vars(#k_nil{}) -> {[],[]};
+pat_vars(#k_cons{hd=H,tl=T}) ->
+ pat_list_vars([H,T]);
+pat_vars(#k_binary{segs=V}) ->
+ pat_vars(V);
+pat_vars(#k_bin_seg{size=Size,seg=S}) ->
+ {U1,New} = pat_list_vars([S]),
+ {[],U2} = pat_vars(Size),
+ {union(U1, U2),New};
+pat_vars(#k_bin_int{size=Size}) ->
+ {[],U} = pat_vars(Size),
+ {U,[]};
+pat_vars(#k_bin_end{}) -> {[],[]};
+pat_vars(#k_tuple{es=Es}) ->
+ pat_list_vars(Es).
+
+pat_list_vars(Ps) ->
+ foldl(fun (P, {Used0,New0}) ->
+ {Used,New} = pat_vars(P),
+ {union(Used0, Used),union(New0, New)} end,
+ {[],[]}, Ps).
+
+%% handle_literal(Literal, Anno) -> Kernel
+%% Examine the literal. Complex (heap-based) literals such as lists,
+%% tuples, and binaries should be kept as literals and put into the constant pool.
+%%
+%% (If necessary, this function could be extended to go through the literal
+%% and convert huge binary literals to bit syntax expressions. We don't do that
+%% because v3_core does not produce huge binary literals, and the optimizations in
+%% sys_core_fold don't do much optimizations of binaries. IF THAT CHANGE IS MADE,
+%% ALSO CHANGE sys_core_dsetel.)
+
+handle_literal(#c_literal{anno=A,val=V}) ->
+ case V of
+ [_|_] ->
+ #k_literal{anno=A,val=V};
+ V when is_tuple(V) ->
+ #k_literal{anno=A,val=V};
+ V when is_bitstring(V) ->
+ #k_literal{anno=A,val=V};
+ _ ->
+ expand_literal(V, A)
+ end.
+
+%% expand_literal(Literal, Anno) -> CoreTerm | KernelTerm
+%% Fully expand the literal. Atomic terms such as integers are directly
+%% translated to the Kernel Erlang format, while complex terms are kept
+%% in the Core Erlang format (but the content is recursively processed).
+
+expand_literal([H|T]=V, A) when is_integer(H), 0 =< H, H =< 255 ->
+ case is_print_char_list(T) of
+ false ->
+ #c_cons{anno=A,hd=#k_int{anno=A,val=H},tl=expand_literal(T, A)};
+ true ->
+ #k_string{anno=A,val=V}
+ end;
+expand_literal([H|T], A) ->
+ #c_cons{anno=A,hd=expand_literal(H, A),tl=expand_literal(T, A)};
+expand_literal([], A) ->
+ #k_nil{anno=A};
+expand_literal(V, A) when is_tuple(V) ->
+ #c_tuple{anno=A,es=expand_literal_list(tuple_to_list(V), A)};
+expand_literal(V, A) when is_integer(V) ->
+ #k_int{anno=A,val=V};
+expand_literal(V, A) when is_float(V) ->
+ #k_float{anno=A,val=V};
+expand_literal(V, A) when is_atom(V) ->
+ #k_atom{anno=A,val=V}.
+
+expand_literal_list([H|T], A) ->
+ [expand_literal(H, A)|expand_literal_list(T, A)];
+expand_literal_list([], _) -> [].
+
+is_print_char_list([H|T]) when is_integer(H), 0 =< H, H =< 255 ->
+ is_print_char_list(T);
+is_print_char_list([]) -> true;
+is_print_char_list(_) -> false.
+
+make_list(Es) ->
+ foldr(fun(E, Acc) ->
+ #c_cons{hd=E,tl=Acc}
+ end, #c_literal{val=[]}, Es).
+
+%% List of integers in interval [N,M]. Empty list if N > M.
+
+integers(N, M) when N =< M ->
+ [N|integers(N + 1, M)];
+integers(_, _) -> [].
+
+%%%
+%%% Handling of errors and warnings.
+%%%
+
+-type error() :: 'bad_call' | 'nomatch_shadow' | {'nomatch_shadow', integer()}.
+
+-spec format_error(error()) -> string().
+
+format_error({nomatch_shadow,Line}) ->
+ M = io_lib:format("this clause cannot match because a previous clause at line ~p "
+ "always matches", [Line]),
+ lists:flatten(M);
+format_error(nomatch_shadow) ->
+ "this clause cannot match because a previous clause always matches";
+format_error(bad_call) ->
+ "invalid module and/or function name; this call will always fail".
+
+add_warning(none, Term, Anno, #kern{ws=Ws}=St) ->
+ File = get_file(Anno),
+ St#kern{ws=[{File,[{?MODULE,Term}]}|Ws]};
+add_warning(Line, Term, Anno, #kern{ws=Ws}=St) when Line >= 0 ->
+ File = get_file(Anno),
+ St#kern{ws=[{File,[{Line,?MODULE,Term}]}|Ws]};
+add_warning(_, _, _, St) -> St.
diff --git a/lib/compiler/src/v3_kernel.hrl b/lib/compiler/src/v3_kernel.hrl
new file mode 100644
index 0000000000..37f2fdcf7e
--- /dev/null
+++ b/lib/compiler/src/v3_kernel.hrl
@@ -0,0 +1,83 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1999-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%
+%%
+
+%% Purpose : Kernel Erlang as records.
+
+%% It would be nice to incorporate some generic functions as well but
+%% this could make including this file difficult.
+%% N.B. the annotation field is ALWAYS the first field!
+
+%% Kernel annotation record.
+-record(k, {us, %Used variables
+ ns, %New variables
+ a}). %Core annotation
+
+%% Literals
+%% NO CHARACTERS YET.
+%%-record(k_char, {anno=[],val}).
+-record(k_literal, {anno=[],val}). %Only used for complex literals.
+-record(k_int, {anno=[],val}).
+-record(k_float, {anno=[],val}).
+-record(k_atom, {anno=[],val}).
+-record(k_string, {anno=[],val}).
+-record(k_nil, {anno=[]}).
+
+-record(k_tuple, {anno=[],es}).
+-record(k_cons, {anno=[],hd,tl}).
+-record(k_binary, {anno=[],segs}).
+-record(k_bin_seg, {anno=[],size,unit,type,flags,seg,next}).
+-record(k_bin_int, {anno=[],size,unit,flags,val,next}).
+-record(k_bin_end, {anno=[]}).
+-record(k_var, {anno=[],name}).
+
+-record(k_local, {anno=[],name,arity}).
+-record(k_remote, {anno=[],mod,name,arity}).
+-record(k_internal, {anno=[],name,arity}).
+
+-record(k_mdef, {anno=[],name,exports,attributes,body}).
+-record(k_fdef, {anno=[],func,arity,vars,body}).
+
+-record(k_seq, {anno=[],arg,body}).
+-record(k_put, {anno=[],arg,ret=[]}).
+-record(k_bif, {anno=[],op,args,ret=[]}).
+-record(k_test, {anno=[],op,args}).
+-record(k_call, {anno=[],op,args,ret=[]}).
+-record(k_enter, {anno=[],op,args}).
+-record(k_receive, {anno=[],var,body,timeout,action,ret=[]}).
+-record(k_receive_accept, {anno=[]}).
+-record(k_receive_next, {anno=[]}).
+-record(k_try, {anno=[],arg,vars,body,evars,handler,ret=[]}).
+-record(k_try_enter, {anno=[],arg,vars,body,evars,handler}).
+-record(k_catch, {anno=[],body,ret=[]}).
+
+-record(k_guard_match, {anno=[],vars,body,ret=[]}).
+-record(k_match, {anno=[],vars,body,ret=[]}).
+-record(k_alt, {anno=[],first,then}).
+-record(k_select, {anno=[],var,types}).
+-record(k_type_clause, {anno=[],type,values}).
+-record(k_val_clause, {anno=[],val,body}).
+-record(k_guard, {anno=[],clauses}).
+-record(k_guard_clause, {anno=[],guard,body}).
+
+-record(k_break, {anno=[],args=[]}).
+-record(k_guard_break, {anno=[],args=[]}).
+-record(k_return, {anno=[],args=[]}).
+
+%%k_get_anno(Thing) -> element(2, Thing).
+%%k_set_anno(Thing, Anno) -> setelement(2, Thing, Anno).
diff --git a/lib/compiler/src/v3_kernel_pp.erl b/lib/compiler/src/v3_kernel_pp.erl
new file mode 100644
index 0000000000..b1ca907d11
--- /dev/null
+++ b/lib/compiler/src/v3_kernel_pp.erl
@@ -0,0 +1,493 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1999-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%
+%%
+%% Purpose : Kernel Erlang (naive) prettyprinter
+
+-module(v3_kernel_pp).
+
+-include("v3_kernel.hrl").
+
+-export([format/1]).
+
+%% These are "internal" structures in sys_kernel which are here for
+%% debugging purposes.
+-record(iset, {anno=[],vars,arg,body}).
+-record(ifun, {anno=[],vars,body}).
+
+%% ====================================================================== %%
+%% format(Node) -> Text
+%% Node = coreErlang()
+%% Text = string() | [Text]
+%%
+%% Prettyprint-formats (naively) an abstract Core Erlang syntax
+%% tree.
+
+-record(ctxt, {indent = 0 :: non_neg_integer(),
+ item_indent = 2 :: non_neg_integer(),
+ body_indent = 2 :: non_neg_integer(),
+ tab_width = 8 :: non_neg_integer()}).
+
+canno(Cthing) -> element(2, Cthing).
+
+-spec format(cerl:cerl()) -> iolist().
+
+format(Node) -> format(Node, #ctxt{}).
+
+format(Node, Ctxt) ->
+ case canno(Node) of
+%% [] ->
+%% format_1(Node, Ctxt);
+%% [L,{file,_}] when is_integer(L) ->
+%% format_1(Node, Ctxt);
+%% #k{a=Anno}=K when Anno =/= [] ->
+%% format(setelement(2, Node, K#k{a=[]}), Ctxt);
+%% List ->
+%% format_anno(List, Ctxt, fun (Ctxt1) ->
+%% format_1(Node, Ctxt1)
+%% end);
+ _ ->
+ format_1(Node, Ctxt)
+ end.
+
+%% format_anno(Anno, Ctxt0, ObjFun) ->
+%% Ctxt1 = ctxt_bump_indent(Ctxt0, 1),
+%% ["( ",
+%% ObjFun(Ctxt0),
+%% nl_indent(Ctxt1),
+%% "-| ",io_lib:write(Anno),
+%% " )"].
+
+
+%% format_1(Kexpr, Context) -> string().
+
+format_1(#k_atom{val=A}, _Ctxt) -> core_atom(A);
+%%format_1(#k_char{val=C}, _Ctxt) -> io_lib:write_char(C);
+format_1(#k_float{val=F}, _Ctxt) -> float_to_list(F);
+format_1(#k_int{val=I}, _Ctxt) -> integer_to_list(I);
+format_1(#k_nil{}, _Ctxt) -> "[]";
+format_1(#k_string{val=S}, _Ctxt) -> io_lib:write_string(S);
+format_1(#k_var{name=V}, _Ctxt) ->
+ if is_atom(V) ->
+ case atom_to_list(V) of
+ [$_|Cs] -> "_X" ++ Cs;
+ [C|_Cs] = L when C >= $A, C =< $Z -> L;
+ Cs -> [$_|Cs]
+ end;
+ is_integer(V) -> [$_|integer_to_list(V)]
+ end;
+format_1(#k_cons{hd=H,tl=T}, Ctxt) ->
+ Txt = ["["|format(H, ctxt_bump_indent(Ctxt, 1))],
+ [Txt|format_list_tail(T, ctxt_bump_indent(Ctxt, width(Txt, Ctxt)))];
+format_1(#k_tuple{es=Es}, Ctxt) ->
+ [${,
+ format_hseq(Es, ",", ctxt_bump_indent(Ctxt, 1), fun format/2),
+ $}
+ ];
+format_1(#k_binary{segs=S}, Ctxt) ->
+ ["#<",format(S, ctxt_bump_indent(Ctxt, 2)),">#"];
+format_1(#k_bin_seg{next=Next}=S, Ctxt) ->
+ [format_bin_seg_1(S, Ctxt),
+ format_bin_seg(Next, ctxt_bump_indent(Ctxt, 2))];
+format_1(#k_bin_int{size=Sz,unit=U,flags=Fs,val=Val,next=Next}, Ctxt) ->
+ S = #k_bin_seg{size=Sz,unit=U,type=integer,flags=Fs,seg=#k_int{val=Val},next=Next},
+ [format_bin_seg_1(S, Ctxt),
+ format_bin_seg(Next, ctxt_bump_indent(Ctxt, 2))];
+format_1(#k_bin_end{}, _Ctxt) -> "#<>#";
+format_1(#k_local{name=N,arity=A}, Ctxt) ->
+ "local " ++ format_fa_pair({N,A}, Ctxt);
+format_1(#k_remote{mod=M,name=N,arity=A}, _Ctxt) ->
+ %% This is for our internal translator.
+ io_lib:format("remote ~s:~s/~w", [format(M),format(N),A]);
+format_1(#k_internal{name=N,arity=A}, Ctxt) ->
+ "internal " ++ format_fa_pair({N,A}, Ctxt);
+format_1(#k_seq{arg=A,body=B}, Ctxt) ->
+ Ctxt1 = ctxt_bump_indent(Ctxt, 2),
+ ["do",
+ nl_indent(Ctxt1),
+ format(A, Ctxt1),
+ nl_indent(Ctxt),
+ "then",
+ nl_indent(Ctxt)
+ | format(B, Ctxt)
+ ];
+format_1(#k_match{vars=Vs,body=Bs,ret=Rs}, Ctxt) ->
+ Ctxt1 = ctxt_bump_indent(Ctxt, Ctxt#ctxt.item_indent),
+ ["match ",
+ format_hseq(Vs, ",", ctxt_bump_indent(Ctxt, 6), fun format/2),
+ nl_indent(Ctxt1),
+ format(Bs, Ctxt1),
+ nl_indent(Ctxt),
+ "end",
+ format_ret(Rs, Ctxt1)
+ ];
+format_1(#k_guard_match{vars=Vs,body=Bs,ret=Rs}, Ctxt) ->
+ Ctxt1 = ctxt_bump_indent(Ctxt, Ctxt#ctxt.item_indent),
+ ["guard_match ",
+ format_hseq(Vs, ",", ctxt_bump_indent(Ctxt, 6), fun format/2),
+ nl_indent(Ctxt1),
+ format(Bs, Ctxt1),
+ nl_indent(Ctxt),
+ "end",
+ format_ret(Rs, Ctxt1)
+ ];
+format_1(#k_alt{first=O,then=T}, Ctxt) ->
+ Ctxt1 = ctxt_bump_indent(Ctxt, Ctxt#ctxt.item_indent),
+ ["alt",
+ nl_indent(Ctxt1),
+ format(O, Ctxt1),
+ nl_indent(Ctxt1),
+ format(T, Ctxt1)];
+format_1(#k_select{var=V,types=Cs}, Ctxt) ->
+ Ctxt1 = ctxt_bump_indent(Ctxt, 2),
+ ["select ",
+ format(V, Ctxt),
+ nl_indent(Ctxt1),
+ format_vseq(Cs, "", "", Ctxt1, fun format/2)
+ ];
+format_1(#k_type_clause{type=T,values=Cs}, Ctxt) ->
+ Ctxt1 = ctxt_bump_indent(Ctxt, Ctxt#ctxt.body_indent),
+ ["type ",
+ io_lib:write(T),
+ nl_indent(Ctxt1),
+ format_vseq(Cs, "", "", Ctxt1, fun format/2)
+ ];
+format_1(#k_val_clause{val=Val,body=B}, Ctxt) ->
+ Ctxt1 = ctxt_bump_indent(Ctxt, Ctxt#ctxt.body_indent),
+ [format(Val, Ctxt),
+ " ->",
+ nl_indent(Ctxt1)
+ | format(B, Ctxt1)
+ ];
+format_1(#k_guard{clauses=Gs}, Ctxt) ->
+ Ctxt1 = ctxt_bump_indent(Ctxt, 5),
+ ["when ",
+ nl_indent(Ctxt1),
+ format_vseq(Gs, "", "", Ctxt1, fun format/2)];
+format_1(#k_guard_clause{guard=G,body=B}, Ctxt) ->
+ Ctxt1 = ctxt_bump_indent(Ctxt, Ctxt#ctxt.body_indent),
+ [format(G, Ctxt),
+ nl_indent(Ctxt),
+ "->",
+ nl_indent(Ctxt1)
+ | format(B, Ctxt1)
+ ];
+format_1(#k_call{op=Op,args=As,ret=Rs}, Ctxt) ->
+ Txt = ["call (",format(Op, ctxt_bump_indent(Ctxt, 6)),$)],
+ Ctxt1 = ctxt_bump_indent(Ctxt, 2),
+ [Txt,format_args(As, Ctxt1),
+ format_ret(Rs, Ctxt1)
+ ];
+format_1(#k_enter{op=Op,args=As}, Ctxt) ->
+ Txt = ["enter (",format(Op, ctxt_bump_indent(Ctxt, 7)),$)],
+ Ctxt1 = ctxt_bump_indent(Ctxt, 2),
+ [Txt,format_args(As, Ctxt1)];
+format_1(#k_bif{op=Op,args=As,ret=Rs}, Ctxt) ->
+ Txt = ["bif (",format(Op, ctxt_bump_indent(Ctxt, 5)),$)],
+ Ctxt1 = ctxt_bump_indent(Ctxt, 2),
+ [Txt,format_args(As, Ctxt1),
+ format_ret(Rs, Ctxt1)
+ ];
+format_1(#k_test{op=Op,args=As}, Ctxt) ->
+ Txt = ["test (",format(Op, ctxt_bump_indent(Ctxt, 6)),$)],
+ Ctxt1 = ctxt_bump_indent(Ctxt, 2),
+ [Txt,format_args(As, Ctxt1)];
+format_1(#k_put{arg=A,ret=Rs}, Ctxt) ->
+ [format(A, Ctxt),
+ format_ret(Rs, ctxt_bump_indent(Ctxt, 1))
+ ];
+format_1(#k_try{arg=A,vars=Vs,body=B,evars=Evs,handler=H}, Ctxt) ->
+ Ctxt1 = ctxt_bump_indent(Ctxt, Ctxt#ctxt.body_indent),
+ ["try",
+ nl_indent(Ctxt1),
+ format(A, Ctxt1),
+ nl_indent(Ctxt),
+ "of ",
+ format_hseq(Vs, ", ", ctxt_bump_indent(Ctxt, 3), fun format/2),
+ nl_indent(Ctxt1),
+ format(B, Ctxt1),
+ nl_indent(Ctxt),
+ "catch ",
+ format_hseq(Evs, ", ", ctxt_bump_indent(Ctxt, 6), fun format/2),
+ nl_indent(Ctxt1),
+ format(H, Ctxt1),
+ nl_indent(Ctxt),
+ "end"
+ ];
+format_1(#k_try_enter{arg=A,vars=Vs,body=B,evars=Evs,handler=H}, Ctxt) ->
+ Ctxt1 = ctxt_bump_indent(Ctxt, Ctxt#ctxt.body_indent),
+ ["try_enter",
+ nl_indent(Ctxt1),
+ format(A, Ctxt1),
+ nl_indent(Ctxt),
+ "of ",
+ format_hseq(Vs, ", ", ctxt_bump_indent(Ctxt, 3), fun format/2),
+ nl_indent(Ctxt1),
+ format(B, Ctxt1),
+ nl_indent(Ctxt),
+ "catch ",
+ format_hseq(Evs, ", ", ctxt_bump_indent(Ctxt, 6), fun format/2),
+ nl_indent(Ctxt1),
+ format(H, Ctxt1),
+ nl_indent(Ctxt),
+ "end"
+ ];
+format_1(#k_catch{body=B,ret=Rs}, Ctxt) ->
+ Ctxt1 = ctxt_bump_indent(Ctxt, Ctxt#ctxt.body_indent),
+ ["catch",
+ nl_indent(Ctxt1),
+ format(B, Ctxt1),
+ nl_indent(Ctxt),
+ "end",
+ format_ret(Rs, Ctxt1)
+ ];
+format_1(#k_receive{var=V,body=B,timeout=T,action=A,ret=Rs}, Ctxt) ->
+ Ctxt1 = ctxt_bump_indent(Ctxt, Ctxt#ctxt.item_indent),
+ ["receive ",
+ format(V, Ctxt),
+ nl_indent(Ctxt1),
+ format(B, Ctxt1),
+ nl_indent(Ctxt),
+ "after ",
+ format(T, ctxt_bump_indent(Ctxt, 6)),
+ " ->",
+ nl_indent(Ctxt1),
+ format(A, Ctxt1),
+ nl_indent(Ctxt),
+ "end",
+ format_ret(Rs, Ctxt1)
+ ];
+format_1(#k_receive_accept{}, _Ctxt) -> "receive_accept";
+format_1(#k_receive_next{}, _Ctxt) -> "receive_next";
+format_1(#k_break{args=As}, Ctxt) ->
+ ["<",
+ format_hseq(As, ",", ctxt_bump_indent(Ctxt, 1), fun format/2),
+ ">"
+ ];
+format_1(#k_guard_break{args=As}, Ctxt) ->
+ [":<",
+ format_hseq(As, ",", ctxt_bump_indent(Ctxt, 1), fun format/2),
+ ">:"
+ ];
+format_1(#k_return{args=As}, Ctxt) ->
+ ["<<",
+ format_hseq(As, ",", ctxt_bump_indent(Ctxt, 1), fun format/2),
+ ">>"
+ ];
+format_1(#k_fdef{func=F,arity=A,vars=Vs,body=B}, Ctxt) ->
+ Ctxt1 = ctxt_bump_indent(Ctxt, Ctxt#ctxt.body_indent),
+ ["fdef ",
+ format_fa_pair({F,A}, ctxt_bump_indent(Ctxt, 5)),
+ format_args(Vs, ctxt_bump_indent(Ctxt, 14)),
+ " =",
+ nl_indent(Ctxt1),
+ format(B, Ctxt1)
+ ];
+format_1(#k_mdef{name=N,exports=Es,attributes=As,body=B}, Ctxt) ->
+ ["module ",
+ format(#k_atom{val=N}, ctxt_bump_indent(Ctxt, 7)),
+ nl_indent(Ctxt),
+ "export [",
+ format_vseq(Es,
+ "", ",",
+ ctxt_bump_indent(Ctxt, 8),
+ fun format_fa_pair/2),
+ "]",
+ nl_indent(Ctxt),
+ "attributes [",
+ format_vseq(As,
+ "", ",",
+ ctxt_bump_indent(Ctxt, 12),
+ fun format_attribute/2),
+ "]",
+ nl_indent(Ctxt),
+ format_vseq(B,
+ "", "",
+ Ctxt,
+ fun format/2),
+ nl_indent(Ctxt)
+ | "end"
+ ];
+%% Internal sys_kernel structures.
+format_1(#iset{vars=Vs,arg=A,body=B}, Ctxt) ->
+ Ctxt1 = ctxt_bump_indent(Ctxt, Ctxt#ctxt.body_indent),
+ ["set <",
+ format_hseq(Vs, ", ", ctxt_bump_indent(Ctxt, 5), fun format/2),
+ "> =",
+ nl_indent(Ctxt1),
+ format(A, Ctxt1),
+ nl_indent(Ctxt),
+ "in "
+ | format(B, ctxt_bump_indent(Ctxt, 2))
+ ];
+format_1(#ifun{vars=Vs,body=B}, Ctxt) ->
+ Ctxt1 = ctxt_bump_indent(Ctxt, Ctxt#ctxt.body_indent),
+ ["fun ",
+ format_args(Vs, ctxt_bump_indent(Ctxt, 4)),
+ " ->",
+ nl_indent(Ctxt1)
+ | format(B, Ctxt1)
+ ];
+format_1(Type, _Ctxt) ->
+ ["** Unsupported type: ",
+ io_lib:write(Type)
+ | " **"
+ ].
+
+%% format_ret([RetVar], Context) -> Txt.
+%% Format the return vars of kexpr.
+
+format_ret(Rs, Ctxt) ->
+ [" >> ",
+ "<",
+ format_hseq(Rs, ",", ctxt_bump_indent(Ctxt, 5), fun format/2),
+ ">"].
+
+%% format_args([Arg], Context) -> Txt.
+%% Format arguments.
+
+format_args(As, Ctxt) ->
+ [$(,format_hseq(As, ", ", ctxt_bump_indent(Ctxt, 1), fun format/2),$)].
+
+%% format_hseq([Thing], Separator, Context, Fun) -> Txt.
+%% Format a sequence horizontally.
+
+format_hseq([H], _Sep, Ctxt, Fun) ->
+ Fun(H, Ctxt);
+format_hseq([H|T], Sep, Ctxt, Fun) ->
+ Txt = [Fun(H, Ctxt)|Sep],
+ Ctxt1 = ctxt_bump_indent(Ctxt, width(Txt, Ctxt)),
+ [Txt|format_hseq(T, Sep, Ctxt1, Fun)];
+format_hseq([], _, _, _) -> "".
+
+%% format_vseq([Thing], LinePrefix, LineSuffix, Context, Fun) -> Txt.
+%% Format a sequence vertically.
+
+format_vseq([H], _Pre, _Suf, Ctxt, Fun) ->
+ Fun(H, Ctxt);
+format_vseq([H|T], Pre, Suf, Ctxt, Fun) ->
+ [Fun(H, Ctxt),Suf,nl_indent(Ctxt),Pre|
+ format_vseq(T, Pre, Suf, Ctxt, Fun)];
+format_vseq([], _, _, _, _) -> "".
+
+format_fa_pair({F,A}, _Ctxt) -> [core_atom(F),$/,integer_to_list(A)].
+
+%% format_attribute({Name,Val}, Context) -> Txt.
+
+format_attribute({Name,Val}, Ctxt) when is_list(Val) ->
+ Txt = format(#k_atom{val=Name}, Ctxt),
+ Ctxt1 = ctxt_bump_indent(Ctxt, width(Txt,Ctxt)+4),
+ [Txt," = ",
+ $[,format_vseq(Val, "", ",", Ctxt1,
+ fun (A, _C) -> io_lib:write(A) end),$]
+ ];
+format_attribute({Name,Val}, Ctxt) ->
+ Txt = format(#k_atom{val=Name}, Ctxt),
+ [Txt," = ",io_lib:write(Val)].
+
+format_list_tail(#k_nil{anno=[]}, _Ctxt) -> "]";
+format_list_tail(#k_cons{anno=[],hd=H,tl=T}, Ctxt) ->
+ Txt = [$,|format(H, Ctxt)],
+ Ctxt1 = ctxt_bump_indent(Ctxt, width(Txt, Ctxt)),
+ [Txt|format_list_tail(T, Ctxt1)];
+format_list_tail(Tail, Ctxt) ->
+ ["|",format(Tail, ctxt_bump_indent(Ctxt, 1)), "]"].
+
+format_bin_seg([], _Ctx) -> "";
+format_bin_seg(#k_bin_end{anno=[]}, _Ctxt) -> "";
+format_bin_seg(#k_bin_seg{anno=[],next=N}=Seg, Ctxt) ->
+ Txt = [$,|format_bin_seg_1(Seg, Ctxt)],
+ [Txt|format_bin_seg(N, ctxt_bump_indent(Ctxt, width(Txt, Ctxt)))];
+format_bin_seg(Seg, Ctxt) ->
+ ["|",format(Seg, ctxt_bump_indent(Ctxt, 2))].
+
+format_bin_seg_1(#k_bin_seg{size=S,unit=U,type=T,flags=Fs,seg=Seg}, Ctxt) ->
+ [format(Seg, Ctxt),
+ ":",format(S, Ctxt),"*",io_lib:write(U),
+ ":",io_lib:write(T),
+ [[$-,io_lib:write(F)] || F <- Fs]
+ ].
+
+% format_bin_elements(#k_binary_cons{hd=H,tl=T,size=S,info=I}, Ctxt) ->
+% A = canno(T),
+% Fe = fun (Eh, Es, Ei, Ct) ->
+% [format(Eh, Ct),":",format(Es, Ct),"/",io_lib:write(Ei)]
+% end,
+% case T of
+% #k_zero_binary{} when A == [] ->
+% Fe(H, S, I, Ctxt);
+% #k_binary_cons{} when A == [] ->
+% Txt = [Fe(H, S, I, Ctxt)|","],
+% Ctxt1 = ctxt_bump_indent(Ctxt, width(Txt, Ctxt)),
+% [Txt|format_bin_elements(T, Ctxt1)];
+% _ ->
+% Txt = [Fe(H, S, I, Ctxt)|"|"],
+% [Txt|format(T, ctxt_bump_indent(Ctxt, width(Txt, Ctxt)))]
+% end.
+
+indent(Ctxt) -> indent(Ctxt#ctxt.indent, Ctxt).
+
+indent(N, _Ctxt) when N =< 0 -> "";
+indent(N, Ctxt) ->
+ T = Ctxt#ctxt.tab_width,
+ string:chars($\t, N div T, string:chars($\s, N rem T)).
+
+nl_indent(Ctxt) -> [$\n|indent(Ctxt)].
+
+
+unindent(T, Ctxt) ->
+ unindent(T, Ctxt#ctxt.indent, Ctxt, []).
+
+unindent(T, N, _Ctxt, C) when N =< 0 ->
+ [T|C];
+unindent([$\s|T], N, Ctxt, C) ->
+ unindent(T, N - 1, Ctxt, C);
+unindent([$\t|T], N, Ctxt, C) ->
+ Tab = Ctxt#ctxt.tab_width,
+ if N >= Tab ->
+ unindent(T, N - Tab, Ctxt, C);
+ true ->
+ unindent([string:chars($\s, Tab - N)|T], 0, Ctxt, C)
+ end;
+unindent([L|T], N, Ctxt, C) when is_list(L) ->
+ unindent(L, N, Ctxt, [T|C]);
+unindent([H|T], _N, _Ctxt, C) ->
+ [H|[T|C]];
+unindent([], N, Ctxt, [H|T]) ->
+ unindent(H, N, Ctxt, T);
+unindent([], _, _, []) -> [].
+
+
+width(Txt, Ctxt) ->
+ width(Txt, 0, Ctxt, []).
+
+width([$\t|T], A, Ctxt, C) ->
+ width(T, A + Ctxt#ctxt.tab_width, Ctxt, C);
+width([$\n|T], _A, Ctxt, C) ->
+ width(unindent([T|C], Ctxt), Ctxt);
+width([H|T], A, Ctxt, C) when is_list(H) ->
+ width(H, A, Ctxt, [T|C]);
+width([_|T], A, Ctxt, C) ->
+ width(T, A + 1, Ctxt, C);
+width([], A, Ctxt, [H|T]) ->
+ width(H, A, Ctxt, T);
+width([], A, _, []) -> A.
+
+ctxt_bump_indent(Ctxt, Dx) ->
+ Ctxt#ctxt{indent=Ctxt#ctxt.indent + Dx}.
+
+core_atom(A) -> io_lib:write_string(atom_to_list(A), $').
diff --git a/lib/compiler/src/v3_life.erl b/lib/compiler/src/v3_life.erl
new file mode 100644
index 0000000000..0adeaca8fa
--- /dev/null
+++ b/lib/compiler/src/v3_life.erl
@@ -0,0 +1,565 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1999-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%
+%%
+%% Purpose : Convert annotated kernel expressions to annotated beam format.
+
+%% This module creates beam format annotated with variable lifetime
+%% information. Each thing is given an index and for each variable we
+%% store the first and last index for its occurrence. The variable
+%% database, VDB, attached to each thing is only relevant internally
+%% for that thing.
+%%
+%% For nested things like matches the numbering continues locally and
+%% the VDB for that thing refers to the variable usage within that
+%% thing. Variables which live through a such a thing are internally
+%% given a very large last index. Internally the indexes continue
+%% after the index of that thing. This creates no problems as the
+%% internal variable info never escapes and externally we only see
+%% variable which are alive both before or after.
+%%
+%% This means that variables never "escape" from a thing and the only
+%% way to get values from a thing is to "return" them, with 'break' or
+%% 'return'. Externally these values become the return values of the
+%% thing. This is no real limitation as most nested things have
+%% multiple threads so working out a common best variable usage is
+%% difficult.
+
+-module(v3_life).
+
+-export([module/2]).
+
+-export([vdb_find/2]).
+
+-import(lists, [member/2,map/2,foldl/3,reverse/1,sort/1]).
+-import(ordsets, [add_element/2,intersection/2,union/2]).
+
+-include("v3_kernel.hrl").
+-include("v3_life.hrl").
+
+%% These are not defined in v3_kernel.hrl.
+get_kanno(Kthing) -> element(2, Kthing).
+%%set_kanno(Kthing, Anno) -> setelement(2, Kthing, Anno).
+
+module(#k_mdef{name=M,exports=Es,attributes=As,body=Fs0}, _Opts) ->
+ Fs1 = functions(Fs0, []),
+ {ok,{M,Es,As,Fs1}}.
+
+functions([F|Fs], Acc) ->
+ functions(Fs, [function(F)|Acc]);
+functions([], Acc) -> reverse(Acc).
+
+%% function(Kfunc) -> Func.
+
+function(#k_fdef{func=F,arity=Ar,vars=Vs,body=Kb}) ->
+ %ok = io:fwrite("life ~w: ~p~n~p~n", [?LINE,{F,Ar},Kb]),
+ As = var_list(Vs),
+ Vdb0 = foldl(fun ({var,N}, Vdb) -> new_var(N, 0, Vdb) end, [], As),
+ %% Force a top-level match!
+ B0 = case Kb of
+ #k_match{} -> Kb;
+ _ ->
+ Ka = get_kanno(Kb),
+ #k_match{anno=#k{us=Ka#k.us,ns=[],a=Ka#k.a},
+ vars=Vs,body=Kb,ret=[]}
+ end,
+ put(guard_refc, 0),
+ {B1,_,Vdb1} = body(B0, 1, Vdb0),
+ erase(guard_refc),
+ {function,F,Ar,As,B1,Vdb1}.
+
+%% body(Kbody, I, Vdb) -> {[Expr],MaxI,Vdb}.
+%% Handle a body, need special cases for transforming match_fails.
+%% We KNOW that they only occur last in a body.
+
+body(#k_seq{arg=#k_put{anno=Pa,arg=Arg,ret=[R]},
+ body=#k_enter{anno=Ea,op=#k_internal{name=match_fail,arity=1},
+ args=[R]}},
+ I, Vdb0) ->
+ Vdb1 = use_vars(Pa#k.us, I, Vdb0), %All used here
+ {[match_fail(Arg, I, Pa#k.a ++ Ea#k.a)],I,Vdb1};
+body(#k_enter{anno=Ea,op=#k_internal{name=match_fail,arity=1},args=[Arg]},
+ I, Vdb0) ->
+ Vdb1 = use_vars(Ea#k.us, I, Vdb0),
+ {[match_fail(Arg, I, Ea#k.a)],I,Vdb1};
+body(#k_seq{arg=Ke,body=Kb}, I, Vdb0) ->
+ %%ok = io:fwrite("life ~w:~p~n", [?LINE,{Ke,I,Vdb0}]),
+ A = get_kanno(Ke),
+ Vdb1 = use_vars(A#k.us, I, new_vars(A#k.ns, I, Vdb0)),
+ {Es,MaxI,Vdb2} = body(Kb, I+1, Vdb1),
+ E = expr(Ke, I, Vdb2),
+ {[E|Es],MaxI,Vdb2};
+body(Ke, I, Vdb0) ->
+ %%ok = io:fwrite("life ~w:~p~n", [?LINE,{Ke,I,Vdb0}]),
+ A = get_kanno(Ke),
+ Vdb1 = use_vars(A#k.us, I, new_vars(A#k.ns, I, Vdb0)),
+ E = expr(Ke, I, Vdb1),
+ {[E],I,Vdb1}.
+
+%% guard(Kguard, I, Vdb) -> Guard.
+
+guard(#k_try{anno=A,arg=Ts,vars=[#k_var{name=X}],body=#k_var{name=X},
+ handler=#k_atom{val=false},ret=Rs}, I, Vdb) ->
+ %% Lock variables that are alive before try and used afterwards.
+ %% Don't lock variables that are only used inside the try expression.
+ Pdb0 = vdb_sub(I, I+1, Vdb),
+ {T,MaxI,Pdb1} = guard_body(Ts, I+1, Pdb0),
+ Pdb2 = use_vars(A#k.ns, MaxI+1, Pdb1), %Save "return" values
+ #l{ke={protected,T,var_list(Rs)},i=I,a=A#k.a,vdb=Pdb2};
+guard(#k_seq{}=G, I, Vdb0) ->
+ {Es,_,Vdb1} = guard_body(G, I, Vdb0),
+ #l{ke={block,Es},i=I,vdb=Vdb1,a=[]};
+guard(G, I, Vdb) -> guard_expr(G, I, Vdb).
+
+%% guard_body(Kbody, I, Vdb) -> {[Expr],MaxI,Vdb}.
+
+guard_body(#k_seq{arg=Ke,body=Kb}, I, Vdb0) ->
+ A = get_kanno(Ke),
+ Vdb1 = use_vars(A#k.us, I, new_vars(A#k.ns, I, Vdb0)),
+ {Es,MaxI,Vdb2} = guard_body(Kb, I+1, Vdb1),
+ E = guard_expr(Ke, I, Vdb2),
+ {[E|Es],MaxI,Vdb2};
+guard_body(Ke, I, Vdb0) ->
+ A = get_kanno(Ke),
+ Vdb1 = use_vars(A#k.us, I, new_vars(A#k.ns, I, Vdb0)),
+ E = guard_expr(Ke, I, Vdb1),
+ {[E],I,Vdb1}.
+
+%% guard_expr(Call, I, Vdb) -> Expr
+
+guard_expr(#k_test{anno=A,op=Op,args=As}, I, _Vdb) ->
+ #l{ke={test,test_op(Op),atomic_list(As)},i=I,a=A#k.a};
+guard_expr(#k_bif{anno=A,op=Op,args=As,ret=Rs}, I, _Vdb) ->
+ Name = bif_op(Op),
+ Ar = length(As),
+ case is_gc_bif(Name, Ar) of
+ false ->
+ #l{ke={bif,Name,atomic_list(As),var_list(Rs)},i=I,a=A#k.a};
+ true ->
+ #l{ke={gc_bif,Name,atomic_list(As),var_list(Rs)},i=I,a=A#k.a}
+ end;
+guard_expr(#k_put{anno=A,arg=Arg,ret=Rs}, I, _Vdb) ->
+ #l{ke={set,var_list(Rs),literal(Arg, [])},i=I,a=A#k.a};
+guard_expr(#k_guard_match{anno=A,body=Kb,ret=Rs}, I, Vdb) ->
+ %% Support for andalso/orelse in guards.
+ %% Work out imported variables which need to be locked.
+ Mdb = vdb_sub(I, I+1, Vdb),
+ M = match(Kb, A#k.us, I+1, [], Mdb),
+ #l{ke={guard_match,M,var_list(Rs)},i=I,vdb=use_vars(A#k.us, I+1, Mdb),a=A#k.a};
+guard_expr(G, I, Vdb) -> guard(G, I, Vdb).
+
+%% expr(Kexpr, I, Vdb) -> Expr.
+
+expr(#k_call{anno=A,op=Op,args=As,ret=Rs}, I, _Vdb) ->
+ #l{ke={call,call_op(Op),atomic_list(As),var_list(Rs)},i=I,a=A#k.a};
+expr(#k_enter{anno=A,op=Op,args=As}, I, _Vdb) ->
+ #l{ke={enter,call_op(Op),atomic_list(As)},i=I,a=A#k.a};
+expr(#k_bif{anno=A,op=Op,args=As,ret=Rs}, I, _Vdb) ->
+ Bif = k_bif(A, Op, As, Rs),
+ #l{ke=Bif,i=I,a=A#k.a};
+expr(#k_match{anno=A,body=Kb,ret=Rs}, I, Vdb) ->
+ %% Work out imported variables which need to be locked.
+ Mdb = vdb_sub(I, I+1, Vdb),
+ M = match(Kb, A#k.us, I+1, [], Mdb),
+ #l{ke={match,M,var_list(Rs)},i=I,vdb=use_vars(A#k.us, I+1, Mdb),a=A#k.a};
+expr(#k_guard_match{anno=A,body=Kb,ret=Rs}, I, Vdb) ->
+ %% Work out imported variables which need to be locked.
+ Mdb = vdb_sub(I, I+1, Vdb),
+ M = match(Kb, A#k.us, I+1, [], Mdb),
+ #l{ke={guard_match,M,var_list(Rs)},i=I,vdb=use_vars(A#k.us, I+1, Mdb),a=A#k.a};
+expr(#k_try{anno=A,arg=Ka,vars=Vs,body=Kb,evars=Evs,handler=Kh,ret=Rs}, I, Vdb) ->
+ %% Lock variables that are alive before the catch and used afterwards.
+ %% Don't lock variables that are only used inside the try.
+ Tdb0 = vdb_sub(I, I+1, Vdb),
+ %% This is the tricky bit. Lock variables in Arg that are used in
+ %% the body and handler. Add try tag 'variable'.
+ Ab = get_kanno(Kb),
+ Ah = get_kanno(Kh),
+ Tdb1 = use_vars(Ab#k.us, I+3, use_vars(Ah#k.us, I+3, Tdb0)),
+ Tdb2 = vdb_sub(I, I+2, Tdb1),
+ Vnames = fun (Kvar) -> Kvar#k_var.name end, %Get the variable names
+ {Aes,_,Adb} = body(Ka, I+2, add_var({catch_tag,I+1}, I+1, locked, Tdb2)),
+ {Bes,_,Bdb} = body(Kb, I+4, new_vars(map(Vnames, Vs), I+3, Tdb2)),
+ {Hes,_,Hdb} = body(Kh, I+4, new_vars(map(Vnames, Evs), I+3, Tdb2)),
+ #l{ke={'try',#l{ke={block,Aes},i=I+1,vdb=Adb,a=[]},
+ var_list(Vs),#l{ke={block,Bes},i=I+3,vdb=Bdb,a=[]},
+ var_list(Evs),#l{ke={block,Hes},i=I+3,vdb=Hdb,a=[]},
+ var_list(Rs)},
+ i=I,vdb=Tdb1,a=A#k.a};
+expr(#k_try_enter{anno=A,arg=Ka,vars=Vs,body=Kb,evars=Evs,handler=Kh}, I, Vdb) ->
+ %% Lock variables that are alive before the catch and used afterwards.
+ %% Don't lock variables that are only used inside the try.
+ Tdb0 = vdb_sub(I, I+1, Vdb),
+ %% This is the tricky bit. Lock variables in Arg that are used in
+ %% the body and handler. Add try tag 'variable'.
+ Ab = get_kanno(Kb),
+ Ah = get_kanno(Kh),
+ Tdb1 = use_vars(Ab#k.us, I+3, use_vars(Ah#k.us, I+3, Tdb0)),
+ Tdb2 = vdb_sub(I, I+2, Tdb1),
+ Vnames = fun (Kvar) -> Kvar#k_var.name end, %Get the variable names
+ {Aes,_,Adb} = body(Ka, I+2, add_var({catch_tag,I+1}, I+1, 1000000, Tdb2)),
+ {Bes,_,Bdb} = body(Kb, I+4, new_vars(map(Vnames, Vs), I+3, Tdb2)),
+ {Hes,_,Hdb} = body(Kh, I+4, new_vars(map(Vnames, Evs), I+3, Tdb2)),
+ #l{ke={try_enter,#l{ke={block,Aes},i=I+1,vdb=Adb,a=[]},
+ var_list(Vs),#l{ke={block,Bes},i=I+3,vdb=Bdb,a=[]},
+ var_list(Evs),#l{ke={block,Hes},i=I+3,vdb=Hdb,a=[]}},
+ i=I,vdb=Tdb1,a=A#k.a};
+expr(#k_catch{anno=A,body=Kb,ret=[R]}, I, Vdb) ->
+ %% Lock variables that are alive before the catch and used afterwards.
+ %% Don't lock variables that are only used inside the catch.
+ %% Add catch tag 'variable'.
+ Cdb0 = vdb_sub(I, I+1, Vdb),
+ {Es,_,Cdb1} = body(Kb, I+1, add_var({catch_tag,I}, I, locked, Cdb0)),
+ #l{ke={'catch',Es,variable(R)},i=I,vdb=Cdb1,a=A#k.a};
+expr(#k_receive{anno=A,var=V,body=Kb,timeout=T,action=Ka,ret=Rs}, I, Vdb) ->
+ %% Work out imported variables which need to be locked.
+ Rdb = vdb_sub(I, I+1, Vdb),
+ M = match(Kb, add_element(V#k_var.name, A#k.us), I+1, [],
+ new_var(V#k_var.name, I, Rdb)),
+ {Tes,_,Adb} = body(Ka, I+1, Rdb),
+ #l{ke={receive_loop,atomic(T),variable(V),M,
+ #l{ke=Tes,i=I+1,vdb=Adb,a=[]},var_list(Rs)},
+ i=I,vdb=use_vars(A#k.us, I+1, Vdb),a=A#k.a};
+expr(#k_receive_accept{anno=A}, I, _Vdb) ->
+ #l{ke=receive_accept,i=I,a=A#k.a};
+expr(#k_receive_next{anno=A}, I, _Vdb) ->
+ #l{ke=receive_next,i=I,a=A#k.a};
+expr(#k_put{anno=A,arg=Arg,ret=Rs}, I, _Vdb) ->
+ #l{ke={set,var_list(Rs),literal(Arg, [])},i=I,a=A#k.a};
+expr(#k_break{anno=A,args=As}, I, _Vdb) ->
+ #l{ke={break,atomic_list(As)},i=I,a=A#k.a};
+expr(#k_guard_break{anno=A,args=As}, I, Vdb) ->
+ Locked = [V || {V,_,_} <- Vdb],
+ #l{ke={guard_break,atomic_list(As),Locked},i=I,a=A#k.a};
+expr(#k_return{anno=A,args=As}, I, _Vdb) ->
+ #l{ke={return,atomic_list(As)},i=I,a=A#k.a}.
+
+%% call_op(Op) -> Op.
+%% bif_op(Op) -> Op.
+%% test_op(Op) -> Op.
+%% Do any necessary name translations here to munge into beam format.
+
+call_op(#k_local{name=N}) -> N;
+call_op(#k_remote{mod=M,name=N}) -> {remote,atomic(M),atomic(N)};
+call_op(Other) -> variable(Other).
+
+bif_op(#k_remote{mod=#k_atom{val=erlang},name=#k_atom{val=N}}) -> N;
+bif_op(#k_internal{name=N}) -> N.
+
+test_op(#k_remote{mod=#k_atom{val=erlang},name=#k_atom{val=N}}) -> N.
+
+%% k_bif(Anno, Op, [Arg], [Ret], Vdb) -> Expr.
+%% Build bifs, do special handling of internal some calls.
+
+k_bif(_A, #k_internal{name=dsetelement,arity=3}, As, []) ->
+ {bif,dsetelement,atomic_list(As),[]};
+k_bif(_A, #k_internal{name=bs_context_to_binary=Op,arity=1}, As, []) ->
+ {bif,Op,atomic_list(As),[]};
+k_bif(_A, #k_internal{name=bs_init_writable=Op,arity=1}, As, Rs) ->
+ {bif,Op,atomic_list(As),var_list(Rs)};
+k_bif(_A, #k_internal{name=make_fun},
+ [#k_atom{val=Fun},#k_int{val=Arity},
+ #k_int{val=Index},#k_int{val=Uniq}|Free],
+ Rs) ->
+ {bif,{make_fun,Fun,Arity,Index,Uniq},var_list(Free),var_list(Rs)};
+k_bif(_A, Op, As, Rs) ->
+ %% The general case.
+ Name = bif_op(Op),
+ Ar = length(As),
+ case is_gc_bif(Name, Ar) of
+ false ->
+ {bif,Name,atomic_list(As),var_list(Rs)};
+ true ->
+ {gc_bif,Name,atomic_list(As),var_list(Rs)}
+ end.
+
+%% match(Kexpr, [LockVar], I, Vdb) -> Expr.
+%% Convert match tree to old format.
+
+match(#k_alt{anno=A,first=Kf,then=Kt}, Ls, I, Ctxt, Vdb0) ->
+ Vdb1 = use_vars(union(A#k.us, Ls), I, Vdb0),
+ F = match(Kf, Ls, I+1, Ctxt, Vdb1),
+ T = match(Kt, Ls, I+1, Ctxt, Vdb1),
+ #l{ke={alt,F,T},i=I,vdb=Vdb1,a=A#k.a};
+match(#k_select{anno=A,var=V,types=Kts}, Ls0, I, Ctxt, Vdb0) ->
+ Vanno = get_kanno(V),
+ Ls1 = case member(no_usage, Vanno) of
+ false -> add_element(V#k_var.name, Ls0);
+ true -> Ls0
+ end,
+ Anno = case member(reuse_for_context, Vanno) of
+ true -> [reuse_for_context|A#k.a];
+ false -> A#k.a
+ end,
+ Vdb1 = use_vars(union(A#k.us, Ls1), I, Vdb0),
+ Ts = [type_clause(Tc, Ls1, I+1, Ctxt, Vdb1) || Tc <- Kts],
+ #l{ke={select,literal2(V, Ctxt),Ts},i=I,vdb=Vdb1,a=Anno};
+match(#k_guard{anno=A,clauses=Kcs}, Ls, I, Ctxt, Vdb0) ->
+ Vdb1 = use_vars(union(A#k.us, Ls), I, Vdb0),
+ Cs = [guard_clause(G, Ls, I+1, Ctxt, Vdb1) || G <- Kcs],
+ #l{ke={guard,Cs},i=I,vdb=Vdb1,a=A#k.a};
+match(Other, Ls, I, _Ctxt, Vdb0) ->
+ Vdb1 = use_vars(Ls, I, Vdb0),
+ {B,_,Vdb2} = body(Other, I+1, Vdb1),
+ #l{ke={block,B},i=I,vdb=Vdb2,a=[]}.
+
+type_clause(#k_type_clause{anno=A,type=T,values=Kvs}, Ls, I, Ctxt, Vdb0) ->
+ %%ok = io:format("life ~w: ~p~n", [?LINE,{T,Kvs}]),
+ Vdb1 = use_vars(union(A#k.us, Ls), I+1, Vdb0),
+ Vs = [val_clause(Vc, Ls, I+1, Ctxt, Vdb1) || Vc <- Kvs],
+ #l{ke={type_clause,type(T),Vs},i=I,vdb=Vdb1,a=A#k.a}.
+
+val_clause(#k_val_clause{anno=A,val=V,body=Kb}, Ls0, I, Ctxt0, Vdb0) ->
+ New = (get_kanno(V))#k.ns,
+ Bus = (get_kanno(Kb))#k.us,
+ %%ok = io:format("Ls0 = ~p, Used=~p\n New=~p, Bus=~p\n", [Ls0,Used,New,Bus]),
+ Ls1 = union(intersection(New, Bus), Ls0), %Lock for safety
+ Vdb1 = use_vars(union(A#k.us, Ls1), I+1, new_vars(New, I, Vdb0)),
+ Ctxt = case V of
+ #k_binary{segs=#k_var{name=C0}} -> C0;
+ _ -> Ctxt0
+ end,
+ B = match(Kb, Ls1, I+1, Ctxt, Vdb1),
+ #l{ke={val_clause,literal2(V, Ctxt),B},i=I,vdb=use_vars(Bus, I+1, Vdb1),a=A#k.a}.
+
+guard_clause(#k_guard_clause{anno=A,guard=Kg,body=Kb}, Ls, I, Ctxt, Vdb0) ->
+ Vdb1 = use_vars(union(A#k.us, Ls), I+2, Vdb0),
+ Gdb = vdb_sub(I+1, I+2, Vdb1),
+ OldRefc = put(guard_refc, get(guard_refc)+1),
+ G = guard(Kg, I+1, Gdb),
+ put(guard_refc, OldRefc),
+ B = match(Kb, Ls, I+2, Ctxt, Vdb1),
+ #l{ke={guard_clause,G,B},
+ i=I,vdb=use_vars((get_kanno(Kg))#k.us, I+2, Vdb1),
+ a=A#k.a}.
+
+%% match_fail(FailValue, I, Anno) -> Expr.
+%% Generate the correct match_fail instruction. N.B. there is no
+%% generic case for when the fail value has been created elsewhere.
+
+match_fail(#k_literal{anno=Anno,val={Atom,Val}}, I, A) when is_atom(Atom) ->
+ match_fail(#k_tuple{anno=Anno,es=[#k_atom{val=Atom},#k_literal{val=Val}]}, I, A);
+match_fail(#k_literal{anno=Anno,val={Atom}}, I, A) when is_atom(Atom) ->
+ match_fail(#k_tuple{anno=Anno,es=[#k_atom{val=Atom}]}, I, A);
+match_fail(#k_literal{anno=Anno,val=Atom}, I, A) when is_atom(Atom) ->
+ match_fail(#k_atom{anno=Anno,val=Atom}, I, A);
+match_fail(#k_tuple{es=[#k_atom{val=function_clause}|As]}, I, A) ->
+ #l{ke={match_fail,{function_clause,literal_list(As, [])}},i=I,a=A};
+match_fail(#k_tuple{es=[#k_atom{val=badmatch},Val]}, I, A) ->
+ #l{ke={match_fail,{badmatch,literal(Val, [])}},i=I,a=A};
+match_fail(#k_tuple{es=[#k_atom{val=case_clause},Val]}, I, A) ->
+ #l{ke={match_fail,{case_clause,literal(Val, [])}},i=I,a=A};
+match_fail(#k_atom{val=if_clause}, I, A) ->
+ #l{ke={match_fail,if_clause},i=I,a=A};
+match_fail(#k_tuple{es=[#k_atom{val=try_clause},Val]}, I, A) ->
+ #l{ke={match_fail,{try_clause,literal(Val, [])}},i=I,a=A}.
+
+%% type(Ktype) -> Type.
+
+type(k_literal) -> literal;
+type(k_int) -> integer;
+%%type(k_char) -> integer; %Hhhmmm???
+type(k_float) -> float;
+type(k_atom) -> atom;
+type(k_nil) -> nil;
+type(k_cons) -> cons;
+type(k_tuple) -> tuple;
+type(k_binary) -> binary;
+type(k_bin_seg) -> bin_seg;
+type(k_bin_int) -> bin_int;
+type(k_bin_end) -> bin_end.
+
+%% variable(Klit) -> Lit.
+%% var_list([Klit]) -> [Lit].
+
+variable(#k_var{name=N}) -> {var,N}.
+
+var_list(Ks) -> [variable(K) || K <- Ks].
+
+%% atomic(Klit) -> Lit.
+%% atomic_list([Klit]) -> [Lit].
+
+atomic(#k_literal{val=V}) -> {literal,V};
+atomic(#k_var{name=N}) -> {var,N};
+atomic(#k_int{val=I}) -> {integer,I};
+atomic(#k_float{val=F}) -> {float,F};
+atomic(#k_atom{val=N}) -> {atom,N};
+%%atomic(#k_char{val=C}) -> {char,C};
+%%atomic(#k_string{val=S}) -> {string,S};
+atomic(#k_nil{}) -> nil.
+
+atomic_list(Ks) -> [atomic(K) || K <- Ks].
+
+%% literal(Klit) -> Lit.
+%% literal_list([Klit]) -> [Lit].
+
+literal(#k_var{name=N}, _) -> {var,N};
+literal(#k_int{val=I}, _) -> {integer,I};
+literal(#k_float{val=F}, _) -> {float,F};
+literal(#k_atom{val=N}, _) -> {atom,N};
+%%literal(#k_char{val=C}, _) -> {char,C};
+literal(#k_string{val=S}, _) -> {string,S};
+literal(#k_nil{}, _) -> nil;
+literal(#k_cons{hd=H,tl=T}, Ctxt) ->
+ {cons,[literal(H, Ctxt),literal(T, Ctxt)]};
+literal(#k_binary{segs=V}, Ctxt) ->
+ {binary,literal(V, Ctxt)};
+literal(#k_bin_seg{size=S,unit=U,type=T,flags=Fs,seg=Seg,next=N}, Ctxt) ->
+ {bin_seg,Ctxt,literal(S, Ctxt),U,T,Fs,
+ [literal(Seg, Ctxt),literal(N, Ctxt)]};
+literal(#k_bin_end{}, Ctxt) ->
+ {bin_end,Ctxt};
+literal(#k_tuple{es=Es}, Ctxt) ->
+ {tuple,literal_list(Es, Ctxt)};
+literal(#k_literal{val=V}, _Ctxt) ->
+ {literal,V}.
+
+literal_list(Ks, Ctxt) ->
+ [literal(K, Ctxt) || K <- Ks].
+
+literal2(#k_var{name=N}, _) -> {var,N};
+literal2(#k_literal{val=I}, _) -> {literal,I};
+literal2(#k_int{val=I}, _) -> {integer,I};
+literal2(#k_float{val=F}, _) -> {float,F};
+literal2(#k_atom{val=N}, _) -> {atom,N};
+%%literal2(#k_char{val=C}, _) -> {char,C};
+literal2(#k_string{val=S}, _) -> {string,S};
+literal2(#k_nil{}, _) -> nil;
+literal2(#k_cons{hd=H,tl=T}, Ctxt) ->
+ {cons,[literal2(H, Ctxt),literal2(T, Ctxt)]};
+literal2(#k_binary{segs=V}, Ctxt) ->
+ {binary,literal2(V, Ctxt)};
+literal2(#k_bin_seg{size=S,unit=U,type=T,flags=Fs,seg=Seg,next=[]}, Ctxt) ->
+ {bin_seg,Ctxt,literal2(S, Ctxt),U,T,Fs,[literal2(Seg, Ctxt)]};
+literal2(#k_bin_seg{size=S,unit=U,type=T,flags=Fs,seg=Seg,next=N}, Ctxt) ->
+ {bin_seg,Ctxt,literal2(S, Ctxt),U,T,Fs,
+ [literal2(Seg, Ctxt),literal2(N, Ctxt)]};
+literal2(#k_bin_int{size=S,unit=U,flags=Fs,val=Int,next=N}, Ctxt) ->
+ {bin_int,Ctxt,literal2(S, Ctxt),U,Fs,Int,
+ [literal2(N, Ctxt)]};
+literal2(#k_bin_end{}, Ctxt) ->
+ {bin_end,Ctxt};
+literal2(#k_tuple{es=Es}, Ctxt) ->
+ {tuple,literal_list2(Es, Ctxt)}.
+
+literal_list2(Ks, Ctxt) ->
+ [literal2(K, Ctxt) || K <- Ks].
+
+%% literal_bin(#k_bin_seg{size=S,unit=U,type=T,flags=Fs,seg=Seg,next=N}) ->
+%% {bin_seg,literal(S),U,T,Fs,[literal(Seg),literal(N)]}
+
+
+%% is_gc_bif(Name, Arity) -> true|false
+%% Determines whether the BIF Name/Arity might do a GC.
+
+is_gc_bif(hd, 1) -> false;
+is_gc_bif(tl, 1) -> false;
+is_gc_bif(self, 0) -> false;
+is_gc_bif(node, 0) -> false;
+is_gc_bif(node, 1) -> false;
+is_gc_bif(element, 2) -> false;
+is_gc_bif(get, 1) -> false;
+is_gc_bif(raise, 2) -> false;
+is_gc_bif(tuple_size, 1) -> false;
+is_gc_bif(Bif, Arity) ->
+ not (erl_internal:bool_op(Bif, Arity) orelse
+ erl_internal:new_type_test(Bif, Arity) orelse
+ erl_internal:comp_op(Bif, Arity)).
+
+%% new_var(VarName, I, Vdb) -> Vdb.
+%% new_vars([VarName], I, Vdb) -> Vdb.
+%% use_var(VarName, I, Vdb) -> Vdb.
+%% use_vars([VarName], I, Vdb) -> Vdb.
+%% add_var(VarName, F, L, Vdb) -> Vdb.
+
+new_var(V, I, Vdb) ->
+ vdb_store_new(V, I, I, Vdb).
+
+new_vars(Vs, I, Vdb0) ->
+ foldl(fun (V, Vdb) -> new_var(V, I, Vdb) end, Vdb0, Vs).
+
+use_var(V, I, Vdb) ->
+ case vdb_find(V, Vdb) of
+ {V,F,L} when I > L -> vdb_update(V, F, I, Vdb);
+ {V,_,_} -> Vdb;
+ error -> vdb_store_new(V, I, I, Vdb)
+ end.
+
+use_vars([], _, Vdb) -> Vdb;
+use_vars([V], I, Vdb) -> use_var(V, I, Vdb);
+use_vars(Vs, I, Vdb) ->
+ Res = use_vars_1(sort(Vs), Vdb, I),
+ %% The following line can be used as an assertion.
+ %% Res = foldl(fun (V, Vdb) -> use_var(V, I, Vdb) end, Vdb, Vs),
+ Res.
+
+%% Measurements show that it is worthwhile having this special
+%% function that updates/inserts several variables at once.
+
+use_vars_1([V|_]=Vs, [{V1,_,_}=Vd|Vdb], I) when V > V1 ->
+ [Vd|use_vars_1(Vs, Vdb, I)];
+use_vars_1([V|Vs], [{V1,_,_}|_]=Vdb, I) when V < V1 ->
+ %% New variable.
+ [{V,I,I}|use_vars_1(Vs, Vdb, I)];
+use_vars_1([V|Vs], [{_,F,L}=Vd|Vdb], I) ->
+ %% Existing variable.
+ if
+ I > L ->[{V,F,I}|use_vars_1(Vs, Vdb, I)];
+ true -> [Vd|use_vars_1(Vs, Vdb, I)]
+ end;
+use_vars_1([V|Vs], [], I) ->
+ %% New variable.
+ [{V,I,I}|use_vars_1(Vs, [], I)];
+use_vars_1([], Vdb, _) -> Vdb.
+
+add_var(V, F, L, Vdb) ->
+ vdb_store_new(V, F, L, Vdb).
+
+vdb_find(V, Vdb) ->
+ %% Performance note: Profiling shows that this function accounts for
+ %% a lot of the execution time when huge constant terms are built.
+ %% Using the BIF lists:keyfind/3 is a lot faster than the
+ %% original Erlang version.
+ case lists:keyfind(V, 1, Vdb) of
+ false -> error;
+ Vd -> Vd
+ end.
+
+%vdb_find(V, [{V1,F,L}=Vd|Vdb]) when V < V1 -> error;
+%vdb_find(V, [{V1,F,L}=Vd|Vdb]) when V == V1 -> Vd;
+%vdb_find(V, [{V1,F,L}=Vd|Vdb]) when V > V1 -> vdb_find(V, Vdb);
+%vdb_find(V, []) -> error.
+
+vdb_update(V, F, L, [{V1,_,_}=Vd|Vdb]) when V > V1 ->
+ [Vd|vdb_update(V, F, L, Vdb)];
+vdb_update(V, F, L, [{V1,_,_}|Vdb]) when V == V1 ->
+ [{V,F,L}|Vdb].
+
+vdb_store_new(V, F, L, [{V1,_,_}=Vd|Vdb]) when V > V1 ->
+ [Vd|vdb_store_new(V, F, L, Vdb)];
+vdb_store_new(V, F, L, [{V1,_,_}|_]=Vdb) when V < V1 -> [{V,F,L}|Vdb];
+vdb_store_new(V, F, L, []) -> [{V,F,L}].
+
+%% vdb_sub(Min, Max, Vdb) -> Vdb.
+%% Extract variables which are used before and after Min. Lock
+%% variables alive after Max.
+
+vdb_sub(Min, Max, Vdb) ->
+ [ if L >= Max -> {V,F,locked};
+ true -> Vd
+ end || {V,F,L}=Vd <- Vdb, F < Min, L >= Min ].
+
diff --git a/lib/compiler/src/v3_life.hrl b/lib/compiler/src/v3_life.hrl
new file mode 100644
index 0000000000..541e4cf66d
--- /dev/null
+++ b/lib/compiler/src/v3_life.hrl
@@ -0,0 +1,26 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 1999-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%
+%%
+%% This record contains variable life-time annotation for a
+%% kernel expression. Added by v3_life, used by v3_codegen.
+
+-record(l, {ke, %Kernel expression
+ i=0, %Op number
+ vdb=[], %Variable database
+ a}). %Core annotation
+