diff options
Diffstat (limited to 'lib/compiler')
208 files changed, 61825 insertions, 0 deletions
diff --git a/lib/compiler/AUTHORS b/lib/compiler/AUTHORS new file mode 100644 index 0000000000..c40e02dc4c --- /dev/null +++ b/lib/compiler/AUTHORS @@ -0,0 +1,44 @@ +The original JAM compiler was first implemented by Joe Armstrong. + +The original BEAM compiler (v1) was first implemented by Bogumil Hausman. + +The original v2 and v3 compilers were implemented by Robert Virding. +Bj�rn Gustavsson adapted the code generation for the BEAM machine and +added the optimisation passes. + +General improvements and corrections were made by Robert Virding, +Arndt Jonasson, Tony Rogvall, Bj�rn Gustavsson and Jan-Erik Dahlin. + +The bit syntax support was implemented by Bj�rn Gustavsson, Arndt Jonasson +and Robert Virding. + +The Core Erlang is used as an intermediate format in the v3 compiler (R7). +Core Erlang was suggested by Richard Carlsson (HiPE). + +The new inliner in R8 is written by Richard Carlsson (HiPE). + +Updates, extensions, and bugfixes in the R8 compiler were made by Robert Virding, +Richard Carlsson (HiPE), and Bj�rn Gustavsson. + +Bjorn Gustavsson and Raimo Niskanen implemented the beam_validator compiler +pass for R10B-2 (it makes that the compiler did not generate code that could +crash the run-time system). + +The current maintainer of the compiler is Bjorn Gustavsson. To the R12B he +added a simple form of stack trimming, as well as other optimizations. + +Original Authors and Contributors: + +Joe Armstrong +Bogumil Hausman +Robert Virding +Bj�rn Gustavsson +Arndt Jonasson +Tony Rogvall +Jan-Erik Dahlin +Richard Carlsson +Raimo Niskanen + +Open Source Contributors: + +Robert Virding diff --git a/lib/compiler/Makefile b/lib/compiler/Makefile new file mode 100644 index 0000000000..1ad883b014 --- /dev/null +++ b/lib/compiler/Makefile @@ -0,0 +1,37 @@ +# +# %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% +# +include $(ERL_TOP)/make/target.mk +include $(ERL_TOP)/make/$(TARGET)/otp.mk + +# +# Macros +# + +SUB_DIRECTORIES = src doc/src + +include vsn.mk +VSN = $(COMPILER_VSN) + +SPECIAL_TARGETS = + +# +# Default Subdir Targets +# +include $(ERL_TOP)/make/otp_subdir.mk + diff --git a/lib/compiler/doc/html/.gitignore b/lib/compiler/doc/html/.gitignore new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/lib/compiler/doc/html/.gitignore diff --git a/lib/compiler/doc/man3/.gitignore b/lib/compiler/doc/man3/.gitignore new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/lib/compiler/doc/man3/.gitignore diff --git a/lib/compiler/doc/pdf/.gitignore b/lib/compiler/doc/pdf/.gitignore new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/lib/compiler/doc/pdf/.gitignore diff --git a/lib/compiler/doc/src/Makefile b/lib/compiler/doc/src/Makefile new file mode 100644 index 0000000000..ee41a7074f --- /dev/null +++ b/lib/compiler/doc/src/Makefile @@ -0,0 +1,112 @@ +# +# %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% +# +include $(ERL_TOP)/make/target.mk +include $(ERL_TOP)/make/$(TARGET)/otp.mk + +# ---------------------------------------------------- +# Application version +# ---------------------------------------------------- +include ../../vsn.mk +VSN=$(COMPILER_VSN) +APPLICATION=compiler + +# ---------------------------------------------------- +# Release directory specification +# ---------------------------------------------------- +RELSYSDIR = $(RELEASE_PATH)/lib/$(APPLICATION)-$(VSN) + +# ---------------------------------------------------- +# Target Specs +# ---------------------------------------------------- +XML_APPLICATION_FILES = ref_man.xml +XML_REF3_FILES = compile.xml + +XML_PART_FILES = part_notes.xml part_notes_history.xml +XML_CHAPTER_FILES = notes.xml notes_history.xml + +BOOK_FILES = book.xml + +GIF_FILES = \ + warning.gif + +XML_FILES = \ + $(BOOK_FILES) $(XML_CHAPTER_FILES) \ + $(XML_PART_FILES) $(XML_REF3_FILES) $(XML_APPLICATION_FILES) + +# ---------------------------------------------------- + +HTML_FILES = $(XML_APPLICATION_FILES:%.xml=$(HTMLDIR)/%.html) \ + $(XML_PART_FILES:%.xml=$(HTMLDIR)/%.html) + +INFO_FILE = ../../info + +MAN3_FILES = $(XML_REF3_FILES:%.xml=$(MAN3DIR)/%.3) + +HTML_REF_MAN_FILE = $(HTMLDIR)/index.html + +TOP_PDF_FILE = $(PDFDIR)/$(APPLICATION)-$(VSN).pdf + +# ---------------------------------------------------- +# FLAGS +# ---------------------------------------------------- +XML_FLAGS += + +# ---------------------------------------------------- +# Targets +# ---------------------------------------------------- +$(HTMLDIR)/%.gif: %.gif + $(INSTALL_DATA) $< $@ + +docs: pdf html man + +$(TOP_PDF_FILE): $(XML_FILES) + +pdf: $(TOP_PDF_FILE) + +html: gifs $(HTML_REF_MAN_FILE) + +man: $(MAN3_FILES) + +gifs: $(GIF_FILES:%=$(HTMLDIR)/%) + +debug opt: + +clean clean_docs: + rm -rf $(HTMLDIR)/* + rm -f $(MAN3DIR)/* + rm -f $(TOP_PDF_FILE) $(TOP_PDF_FILE:%.pdf=%.fo) + rm -f errs core *~ + +# ---------------------------------------------------- +# Release Target +# ---------------------------------------------------- +include $(ERL_TOP)/make/otp_release_targets.mk + +release_docs_spec: docs + $(INSTALL_DIR) $(RELSYSDIR)/doc/pdf + $(INSTALL_DATA) $(TOP_PDF_FILE) $(RELSYSDIR)/doc/pdf + $(INSTALL_DIR) $(RELSYSDIR)/doc/html + $(INSTALL_DATA) $(HTMLDIR)/* \ + $(RELSYSDIR)/doc/html + $(INSTALL_DATA) $(INFO_FILE) $(RELSYSDIR) + $(INSTALL_DIR) $(RELEASE_PATH)/man/man3 + $(INSTALL_DATA) $(MAN3DIR)/* $(RELEASE_PATH)/man/man3 + +release_spec: + diff --git a/lib/compiler/doc/src/book.xml b/lib/compiler/doc/src/book.xml new file mode 100644 index 0000000000..fc56a837d5 --- /dev/null +++ b/lib/compiler/doc/src/book.xml @@ -0,0 +1,46 @@ +<?xml version="1.0" encoding="latin1" ?> +<!DOCTYPE book SYSTEM "book.dtd"> + +<book xmlns:xi="http://www.w3.org/2001/XInclude"> + <header titlestyle="normal"> + <copyright> + <year>1997</year><year>2009</year> + <holder>Ericsson AB. All Rights Reserved.</holder> + </copyright> + <legalnotice> + 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. + + </legalnotice> + + <title>Compiler</title> + <prepared>Robert Virding</prepared> + <docno></docno> + <date>1997-05-02</date> + <rev>1.1.2</rev> + <file>book.sgml</file> + </header> + <insidecover> + </insidecover> + <pagetext>Compiler Application (COMPILER)</pagetext> + <preamble> + <contents level="2"></contents> + </preamble> + <applications> + <xi:include href="ref_man.xml"/> + </applications> + <releasenotes> + <xi:include href="notes.xml"/> + </releasenotes> + <listofterms></listofterms> + <index></index> +</book> + diff --git a/lib/compiler/doc/src/compile.xml b/lib/compiler/doc/src/compile.xml new file mode 100644 index 0000000000..c39c9b25eb --- /dev/null +++ b/lib/compiler/doc/src/compile.xml @@ -0,0 +1,743 @@ +<?xml version="1.0" encoding="latin1" ?> +<!DOCTYPE erlref SYSTEM "erlref.dtd"> + +<erlref> + <header> + <copyright> + <year>1996</year><year>2009</year> + <holder>Ericsson AB. All Rights Reserved.</holder> + </copyright> + <legalnotice> + 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. + + </legalnotice> + + <title>compile</title> + <prepared>Robert Virding</prepared> + <docno></docno> + <date>1996-11-04</date> + <rev>A</rev> + <file>compile.sgml</file> + </header> + <module>compile</module> + <modulesummary>Erlang Compiler</modulesummary> + <description> + <p>This module provides an interface to the standard Erlang + compiler. It can generate either a new file which contains + the object code, or return a binary which can be loaded directly. + </p> + </description> + + <funcs> + <func> + <name>file(File)</name> + <fsummary>Compile a file</fsummary> + <desc> + <p>Is the same as + <c>file(File, [verbose,report_errors,report_warnings])</c>. + </p> + </desc> + </func> + + <func> + <name>file(File, Options) -> CompRet</name> + <fsummary>Compile a file</fsummary> + <type> + <v>CompRet = ModRet | BinRet | ErrRet</v> + <v>ModRet = {ok,ModuleName} | {ok,ModuleName,Warnings}</v> + <v>BinRet = {ok,ModuleName,Binary} | {ok,ModuleName,Binary,Warnings}</v> + <v>ErrRet = error | {error,Errors,Warnings}</v> + </type> + <desc> + <p>Compiles the code in the file <c>File</c>, which is an + Erlang source code file without the <c>.erl</c> extension. + <c>Options</c> determine the behavior of the compiler.</p> + + <p>Returns <c>{ok,ModuleName}</c> if successful, or <c>error</c> + if there are errors. An object code file is created if + the compilation succeeds with no errors. It is considered + to be an error if the module name in the source code is + not the same as the basename of the output file.</p> + + <p>Here follows first all elements of <c>Options</c> that in + some way control the behavior of the compiler.</p> + <taglist> + <tag><c>basic_validation</c></tag> + <item> + <p>This option is fast way to test whether a module will + compile successfully (mainly useful for code generators + that want to verify the code they emit). No code will + generated. If warnings are enabled, warnings generated by + the <c>erl_lint</c> module (such as warnings for unused + variables and functions) will be returned too.</p> + + <p>Use the <c>strong_validation</c> option to generate all + warnings that the compiler would generate.</p> + </item> + + <tag><c>strong_validation</c></tag> + <item> + <p>Similar to the <c>basic_validation</c> option, no code + will be generated, but more compiler passes will be run + to ensure also warnings generated by the optimization + passes are generated (such as clauses that will not match + or expressions that are guaranteed to fail with an + exception at run-time).</p> + </item> + + <tag><c>binary</c></tag> + <item> + <p>Causes the compiler to return the object code in a + binary instead of creating an object file. If successful, + the compiler returns <c>{ok,ModuleName,Binary}</c>.</p> + </item> + + <tag><c>bin_opt_info</c></tag> + <item> + <p>The compiler will emit informational warnings about binary + matching optimizations (both successful and unsuccessful). + See the <em>Efficiency Guide</em> for further information.</p> + </item> + + <tag><c>compressed</c></tag> + <item> + <p>The compiler will compress the generated object code, + which can be useful for embedded systems.</p> + </item> + + <tag><c>debug_info</c></tag> + <item> + <marker id="debug_info"></marker> + <p>Include debug information in the form of abstract code + (see + <seealso marker="erts:absform">The Abstract Format</seealso> + in ERTS User's Guide) in the compiled beam module. Tools + such as Debugger, Xref and Cover require the debug + information to be included.</p> + + <p><em>Warning</em>: Source code can be reconstructed from + the debug information. Use encrypted debug information + (see below) to prevent this.</p> + + <p>See + <seealso marker="stdlib:beam_lib#debug_info">beam_lib(3)</seealso> + for details.</p> + </item> + + <tag><c>{debug_info_key,KeyString}</c></tag> + <item></item> + <tag><c>{debug_info_key,{Mode,KeyString}}</c></tag> + <item> + <marker id="debug_info_key"></marker> + <p>Include debug information, but encrypt it, so that it + cannot be accessed without supplying the key. (To give + the <c>debug_info</c> option as well is allowed, but is + not necessary.) Using this option is a good way to always + have the debug information available during testing, yet + protect the source code.</p> + <p><c>Mode</c> is the type of crypto algorithm to be used + for encrypting the debug information. The default type -- + and currently the only type -- is <c>des3_cbc</c>.</p> + <p>See + <seealso marker="stdlib:beam_lib#debug_info">beam_lib(3)</seealso> + for details.</p> + </item> + + <tag><c>encrypt_debug_info</c></tag> + <item> + <marker id="encrypt_debug_info"></marker> + <p>Like the <c>debug_info_key</c> option above, except that + the key will be read from an <c>.erlang.crypt</c> file. + </p> + + <p>See + <seealso marker="stdlib:beam_lib#debug_info">beam_lib(3)</seealso> + for details.</p> + </item> + + <tag><c>'P'</c></tag> + <item> + <p>Produces a listing of the parsed code after preprocessing + and parse transforms, in the file + <c><![CDATA[<File>.P]]></c>. No object file is produced. + </p> + </item> + + <tag><c>'E'</c></tag> + <item> + <p>Produces a listing of the code after all source code + transformations have been performed, in the file + <c><![CDATA[<File>.E]]></c>. No object file is produced. + </p> + </item> + + <tag><c>'S'</c></tag> + <item> + <p>Produces a listing of the assembler code in the file + <c><![CDATA[<File>.S]]></c>. No object file is produced. + </p> + </item> + + <tag><c>report_errors/report_warnings</c></tag> + <item> + <p>Causes errors/warnings to be printed as they occur.</p> + </item> + + <tag><c>report</c></tag> + <item> + <p>This is a short form for both <c>report_errors</c> and + <c>report_warnings</c>.</p> + </item> + + <tag><c>return_errors</c></tag> + <item> + <p>If this flag is set, then + <c>{error,ErrorList,WarningList}</c> is returned when + there are errors.</p> + </item> + + <tag><c>return_warnings</c></tag> + <item> + <p>If this flag is set, then an extra field containing + <c>WarningList</c> is added to the tuples returned on + success.</p> + </item> + + <tag><c>return</c></tag> + <item> + <p>This is a short form for both <c>return_errors</c> and + <c>return_warnings</c>.</p> + </item> + + <tag><c>verbose</c></tag> + <item> + <p>Causes more verbose information from the compiler + describing what it is doing.</p> + </item> + + <tag><c>{outdir,Dir}</c></tag> + <item> + <p>Sets a new directory for the object code. The current + directory is used for output, except when a directory + has been specified with this option.</p> + </item> + + <tag><c>export_all</c></tag> + <item> + <p>Causes all functions in the module to be exported.</p> + </item> + + <tag><c>{i,Dir}</c></tag> + <item> + <p>Add <c>Dir</c> to the list of directories to be searched + when including a file. When encountering an + <c>-include</c> or <c>-include_dir</c> directive, + the compiler searches for header files in the following + directories:</p> + <list type="ordered"> + <item> + <p><c>"."</c>, the current working directory of + the file server;</p> + </item> + <item> + <p>the base name of the compiled file;</p> + </item> + <item> + <p>the directories specified using the <c>i</c> option. + The directory specified last is searched first.</p> + </item> + </list> + </item> + + <tag><c>{d,Macro}</c></tag> + <item></item> + <tag><c>{d,Macro,Value}</c></tag> + <item> + <p>Defines a macro <c>Macro</c> to have the value + <c>Value</c>. The default is <c>true</c>).</p> + </item> + + <tag><c>{parse_transform,Module}</c></tag> + <item> + <p>Causes the parse transformation function + <c>Module:parse_transform/2</c> to be applied to the + parsed code before the code is checked for errors.</p> + </item> + + <tag><c>asm</c></tag> + <item> + <p>The input file is expected to be assembler code (default + file suffix ".S"). Note that the format of assembler files + is not documented, and may change between releases - this + option is primarily for internal debugging use.</p> + </item> + + <tag><c>no_strict_record_tests</c></tag> + <item> + <p>This option is not recommended.</p> + + <p>By default, the generated code for + the <c>Record#record_tag.field</c> operation verifies that + the tuple <c>Record</c> is of the correct size for + the record and that the first element is the tag + <c>record_tag</c>. Use this option to omit + the verification code.</p> + </item> + + <tag><c>no_error_module_mismatch</c></tag> + <item> + <p>Normally the compiler verifies that the module name + given in the source code is the same as the base name + of the output file and refuses to generate an output file + if there is a mismatch. If you have a good reason (or + other reason) for having a module name unrelated to the + name of the output file, this option disables that verification + (there will not even be a warning if there is a mismatch).</p> + </item> + + </taglist> + + <p>If warnings are turned on (the <c>report_warnings</c> option + described above), the following options control what type of + warnings that will be generated. + <marker id="erl_lint_options"></marker> + With the exception of <c>{warn_format,Verbosity}</c> all + options below have two forms; one <c>warn_xxx</c> form to + turn on the warning and one <c>nowarn_xxx</c> form to turn off + the warning. In the description that follows, the form that + is used to change the default value is listed.</p> + + <taglist> + <tag><c>{warn_format, Verbosity}</c></tag> + <item> + <p>Causes warnings to be emitted for malformed format + strings as arguments to <c>io:format</c> and similar + functions. <c>Verbosity</c> selects the amount of + warnings: 0 = no warnings; 1 = warnings for invalid + format strings and incorrect number of arguments; 2 = + warnings also when the validity could not be checked + (for example, when the format string argument is a + variable). The default verbosity is 1. Verbosity 0 can + also be selected by the option <c>nowarn_format</c>.</p> + </item> + + <tag><c>nowarn_bif_clash</c></tag> + <item> + <p>By default, there will be a compilation error if a + module contains an exported function with the same name + as an auto-imported BIF (such as <c>size/1</c>) AND + there is a call to it without a qualifying module name. + The reason is that the BIF will be called, not + the function in the same module. The recommended way to + eliminate that warning is to use a call with a module + name - either <c>erlang</c> to call the BIF or + <c>?MODULE</c> to call the function in the same module. + The warning can also be turned off using this option, + but that is not recommended.</p> + + <p><em>The use of this option is strongly discouraged, + as code that uses it will probably break in a future + major release (R14 or R15).</em></p> + </item> + + <tag><c>{nowarn_bif_clash, FAs}</c></tag> + <item> + <p>Turns off warnings as <c>nowarn_bif_clash</c> but only + for the mentioned local functions. <c>FAs</c> is a tuple + <c>{Name,Arity}</c> or a list of such tuples.</p> + <p><em>The use of this option is strongly discouraged, + as code that uses it will probably break in a future + major release (R14 or R15).</em></p> + </item> + + <tag><c>warn_export_all</c></tag> + <item> + <p>Causes a warning to be emitted if the <c>export_all</c> + option has also been given.</p> + </item> + + <tag><c>warn_export_vars</c></tag> + <item> + <p>Causes warnings to be emitted for all implicitly + exported variables referred to after the primitives + where they were first defined. No warnings for exported + variables unless they are referred to in some pattern, + which is the default, can be selected by the option + <c>nowarn_export_vars</c>.</p> + </item> + + <tag><c>warn_shadow_vars</c></tag> + <item> + <p>Causes warnings to be emitted for "fresh" variables + in functional objects or list comprehensions with the same + name as some already defined variable. The default is to + warn for such variables. No warnings for shadowed + variables can be selected by the option + <c>nowarn_shadow_vars</c>.</p> + </item> + + <tag><c>nowarn_unused_function</c></tag> + <item> + <p>Turns off warnings for unused local functions. + By default (<c>warn_unused_function</c>), warnings are + emitted for all local functions that are not called + directly or indirectly by an exported function. + The compiler does not include unused local functions in + the generated beam file, but the warning is still useful + to keep the source code cleaner.</p> + </item> + + <tag><c>{nowarn_unused_function, FAs}</c></tag> + <item> + <p>Turns off warnings for unused local functions as + <c>nowarn_unused_function</c> but only for the mentioned + local functions. <c>FAs</c> is a tuple <c>{Name,Arity}</c> + or a list of such tuples.</p> + </item> + + <tag><c>nowarn_deprecated_function</c></tag> + <item> + <p>Turns off warnings for calls to deprecated functions. By + default (<c>warn_deprecated_function</c>), warnings are + emitted for every call to a function known by the compiler + to be deprecated. Note that the compiler does not know + about the <c>-deprecated()</c> attribute but uses an + assembled list of deprecated functions in Erlang/OTP. To + do a more general check the <c>Xref</c> tool can be used. + See also + <seealso marker="tools:xref#deprecated_function">xref(3)</seealso> + and the function + <seealso marker="tools:xref#m/1">xref:m/1</seealso> also + accessible through + the <seealso marker="stdlib:c#xm/1">c:xm/1</seealso> + function.</p> + </item> + + <tag><c>{nowarn_deprecated_function, MFAs}</c></tag> + <item> + <p>Turns off warnings for calls to deprecated functions as + <c>nowarn_deprecated_function</c> but only for + the mentioned functions. <c>MFAs</c> is a tuple + <c>{Module,Name,Arity}</c> or a list of such tuples.</p> + </item> + + <tag><c>warn_obsolete_guard</c></tag> + <item> + <p>Causes warnings to be emitted for calls to old type + testing BIFs such as <c>pid/1</c> and <c>list/1</c>. See + the + <seealso marker="doc/reference_manual:expressions#guards">Erlang Reference Manual</seealso> + for a complete list of type testing BIFs and their old + equivalents. No warnings for calls to old type testing + BIFs, which is the default, can be selected by the option + <c>nowarn_obsolete_guard</c>.</p> + </item> + + <tag><c>warn_unused_import</c></tag> + <item> + <p>Causes warnings to be emitted for unused imported + functions. No warnings for unused imported functions, + which is the default, can be selected by the option + <c>nowarn_unused_import</c>. </p> + </item> + + <tag><c>nowarn_unused_vars</c></tag> + <item> + <p>By default, warnings are emitted for variables which + are not used, with the exception of variables beginning + with an underscore ("Prolog style warnings"). + Use this option to turn off this kind of warnings.</p> + </item> + + <tag><c>nowarn_unused_record</c></tag> + <item> + <p>Turns off warnings for unused record types. By + default (<c>warn_unused_records</c>), warnings are + emitted for unused locally defined record types.</p> + </item> + </taglist> + + <p>Another class of warnings is generated by the compiler + during optimization and code generation. They warn about + patterns that will never match (such as <c>a=b</c>), guards + that will always evaluate to false, and expressions that will + always fail (such as <c>atom+42</c>).</p> + + <p>Note that the compiler does not warn for expressions that it + does not attempt to optimize. For instance, the compiler tries + to evaluate <c>1/0</c>, notices that it will cause an + exception and emits a warning. On the other hand, + the compiler is silent about the similar expression + <c>X/0</c>; because of the variable in it, the compiler does + not even try to evaluate and therefore it emits no warnings. + </p> + + <p>Currently, those warnings cannot be disabled (except by + disabling all warnings).</p> + + <warning> + <p>Obviously, the absence of warnings does not mean that + there are no remaining errors in the code.</p> + </warning> + + <p>Note that all the options except the include path + (<c>{i,Dir}</c>) can also be given in the file with a + <c>-compile([Option,...])</c>. attribute. + The <c>-compile()</c> attribute is allowed after function + definitions.</p> + + <p>Note also that the <c>{nowarn_unused_function, FAs}</c>, + <c>{nowarn_bif_clash, FAs}</c>, and + <c>{nowarn_deprecated_function, MFAs}</c> options are only + recognized when given in files. They are not affected by + the <c>warn_unused_function</c>, <c>warn_bif_clash</c>, or + <c>warn_deprecated_function</c> options.</p> + + <p>For debugging of the compiler, or for pure curiosity, + the intermediate code generated by each compiler pass can be + inspected. + A complete list of the options to produce list files can be + printed by typing <c>compile:options()</c> at the Erlang + shell prompt. + The options will be printed in order that the passes are + executed. If more than one listing option is used, the one + representing the earliest pass takes effect.</p> + + <p><em>Unrecognized options are ignored.</em></p> + + <p>Both <c>WarningList</c> and <c>ErrorList</c> have + the following format:</p> + <code> +[{FileName,[ErrorInfo]}]. + </code> + + <p><c>ErrorInfo</c> is described below. The file name has been + included here as the compiler uses the Erlang pre-processor + <c>epp</c>, which allows the code to be included in other + files. For this reason, it is important to know to + <em>which</em> file an error or warning line number refers. + </p> + </desc> + </func> + + <func> + <name>forms(Forms)</name> + <fsummary>Compile a list of forms</fsummary> + <desc> + <p>Is the same as + <c>forms(File, [verbose,report_errors,report_warnings])</c>. + </p> + </desc> + </func> + + <func> + <name>forms(Forms, Options) -> CompRet</name> + <fsummary>Compile a list of forms</fsummary> + <type> + <v>Forms = [Form]</v> + <v>CompRet = BinRet | ErrRet</v> + <v>BinRet = {ok,ModuleName,BinaryOrCode} | {ok,ModuleName,BinaryOrCode,Warnings}</v> + <v>BinaryOrCode = binary() | term()</v> + <v>ErrRet = error | {error,Errors,Warnings}</v> + </type> + <desc> + <p>Analogous to <c>file/1</c>, but takes a list of forms (in + the Erlang abstract format representation) as first argument. + The option <c>binary</c> is implicit; i.e., no object code + file is produced. Options that would ordinarily produce a + listing file, such as 'E', will instead cause the internal + format for that compiler pass (an Erlang term; usually not a + binary) to be returned instead of a binary.</p> + </desc> + </func> + + <func> + <name>format_error(ErrorDescriptor) -> chars()</name> + <fsummary>Format an error descriptor</fsummary> + <type> + <v>ErrorDescriptor = errordesc()</v> + </type> + <desc> + <p>Uses an <c>ErrorDescriptor</c> and returns a deep list of + characters which describes the error. This function is + usually called implicitly when an <c>ErrorInfo</c> structure + is processed. See below.</p> + </desc> + </func> + + <func> + <name>output_generated(Options) -> true | false</name> + <fsummary>Determine whether the compile will generate an output file</fsummary> + <type> + <v>Options = [term()]</v> + </type> + <desc> + <p>Determines whether the compiler would generate a <c>beam</c> + file with the given options. <c>true</c> means that a <c>beam</c> + file would be generated; <c>false</c> means that the compiler + would generate some listing file, return a binary, or merely + check the syntax of the source code.</p> + </desc> + </func> + + <func> + <name>noenv_file(File, Options) -> CompRet</name> + <fsummary>Compile a file (ignoring ERL_COMPILER_OPTIONS)</fsummary> + <desc> + <p>Works exactly like <seealso marker="#file/2">file/2</seealso>, + except that the environment variable <c>ERL_COMPILER_OPTIONS</c> + is not consulted.</p> + </desc> + </func> + + <func> + <name>noenv_forms(Forms, Options) -> CompRet</name> + <fsummary>Compile a list of forms (ignoring ERL_COMPILER_OPTIONS)</fsummary> + <desc> + <p>Works exactly like <seealso marker="#forms/2">forms/2</seealso>, + except that the environment variable <c>ERL_COMPILER_OPTIONS</c> + is not consulted.</p> + </desc> + </func> + + <func> + <name>noenv_output_generated(Options) -> true | false</name> + <fsummary>Determine whether the compile will generate an output file (ignoring ERL_COMPILER_OPTIONS)</fsummary> + <type> + <v>Options = [term()]</v> + </type> + <desc> + <p>Works exactly like + <seealso marker="#output_generated/1">output_generated/1</seealso>, + except that the environment variable <c>ERL_COMPILER_OPTIONS</c> + is not consulted.</p> + </desc> + </func> + + </funcs> + + <section> + <title>Default compiler options</title> + <p>The (host operating system) environment variable + <c>ERL_COMPILER_OPTIONS</c> can be used to give default compiler + options. Its value must be a valid Erlang term. If the value is a + list, it will be used as is. If it is not a list, it will be put + into a list.</p> + + <p>The list will be appended to any options given to + <seealso marker="#file/2">file/2</seealso>, + <seealso marker="#forms/2">forms/2</seealso>, and + <seealso marker="#output_generated/1">output_generated/2</seealso>. + Use the alternative functions + <seealso marker="#noenv_file/2">noenv_file/2</seealso>, + <seealso marker="#noenv_forms/2">noenv_forms/2</seealso>, or + <seealso marker="#noenv_output_generated/1">noenv_output_generated/2</seealso> + if you don't want the environment variable to be consulted + (for instance, if you are calling the compiler recursively from + inside a parse transform).</p> + </section> + + <section> + <title>Inlining</title> + <p>The compiler can do function inlining within an Erlang + module. Inlining means that a call to a function is replaced with + the function body with the arguments replaced with the actual + values. The semantics are preserved, except if exceptions are + generated in the inlined code. Exceptions will be reported as + occurring in the function the body was inlined into. Also, + <c>function_clause</c> exceptions will be converted to similar + <c>case_clause</c> exceptions.</p> + + <p>When a function is inlined, the original function will be + kept if it is exported (either by an explicit export or if the + <c>export_all</c> option was given) or if not all calls to the + function were inlined.</p> + + <p>Inlining does not necessarily improve running time. + For instance, inlining may increase Beam stack usage which will + probably be detrimental to performance for recursive functions. + </p> + + <p>Inlining is never default; it must be explicitly enabled with a + compiler option or a <c>-compile()</c> attribute in the source + module.</p> + + <p>To enable inlining, either use the <c>inline</c> option to + let the compiler decide which functions to inline or + <c>{inline,[{Name,Arity},...]}</c> to have the compiler inline + all calls to the given functions. If the option is given inside + a <c>compile</c> directive in an Erlang module, <c>{Name,Arity}</c> + may be written as <c>Name/Arity</c>.</p> + + <p>Example of explicit inlining:</p> + + <pre> +-compile({inline,[pi/0]}). + +pi() -> 3.1416. + </pre> + + <p>Example of implicit inlining:</p> + <pre> +-compile(inline). + </pre> + + <p>The <c>{inline_size,Size}</c> option controls how large functions + that are allowed to be inlined. Default is <c>24</c>, which will + keep the size of the inlined code roughly the same as + the un-inlined version (only relatively small functions will be + inlined).</p> + + <p>Example:</p> + <pre> +%% Aggressive inlining - will increase code size. +-compile(inline). +-compile({inline_size,100}). + </pre> + </section> + + <section> + <title>Parse Transformations</title> + + <p>Parse transformations are used when a programmer wants to use + Erlang syntax but with different semantics. The original Erlang + code is then transformed into other Erlang code.</p> + </section> + + <section> + <title>Error Information</title> + + <p>The <c>ErrorInfo</c> mentioned above is the standard + <c>ErrorInfo</c> structure which is returned from all IO modules. + It has the following format:</p> + <code> +{ErrorLine, Module, ErrorDescriptor} + </code> + + <p>A string describing the error is obtained with the following + call:</p> + <code> +apply(Module, format_error, ErrorDescriptor) + </code> + </section> + + <section> + <title>See Also</title> + <p> + <seealso marker="stdlib:epp">epp(3)</seealso>, + <seealso marker="stdlib:erl_id_trans">erl_id_trans(3)</seealso>, + <seealso marker="stdlib:erl_lint">erl_lint(3)</seealso>, + <seealso marker="stdlib:beam_lib">beam_lib(3)</seealso> + </p> + </section> +</erlref> + diff --git a/lib/compiler/doc/src/fascicules.xml b/lib/compiler/doc/src/fascicules.xml new file mode 100644 index 0000000000..43090b4aed --- /dev/null +++ b/lib/compiler/doc/src/fascicules.xml @@ -0,0 +1,15 @@ +<?xml version="1.0" encoding="latin1" ?> +<!DOCTYPE fascicules SYSTEM "fascicules.dtd"> + +<fascicules> + <fascicule file="ref_man" href="ref_man_frame.html" entry="yes"> + Reference Manual + </fascicule> + <fascicule file="part_notes" href="part_notes_frame.html" entry="no"> + Release Notes + </fascicule> + <fascicule file="" href="../../../../doc/print.html" entry="no"> + Off-Print + </fascicule> +</fascicules> + diff --git a/lib/compiler/doc/src/make.dep b/lib/compiler/doc/src/make.dep new file mode 100644 index 0000000000..f5c097afad --- /dev/null +++ b/lib/compiler/doc/src/make.dep @@ -0,0 +1,19 @@ +# ---------------------------------------------------- +# >>>> Do not edit this file <<<< +# This file was automaticly generated by +# /home/otp/bin/docdepend +# ---------------------------------------------------- + + +# ---------------------------------------------------- +# TeX files that the DVI file depend on +# ---------------------------------------------------- + +book.dvi: book.tex compile.tex ref_man.tex + +# ---------------------------------------------------- +# Source inlined when transforming from source to LaTeX +# ---------------------------------------------------- + +book.tex: ref_man.xml + diff --git a/lib/compiler/doc/src/note.gif b/lib/compiler/doc/src/note.gif Binary files differnew file mode 100644 index 0000000000..6fffe30419 --- /dev/null +++ b/lib/compiler/doc/src/note.gif diff --git a/lib/compiler/doc/src/notes.xml b/lib/compiler/doc/src/notes.xml new file mode 100644 index 0000000000..7d1913d740 --- /dev/null +++ b/lib/compiler/doc/src/notes.xml @@ -0,0 +1,1331 @@ +<?xml version="1.0" encoding="latin1" ?> +<!DOCTYPE chapter SYSTEM "chapter.dtd"> + +<chapter> + <header> + <copyright> + <year>2004</year><year>2009</year> + <holder>Ericsson AB. All Rights Reserved.</holder> + </copyright> + <legalnotice> + 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. + + </legalnotice> + + <title>Compiler Release Notes</title> + <prepared>otp_appnotes</prepared> + <docno>nil</docno> + <date>nil</date> + <rev>nil</rev> + <file>notes.xml</file> + </header> + <p>This document describes the changes made to the Compiler + application.</p> + +<section><title>Compiler 4.6.4</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p>The compiler's 'E' option now works with modules with + types and specifications.</p> + <p> + Own Id: OTP-8238 Aux Id: OTP-8150 </p> + </item> + <item> + <p> + Certain uses of binary matching in a + <c>begin</c>-<c>end</c> in a list comprehension could + cause the compiler to crash or generate incorrect code.</p> + <p> + Own Id: OTP-8271</p> + </item> + </list> + </section> + + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + The documentation is now built with open source tools + (xsltproc and fop) that exists on most platforms. One + visible change is that the frames are removed.</p> + <p> + Own Id: OTP-8201</p> + </item> + <item> + <p> + The compiler could crash if invalid calls to is_record/2 + was used in (for example) a list comprehension. (Thanks + to Tobias Lindahl.)</p> + <p> + Own Id: OTP-8269</p> + </item> + <item> + <p>The -on_load() directive can be used to run a function + when a module is loaded. It is documented in the section + about code loading in the Reference Manual.</p> + <p> + Own Id: OTP-8295</p> + </item> + </list> + </section> + +</section> + +<section><title>Compiler 4.6.3</title> + + <section><title>Improvements and New Features</title> + <list> + <item> + <p>Corrected liveness optimization to eliminate a + compiler crash that could occur when compiling bit syntax + construction code. (Thanks to Mikage Sawatari.)</p> + <p>Calling BIFs such as <c>length/1</c> in guard context + in a try/catch block could cause a compiler crash. + (Thanks to Paul Fisher.)</p> + <p>Using filter expressions containing <c>andalso</c> or + <c>orelse</c> in a list comprehension could cause a + compiler crash. (Thanks to Martin Engstr�m.)</p> + <p> + Own Id: OTP-8054</p> + </item> + <item> + <p> + A guard with nested 'not' operators could cause the + compiler to crash. (Thanks to Tuncer Ayaz.)</p> + <p> + Own Id: OTP-8131</p> + </item> + </list> + </section> + +</section> + +<section><title>Compiler 4.6.2</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + The compiler would crash while compiling certain complex + function bodies containing <c>receive after</c> due to a + bug in the jump optimizer (a label that had only had + backward references could still be removed). (Thanks to + Vincent de Phily.)</p> + <p> + Own Id: OTP-7980</p> + </item> + </list> + </section> + +</section> + +<section><title>Compiler 4.6.1</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Miscellaneous minor bugs fixed.</p> + <p> + Own Id: OTP-7937</p> + </item> + </list> + </section> + + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + There will be more efficient code if there is a clause + that matches the empty binary and no other clauses that + matches non-empty binaries.</p> + <p> + Own Id: OTP-7924</p> + </item> + <item> + <p>There is new option to allow a module to have a module + name other than the filename. Do not use it unless you + know what you are doing.</p> + <p> + Own Id: OTP-7927</p> + </item> + </list> + </section> + +</section> + +<section><title>Compiler 4.6.0.1</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p>Using <c>andalso</c>/<c>orelse</c> or record access in + a <c>try</c>...<c>catch</c> could cause a compiler + crash.</p> + <p>Som large and complex functions could require + extremely long compilation times (hours or days).</p> + <p> + Own Id: OTP-7905</p> + </item> + </list> + </section> + +</section> + +<section><title>Compiler 4.6</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + For some complex guards which used + <c>andalso</c>/<c>orelse</c>, the compiler would crash. + (Thanks to Hunter Morris.)</p> + <p> + Own Id: OTP-7679</p> + </item> + <item> + <p> + Code that (incorrectly) used the the value of nested + applications of <c>setelement/3</c> in bit syntax + construction could crash the compiler.</p> + <p> + Own Id: OTP-7690</p> + </item> + <item> + <p>Modules containing huge integers (consisting of + several hundreds of thousands of digits or more) could be + slow to compile. This problem has been corrected.</p> + <p> + Own Id: OTP-7707 Aux Id: seq11129 </p> + </item> + <item> + <p>If the generator in a list comprehension is given a + non-list term, there will now be <c>function_clause</c> + exception instead of a <c>case_clause</c> exception (as + it was in all releases before R12B).</p> + <p> + Own Id: OTP-7844</p> + </item> + </list> + </section> + + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + The compiler could crash if the size for a binary segment + in matching was a complex literal such as binary or + tuple.</p> + <p> + Own Id: OTP-7650</p> + </item> + <item> + <p> + The compiler generates more compact and faster code for + matching of complex constants (such as constant lists and + tuples).</p> + <p> + Own Id: OTP-7655</p> + </item> + <item> + <p> + The undocumented, unsupported, and deprecated guard BIF + <c>is_constant/1</c> has been removed.</p> + <p> + *** INCOMPATIBILITY with R12B ***</p> + <p> + Own Id: OTP-7673</p> + </item> + <item> + <p>The compiler generates better code for many guard + expressions, and especially for guards that use + <c>andalso</c>/<c>orelse</c> or record fields.</p> + <p>(In technical terms, <c>andalso</c>/<c>orelse</c> in a + guard would case the creation of a stack frame and saving + of all x registers that could potentially be alive after + the guard and restoring all x registers before leaving + the guard. For certain guards, far too many x registers + were saved and subsequently restored. In this version of + the compiler, no stack frame is created and no x + registers are saved and restored.)</p> + <p> + Own Id: OTP-7718</p> + </item> + <item> + <p>The default size for the resulting binary created by a + binary comprehension was 64Kb in R12B (it would grow if + needed). This was often far too much. In this release, + the default is changed to 256 bytes. Furthermore, for + most binary comprehensions without filters, the exact + size of the resulting binary can be calculated beforehand + and the compiler now generates code that does that + calculation.</p> + <p> + Own Id: OTP-7737</p> + </item> + <item> + <p>The short-circuit operators <c>andalso</c> and + <c>orelse</c> no longer guarantees that their second + argument is either <c>true</c> or <c>false</c>. As a + consequence, <c>andalso</c>/<c>orelse</c> are now + tail-recursive.</p> + <p> + *** POTENTIAL INCOMPATIBILITY ***</p> + <p> + Own Id: OTP-7748</p> + </item> + <item> + <p>The compiler will refuse to a compile file where the + module name in the file differs from the output file + name.</p> + <p>When compiling using <c>erlc</c>, the current working + directory will no be included in the code path (unless + explicitly added using "-pa .").</p> + <p> + *** POTENTIAL INCOMPATIBILITY ***</p> + <p> + Own Id: OTP-7793</p> + </item> + <item> + <p>There will no longer be any warnings for list + comprehensions without generators, as such list + comprehension have turned out to be useful.</p> + <p> + Own Id: OTP-7846</p> + </item> + <item> + <p>Warnings for obsolete guard tests are now turned on. + (That is, writing <c>list(L)</c> in a guard instead of + <c>is_list(L)</c> will generate a warning.)</p> + <p>The warnings can be turned off using the + <c>nowarn_obsolete_guard</c> option.</p> + <p> + Own Id: OTP-7850</p> + </item> + <item> + <p>The copyright notices have been updated.</p> + <p> + Own Id: OTP-7851</p> + </item> + <item> + <p>If a module contains an exported function with the + same name as an auto-imported BIF (such as + <c>length/1</c>), any calls to the BIF must have an + explicit <c>erlang:</c> prefix, or there will be a + compilation error (such calls would only generate a + warning in previous releases).</p> + <p>(The reason for the change is to avoid breaking code + in a future major release, R14 or R15, in which we plan + to make calls without a module prefix always call the + local function in the same module even if there is an + auto-imported BIF with the same name.)</p> + <p> + *** POTENTIAL INCOMPATIBILITY ***</p> + <p> + Own Id: OTP-7873</p> + </item> + </list> + </section> + +</section> + +<section><title>Compiler 4.5.5</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p>Matching on a zero-width segment in the bit syntax + would crash the compiler. (Thanks to Will.)</p> + <p> + Own Id: OTP-7591</p> + </item> + </list> + </section> + + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + In bit syntax expressions which started with a binary + segment, and was followed by at least two segments of + variable size, too little space could be allocated for + the binary, leading to memory corruption.</p> + <p> + Own Id: OTP-7556</p> + </item> + <item> + <p>In user-defined attributes, <c>Name/Arity</c> is now + allowed and will be translated to <c>{Name,Arity}</c>. + (An implementation of EEP-24 by Richard O'Keefe.)</p> + <p>The <c>module_info/{0,1}</c> functions automatically + inserted into each compiled modules are now documented in + the Modules section in the Reference Manual.</p> + <p> + Own Id: OTP-7586</p> + </item> + </list> + </section> + +</section> + +<section><title>Compiler 4.5.4</title> + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + Certain complex bit syntax matching operations matching + out binaries and having several clauses could give + incorrect results (the matched out binaries were too + short). (Thanks to Christian von Roques for bug report + and correction.)</p> + <p> + Own Id: OTP-7498</p> + </item> + </list> + </section> + +</section> + +<section><title>Compiler 4.5.3</title> + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + New option <c>warn_export_all</c> to warn for a module + using <c>export_all</c>. (Thanks to Richard Carlsson.)</p> + <p> + Own Id: OTP-7392</p> + </item> + </list> + </section> + +</section> + +<section><title>Compiler 4.5.2.1</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + In rare circumstances, the length/1 BIF (and a few other + guard BIFs) would seem to return an incorrect value (of + any type).</p> + <p> + Own Id: OTP-7345 Aux Id: seq10962 </p> + </item> + </list> + </section> + +</section> +<section><title>Compiler 4.5.2</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p>A bug in the old inliner has been fixed. Some + undocumented functionality has been removed.</p> + <p> + Own Id: OTP-7223</p> + </item> + <item> + <p>Matching several binary patterns in parallel using the + '=' operator is not allowed (an implementation + limitation), but the compiler did not reject all such + attempts (depending on the patterns, the generated code + might or might not work correctly). Now the compiler + rejects all binary patterns joined by '='.</p> + <p> + Own Id: OTP-7227</p> + </item> + <item> + <p>Complex combinations of record operations and binary + matching could cause the compiler to crash. (Thanks to + Vladimir Klebansky.)</p> + <p> + Own Id: OTP-7233</p> + </item> + <item> + <p> + In rare circumstances, mixing binary matching clauses + with clauses matching other data types, the compiler + could crash.</p> + <p> + Own Id: OTP-7240 Aux Id: seq10916 </p> + </item> + </list> + </section> + +</section> + +<section><title>Compiler 4.5.1.1</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Corrected a compiler bug that could cause a complex + binary matching operation to fail when it shouldn't. + (Thanks to Tomas Stejskal.)</p> + <p> + Own Id: OTP-7188</p> + </item> + <item> + <p> + In unusual circumstances, the environment for a fun could + bind wrong values.</p> + <p> + Own Id: OTP-7202 Aux Id: seq10887 </p> + </item> + <item> + <p>Long sequences of list comprehensions without + generators joined by the '++' operator would cause a code + expansion explosion, which could cause the compiler to + run out of memory. To resolve this problem, in + '<c>[...||...]++Expr</c>', <c>Expr</c> is now evaluated + before the list comprehension. This change <em>is</em> + backwards compatible (see the following note about + evaluation order if you have doubts).</p> + <p>Note about evaluation order: The Reference manual says + that subexpressions are evaluated <em>in any order</em> + before the expression itself. Therefore, in an expression + such as '<c>LeftExpr++RightExpr</c>', you should not + depend on <c>LeftExpr</c> being evaluated before + <c>RightExpr</c> or vice versa. The evaluation order is + only important if the expressions contains and/or depends + on operations with side-effects, such as message passing + or <c>ets</c> operations.</p> + <p> + Own Id: OTP-7206</p> + </item> + </list> + </section> + +</section> + + +<section><title>Compiler 4.5.1</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + A match expression inside a function call could cause a + false "a term is constructed but never used" warning.</p> + <p> + Own Id: OTP-7018 Aux Id: seq10824 </p> + </item> + <item> + <p>The compiler could crash if a binary tail was matched + out, and then used in a binary append operation. (Thanks + to Oleg Avdeev.)</p> + <p>Similarly, the compiler could crash if a binary tail + was matched out, and then used (incorrectly) in binary + construction in an integer field. (Thanks to Fredrik + Svahn.) Or was incorrectly used in a float field. Or was + used in a binary field with a given length. (Thanks to + Chih - Wei Yu.) </p> + <p> + Own Id: OTP-7022</p> + </item> + <item> + <p> + Matching an empty binary in a record and then using the + same record again could cause a compiler crash. (Thanks + to Fredrik Thulin.)</p> + <p> + Own Id: OTP-7029</p> + </item> + <item> + <p>In rare circumstances, constants containing floating + points and integers could be confused. Example:</p> + <p><c>f(a) -> [1]; f(b) -> [1.0].</c></p> + <p>Both <c>f(a)</c> and <c>f(b)</c> would return + <c>[1]</c>.</p> + <p> + Own Id: OTP-7073</p> + </item> + <item> + <p>Some bit syntax code such as</p> + <p><c>matching d(_,<$lt;$gt;$gt;) -> one; d(0,<$lt;D$gt;$gt;) + ->two.</c></p> + <p>could crash the compiler. (Thanks to Simon + Cornish.)</p> + <p> + Own Id: OTP-7094</p> + </item> + <item> + <p> + In unusual circumstances, a call to a fun could fail due + to an unsafe optimization. (Thanks to Simon Cornish.)</p> + <p> + Own Id: OTP-7102</p> + </item> + <item> + <p> + Bit syntax matching with a guard containing two or more + uses of andalso/orelse could cause the compiler to crash. + (Thanks to Mateusz Berezecki.)</p> + <p> + Own Id: OTP-7113</p> + </item> + <item> + <p> + This was only a problem if you generated or wrote your + own Core Erlang code: The Core Erlang optimizer code + could move nested calls such as + <c>erlang:'$lt;'(erlang:length(L), 2)</c> as case expression + into a guard, which would change the semantics. (Thanks + to Robert Virding.)</p> + <p> + Own Id: OTP-7117</p> + </item> + </list> + </section> + + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + The compiler could generate suboptimal code for record + updates if the record update code consisted of multiple + source code lines.</p> + <p> + Own Id: OTP-7101</p> + </item> + </list> + </section> + +</section> + +<section><title>Compiler 4.5</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p>The compiler used to allow that a binary field without + size could be used in other positions than at the end in + bit syntax pattern. For instance, + <c><![CDATA[<<B/binary,EmptyBinary/binary>> = Bin]]></c> + used to compile, but now the compilation will fail with + an an error message.</p> + <p>Also, it is now longer permitted to give a literal + string in a binary pattern a type or a size; for + instance, <c><![CDATA[<<"abc"/binary>> = Bin]]></c> will + no longer compile. (In previous releases, there would + always be a <c>badmatch</c> exception at run-time.)</p> + <p> + Own Id: OTP-6885</p> + </item> + </list> + </section> + + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + Bitstrings (bit-level) binaries and binary comprehensions + are now part of the language. See the Reference Manual.</p> + <p> + Own Id: OTP-6558</p> + </item> + <item> + <p> + The '<c>compressed</c>' option for the compiler has been + documented.</p> + <p> + Own Id: OTP-6801</p> + </item> + <item> + <p>If the value of a list comprehension is not used, such + as in '<c>[do_something(X) || X <- List], ok</c>', a + result list will no longer be built. For more details, + see the Efficiency Guide.</p> + <p>If the value of an expression is not used, and the + expression has no side effects except for possibly + throwing an exception, a warning will be generated. + Examples: '<c>self(),ok</c>' and + '<c>{error,Reason},ok</c>'.</p> + <p> + Own Id: OTP-6824</p> + </item> + <item> + <p> + Three new functions have been added to the <c>compile</c> + module: <c>noenv_file/2</c>, <c>noenv_forms/2</c>, and + <c>noenv_output_generated/1</c>.</p> + <p> + Own Id: OTP-6829</p> + </item> + <item> + <p>Many bit syntax operations, both construction and + matching, are faster. For further information, see the + Efficiency Guide.</p> + <p> + Own Id: OTP-6838</p> + </item> + <item> + <p>Literal lists, tuples, and binaries are no longer + constructed at run-time as they used to be, but are + stored in a per-module constant pool. Literals that are + used more than once are stored only once.</p> + <p>This is not a change to the language, only in the + details of its implementation. Therefore, the + implications of this change is described in the + Efficiency Guide.</p> + <p>Example 1: In the expression <c>element(BitNum-1, + {1,2,4,8,16,32,64,128})</c>, the tuple used to be + constructed every time the expression was executed, which + could be detrimental to performance in two ways if the + expression was executed in a loop: the time to build the + tuple itself and the time spent in garbage collections + because the heap filled up with garbage faster.</p> + <p>Example 2: Literal strings, such as <c>"abc"</c>, used + to be stored in the compiled code compactly as a byte + string and expanded to a list at run-time. Now all + strings will be stored expanded to lists (such as + <c>[$a,$b,$c]</c>) in the constant pool. That means that + the string will be faster to use at run-time, but that it + will require more space even when not used. If space is + an issue, you might want to use binary literals (that is, + <c><<"abc"<<</c>) instead of string literals for + infrequently used long strings (such as error + messages).</p> + <p> + Own Id: OTP-6850</p> + </item> + <item> + <p> + Recursive calls now usually consume less stack than in + R11B. See the Efficiency Guide.</p> + <p> + Own Id: OTP-6862 Aux Id: seq10746 </p> + </item> + <item> + <p>Two new guard BIFs have been introduced as a + recommended replacement for <c>size/1</c>. (The + <c>size/1</c> BIF will be removed no earlier than in + R14B.) The BIFs are <c>tuple_size/1</c> to calculate the + size of a tuple and <c>byte_size/1</c> to calculate the + number of bytes needed for the contents of the binary or + bitstring (rounded up to the nearest number of bytes if + necessary).</p> + <p>There is also a new <c>bit_size/1</c> BIF that returns + the exact number of bits that a binary or bitstring + contains.</p> + <p> + Own Id: OTP-6902</p> + </item> + <item> + <p> + The two internal functions <c>erl_bifs:is_bif/3</c> and + <c>erl_bifs:is_guard/3</c> have been removed. They were + unsupported, undocumented, and unmaintained.</p> + <p> + Own Id: OTP-6966</p> + </item> + </list> + </section> + +</section> + + <section> + <title>Compiler 4.4.5</title> + + <section> + <title>Fixed Bugs and Malfunctions</title> + <list type="bulleted"> + <item> + <p>The compiler would crash if you tried to combine to + non-list literals with '<c><![CDATA[++]]></c>' (for instance, + <c><![CDATA[an_atom++"string"]]></c>).</p> + <p>Own Id: OTP-6630 Aux Id: seq10635 </p> + </item> + </list> + </section> + + <section> + <title>Improvements and New Features</title> + <list type="bulleted"> + <item> + <p>Minor Makefile changes.</p> + <p>Own Id: OTP-6689</p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.4.4</title> + + <section> + <title>Fixed Bugs and Malfunctions</title> + <list type="bulleted"> + <item> + <p>Incorrect code could be generated for bit syntax matching + if the old inliner was used with aggressive settings.</p> + <p>Own Id: OTP-6461</p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.4.3</title> + + <section> + <title>Fixed Bugs and Malfunctions</title> + <list type="bulleted"> + <item> + <p>The R10B compiler could generate unsafe + <c><![CDATA[bs_save/bs_restore]]></c> instructions that could cause + memory corruption. (The R11B compiler does not have that + problem.) The erlang emulator will now refuse to load + R10B-compiled modules that contain such unsafe + <c><![CDATA[bs_save/bs_restore]]></c> instructions. In addition, the + beam_validator module in the compiler will also reject + such instructions (in case it is used to validate R10B + code). (Thanks to Matthew Reilly.)</p> + <p>Own Id: OTP-6386</p> + </item> + </list> + </section> + + <section> + <title>Improvements and New Features</title> + <list type="bulleted"> + <item> + <p>Directives for parse transforms that have been run are + now removed from the abstract code stored when the + debug_info option is given, to prevent the parse + transforms to be run again.</p> + <p>Own Id: OTP-5344</p> + </item> + <item> + <p>Minor improvements in code generation for some guards + expression involving boolean expressions.</p> + <p>Own Id: OTP-6347</p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.4.2.1</title> + + <section> + <title>Fixed Bugs and Malfunctions</title> + <list type="bulleted"> + <item> + <p>The compiler could generate incorrect code for bit syntax + matching consisting of several clauses.</p> + <p>Own Id: OTP-6392 Aux Id: seq10539 </p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.4.2</title> + + <section> + <title>Fixed Bugs and Malfunctions</title> + <list type="bulleted"> + <item> + <p>Defining a fun itself containing a fun in an + <c><![CDATA[after]]></c> block of a <c><![CDATA[try]]></c> would cause the + compiler to crash or generate incorrect code. (Thanks to + Tim Rath.)</p> + <p>Shorter compilation times for modules containing with + an extreme number of functions (10000 functions or more).</p> + <p>(The compiled could generate deprecated instructions + for certain bit syntax matching operations.)</p> + <p>Own Id: OTP-6212 Aux Id: seq10446 </p> + </item> + <item> + <p>Fixed several bugs that would cause warnings to be shown + without file name and line number.</p> + <p>Own Id: OTP-6260 Aux Id: seq10461 </p> + </item> + </list> + </section> + + <section> + <title>Improvements and New Features</title> + <list type="bulleted"> + <item> + <p>The <c><![CDATA[strict_record_tests]]></c> option is now default; + that is, reading a field from a record using the + <c><![CDATA[Record#record_tag.field]]></c> syntax will fail if + <c><![CDATA[Record]]></c> is not a record of the correct type.</p> + <p>If necessary, the record tests can be turned off by + giving the <c><![CDATA[no_strict_record_tests]]></c> option. To avoid + editing Makefiles, the environment variable + <c><![CDATA[ERL_COMPILER_OPTIONS]]></c> can be set to + "<c><![CDATA[no_strict_record_tests]]></c>".</p> + <p>The <c><![CDATA[no_strict_record_tests]]></c> option will probably + be removed in the R12B release.</p> + <p>*** POTENTIAL INCOMPATIBILITY ***</p> + <p>Own Id: OTP-6294</p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.4.1</title> + + <section> + <title>Fixed Bugs and Malfunctions</title> + <list type="bulleted"> + <item> + <p>The compiler used to crash if a module contained code + similar to '<c><![CDATA[fun(1=0) -> ok end]]></c>'. (Thanks to + Richard Carlsson.)</p> + <p>The compiler would spend really long time compiling + bit syntax expressions such as + '<c><![CDATA[<<1:(50*1024*1024)>>]]></c>' and produce a huge .beam + file. Corrected.</p> + <p>The compiler would compile list comprehensions with + many generators really, really slow. (Thanks to Thomas + Raes.)</p> + <p>Module attributes would be stored in reverse order + compared to the order in the source code. (Thus, + <c><![CDATA[M:module_info(attributes)]]></c> would also return the + attributes in reversed order.)</p> + <p>Defining a fun in an <c><![CDATA[after]]></c> block of a + <c><![CDATA[try]]></c> would cause the compiler to crash or generate + incorrect code. (Thanks to Martin Bjorklund.)</p> + <p>The combination of binary pattern and a guard with + andalso/orelse could cause the compiler to crash.</p> + <p>Own Id: OTP-6121 Aux Id: seq10400 </p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.4</title> + + <section> + <title>Fixed Bugs and Malfunctions</title> + <list type="bulleted"> + <item> + <p>When a <c><![CDATA[.hrl]]></c> file is included using + <c><![CDATA[-include_lib]]></c>, the include path is temporarily + updated to include the directory the <c><![CDATA[.hrl]]></c> file was + found in, which will allow that <c><![CDATA[.hrl]]></c> file to itself + include files from the same directory using + <c><![CDATA[-include]]></c>. (Thanks to Richard Carlsson.)</p> + <p>Own Id: OTP-5944</p> + </item> + </list> + </section> + + <section> + <title>Improvements and New Features</title> + <list type="bulleted"> + <item> + <p>The <c><![CDATA[andalso]]></c> and <c><![CDATA[orelse]]></c> operators are + now allowed to be used in guards. That also applies to + match specifications.</p> + <p>Own Id: OTP-5894 Aux Id: OTP-5149 </p> + </item> + <item> + <p>When given the new option + <c><![CDATA[strict_record_tests]]></c>, the compiler will generate + code that verifies the record type for + <c><![CDATA[R#record.field]]></c> operations in guards. Code that + verifies record types in bodies has already been + generated since R10B, but in this release there will be a + <c><![CDATA[{badrecord,RecordTag}]]></c> instead of a + <c><![CDATA[badmatch]]></c> if the record verification test fails. + See <c><![CDATA[compile(3)]]></c> for more information.</p> + <p>The Erlang shell always applies strict record tests.</p> + <p>Own Id: OTP-5915 Aux Id: OTP-5714 </p> + </item> + <item> + <p>The BIF <c><![CDATA[is_record/3]]></c> can now be used in guards. + Also, <c><![CDATA[is_record/3]]></c> can now be called without an + <c><![CDATA[erlang:]]></c> module prefix for consistency with the other + <c><![CDATA[is_*]]></c> functions.</p> + <p>Own Id: OTP-5916</p> + </item> + <item> + <p>The compiler options <c><![CDATA[ignore_try]]></c> and + <c><![CDATA[ignore_cond]]></c>, which allowed code that used + unquoted <c><![CDATA[try]]></c> or <c><![CDATA[cond]]></c> as atoms or record + tags, has been removed. Old code that depended on the + options need to be revised to have occurrences of + <c><![CDATA[try]]></c> or <c><![CDATA[cond]]></c> as atom or record tags + single-quoted. (Note: Although <c><![CDATA[cond]]></c> is a reserved + keyword, there is no <c><![CDATA[cond]]></c> statement. It might be + introduced in a future release.)</p> + <p>*** POTENTIAL INCOMPATIBILITY ***</p> + <p>Own Id: OTP-6058</p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.3.12</title> + + <section> + <title>Improvements and New Features</title> + <list type="bulleted"> + <item> + <p>The following code would crash the compiler: <c><![CDATA[case T of #r{s = ""} -> T #r{s = "x"} end]]></c>. (Thanks to + Richard Carlsson.)</p> + <p>The compiler could crash if binaries were constructed + in certain guards involving boolean operators (including + semicolon). (Thanks to Torbjorn Tornkvist.)</p> + <p>Own Id: OTP-5872</p> + </item> + <item> + <p>The compiler will now warn that the + <c><![CDATA[megaco:format_versions/1]]></c> function is deprecated.</p> + <p>Own Id: OTP-5976</p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.3.11</title> + + <section> + <title>Improvements and New Features</title> + <list type="bulleted"> + <item> + <p>The compiler would assume that some patterns with + aliases ('=') would not match if they were split into + several lines. (Thanks to Peter Nagy/Mats Cronqvist.)</p> + <p>Minor cleanups to eliminate Dialyzer warnings.</p> + <p>Own Id: OTP-5791 Aux Id: seq10141 </p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.3.10</title> + + <section> + <title>Fixed Bugs and Malfunctions</title> + <list type="bulleted"> + <item> + <p>When given the new option + <c><![CDATA[strict_record_tests]]></c>, the compiler will generate + code that verifies the record type for + <c><![CDATA[R#record.field]]></c> operations (in body context only, + not in guards). See the documentation for the + <c><![CDATA[compile]]></c> module for more information.</p> + <p>The beam validator pass of the compiler could crash + given in rare circumstances when given certain + combinations of catches and record operations. (Thanks to + Mats Cronqvist.)</p> + <p>Attributes containing binaries (such as -a(<<1,2,3>>)) + would crash the compiler. (Thanks to Roger Price.)</p> + <p>Multiple behaviours in the same module will no longer + generate a warning, unless one or more callbacks for the + behaviours overlap. For instance, using both the + <c><![CDATA[application]]></c> and <c><![CDATA[supervisor]]></c> behaviours + in the same module will NOT generate any warning, but + using <c><![CDATA[gen_server]]></c> and <c><![CDATA[gen_fsm]]></c> will.</p> + <p>Own Id: OTP-5714 Aux Id: seq10073 </p> + </item> + <item> + <p>The pre-processor used to complain that the macro + definition <c><![CDATA[-define(S(S), ??S).]]></c> was circular, + which it isn't. (Thanks to Richard Carlsson.)</p> + <p>Own Id: OTP-5777</p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.3.9</title> + + <section> + <title>Fixed Bugs and Malfunctions</title> + <list type="bulleted"> + <item> + <p>Updating at least two fields of a record with a literal + string could cause the compiler to generate dangerous + code that could cause a crash at run-time (e.g. + <c><![CDATA[R#r{a="abc",b=1}]]></c>). (Thanks to Mikael Karlsson.)</p> + <p>Unecessary tests (such as a 'case' with two case + branches that were identical) could cause the compiler to + crash. (Thanks to Fredrik Thulin.)</p> + <p>The validation pass of the compiler could generate an + error for correct code when floating point operations + were used in try/catch statements.</p> + <p>In bit syntax construction, any field following a + binary field would always be marked as "aligned" (which + may or may not be correct). That would cause the hipe + native compiler to generate incorrect code if the field + was in fact unaligned. (Thanks to Per Gustafsson.)</p> + <p>Some complex guard expressions (such as <c><![CDATA[A#a.b==""; A#a.b==undefined]]></c>) would crash the compiler. (Thanks + to Sean Hinde.)</p> + <p>Compilation speed has been increased for modules with + many functions and/or atoms (such as modules generated by + the Asn1 application or other code generators).</p> + <p>Own Id: OTP-5632 Aux Id: seq10057 </p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.3.8</title> + + <section> + <title>Fixed Bugs and Malfunctions</title> + <list type="bulleted"> + <item> + <p>In some circumstances, having two try/catch constructs + following each in a function body, would cause an + internal error to be generated (when in fact the + generated code was correct). (Thanks to Fredrik Thulin.)</p> + <p>Incorrect calls such as <c><![CDATA[M:42()]]></c> would crash the + compiler. The compiler now generates a warning. (Thanks + to Ulf Wiger.)</p> + <p>Own Id: OTP-5553</p> + </item> + </list> + </section> + + <section> + <title>Improvements and New Features</title> + <list type="bulleted"> + <item> + <p>The new <c><![CDATA[fun M:F/A]]></c> construct creates a fun that + refers to the latest version of <c><![CDATA[M:F/A]]></c>. This syntax is + meant to replace tuple funs <c><![CDATA[{M,F}]]></c> which have many + problems.</p> + <p>The new type test <c><![CDATA[is_function(Fun, A)]]></c> (which may be + used in guards) test whether <c><![CDATA[Fun]]></c> is a fun that can be + applied with <c><![CDATA[A]]></c> arguments. (Currently, <c><![CDATA[Fun]]></c> can + also be a tuple fun.)</p> + <p>Own Id: OTP-5584</p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.3.7</title> + + <section> + <title>Improvements and New Features</title> + <list type="bulleted"> + <item> + <p>Further improvements of encrypted debug info: New option + <c><![CDATA[encrypt_debug_info]]></c> for compiler.</p> + <p>Own Id: OTP-5541 Aux Id: seq9837 </p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.3.6</title> + + <section> + <title>Fixed Bugs and Malfunctions</title> + <list type="bulleted"> + <item> + <p>Fixed a bug in the validator of the generated code + (beam_validator) which caused an internal compiler error + even though the generated code was indeed correct.</p> + <p>Own Id: OTP-5481 Aux Id: seq9798 </p> + </item> + </list> + </section> + + <section> + <title>Improvements and New Features</title> + <list type="bulleted"> + <item> + <p>It is now possible to encrypt the debug information in + Beam files, to help keep the source code secret. See the + documentation for <c><![CDATA[compile]]></c> on how to provide the key + for encrypting, and the documentation for <c><![CDATA[beam_lib]]></c> + on how to provide the key for decryption so that tools such + as the Debugger, Xref, or Cover can be used.</p> + <p>The <c><![CDATA[beam_lib:chunks/2]]></c> functions now accepts an + additional chunk type <c><![CDATA[compile_info]]></c> to retrieve + the compilation information directly as a term. (Thanks + to Tobias Lindahl.)</p> + <p>Own Id: OTP-5460 Aux Id: seq9787 </p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.3.5</title> + + <section> + <title>Fixed Bugs and Malfunctions</title> + <list type="bulleted"> + <item> + <p>Complex functions could cause the internal validator in + the compiler to generate an internal error even though + the generated code was correct.</p> + <p>Own Id: OTP-5436 Aux Id: seq9781 </p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.3.4</title> + + <section> + <title>Fixed Bugs and Malfunctions</title> + <list type="bulleted"> + <item> + <p>In rare circumstances, incorrect code for record or + tuple access could be generated. The incorrect code would + either trigger an internal error in the compiler or cause + an exception at run time. (Thanks to Martin Bjorklund.)</p> + <p>Corrected a bug in in bit syntax matching where + clauses could match in the wrong order. (Thanks to Ulf + Wiger.)</p> + <p>Own Id: OTP-5404 Aux Id: seq9767 </p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.3.3</title> + + <section> + <title>Improvements and New Features</title> + <list type="bulleted"> + <item> + <p>Given bit syntax construction in certain complex + contexts involving a catch, the compiler would either + crash or terminate due to failure in an internal + consistency check. (Thanks to Fredrik Thulin.)</p> + <p>Matches such as + <c><![CDATA[<<103133:64/float>> = <<103133:64/float>>]]></c> + used to fail. Now they succeed.</p> + <p>Shadowing of variables in bit syntax matches in fun heads + such as in + <c><![CDATA[L = 8, F = fun(<<L:L,B:L>>) -> B end]]></c> was + handled incorrectly by the compiler. The fun used to be + compiled as if it was written + '<c><![CDATA[>fun(<<8:8,B:8>>)]]></c>, while it should be + compiled in the same way as <c><![CDATA[fun(<<L:8,B:L>>)]]></c>.</p> + <p>A bug in the validation pass has been corrected. It + sometimes occurred when the compiler optimized by reusing + code for causing an exception when the reused code was + called from within catch or try-catch statements. Then the + validator refused to approve the code and complained about + <c><![CDATA[fun(<<L:L,B:L>>) -> B end]]></c> was handled + incorrectly by the in the same way as + <c><![CDATA[fun(<<L:8,B:L>>)]]></c>.</p> + <p>A bug in the unknown_catch_try_state.</p> + <p>Corrected a bug in the optimizer that would cause + the compiler to crash. (Thanks to Peter-Henry Mander.)</p> + <p>There are now warnings generated if a bit syntax + construction will fail at run-time because of a type + mismatch (e.g. <c><![CDATA[<<an_atom:8>>]]></c>).</p> + <p>Own Id: OTP-5342 Aux Id: OTP-5118, OTP-5270, OTP-5323 </p> + </item> + <item> + <p>Binary pattern matching such as + <c><![CDATA[t(<<A:8>> = <<A:8>)]]></c> used to silently + fail at runtime (i.e. never match). The compiler now + generates an error for any such patterns.</p> + <p>Own Id: OTP-5371</p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.3.2</title> + + <section> + <title>Fixed Bugs and Malfunctions</title> + <list type="bulleted"> + <item> + <p>In rare cases, the code compiler code generate code + for a tuple match that could crash the emulator if passed + a term that was not a tuple.</p> + <p>If a bit syntax construction failed within a catch, + previously assigned variables could get the wrong value.</p> + <p>The compiler now runs a validation pass on the + generated code and aborts before writing a Beam file if + any suspect code is found. In particular, the validation + pass checks for incorrect code that may cause emulator + crashes or other strange symptoms in the emulator.</p> + <p>Some corrections to the unsupported feature + parameterized modules by Richard Carlsson (HiPE).</p> + <p>Own Id: OTP-5247 Aux Id: OTP-5235 </p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.3.1</title> + + <section> + <title>Fixed Bugs and Malfunctions</title> + <list type="bulleted"> + <item> + <p>Corrected the release note regarding <c><![CDATA[try/catch]]></c> below. + <c><![CDATA[try/catch]]></c> DOES work in the initial R10B release.</p> + <p>A few minor issues code generation issues were corrected. + Although the generated code was correct, it was slightly + slower and larger than it needed to be.</p> + <p>A debug printout (that could be seen in rare + circumstances) has been removed.</p> + <p><c><![CDATA[not record_test(not_a_tuple, RecordTag)]]></c> and + similar expressions in a guard would fail.</p> + <p>New options <c><![CDATA[basic_validation]]></c> and + <c><![CDATA[strong_validation]]></c> to do a quick check of the code + of a module.</p> + <p>The <c><![CDATA[inline]]></c> option was not recognized if it + appeared in a <c><![CDATA[-compile()]]></c> directive inside the + module.</p> + <p>Corrected some bugs in the undocumented feature + "parameterized modules".</p> + <p>Own Id: OTP-5198</p> + </item> + <item> + <p>When the undocumented feature "parameterized modules" was + used, the <c><![CDATA[?MODULE]]></c> macro did not work correctly.</p> + <p>Own Id: OTP-5224</p> + </item> + </list> + </section> + </section> +</chapter> + diff --git a/lib/compiler/doc/src/notes_history.xml b/lib/compiler/doc/src/notes_history.xml new file mode 100644 index 0000000000..db0dc2f683 --- /dev/null +++ b/lib/compiler/doc/src/notes_history.xml @@ -0,0 +1,200 @@ +<?xml version="1.0" encoding="latin1" ?> +<!DOCTYPE chapter SYSTEM "chapter.dtd"> + +<chapter> + <header> + <copyright> + <year>2006</year><year>2009</year> + <holder>Ericsson AB. All Rights Reserved.</holder> + </copyright> + <legalnotice> + 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. + + </legalnotice> + + <title>Compiler Release Notes History</title> + <prepared>otp_appnotes</prepared> + <docno>nil</docno> + <date>nil</date> + <rev>nil</rev> + </header> + + <section> + <title>Compiler 4.3</title> + + <section> + <title>Fixed Bugs and Malfunctions</title> + <list type="bulleted"> + <item> + <p>The semantics for boolean operators in guards have + been changed to be more consistent.</p> + <p>All boolean operators will fail if given non-boolean + arguments; '<c><![CDATA[true or garbage]]></c>' used to succeed but + will now fail. Also, failure in the evaluation of + the operands will also cause the guard to fail; + '<c><![CDATA[true or element(1, [])]]></c>' used to succeed but will + now fail.</p> + <p>Semicolon will behave as it used to. If a failure as + described above occurs, evaluation will continue with + the right operand of the semicolon.</p> + <p>*** POTENTIAL INCOMPATIBILITY ***</p> + <p>Own Id: OTP-4623</p> + </item> + <item> + <p><c><![CDATA[-compile(...)]]></c> attributes inside an Erlang module + can now contain compiler options that control warnings + (such as <c><![CDATA[warn_unused_vars]]></c>). They used to be ignored.</p> + <p>Own Id: OTP-4911</p> + </item> + <item> + <p>When a record was updated, and the record given as an + expression (such as function call), the record could be + evaluated more than once.</p> + <p>Own Id: OTP-4933</p> + </item> + <item> + <p>Compilation of modules with long strings could be + extremely slow.</p> + <p>Own Id: OTP-4960 Aux Id: seq8310 </p> + </item> + <item> + <p>In bit syntax matching with clauses having guards, + sometimes the following clauses would never match if a + guard was evaluated (and failed).</p> + <p>Own Id: OTP-4961 Aux Id: seq8338, OTP-4891 </p> + </item> + <item> + <p>Using multiple matching ('=') in the pattern for a + generator in list comprehension would cause an internal + compiler error.</p> + <p>Example:</p> + <code type="none"><![CDATA[ +[3 || {3=4} <- []]. + ]]></code> + <p>Own Id: OTP-5076 Aux Id: OTP-5092 </p> + </item> + <item> + <p>List and string literals, and integer and character + literals were not equivalent in matching as they should + be. For instance, <c><![CDATA[f("a"=[$a])]]></c> would never match.</p> + <p>Own Id: OTP-5092 Aux Id: OTP-5076 </p> + </item> + </list> + </section> + + <section> + <title>Improvements and New Features</title> + <list type="bulleted"> + <item> + <p>The compiler used to warn for definition of functions + having the same name as an auto-imported BIF (such as + <c><![CDATA[size/1]]></c>). In the R10B release, such warnings will + only be emitted if the function is NOT exported (because it + will be impossible to call it). Instead, there will be a + warning for any local call (call without module prefix) + to any (exported) function in the same module that is + also the name of an auto-imported BIF. To avoid the + warning, insert a module prefix (either <c><![CDATA[erlang]]></c> to + call the BIF, or the name of the module to call function in + the module).</p> + <p>Own Id: OTP-4909</p> + </item> + <item> + <p>The unary '+' operator has been changed to throw an + <c><![CDATA[badarith]]></c> exception if its argument is not numeric (or + fail in a guard). It used its argument unchanged whatever + the type. Given the new meaning, unary '+' can now be + used to test whether a term is numeric.</p> + <p>*** POTENTIAL INCOMPATIBILITY ***</p> + <p>Own Id: OTP-4928</p> + </item> + <item> + <p>The compiler now warns for more types of suspect code, + such as expressions that will fail at run-time (such as + <c><![CDATA[atom-42]]></c>), guards that are always false, or + patterns that cannot match.</p> + <p>Own Id: OTP-5098 Aux Id: seq8965, OTP-2456 </p> + </item> + <item> + <p>The long-awaited <c><![CDATA[try]]></c>...<c><![CDATA[catch]]></c> construction + is included in this release. See the reference manual + for how to use it.</p> + <p>Own Id: OTP-5150</p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.2.3</title> + + <section> + <title>Fixed Bugs and Malfunctions</title> + <list type="bulleted"> + <item> + <p>The compiler could generate incorrect code for receive + clauses did not use the message in any way, for instance + if a guard would ignore message depending on some + condition not based on the contents of the message (e.g. + a state variable in the "loop data").</p> + <p>Own Id: OTP-5050</p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.2.2</title> + + <section> + <title>Fixed Bugs and Malfunctions</title> + <list type="bulleted"> + <item> + <p>Compilation of modules with long strings could be + extremely slow.</p> + <p>Own Id: OTP-4960 Aux Id: seq8310 </p> + </item> + <item> + <p>In bit syntax matching with clauses having guards, + sometimes the following clauses would never match if a + guard was evaluated (and failed).</p> + <p>Own Id: OTP-4961 Aux Id: seq8338, OTP-4891 </p> + </item> + <item> + <p>In <c><![CDATA[(Expr)#rec{a=A,b=B}]]></c>, <c><![CDATA[Expr]]></c> would be + evaluated more than once.</p> + <p>Own Id: OTP-4962 Aux Id: seq8292 </p> + </item> + </list> + </section> + </section> + + <section> + <title>Compiler 4.2.1</title> + + <section> + <title>Improvements and New Features</title> + <list type="bulleted"> + <item> + <p>In rare circumstances, the compiler could optimize away + test that would verify that a tuple or record argument + indeed was of the correct type (resulting in an emulator + crash if the argument was not of the correct type/size). + Wrong code could also be generated for floating point + expressions.</p> + <p>Own Id: OTP-4790</p> + </item> + </list> + </section> + </section> +</chapter> + diff --git a/lib/compiler/doc/src/part_notes.xml b/lib/compiler/doc/src/part_notes.xml new file mode 100644 index 0000000000..e730e3f7e2 --- /dev/null +++ b/lib/compiler/doc/src/part_notes.xml @@ -0,0 +1,39 @@ +<?xml version="1.0" encoding="latin1" ?> +<!DOCTYPE part SYSTEM "part.dtd"> + +<part xmlns:xi="http://www.w3.org/2001/XInclude"> + <header> + <copyright> + <year>2004</year><year>2009</year> + <holder>Ericsson AB. All Rights Reserved.</holder> + </copyright> + <legalnotice> + 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. + + </legalnotice> + + <title>Compiler Release Notes</title> + <prepared></prepared> + <docno></docno> + <date>2004-09-07</date> + <rev>1.0</rev> + </header> + <description> + <p>The <em>Compiler</em> application compiles Erlang + code to byte-code. The highly compact byte-code is executed by + the Erlang emulator.</p> + <p>For information about older versions, see + <url href="part_notes_history_frame.html">Release Notes History</url>.</p> + </description> + <xi:include href="notes.xml"/> +</part> + diff --git a/lib/compiler/doc/src/part_notes_history.xml b/lib/compiler/doc/src/part_notes_history.xml new file mode 100644 index 0000000000..cd17c4285e --- /dev/null +++ b/lib/compiler/doc/src/part_notes_history.xml @@ -0,0 +1,39 @@ +<?xml version="1.0" encoding="latin1" ?> +<!DOCTYPE part SYSTEM "part.dtd"> + +<part> + <header> + <copyright> + <year>2006</year> + <year>2007</year> + <holder>Ericsson AB, All Rights Reserved</holder> + </copyright> + <legalnotice> + 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. + + The Initial Developer of the Original Code is Ericsson AB. + </legalnotice> + + <title>Compiler Release Notes History</title> + <prepared></prepared> + <docno></docno> + <date></date> + <rev></rev> + </header> + <description> + <p>The <em>Compiler</em> application compiles Erlang + code to byte-code. The highly compact byte-code is executed by + the Erlang emulator.</p> + </description> + <include file="notes_history"></include> +</part> + diff --git a/lib/compiler/doc/src/ref_man.xml b/lib/compiler/doc/src/ref_man.xml new file mode 100644 index 0000000000..74fe45aa77 --- /dev/null +++ b/lib/compiler/doc/src/ref_man.xml @@ -0,0 +1,38 @@ +<?xml version="1.0" encoding="latin1" ?> +<!DOCTYPE application SYSTEM "application.dtd"> + +<application xmlns:xi="http://www.w3.org/2001/XInclude"> + <header> + <copyright> + <year>1996</year><year>2009</year> + <holder>Ericsson AB. All Rights Reserved.</holder> + </copyright> + <legalnotice> + 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. + + </legalnotice> + + <title>Compiler Reference Manual</title> + <prepared>Robert Virding</prepared> + <docno></docno> + <date>1997-05-02</date> + <rev>1.1.2</rev> + <file>application.sgml</file> + </header> + <description> + <p>The <em>Compiler</em> application compiles Erlang + code to byte-code. The highly compact byte-code is executed by + the Erlang emulator.</p> + </description> + <xi:include href="compile.xml"/> +</application> + diff --git a/lib/compiler/doc/src/user_guide.gif b/lib/compiler/doc/src/user_guide.gif Binary files differnew file mode 100644 index 0000000000..e6275a803d --- /dev/null +++ b/lib/compiler/doc/src/user_guide.gif diff --git a/lib/compiler/doc/src/warning.gif b/lib/compiler/doc/src/warning.gif Binary files differnew file mode 100644 index 0000000000..96af52360e --- /dev/null +++ b/lib/compiler/doc/src/warning.gif diff --git a/lib/compiler/ebin/.gitignore b/lib/compiler/ebin/.gitignore new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/lib/compiler/ebin/.gitignore diff --git a/lib/compiler/info b/lib/compiler/info new file mode 100644 index 0000000000..2005abd54c --- /dev/null +++ b/lib/compiler/info @@ -0,0 +1,3 @@ +group: basic +short: A byte code compiler for Erlang which produces highly compact +short: code diff --git a/lib/compiler/priv/.gitignore b/lib/compiler/priv/.gitignore new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/lib/compiler/priv/.gitignore 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><<em>E1</em>, ..., <em>En</em>></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>#<<em>Value</em>>(<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 +%% <<em>V1</em>, ..., <em>Vn</em>> = <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><<em>P1</em>, ..., <em>Pn</em>> 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 <<em>V1</em>, ..., <em>Vn</em>> -> +%% <em>Body</em> catch <<em>X1</em>, ..., <em>Xm</em>> -> +%% <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 <- Group] +%% || Group <- 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 =< Max +%% =< 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 + diff --git a/lib/compiler/test/Makefile b/lib/compiler/test/Makefile new file mode 100644 index 0000000000..ad2f63e9e5 --- /dev/null +++ b/lib/compiler/test/Makefile @@ -0,0 +1,155 @@ +include $(ERL_TOP)/make/target.mk +include $(ERL_TOP)/make/$(TARGET)/otp.mk + +# ---------------------------------------------------- +# Target Specs +# ---------------------------------------------------- + +MODULES= \ + andor_SUITE \ + apply_SUITE \ + beam_validator_SUITE \ + bs_bincomp_SUITE \ + bs_bit_binaries_SUITE \ + bs_construct_SUITE \ + bs_match_SUITE \ + bs_utf_SUITE \ + core_fold_SUITE \ + compile_SUITE \ + compilation_SUITE \ + core_SUITE \ + error_SUITE \ + float_SUITE \ + fun_SUITE \ + guard_SUITE \ + inline_SUITE \ + lc_SUITE \ + match_SUITE \ + misc_SUITE \ + num_bif_SUITE \ + pmod_SUITE \ + parteval_SUITE \ + receive_SUITE \ + record_SUITE \ + trycatch_SUITE \ + warnings_SUITE \ + test_lib + +NO_OPT= \ + andor \ + apply \ + bs_construct \ + bs_match \ + bs_utf \ + core_fold \ + float \ + fun \ + guard \ + lc \ + match \ + misc \ + num_bif \ + receive \ + record \ + trycatch + +R11= \ + andor \ + apply \ + float \ + fun \ + match \ + num_bif \ + receive \ + record \ + trycatch + +CORE_MODULES = \ + bs_shadowed_size_var \ + nested_call_in_case + + +NO_OPT_MODULES= $(NO_OPT:%=%_no_opt_SUITE) +NO_OPT_ERL_FILES= $(NO_OPT_MODULES:%=%.erl) +POST_OPT_MODULES= $(NO_OPT:%=%_post_opt_SUITE) +POST_OPT_ERL_FILES= $(POST_OPT_MODULES:%=%.erl) +R11_MODULES= $(R11:%=%_r11_SUITE) +R11_ERL_FILES= $(R11_MODULES:%=%.erl) + +ERL_FILES= $(MODULES:%=%.erl) + +CORE_FILES= $(CORE_MODULES:%=%.core) + +##TARGET_FILES= $(MODULES:%=$(EBIN)/%.$(EMULATOR)) +##INSTALL_PROGS= $(TARGET_FILES) + +EMAKEFILE=Emakefile + +# ---------------------------------------------------- +# Release directory specification +# ---------------------------------------------------- +RELSYSDIR = $(RELEASE_PATH)/compiler_test + +# ---------------------------------------------------- +# FLAGS +# ---------------------------------------------------- + +ERL_MAKE_FLAGS += +ERL_COMPILE_FLAGS += -I$(ERL_TOP)/lib/test_server/include +clint + +EBIN = . + +# ---------------------------------------------------- +# Targets +# ---------------------------------------------------- + +make_emakefile: $(NO_OPT_ERL_FILES) $(POST_OPT_ERL_FILES) $(R11_ERL_FILES) + $(ERL_TOP)/make/make_emakefile $(ERL_COMPILE_FLAGS) -o$(EBIN) $(MODULES) \ + > $(EMAKEFILE) + $(ERL_TOP)/make/make_emakefile +no_copt +no_postopt $(ERL_COMPILE_FLAGS) \ + -o$(EBIN) $(NO_OPT_MODULES) >> $(EMAKEFILE) + $(ERL_TOP)/make/make_emakefile +no_copt $(ERL_COMPILE_FLAGS) \ + -o$(EBIN) $(POST_OPT_MODULES) >> $(EMAKEFILE) + $(ERL_TOP)/make/make_emakefile +r11 $(ERL_COMPILE_FLAGS) \ + -o$(EBIN) $(R11_MODULES) >> $(EMAKEFILE) + +tests debug opt: make_emakefile + erl $(ERL_MAKE_FLAGS) -make + +clean: + rm -f $(EMAKEFILE) + rm -f $(TARGET_FILES) + rm -f core + +docs: + +# ---------------------------------------------------- +# Special targets +# ---------------------------------------------------- + +%_no_opt_SUITE.erl: %_SUITE.erl + sed -e 's;-module($(basename $<));-module($(basename $@));' $< > $@ + +%_post_opt_SUITE.erl: %_SUITE.erl + sed -e 's;-module($(basename $<));-module($(basename $@));' $< > $@ + +%_r11_SUITE.erl: %_SUITE.erl + sed -e 's;-module($(basename $<));-module($(basename $@));' $< > $@ + +# ---------------------------------------------------- +# Release Target +# ---------------------------------------------------- +include $(ERL_TOP)/make/otp_release_targets.mk + +release_spec: opt + +release_tests_spec: make_emakefile + $(INSTALL_DIR) $(RELSYSDIR) + $(INSTALL_DATA) compiler.dynspec compiler.cover \ + $(EMAKEFILE) $(ERL_FILES) $(CORE_FILES) $(RELSYSDIR) + $(INSTALL_DATA) $(NO_OPT_ERL_FILES) $(POST_OPT_ERL_FILES) \ + $(R11_ERL_FILES) $(RELSYSDIR) + chmod -f -R u+w $(RELSYSDIR) + @tar cf - *_SUITE_data | (cd $(RELSYSDIR); tar xf -) + +release_docs_spec: diff --git a/lib/compiler/test/andor_SUITE.erl b/lib/compiler/test/andor_SUITE.erl new file mode 100644 index 0000000000..34609a49f2 --- /dev/null +++ b/lib/compiler/test/andor_SUITE.erl @@ -0,0 +1,397 @@ +%% +%% %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% +%% +-module(andor_SUITE). + +-export([all/1, + t_case/1,t_and_or/1,t_andalso/1,t_orelse/1,inside/1,overlap/1, + combined/1,in_case/1]). + +-include("test_server.hrl"). + +all(suite) -> + test_lib:recompile(?MODULE), + [t_case,t_and_or,t_andalso,t_orelse,inside,overlap,combined,in_case]. + +t_case(Config) when is_list(Config) -> + %% We test boolean cases almost but not quite like cases + %% generated by andalso/orelse. + ?line less = t_case_a(1, 2), + ?line not_less = t_case_a(2, 2), + ?line {'EXIT',{{case_clause,false},_}} = (catch t_case_b({x,y,z}, 2)), + ?line {'EXIT',{{case_clause,true},_}} = (catch t_case_b(a, a)), + ?line eq = t_case_c(a, a), + ?line ne = t_case_c(42, []), + ?line t = t_case_d(x, x, true), + ?line f = t_case_d(x, x, false), + ?line f = t_case_d(x, y, true), + ?line {'EXIT',{badarg,_}} = (catch t_case_d(x, y, blurf)), + ?line true = (catch t_case_e({a,b}, {a,b})), + ?line false = (catch t_case_e({a,b}, 42)), + + ?line true = t_case_xy(42, 100, 700), + ?line true = t_case_xy(42, 100, whatever), + ?line false = t_case_xy(42, wrong, 700), + ?line false = t_case_xy(42, wrong, whatever), + + ?line true = t_case_xy(0, whatever, 700), + ?line true = t_case_xy(0, 100, 700), + ?line false = t_case_xy(0, whatever, wrong), + ?line false = t_case_xy(0, 100, wrong), + + ok. + +t_case_a(A, B) -> + case A < B of + [_|_] -> ok; + true -> less; + false -> not_less; + {a,b,c} -> ok; + _Var -> ok + end. + +t_case_b(A, B) -> + case A =:= B of + blurf -> ok + end. + +t_case_c(A, B) -> + case not(A =:= B) of + true -> ne; + false -> eq + end. + +t_case_d(A, B, X) -> + case (A =:= B) and X of + true -> t; + false -> f + end. + +t_case_e(A, B) -> + case A =:= B of + Bool when is_tuple(A) -> id(Bool) + end. + +t_case_xy(X, Y, Z) -> + Res = t_case_x(X, Y, Z), + Res = t_case_y(X, Y, Z). + +t_case_x(X, Y, Z) -> + case abs(X) =:= 42 of + true -> + Y =:= 100; + false -> + Z =:= 700 + end. + +t_case_y(X, Y, Z) -> + case abs(X) =:= 42 of + false -> + Z =:= 700; + true -> + Y =:= 100 + end. + +t_and_or(Config) when is_list(Config) -> + ?line true = true and true, + ?line false = true and false, + ?line false = false and true, + ?line false = false and false, + + ?line true = id(true) and true, + ?line false = id(true) and false, + ?line false = id(false) and true, + ?line false = id(false) and false, + + ?line true = true and id(true), + ?line false = true and id(false), + ?line false = false and id(true), + ?line false = false and id(false), + + ?line true = true or true, + ?line true = true or false, + ?line true = false or true, + ?line false = false or false, + + ?line true = id(true) or true, + ?line true = id(true) or false, + ?line true = id(false) or true, + ?line false = id(false) or false, + + ?line true = true or id(true), + ?line true = true or id(false), + ?line true = false or id(true), + ?line false = false or id(false), + + ok. + +t_andalso(Config) when is_list(Config) -> + Bs = [true,false], + Ps = [{X,Y} || X <- Bs, Y <- Bs], + lists:foreach(fun (P) -> t_andalso_1(P) end, Ps), + + ?line true = true andalso true, + ?line false = true andalso false, + ?line false = false andalso true, + ?line false = false andalso false, + + ?line false = false andalso glurf, + ?line false = false andalso exit(exit_now), + + ?line true = not id(false) andalso not id(false), + ?line false = not id(false) andalso not id(true), + ?line false = not id(true) andalso not id(false), + ?line false = not id(true) andalso not id(true), + + ?line {'EXIT',{badarg,_}} = (catch not id(glurf) andalso id(true)), + ?line {'EXIT',{badarg,_}} = (catch not id(false) andalso not id(glurf)), + ?line false = id(false) andalso not id(glurf), + ?line false = false andalso not id(glurf), + + ok. + +t_orelse(Config) when is_list(Config) -> + Bs = [true,false], + Ps = [{X,Y} || X <- Bs, Y <- Bs], + lists:foreach(fun (P) -> t_orelse_1(P) end, Ps), + + ?line true = true orelse true, + ?line true = true orelse false, + ?line true = false orelse true, + ?line false = false orelse false, + + ?line true = true orelse glurf, + ?line true = true orelse exit(exit_now), + + ?line true = not id(false) orelse not id(false), + ?line true = not id(false) orelse not id(true), + ?line true = not id(true) orelse not id(false), + ?line false = not id(true) orelse not id(true), + + ?line {'EXIT',{badarg,_}} = (catch not id(glurf) orelse id(true)), + ?line {'EXIT',{badarg,_}} = (catch not id(true) orelse not id(glurf)), + ?line true = id(true) orelse not id(glurf), + ?line true = true orelse not id(glurf), + + ok. + +t_andalso_1({X,Y}) -> + io:fwrite("~w andalso ~w: ",[X,Y]), + V1 = echo(X) andalso echo(Y), + V1 = if + X andalso Y -> true; + true -> false + end, + check(V1, X and Y). + +t_orelse_1({X,Y}) -> + io:fwrite("~w orelse ~w: ",[X,Y]), + V1 = echo(X) orelse echo(Y), + V1 = if + X orelse Y -> true; + true -> false + end, + check(V1, X or Y). + +inside(Config) when is_list(Config) -> + ?line true = inside(-8, 1), + ?line false = inside(-53.5, -879798), + ?line false = inside(1.0, -879), + ?line false = inside(59, -879), + ?line false = inside(-11, 1.0), + ?line false = inside(100, 0.2), + ?line false = inside(100, 1.2), + ?line false = inside(-53.5, 4), + ?line false = inside(1.0, 5.3), + ?line false = inside(59, 879), + ok. + +inside(Xm, Ym) -> + X = -10.0, + Y = -2.0, + W = 20.0, + H = 4.0, + Res = inside(Xm, Ym, X, Y, W, H), + Res = if + X =< Xm andalso Xm < X+W andalso Y =< Ym andalso Ym < Y+H -> true; + true -> false + end, + case not id(Res) of + Outside -> + Outside = if + not(X =< Xm andalso Xm < X+W andalso Y =< Ym andalso Ym < Y+H) -> true; + true -> false + end + end, + {Res,Xm,Ym,X,Y,W,H} = inside_guard(Xm, Ym, X, Y, W, H), + io:format("~p =< ~p andalso ~p < ~p andalso ~p =< ~p andalso ~p < ~p ==> ~p", + [X,Xm,Xm,X+W,Y,Ym,Ym,Y+H,Res]), + Res. + +inside(Xm, Ym, X, Y, W, H) -> + X =< Xm andalso Xm < X+W andalso Y =< Ym andalso Ym < Y+H. + +inside_guard(Xm, Ym, X, Y, W, H) when X =< Xm andalso Xm < X+W + andalso Y =< Ym andalso Ym < Y+H -> + {true,Xm,Ym,X,Y,W,H}; +inside_guard(Xm, Ym, X, Y, W, H) -> + {false,Xm,Ym,X,Y,W,H}. + +overlap(Config) when is_list(Config) -> + ?line true = overlap(7.0, 2.0, 8.0, 0.5), + ?line true = overlap(7.0, 2.0, 8.0, 2.5), + ?line true = overlap(7.0, 2.0, 5.3, 2), + ?line true = overlap(7.0, 2.0, 0.0, 100.0), + + ?line false = overlap(-1, 2, -35, 0.5), + ?line false = overlap(-1, 2, 777, 0.5), + ?line false = overlap(-1, 2, 2, 10), + ?line false = overlap(2, 10, 12, 55.3), + ok. + +overlap(Pos1, Len1, Pos2, Len2) -> + Res = case Pos1 of + Pos1 when (Pos2 =< Pos1 andalso Pos1 < Pos2+Len2) + orelse (Pos1 =< Pos2 andalso Pos2 < Pos1+Len1) -> + true; + Pos1 -> false + end, + Res = (Pos2 =< Pos1 andalso Pos1 < Pos2+Len2) + orelse (Pos1 =< Pos2 andalso Pos2 < Pos1+Len1), + Res = case Pos1 of + Pos1 when (Pos2 =< Pos1 andalso Pos1 < Pos2+Len2) + orelse (Pos1 =< Pos2 andalso Pos2 < Pos1+Len1) -> + true; + Pos1 -> false + end, + id(Res). + + +-define(COMB(A,B,C), (A andalso B orelse C)). + +combined(Config) when is_list(Config) -> + ?line false = comb(false, false, false), + ?line true = comb(false, false, true), + ?line false = comb(false, true, false), + ?line true = comb(false, true, true), + + ?line false = comb(true, false, false), + ?line true = comb(true, true, false), + ?line true = comb(true, false, true), + ?line true = comb(true, true, true), + + ?line false = comb(false, blurf, false), + ?line true = comb(false, blurf, true), + ?line true = comb(true, true, blurf), + + ?line false = ?COMB(false, false, false), + ?line true = ?COMB(false, false, true), + ?line false = ?COMB(false, true, false), + ?line true = ?COMB(false, true, true), + + ?line false = ?COMB(true, false, false), + ?line true = ?COMB(true, true, false), + ?line true = ?COMB(true, false, true), + ?line true = ?COMB(true, true, true), + + ?line false = ?COMB(false, blurf, false), + ?line true = ?COMB(false, blurf, true), + ?line true = ?COMB(true, true, blurf), + + ok. +-undef(COMB). + +comb(A, B, C) -> + Res = A andalso B orelse C, + Res = if + A andalso B orelse C -> true; + true -> false + end, + NotRes = if + not(A andalso B orelse C) -> true; + true -> false + end, + NotRes = id(not Res), + Res = A andalso B orelse C, + Res = if + A andalso B orelse C -> true; + true -> false + end, + NotRes = id(not Res), + Res = if + A andalso B orelse C -> true; + true -> false + end, + id(Res). + +%% Test that a boolean expression in a case expression is properly +%% optimized (in particular, that the error behaviour is correct). +in_case(Config) when is_list(Config) -> + ?line edge_rings = in_case_1(1, 1, 1, 1, 1), + ?line not_loop = in_case_1(0.5, 1, 1, 1, 1), + ?line loop = in_case_1(0.5, 0.9, 1.1, 1, 4), + ?line {'EXIT',{badarith,_}} = (catch in_case_1(1, 1, 1, 1, 0)), + ?line {'EXIT',{badarith,_}} = (catch in_case_1(1, 1, 1, 1, nan)), + ?line {'EXIT',{badarg,_}} = (catch in_case_1(1, 1, 1, blurf, 1)), + ?line {'EXIT',{badarith,_}} = (catch in_case_1([nan], 1, 1, 1, 1)), + ok. + +in_case_1(LenUp, LenDw, LenN, Rotation, Count) -> + Res = in_case_1_body(LenUp, LenDw, LenN, Rotation, Count), + Res = in_case_1_guard(LenUp, LenDw, LenN, Rotation, Count), + Res. + +in_case_1_body(LenUp, LenDw, LenN, Rotation, Count) -> + case (LenUp/Count > 0.707) and (LenN/Count > 0.707) and + (abs(Rotation) > 0.707) of + true -> + edge_rings; + false -> + case (LenUp >= 1) or (LenDw >= 1) or + (LenN =< 1) or (Count < 4) of + true -> + not_loop; + false -> + loop + end + end. + +in_case_1_guard(LenUp, LenDw, LenN, Rotation, Count) -> + case (LenUp/Count > 0.707) andalso (LenN/Count > 0.707) andalso + (abs(Rotation) > 0.707) of + true -> edge_rings; + false when LenUp >= 1 orelse LenDw >= 1 orelse + LenN =< 1 orelse Count < 4 -> not_loop; + false -> loop + end. + +check(V1, V0) -> + if V1 /= V0 -> + io:fwrite("error: ~w.\n", [V1]), + ?t:fail(); + true -> + io:fwrite("ok: ~w.\n", [V1]) + end. + +echo(X) -> + io:fwrite("eval(~w); ",[X]), + X. + +id(I) -> I. + + diff --git a/lib/compiler/test/apply_SUITE.erl b/lib/compiler/test/apply_SUITE.erl new file mode 100644 index 0000000000..f23dd6c2db --- /dev/null +++ b/lib/compiler/test/apply_SUITE.erl @@ -0,0 +1,107 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2005-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(apply_SUITE). + +-export([all/1,mfa/1,fun_apply/1]). + +-export([foo/0,bar/1,baz/2]). + +-include("test_server.hrl"). + +all(suite) -> + test_lib:recompile(?MODULE), + [mfa,fun_apply]. + +-define(APPLY0(M, F), (fun(Res) -> Res = M:F() end)(apply(M, F, []))). +-define(APPLY1(M, F, A1), (fun(Res) -> Res = M:F(A1) end)(apply(M, F, [A1]))). +-define(APPLY2(M, F, A1, A2), (fun(Res) -> Res = M:F(A1, A2) end)(apply(M, F, [A1,A2]))). + +mfa(Config) when is_list(Config) -> + ?line ok = ?APPLY0(?MODULE, foo), + ?line {[a,b]} = ?APPLY1(?MODULE, bar, [a,b]), + ?line {39,{a}} = ?APPLY2(?MODULE, baz, 39, {a}), + + ?line Mod = id(?MODULE), + ?line ok = ?APPLY0(Mod, foo), + ?line {[a,b]} = ?APPLY1(Mod, bar, [a,b]), + ?line {39,{a}} = ?APPLY2(Mod, baz, 39, {a}), + + ?line ok = ?APPLY0(?MODULE, (id(foo))), + ?line {[a,b]} = ?APPLY1(?MODULE, (id(bar)), [a,b]), + ?line {39,{a}} = ?APPLY2(?MODULE, (id(baz)), 39, {a}), + + ?line ok = ?APPLY0(Mod, (id(foo))), + ?line {[a,b]} = ?APPLY1(Mod, (id(bar)), [a,b]), + ?line {39,{a}} = ?APPLY2(Mod, (id(baz)), 39, {a}), + + ?line {'EXIT',_} = (catch ?APPLY2(Mod, (id(bazzzzzz)), a, b)), + ?line {'EXIT',_} = (catch ?APPLY2({}, baz, a, b)), + ?line {'EXIT',_} = (catch ?APPLY2(?MODULE, [], a, b)), + + ?line ok = apply(Mod, foo, id([])), + ?line {[a,b|c]} = apply(Mod, bar, id([[a,b|c]])), + ?line {[xx],{a}} = apply(?MODULE, baz, id([[xx],{a}])), + + ?line Erlang = id(erlang), + ?line Self = self(), + ?line Self = ?APPLY0(Erlang, self), + ?line 42.0 = ?APPLY1(Erlang, abs, -42.0), + ?line b = ?APPLY2(Erlang, element, 2, {a,b,c}), + ?line true = ?APPLY1(Erlang, is_function, fun erlang:list_to_binary/1), + ?line true = ?APPLY1(Erlang, is_function, fun() -> ok end), + ?line false = ?APPLY1(Erlang, is_function, blurf), + ?line true = ?APPLY2(Erlang, is_function, fun erlang:list_to_binary/1, 1), + ?line true = ?APPLY2(Erlang, is_function, fun() -> ok end, 0), + ?line false = ?APPLY2(Erlang, is_function, blurf, 0), + + ?line apply(Mod, foo, []). + +foo() -> + ok. + +bar(A) -> + {A}. + +baz(A, B) -> + {A,B}. + +-define(FUNAPPLY0(F), (fun(Res) -> Res = F() end)(apply(F, []))). +-define(FUNAPPLY1(F, A1), (fun(Res) -> Res = F(A1) end)(apply(F, [A1]))). +-define(FUNAPPLY2(F, A1, A2), (fun(Res) -> Res = F(A1, A2) end)(apply(F, [A1,A2]))). + +fun_apply(Config) when is_list(Config) -> + ?line Self = self(), + + ?line Self = ?FUNAPPLY0(fun() -> self() end), + ?line Self = ?FUNAPPLY0((id(fun() -> self() end))), + ?line ok = ?FUNAPPLY0(fun ?MODULE:foo/0), + ?line ok = ?FUNAPPLY0((id(fun ?MODULE:foo/0))), + + ?line -42 = ?FUNAPPLY1(fun(A) -> -A end, 42), + ?line [x,yy] = ?FUNAPPLY1((id(fun(T) -> [x|T] end)), [yy]), + ?line {[a|b]} = ?FUNAPPLY1(fun ?MODULE:bar/1, [a|b]), + ?line {[a|b]} = ?FUNAPPLY1((id(fun ?MODULE:bar/1)), [a|b]), + + ?line {a,b} = ?FUNAPPLY2(fun(A, B) -> {A,B} end, a, b), + ?line {a,[b]} = ?FUNAPPLY2((id(fun(A, B) -> {A,B} end)), a, [b]), + ?line {42,{a}} = ?FUNAPPLY2((id(fun ?MODULE:baz/2)), 42, {a}), + + ok. + +id(I) -> I. diff --git a/lib/compiler/test/beam_validator_SUITE.erl b/lib/compiler/test/beam_validator_SUITE.erl new file mode 100644 index 0000000000..ef8feb8a27 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE.erl @@ -0,0 +1,375 @@ +%% +%% %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_SUITE). + +-export([all/1,init_per_testcase/2,fin_per_testcase/2, + beam_files/1,compiler_bug/1,stupid_but_valid/1, + xrange/1,yrange/1,stack/1,call_last/1,merge_undefined/1, + uninit/1,unsafe_catch/1, + dead_code/1,mult_labels/1, + overwrite_catchtag/1,overwrite_trytag/1,accessing_tags/1,bad_catch_try/1, + cons_guard/1, + freg_range/1,freg_uninit/1,freg_state/1, + bin_match/1,bin_aligned/1,bad_dsetel/1, + state_after_fault_in_catch/1,no_exception_in_catch/1, + undef_label/1,illegal_instruction/1]). + +-include("test_server.hrl"). + +init_per_testcase(Case, Config) when is_atom(Case), is_list(Config) -> + Dog = test_server:timetrap(?t:minutes(10)), + [{watchdog,Dog}|Config]. + +fin_per_testcase(Case, Config) when is_atom(Case), is_list(Config) -> + Dog = ?config(watchdog, Config), + ?t:timetrap_cancel(Dog), + ok. + +all(suite) -> + test_lib:recompile(?MODULE), + [beam_files,compiler_bug,stupid_but_valid, + xrange,yrange,stack,call_last,merge_undefined, + uninit,unsafe_catch, + dead_code,mult_labels, + overwrite_catchtag,overwrite_trytag,accessing_tags,bad_catch_try, + cons_guard, + freg_range,freg_uninit,freg_state, + bin_match,bin_aligned, + bad_dsetel,state_after_fault_in_catch,no_exception_in_catch, + undef_label,illegal_instruction]. + +beam_files(Config) when is_list(Config) -> + ?line {ok,Cwd} = file:get_cwd(), + ?line Parent = filename:dirname(Cwd), + ?line Wc = filename:join([Parent,"*","*.beam"]), + %% Must have at least two files here, or there will could be + %% a grammatical error in the output of the io:format/2 call below. ;-) + ?line [_,_|_] = Fs = filelib:wildcard(Wc), + ?line io:format("~p files\n", [length(Fs)]), + beam_files_1(Fs, 0). + +beam_files_1([F|Fs], Errors) -> + ?line case beam_validator:file(F) of + ok -> + beam_files_1(Fs, Errors); + {error,Es} -> + io:format("File: ~s", [F]), + io:format("Error: ~p\n", [Es]), + beam_files_1(Fs, Errors+1) + end; +beam_files_1([], 0) -> ok; +beam_files_1([], Errors) -> + ?line io:format("~p error(s)", [Errors]), + ?line ?t:fail(). + +compiler_bug(Config) when is_list(Config) -> + %% Check that the compiler returns an error if we try to + %% assemble one of the bad '.S' files. + ?line Data = ?config(data_dir, Config), + ?line File = filename:join(Data, "stack"), + ?line error = compile:file(File, [asm,report_errors,binary,time]), + ok. + +%% The following code is stupid but it should compile. +stupid_but_valid(Config) when is_list(Config) -> + AnAtom = nisse, + ?line try setelement(5, setelement(6, AnAtom, value), another_value) of + Term -> ?line ?t:fail({what_happened,Term}) + catch + error:badarg -> ok + end, + ok. + +xrange(Config) when is_list(Config) -> + Errors = do_val(xrange, Config), + ?line + [{{t,sum_1,2}, + {{bif,'+',{f,0},[{x,-1},{x,1}],{x,0}},4, + {uninitialized_reg,{x,-1}}}}, + {{t,sum_2,2}, + {{bif,'+',{f,0},[{x,0},{x,1024}],{x,0}},4, + {uninitialized_reg,{x,1024}}}}, + {{t,sum_3,2}, + {{bif,'+',{f,0},[{x,0},{x,1}],{x,-1}},4, + {invalid_store,{x,-1},number}}}, + {{t,sum_4,2}, + {{bif,'+',{f,0},[{x,0},{x,1}],{x,1024}},4,limit}}] = Errors, + ok. + +yrange(Config) when is_list(Config) -> + Errors = do_val(yrange, Config), + ?line + [{{t,sum_1,2}, + {{move,{x,1},{y,-1}},5, + {invalid_store,{y,-1},term}}}, + {{t,sum_2,2}, + {{bif,'+',{f,0},[{x,0},{y,1024}],{x,0}},8, + {uninitialized_reg,{y,1024}}}}, + {{t,sum_3,2}, + {{move,{x,1},{y,1024}},5,limit}}, + {{t,sum_4,2}, + {{move,{x,1},{y,-1}},5, + {invalid_store,{y,-1},term}}}] = Errors, + ok. + +stack(Config) when is_list(Config) -> + Errors = do_val(stack, Config), + ?line [{{t,a,2},{return,11,{stack_frame,2}}}, + {{t,b,2},{{deallocate,2},4,{allocated,none}}}, + {{t,c,2},{{deallocate,2},12,{allocated,none}}}, + {{t,d,2}, + {{allocate,2,2},5,{existing_stack_frame,{size,2}}}}, + {{t,e,2},{{deallocate,5},6,{allocated,2}}}, + {{t,bad_1,0},{{allocate_zero,2,10},4,{{x,9},not_live}}}, + {{t,bad_2,0},{{move,{y,0},{x,0}},5,{unassigned,{y,0}}}}] = Errors, + ok. + +call_last(Config) when is_list(Config) -> + Errors = do_val(call_last, Config), + ?line [{{t,a,1},{{call_last,1,{f,8},2},11,{allocated,1}}}, + {{t,b,1}, + {{call_ext_last,2,{extfunc,lists,seq,2},2}, + 11, + {allocated,1}}}] = Errors, + ok. + +merge_undefined(Config) when is_list(Config) -> + Errors = do_val(merge_undefined, Config), + ?line [{{t,handle_call,2}, + {{call_ext,2,{extfunc,debug,filter,2}}, + 22, + {uninitialized_reg,{y,0}}}}] = Errors, + ok. + +uninit(Config) when is_list(Config) -> + Errors = do_val(uninit, Config), + ?line + [{{t,sum_1,2}, + {{move,{y,0},{x,0}},5,{uninitialized_reg,{y,0}}}}, + {{t,sum_2,2}, + {{call,1,{f,10}},6,{uninitialized_reg,{y,0}}}}, + {{t,sum_3,2}, + {{bif,'+',{f,0},[{x,0},{y,0}],{x,0}}, + 7, + {unassigned,{y,0}}}}] = Errors, + ok. + +unsafe_catch(Config) when is_list(Config) -> + Errors = do_val(unsafe_catch, Config), + ?line + [{{t,small,2}, + {{bs_put_integer,{f,0},{integer,16},1, + {field_flags,[aligned,unsigned,big]},{y,0}}, + 20, + {unassigned,{y,0}}}}] = Errors, + ok. + +dead_code(Config) when is_list(Config) -> + [] = do_val(dead_code, Config), + ok. + +mult_labels(Config) when is_list(Config) -> + [] = do_val(erl_prim_loader, Config, ".beam"), + ok. + +overwrite_catchtag(Config) when is_list(Config) -> + Errors = do_val(overwrite_catchtag, Config), + ?line + [{{overwrite_catchtag,foo,1}, + {{move,{x,0},{y,0}},6,{catchtag,_}}}] = Errors, + ok. + +overwrite_trytag(Config) when is_list(Config) -> + Errors = do_val(overwrite_trytag, Config), + ?line + [{{overwrite_trytag,foo,1}, + {{kill,{y,2}},9,{trytag,_}}}] = Errors, + ok. + +accessing_tags(Config) when is_list(Config) -> + Errors = do_val(accessing_tags, Config), + ?line + [{{accessing_tags,foo,1}, + {{move,{y,0},{x,0}},6,{catchtag,_}}}, + {{accessing_tags,bar,1}, + {{move,{y,0},{x,0}},6,{trytag,_}}}] = Errors, + ok. + +bad_catch_try(Config) when is_list(Config) -> + Errors = do_val(bad_catch_try, Config), + ?line [{{bad_catch_try,bad_1,1}, + {{'catch',{x,0},{f,3}}, + 5,{invalid_store,{x,0},{catchtag,[3]}}}}, + {{bad_catch_try,bad_2,1}, + {{catch_end,{x,9}}, + 8,{source_not_y_reg,{x,9}}}}, + {{bad_catch_try,bad_3,1}, + {{catch_end,{y,1}},9,{bad_type,{atom,kalle}}}}, + {{bad_catch_try,bad_4,1}, + {{'try',{x,0},{f,15}},5,{invalid_store,{x,0},{trytag,[15]}}}}, + {{bad_catch_try,bad_5,1}, + {{try_case,{y,1}},12,{bad_type,term}}}, + {{bad_catch_try,bad_6,1}, + {{try_end,{y,1}},8,{bad_type,{integer,1}}}}] = Errors, + ok. + +cons_guard(Config) when is_list(Config) -> + Errors = do_val(cons, Config), + ?line + [{{cons,foo,1}, + {{get_list,{x,0},{x,1},{x,2}}, + 5, + {bad_type,{needed,cons},{actual,term}}}}] = Errors, + ok. + +freg_range(Config) when is_list(Config) -> + Errors = do_val(freg_range, Config), + ?line + [{{t,sum_1,2}, + {{bif,fadd,{f,0},[{fr,-1},{fr,1}],{fr,0}}, + 5, + {bad_source,{fr,-1}}}}, + {{t,sum_2,2}, + {{bif,fadd,{f,0},[{fr,0},{fr,1024}],{fr,0}}, + 6, + {uninitialized_reg,{fr,1024}}}}, + {{t,sum_3,2}, + {{bif,fadd,{f,0},[{fr,0},{fr,1}],{fr,-1}}, + 7, + {bad_target,{fr,-1}}}}, + {{t,sum_4,2}, + {{bif,fadd,{f,0},[{fr,0},{fr,1}],{fr,1024}}, + 7, + limit}}] = Errors, + ok. + +freg_uninit(Config) when is_list(Config) -> + Errors = do_val(freg_uninit, Config), + ?line + [{{t,sum_1,2}, + {{bif,fadd,{f,0},[{fr,0},{fr,1}],{fr,0}}, + 6, + {uninitialized_reg,{fr,1}}}}, + {{t,sum_2,2}, + {{bif,fadd,{f,0},[{fr,0},{fr,1}],{fr,0}}, + 9, + {uninitialized_reg,{fr,0}}}}] = Errors, + ok. + +freg_state(Config) when is_list(Config) -> + Errors = do_val(freg_state, Config), + ?line + [{{t,sum_1,2}, + {{bif,fmul,{f,0},[{fr,0},{fr,1}],{fr,0}}, + 6, + {bad_floating_point_state,undefined}}}, + {{t,sum_2,2}, + {{fmove,{fr,0},{x,0}}, + 8, + {bad_floating_point_state,cleared}}}, + {{t,sum_3,2}, + {{bif,'-',{f,0},[{x,1},{x,0}],{x,1}}, + 8, + {unsafe_instruction,{float_error_state,cleared}}}}, + {{t,sum_4,2}, + {{fcheckerror,{f,0}}, + 4, + {bad_floating_point_state,undefined}}}, + {{t,sum_5,2}, + {fclearerror,5,{bad_floating_point_state,cleared}}}] = Errors, + ok. + +bin_match(Config) when is_list(Config) -> + Errors = do_val(bin_match, Config), + ?line + [{{t,t,1},{{bs_save,0},4,no_bs_match_state}}, + {{t,x,1},{{bs_restore,1},16,{no_save_point,1}}}] = Errors, + ok. + +bin_aligned(Config) when is_list(Config) -> + Errors = do_val(bin_aligned, Config), + ?line + [{{t,decode,1}, + {{bs_put_integer,{f,0}, + {integer,5}, + 1, + {field_flags,[unsigned,big,aligned]}, + {integer,0}}, + 10, + {aligned_flag_set,{bits,3}}}}] = Errors, + ok. + +bad_dsetel(Config) when is_list(Config) -> + Errors = do_val(bad_dsetel, Config), + ?line + [{{t,t,1}, + {{set_tuple_element,{x,1},{x,0},1}, + 15, + illegal_context_for_set_tuple_element}}] = Errors, + ok. + +state_after_fault_in_catch(Config) when is_list(Config) -> + Errors = do_val(state_after_fault_in_catch, Config), + [{{t,foo,1}, + {{move,{x,1},{x,0}},10,{uninitialized_reg,{x,1}}}}, + {{state_after_fault_in_catch,if_end,1}, + {{move,{x,1},{x,0}},9,{uninitialized_reg,{x,1}}}}, + {{state_after_fault_in_catch,case_end,1}, + {{move,{x,1},{x,0}},9,{uninitialized_reg,{x,1}}}}, + {{state_after_fault_in_catch,badmatch,1}, + {{move,{x,1},{x,0}},9,{uninitialized_reg,{x,1}}}}] = Errors, + ok. + +no_exception_in_catch(Config) when is_list(Config) -> + Errors = do_val(no_exception_in_catch, Config), + [{{no_exception_in_catch,nested_of_1,4}, + {{move,{x,3},{x,0}},91,{uninitialized_reg,{x,3}}}}] = Errors, + ok. + +undef_label(Config) when is_list(Config) -> + Errors = do_val(undef_label, Config), + [{{undef_label,t,1},{undef_labels,[42]}}, + {{undef_label,x,1},{return,4,no_entry_label}}] = Errors, + ok. + +illegal_instruction(Config) when is_list(Config) -> + Errors = do_val(illegal_instruction, Config), + [{{illegal_instruction,t,1}, + {{my_illegal_instruction,{x,0}},4,unknown_instruction}}, + {{'_',x,1},{bad_func_info,1,illegal_instruction}}, + {{'_',y,0},{[],0,illegal_instruction}}] = Errors, + ok. + + + +%%%------------------------------------------------------------------------- + +do_val(Name, Config) -> + do_val(Name, Config, ".S"). + +do_val(Name, Config, Type) -> + ?line Data = ?config(data_dir, Config), + ?line File = filename:join(Data, atom_to_list(Name)++Type), + ?line case beam_validator:file(File) of + {error,Errors} -> + ?line io:format("~p:~n~s", + [File,beam_validator:format_error(Errors)]), + Errors; + ok -> [] + end. diff --git a/lib/compiler/test/beam_validator_SUITE_data/accessing_tags.S b/lib/compiler/test/beam_validator_SUITE_data/accessing_tags.S new file mode 100644 index 0000000000..2728a2fa32 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/accessing_tags.S @@ -0,0 +1,31 @@ +{module, accessing_tags}. %% version = 0 + +{exports, [{foo,1},{bar,1}]}. + +{attributes, []}. + +{function, foo, 1, 2}. + {label,1}. + {func_info,{atom,accessing_tags},{atom,foo},1}. + {label,2}. + {allocate,1,1}. + {'catch',{y,0},{f,3}}. + {move,{y,0},{x,0}}. %Retrieve the catch tag. + {call,1,{f,2}}. + {label,3}. + {catch_end,{y,0}}. + {deallocate,1}. + return. + +{function, bar, 1, 5}. + {label,4}. + {func_info,{atom,accessing_tags},{atom,bar},1}. + {label,5}. + {allocate,1,1}. + {'try',{y,0},{f,6}}. + {move,{y,0},{x,0}}. %Retrieve the try tag. + {call,5,{f,2}}. + {label,6}. + {catch_end,{y,0}}. + {deallocate,1}. + return. diff --git a/lib/compiler/test/beam_validator_SUITE_data/bad_catch_try.S b/lib/compiler/test/beam_validator_SUITE_data/bad_catch_try.S new file mode 100644 index 0000000000..2a53f0dd93 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/bad_catch_try.S @@ -0,0 +1,168 @@ +{module, bad_catch_try}. %% version = 0 + +{exports, [{bad_1,1}, + {bad_2,1}, + {bad_3,1}, + {bad_4,1}, + {bad_5,1}, + {bad_6,1}, + {foo,1}, + {module_info,0}, + {module_info,1}]}. + +{attributes, []}. + +{labels, 31}. + + +{function, bad_1, 1, 2}. + {label,1}. + {func_info,{atom,bad_catch_try},{atom,bad_1},1}. + {label,2}. + {allocate,1,1}. + {'catch',{x,0},{f,3}}. + {call,1,{f,26}}. + {label,3}. + {catch_end,{x,0}}. + {test,is_tuple,{f,4},[{x,0}]}. + {test,test_arity,{f,4},[{x,0},2]}. + {get_tuple_element,{x,0},0,{x,1}}. + {test,is_eq_exact,{f,4},[{x,1},{atom,'EXIT'}]}. + {move,{atom,error},{x,0}}. + {deallocate,1}. + return. + {label,4}. + {move,{atom,ok},{x,0}}. + {deallocate,1}. + return. + + +{function, bad_2, 1, 6}. + {label,5}. + {func_info,{atom,bad_catch_try},{atom,bad_2},1}. + {label,6}. + {allocate,1,1}. + {'catch',{y,0},{f,7}}. + {call,1,{f,26}}. + {label,7}. + {catch_end,{x,9}}. + {test,is_tuple,{f,8},[{x,0}]}. + {test,test_arity,{f,8},[{x,0},2]}. + {get_tuple_element,{x,0},0,{x,1}}. + {test,is_eq_exact,{f,8},[{x,1},{atom,'EXIT'}]}. + {move,{atom,error},{x,0}}. + {deallocate,1}. + return. + {label,8}. + {move,{atom,ok},{x,0}}. + {deallocate,1}. + return. + + +{function, bad_3, 1, 10}. + {label,9}. + {func_info,{atom,bad_catch_try},{atom,bad_3},1}. + {label,10}. + {allocate,1,1}. + {'catch',{y,0},{f,11}}. + {call,1,{f,26}}. + {label,11}. + {move,{atom,kalle},{y,1}}. + {catch_end,{y,1}}. + {test,is_tuple,{f,12},[{x,0}]}. + {test,test_arity,{f,12},[{x,0},2]}. + {get_tuple_element,{x,0},0,{x,1}}. + {test,is_eq_exact,{f,12},[{x,1},{atom,'EXIT'}]}. + {move,{atom,error},{x,0}}. + {deallocate,1}. + return. + {label,12}. + {move,{atom,ok},{x,0}}. + {deallocate,1}. + return. + + +{function, bad_4, 1, 14}. + {label,13}. + {func_info,{atom,bad_catch_try},{atom,bad_4},1}. + {label,14}. + {allocate_zero,1,1}. + {'try',{x,0},{f,15}}. + {call,1,{f,26}}. + {try_end,{y,0}}. + {move,{atom,ok},{x,0}}. + {jump,{f,16}}. + {label,15}. + {try_case,{y,0}}. + {test,is_ne_exact,{f,16},[{x,0},{atom,error}]}. + {bif,raise,{f,0},[{x,2},{x,1}],{x,0}}. + {'%live',1}. + {label,16}. + {deallocate,1}. + return. + + +{function, bad_5, 1, 18}. + {label,17}. + {func_info,{atom,bad_catch_try},{atom,bad_5},1}. + {label,18}. + {allocate_zero,1,1}. + {'try',{y,0},{f,19}}. + {call,1,{f,26}}. + {try_end,{y,0}}. + {move,{atom,ok},{x,0}}. + {jump,{f,20}}. + {label,19}. + {move,{x,0},{y,1}}. + {try_case,{y,1}}. + {test,is_ne_exact,{f,20},[{x,0},{atom,error}]}. + {bif,raise,{f,0},[{x,2},{x,1}],{x,0}}. + {'%live',1}. + {label,20}. + {deallocate,1}. + return. + + +{function, bad_6, 1, 22}. + {label,21}. + {func_info,{atom,bad_catch_try},{atom,bad_6},1}. + {label,22}. + {allocate_zero,1,1}. + {'try',{y,0},{f,23}}. + {call,1,{f,26}}. + {move,{integer,1},{y,1}}. + {try_end,{y,1}}. + {move,{atom,ok},{x,0}}. + {jump,{f,24}}. + {label,23}. + {try_case,{y,0}}. + {test,is_ne_exact,{f,24},[{x,0},{atom,error}]}. + {bif,raise,{f,0},[{x,2},{x,1}],{x,0}}. + {'%live',1}. + {label,24}. + {deallocate,1}. + return. + + +{function, foo, 1, 26}. + {label,25}. + {func_info,{atom,bad_catch_try},{atom,foo},1}. + {label,26}. + return. + + +{function, module_info, 0, 28}. + {label,27}. + {func_info,{atom,bad_catch_try},{atom,module_info},0}. + {label,28}. + {move,{atom,bad_catch_try},{x,0}}. + {call_ext_only,1,{extfunc,erlang,get_module_info,1}}. + + +{function, module_info, 1, 30}. + {label,29}. + {func_info,{atom,bad_catch_try},{atom,module_info},1}. + {label,30}. + {move,{x,0},{x,1}}. + {move,{atom,bad_catch_try},{x,0}}. + {call_ext_only,2,{extfunc,erlang,get_module_info,2}}. diff --git a/lib/compiler/test/beam_validator_SUITE_data/bad_dsetel.S b/lib/compiler/test/beam_validator_SUITE_data/bad_dsetel.S new file mode 100644 index 0000000000..279b2fa97f --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/bad_dsetel.S @@ -0,0 +1,52 @@ +{module, t}. %% version = 0 + +{exports, [{module_info,0},{module_info,1},{t,1}]}. + +{attributes, []}. + +{labels, 8}. + + +{function, t, 1, 2}. + {label,1}. + {func_info,{atom,t},{atom,t},1}. + {label,2}. + {test,is_tuple,{f,3},[{x,0}]}. + {test,test_arity,{f,3},[{x,0},7]}. + {get_tuple_element,{x,0},0,{x,1}}. + {test,is_eq_exact,{f,3},[{x,1},{atom,r}]}. + {allocate,0,1}. + {move,{x,0},{x,1}}. + {move,{integer,1},{x,2}}. + {move,{integer,3},{x,0}}. + {call_ext,3,{extfunc,erlang,setelement,3}}. + {test_heap,6,1}. + {put_string,3,{string,"abc"},{x,1}}. + {set_tuple_element,{x,1},{x,0},1}. + {'%live',1}. + {deallocate,0}. + return. + {label,3}. + {test_heap,3,0}. + {put_tuple,2,{x,0}}. + {put,{atom,badrecord}}. + {put,{atom,r}}. + {'%live',1}. + {call_ext_only,1,{extfunc,erlang,error,1}}. + + +{function, module_info, 0, 5}. + {label,4}. + {func_info,{atom,t},{atom,module_info},0}. + {label,5}. + {move,{atom,t},{x,0}}. + {call_ext_only,1,{extfunc,erlang,get_module_info,1}}. + + +{function, module_info, 1, 7}. + {label,6}. + {func_info,{atom,t},{atom,module_info},1}. + {label,7}. + {move,{x,0},{x,1}}. + {move,{atom,t},{x,0}}. + {call_ext_only,2,{extfunc,erlang,get_module_info,2}}. diff --git a/lib/compiler/test/beam_validator_SUITE_data/bin_aligned.S b/lib/compiler/test/beam_validator_SUITE_data/bin_aligned.S new file mode 100644 index 0000000000..2f353fbd25 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/bin_aligned.S @@ -0,0 +1,47 @@ +{module, t}. %% version = 0 + +{exports, [{decode,1},{module_info,0},{module_info,1}]}. + +{attributes, []}. + +{labels, 7}. + + +{function, decode, 1, 2}. + {label,1}. + {func_info,{atom,t},{atom,decode},1}. + {label,2}. + {move,{integer,1},{x,1}}. + {bif,size,{f,0},[{x,0}],{x,2}}. + {bs_add,{f,0},[{x,1},{x,2},1],{x,1}}. + {bs_init2,{f,0},{x,1},0,1,{field_flags,[]},{x,1}}. + {bs_put_integer,{f,0}, + {integer,3}, + 1, + {field_flags,[aligned,unsigned,big]}, + {integer,0}}. + {bs_put_binary,{f,0},{atom,all},8,{field_flags,[unsigned,big]},{x,0}}. + {bs_put_integer,{f,0}, + {integer,5}, + 1, + {field_flags,[unsigned,big,aligned]}, + {integer,0}}. + {move,{x,1},{x,0}}. + return. + + +{function, module_info, 0, 4}. + {label,3}. + {func_info,{atom,t},{atom,module_info},0}. + {label,4}. + {move,{atom,t},{x,0}}. + {call_ext_only,1,{extfunc,erlang,get_module_info,1}}. + + +{function, module_info, 1, 6}. + {label,5}. + {func_info,{atom,t},{atom,module_info},1}. + {label,6}. + {move,{x,0},{x,1}}. + {move,{atom,t},{x,0}}. + {call_ext_only,2,{extfunc,erlang,get_module_info,2}}. diff --git a/lib/compiler/test/beam_validator_SUITE_data/bin_match.S b/lib/compiler/test/beam_validator_SUITE_data/bin_match.S new file mode 100644 index 0000000000..96df0f7933 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/bin_match.S @@ -0,0 +1,64 @@ +{module, bin_match}. %% version = 0 + +{exports, [{t,1}]}. + +{attributes, []}. + +{labels, 8}. + + +{function, t, 1, 2}. + {label,1}. + {func_info,{atom,t},{atom,t},1}. + {label,2}. +%% {test,bs_start_match,{f,1},[{x,0}]}. + {bs_save,0}. + {test,bs_get_integer, + {f,3}, + [{integer,8},1,{field_flags,[aligned,unsigned,big]},{x,1}]}. + {test,bs_get_integer, + {f,3}, + [{integer,8},1,{field_flags,[aligned,unsigned,big]},{x,2}]}. + {test,bs_test_tail,{f,3},[0]}. + {test_heap,3,3}. + {put_tuple,2,{x,0}}. + {put,{x,1}}. + {put,{x,2}}. + {'%live',1}. + return. + {label,3}. + {bs_restore,0}. + {test,bs_get_integer, + {f,1}, + [{integer,32},1,{field_flags,[aligned,unsigned,big]},{x,1}]}. + {test,bs_test_tail,{f,1},[0]}. + {move,{x,1},{x,0}}. + return. + +{function, x, 1, 5}. + {label,4}. + {func_info,{atom,t},{atom,x},1}. + {label,5}. + {test,bs_start_match,{f,4},[{x,0}]}. + {bs_save,0}. + {test,bs_get_integer, + {f,6}, + [{integer,8},1,{field_flags,[aligned,unsigned,big]},{x,1}]}. + {test,bs_get_integer, + {f,6}, + [{integer,8},1,{field_flags,[aligned,unsigned,big]},{x,2}]}. + {test,bs_test_tail,{f,6},[0]}. + {test_heap,3,3}. + {put_tuple,2,{x,0}}. + {put,{x,1}}. + {put,{x,2}}. + {'%live',1}. + return. + {label,6}. + {bs_restore,1}. + {test,bs_get_integer, + {f,4}, + [{integer,32},1,{field_flags,[aligned,unsigned,big]},{x,1}]}. + {test,bs_test_tail,{f,4},[0]}. + {move,{x,1},{x,0}}. + return. diff --git a/lib/compiler/test/beam_validator_SUITE_data/call_last.S b/lib/compiler/test/beam_validator_SUITE_data/call_last.S new file mode 100644 index 0000000000..827b6c0ae6 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/call_last.S @@ -0,0 +1,71 @@ +{module, call_last}. %% version = 0 + +{exports, [{a,1},{b,1},{bar,1},{foo,1},{module_info,0},{module_info,1}]}. + +{attributes, []}. + +{labels, 13}. + + +{function, a, 1, 2}. + {label,1}. + {func_info,{atom,t},{atom,a},1}. + {label,2}. + {allocate,1,1}. + {move,{x,0},{y,0}}. + {bif,'+',{f,0},[{y,0},{integer,1}],{x,0}}. + {'%live',1}. + {call,1,{f,6}}. + {bif,'+',{f,0},[{y,0},{integer,2}],{x,0}}. + {'%live',1}. + {call_last,1,{f,8},2}. + + +{function, b, 1, 4}. + {label,3}. + {func_info,{atom,t},{atom,b},1}. + {label,4}. + {allocate,1,1}. + {move,{x,0},{y,0}}. + {bif,'+',{f,0},[{y,0},{integer,1}],{x,0}}. + {'%live',1}. + {call,1,{f,6}}. + {move,{y,0},{x,1}}. + {move,{integer,0},{x,0}}. + {call_ext_last,2,{extfunc,lists,seq,2},2}. + + +{function, foo, 1, 6}. + {label,5}. + {func_info,{atom,t},{atom,foo},1}. + {label,6}. + {move,{x,0},{x,1}}. + {move,{atom,glurf},{x,0}}. + {call_ext_only,2,{extfunc,erlang,put,2}}. + + +{function, bar, 1, 8}. + {label,7}. + {func_info,{atom,t},{atom,bar},1}. + {label,8}. + {bif,get,{f,0},[{atom,glurf}],{x,1}}. + {bif,'+',{f,0},[{x,0},{x,1}],{x,0}}. + {'%live',1}. + return. + + +{function, module_info, 0, 10}. + {label,9}. + {func_info,{atom,t},{atom,module_info},0}. + {label,10}. + {move,{atom,t},{x,0}}. + {call_ext_only,1,{extfunc,erlang,get_module_info,1}}. + + +{function, module_info, 1, 12}. + {label,11}. + {func_info,{atom,t},{atom,module_info},1}. + {label,12}. + {move,{x,0},{x,1}}. + {move,{atom,t},{x,0}}. + {call_ext_only,2,{extfunc,erlang,get_module_info,2}}. diff --git a/lib/compiler/test/beam_validator_SUITE_data/cons.S b/lib/compiler/test/beam_validator_SUITE_data/cons.S new file mode 100644 index 0000000000..83b9daa6f5 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/cons.S @@ -0,0 +1,38 @@ +{module, cons}. %% version = 0 + +{exports, [{foo,1},{module_info,0},{module_info,1}]}. + +{attributes, []}. + +{labels, 7}. + + +{function, foo, 1, 2}. + {label,1}. + {func_info,{atom,cons},{atom,foo},1}. + {label,2}. +% {test,is_nonempty_list,{f,1},[{x,0}]}. + {test_heap,3,1}. + {get_list,{x,0},{x,1},{x,2}}. % <= {bad_type,{needed,cons},{actual,term}} + {put_tuple,2,{x,0}}. + {put,{x,1}}. + {put,{x,2}}. + {'%live',1}. + return. + + +{function, module_info, 0, 4}. + {label,3}. + {func_info,{atom,cons},{atom,module_info},0}. + {label,4}. + {move,{atom,cons},{x,0}}. + {call_ext_only,1,{extfunc,erlang,get_module_info,1}}. + + +{function, module_info, 1, 6}. + {label,5}. + {func_info,{atom,cons},{atom,module_info},1}. + {label,6}. + {move,{x,0},{x,1}}. + {move,{atom,cons},{x,0}}. + {call_ext_only,2,{extfunc,erlang,get_module_info,2}}. diff --git a/lib/compiler/test/beam_validator_SUITE_data/dead_code.S b/lib/compiler/test/beam_validator_SUITE_data/dead_code.S new file mode 100644 index 0000000000..f964f98fba --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/dead_code.S @@ -0,0 +1,48 @@ +{module, dead_code}. %% version = 0 + +{exports, [{execute,0},{module_info,0},{module_info,1}]}. + +{attributes, []}. + +{labels, 10}. + + +{function, execute, 0, 2}. + {label,1}. + {func_info,{atom,dead_code},{atom,execute},0}. + {label,2}. + {allocate,0,0}. + {'%live',0}. + {call_ext,0,{extfunc,foo,fie,0}}. + {test,is_ne,{f,4},[{x,0},{integer,0}]}. + {test,is_ne,{f,4},[{x,0},{integer,1}]}. + {label,3}. + {test,is_ne,{f,4},[{x,0},{integer,2}]}. + {test,is_ne,{f,4},[{x,0},{integer,3}]}. + {case_end,{x,0}}. + {label,4}. + {move,{atom,ok},{x,0}}. + {'%live',1}. + {deallocate,0}. + return. + {'%','Moved code'}. + {label,5}. + {case_end,{x,0}}. + + +{function, module_info, 0, 7}. + {label,6}. + {func_info,{atom,dead_code},{atom,module_info},0}. + {label,7}. + {move,nil,{x,0}}. + {'%live',1}. + return. + + +{function, module_info, 1, 9}. + {label,8}. + {func_info,{atom,dead_code},{atom,module_info},1}. + {label,9}. + {move,nil,{x,0}}. + {'%live',1}. + return. diff --git a/lib/compiler/test/beam_validator_SUITE_data/erl_prim_loader.beam b/lib/compiler/test/beam_validator_SUITE_data/erl_prim_loader.beam Binary files differnew file mode 100644 index 0000000000..dd58a88e42 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/erl_prim_loader.beam diff --git a/lib/compiler/test/beam_validator_SUITE_data/freg_range.S b/lib/compiler/test/beam_validator_SUITE_data/freg_range.S new file mode 100644 index 0000000000..ee583a923e --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/freg_range.S @@ -0,0 +1,53 @@ +{module, freg_range}. %% version = 0 + +{exports, [{module_info,0},{module_info,1},{prod,2},{sum,2},{sum_prod,3}]}. + +{attributes, []}. + +{labels, 8}. + + +{function, sum_1, 2, 2}. + {label,1}. + {func_info,{atom,t},{atom,sum_1},2}. + {label,2}. + fclearerror. + {bif,fadd,{f,0},[{fr,-1},{fr,1}],{fr,0}}. + {'%live',1}. + return. + + +{function, sum_2, 2, 4}. + {label,3}. + {func_info,{atom,t},{atom,sum_2},2}. + {label,4}. + {fconv,{x,0},{fr,0}}. + fclearerror. + {bif,fadd,{f,0},[{fr,0},{fr,1024}],{fr,0}}. + {'%live',1}. + return. + + +{function, sum_3, 2, 6}. + {label,5}. + {func_info,{atom,t},{atom,sum_3},2}. + {label,6}. + {fconv,{x,0},{fr,0}}. + {fconv,{x,1},{fr,1}}. + fclearerror. + {bif,fadd,{f,0},[{fr,0},{fr,1}],{fr,-1}}. + {'%live',1}. + return. + + +{function, sum_4, 2, 8}. + {label,7}. + {func_info,{atom,t},{atom,sum_4},2}. + {label,8}. + {fconv,{x,0},{fr,0}}. + {fconv,{x,1},{fr,1}}. + fclearerror. + {bif,fadd,{f,0},[{fr,0},{fr,1}],{fr,1024}}. + {'%live',1}. + return. + diff --git a/lib/compiler/test/beam_validator_SUITE_data/freg_state.S b/lib/compiler/test/beam_validator_SUITE_data/freg_state.S new file mode 100644 index 0000000000..ff4d7548ae --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/freg_state.S @@ -0,0 +1,59 @@ +{module, freg_state}. %% version = 0 + +{exports, []}. + +{attributes, []}. + + +{function, sum_1, 2, 2}. + {label,1}. + {func_info,{atom,t},{atom,sum_1},2}. + {label,2}. + {fconv,{x,0},{fr,0}}. + {fconv,{x,1},{fr,1}}. + {bif,fmul,{f,0},[{fr,0},{fr,1}],{fr,0}}. + {'%live',1}. + return. + +{function, sum_2, 2, 4}. + {label,3}. + {func_info,{atom,t},{atom,sum_2},2}. + {label,4}. + {fconv,{x,0},{fr,0}}. + {fconv,{x,1},{fr,1}}. + fclearerror. + {bif,fmul,{f,0},[{fr,0},{fr,1}],{fr,0}}. + {fmove,{fr,0},{x,0}}. + {'%live',1}. + return. + +{function, sum_3, 2, 6}. + {label,5}. + {func_info,{atom,t},{atom,sum_3},2}. + {label,6}. + {fconv,{x,0},{fr,0}}. + {fconv,{x,1},{fr,1}}. + fclearerror. + {bif,fmul,{f,0},[{fr,0},{fr,1}],{fr,0}}. + {bif,'-',{f,0},[{x,1},{x,0}],{x,1}}. + {fcheckerror,{f,0}}. + {fmove,{fr,0},{x,0}}. + {'%live',1}. + return. + +{function, sum_4, 2, 8}. + {label,6}. + {func_info,{atom,t},{atom,sum_4},2}. + {label,8}. + {fcheckerror,{f,0}}. + {fmove,{fr,0},{x,0}}. + {'%live',1}. + return. + +{function, sum_5, 2, 10}. + {label,9}. + {func_info,{atom,t},{atom,sum_5},2}. + {label,10}. + fclearerror. + fclearerror. + return. diff --git a/lib/compiler/test/beam_validator_SUITE_data/freg_uninit.S b/lib/compiler/test/beam_validator_SUITE_data/freg_uninit.S new file mode 100644 index 0000000000..f8d805d9ec --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/freg_uninit.S @@ -0,0 +1,32 @@ +{module, freg_uninit}. %% version = 0 + +{exports, []}. + +{attributes, []}. + +{labels, 8}. + + +{function, sum_1, 2, 2}. + {label,1}. + {func_info,{atom,t},{atom,sum_1},2}. + {label,2}. + {fconv,{x,0},{fr,0}}. + fclearerror. + {bif,fadd,{f,0},[{fr,0},{fr,1}],{fr,0}}. + {'%live',1}. + return. + + +{function, sum_2, 2, 4}. + {label,3}. + {func_info,{atom,t},{atom,sum_2},2}. + {label,4}. + {fconv,{x,0},{fr,0}}. + {fconv,{x,1},{fr,1}}. + fclearerror. + {fcheckerror,{f,0}}. + {call,2,{f,8}}. + {bif,fadd,{f,0},[{fr,0},{fr,1}],{fr,0}}. + {'%live',1}. + return. diff --git a/lib/compiler/test/beam_validator_SUITE_data/illegal_instruction.S b/lib/compiler/test/beam_validator_SUITE_data/illegal_instruction.S new file mode 100644 index 0000000000..d6e92abc71 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/illegal_instruction.S @@ -0,0 +1,26 @@ +{module, illegal_instruction}. %% version = 0 + +{exports, []}. + +{attributes, []}. + +{labels, 7}. + + +{function, t, 1, 2}. + {label,1}. + {func_info,{atom,illegal_instruction},{atom,t},1}. + {label,2}. + {my_illegal_instruction,{x,0}}. + return. + + +{function, x, 1, 4}. + {label,3}. + bad_func_info. + {label,4}. + {my_illegal_instruction,{x,0}}. + return. + +{function, y, 0, 17}. +
\ No newline at end of file diff --git a/lib/compiler/test/beam_validator_SUITE_data/merge_undefined.S b/lib/compiler/test/beam_validator_SUITE_data/merge_undefined.S new file mode 100644 index 0000000000..3d76127824 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/merge_undefined.S @@ -0,0 +1,84 @@ +{module, merge_undefined}. %% version = 0 + +{exports, [{bar,2},{foo,1},{handle_call,2},{module_info,0},{module_info,1}]}. + +{attributes, []}. + +{labels, 15}. + + +{function, handle_call, 2, 2}. + {label,1}. + {func_info,{atom,t},{atom,handle_call},2}. + {label,2}. + {test,is_atom,{f,1},[{x,0}]}. + {select_val,{x,0},{f,1},{list,[{atom,gurka},{f,3},{atom,delete},{f,4}]}}. + {label,3}. + {allocate_heap,2,6,2}. + %% The Y registers are not initialized here. + {test,is_eq_exact,{f,5},[{x,0},{atom,ok}]}. + {move,{atom,nisse},{x,0}}. + {call_ext,1,{extfunc,erlang,exit,1}}. + {label,4}. + {allocate_heap,1,6,2}. + {move,{x,1},{y,0}}. + {put_string,2,{string,"~p"},{x,0}}. + {put_list,{y,0},nil,{x,1}}. + {'%live',2}. + {call_ext,2,{extfunc,io,format,2}}. + {test,is_ne_exact,{f,6},[{x,0},{atom,ok}]}. + {label,5}. + {move,{atom,logReader},{x,1}}. + {move,{atom,console},{x,0}}. + {call_ext,2,{extfunc,debug,filter,2}}. + {test_heap,14,1}. + {put_list,{atom,logReader},nil,{x,1}}. + {put_list,{atom,console},{x,1},{x,1}}. + {put_tuple,3,{x,2}}. + {put,{atom,debug}}. + {put,{atom,filter}}. + {put,{x,1}}. + {put_tuple,2,{x,1}}. + {put,{x,2}}. + {put,{x,0}}. + {put_tuple,2,{x,0}}. + {put,{atom,badmatch}}. + {put,{x,1}}. + {'%live',1}. + {call_ext,1,{extfunc,erlang,exit,1}}. + {label,6}. + {move,{y,0},{x,0}}. + {call_last,1,{f,8},1}. + + +{function, foo, 1, 8}. + {label,7}. + {func_info,{atom,t},{atom,foo},1}. + {label,8}. + {move,{atom,ok},{x,0}}. + return. + + +{function, bar, 2, 10}. + {label,9}. + {func_info,{atom,t},{atom,bar},2}. + {label,10}. + {move,{atom,ok},{x,0}}. + return. + + +{function, module_info, 0, 12}. + {label,11}. + {func_info,{atom,t},{atom,module_info},0}. + {label,12}. + {move,{atom,t},{x,0}}. + {call_ext_only,1,{extfunc,erlang,get_module_info,1}}. + + +{function, module_info, 1, 14}. + {label,13}. + {func_info,{atom,t},{atom,module_info},1}. + {label,14}. + {move,{x,0},{x,1}}. + {move,{atom,t},{x,0}}. + {call_ext_only,2,{extfunc,erlang,get_module_info,2}}. diff --git a/lib/compiler/test/beam_validator_SUITE_data/no_exception_in_catch.S b/lib/compiler/test/beam_validator_SUITE_data/no_exception_in_catch.S new file mode 100644 index 0000000000..e08a718a39 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/no_exception_in_catch.S @@ -0,0 +1,209 @@ +{module, no_exception_in_catch}. %% version = 0 + +{exports, [{foo,1},{module_info,0},{module_info,1},{nested_of_1,4}]}. + +{attributes, []}. + +{labels, 22}. + + +{function, nested_of_1, 4, 2}. + {label,1}. + {func_info,{atom,no_exception_in_catch},{atom,nested_of_1},4}. + {label,2}. + {test,is_tuple,{f,1},[{x,0}]}. + {test,test_arity,{f,1},[{x,0},3]}. + {allocate_zero,15,4}. + {get_tuple_element,{x,0},0,{y,9}}. + {get_tuple_element,{x,0},1,{y,10}}. + {get_tuple_element,{x,0},2,{y,11}}. + {move,{x,3},{y,14}}. + {move,{x,2},{y,13}}. + {move,{x,1},{y,12}}. + {move,{atom,nested3},{x,0}}. + {call_ext,1,{extfunc,erlang,erase,1}}. + {move,{atom,nested4},{x,0}}. + {call_ext,1,{extfunc,erlang,erase,1}}. + {move,{atom,nested},{x,0}}. + {call_ext,1,{extfunc,erlang,erase,1}}. + {bif,self,nofail,[],{x,0}}. + {'try',{y,8},{f,13}}. + {'try',{y,7},{f,11}}. + {'try',{y,6},{f,9}}. + {'try',{y,5},{f,7}}. +%% Because the following instructions can't possible throw an exception, +%% label 7 used to get no state. Now the try_end itself will save the state. + {move,{x,0},{y,4}}. + {bif,self,nofail,[],{x,0}}. + {'%live',1}. + {try_end,{y,5}}. + {test,is_eq_exact,{f,15},[{x,0},{y,4}]}. + {'try',{y,5},{f,6}}. + {'try',{y,3},{f,3}}. + {move,{y,9},{x,0}}. + {call,1,{f,17}}. + {try_end,{y,3}}. + {test,is_eq_exact,{f,15},[{x,0},{y,11}]}. + {move,{y,12},{x,0}}. + {call,1,{f,17}}. + {test_heap,3,1}. + {put_tuple,2,{x,1}}. + {put,{atom,value1}}. + {put,{x,0}}. + {move,{x,1},{x,0}}. + {jump,{f,5}}. + {label,3}. + {try_case,{y,3}}. + {move,{x,1},{y,1}}. + {move,{x,0},{y,2}}. + {move,{x,2},{y,3}}. + {bif,'=:=',{f,4},[{x,0},{y,10}],{x,3}}. + {move,{x,3},{y,0}}. + {bif,'=:=',{f,4},[{x,1},{y,11}],{x,4}}. + {bif,'and',{f,4},[{x,3},{x,4}],{x,3}}. + {test,is_eq_exact,{f,4},[{x,3},{atom,true}]}. + {kill,{y,0}}. + {kill,{y,1}}. + {kill,{y,2}}. + {kill,{y,3}}. + {move,{y,12},{x,0}}. + {call,1,{f,17}}. + {test_heap,3,1}. + {put_tuple,2,{x,1}}. + {put,{atom,caught1}}. + {put,{x,0}}. + {move,{x,1},{x,0}}. + {jump,{f,5}}. + {label,4}. + {bif,raise,{f,0},[{x,2},{x,1}],{x,0}}. + {'%live',1}. + {label,5}. + {try_end,{y,5}}. + {move,{x,0},{y,5}}. + {move,{y,13},{x,0}}. + {call,1,{f,17}}. + {move,{x,0},{x,1}}. + {move,{atom,nested3},{x,0}}. + {call_ext,2,{extfunc,erlang,put,2}}. + {move,{y,5},{x,0}}. + {jump,{f,8}}. + {label,6}. + {try_case,{y,5}}. + {move,{x,2},{y,5}}. + {move,{x,1},{y,3}}. + {move,{y,13},{x,0}}. + {call,1,{f,17}}. + {move,{x,0},{x,1}}. + {move,{atom,nested3},{x,0}}. + {call_ext,2,{extfunc,erlang,put,2}}. + {bif,raise,{f,0},[{y,5},{y,3}],{x,0}}. + {'%live',1}. + {jump,{f,8}}. + {label,7}. +%% The instructions here used to be not checked. + {move,{x,3},{x,0}}. + {try_case,{y,5}}. + {bif,raise,{f,0},[{x,2},{x,1}],{x,0}}. + {'%live',1}. + {label,8}. + {try_end,{y,6}}. + {move,{x,0},{y,13}}. + {kill,{y,3}}. + {kill,{y,4}}. + {kill,{y,5}}. + {kill,{y,9}}. + {kill,{y,10}}. + {kill,{y,11}}. + {kill,{y,12}}. + {move,{y,14},{x,0}}. + {call,1,{f,17}}. + {move,{x,0},{x,1}}. + {move,{atom,nested4},{x,0}}. + {call_ext,2,{extfunc,erlang,put,2}}. + {move,{y,13},{x,0}}. + {jump,{f,10}}. + {label,9}. + {try_case,{y,6}}. + {move,{x,2},{y,13}}. + {move,{x,1},{y,12}}. + {kill,{y,3}}. + {kill,{y,4}}. + {kill,{y,5}}. + {kill,{y,9}}. + {kill,{y,10}}. + {kill,{y,11}}. + {move,{y,14},{x,0}}. + {call,1,{f,17}}. + {move,{x,0},{x,1}}. + {move,{atom,nested4},{x,0}}. + {call_ext,2,{extfunc,erlang,put,2}}. + {bif,raise,{f,0},[{y,13},{y,12}],{x,0}}. + {'%live',1}. + {label,10}. + {try_end,{y,7}}. + {test_heap,3,1}. + {put_tuple,2,{x,1}}. + {put,{atom,value}}. + {put,{x,0}}. + {move,{x,1},{x,0}}. + {jump,{f,12}}. + {label,11}. + {try_case,{y,7}}. + {test_heap,6,3}. + {put_tuple,2,{x,3}}. + {put,{x,0}}. + {put,{x,1}}. + {put_tuple,2,{x,0}}. + {put,{atom,caught}}. + {put,{x,3}}. + {'%live',1}. + {label,12}. + {try_end,{y,8}}. + {move,{x,0},{y,14}}. + {move,{atom,finalized},{x,1}}. + {kill,{y,12}}. + {kill,{y,13}}. + {move,{atom,nested},{x,0}}. + {call_ext,2,{extfunc,erlang,put,2}}. + {move,{y,14},{x,0}}. + {jump,{f,14}}. + {label,13}. + {try_case,{y,8}}. + {move,{x,2},{y,14}}. + {move,{x,1},{y,13}}. + {move,{atom,finalized},{x,1}}. + {kill,{y,12}}. + {move,{atom,nested},{x,0}}. + {call_ext,2,{extfunc,erlang,put,2}}. + {bif,raise,{f,0},[{y,14},{y,13}],{x,0}}. + {'%live',1}. + {label,14}. + {move,{x,0},{y,14}}. + {kill,{y,13}}. + {move,{atom,nested3},{x,0}}. + {call_ext,1,{extfunc,erlang,erase,1}}. + {move,{x,0},{y,13}}. + {move,{atom,nested4},{x,0}}. + {call_ext,1,{extfunc,erlang,erase,1}}. + {move,{x,0},{y,12}}. + {move,{atom,nested},{x,0}}. + {call_ext,1,{extfunc,erlang,erase,1}}. + {test_heap,5,1}. + {put_tuple,4,{x,1}}. + {put,{y,14}}. + {put,{y,13}}. + {put,{y,12}}. + {put,{x,0}}. + {move,{x,1},{x,0}}. + {deallocate,15}. + return. + {label,15}. + {try_case_end,{x,0}}. + + +{function, foo, 1, 17}. + {label,16}. + {func_info,{atom,no_exception_in_catch},{atom,foo},1}. + {label,17}. + {move,{atom,ok},{x,0}}. + return. diff --git a/lib/compiler/test/beam_validator_SUITE_data/overwrite_catchtag.S b/lib/compiler/test/beam_validator_SUITE_data/overwrite_catchtag.S new file mode 100644 index 0000000000..f6ad0ac50a --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/overwrite_catchtag.S @@ -0,0 +1,38 @@ +{module, overwrite_catchtag}. %% version = 0 + +{exports, [{foo,1},{module_info,0},{module_info,1}]}. + +{attributes, []}. + +{labels, 8}. + + +{function, foo, 1, 2}. + {label,1}. + {func_info,{atom,overwrite_catchtag},{atom,foo},1}. + {label,2}. + {allocate,1,1}. + {'catch',{y,0},{f,3}}. + {move,{x,0},{y,0}}. % <= {catchtag,3} + {call,1,{f,2}}. + {label,3}. + {catch_end,{y,0}}. + {deallocate,1}. + return. + + +{function, module_info, 0, 5}. + {label,4}. + {func_info,{atom,overwrite_catchtag},{atom,module_info},0}. + {label,5}. + {move,{atom,overwrite_catchtag},{x,0}}. + {call_ext_only,1,{extfunc,erlang,get_module_info,1}}. + + +{function, module_info, 1, 7}. + {label,6}. + {func_info,{atom,overwrite_catchtag},{atom,module_info},1}. + {label,7}. + {move,{x,0},{x,1}}. + {move,{atom,overwrite_catchtag},{x,0}}. + {call_ext_only,2,{extfunc,erlang,get_module_info,2}}. diff --git a/lib/compiler/test/beam_validator_SUITE_data/overwrite_trytag.S b/lib/compiler/test/beam_validator_SUITE_data/overwrite_trytag.S new file mode 100644 index 0000000000..db552d5418 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/overwrite_trytag.S @@ -0,0 +1,53 @@ +{module, overwrite_trytag}. %% version = 0 + +{exports, [{foo,1},{module_info,0},{module_info,1}]}. + +{attributes, []}. + +{labels, 9}. + + +{function, foo, 1, 2}. + {label,1}. + {func_info,{atom,overwrite_trytag},{atom,foo},1}. + {label,2}. + {allocate_zero,3,1}. + {'try',{y,2},{f,3}}. + {move,{x,0},{y,1}}. + {'%live',1}. + {call,1,{f,2}}. + {kill,{y,2}}. + {try_end,{y,2}}. + {move,{x,0},{y,2}}. + {move,{y,1},{x,0}}. + {call,1,{f,2}}. + {move,{y,2},{x,0}}. + {jump,{f,4}}. + {label,3}. + {try_case,{y,2}}. + {move,{x,2},{y,2}}. + {move,{x,1},{y,0}}. + {move,{y,1},{x,0}}. + {call,1,{f,2}}. + {bif,raise,{f,0},[{y,2},{y,0}],{x,0}}. + {'%live',1}. + {label,4}. + {deallocate,3}. + return. + + +{function, module_info, 0, 6}. + {label,5}. + {func_info,{atom,overwrite_trytag},{atom,module_info},0}. + {label,6}. + {move,{atom,overwrite_trytag},{x,0}}. + {call_ext_only,1,{extfunc,erlang,get_module_info,1}}. + + +{function, module_info, 1, 8}. + {label,7}. + {func_info,{atom,overwrite_trytag},{atom,module_info},1}. + {label,8}. + {move,{x,0},{x,1}}. + {move,{atom,overwrite_trytag},{x,0}}. + {call_ext_only,2,{extfunc,erlang,get_module_info,2}}. diff --git a/lib/compiler/test/beam_validator_SUITE_data/stack.S b/lib/compiler/test/beam_validator_SUITE_data/stack.S new file mode 100644 index 0000000000..244c22a2f9 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/stack.S @@ -0,0 +1,89 @@ +{module, stack}. %% version = 0 + +{exports, [{a,2},{b,2},{c,2},{d,2},{e,2}]}. + +{attributes, []}. + +{labels, 21}. + + +{function, a, 2, 2}. + {label,1}. + {func_info,{atom,t},{atom,a},2}. + {label,2}. + {allocate,2,2}. + {move,{x,1},{y,1}}. + {move,{x,0},{y,0}}. + {'%live',0}. + {call,0,{f,16}}. + {bif,'+',{f,0},[{y,0},{y,1}],{x,0}}. + {'%live',1}. + return. + + +{function, b, 2, 4}. + {label,3}. + {func_info,{atom,t},{atom,b},2}. + {label,4}. + {deallocate,2}. + return. + + +{function, c, 2, 6}. + {label,5}. + {func_info,{atom,t},{atom,c},2}. + {label,6}. + {allocate,2,2}. + {move,{x,1},{y,1}}. + {move,{x,0},{y,0}}. + {'%live',0}. + {call,0,{f,16}}. + {bif,'+',{f,0},[{y,0},{y,1}],{x,0}}. + {'%live',1}. + {deallocate,2}. + {deallocate,2}. + return. + + +{function, d, 2, 8}. + {label,7}. + {func_info,{atom,t},{atom,d},2}. + {label,8}. + {allocate,2,2}. + {allocate,2,2}. + {deallocate,2}. + return. + +{function, e, 2, 14}. + {label,13}. + {func_info,{atom,t},{atom,e},2}. + {label,14}. + {allocate,2,2}. + {move,{atom,ok},{x,0}}. + {deallocate,5}. + return. + + +{function, bad_1, 0, 10}. + {label,9}. + {func_info,{atom,t},{atom,bad_1},0}. + {label,10}. + {allocate_zero,2,10}. + {move,{y,0},{x,0}}. + return. + + +{function, bad_2, 0, 12}. + {label,11}. + {func_info,{atom,t},{atom,bad_2},0}. + {label,12}. + {allocate_zero,2,0}. + {move,{y,0},{x,0}}. + return. + +{function, foo, 0, 16}. + {label,15}. + {func_info,{atom,t},{atom,foo},0}. + {label,16}. + {move,{atom,ok},{x,0}}. + return. diff --git a/lib/compiler/test/beam_validator_SUITE_data/state_after_fault_in_catch.S b/lib/compiler/test/beam_validator_SUITE_data/state_after_fault_in_catch.S new file mode 100644 index 0000000000..8e27347ed5 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/state_after_fault_in_catch.S @@ -0,0 +1,58 @@ +{module, state_after_fault_in_catch}. %% version = 0 + +{exports, [{foo,1},{if_end,1},{case_end,1},{badmatch,1}]}. + +{attributes, []}. + +{labels, 12}. + + +{function, foo, 1, 2}. + {label,1}. + {func_info,{atom,t},{atom,foo},1}. + {label,2}. + {allocate,1,0}. + {'catch',{y,0},{f,3}}. + {move,{atom,apa},{x,0}}. + {call_ext,1,{extfunc,erlang,fault,1}}. + {label,3}. + {catch_end,{y,0}}. + {move,{x,1},{x,0}}. + return. + +{function, if_end, 1, 5}. + {label,4}. + {func_info,{atom,state_after_fault_in_catch},{atom,if_end},1}. + {label,5}. + {allocate,1,0}. + {'catch',{y,0},{f,6}}. + if_end. + {label,6}. + {catch_end,{y,0}}. + {move,{x,1},{x,0}}. + return. + +{function, case_end, 1, 8}. + {label,7}. + {func_info,{atom,state_after_fault_in_catch},{atom,case_end},1}. + {label,8}. + {allocate,1,1}. + {'catch',{y,0},{f,9}}. + {case_end,{x,0}}. + {label,9}. + {catch_end,{y,0}}. + {move,{x,1},{x,0}}. + return. + +{function, badmatch, 1, 11}. + {label,10}. + {func_info,{atom,state_after_fault_in_catch},{atom,badmatch},1}. + {label,11}. + {allocate,1,1}. + {'catch',{y,0},{f,12}}. + {badmatch,{x,0}}. + {label,12}. + {catch_end,{y,0}}. + {move,{x,1},{x,0}}. + return. + diff --git a/lib/compiler/test/beam_validator_SUITE_data/undef_label.S b/lib/compiler/test/beam_validator_SUITE_data/undef_label.S new file mode 100644 index 0000000000..dd29066bf4 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/undef_label.S @@ -0,0 +1,22 @@ +{module, undef_label}. %% version = 0 + +{exports, []}. + +{attributes, []}. + +{labels, 7}. + + +{function, t, 1, 2}. + {label,1}. + {func_info,{atom,undef_label},{atom,t},1}. + {label,2}. + {test,is_eq_exact,{f,42},[{x,0},{atom,x}]}. + {move,{atom,ok},{x,0}}. + return. + +{function, x, 1, 17}. + {label,3}. + {func_info,{atom,undef_label},{atom,x},1}. + {label,4}. + return. diff --git a/lib/compiler/test/beam_validator_SUITE_data/uninit.S b/lib/compiler/test/beam_validator_SUITE_data/uninit.S new file mode 100644 index 0000000000..1a45c31411 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/uninit.S @@ -0,0 +1,48 @@ +{module, uninit}. %% version = 0 + +{exports, []}. + +{attributes, []}. + +{function, sum_1, 2, 2}. + {label,1}. + {func_info,{atom,t},{atom,sum_1},2}. + {label,2}. + {allocate,1,2}. + {move,{y,0},{x,0}}. + {'%live',1}. + {call,1,{f,10}}. + {bif,'+',{f,0},[{x,0},{y,0}],{x,0}}. + {'%live',1}. + {deallocate,1}. + return. + +{function, sum_2, 2, 4}. + {label,3}. + {func_info,{atom,t},{atom,sum_2},2}. + {label,4}. + {allocate,1,2}. + {'%live',1}. + {call,1,{f,10}}. + {bif,'+',{f,0},[{x,0},{y,0}],{x,0}}. + {'%live',1}. + {deallocate,1}. + return. + +{function, sum_3, 2, 6}. + {label,5}. + {func_info,{atom,t},{atom,sum_3},2}. + {label,6}. + {allocate_zero,1,2}. + {'%live',1}. + {call,1,{f,10}}. + {bif,'+',{f,0},[{x,0},{y,0}],{x,0}}. + {'%live',1}. + {deallocate,1}. + return. + +{function, id, 1, 10}. + {label,9}. + {func_info,{atom,t},{atom,id},1}. + {label,10}. + return. diff --git a/lib/compiler/test/beam_validator_SUITE_data/unsafe_catch.S b/lib/compiler/test/beam_validator_SUITE_data/unsafe_catch.S new file mode 100644 index 0000000000..500ac11377 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/unsafe_catch.S @@ -0,0 +1,67 @@ +{module, unsafe_catch}. %% version = 0 + +{exports, [{small,2}]}. + +{attributes, []}. + +{labels, 14}. + + +{function, small, 2, 5}. + {label,4}. + {func_info,{atom,t},{atom,small},2}. + {label,5}. + {allocate_zero,2,2}. + {'catch',{y,1},{f,6}}. + {bs_init2,{f,0},1,0,2,{field_flags,[]},{x,2}}. + {bs_put_integer,{f,0}, + {integer,8}, + 1, + {field_flags,[aligned,unsigned,big]}, + {x,0}}. + {move,{x,1},{y,0}}. + {move,{x,2},{x,0}}. + {label,6}. + {catch_end,{y,1}}. + {test,is_tuple,{f,7},[{x,0}]}. + {test,test_arity,{f,7},[{x,0},2]}. + {get_tuple_element,{x,0},0,{x,1}}. + {test,is_eq_exact,{f,7},[{x,1},{atom,'EXIT'}]}. + {bs_init2,{f,0},0,0,0,{field_flags,[]},{x,0}}. + {label,7}. + {'catch',{y,1},{f,8}}. + {bs_init2,{f,0},2,0,1,{field_flags,[]},{x,1}}. + {bs_put_integer,{f,0}, + {integer,16}, + 1, + {field_flags,[aligned,unsigned,big]}, + {y,0}}. + {move,{x,0},{y,0}}. + {move,{x,1},{x,0}}. + {label,8}. + {catch_end,{y,1}}. + {test,is_tuple,{f,9},[{x,0}]}. + {test,test_arity,{f,9},[{x,0},2]}. + {get_tuple_element,{x,0},0,{x,1}}. + {test,is_eq_exact,{f,9},[{x,1},{atom,'EXIT'}]}. + {bs_init2,{f,0},0,0,0,{field_flags,[]},{x,0}}. + {label,9}. + {move,{integer,0},{x,1}}. + {bif,size,{f,0},[{x,0}],{x,2}}. + {bs_add,{f,0},[{x,1},{x,2},1],{x,1}}. + {bif,size,{f,0},[{y,0}],{x,2}}. + {bs_add,{f,0},[{x,1},{x,2},1],{x,1}}. + {bs_init2,{f,0},{x,1},0,2,{field_flags,[]},{x,1}}. + {bs_put_binary,{f,0}, + {atom,all}, + 8, + {field_flags,[aligned,unsigned,big]}, + {y,0}}. + {bs_put_binary,{f,0}, + {atom,all}, + 8, + {field_flags,[aligned,unsigned,big]}, + {x,0}}. + {move,{x,1},{x,0}}. + {deallocate,2}. + return. diff --git a/lib/compiler/test/beam_validator_SUITE_data/xrange.S b/lib/compiler/test/beam_validator_SUITE_data/xrange.S new file mode 100644 index 0000000000..3abbdffbc2 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/xrange.S @@ -0,0 +1,44 @@ +{module, xrange}. %% version = 0 + +{exports, [{module_info,0},{module_info,1},{prod,2},{sum,2},{sum_prod,3}]}. + +{attributes, []}. + +{labels, 8}. + + +{function, sum_1, 2, 2}. + {label,1}. + {func_info,{atom,t},{atom,sum_1},2}. + {label,2}. + {bif,'+',{f,0},[{x,-1},{x,1}],{x,0}}. + {'%live',1}. + return. + + +{function, sum_2, 2, 4}. + {label,3}. + {func_info,{atom,t},{atom,sum_2},2}. + {label,4}. + {bif,'+',{f,0},[{x,0},{x,1024}],{x,0}}. + {'%live',1}. + return. + + +{function, sum_3, 2, 6}. + {label,5}. + {func_info,{atom,t},{atom,sum_3},2}. + {label,6}. + {bif,'+',{f,0},[{x,0},{x,1}],{x,-1}}. + {'%live',1}. + return. + + +{function, sum_4, 2, 8}. + {label,7}. + {func_info,{atom,t},{atom,sum_4},2}. + {label,8}. + {bif,'+',{f,0},[{x,0},{x,1}],{x,1024}}. + {'%live',1}. + return. + diff --git a/lib/compiler/test/beam_validator_SUITE_data/yrange.S b/lib/compiler/test/beam_validator_SUITE_data/yrange.S new file mode 100644 index 0000000000..483b14ebd3 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/yrange.S @@ -0,0 +1,76 @@ +{module, yrange}. %% version = 0 + +{exports, [{id,1}, + {module_info,0}, + {module_info,1}, + {sum_1,2}, + {sum_2,2}, + {sum_3,2}, + {sum_4,2}]}. + +{attributes, []}. + +{labels, 15}. + + +{function, sum_1, 2, 2}. + {label,1}. + {func_info,{atom,t},{atom,sum_1},2}. + {label,2}. + {allocate,1,2}. + {move,{x,1},{y,-1}}. + {'%live',1}. + {call,1,{f,10}}. + {bif,'+',{f,0},[{x,0},{y,0}],{x,0}}. + {'%live',1}. + {deallocate,1}. + return. + + +{function, sum_2, 2, 4}. + {label,3}. + {func_info,{atom,t},{atom,sum_2},2}. + {label,4}. + {allocate,1,2}. + {move,{x,1},{y,0}}. + {'%live',1}. + {call,1,{f,10}}. + {bif,'+',{f,0},[{x,0},{y,1024}],{x,0}}. + {'%live',1}. + {deallocate,1}. + return. + + +{function, sum_3, 2, 6}. + {label,5}. + {func_info,{atom,t},{atom,sum_3},2}. + {label,6}. + {allocate,1,2}. + {move,{x,1},{y,1024}}. + {'%live',1}. + {call,1,{f,10}}. + {bif,'+',{f,0},[{x,0},{y,0}],{x,0}}. + {'%live',1}. + {deallocate,1}. + return. + + +{function, sum_4, 2, 8}. + {label,7}. + {func_info,{atom,t},{atom,sum_4},2}. + {label,8}. + {allocate,1,2}. + {move,{x,1},{y,-1}}. + {'%live',1}. + {call,1,{f,10}}. + {bif,'+',{f,0},[{x,0},{y,0}],{x,0}}. + {'%live',1}. + {deallocate,1}. + return. + + +{function, id, 1, 10}. + {label,9}. + {func_info,{atom,t},{atom,id},1}. + {label,10}. + return. diff --git a/lib/compiler/test/bs_bincomp_SUITE.erl b/lib/compiler/test/bs_bincomp_SUITE.erl new file mode 100644 index 0000000000..a64a5d590b --- /dev/null +++ b/lib/compiler/test/bs_bincomp_SUITE.erl @@ -0,0 +1,297 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2006-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% +%% +%% Originally based on Per Gustafsson's test suite. +%% + +-module(bs_bincomp_SUITE). + +-export([all/1, + byte_aligned/1,bit_aligned/1,extended_byte_aligned/1, + extended_bit_aligned/1,mixed/1,filters/1,trim_coverage/1, + nomatch/1,sizes/1]). + +-include("test_server.hrl"). + +all(suite) -> + test_lib:recompile(?MODULE), + [byte_aligned,bit_aligned,extended_byte_aligned, + extended_bit_aligned,mixed,filters,trim_coverage, + nomatch,sizes]. + + +byte_aligned(Config) when is_list(Config) -> + cs_init(), + ?line <<"abcdefg">> = cs(<< <<(X+32)>> || <<X>> <= <<"ABCDEFG">> >>), + <<1:32/little,2:32/little,3:32/little,4:32/little>> = + cs(<< <<X:32/little>> || <<X:32>> <= <<1:32,2:32,3:32,4:32>> >>), + ?line cs(<<1:32/little,2:32/little,3:32/little,4:32/little>> = + << <<X:32/little>> || <<X:16>> <= <<1:16,2:16,3:16,4:16>> >>), + cs_end(). + +bit_aligned(Config) when is_list(Config) -> + cs_init(), + ?line <<$a:7,$b:7,$c:7,$d:7,$e:7,$f:7,$g:7>> = + cs(<< <<(X+32):7>> || <<X>> <= <<"ABCDEFG">> >>), + ?line <<"ABCDEFG">> = + cs(<< <<(X-32)>> || <<X:7>> <= <<$a:7,$b:7,$c:7,$d:7,$e:7,$f:7,$g:7>> >>), + ?line <<1:31/little,2:31/little,3:31/little,4:31/little>> = + cs(<< <<X:31/little>> || <<X:31>> <= <<1:31,2:31,3:31,4:31>> >>), + ?line <<1:31/little,2:31/little,3:31/little,4:31/little>> = + cs(<< <<X:31/little>> || <<X:15>> <= <<1:15,2:15,3:15,4:15>> >>), + cs_end(). + +extended_byte_aligned(Config) when is_list(Config) -> + cs_init(), + ?line <<"abcdefg">> = cs(<< <<(X+32)>> || X <- "ABCDEFG" >>), + ?line "abcdefg" = [(X+32) || <<X>> <= <<"ABCDEFG">>], + ?line <<1:32/little,2:32/little,3:32/little,4:32/little>> = + cs(<< <<X:32/little>> || X <- [1,2,3,4] >>), + ?line [256,512,768,1024] = + [X || <<X:16/little>> <= <<1:16,2:16,3:16,4:16>>], + cs_end(). + +extended_bit_aligned(Config) when is_list(Config) -> + cs_init(), + ?line <<$a:7,$b:7,$c:7,$d:7,$e:7,$f:7,$g:7>> = + cs(<< <<(X+32):7>> || X <- "ABCDEFG" >>), + ?line "ABCDEFG" = [(X-32) || <<X:7>> <= <<$a:7,$b:7,$c:7,$d:7,$e:7,$f:7,$g:7>>], + ?line <<1:31/little,2:31/little,3:31/little,4:31/little>> = + cs(<< <<X:31/little>> || X <- [1,2,3,4] >>), + ?line [256,512,768,1024] = + [X || <<X:15/little>> <= <<1:15,2:15,3:15,4:15>>], + cs_end(). + +mixed(Config) when is_list(Config) -> + cs_init(), + ?line <<2,3,3,4,4,5,5,6>> = + cs(<< <<(X+Y)>> || <<X>> <= <<1,2,3,4>>, <<Y>> <= <<1,2>> >>), + ?line <<2,3,3,4,4,5,5,6>> = + << <<(X+Y)>> || <<X>> <= <<1,2,3,4>>, Y <- [1,2] >>, + ?line <<2,3,3,4,4,5,5,6>> = + cs(<< <<(X+Y)>> || X <- [1,2,3,4], Y <- [1,2] >>), + One = id([1,2,3,4]), + Two = id([1,2]), + ?line <<2,3,3,4,4,5,5,6>> = + cs(<< <<(X+Y)>> || X <- One, Y <- Two >>), + ?line [2,3,3,4,4,5,5,6] = + [(X+Y) || <<X>> <= <<1,2,3,4>>, <<Y>> <= <<1,2>>], + ?line [2,3,3,4,4,5,5,6] = + [(X+Y) || <<X>> <= <<1,2,3,4>>, Y <- [1,2]], + ?line <<2:3,3:3,3:3,4:3,4:3,5:3,5:3,6:3>> = + cs(<< <<(X+Y):3>> || <<X:3>> <= <<1:3,2:3,3:3,4:3>>, + <<Y:3>> <= <<1:3,2:3>> >>), + ?line <<2:3,3:3,3:3,4:3,4:3,5:3,5:3,6:3>> = + cs(<< <<(X+Y):3>> || <<X:3>> <= <<1:3,2:3,3:3,4:3>>, Y <- [1,2] >>), + ?line <<2:3,3:3,3:3,4:3,4:3,5:3,5:3,6:3>> = + cs(<< <<(X+Y):3>> || X <- [1,2,3,4], Y <- [1,2] >>), + ?line <<2:3,3:3,3:3,4:3,4:3,5:3,5:3,6:3>> = + cs_default(<< <<(X+Y):3>> || {X,Y} <- [{1,1},{1,2},{2,1},{2,2}, + {3,1},{3,2},{4,1},{4,2}] >>), + ?line [2,3,3,4,4,5,5,6] = + [(X+Y) || <<X:3>> <= <<1:3,2:3,3:3,4:3>>, <<Y:3>> <= <<1:3,2:3>>], + ?line [2,3,3,4,4,5,5,6] = + [(X+Y) || <<X:3>> <= <<1:3,2:3,3:3,4:3>>, {_,Y} <- [{a,1},{b,2}]], + cs_end(). + +filters(Config) when is_list(Config) -> + cs_init(), + ?line <<"BDF">> = + cs_default(<< <<(X-32)>> || <<X:7>> <= <<$a:7,$b:7,$c:7,$d:7,$e:7,$f:7,$g:7>>, + X rem 2 == 0>>), + ?line <<"abc">> = cs_default(<< <<(X+32)>> || X <- "ABCDEFG", + is_less_than(X, $D)>>), + ?line <<"efg">> = cs_default(<< <<(X+32)>> || X <- "ABCDEFG", + not is_less_than(X, $E)>>), + ?line <<"b">> = cs_default(<< <<(X+32)>> || X <- "ABCDEFG", + is_less_than(X, $D), + X rem 2 == 0>>), + ?line <<"eg">> = cs_default(<< <<(X+32)>> || X <- "ABCDEFG", + not is_less_than(X, $E), + X rem 2 == 1>>), + + %% Filtering by a non-matching pattern. + ?line <<"abd">> = cs_default(<< <<X:8>> || + <<0:1,X:7>> <= <<$a:8,$b:8,1:1,$c:7,$d:8, + 1:1,$e:7,0:4>> >>), + + ?line <<42,42>> = cs_default(<< <<42:8>> || + 42 <- [1,2,3,42,43,42] >>), + cs_end(). + +is_less_than(X, C) when X < C -> true; +is_less_than(_, _) -> false. + +trim_coverage(Config) when is_list(Config) -> + ?line <<0,0,0,2,0,0,5,48,0,11,219,174,0,0,0,0>> = coverage_materialiv(a, b, {1328,777134}), + ?line <<67,40,0,0,66,152,0,0,69,66,64,0>> = coverage_trimmer([42,19,777]), + ?line <<0,0,2,43,0,0,3,9,0,0,0,3,64,8,0,0,0,0,0,0, + 64,68,0,0,0,0,0,0,192,171,198,0,0,0,0,0>> = + coverage_lightfv(555, 777, {3.0,40.0,-3555.0}), + ok. + +coverage_materialiv(A, B, Params) -> + A = id(A), + B = id(B), + <<(tuple_size(Params)):32, + (<< <<C:32>> || C <- tuple_to_list(Params)>>)/binary, + 0:(((1+tuple_size(Params)) rem 2)*32)>>. + +coverage_lightfv(Light, Pname, Params) -> + id(<<Light:32,Pname:32,(size(Params)):32, + (<< <<C:64/float>> || C <- tuple_to_list(Params)>>)/binary, + 0:(((1+size(Params)) rem 2)*32)>>). + +coverage_trimmer(Params) -> + X = id(0), + Y = id(1), + id({X,Y}), + << <<(begin {A,B,D} = id({C,C,C}), id(0), + coverage_summer(A, B, C, D) end):32/float>> || + C <- Params >>. + +coverage_summer(A, B, C, D) -> A+B+C+D. + +nomatch(Config) when is_list(Config) -> + ?line <<>> = << <<X:8>> || X = {_,_} = [_|_] <- [1,2,3] >>, + ok. + +sizes(Config) when is_list(Config) -> + ?line cs_init(), + Fun0 = fun(List) -> + cs(<< <<E:8>> || E <- List >>) + end, + ?line <<>> = Fun0([]), + ?line <<1>> = Fun0([1]), + ?line <<1,2>> = Fun0([1,2]), + ?line <<1,2,3>> = Fun0([1,2,3]), + + Fun1 = fun(List) -> + cs(<< <<E:16>> || E <- List >>) + end, + ?line <<>> = Fun1([]), + ?line <<1:16>> = Fun1([1]), + ?line <<1:16,2:16>> = Fun1([1,2]), + ?line <<1:16,2:16,3:16>> = Fun1([1,2,3]), + + Fun2 = fun(List) -> + cs(<< <<E:4>> || E <- List >>) + end, + ?line <<>> = Fun2([]), + ?line <<1:4>> = Fun2([1]), + ?line <<1:4,13:4>> = Fun2([1,13]), + ?line <<1:4,13:4,7:4>> = Fun2([1,13,7]), + ?line <<0:1000/unit:8>> = Fun2(lists:duplicate(2000, 0)), + + Fun3 = fun(List) -> + cs(<< <<E:3>> || E <- List >>) + end, + ?line <<>> = Fun3([]), + ?line <<40,177,29:5>> = Fun3([1,2,1,3,0,7,5]), + ?line <<0:512/unit:3>> = Fun3(lists:duplicate(512, 0)), + + Fun4 = fun(List, Size) -> + cs(<< <<E:Size>> || E <- List >>) + end, + ?line <<>> = Fun4([], 8), + ?line <<42:6>> = Fun4([42], 6), + ?line <<42:16>> = Fun4([42], 16), + + Fun5 = fun(List, Sz1, Sz2, Sz3) -> + cs(<< <<E:Sz1,(E+1):Sz2/unit:8,(E+2):Sz3/unit:8>> || E <- List >>) + end, + ?line <<>> = Fun5([], 1, 1, 1), + ?line <<7:3,8:40,9:56>> = Fun5([7], 3, 5, 7), + + Fun6 = fun(List, Size) -> + cs(<< <<E:8,(E+1):Size>> || E <- List >>) + end, + ?line <<>> = Fun6([], 42), + ?line <<42,43:20>> = Fun6([42], 20), + + %% Binary generators. + + Fun10 = fun(Bin) -> + cs(<< <<E:16>> || <<E:8>> <= Bin >>) + end, + ?line <<>> = Fun10(<<>>), + ?line <<1:16>> = Fun10(<<1>>), + ?line <<1:16,2:16>> = Fun10(<<1,2>>), + + Fun11 = fun(Bin) -> + cs(<< <<E:8>> || <<E:16>> <= Bin >>) + end, + ?line <<>> = Fun11(<<>>), + ?line <<1>> = Fun11(<<1:16>>), + ?line <<1,2>> = Fun11(<<1:16,2:16>>), + ?line <<1,2>> = Fun11(<<1:16,2:16,0:1>>), + ?line <<1,2>> = Fun11(<<1:16,2:16,0:7>>), + ?line <<1,2>> = Fun11(<<1:16,2:16,42:8>>), + ?line <<1,2>> = Fun11(<<1:16,2:16,42:9>>), + ?line <<1,2>> = Fun11(<<1:16,2:16,255:15>>), + + Fun12 = fun(Bin, Sz1, Sz2) -> + cs(<< <<E:Sz1>> || <<E:Sz2>> <= Bin >>) + end, + ?line <<>> = Fun12(<<>>, 1, 1), + ?line Binary = list_to_binary(lists:seq(0, 255)), + ?line Binary = Fun12(Binary, 1, 1), + ?line Binary = Fun12(Binary, 4, 4), + ?line Binary = Fun12(Binary, 8, 8), + ?line <<17:9,19:9>> = Fun12(<<17:6,19:6>>, 9, 6), + + Fun13 = fun(Sz) -> + cs_default(<< <<C:8>> || <<C:4>> <= <<1:4,2:4,3:4,0:Sz>> >>) + end, + ?line <<1,2,3>> = Fun13(0), + ?line <<1,2,3,0>> = Fun13(4), + ?line <<1,2,3,0>> = Fun13(5), + ?line <<1,2,3,0>> = Fun13(6), + ?line <<1,2,3,0>> = Fun13(7), + ?line <<1,2,3,0,0>> = Fun13(8), + + ?line {'EXIT',_} = (catch << <<C:4>> || <<C:8>> <= {1,2,3} >>), + + ?line cs_end(), + ok. + + + +cs_init() -> + erts_debug:set_internal_state(available_internal_state, true), + ok. + +cs_end() -> + erts_debug:set_internal_state(available_internal_state, false), + ok. + +%% Verify that the allocated size is exact (rounded up to the nearest byte). +cs(Bin) -> + ByteSize = byte_size(Bin), + {refc_binary,ByteSize,{binary,ByteSize},_} = + erts_debug:get_internal_state({binary_info,Bin}), + Bin. + +%% Verify that the allocated size of the binary is the default size. +cs_default(Bin) -> + ByteSize = byte_size(Bin), + {refc_binary,ByteSize,{binary,256},_} = + erts_debug:get_internal_state({binary_info,Bin}), + Bin. + +id(I) -> I. diff --git a/lib/compiler/test/bs_bit_binaries_SUITE.erl b/lib/compiler/test/bs_bit_binaries_SUITE.erl new file mode 100644 index 0000000000..6337460b13 --- /dev/null +++ b/lib/compiler/test/bs_bit_binaries_SUITE.erl @@ -0,0 +1,155 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2006-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% +%% +%% Originally based on Per Gustafsson's test suite. +%% + +-module(bs_bit_binaries_SUITE). + +-export([all/1, + misc/1,horrid_match/1,test_bitstr/1,test_bit_size/1,asymmetric_tests/1, + big_asymmetric_tests/1,binary_to_and_from_list/1, + big_binary_to_and_from_list/1,send_and_receive/1, + send_and_receive_alot/1]). + +-include("test_server.hrl"). + +all(suite) -> + test_lib:recompile(?MODULE), + [misc,horrid_match,test_bitstr,test_bit_size,asymmetric_tests, + big_asymmetric_tests,binary_to_and_from_list,big_binary_to_and_from_list, + send_and_receive,send_and_receive_alot]. + +misc(Config) when is_list(Config) -> + ?line <<1:100>> = <<1:100>>, + ?line {ok,ok} = {match(7),match(9)}, + ?line {ok,ok} = {match1(15),match1(31)}, + ok. + + +match(N) -> + <<0:N>> = <<0:N>>, + ok. + +match1(N) -> + <<42:N/little>> = <<42:N/little>>, + ok. + +test_bit_size(Config) when is_list(Config) -> + ?line 101 = erlang:bit_size(<<1:101>>), + ?line 1001 = erlang:bit_size(<<1:1001>>), + ?line 1001 = erlang:bit_size(<<-10:1001>>), + ?line 80 = erlang:bit_size(<<1:80>>), + ?line 800 = erlang:bit_size(<<1:800>>), + ?line Bin = <<0:16#1000000>>, + ?line BigBin = list_to_bitstring([Bin||_ <- lists:seq(1,16#10)]++[<<1:1>>]), + ?line 16#10000001 = erlang:bit_size(BigBin), + %% Only run these on computers with lots of memory + %% HugeBin = list_to_bitstring([BigBin||_ <- lists:seq(1,16#10)]++[<<1:1>>]), + %% 16#100000011 = erlang:bit_size(HugeBin), + ?line 0 = erlang:bit_size(<<>>), + ok. + +horrid_match(Config) when is_list(Config) -> + ?line <<1:4,B:24/bitstring>> = <<1:4,42:24/little>>, + ?line <<42:24/little>> = B, + ok. + +test_bitstr(Config) when is_list(Config) -> + ?line <<1:7,B/bitstring>> = <<1:7,<<1:1,6>>/bitstring>>, + ?line <<1:1,6>> = B, + ?line B = <<1:1,6>>, + ok. + +asymmetric_tests(Config) when is_list(Config) -> + ?line <<1:12>> = <<0,1:4>>, + ?line <<0,1:4>> = <<1:12>>, + ?line <<1:1,X/bitstring>> = <<128,255,0,0:2>>, + ?line <<1,254,0,0:1>> = X, + ?line X = <<1,254,0,0:1>>, + ?line <<1:1,X1:25/bitstring>> = <<128,255,0,0:2>>, + ?line <<1,254,0,0:1>> = X1, + ?line X1 = <<1,254,0,0:1>>, + ok. + +big_asymmetric_tests(Config) when is_list(Config) -> + ?line <<1:875,1:12>> = <<1:875,0,1:4>>, + ?line <<1:875,0,1:4>> = <<1:875,1:12>>, + ?line <<1:1,X/bitstring>> = <<128,255,0,0:2,1:875>>, + ?line <<1,254,0,0:1,1:875>> = X, + ?line X = <<1,254,0,0:1,1:875>>, + ?line <<1:1,X1:900/bitstring>> = <<128,255,0,0:2,1:875>>, + ?line <<1,254,0,0:1,1:875>> = X1, + ?line X1 = <<1,254,0,0:1,1:875>>, + ok. + +binary_to_and_from_list(Config) when is_list(Config) -> + ?line <<1,2,3,4,1:1>> = list_to_bitstring(bitstring_to_list(<<1,2,3,4,1:1>>)), + ?line [1,2,3,4,<<1:1>>] = bitstring_to_list(<<1,2,3,4,1:1>>), + ?line <<1:1,1,2,3,4>> = list_to_bitstring([<<1:1>>,1,2,3,4]), + ?line [128,129,1,130,<<0:1>>] = bitstring_to_list(<<1:1,1,2,3,4>>), + ok. + +big_binary_to_and_from_list(Config) when is_list(Config) -> + ?line <<1:800,2,3,4,1:1>> = + list_to_bitstring(bitstring_to_list(<<1:800,2,3,4,1:1>>)), + ?line [1,2,3,4|_Rest1] = bitstring_to_list(<<1,2,3,4,1:800,1:1>>), + ?line <<1:801,1,2,3,4>> = list_to_bitstring([<<1:801>>,1,2,3,4]), + ok. + +send_and_receive(Config) when is_list(Config) -> + ?line Bin = <<1,2:7>>, + Pid = spawn_link(fun() -> receiver(Bin) end), + ?line Pid ! {self(),<<1:7,8:5,Bin/bitstring>>}, + ?line receive + ok -> + ok + end. + +receiver(Bin) -> + receive + {Pid,<<1:7,8:5,Bin/bitstring>>} -> + Pid ! ok + end. + +send_and_receive_alot(Config) when is_list(Config) -> + Bin = <<1:1000001>>, + Pid = spawn_link(fun() -> receiver_alot(Bin) end), + spamalot(100,Bin,Pid). + +spamalot(N,Bin,Pid) when N > 0 -> + Pid ! {self(),<<1:7,8:5,Bin/bitstring>>}, + receive + ok -> + ok + end, + spamalot(N-1,Bin,Pid); +spamalot(0,_Bin,Pid) -> + Pid ! no_more, + ok. + +receiver_alot(Bin) -> + receive + {Pid,<<1:7,8:5,Bin/bitstring>>} -> + Pid ! ok; + no_more -> ok + end, + receiver_alot(Bin). + + + diff --git a/lib/compiler/test/bs_construct_SUITE.erl b/lib/compiler/test/bs_construct_SUITE.erl new file mode 100644 index 0000000000..1862a28bbe --- /dev/null +++ b/lib/compiler/test/bs_construct_SUITE.erl @@ -0,0 +1,499 @@ +%% +%% %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% +%% + +%%% While similar to bs_construct_SUITE in the emulator test suite, +%%% this module is more corncerned with testing sizes than the contents +%%% of binaries. + +-module(bs_construct_SUITE). + +-export([all/1,init_per_testcase/2,fin_per_testcase/2, + two/1,test1/1,fail/1,float_bin/1,in_guard/1,in_catch/1, + nasty_literals/1,coerce_to_float/1,side_effect/1, + opt/1,otp_7556/1,float_arith/1,otp_8054/1]). + +-include("test_server.hrl"). + +all(suite) -> + test_lib:recompile(?MODULE), + [two,test1,fail,float_bin,in_guard,in_catch,nasty_literals, + side_effect,opt,otp_7556,float_arith,otp_8054]. + +init_per_testcase(Case, Config) when is_atom(Case), is_list(Config) -> + Dog = test_server:timetrap(?t:minutes(1)), + [{watchdog,Dog}|Config]. + +fin_per_testcase(Case, Config) when is_atom(Case), is_list(Config) -> + Dog = ?config(watchdog, Config), + ?t:timetrap_cancel(Dog), + ok. + +two(Config) when is_list(Config) -> + <<0,1,2,3,4,6,7,8,9>> = two_1([0], [<<1,2,3,4>>,<<6,7,8,9>>]), + ok. + +two_1(P, L) -> + list_to_binary([P|L]). + + +big(1) -> + 57285702734876389752897683. + +i(X) -> X. + +id(I) -> I. + +-define(T(B, L), {B, ??B, L}). +-define(N(B), {B, ??B, unknown}). + +-define(FAIL(Expr), ?line {'EXIT',{badarg,_}} = (catch Expr)). + +l(I_13, I_big1, I_16, Bin) -> + [ + ?T(<<-43>>, + [256-43]), + ?T(<<4:4,7:4>>, + [4*16+7]), + ?T(<<45:I_16/little>>, + [45,0]), + ?T(<<777:16/little>>, + [9,3]), + ?T(<<777:I_13,13:3>>, + [24,77]), + ?T(<<5:4,987:I_13,537:7>>, + [81,237,153]), + ?T(<<0.0:32/float>>, + [0,0,0,0]), + ?T(<<0.125:32/float>>, + [62,0,0,0]), + ?T(<<1.0:32/little-float>>, + [0,0,128,63]), + ?T(<<I_big1:32>>, + [138,99,0,147]), + ?T(<<57285702734876389752897684:(I_16+16)>>, + [138,99,0,148]), + ?T(<<-1:17/unit:8>>, + lists:duplicate(17, 255)), + ?T(<<-1:8/unit:17>>, + lists:duplicate(17, 255)), + ?T(<<4:(I_16-8)/unit:2,5:2/unit:8>>, + [0,4,0,5]), + ?T(<<1:1, 0:(I_13-7), 1:1>>, + [129]), + ?T(<<1:3,"string",9:5>>, + [46,110,142,77,45,204,233]), + ?T(<<37.98:64/native-float>>, + native_3798()), + ?T(<<32978297842987249827298387697777669766334937:128/native-integer>>, + native_bignum()), + + ?T(<<Bin/binary>>, + [165,90,195]), + ?T(<<79,Bin/binary>>, + [79,165,90,195]), + ?T(<<3479:I_13,Bin/binary,7:3>>, + [108,189,42,214,31]), + ?T(<<3479:I_13,Bin/binary,7:1/unit:3>>, + [108,189,42,214,31]), + ?T(<<869:16/little,3479:I_13,Bin/binary,7:1/unit:3>>, + [101,3,108,189,42,214,31]), + ?T(<<869:16/little,3479:I_13,Bin/binary,7:1/unit:3,Bin/binary>>, + [101,3,108,189,42,214,31,165,90,195]), + + %% Test of aligment flag. + ?T(<<0:I_13/unit:8,1:6,0:2>>, + [0,0,0,0,0,0,0,0,0,0,0,0,0,4]), + + %% Test of literals (coverage). + ?T(<<0:128>>,[0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]), + ?T(<<0:13/little,7:3>>,[0,7]), + ?T(<<16#77FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF:264>>, + [0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0, + 16#77,16#FF,16#FF,16#FF,16#FF,16#FF,16#FF,16#FF,16#FF,16#FF,16#FF, + 16#FF,16#FF,16#FF,16#FF,16#FF,16#FF]), + + %% Mix different units. + ?T(<<37558955:(I_16-12)/unit:8,1:1>>, + [2,61,26,171,<<1:1>>]) + ]. + +native_3798() -> + case <<1:16/native>> of + <<0,1>> -> [64,66,253,112,163,215,10,61]; + <<1,0>> -> [61,10,215,163,112,253,66,64] + end. + +native_bignum() -> + case <<1:16/native>> of + <<0,1>> -> [129,205,18,177,1,213,170,101,39,231,109,128,176,11,73,217]; + <<1,0>> -> [217,73,11,176,128,109,231,39,101,170,213,1,177,18,205,129] + end. + +evaluate(Str, Vars) -> + {ok,Tokens,_} = + erl_scan:string(Str ++ " . "), + {ok, [Expr]} = erl_parse:parse_exprs(Tokens), + case erl_eval:expr(Expr, Vars) of + {value, Result, _} -> + Result + end. + +eval_list([], _Vars) -> + []; +eval_list([{C_bin, Str, Bytes} | Rest], Vars) -> + case catch evaluate(Str, Vars) of + {'EXIT', Error} -> + io:format("Evaluation error: ~p, ~p, ~p~n", [Str, Vars, Error]), + exit(Error); + E_bin -> + [{C_bin, E_bin, Str, Bytes} | eval_list(Rest, Vars)] + end. + +one_test({C_bin, E_bin, Str, Bytes}) when is_list(Bytes) -> + io:format(" ~s, ~p~n", [Str, Bytes]), + Bin = list_to_bitstring(Bytes), + if + C_bin == Bin -> + ok; + true -> + io:format("ERROR: Compiled: ~p. Expected ~p. Got ~p.~n", + [Str, Bytes, bitstring_to_list(C_bin)]), + test_server:fail(comp) + end, + if + E_bin == Bin -> + ok; + true -> + io:format("ERROR: Interpreted: ~p. Expected ~p. Got ~p.~n", + [Str, Bytes, bitstring_to_list(E_bin)]), + test_server:fail(comp) + end; +one_test({C_bin, E_bin, Str, Result}) -> + io:format(" ~s ~p~n", [Str, C_bin]), + if + C_bin == E_bin -> + ok; + true -> + Arbitrary = case Result of + unknown -> + size(C_bin); + _ -> + Result + end, + case equal_lists(bitstring_to_list(C_bin), + bitstring_to_list(E_bin), + Arbitrary) of + false -> + io:format("ERROR: Compiled not equal to interpreted:" + "~n ~p, ~p.~n", + [bitstring_to_list(C_bin), bitstring_to_list(E_bin)]), + test_server:fail(comp); + 0 -> + ok; + %% For situations where the final bits may not matter, like + %% for floats: + N when integer(N) -> + io:format("Info: compiled and interpreted differ in the" + " last bytes:~n ~p, ~p.~n", + [bitstring_to_list(C_bin), bitstring_to_list(E_bin)]), + ok + end + end. + +equal_lists([], [], _) -> + 0; +equal_lists([], _, _) -> + false; +equal_lists(_, [], _) -> + false; +equal_lists([A|AR], [A|BR], R) -> + equal_lists(AR, BR, R); +equal_lists(A, B, R) -> + if + length(A) /= length(B) -> + false; + length(A) =< R -> + R; + true -> + false + end. + +test1(Config) when is_list(Config) -> + ?line I_13 = i(13), + ?line I_big1 = big(1), + ?line I_16 = i(16), + ?line Bin = i(<<16#A5,16#5A,16#C3>>), + ?line Vars = lists:sort([{'I_13',I_13}, + {'I_big1',I_big1}, + {'I_16',I_16}, + {'Bin',Bin}]), + ?line lists:foreach(fun one_test/1, eval_list(l(I_13, I_big1, I_16, Bin), Vars)). + +fail(Config) when is_list(Config) -> + I_minus_777 = i(-777), + I_minus_2047 = i(-2047), + + %% One negative field size, but the sum of field sizes will be 1 byte. + %% Make sure that we reject that properly. + + ?line {'EXIT',{badarg,_}} = (catch <<I_minus_777:2048/unit:8, + 57:I_minus_2047/unit:8>>), + + %% Same thing, but use literals. + ?line {'EXIT',{badarg,_}} = (catch <<I_minus_777:2048/unit:8, + 57:(-2047)/unit:8>>), + + %% Not numbers. + ?line {'EXIT',{badarg,_}} = (catch <<45:(i(not_a_number))>>), + ?line {'EXIT',{badarg,_}} = (catch <<13:8,45:(i(not_a_number))>>), + + %% Unaligned sizes. + BadSz = i(7), + Bitstr = i(<<42:17>>), + + ?line {'EXIT',{badarg,_}} = (catch <<Bitstr:4/binary>>), + ?line {'EXIT',{badarg,_}} = (catch <<Bitstr:BadSz/binary>>), + + ?line [] = [X || {X} <- [], X == <<Bitstr:BadSz/binary>>], + ?line [] = [X || {X} <- [], X == <<Bitstr:4/binary>>], + + %% Literals with incorrect type. + ?line {'EXIT',{badarg,_}} = (catch <<42.0/integer>>), + ?line {'EXIT',{badarg,_}} = (catch <<42/binary>>), + ?line {'EXIT',{badarg,_}} = (catch <<an_atom/integer>>), + + ok. + +float_bin(Config) when is_list(Config) -> + %% Some more coverage. + ?line {<<1,2,3>>,7.0} = float_bin_1(4), + F = 42.0, + ?line <<42,0,0,0,0,0,0,69,64>> = <<(id(42)),F/little-float>>, + ok. + +float_bin_1(F) -> + {<<1,2,3>>,F+3.0}. + +in_guard(Config) when is_list(Config) -> + ?line 1 = in_guard_1(<<16#74ad:16>>, 16#e95, 5), + ?line 2 = in_guard_1(<<16#3A,16#F7,"hello">>, 16#3AF7, <<"hello">>), + ?line 3 = in_guard_1(<<16#FBCD:14,3.1415/float,3:2>>, 16#FBCD, 3.1415), + ?line nope = in_guard_1(<<1>>, 42, b), + ?line nope = in_guard_1(<<1>>, a, b), + ?line nope = in_guard_1(<<1,2>>, 1, 1), + ?line nope = in_guard_1(<<4,5>>, 1, 2.71), + ?line nope = in_guard_1(<<4,5>>, 1, <<12,13>>), + + ?line 1 = in_guard_2(<<0,56>>, 7, blurf), + ?line 2 = in_guard_2(<<1,255>>, 511, blurf), + ?line 3 = in_guard_2(<<0,3>>, 0, blurf), + ?line 4 = in_guard_2(<<>>, 1, {<<7:16>>}), + ?line nope = in_guard_2(<<4,5>>, 1, blurf), + + ?line 42 = in_guard_3(<<1,2,3,42>>, <<1,2,3>>), + ?line 42 = in_guard_3(<<1,2,3,42>>, <<1,2,3>>), + ?line nope = in_guard_3(<<>>, <<>>), + + ?line ok = in_guard_4(<<15:4>>, 255), + ?line nope = in_guard_4(<<15:8>>, 255), + ok. + +in_guard_1(Bin, A, B) when <<A:13,B:3>> == Bin -> 1; +in_guard_1(Bin, A, B) when <<A:16,B/binary>> == Bin -> 2; +in_guard_1(Bin, A, B) when <<A:14,B/float,3:2>> == Bin -> 3; +in_guard_1(Bin, A, B) when {a,b,<<A:14,B/float,3:2>>} == Bin -> cant_happen; +in_guard_1(_, _, _) -> nope. + +in_guard_2(Bin, A, _T) when <<A:13,0:3>> == Bin -> 1; +in_guard_2(Bin, A, _T) when <<A:16>> == Bin -> 2; +in_guard_2(Bin, A, _T) when <<A:14,3:2>> == Bin -> 3; +in_guard_2(_Bin, A, T) when {A,b} > {0,1}, {<<A:14,3:2>>} == T -> 4; +in_guard_2(_, _, _) -> nope. + +in_guard_3(Bin, A) when <<A/binary,42>> =:= Bin -> 42; +in_guard_3(_, _) -> nope. + +in_guard_4(Bin, A) when <<A:4>> =:= Bin -> ok; +in_guard_4(_, _) -> nope. + +in_catch(Config) when is_list(Config) -> + ?line <<42,0,5>> = small(42, 5), + ?line <<255>> = small(255, <<1,2,3,4,5,6,7,8,9>>), + ?line <<1,2>> = small(<<7,8,9,10>>, 258), + ?line <<>> = small(<<1,2,3,4,5>>, <<7,8,9,10>>), + ok. + +small(A, B) -> + case begin + case catch <<A:8>> of + {'EXIT',_} -> <<>>; + ResA0 -> ResA0 + end + end of + ResA -> ok + end, + case begin + case catch <<B:16>> of + {'EXIT',_} -> <<>>; + ResB0 -> ResB0 + end + end of + ResB -> ok + end, + <<ResA/binary,ResB/binary>>. + +nasty_literals(Config) when is_list(Config) -> + case erlang:system_info(endian) of + big -> + ?line [0,42] = binary_to_list(id(<<42:16/native>>)); + little -> + ?line [42,0] = binary_to_list(id(<<42:16/native>>)) + end, + + ?line Bin0 = id(<<1,2,3,0:10000000,4,5,6>>), + ?line 1250006 = size(Bin0), + ?line <<1,2,3,0:10000000,4,5,6>> = Bin0, + + ?line Bin1 = id(<<0:10000000,7,8,-1:10000000,9,10,0:10000000>>), + ?line 3750004 = size(Bin1), + ?line <<0:10000000,7,8,-1:10000000/signed,9,10,0:10000000>> = Bin1, + + ?line <<255,255,0,0,0>> = id(<<255,255,0,0,0>>), + + %% Coverage. + I = 16#7777FFFF7777FFFF7777FFFF7777FFFF7777FFFF7777FFFF, + id(<<I:260>>), + + ok. + +-define(COF(Int0), + ?line (fun(Int) -> + true = <<Int:32/float>> =:= <<(float(Int)):32/float>>, + true = <<Int:64/float>> =:= <<(float(Int)):64/float>> + end)(nonliteral(Int0)), + ?line true = <<Int0:32/float>> =:= <<(float(Int0)):32/float>>, + ?line true = <<Int0:64/float>> =:= <<(float(Int0)):64/float>>). + +-define(COF64(Int0), + ?line (fun(Int) -> + true = <<Int:64/float>> =:= <<(float(Int)):64/float>> + end)(nonliteral(Int0)), + ?line true = <<Int0:64/float>> =:= <<(float(Int0)):64/float>>). + +nonliteral(X) -> X. + +coerce_to_float(Config) when is_list(Config) -> + ?COF(0), + ?COF(-1), + ?COF(1), + ?COF(42), + ?COF(255), + ?COF(-255), + ?COF(38474), + ?COF(387498738948729893849444444443), + ?COF(-37489378937773899999999999999993), + ?COF64(298748888888888888888888888883478264866528467367364766666666666666663), + ?COF64(-367546729879999999999947826486652846736736476555566666663), + ok. + +side_effect(Config) when is_list(Config) -> + {'EXIT',{badarg,_}} = (catch side_effect_1(a)), + {'EXIT',{badarg,_}} = (catch side_effect_1(<<>>)), + ?line ok = side_effect_1(42), + ok. + +side_effect_1(A) -> + <<A:17>>, %Warning intentional. + ok. + +-record(otp_7029, {a,b}). + +opt(Config) when is_list(Config) -> + ?line 42 = otp_7029(#otp_7029{a = <<>>,b = 42}), + N = 16, + ?line <<1,3,65>> = id(<<1,833:N>>), + ?line <<1,66,3>> = id(<<1,834:N/little>>), + ?line <<1,65,136,0,0>> = id(<<1,17.0:32/float>>), + ?line <<1,64,8,0,0,0,0,0,0>> = id(<<1,3.0:N/float-unit:4>>), + ?line <<1,0,0,0,0,0,0,8,64>> = id(<<1,3.0:N/little-float-unit:4>>), + ?line {'EXIT',{badarg,_}} = (catch id(<<3.1416:N/float>>)), + + B = <<1,2,3,4,5>>, + ?line <<0,1,2,3,4,5>> = id(<<0,B/binary>>), + ?line <<1,2,3,4,5,19>> = id(<<B:5/binary,19>>), + ?line <<1,2,3,42>> = id(<<B:3/binary,42>>), + + ?line {'EXIT',_} = (catch <<<<23,56,0,2>>:(2.5)/binary>>), + ?line {'EXIT',_} = (catch <<<<23,56,0,2>>:(-16)/binary>>), + ?line {'EXIT',_} = (catch <<<<23,56,0,2>>:(anka)>>), + ?line {'EXIT',_} = (catch <<<<23,56,0,2>>:64/float>>), + ?line {'EXIT',_} = (catch <<<<23,56,0,2:7>>/binary>>), + + case id(false) of + true -> ?line opt_dont_call_me(); + false -> ok + end, + + ok. + +opt_dont_call_me() -> + N = 16#12345678, + <<0:N>>. + +otp_7029(R) -> + #otp_7029{a = <<>>} = R, + R#otp_7029.b. + +otp_7556(Config) when is_list(Config) -> + [otp_7556(<<>>, 1024, 1024, 1024) || _ <- lists:seq(0, 1023)], + ok. + +otp_7556(Bin, A, B, C) -> + %% When allocating the binary, the sizes 16*A and 16*A would + %% be forgotten. + <<Bin/binary,(-1):A/unit:16,0:B/unit:16,(-1):C/unit:16>>. + +%% Test binary construction combined with floating point operations +%% (mostly to cover code in beam_flatten that combines the allocation +%% for a binary construction with a later allocation). + +float_arith(Config) when is_list(Config) -> + ?line {<<1,2,3,64,69,0,0,0,0,0,0>>,21.0} = do_float_arith(<<1,2,3>>, 42, 2), + ok. + +do_float_arith(Bin0, X, Y) -> + Bin = <<Bin0/binary,X/float>>, + {Bin,X / Y}. + +otp_8054(Config) when is_list(Config) -> + ?line <<"abc">> = otp_8054_1([null,1,2,3], <<"abc">>), + ok. + +otp_8054_1([H|T], Bin) -> + _ = case H of + null -> + %% The beam_validator would complain about {x,3} + %% not being live in bs_append/8 because of a live + %% optimization bug. + <<Bin/binary>>; + _ -> + ok + end, + otp_8054_1(T, Bin); +otp_8054_1([], Bin) -> Bin. diff --git a/lib/compiler/test/bs_match_SUITE.erl b/lib/compiler/test/bs_match_SUITE.erl new file mode 100644 index 0000000000..5c2797170b --- /dev/null +++ b/lib/compiler/test/bs_match_SUITE.erl @@ -0,0 +1,991 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2005-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(bs_match_SUITE). +-compile(nowarn_shadow_vars). + +-export([all/1,init_per_testcase/2,fin_per_testcase/2, + fun_shadow/1,int_float/1,otp_5269/1,null_fields/1,wiger/1, + bin_tail/1,save_restore/1,shadowed_size_var/1, + partitioned_bs_match/1,function_clause/1, + unit/1,shared_sub_bins/1,bin_and_float/1, + dec_subidentifiers/1,skip_optional_tag/1, + wfbm/1,degenerated_match/1,bs_sum/1,coverage/1, + multiple_uses/1,zero_label/1,followed_by_catch/1, + matching_meets_construction/1,simon/1,matching_and_andalso/1, + otp_7188/1,otp_7233/1,otp_7240/1,otp_7498/1, + match_string/1,zero_width/1,bad_size/1,haystack/1]). + +-export([coverage_id/1]). + +-include("test_server.hrl"). + + +all(suite) -> + test_lib:recompile(?MODULE), + [fun_shadow,int_float,otp_5269,null_fields,wiger,bin_tail,save_restore, + shadowed_size_var,partitioned_bs_match,function_clause,unit, + shared_sub_bins,bin_and_float,dec_subidentifiers,skip_optional_tag, + wfbm,degenerated_match,bs_sum,coverage,multiple_uses,zero_label, + followed_by_catch,matching_meets_construction,simon,matching_and_andalso, + otp_7188,otp_7233,otp_7240,otp_7498,match_string,zero_width,bad_size, + haystack]. + +init_per_testcase(Case, Config) when is_atom(Case), is_list(Config) -> + Dog = test_server:timetrap(?t:minutes(1)), + [{watchdog,Dog}|Config]. + +fin_per_testcase(Case, Config) when is_atom(Case), is_list(Config) -> + Dog = ?config(watchdog, Config), + ?t:timetrap_cancel(Dog), + ok. + +fun_shadow(Config) when is_list(Config) -> + %% OTP-5270 + ?line 7 = fun_shadow_1(), + ?line 7 = fun_shadow_2(8), + ?line 7 = fun_shadow_3(), + ?line no = fun_shadow_4(8), + ok. + +fun_shadow_1() -> + L = 8, + F = fun(<<L:L,B:L>>) -> B end, + F(<<16:8, 7:16>>). + +fun_shadow_2(L) -> + F = fun(<<L:L,B:L>>) -> B end, + F(<<16:8, 7:16>>). + +fun_shadow_3() -> + L = 8, + F = fun(<<L:L,B:L,L:L>>) -> B end, + F(<<16:8, 7:16,16:16>>). + +fun_shadow_4(L) -> + F = fun(<<L:L,B:L,L:L>>) -> B; + (_) -> no end, + F(<<16:8, 7:16,15:16>>). + +int_float(Config) when is_list(Config) -> + %% OTP-5323 + ?line <<103133.0:64/float>> = <<103133:64/float>>, + ?line <<103133:64/float>> = <<103133:64/float>>, + ok. + +%% Stolen from erl_eval_SUITE and modified. +%% OTP-5269. Bugs in the bit syntax. +otp_5269(Config) when is_list(Config) -> + ?line check(fun() -> L = 8, + F = fun(<<A:L,B:A>>) -> B end, + F(<<16:8, 7:16>>) + end, + 7), + ?line check(fun() -> L = 8, <<A:L,B:A>> = <<16:8, 7:16>>, B end, + 7), + ?line check(fun() -> U = 8, (fun(<<U:U>>) -> U end)(<<32:8>>) end, + 32), + ?line check(fun() -> U = 8, [U || <<U:U>> <- [<<32:8>>]] end, + [32]), + ?line check(fun() -> [X || <<A:8, + B:A>> <- [<<16:8,19:16>>], + <<X:8>> <- [<<B:8>>]] end, + [19]), + ?line check(fun() -> A = 4, B = 28, bit_size(<<13:(A+(X=B))>>), X end, + 28), + ?line check(fun() -> + <<Size,B:Size/binary,Rest/binary>> = <<2,"AB","CD">>, + {Size,B,Rest} + end, + {2,<<"AB">>,<<"CD">>}), + ?line check(fun() -> X = 32, + [X || <<X:X>> <- [<<1:32>>,<<2:32>>,<<3:8>>]] end, + %% "binsize variable" ^ + [1,2]), + + ok. + +null_fields(Config) when is_list(Config) -> + ?line check(fun() -> + W = id(0), + F = fun(<<_:W>>) -> tail; + (<<>>) -> empty + end, + F(<<>>) + end, tail), + ?line check(fun() -> + F = fun(<<_/binary>>) -> tail; + (<<>>) -> empty + end, + F(<<>>) + end, tail), + ok. + +wiger(Config) when is_list(Config) -> + ?line ok1 = wcheck(<<3>>), + ?line ok2 = wcheck(<<1,2,3>>), + ?line ok3 = wcheck(<<4>>), + ?line {error,<<1,2,3,4>>} = wcheck(<<1,2,3,4>>), + ?line {error,<<>>} = wcheck(<<>>), + ok. + +wcheck(<<A>>) when A==3-> + ok1; +wcheck(<<_,_:2/binary>>) -> + ok2; +wcheck(<<_>>) -> + ok3; +wcheck(Other) -> + {error,Other}. + +bin_tail(Config) when is_list(Config) -> + S = <<"abcde">>, + ?line $a = bin_tail_c(S, 0), + ?line $c = bin_tail_c(S, 2), + ?line $e = bin_tail_c(S, 4), + ?line {'EXIT',_} = (catch bin_tail_c(S, 5)), + ?line {'EXIT',_} = (catch bin_tail_c_var(S, 5)), + + ?line $a = bin_tail_d(S, 0), + ?line $b = bin_tail_d(S, 8), + ?line $d = bin_tail_d(S, 3*8), + ?line {'EXIT',_} = (catch bin_tail_d_dead(S, 1)), + ?line {'EXIT',_} = (catch bin_tail_d_dead(S, 9)), + ?line {'EXIT',_} = (catch bin_tail_d_dead(S, 5*8)), + ?line {'EXIT',_} = (catch bin_tail_d_var(S, 1)), + + ?line ok = bin_tail_e(<<2:2,0:1,1:5>>), + ?line ok = bin_tail_e(<<2:2,1:1,1:5,42:64>>), + ?line error = bin_tail_e(<<3:2,1:1,1:5,42:64>>), + ?line error = bin_tail_e(<<>>), + ok. + +bin_tail_c(Bin, Offset) -> + Res = bin_tail_c_dead(Bin, Offset), + <<_:Offset/binary,_,Tail/binary>> = Bin, + {Res,Tail} = bin_tail_c_var(Bin, Offset), + Res. + +bin_tail_c_dead(Bin, Offset) -> + <<_:Offset/binary,C,_/binary>> = Bin, + C. + +bin_tail_c_var(Bin, Offset) -> + <<_:Offset/binary,C,Tail/binary>> = Bin, + {C,Tail}. + + +bin_tail_d(Bin, BitOffset) -> + Res = bin_tail_d_dead(Bin, BitOffset), + <<_:BitOffset,_:8,Tail/binary>> = Bin, + {Res,Tail} = bin_tail_d_var(Bin, BitOffset), + Res. + +bin_tail_d_dead(Bin, BitOffset) -> + <<_:BitOffset,C,_/binary>> = Bin, + C. + +bin_tail_d_var(Bin, BitOffset) -> + <<_:BitOffset,C,Tail/binary>> = Bin, + {C,Tail}. + +bin_tail_e(Bin) -> + case bin_tail_e_dead(Bin) of + ok -> + <<_,Tail/binary>> = Bin, + Tail = bin_tail_e_var(Bin), + ok; + error -> + bin_tail_e_var(Bin) + end. + +bin_tail_e_dead(Bin) -> + case Bin of + %% The binary is aligned at the end; neither the bs_skip_bits2 nor + %% bs_test_tail2 instructions are needed. + <<2:2,_:1,1:5,_/binary>> -> ok; + _ -> error + end. + +bin_tail_e_var(Bin) -> + case Bin of + %% The binary is aligned at the end; neither the bs_skip_bits2 nor + %% bs_test_tail2 instructions are needed. + <<2:2,_:1,1:5,Tail/binary>> -> Tail; + _ -> error + end. + +save_restore(Config) when is_list(Config) -> + ?line 0 = save_restore_1(<<0:2,42:6>>), + ?line {1,3456} = save_restore_1(<<1:2,3456:14>>), + ?line {2,7981234} = save_restore_1(<<2:2,7981234:30>>), + ?line {3,763967493838} = save_restore_1(<<0:2,763967493838:62>>), + + A = <<" x">>, + B = <<".x">>, + C = <<"-x">>, + + ?line {" ",<<"x">>} = lll(A), + ?line {" ",<<"x">>} = mmm(A), + ?line {" ",<<"x">>} = nnn(A), + ?line {" ",<<"x">>} = ooo(A), + + ?line {".",<<"x">>} = lll(B), + ?line {".",<<"x">>} = mmm(B), + ?line {".",<<"x">>} = nnn(B), + ?line {".",<<"x">>} = ooo(B), + + ?line {"-",<<"x">>} = lll(C), + ?line {"-",<<"x">>} = mmm(C), + ?line {"-",<<"x">>} = nnn(C), + ?line {"-",<<"x">>} = ooo(C), + + Bin = <<-1:64>>, + case bad_float_unpack_match(Bin) of + -1 -> ok; + _Other -> ?line ?t:fail(bad_return_value_probably_NaN) + end. + +save_restore_1(Bin) -> + case Bin of + <<0:2,_:6>> -> 0; + <<1:2,A:14>> -> {1,A}; + <<2:2,A:30>> -> {2,A}; + <<A:64>> -> {3,A} + end. + +lll(<<Char, Tail/binary>>) -> {[Char],Tail}. + +mmm(<<$.,$.,$., Tail/binary>>) -> Tail; +mmm(<<$\s,$-,$\s, Tail/binary>>) -> Tail; +mmm(<<Char, Tail/binary>>) -> {[Char],Tail}. %% Buggy Tail! + +nnn(<<"...", Tail/binary>>) -> Tail; +nnn(<<" - ", Tail/binary>>) -> Tail; +nnn(<<Char, Tail/binary>>) -> {[Char],Tail}. %% Buggy Tail! + +ooo(<<" - ", Tail/binary>>) -> Tail; +ooo(<<Char, Tail/binary>>) -> {[Char],Tail}. + +bad_float_unpack_match(<<F:64/float>>) -> F; +bad_float_unpack_match(<<I:64/integer-signed>>) -> I. + + +shadowed_size_var(Config) when is_list(Config) -> + ?line PrivDir = ?config(priv_dir, Config), + ?line Dir = filename:dirname(code:which(?MODULE)), + ?line Core = filename:join(Dir, "bs_shadowed_size_var"), + ?line Opts = [from_core,{outdir,PrivDir}|test_lib:opt_opts(?MODULE)], + ?line io:format("~p", [Opts]), + ?line {ok,Mod} = c:c(Core, Opts), + ?line [42|<<"abcde">>] = Mod:filter_essentials([<<42:32>>|<<5:32,"abcde">>]), + ok. + +partitioned_bs_match(Config) when is_list(Config) -> + ?line <<1,2,3>> = partitioned_bs_match(blurf, <<42,1,2,3>>), + ?line error = partitioned_bs_match(10, <<7,8,15,13>>), + ?line error = partitioned_bs_match(100, {a,tuple,is,'not',a,binary}), + ?line ok = partitioned_bs_match(0, <<>>), + ?line {'EXIT',{function_clause,[{?MODULE,partitioned_bs_match,[-1,blurf]}|_]}} = + (catch partitioned_bs_match(-1, blurf)), + ?line {'EXIT',{function_clause,[{?MODULE,partitioned_bs_match,[-1,<<1,2,3>>]}|_]}} = + (catch partitioned_bs_match(-1, <<1,2,3>>)), + + ?line {17,<<1,2,3>>} = partitioned_bs_match_2(1, <<17,1,2,3>>), + ?line {7,<<1,2,3>>} = partitioned_bs_match_2(7, <<17,1,2,3>>), + ?line {'EXIT',{function_clause,[{?MODULE,partitioned_bs_match_2,[4,<<0:17>>]}|_]}} = + (catch partitioned_bs_match_2(4, <<0:17>>)), + ok. + +partitioned_bs_match(_, <<42:8,T/binary>>) -> + T; +partitioned_bs_match(N, _) when N > 0 -> + error; +partitioned_bs_match(_, <<>>) -> + ok. + +partitioned_bs_match_2(1, <<B:8,T/binary>>) -> + {B,T}; +partitioned_bs_match_2(Len, <<_:8,T/binary>>) -> + {Len,T}. + +function_clause(Config) when is_list(Config) -> + ?line ok = function_clause_1(<<0,7,0,7,42>>), + ?line {'EXIT',{function_clause, + [{?MODULE,function_clause_1,[<<0,1,2,3>>]}|_]}} = + (catch function_clause_1(<<0,1,2,3>>)), + ?line {'EXIT',{function_clause, + [{?MODULE,function_clause_1,[<<0,1,2,3>>]}|_]}} = + (catch function_clause_1(<<0,7,0,1,2,3>>)), + ok. + +function_clause_1(<<0:8,7:8,T/binary>>) -> + function_clause_1(T); +function_clause_1(<<_:8>>) -> + ok. + +unit(Config) when is_list(Config) -> + ?line 42 = peek1(<<42>>), + ?line 43 = peek1(<<43,1,2>>), + ?line 43 = peek1(<<43,1,2,(-1):1>>), + ?line 43 = peek1(<<43,1,2,(-1):2>>), + ?line 43 = peek1(<<43,1,2,(-1):7>>), + + ?line 99 = peek8(<<99>>), + ?line 100 = peek8(<<100,101>>), + ?line {'EXIT',{function_clause,[{?MODULE,peek8,[<<100,101,0:1>>]}|_]}} = + (catch peek8(<<100,101,0:1>>)), + + ?line 37484 = peek16(<<37484:16>>), + ?line 37489 = peek16(<<37489:16,5566:16>>), + ?line {'EXIT',{function_clause,[{?MODULE,peek16,[<<8>>]}|_]}} = + (catch peek16(<<8>>)), + ?line {'EXIT',{function_clause,[{?MODULE,peek16,[<<42:15>>]}|_]}} = + (catch peek16(<<42:15>>)), + ?line {'EXIT',{function_clause,[{?MODULE,peek16,[<<1,2,3,4,5>>]}|_]}} = + (catch peek16(<<1,2,3,4,5>>)), + + ?line 127 = peek7(<<127:7>>), + ?line 100 = peek7(<<100:7,19:7>>), + ?line {'EXIT',{function_clause,[{?MODULE,peek7,[<<1,2>>]}|_]}} = + (catch peek7(<<1,2>>)), + ok. + +peek1(<<B:8,_/bitstring>>) -> B. + +peek7(<<B:7,_/binary-unit:7>>) -> B. + +peek8(<<B:8,_/binary>>) -> B. + +peek16(<<B:16,_/binary-unit:16>>) -> B. + +shared_sub_bins(Config) when is_list(Config) -> + ?line {15,[<<>>,<<5>>,<<4,5>>,<<3,4,5>>,<<2,3,4,5>>]} = sum(<<1,2,3,4,5>>, [], 0), + ok. + +sum(<<B,T/binary>>, Acc, Sum) -> + sum(T, [T|Acc], Sum+B); +sum(<<>>, Last, Sum) -> {Sum,Last}. + + +bin_and_float(Config) when is_list(Config) -> + ?line 14.0 = bin_and_float(<<1.0/float,2.0/float,3.0/float>>, 0.0), + ok. + +bin_and_float(<<X/float,Y/float,Z/float,T/binary>>, Sum) when is_float(X), + is_float(Y), + is_float(Z) -> + bin_and_float(T, Sum+X*X+Y*Y+Z*Z); +bin_and_float(<<>>, Sum) -> Sum. + +dec_subidentifiers(Config) when is_list(Config) -> + ?line {[],<<1,2,3>>} = + do_dec_subidentifiers(<<1:1,42:7,1:1,99:7,1,2,3>>, 0, [], 2), + ?line {[5389],<<1,2,3>>} = do_dec_subidentifiers(<<1:1,42:7,0:1,13:7,1,2,3>>, 0, [], 2), + ?line {[3,2,1],not_a_binary} = dec_subidentifiers(not_a_binary, any, [1,2,3], 0), + ok. + +do_dec_subidentifiers(Buffer, Av, Al, Len) -> + Res = dec_subidentifiers(Buffer, Av, Al, Len), + Res = dec_subidentifiers2(Buffer, Av, Al, Len), + Res = dec_subidentifiers4(Buffer, Av, Al, Len), + Res = dec_subidentifiers3(Buffer, Av, Al, Len). + +dec_subidentifiers(Buffer, _Av, Al, 0) -> + {lists:reverse(Al),Buffer}; +dec_subidentifiers(<<1:1,H:7,T/binary>>, Av, Al, Len) -> + dec_subidentifiers(T, (Av bsl 7) bor H, Al, Len-1); +dec_subidentifiers(<<H,T/binary>>, Av, Al, Len) -> + dec_subidentifiers(T, 0, [((Av bsl 7) bor H)|Al], Len-1). + +dec_subidentifiers2(<<Buffer/binary>>, _Av, Al, 0) -> + {lists:reverse(Al),Buffer}; +dec_subidentifiers2(<<1:1,H:7,T/binary>>, Av, Al, Len) -> + dec_subidentifiers2(T, (Av bsl 7) bor H, Al, Len-1); +dec_subidentifiers2(<<H,T/binary>>, Av, Al, Len) -> + dec_subidentifiers2(T, 0, [((Av bsl 7) bor H)|Al], Len-1). + +dec_subidentifiers3(Buffer, _Av, Al, 0) when is_binary(Buffer) -> + {lists:reverse(Al),Buffer}; +dec_subidentifiers3(<<1:1,H:7,T/binary>>, Av, Al, Len) -> + dec_subidentifiers3(T, (Av bsl 7) bor H, Al, Len-1); +dec_subidentifiers3(<<H,T/binary>>, Av, Al, Len) -> + dec_subidentifiers3(T, 0, [((Av bsl 7) bor H)|Al], Len-1). + +dec_subidentifiers4(<<1:1,H:7,T/binary>>, Av, Al, Len) when Len =/= 0 -> + dec_subidentifiers4(T, (Av bsl 7) bor H, Al, Len-1); +dec_subidentifiers4(<<H,T/binary>>, Av, Al, Len) when Len =/= 0 -> + dec_subidentifiers4(T, 0, [((Av bsl 7) bor H)|Al], Len-1); +dec_subidentifiers4(Buffer, _Av, Al, 0) -> + {lists:reverse(Al),Buffer}. + + +skip_optional_tag(Config) when is_list(Config) -> + {ok,<<>>} = skip_optional_tag(<<42>>, <<42>>), + {ok,<<>>} = skip_optional_tag(<<42,1>>, <<42,1>>), + {ok,<<1,2,3>>} = skip_optional_tag(<<42>>, <<42,1,2,3>>), + missing = skip_optional_tag(<<2:3>>, blurf), + ok. + +skip_optional_tag(<<>>, Binary) -> + {ok,Binary}; +skip_optional_tag(<<Tag,RestTag/binary>>, <<Tag,Rest/binary>>) -> + skip_optional_tag(RestTag, Rest); +skip_optional_tag(_, _) -> missing. + +-define(DATELEN, 16). + +wfbm(Config) when is_list(Config) -> + %% check_for_dot_or_space and get_tail is from wfbm4 by Steve Vinoski, + %% with modifications. + ?line {nomatch,0} = check_for_dot_or_space(<<" ">>), + ?line {nomatch,0} = check_for_dot_or_space(<<" abc">>), + ?line {ok,<<"abcde">>} = check_for_dot_or_space(<<"abcde 34555">>), + ?line {nomatch,0} = check_for_dot_or_space(<<".gurka">>), + ?line {nomatch,1} = check_for_dot_or_space(<<"g.urka">>), + + ?line nomatch = get_tail(<<>>), + ?line {ok,<<"2007/10/23/blurf">>} = get_tail(<<"200x/2007/10/23/blurf ">>), + ?line {skip,?DATELEN+5} = get_tail(<<"200x/2007/10/23/blurf.">>), + ?line nomatch = get_tail(<<"200y.2007.10.23.blurf ">>), + ?line {'EXIT',_} = (catch get_tail({no,binary,at,all})), + ?line {'EXIT',_} = (catch get_tail(no_binary)), + ok. + +check_for_dot_or_space(Bin) -> + check_for_dot_or_space(Bin, 0). + +check_for_dot_or_space(<<$\s, _/binary>>, 0) -> + {nomatch,0}; +check_for_dot_or_space(Bin, Len) -> + case Bin of + <<Front:Len/binary, $\s, _/binary>> -> + {ok,Front}; + <<_:Len/binary, $., _/binary>> -> + {nomatch,Len}; + _ -> + check_for_dot_or_space(Bin, Len+1) + end. + +get_tail(<<>>) -> + nomatch; +get_tail(Bin) -> + <<Front:?DATELEN/binary, Tail/binary>> = Bin, + case Front of + <<_:3/binary,"x/",Y:4/binary,$/,M:2/binary,$/,D:2/binary,$/>> -> + case check_for_dot_or_space(Tail) of + {ok,Match} -> + {ok,<<Y/binary,$/,M/binary,$/,D/binary,$/, Match/binary>>}; + {nomatch,Skip} -> {skip,?DATELEN + Skip} + end; + _ -> nomatch + end. + +degenerated_match(Config) when is_list(Config) -> + ?line error = degenerated_match_1(<<>>), + ?line 1 = degenerated_match_1(<<1:1>>), + ?line 2 = degenerated_match_1(<<42,43>>), + + ?line error = degenerated_match_2(<<>>), + ?line no_split = degenerated_match_2(<<1,2>>), + ?line {<<1,2,3,4>>,<<5>>} = degenerated_match_2(<<1,2,3,4,5>>), + + ok. + +degenerated_match_1(<<>>) -> error; +degenerated_match_1(Bin) -> byte_size(Bin). + +degenerated_match_2(<<>>) -> error; +degenerated_match_2(Bin) -> + case byte_size(Bin) > 4 of + true -> + split_binary(Bin, 4); + false -> + no_split + end. + +bs_sum(Config) when is_list(Config) -> + ?line 0 = bs_sum_1([]), + ?line 0 = bs_sum_1(<<>>), + ?line 42 = bs_sum_1([42]), + ?line 1 = bs_sum_1(<<1>>), + ?line 10 = bs_sum_1([1,2,3,4]), + ?line 15 = bs_sum_1(<<1,2,3,4,5>>), + ?line 21 = bs_sum_1([1,2,3|<<4,5,6>>]), + ?line 15 = bs_sum_1([1,2,3|{4,5}]), + ?line 6 = bs_sum_1([1,2,3|zero]), + ?line 6 = bs_sum_1([1,2,3|0]), + ?line 7 = bs_sum_1([1,2,3|one]), + + ?line {'EXIT',{function_clause,_}} = (catch bs_sum_1({too,big,tuple})), + ?line {'EXIT',{function_clause,_}} = (catch bs_sum_1([1,2,3|{too,big,tuple}])), + + ?line [] = sneaky_alias(<<>>), + ?line [559,387655] = sneaky_alias(id(<<559:32,387655:32>>)), + ?line {'EXIT',{function_clause,[{?MODULE,sneaky_alias,[<<1>>]}|_]}} = + (catch sneaky_alias(id(<<1>>))), + ?line {'EXIT',{function_clause,[{?MODULE,sneaky_alias,[[1,2,3,4]]}|_]}} = + (catch sneaky_alias(lists:seq(1, 4))), + ok. + +bs_sum_1(<<H,T/binary>>) -> H+bs_sum_1(T); +bs_sum_1([H|T]) -> H+bs_sum_1(T); +bs_sum_1({A,B}=_Tuple=_AliasForNoGoodReason) -> A+B; +bs_sum_1(0) -> 0; +bs_sum_1(zero=_Zero) -> 0; +bs_sum_1(one) -> 1; +bs_sum_1([]) -> 0; +bs_sum_1(<<>>) -> 0. + +sneaky_alias(<<>>=L) -> binary_to_list(L); +sneaky_alias(<<From:32,L/binary>>) -> [From|sneaky_alias(L)]. + +coverage(Config) when is_list(Config) -> + ?line 0 = coverage_fold(fun(B, A) -> A+B end, 0, <<>>), + ?line 6 = coverage_fold(fun(B, A) -> A+B end, 0, <<1,2,3>>), + ?line {'EXIT',{function_clause,_}} = (catch coverage_fold(fun(B, A) -> + A+B + end, 0, [a,b,c])), + + ?line {<<>>,not_a_tuple} = coverage_build(<<>>, <<>>, not_a_tuple), + ?line {<<16#76,"abc",16#A9,"abc">>,{x,42,43}} = + coverage_build(<<>>, <<16#7,16#A>>, {x,y,z}), + + ?line {x,<<"abc">>,z} = coverage_setelement(<<2,"abc">>, {x,y,z}), + + ?line [42] = coverage_apply(<<42>>, [coverage_id]), + + ?line do_coverage_bin_to_term_list([]), + ?line do_coverage_bin_to_term_list([lists:seq(0, 10),{a,b,c},<<23:42>>]), + ?line {'EXIT',{function_clause, + [{?MODULE,coverage_bin_to_term_list,[<<0,0,0,7>>]}|_]}} = + (catch do_coverage_bin_to_term_list_1(<<7:32>>)), + + ?line <<>> = coverage_per_key(<<4:32>>), + ?line <<$a,$b,$c>> = coverage_per_key(<<7:32,"abc">>), + + ok. + +coverage_fold(Fun, Acc, <<H,T/binary>>) -> + IdFun = fun id/1, + coverage_fold(Fun, Fun(IdFun(H), IdFun(Acc)), T); +coverage_fold(Fun, Acc, <<>>) when is_function(Fun, 2) -> Acc. + +coverage_build(Acc0, <<H,T/binary>>, Tuple0) -> + Str = id(<<H:(id(4)),(H-1):4,"abc">>), + Acc = id(<<Acc0/bitstring,Str/bitstring>>), + Tuple = setelement(2, setelement(3, Tuple0, 43), 42), + if + byte_size(Acc) > 0 -> + coverage_build(Acc, T, Tuple) + end; +coverage_build(Acc, <<>>, Tuple) -> {Acc,Tuple}. + +coverage_setelement(<<H,T1/binary>>, Tuple) when element(1, Tuple) =:= x -> + setelement(H, Tuple, T1). + +coverage_apply(<<H,T/binary>>, [F|Fs]) -> + [?MODULE:F(H)|coverage_apply(T, Fs)]; +coverage_apply(<<>>, []) -> []. + +coverage_id(I) -> id(I). + +do_coverage_bin_to_term_list(L) -> + Bin = << <<(begin BinTerm = term_to_binary(Term), + <<(byte_size(BinTerm)):32,BinTerm/binary>> end)/binary>> || + Term <- L >>, + L = do_coverage_bin_to_term_list_1(Bin), + L = do_coverage_bin_to_term_list_1(<<Bin/binary,7:32,"garbage">>), + L = do_coverage_bin_to_term_list_1(<<7:32,"garbage",Bin/binary>>). + +do_coverage_bin_to_term_list_1(Bin) -> + Res = coverage_bin_to_term_list(Bin), + Res = coverage_bin_to_term_list(Bin, []), + Res = coverage_bin_to_term_list_catch(Bin), + Res = coverage_bin_to_term_list_catch(Bin, []). + +coverage_bin_to_term_list(<<Sz:32,BinTerm:Sz/binary,T/binary>>) -> + try binary_to_term(BinTerm) of + Term -> [Term|coverage_bin_to_term_list(T)] + catch + error:badarg -> coverage_bin_to_term_list(T) + end; +coverage_bin_to_term_list(<<>>) -> []. + +coverage_bin_to_term_list(<<Sz:32,BinTerm:Sz/binary,T/binary>>, Acc) -> + try binary_to_term(BinTerm) of + Term -> coverage_bin_to_term_list(T, [Term|Acc]) + catch + error:badarg -> coverage_bin_to_term_list(T, Acc) + end; +coverage_bin_to_term_list(<<>>, Acc) -> lists:reverse(Acc). + +coverage_bin_to_term_list_catch(<<Sz:32,BinTerm:Sz/binary,T/binary>>) -> + case catch binary_to_term(BinTerm) of + {'EXIT',_} -> coverage_bin_to_term_list_catch(T); + Term -> [Term|coverage_bin_to_term_list_catch(T)] + end; +coverage_bin_to_term_list_catch(<<>>) -> []. + +coverage_bin_to_term_list_catch(<<Sz:32,BinTerm:Sz/binary,T/binary>>, Acc) -> + case catch binary_to_term(BinTerm) of + {'EXIT',_} -> coverage_bin_to_term_list_catch(T, Acc); + Term -> coverage_bin_to_term_list_catch(T, [Term|Acc]) + end; +coverage_bin_to_term_list_catch(<<>>, Acc) -> lists:reverse(Acc). + +coverage_per_key(<<BinSize:32,Bin/binary>> = B) -> + true = (byte_size(B) =:= BinSize), + Bin. + +multiple_uses(Config) when is_list(Config) -> + ?line {344,62879,345,<<245,159,1,89>>} = multiple_uses_1(<<1,88,245,159,1,89>>), + ?line true = multiple_uses_2(<<0,0,197,18>>), + ?line <<42,43>> = multiple_uses_3(<<0,0,42,43>>, fun id/1), + ok. + +multiple_uses_1(<<X:16,Tail/binary>>) -> + %% NOT OPTIMIZED: sub binary is matched or used in more than one place + {Y,Z} = multiple_uses_match(Tail), + {X,Y,Z,Tail}. + +multiple_uses_2(<<_:16,Tail/binary>>) -> + %% NOT OPTIMIZED: sub binary is matched or used in more than one place + multiple_uses_cmp(Tail, Tail). + +multiple_uses_3(<<_:16,Tail/binary>>, Fun) -> + %% NOT OPTIMIZED: sub binary is used or returned + Fun(Tail). + +multiple_uses_match(<<Y:16,Z:16>>) -> + {Y,Z}. + +multiple_uses_cmp(<<Y:16>>, <<Y:16>>) -> true; +multiple_uses_cmp(<<_:16>>, <<_:16>>) -> false. + +zero_label(Config) when is_list(Config) -> + ?line <<"nosemouth">> = read_pols(<<"FACE","nose","mouth">>), + ?line <<"CE">> = read_pols(<<"noFACE">>), + ok. + +read_pols(Data) -> + <<PolygonType:4/binary,Rest/binary>> = Data, + %% Intentional warning. + (PolygonType == <<"FACE">>) or (PolygonType == <<"PTCH">>), + Rest. + +followed_by_catch(Config) when is_list(Config) -> + ok = handle(<<0,1,2,3,4,5>>). + +-record(rec,{field}). +handle(<<>>) -> ok; +handle(Msg) -> + <<_DataLen:16, Rest/binary>> = Msg, + case catch fooX:func() of + [X] -> + X#rec.field; + _ -> + ok + end, + handle(Rest). + +matching_meets_construction(Config) when is_list(Config) -> + Bin = id(<<"abc">>), + Len = id(2), + Tail0 = id(<<1,2,3,4,5>>), + ?line <<_:Len/binary,Tail/binary>> = Tail0, + ?line Res = <<Tail/binary,Bin/binary>>, + ?line <<3,4,5,"abc">> = Res, + ?line {'EXIT',{badarg,_}} = (catch matching_meets_construction_1(<<"Abc">>)), + ?line {'EXIT',{badarg,_}} = (catch matching_meets_construction_2(<<"Abc">>)), + ?line <<"Bbc">> = matching_meets_construction_3(<<"Abc">>), + + ?line <<1,2>> = encode_octet_string(<<1,2,3>>, 2), + ok. + +matching_meets_construction_1(<<"A",H/binary>>) -> <<"B",H>>. + +matching_meets_construction_2(<<"A",H/binary>>) -> <<"B",H/float>>. + +matching_meets_construction_3(<<"A",H/binary>>) -> <<"B",H/binary>>. + +encode_octet_string(<<OctetString/binary>>, Len) -> + <<OctetString:Len/binary-unit:8>>. + +simon(Config) when is_list(Config) -> + ?line one = simon(blurf, <<>>), + ?line two = simon(0, <<42>>), + ?line {'EXIT',{function_clause,[{?MODULE,simon,[17,<<1>>]}|_]}} = (catch simon(17, <<1>>)), + ?line {'EXIT',{function_clause,[{?MODULE,simon,[0,<<1,2,3>>]}|_]}} = (catch simon(0, <<1,2,3>>)), + + ?line one = simon2(blurf, <<9>>), + ?line two = simon2(0, <<9,1>>), + ?line {'EXIT',{function_clause,[{?MODULE,simon2,[0,<<9,10,11>>]}|_]}} = + (catch simon2(0, <<9,10,11>>)), + ok. + +simon(_, <<>>) -> one; +simon(0, <<_>>) -> two. + +simon2(_, <<9>>) -> one; +simon2(0, <<_:16>>) -> two. + + +%% OTP-7113: Crash in v3_codegen. +matching_and_andalso(Config) when is_list(Config) -> + ?line ok = matching_and_andalso_1(<<1,2,3>>, 3), + ?line {'EXIT',{function_clause,_}} = (catch matching_and_andalso_1(<<1,2,3>>, -8)), + ?line {'EXIT',{function_clause,_}} = (catch matching_and_andalso_1(<<1,2,3>>, blurf)), + ?line {'EXIT',{function_clause,_}} = (catch matching_and_andalso_1(<<1,2,3>>, 19)), + ok. + +matching_and_andalso_1(<<Bitmap/binary>>, K) + when is_integer(K) andalso size(Bitmap) >= K andalso 0 < K -> + ok. + +%% Thanks to Tomas Stejskal. +otp_7188(Config) when is_list(Config) -> + MP3 = <<84,65,71,68,117,154,105,232,107,121,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,68,97,110,105,101,108,32,76, + 97,110,100,97,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,66, + 101,115,116,32,79,102,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,50,48,48,48,50,48,48,48,32,45,32,66,101,115, + 116,32,79,102,32,32,32,32,32,32,32,32,32,32,32,32,32,32, + 32,32,12>>, + ?line {ok,{"ID3v1", + [{title,<<68,117,154,105,232,107,121>>}, + {artist,<<"Daniel Landa">>}, + {album,<<"Best Of">>}]}} = parse_v1_or_v11_tag(MP3). + +parse_v1_or_v11_tag(<<"TAG", Title:30/binary, + Artist:30/binary, Album:30/binary, + _Year:4/binary, _Comment:28/binary, + 0:8, Track:8, _Genre:8>>) -> + {ok, + {"ID3v1.1", + [{track, Track}, {title, trim(Title)}, + {artist, trim(Artist)}, {album, trim(Album)}]}}; +parse_v1_or_v11_tag(<<"TAG", Title:30/binary, + Artist:30/binary, Album:30/binary, + _Year:4/binary, _Comment:30/binary, + _Genre:8>>) -> + {ok, + {"ID3v1", + [{title, trim(Title)}, + {artist, trim(Artist)}, + {album, trim(Album)}]}}; +parse_v1_or_v11_tag(_) -> + error. + +trim(Bin) -> + list_to_binary(trim_blanks(binary_to_list(Bin))). + +trim_blanks(L) -> + lists:reverse(skip_blanks_and_zero(lists:reverse(L))). + +skip_blanks_and_zero([$\s|T]) -> + skip_blanks_and_zero(T); +skip_blanks_and_zero([0|T]) -> + skip_blanks_and_zero(T); +skip_blanks_and_zero(L) -> + L. + +%% OTP-7233. Record and binary matching optimizations clashed. +%% Thanks to Vladimir Klebansky. + +-record(rec_otp_7233, {key, val}). + +otp_7233(Config) when is_list(Config) -> + ?line otp_7233_1(#rec_otp_7233{key = <<"XXabcde">>,val=[{"xxxxxxxx",42}]}), + ?line [<<"XXabcde">>,{"xxxxxxxx",42}] = get(io_format), + erase(io_format), + ?line otp_7233_1(#rec_otp_7233{key = <<"XXabcde">>,val=[]}), + ?line undefined = get(io_format), + ok. + +otp_7233_1(Rec) -> + <<K:2/binary,_Rest:5/binary>> = Rec#rec_otp_7233.key, + case K of + <<"XX">> -> + Value = Rec#rec_otp_7233.val, + case lists:keysearch("xxxxxxxx", 1, Value) of + {value,T} -> put(io_format, [Rec#rec_otp_7233.key,T]); + false -> ok + end; + _ -> ok + end. + + +otp_7240(Config) when is_list(Config) -> + ?line a = otp_7240_a(0, <<>>), + ?line b = otp_7240_a(1, 2), + + ?line a = otp_7240_b(anything, <<>>), + ?line b = otp_7240_b(1, {x,y}), + + ?line a = otp_7240_c(anything, <<>>), + ?line b = otp_7240_c(1, <<2>>), + + ?line a = otp_7240_d(anything, <<>>), + ?line b = otp_7240_d(again, <<2>>), + + ?line a = otp_7240_e(anything, <<>>), + ?line b = otp_7240_e(1, 41), + + ?line a = otp_7240_f(anything, <<>>), + ?line b = otp_7240_f(1, {}), + + ok. + +otp_7240_a(_, <<>>) -> a; +otp_7240_a(1, 2) -> b. + +otp_7240_b(_, <<>>) -> a; +otp_7240_b(1, {_,_}) -> b. + +otp_7240_c(_, <<>>) -> a; +otp_7240_c(1, <<2>>) -> b. + +otp_7240_d(_, <<>>) -> a; +otp_7240_d(_, <<2>>) -> b. + +otp_7240_e(_, <<>>) -> a; +otp_7240_e(1, B) when B < 42 -> b. + +otp_7240_f(_, <<>>) -> a; +otp_7240_f(1, B) when is_tuple(B) -> b. + +otp_7498(Config) when is_list(Config) -> + ?line <<1,2,3>> = otp_7498_foo(<<1,2,3>>, 0), + ?line <<2,3>> = otp_7498_foo(<<1,2,3>>, 1), + ?line <<1,2,3>> = otp_7498_foo(<<1,2,3>>, 2), + + ?line <<1,2,3>> = otp_7498_bar(<<1,2,3>>, 0), + ?line <<2,3>> = otp_7498_bar(<<1,2,3>>, 1), + ?line <<1,2,3>> = otp_7498_bar(<<1,2,3>>, 2), + ?line <<>> = otp_7498_bar(<<>>, 2), + ?line <<1,2,3>> = otp_7498_bar(<<1,2,3>>, 3), + + ok. + +otp_7498_foo(Bin, 0) -> + otp_7498_foo(Bin, 42); +otp_7498_foo(<<_A, Rest/bitstring>>, 1) -> + otp_7498_foo(Rest, 43); +otp_7498_foo(Bin, _I) -> + Bin. + +otp_7498_bar(Bin, 0) -> + otp_7498_bar(Bin, 42); +otp_7498_bar(<<_A, Rest/bitstring>>, 1) -> + otp_7498_bar(Rest, 43); +otp_7498_bar(<<>>, 2) -> + otp_7498_bar(<<>>, 44); +otp_7498_bar(Bin, _I) -> + Bin. + + +match_string(Config) when is_list(Config) -> + %% To make sure that native endian really is handled correctly + %% (i.e. that the compiler does not attempt to use bs_match_string/4 + %% instructions for native segments), running this test is not enough. + %% Either examine the generated for do_match_string_native/1 or + %% check the coverage for the v3_kernel module. + case erlang:system_info(endian) of + little -> + ?line do_match_string_native(<<$a,0,$b,0>>); + big -> + ?line do_match_string_native(<<0,$a,0,$b>>) + end, + + ?line do_match_string_big(<<0,$a,0,$b>>), + ?line do_match_string_little(<<$a,0,$b,0>>), + + ?line do_match_string_big_signed(<<255,255>>), + ?line do_match_string_little_signed(<<255,255>>), + + ?line plain = no_match_string_opt(<<"abc">>), + ?line strange = no_match_string_opt(<<$a:9,$b:9,$c:9>>), + + ok. + +do_match_string_native(<<$a:16/native,$b:16/native>>) -> ok. + +do_match_string_big(<<$a:16/big,$b:16/big>>) -> ok. + +do_match_string_little(<<$a:16/little,$b:16/little>>) -> ok. + +do_match_string_big_signed(<<(-1):16/signed>>) -> ok. + +do_match_string_little_signed(<<(-1):16/little-signed>>) -> ok. + +no_match_string_opt(<<"abc">>) -> plain; +no_match_string_opt(<<$a:9,$b:9,$c:9>>) -> strange. + + +%% OTP-7591: A zero-width segment in matching would crash the compiler. + +zero_width(Config) when is_list(Config) -> + ?line <<Len:16/little, Str:Len/binary, 0:0>> = <<2, 0, $h, $i, 0:0>>, + ?line 2 = Len, + ?line Str = <<"hi">>, + + %% Match sure that values that cannot fit in a segment will not match. + case id(<<0:8>>) of + <<256:8>> -> ?line ?t:fail(); + _ -> ok + end, + ok. + + +%% OTP_7650: A invalid size for binary segments could crash the compiler. +bad_size(Config) when is_list(Config) -> + Tuple = {a,b,c}, + ?line {'EXIT',{{badmatch,<<>>},_}} = (catch <<32:Tuple>> = id(<<>>)), + Binary = <<1,2,3>>, + ?line {'EXIT',{{badmatch,<<>>},_}} = (catch <<32:Binary>> = id(<<>>)), + ok. + +haystack(Config) when is_list(Config) -> + ?line <<0:10/unit:8>> = haystack_1(<<0:10/unit:8>>), + ?line [<<0:10/unit:8>>, + <<0:20/unit:8>>] = haystack_2(<<1:8192>>), + ok. + +%% Used to crash the compiler. +haystack_1(Haystack) -> + Subs = [10], + [begin + <<B:Y/binary>> = Haystack, + B + end || Y <- Subs], + Haystack. + +%% There would be an incorrect badmatch exception. +haystack_2(Haystack) -> + Subs = [{687,10},{369,20}], + [begin + <<_:X/binary,B:Y/binary,_/binary>> = Haystack, + B + end || {X,Y} <- Subs ]. + +check(F, R) -> + R = F(). + +id(I) -> I. diff --git a/lib/compiler/test/bs_shadowed_size_var.core b/lib/compiler/test/bs_shadowed_size_var.core new file mode 100644 index 0000000000..d1d5ebba6d --- /dev/null +++ b/lib/compiler/test/bs_shadowed_size_var.core @@ -0,0 +1,25 @@ +module 'bs_shadowed_size_var' ['filter_essentials'/1] + attributes [] + +%% Reduced code from beam_asm inlined using the old inliner. + +'filter_essentials'/1 = + fun (_cor0) -> + case _cor0 of + <[#{#<Sz>(32,1,'integer',['unsigned','big']) }#|T]> when 'true' -> + let <_cor4> = + case T of + %% Variable 'Sz' repeated here. Should work. + <#{#<Sz>(32,1,'integer',['unsigned','big']), + #<Data>(Sz,8,'binary',['unsigned','big'])}#> when 'true' -> + Data + <_cor5> when 'true' -> + primop 'match_fail' + ({'case_clause',{_cor5}}) + end + in [Sz|_cor4] + <_cor5> when 'true' -> + primop 'match_fail' + ({'function_clause',_cor5}) + end +end diff --git a/lib/compiler/test/bs_utf_SUITE.erl b/lib/compiler/test/bs_utf_SUITE.erl new file mode 100644 index 0000000000..d93bdef73d --- /dev/null +++ b/lib/compiler/test/bs_utf_SUITE.erl @@ -0,0 +1,396 @@ +%% +%% %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(bs_utf_SUITE). + +-export([all/1, + utf8_roundtrip/1,unused_utf_char/1,utf16_roundtrip/1, + utf32_roundtrip/1,guard/1,extreme_tripping/1, + literals/1,coverage/1]). + +-include("test_server.hrl"). + +all(suite) -> + test_lib:recompile(?MODULE), + [utf8_roundtrip,unused_utf_char,utf16_roundtrip, + utf32_roundtrip,guard,extreme_tripping, + literals,coverage]. + +utf8_roundtrip(Config) when is_list(Config) -> + ?line [utf8_roundtrip_1(P) || P <- utf_data()], + ok. + +utf8_roundtrip_1({Str,Bin,Bin}) -> + ?line Str = utf8_to_list(Bin), + ?line Bin = list_to_utf8(Str), + ?line [ok = utf8_guard(C, <<42,C/utf8>>) || C <- Str], + ?line [error = utf8_guard(C, <<C/utf8>>) || C <- Str], + ok. + +utf8_guard(C, Bin) when <<42,C/utf8>> =:= Bin -> ok; +utf8_guard(_, _) -> error. + +utf8_to_list(<<C/utf8,T/binary>>) -> + [C|utf8_to_list(T)]; +utf8_to_list(<<>>) -> []. + +list_to_utf8(L) -> + list_to_utf8(L, <<>>). + +list_to_utf8([H|T], Bin) -> + list_to_utf8(T, <<Bin/binary,H/utf8>>); +list_to_utf8([], Bin) -> Bin. + +unused_utf_char(Config) when is_list(Config) -> + [true = utf8_len(Utf8) =:= length(Str) || + {Str,Utf8} <- utf_data()], + ok. + +utf8_len(B) -> + utf8_len(B, 0). + +utf8_len(<<_/utf8,T/binary>>, N) -> + utf8_len(T, N+1); +utf8_len(<<>>, N) -> N. + +utf16_roundtrip(Config) when is_list(Config) -> + ?line {Str,Big,Big,Little,Little} = utf16_data(), + ?line 4 = utf16_big_len(Big), + ?line 4 = utf16_little_len(Little), + ?line Str = big_utf16_to_list(Big), + ?line Str = little_utf16_to_list(Little), + + ?line Big = list_to_big_utf16(Str), + ?line Little = list_to_little_utf16(Str), + + ok. + +utf16_big_len(B) -> + utf16_big_len(B, 0). + +utf16_big_len(<<_/utf16,T/binary>>, N) -> + utf16_big_len(T, N+1); +utf16_big_len(<<>>, N) -> N. + +utf16_little_len(B) -> + utf16_little_len(B, 0). + +utf16_little_len(<<_/little-utf16,T/binary>>, N) -> + utf16_little_len(T, N+1); +utf16_little_len(<<>>, N) -> N. + +list_to_big_utf16(List) -> + list_to_big_utf16(List, <<>>). + +list_to_big_utf16([H|T], Bin) -> + list_to_big_utf16(T, <<Bin/binary,H/utf16>>); +list_to_big_utf16([], Bin) -> Bin. + +list_to_little_utf16(List) -> + list_to_little_utf16(List, <<>>). + +list_to_little_utf16([H|T], Bin) -> + list_to_little_utf16(T, <<Bin/binary,H/little-utf16>>); +list_to_little_utf16([], Bin) -> Bin. + +big_utf16_to_list(<<H/utf16,T/binary>>) -> + [H|big_utf16_to_list(T)]; +big_utf16_to_list(<<>>) -> []. + +little_utf16_to_list(<<H/little-utf16,T/binary>>) -> + [H|little_utf16_to_list(T)]; +little_utf16_to_list(<<>>) -> []. + +utf32_roundtrip(Config) when is_list(Config) -> + ?line {Str,Big,Big,Little,Little} = utf32_data(), + ?line 4 = utf32_big_len(Big), + ?line 4 = utf32_little_len(Little), + ?line Str = big_utf32_to_list(Big), + ?line Str = little_utf32_to_list(Little), + + ?line Big = list_to_big_utf32(Str), + ?line Little = list_to_little_utf32(Str), + + ok. + +utf32_big_len(B) -> + utf32_big_len(B, 0). + +utf32_big_len(<<_/utf32,T/binary>>, N) -> + utf32_big_len(T, N+1); +utf32_big_len(<<>>, N) -> N. + +utf32_little_len(B) -> + utf32_little_len(B, 0). + +utf32_little_len(<<_/little-utf32,T/binary>>, N) -> + utf32_little_len(T, N+1); +utf32_little_len(<<>>, N) -> N. + +list_to_big_utf32(List) -> + list_to_big_utf32(List, <<>>). + +list_to_big_utf32([H|T], Bin) -> + list_to_big_utf32(T, <<Bin/binary,H/utf32>>); +list_to_big_utf32([], Bin) -> Bin. + +list_to_little_utf32(List) -> + list_to_little_utf32(List, <<>>). + +list_to_little_utf32([H|T], Bin) -> + list_to_little_utf32(T, <<Bin/binary,H/little-utf32>>); +list_to_little_utf32([], Bin) -> Bin. + +big_utf32_to_list(<<H/utf32,T/binary>>) -> + [H|big_utf32_to_list(T)]; +big_utf32_to_list(<<>>) -> []. + +little_utf32_to_list(<<H/little-utf32,T/binary>>) -> + [H|little_utf32_to_list(T)]; +little_utf32_to_list(<<>>) -> []. + + +guard(Config) when is_list(Config) -> + ?line error = do_guard(16#D800), + ok. + +do_guard(C) when byte_size(<<C/utf8>>) =/= 42 -> ok; +do_guard(C) when byte_size(<<C/utf16>>) =/= 42 -> ok; +do_guard(C) when byte_size(<<C/utf32>>) =/= 42 -> ok; +do_guard(_) -> error. + +%% The purpose of this test is to make sure that +%% the delayed creation of sub-binaries works. + +extreme_tripping(Config) when is_list(Config) -> + ?line Unicode = lists:seq(0, 1024), + ?line Utf8 = unicode_to_utf8(Unicode, <<>>), + ?line Utf16 = utf8_to_utf16(Utf8, <<>>), + ?line Utf32 = utf8_to_utf32(Utf8, <<>>), + ?line Utf32 = utf16_to_utf32(Utf16, <<>>), + ?line Utf8 = utf32_to_utf8(Utf32, <<>>), + ?line Unicode = utf32_to_unicode(Utf32), + ok. + +unicode_to_utf8([C|T], Bin) -> + unicode_to_utf8(T, <<Bin/bytes,C/utf8>>); +unicode_to_utf8([], Bin) -> Bin. + +utf8_to_utf16(<<C/utf8,T/binary>>, Bin) -> + utf8_to_utf16(T, <<Bin/bytes,C/utf16>>); +utf8_to_utf16(<<>>, Bin) -> Bin. + +utf16_to_utf32(<<C/utf16,T/binary>>, Bin) -> + utf16_to_utf32(T, <<Bin/bytes,C/utf32>>); +utf16_to_utf32(<<>>, Bin) -> Bin. + +utf8_to_utf32(<<C/utf8,T/binary>>, Bin) -> + utf8_to_utf32(T, <<Bin/bytes,C/utf32>>); +utf8_to_utf32(<<>>, Bin) -> Bin. + +utf32_to_utf8(<<C/utf32,T/binary>>, Bin) -> + utf32_to_utf8(T, <<Bin/bytes,C/utf8>>); +utf32_to_utf8(<<>>, Bin) -> Bin. + +utf32_to_unicode(<<C/utf32,T/binary>>) -> + [C|utf32_to_unicode(T)]; +utf32_to_unicode(<<>>) -> []. + +literals(Config) when is_list(Config) -> + ?line abc_utf8 = match_literal(<<"abc"/utf8>>), + ?line abc_utf8 = match_literal(<<$a,$b,$c>>), + + ?line abc_utf16be = match_literal(<<"abc"/utf16>>), + ?line abc_utf16be = match_literal(<<$a:16,$b:16,$c:16>>), + ?line abc_utf16le = match_literal(<<"abc"/little-utf16>>), + ?line abc_utf16le = match_literal(<<$a:16/little,$b:16/little,$c:16/little>>), + + ?line abc_utf32be = match_literal(<<"abc"/utf32>>), + ?line abc_utf32be = match_literal(<<$a:32,$b:32,$c:32>>), + ?line abc_utf32le = match_literal(<<"abc"/little-utf32>>), + ?line abc_utf32le = match_literal(<<$a:32/little,$b:32/little,$c:32/little>>), + + ?line bjorn_utf8 = match_literal(<<"bj\366rn"/utf8>>), + ?line bjorn_utf8 = match_literal(<<$b,$j,195,182,$r,$n>>), + + ?line bjorn_utf16be = match_literal(<<"bj\366rn"/utf16>>), + ?line bjorn_utf16be = match_literal(<<$b:16,$j:16,246:16,$r:16,$n:16>>), + ?line bjorn_utf16le = match_literal(<<"bj\366rn"/little-utf16>>), + ?line bjorn_utf16le = match_literal(<<$b:16/little,$j:16/little, + 246:16/little,$r:16/little, + $n:16/little>>), + ?line <<244,143,191,191>> = <<16#10ffff/utf8>>, + + %% Invalid literals. + I = 0, + ?line {'EXIT',{badarg,_}} = (catch <<(-1)/utf8,I/utf8>>), + ?line {'EXIT',{badarg,_}} = (catch <<(-1)/utf16,I/utf8>>), + ?line {'EXIT',{badarg,_}} = (catch <<(-1)/little-utf16,I/utf8>>), + ?line {'EXIT',{badarg,_}} = (catch <<(-1)/utf32,I/utf8>>), + ?line {'EXIT',{badarg,_}} = (catch <<(-1)/little-utf32,I/utf8>>), + ?line {'EXIT',{badarg,_}} = (catch <<16#D800/utf8,I/utf8>>), + ?line {'EXIT',{badarg,_}} = (catch <<16#FFFE/utf8,I/utf8>>), + ?line {'EXIT',{badarg,_}} = (catch <<16#FFFF/utf8,I/utf8>>), + ?line {'EXIT',{badarg,_}} = (catch <<16#D800/utf16,I/utf8>>), + ?line {'EXIT',{badarg,_}} = (catch <<16#D800/little-utf16,I/utf8>>), + ?line {'EXIT',{badarg,_}} = (catch <<16#FFFE/utf16,I/utf8>>), + ?line {'EXIT',{badarg,_}} = (catch <<16#FFFE/little-utf16,I/utf8>>), + ?line {'EXIT',{badarg,_}} = (catch <<16#FFFF/utf16,I/utf8>>), + ?line {'EXIT',{badarg,_}} = (catch <<16#FFFF/little-utf16,I/utf8>>), + ?line {'EXIT',{badarg,_}} = (catch <<16#D800/utf32,I/utf8>>), + ?line {'EXIT',{badarg,_}} = (catch <<16#D800/little-utf32,I/utf8>>), + ?line {'EXIT',{badarg,_}} = (catch <<16#FFFE/utf32,I/utf8>>), + ?line {'EXIT',{badarg,_}} = (catch <<16#FFFF/little-utf32,I/utf8>>), + + B = 16#10FFFF+1, + ?line {'EXIT',{badarg,_}} = (catch <<B/utf8>>), + ?line {'EXIT',{badarg,_}} = (catch <<B/utf16>>), + ?line {'EXIT',{badarg,_}} = (catch <<B/little-utf16>>), + ?line {'EXIT',{badarg,_}} = (catch <<B/utf32>>), + ?line {'EXIT',{badarg,_}} = (catch <<B/little-utf32>>), + + %% Matching of bad literals. + ?line error = bad_literal_match(<<237,160,128>>), %16#D800 in UTF-8 + ?line error = bad_literal_match(<<239,191,190>>), %16#FFFE in UTF-8 + ?line error = bad_literal_match(<<239,191,191>>), %16#FFFF in UTF-8 + ?line error = bad_literal_match(<<244,144,128,128>>), %16#110000 in UTF-8 + + ?line error = bad_literal_match(<<255,254>>), %16#FFFE in UTF-16 + ?line error = bad_literal_match(<<255,255>>), %16#FFFF in UTF-16 + + ?line error = bad_literal_match(<<16#D800:32>>), + ?line error = bad_literal_match(<<16#FFFE:32>>), + ?line error = bad_literal_match(<<16#FFFF:32>>), + ?line error = bad_literal_match(<<16#110000:32>>), + ?line error = bad_literal_match(<<16#D800:32/little>>), + ?line error = bad_literal_match(<<16#FFFE:32/little>>), + ?line error = bad_literal_match(<<16#FFFF:32/little>>), + ?line error = bad_literal_match(<<16#110000:32/little>>), + + ok. + +match_literal(<<"abc"/utf8>>) -> abc_utf8; +match_literal(<<"abc"/big-utf16>>) -> abc_utf16be; +match_literal(<<"abc"/little-utf16>>) -> abc_utf16le; +match_literal(<<"abc"/big-utf32>>) -> abc_utf32be; +match_literal(<<"abc"/little-utf32>>) -> abc_utf32le; +match_literal(<<"bj\366rn"/utf8>>) -> bjorn_utf8; +match_literal(<<"bj\366rn"/big-utf16>>) -> bjorn_utf16be; +match_literal(<<"bj\366rn"/little-utf16>>) -> bjorn_utf16le. + +bad_literal_match(<<16#D800/utf8>>) -> ok; +bad_literal_match(<<16#FFFE/utf8>>) -> ok; +bad_literal_match(<<16#FFFF/utf8>>) -> ok; +bad_literal_match(<<16#110000/utf8>>) -> ok; +bad_literal_match(<<16#FFFE/utf16>>) -> ok; +bad_literal_match(<<16#FFFF/utf16>>) -> ok; +bad_literal_match(<<16#D800/utf32>>) -> ok; +bad_literal_match(<<16#110000/utf32>>) -> ok; +bad_literal_match(<<16#D800/little-utf32>>) -> ok; +bad_literal_match(<<16#110000/little-utf32>>) -> ok; +bad_literal_match(_) -> error. + +coverage(Config) when is_list(Config) -> + %% Cover bit syntax matching optimizations in v3_kernel. + ?line 0 = coverage_1(<<4096/utf8,65536/utf8,0>>), + ?line 1 = coverage_1(<<4096/utf8,65536/utf8,1>>), + + ?line 0 = coverage_2(<<4096/utf8,65536/utf8,0>>), + ?line 1 = coverage_2(<<1024/utf8,1025/utf8,1>>), + + ?line {'EXIT',{function_clause,_}} = (catch coverage_3(1)), + + %% Cover beam_flatten (combining the heap allocation in + %% a subsequent test_heap instruction into the bs_init2 + %% instruction). + {ok,<<533/utf8>>} = cover_test_heap_utf8(533), + {ok,<<1024/utf16>>} = cover_test_heap_utf16(1024), + {ok,<<7966/utf32>>} = cover_test_heap_utf32(7966), + + ok. + +coverage_1(<<4096/utf8,65536/utf8,0>>) -> 0; +coverage_1(<<4096/utf8,65536/utf8,1>>) -> 1. + +coverage_2(<<4096/utf8,65536/utf8,0>>) -> 0; +coverage_2(<<1024/utf8,1025/utf8,1>>) -> 1. + +coverage_3(<<16#7fffffff/utf8,65536/utf8,0>>) -> 0. + +cover_test_heap_utf8(C) -> {ok,<<C/utf8>>}. +cover_test_heap_utf16(C) -> {ok,<<C/utf16>>}. +cover_test_heap_utf32(C) -> {ok,<<C/utf32>>}. + +utf_data() -> +%% From RFC-3629. + + %% Give the compiler a chance to do some constant propagation. + NotIdentical = 16#2262, + + [ + %% "A<NOT IDENTICAL TO><ALPHA>." + {[16#0041,NotIdentical,16#0391,16#002E], + <<16#0041/utf8,NotIdentical/utf8,16#0391/utf8,16#002E/utf8>>, + <<16#41,16#E2,16#89,16#A2,16#CE,16#91,16#2E>>}, + + %% Korean "hangugeo" (meaning "the Korean language") + {[16#D55C,16#AD6D,16#C5B4], + <<16#D55C/utf8,16#AD6D/utf8,16#C5B4/utf8>>, + <<16#ED,16#95,16#9C,16#EA,16#B5,16#AD,16#EC,16#96,16#B4>>}, + + %% Japanese "nihongo" (meaning "the Japanese language"). + {[16#65E5,16#672C,16#8A9E], + <<16#65E5/utf8,16#672C/utf8,16#8A9E/utf8>>, + <<16#E6,16#97,16#A5,16#E6,16#9C,16#AC,16#E8,16#AA,16#9E>>} + ]. + +utf16_data() -> + %% Example from RFC-2781. "*=Ra", where "*" represents a + %% hypothetical Ra hieroglyph (code point 16#12345). + + %% Give the compiler a chance to do some constant propagation. + RaHieroglyph = 16#12345, + + %% First as a list of Unicode characters. + {[RaHieroglyph,16#3D,16#52,16#61], + + %% Big endian (the two binaries should be equal). + <<RaHieroglyph/big-utf16,16#3D/big-utf16,16#52/big-utf16,16#61/big-utf16>>, + <<16#D8,16#08,16#DF,16#45,16#00,16#3D,16#00,16#52,16#00,16#61>>, + + %% Little endian (the two binaries should be equal). + <<RaHieroglyph/little-utf16,16#3D/little-utf16, + 16#52/little-utf16,16#61/little-utf16>>, + <<16#08,16#D8,16#45,16#DF,16#3D,16#00,16#52,16#00,16#61,16#00>>}. + +utf32_data() -> + %% "A<NOT IDENTICAL TO><ALPHA>." + NotIdentical = 16#2262, + {[16#0041,NotIdentical,16#0391,16#002E], + + %% Big endian. + <<16#0041/utf32,NotIdentical/utf32,16#0391/utf32,16#002E/utf32>>, + <<16#41:32,NotIdentical:32,16#0391:32,16#2E:32>>, + + %% Little endian. + <<16#0041/little-utf32,NotIdentical/little-utf32, + 16#0391/little-utf32,16#002E/little-utf32>>, + <<16#41:32/little,NotIdentical:32/little, + 16#0391:32/little,16#2E:32/little>>}. + diff --git a/lib/compiler/test/compilation_SUITE.erl b/lib/compiler/test/compilation_SUITE.erl new file mode 100644 index 0000000000..d4843c9eba --- /dev/null +++ b/lib/compiler/test/compilation_SUITE.erl @@ -0,0 +1,599 @@ +%% +%% %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% +%% +%%% Purpose : Compiles various modules with tough code + +-module(compilation_SUITE). + +-include("test_server.hrl"). + +-compile(export_all). + +all(suite) -> + test_lib:recompile(?MODULE), + [self_compile_old_inliner,self_compile, + compiler_1,compiler_3,compiler_5, + beam_compiler_1, beam_compiler_2, beam_compiler_3, + beam_compiler_4, beam_compiler_5, beam_compiler_6, + beam_compiler_7, beam_compiler_8, beam_compiler_9, + beam_compiler_10, beam_compiler_11, beam_compiler_12, + nested_tuples_in_case_expr, + otp_2330, guards, vsn, + otp_2380, otp_2141, otp_2173, otp_4790, + const_list_256, + bin_syntax_1, bin_syntax_2, bin_syntax_3, + bin_syntax_4, bin_syntax_5, bin_syntax_6, + live_var, convopts, + bad_functional_value, + catch_in_catch, redundant_case, long_string, + otp_5076, complex_guard, otp_5092, otp_5151, + otp_5235,otp_5244, + trycatch_4, opt_crash, + otp_5404,otp_5436,otp_5481,otp_5553,otp_5632, + otp_5714,otp_5872,otp_6121,otp_6121a,otp_6121b, + otp_7202,otp_7345,on_load + ]. + +-define(comp(N), + N(Config) when is_list(Config) -> try_it(N, Config)). + +-define(comp_fail(N), + N(Config) when is_list(Config) -> failure(N, Config)). + +?comp(compiler_1). +?comp(compiler_3). +?comp(compiler_4). +?comp(compiler_5). + +?comp(beam_compiler_1). +?comp(beam_compiler_2). +?comp(beam_compiler_3). +?comp(beam_compiler_4). +?comp(beam_compiler_5). +?comp(beam_compiler_6). +?comp(beam_compiler_8). +?comp(beam_compiler_9). +?comp(beam_compiler_10). +?comp(beam_compiler_11). +?comp(beam_compiler_12). +?comp(beam_compiler_13). + +?comp(nested_tuples_in_case_expr). + +?comp(otp_2330). +?comp(otp_2380). +?comp(otp_2141). +?comp(otp_2173). +?comp(otp_4790). +?comp(otp_5235). + +?comp(otp_5244). + +?comp(guards). + +?comp(pattern_expr). + +?comp(const_list_256). + +?comp(bin_syntax_1). +?comp(bin_syntax_2). +?comp(bin_syntax_3). +?comp(bin_syntax_4). + +?comp(bin_syntax_6). + +?comp(otp_5076). + +?comp(complex_guard). + +?comp(otp_5092). +?comp(otp_5151). + +%%% By Per Gustafsson <[email protected]> + +bin_syntax_5(Config) when is_list(Config) -> + {<<45>>,<<>>} = split({int, 1}, <<1:16,45>>). + +split({int, N}, <<N:16,B:N/binary,T/binary>>) -> + {B,T}. + +%% This program works with the old version of the compiler +%% but, the core erlang that it produces have the same variable appearing +%% looks like this: +%% +%% split({int, N}, <<_core1:16, B:N/binary, T/binary>>) when _core1==N +%% +%% with my change it will look like this: +%% +%% split({int, N}, <<_core1:16, B:_core1/binary, T/binary>>) when _core1==N +%% +%% This means that everything worked fine as long as the pattern +%% matching order was left-to-right but on core erlang any order should be possible + +?comp(live_var). + +?comp(trycatch_4). +?comp(bad_functional_value). + +?comp(catch_in_catch). + +?comp(opt_crash). + +?comp(otp_5404). +?comp(otp_5436). +?comp(otp_5481). +?comp(otp_5553). +?comp(otp_5632). +?comp(otp_5714). +?comp(otp_5872). +?comp(otp_6121). +?comp(otp_6121a). +?comp(otp_6121b). +?comp(convopts). +?comp(otp_7202). +?comp(on_load). + +beam_compiler_7(doc) -> + "Code snippet submitted from Ulf Wiger which fails in R3 Beam."; +beam_compiler_7(suite) -> []; +beam_compiler_7(Config) when list(Config) -> + ?line done = empty(2, false). + +empty(N, Toggle) when N > 0 -> + %% R3 Beam copies the second argument to the first before call. + empty(N-1, not(Toggle)); +empty(_, _) -> + done. + +redundant_case(Config) when is_list(Config) -> + d = redundant_case_1(1), + d = redundant_case_1(2), + d = redundant_case_1(3), + d = redundant_case_1(4), + d = redundant_case_1(5), + d = redundant_case_1({glurf,glarf}), + ok. + +%% This function always returns 'd'. Check that the compiler otptimizes +%% it properly. +redundant_case_1(1) -> d; +redundant_case_1(2) -> d; +redundant_case_1(3) -> d; +redundant_case_1(4) -> d; +redundant_case_1(_) -> d. + +failure(Module, Conf) -> + ?line Src = filename:join(?config(data_dir, Conf), atom_to_list(Module)), + ?line Out = ?config(priv_dir,Conf), + ?line io:format("Compiling: ~s\n", [Src]), + ?line CompRc = compile:file(Src, [{outdir,Out},return,time]), + ?line io:format("Result: ~p\n",[CompRc]), + ?line case CompRc of + error -> ok; + {error,Errors,_} -> check_errors(Errors); + _ -> test_server:fail({no_error, CompRc}) + end, + ok. + +check_errors([{_,Eds}|T]) -> + check_error(Eds), + check_errors(T); +check_errors([]) -> ok. + +check_error([{_,Mod,Error}|T]) -> + check_error_1(Mod:format_error(Error)), + check_error(T); +check_error([{Mod,Error}|T]) -> + check_error_1(Mod:format_error(Error)), + check_error(T); +check_error([]) -> ok. + +check_error_1(Str0) -> + Str = lists:flatten(Str0), + io:format("~s\n", [Str]), + case Str of + "internal"++_=Str -> + ?t:fail(internal_compiler_error); + _ -> + ok + end. + +-define(TC(Body), tc(fun() -> Body end, ?LINE)). + +try_it(Module, Conf) -> + %% Change 'false' to 'true' to start a new node for every module. + try_it(false, Module, Conf). + +try_it(StartNode, Module, Conf) -> + ?line OtherOpts = [], %Can be changed to [time] if needed + ?line Src = filename:join(?config(data_dir, Conf), atom_to_list(Module)), + ?line Out = ?config(priv_dir,Conf), + ?line io:format("Compiling: ~s\n", [Src]), + ?line CompRc0 = compile:file(Src, [clint,{outdir,Out},report, + bin_opt_info|OtherOpts]), + ?line io:format("Result: ~p\n",[CompRc0]), + ?line {ok,_Mod} = CompRc0, + + ?line Dog = test_server:timetrap(test_server:minutes(10)), + Node = case StartNode of + false -> + node(); + true -> + ?line Pa = "-pa " ++ filename:dirname(code:which(?MODULE)), + ?line {ok,Node0} = start_node(compiler, Pa), + Node0 + end, + + ?line ok = rpc:call(Node, ?MODULE, load_and_call, [Out, Module]), + ?line load_and_call(Out, Module), + ?line test_server:timetrap_cancel(Dog), + + ?line NewDog = test_server:timetrap(test_server:minutes(10)), + ?line io:format("Compiling (without optimization): ~s\n", [Src]), + ?line CompRc1 = compile:file(Src, + [no_copt,no_postopt,{outdir,Out},report|OtherOpts]), + + ?line io:format("Result: ~p\n",[CompRc1]), + ?line {ok,_Mod} = CompRc1, + ?line ok = rpc:call(Node, ?MODULE, load_and_call, [Out, Module]), + ?line test_server:timetrap_cancel(NewDog), + + ?line LastDog = test_server:timetrap(test_server:minutes(10)), + ?line io:format("Compiling (with old inliner): ~s\n", [Src]), + ?line CompRc2 = compile:file(Src, [{outdir,Out},report,bin_opt_info, + {inline,1000}|OtherOpts]), + ?line io:format("Result: ~p\n",[CompRc2]), + ?line {ok,_Mod} = CompRc2, + ?line ok = rpc:call(Node, ?MODULE, load_and_call, [Out, Module]), + ?line test_server:timetrap_cancel(LastDog), + + case StartNode of + false -> ok; + true -> ?line test_server:stop_node(Node) + end, + ?line test_server:timetrap_cancel(LastDog), + ok. + +load_and_call(Out, Module) -> + ?line io:format("Loading...\n",[]), + ?line {module,Module} = code:load_abs(filename:join(Out, Module)), + + ?line io:format("Calling...\n",[]), + %% Call M:M, and expect ok back, that's our interface + ?line CallRc = Module:Module(), + ?line io:format("Got value: ~p\n",[CallRc]), + + ?line ok = CallRc, + + %% Smoke-test of beam disassembler. + ?line test_lib:smoke_disasm(Module), + + ?line true = erlang:delete_module(Module), + ?line true = erlang:purge_module(Module), + + %% Restore state of trap_exit just in case. (Since the compiler + %% uses a temporary process, we will get {'EXIT',Pid,normal} messages + %% if trap_exit is true.) + + process_flag(trap_exit, false), + ok. + + +tc(F, Line) -> + {Diff,Value} = timer:tc(erlang, apply, [F,[]]), + io:format("~p: ~p\n", [Line,Diff]), + Value. + +start_node(Name, Args) -> + case test_server:start_node(Name, slave, [{args, Args}]) of + {ok, Node} -> + {ok, Node}; + Error -> + ?line test_server:fail(Error) + end. + +from(H, [H | T]) -> T; +from(H, [_ | T]) -> from(H, T); +from(_, []) -> []. + +vsn(suite) -> [vsn_1, vsn_2, vsn_3]. + +vsn_1(doc) -> + "Test generation of 'vsn' attribute"; +vsn_1(suite) -> []; +vsn_1(Conf) when list(Conf) -> + ?line M = vsn_1, + + ?line compile_load(M, ?config(data_dir, Conf), Conf), + ?line Vsn1 = get_vsn(M), + ?line timer:sleep(1000), + + ?line compile_load(M, ?config(data_dir, Conf), Conf), + ?line Vsn2 = get_vsn(M), + + ?line compile_load(M, filename:join(?config(data_dir, Conf), "other"), + Conf), + ?line Vsn3 = get_vsn(M), + ?line if + Vsn1 == Vsn2, Vsn2 == Vsn3 -> + ok; + true -> + test_server:fail({vsn, Vsn1, Vsn2, Vsn3}) + end, + ok. + +vsn_2(doc) -> + "Test overriding of generation of 'vsn' attribute"; +vsn_2(suite) -> []; +vsn_2(Conf) when list(Conf) -> + ?line M = vsn_2, + + ?line compile_load(M, ?config(data_dir, Conf), Conf), + ?line Vsn = get_vsn(M), + ?line case Vsn of + [34] -> + ok; + _ -> + test_server:fail({vsn, Vsn}) + end, + ok. + +vsn_3(doc) -> + "Test that different code yields different generated 'vsn'"; +vsn_3(suite) -> []; +vsn_3(Conf) when list(Conf) -> + ?line M = vsn_3, + + ?line compile_load(M, ?config(data_dir, Conf), Conf), + ?line Vsn1 = get_vsn(M), + + ?line compile_load(M, filename:join(?config(data_dir, Conf), "other"), + Conf), + ?line Vsn2 = get_vsn(M), + ?line if + Vsn1 /= Vsn2 -> + ok; + true -> + test_server:fail({vsn, Vsn1, Vsn2}) + end, + ok. + +get_vsn(M) -> + {value, {vsn, V}} = lists:keysearch(vsn, 1, M:module_info(attributes)), + V. + +long_string(Config) when is_list(Config) -> + %% The test must complete in one minute - it should be plenty of time. + ?line Dog = test_server:timetrap(test_server:minutes(1)), + ?line try_it(long_string, Config), + ?line test_server:timetrap_cancel(Dog), + ok. + +compile_load(Module, Dir, Conf) -> + ?line Src = filename:join(Dir, atom_to_list(Module)), + ?line Out = ?config(priv_dir,Conf), + ?line CompRc = compile:file(Src, [{outdir,Out}]), + ?line {ok, Module} = CompRc, + ?line code:purge(Module), + ?line {module, Module} = + code:load_abs(filename:join(Out, atom_to_list(Module))), + ok. + +self_compile(Config) when is_list(Config) -> + self_compile_1(Config, "new", [inline]). + +self_compile_old_inliner(Config) when is_list(Config) -> + %% The old inliner is useful for testing that sys_core_fold does not + %% introduce name capture problems. + self_compile_1(Config, "old", [verbose,{inline,500}]). + +self_compile_1(Config, Prefix, Opts) -> + ?line Dog = test_server:timetrap(test_server:minutes(40)), + + ?line Priv = ?config(priv_dir,Config), + ?line Version = compiler_version(), + + %% Compile the compiler. (In this node to get better coverage.) + ?line CompA = make_compiler_dir(Priv, Prefix++"compiler_a"), + ?line VsnA = Version ++ ".0", + ?line compile_compiler(compiler_src(), CompA, VsnA, [clint|Opts]), + + %% Compile the compiler again using the newly compiled compiler. + %% (In another node because reloading the compiler would disturb cover.) + CompilerB = Prefix++"compiler_b", + ?line CompB = make_compiler_dir(Priv, Prefix++"compiler_b"), + ?line VsnB = VsnA ++ ".0", + ?line self_compile_node(CompilerB, CompA, CompB, VsnB, Opts), + + %% Compare compiler directories. + ?line compare_compilers(CompA, CompB), + + %% Compile and compare compiler C. + ?line CompilerC = Prefix++"compiler_c", + ?line CompC = make_compiler_dir(Priv, CompilerC), + ?line VsnC = VsnB ++ ".0", + ?line self_compile_node(CompilerC, CompB, CompC, VsnC, Opts), + ?line compare_compilers(CompB, CompC), + + ?line test_server:timetrap_cancel(Dog), + ok. + +self_compile_node(NodeName0, CompilerDir, OutDir, Version, Opts) -> + ?line NodeName = list_to_atom(NodeName0), + ?line Dog = test_server:timetrap(test_server:minutes(10)), + ?line Pa = "-pa " ++ filename:dirname(code:which(?MODULE)) ++ + " -pa " ++ CompilerDir, + ?line {ok,Node} = start_node(NodeName, Pa), + ?line Files = compiler_src(), + ?line ok = rpc:call(Node, ?MODULE, compile_compiler, [Files,OutDir,Version,Opts]), + ?line test_server:stop_node(Node), + ?line test_server:timetrap_cancel(Dog), + ok. + +compile_compiler(Files, OutDir, Version, InlineOpts) -> + io:format("~s", [code:which(compile)]), + io:format("Compiling ~s into ~s", [Version,OutDir]), + Opts = [report, + bin_opt_info, + {outdir,OutDir}, + {d,'COMPILER_VSN',"\""++Version++"\""}, + nowarn_shadow_vars, + {i,filename:join(code:lib_dir(stdlib), "include")}|InlineOpts], + lists:foreach(fun(File) -> + {ok,_} = compile:file(File, Opts) + end, Files). + +compiler_src() -> + filelib:wildcard(filename:join([code:lib_dir(compiler), "src", "*.erl"])). + +compiler_modules(Dir) -> + Files = filelib:wildcard(filename:join(Dir, "*.beam")), + [list_to_atom(filename:rootname(filename:basename(F))) || F <- Files]. + +make_compiler_dir(Priv, Dir0) -> + ?line Dir = filename:join(Priv, Dir0), + ?line ok = file:make_dir(Dir), + Dir. + +make_current(Dir) -> + true = code:add_patha(Dir), + lists:foreach(fun(File) -> + c:l(File) + end, compiler_modules(Dir)), + io:format("~p\n", [code:which(compile)]). + +compiler_version() -> + {value,{version,Version}} = lists:keysearch(version, 1, + compile:module_info(compile)), + Version. + +compare_compilers(ADir, BDir) -> + {[],[],D} = beam_lib:cmp_dirs(ADir, BDir), + [] = [T || {A,_}=T <- D, + filename:basename(A) =/= "beam_asm.beam"]. %Contains compiler version. + + +%%% +%%% The only test of the following code is that it compiles. +%%% + +%% Slightly simplifed from megaco_binary_term_id_gen. +%% beam_block failed to note that the {gc_bif,'-'...} instruction could +%% fail, and that therefore {y,0} need to be initialized. +%% {allocate,8,6}. +%% %% {init,{y,0}} needed here. +%% {get_list,{x,1},{x,6},{x,7}}. +%% {'catch',{y,7},{f,3}}. +%% {move,{x,4},{y,1}}. +%% {move,{x,3},{y,2}}. +%% {move,{x,2},{y,3}}. +%% {move,{x,5},{y,4}}. +%% {move,{x,7},{y,5}}. +%% {move,{x,6},{y,6}}. +%% {gc_bif,'-',{f,0},8,[{x,3},{x,6}],{x,0}}. +%% {move,{x,0},{y,0}}. + +encode_wildcards3([],[],_,_) -> []; +encode_wildcards3([Level|Levels],[BitsInLevel|BitsRest],LevelNo,TotSize) -> + case (catch ?MODULE:encode_wildcard(Level,BitsInLevel,TotSize-BitsInLevel, + length(Levels))) of + {'EXIT',{Reason,Info}} -> + exit({Reason,{LevelNo,Info}}); + + no_wildcard -> + encode_wildcards3(Levels,BitsRest,LevelNo+1,TotSize-BitsInLevel); + + {level,Wl} -> + [Wl| + encode_wildcards3(Levels,BitsRest,LevelNo+1,TotSize-BitsInLevel)]; + + {recursive,Wr} -> + [Wr] + end. + +%% Slightly simplified code from hipe_rtl_ssapre. +%% beam_block used to do the following incorrect optimization: +%% +%% {gc_bif,length,{f,0},1,[{x,0}],{x,3}}. +%% ^^^^^ Was {x,0} - changing to {x,3} is not safe. +%% {gc_bif,'+',{f,0},0,[{y,2},{integer,1}],{x,0}}. +%% ^^^ Only one register live +%% . . . +%% {call_last,4,{f,2},4}. %% beam_validator noted that {x,3} wasn't live. + +find_operands(Cfg,XsiGraph,[],_Count) -> + {Cfg,XsiGraph}; +find_operands(Cfg,XsiGraph,ActiveList,Count) -> + {NewCfg,TempActiveList}=?MODULE:find_operands_for_active_list(Cfg,XsiGraph, + ActiveList,[]), + NewActiveList=lists:reverse(TempActiveList), + [Count+1, length(NewActiveList), length(digraph:vertices(XsiGraph))], + find_operands(NewCfg,XsiGraph,NewActiveList,Count+1). + + +%% The following code +%% +%% {get_list,{x,2},{x,0},{x,1}}. +%% {gc_bif,length,{f,0},1,[{x,0}],{x,0}}. +%% {move,{x,0},{x,1}}. +%% +%% was incorrectly optimized to +%% +%% {get_list,{x,2},{x,0},{y,0}}. +%% {gc_bif,length,{f,0},3,[{x,0}],{x,1}}. +%% +%% because beam_block:is_transparent({x,1}, +%% {gc_bif,length,{f,0},3,[{x,0}],{x,1}} +%% incorrectly returned true. + +-record(contextId,{cid,device_type,contextRef}). +-record(dpRef,{cid,tlli,ms_device_context_id}). +-record(qosProfileBssgp,{peak_bit_rate_msb, + peak_bit_rate_lsb, + t_a_precedence}). +-record(llUnitdataReq,{sapi, + l3_pdu_length, + pdu_life}). +-record(ptmsi,{value}). + +otp_7345(Config) when is_list(Config) -> + #llUnitdataReq{l3_pdu_length=3,pdu_life=4} = + otp_7345(#contextId{}, 0, [[1,2,3],4,5]). + + +otp_7345(ObjRef, _RdEnv, Args) -> + Cid = ObjRef#contextId.cid, + _DpRef = + #dpRef{cid = Cid, + ms_device_context_id = cid_id, + tlli = #ptmsi{value = 0}}, + _QosProfile = + #qosProfileBssgp{peak_bit_rate_msb = 0, + peak_bit_rate_lsb = 80, + t_a_precedence = 49}, + [Cpdu|_] = Args, + LlUnitdataReq = + #llUnitdataReq{sapi = 7, + l3_pdu_length = length(Cpdu), + pdu_life = + id(42) + div + 10}, + id(LlUnitdataReq). + +id(I) -> I. diff --git a/lib/compiler/test/compilation_SUITE_data/bad_functional_value.erl b/lib/compiler/test/compilation_SUITE_data/bad_functional_value.erl new file mode 100644 index 0000000000..126a573e83 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/bad_functional_value.erl @@ -0,0 +1,28 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2003-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +-module(bad_functional_value). + +-export([?MODULE/0,a/0]). + +?MODULE() -> + ok. + +a() -> + .list_to_atom("ok"). + diff --git a/lib/compiler/test/compilation_SUITE_data/beam_compiler_1.erl b/lib/compiler/test/compilation_SUITE_data/beam_compiler_1.erl new file mode 100644 index 0000000000..d6c9c869c8 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/beam_compiler_1.erl @@ -0,0 +1,31 @@ +%% +%% %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_compiler_1). +-export([beam_compiler_1/0]). + +beam_compiler_1() -> + ok. + +-record(foo,{a,b}). + +try_me() -> + X = #foo{}, + Y = #foo{}, + {X#foo.a == Y#foo.a,X#foo.b}. + diff --git a/lib/compiler/test/compilation_SUITE_data/beam_compiler_10.erl b/lib/compiler/test/compilation_SUITE_data/beam_compiler_10.erl new file mode 100644 index 0000000000..a1264055bd --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/beam_compiler_10.erl @@ -0,0 +1,27 @@ +%% +%% %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% +%% +-module(beam_compiler_10). +-export([?MODULE/0,start_timer/0]). + +?MODULE() -> + ok. + +start_timer() -> + Self = self(), + spawn(fun() -> receive after 1000 -> Self ! show end end). diff --git a/lib/compiler/test/compilation_SUITE_data/beam_compiler_11.erl b/lib/compiler/test/compilation_SUITE_data/beam_compiler_11.erl new file mode 100644 index 0000000000..4be32ab505 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/beam_compiler_11.erl @@ -0,0 +1,31 @@ +%% +%% %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% +%% +-module(beam_compiler_11). + +-export([?MODULE/0,a/0]). + +?MODULE() -> + ok. + +a() -> + case foo:bar() of + A -> ok + end, + A = 3. + diff --git a/lib/compiler/test/compilation_SUITE_data/beam_compiler_12.erl b/lib/compiler/test/compilation_SUITE_data/beam_compiler_12.erl new file mode 100644 index 0000000000..baee6b9bce --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/beam_compiler_12.erl @@ -0,0 +1,29 @@ +%% +%% %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% +%% +-module(beam_compiler_12). + +-export([?MODULE/0,t/1]). + +?MODULE() -> + ok. + +t(Name) -> + {ok = {file_info,_,regular,_,AccTime1,ModTime1,_,_,_,_,_,_,_,_}} = + prim_file:read_file_info(Name). + diff --git a/lib/compiler/test/compilation_SUITE_data/beam_compiler_2.erl b/lib/compiler/test/compilation_SUITE_data/beam_compiler_2.erl new file mode 100644 index 0000000000..0c094d584a --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/beam_compiler_2.erl @@ -0,0 +1,35 @@ +%% +%% %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_compiler_2). +-export([beam_compiler_2/0]). + +beam_compiler_2() -> + ok. + +-record(foo,{a,b}). + +try_me() -> + try_me({foo,x,z},{foo,y,z}). + +try_me(X,Y) -> + f(X#foo.a =/= Y#foo.a,X#foo.b =/= X#foo.b). + +f(A,B) -> + A. + diff --git a/lib/compiler/test/compilation_SUITE_data/beam_compiler_3.erl b/lib/compiler/test/compilation_SUITE_data/beam_compiler_3.erl new file mode 100644 index 0000000000..aced49b69c --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/beam_compiler_3.erl @@ -0,0 +1,29 @@ +%% +%% %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_compiler_3). +-export([beam_compiler_3/0, f/0]). + +%% From Ulf Wiger. + +beam_compiler_3() -> + ok. + +f() -> + [_|T] = lists:reverse("xxx"), + T. diff --git a/lib/compiler/test/compilation_SUITE_data/beam_compiler_4.erl b/lib/compiler/test/compilation_SUITE_data/beam_compiler_4.erl new file mode 100644 index 0000000000..5e74d3cd3c --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/beam_compiler_4.erl @@ -0,0 +1,150 @@ +%% +%% %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_compiler_4). +-export([beam_compiler_4/0]). + +%% From Ulf Wiger. + +beam_compiler_4() -> + ok. + +selected_alarm(_Env, Parameters) -> + UnWebParam = x, + [Time, Severity, Info, Cause, + Type, Sender, Name, FaultId] = bar:foo(), + + %% The following case generates no test heap instructions, + %% but the test heap generated before the call to bar:foo(), + %% will be moved to here. And the number of words to allocate + %% will be ridicously big (> 65535) and will not fit in a 16 big + %% word. + + SenderLink = case Name of + "pchScheduledConnectionAlarm" -> + Sender; + "pchVpVcAlarm" -> + Sender; + "pchSystemMemoryAlarm" -> + Sender; + "uniProtocolRestartFailureAlarm" -> + Sender; + "spvcScheduledConnectionAlarm" -> + Sender; + "eqmSwitchCoreInterfaceAlarm" -> + Sender; + "atmPhysicalLayerAlarm" -> + Sender; + "atmBufferCongestionAlarm" -> + Sender; + "sdhLinkAlarm" -> + Sender; + "sdhFarEndAlarm" -> + Sender; + "sdhUpperQosAlarm" -> + Sender; + "sdhLowerQosAlarm" -> + Sender; + "eqmSwitchCoreAlarm" -> + Sender; + "eqmEtAlarm" -> + Sender; + "eqmHwIdentityFaultAlarm" -> + Sender; + "eqmOperatorBlockedEquipmentAlarm" -> + Sender; + "pdh34PathAlarm" -> + Sender; + "pdh34ObservationAlarm" -> + Sender; + "pdh34UpperQosAlarm" -> + Sender; + "pdh34LowerQosAlarm" -> + Sender; + "nsySynchRefAlarm" -> + Sender; + "nsySynchRefBlockedAlarm" -> + Sender; + "nsySynchNodeHoldoverAlarm" -> + Sender; + "nsySynchNodeNotWorkingAlarm" -> + Sender; + "eqmAtbAlarm" -> + Sender; + "eqmCbEtAlarm" -> + Sender; + "eqmCpAlarm" -> + Sender; + "eqmCpInterfaceAlarm" -> + Sender; + "eqmCbClkAlarm" -> + Sender; + "eqmCbClkInterfaceAlarm" -> + Sender; + "eqmCbClkVelocityAlarm" -> + Sender; + "eqmCbClkPhaseDiffAlarm" -> + Sender; + "eqmHwNotFoundAlarm" -> + Sender; + "eqmPduAlarm" -> + Sender; + "eqmFanAlarm" -> + Sender; + "eqmLocAlarm" -> + Sender; + "eqmCustomerDefined1Alarm" -> + Sender; + "eqmCustomerDefined2Alarm" -> + Sender; + "eqmCustomerDefined3Alarm" -> + Sender; + "eqmCustomerDefined4Alarm" -> + Sender; + "eqmOperatorBlockedLinkAlarm" -> + Sender; + "eqmPowerFilterAlarm" -> + Sender; + "eqmCbAbrAlarm" -> + Sender; + "eqmAlarmCutOffAlarm" -> + Sender; + OtherAlarm -> + Sender + end, + + %% The testHeap instruction generated here will move up to before + %% the case. + + bar:foo("<TABLE> + <TR><TD ALIGN=LEFT>Fault id: + <TD>" ++ FaultId ++ " + <TR><TD ALIGN=LEFT>Name: + <TD>" ++ Name ++ " + <TR><TD ALIGN=LEFT>Sender: + <TD>" ++ SenderLink ++ " + <TR><TD ALIGN=LEFT>Class: + <TD>" ++ Type ++ " + <TR><TD ALIGN=LEFT>Cause: + <TD>" ++ Cause ++ " + <TR><TD ALIGN=LEFT>Severity: + <TD>" ++ Severity ++ " + <TR><TD ALIGN=LEFT>Information: + <TD>" ++ Info ++ " + <TR><TD ALIGN=LEFT>Time: + <TD>" ++ Time). diff --git a/lib/compiler/test/compilation_SUITE_data/beam_compiler_5.erl b/lib/compiler/test/compilation_SUITE_data/beam_compiler_5.erl new file mode 100644 index 0000000000..a23a0d518c --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/beam_compiler_5.erl @@ -0,0 +1,28 @@ +%% +%% %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_compiler_5). +-export([beam_compiler_5/0]). + +-compile(export_all). + +beam_compiler_5() -> + ok. + +t() -> + [_|_] = x. diff --git a/lib/compiler/test/compilation_SUITE_data/beam_compiler_6.erl b/lib/compiler/test/compilation_SUITE_data/beam_compiler_6.erl new file mode 100644 index 0000000000..f263fd75b2 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/beam_compiler_6.erl @@ -0,0 +1,153 @@ +%% +%% %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_compiler_6). +-export([beam_compiler_6/0]). + +%% From Ulf Wiger, modified by Bjorn Gustavsson to provoke the +%% same error with partly corrected compiler in P3A. + +beam_compiler_6() -> + ok. + +selected_alarm(_Env, Parameters) -> + UnWebParam = x, + [Time, Severity, Info, Cause, + Type, Sender, Name, FaultId] = bar:foo(), + + %% Each branch of the case needs two words of heap, + %% but the test heap generated before the call to bar:foo(), + %% will be merged to the testHeap of each branch, summed and + %% moved before the branch. And the number of words to allocate + %% will be ridiculously big (> 65535) and will not fit in a + %% 16 bit word. + + SenderLink = + case Name of + "pchScheduledConnectionAlarm" -> + [Sender]; + "pchVpVcAlarm" -> + [Sender]; + "pchSystemMemoryAlarm" -> + [Sender]; + "uniProtocolRestartFailureAlarm" -> + [Sender]; + "spvcScheduledConnectionAlarm" -> + [Sender]; + "eqmSwitchCoreInterfaceAlarm" -> + [Sender]; + "atmPhysicalLayerAlarm" -> + [Sender]; + "atmBufferCongestionAlarm" -> + [Sender]; + "sdhLinkAlarm" -> + [Sender]; + "sdhFarEndAlarm" -> + [Sender]; + "sdhUpperQosAlarm" -> + [Sender]; + "sdhLowerQosAlarm" -> + [Sender]; + "eqmSwitchCoreAlarm" -> + [Sender]; + "eqmEtAlarm" -> + [Sender]; + "eqmHwIdentityFaultAlarm" -> + [Sender]; + "eqmOperatorBlockedEquipmentAlarm" -> + [Sender]; + "pdh34PathAlarm" -> + [Sender]; + "pdh34ObservationAlarm" -> + [Sender]; + "pdh34UpperQosAlarm" -> + [Sender]; + "pdh34LowerQosAlarm" -> + [Sender]; + "nsySynchRefAlarm" -> + [Sender]; + "nsySynchRefBlockedAlarm" -> + [Sender]; + "nsySynchNodeHoldoverAlarm" -> + [Sender]; + "nsySynchNodeNotWorkingAlarm" -> + [Sender]; + "eqmAtbAlarm" -> + [Sender]; + "eqmCbEtAlarm" -> + [Sender]; + "eqmCpAlarm" -> + [Sender]; + "eqmCpInterfaceAlarm" -> + [Sender]; + "eqmCbClkAlarm" -> + [Sender]; + "eqmCbClkInterfaceAlarm" -> + [Sender]; + "eqmCbClkVelocityAlarm" -> + [Sender]; + "eqmCbClkPhaseDiffAlarm" -> + [Sender]; + "eqmHwNotFoundAlarm" -> + [Sender]; + "eqmPduAlarm" -> + [Sender]; + "eqmFanAlarm" -> + [Sender]; + "eqmLocAlarm" -> + [Sender]; + "eqmCustomerDefined1Alarm" -> + [Sender]; + "eqmCustomerDefined2Alarm" -> + [Sender]; + "eqmCustomerDefined3Alarm" -> + [Sender]; + "eqmCustomerDefined4Alarm" -> + [Sender]; + "eqmOperatorBlockedLinkAlarm" -> + [Sender]; + "eqmPowerFilterAlarm" -> + [Sender]; + "eqmCbAbrAlarm" -> + [Sender]; + "eqmAlarmCutOffAlarm" -> + [Sender]; + OtherAlarm -> + [Sender] + end, + + %% The testHeap instruction generated here will move up to before + %% the case. + + bar:foo("<TABLE> + <TR><TD ALIGN=LEFT>Fault id: + <TD>" ++ FaultId ++ " + <TR><TD ALIGN=LEFT>Name: + <TD>" ++ Name ++ " + <TR><TD ALIGN=LEFT>Sender: + <TD>" ++ SenderLink ++ " + <TR><TD ALIGN=LEFT>Class: + <TD>" ++ Type ++ " + <TR><TD ALIGN=LEFT>Cause: + <TD>" ++ Cause ++ " + <TR><TD ALIGN=LEFT>Severity: + <TD>" ++ Severity ++ " + <TR><TD ALIGN=LEFT>Information: + <TD>" ++ Info ++ " + <TR><TD ALIGN=LEFT>Time: + <TD>" ++ Time). diff --git a/lib/compiler/test/compilation_SUITE_data/beam_compiler_8.erl b/lib/compiler/test/compilation_SUITE_data/beam_compiler_8.erl new file mode 100644 index 0000000000..f1f4839798 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/beam_compiler_8.erl @@ -0,0 +1,31 @@ +%% +%% %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% +%% +-module(beam_compiler_8). + +-compile(export_all). + +beam_compiler_8() -> + ok. + +t(Key, Me) -> + Fun = fun(X) -> + me_rec:key_values(X, Key) < me_rec:key_values(Me, Key) + end. + + diff --git a/lib/compiler/test/compilation_SUITE_data/beam_compiler_9.erl b/lib/compiler/test/compilation_SUITE_data/beam_compiler_9.erl new file mode 100644 index 0000000000..581b908753 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/beam_compiler_9.erl @@ -0,0 +1,67 @@ +%% +%% %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% +%% +-module(beam_compiler_9). + +-export([compile/2, test/0, ?MODULE/0]). + +?MODULE() -> + ok. + +test() -> + Failures = failures(), + compile_files([hd(Failures)]). + +compile_files([File | Files]) -> + Pid = spawn(?MODULE, compile, [File, self()]), + Time = infinity, + receive + done -> + compile_files(Files) + after + Time -> + io:fwrite("Compilation not completed within ~w ms~n", [Time]), + exit(Pid, die), + compile_files(Files) + end; + +compile_files([]) -> + done. + + + +compile(File, Parent) -> + io:fwrite("Compiling: ~s~n", [File]), + statistics(runtime), + statistics(wall_clock), + statistics(reductions), + Result = c:c(File), + {_, Rslc} = statistics(runtime), + {_, Tslc} = statistics(wall_clock), + {_, Reds} = statistics(reductions), + io:fwrite("Result: ~w~n", [Result]), + io:fwrite("Reductions: ~w~n", [Reds]), + io:fwrite("Time: ~w~n", [Tslc]), + io:fwrite("Cpu time: ~w~n", [Rslc]), + io:nl(), + Parent ! done. + + + +failures() -> + [test]. diff --git a/lib/compiler/test/compilation_SUITE_data/bin_syntax_1.erl b/lib/compiler/test/compilation_SUITE_data/bin_syntax_1.erl new file mode 100644 index 0000000000..7df1543d83 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/bin_syntax_1.erl @@ -0,0 +1,31 @@ +%% +%% %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% +%% +-module(bin_syntax_1). + +-export([f/2,?MODULE/0]). + +?MODULE() -> + ok. + +f(X, Y) -> + case X of + a -> + Y2 = 8 + end, + <<5:Y2>> = Y. diff --git a/lib/compiler/test/compilation_SUITE_data/bin_syntax_2.erl b/lib/compiler/test/compilation_SUITE_data/bin_syntax_2.erl new file mode 100644 index 0000000000..dcf7b0f8bd --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/bin_syntax_2.erl @@ -0,0 +1,41 @@ +%% +%% %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% +%% +-module(bin_syntax_2). + +-export([?MODULE/0]). + +%% This module tests that constant propagation is done properly. + +?MODULE() -> + 258 = b(<<1,2>>), + F = c(), + 259 = F(<<1,3>>), + ok. + +b(B) -> + Sz = 16, + <<X:Sz/integer>> = B, + X. + +c() -> + Size = 16, + fun(Bin) -> + <<X:Size/integer>> = Bin, + X + end. diff --git a/lib/compiler/test/compilation_SUITE_data/bin_syntax_3.erl b/lib/compiler/test/compilation_SUITE_data/bin_syntax_3.erl new file mode 100644 index 0000000000..93d35d5628 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/bin_syntax_3.erl @@ -0,0 +1,35 @@ +%% +%% %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% +%% +-module(bin_syntax_3). +-export([?MODULE/0,decode_integer/3]). + +?MODULE() -> + ok. + +decode_integer(Len, <<B1:1,B2:7,Bs/binary>>, RemovedBytes) when B1 == 0 -> + Bin = <<Skip:Len/unit:8, Buffer2/binary>> = <<B1:1,B2:7,Bs/binary>>, + Size = size(Bin), + <<Int:Size/unit:8>> = Bin, + {Int,Buffer2,RemovedBytes}; +decode_integer(Len,<<B1:1,B2:7,Bs/binary>>,RemovedBytes) -> + Bin = <<Skip:Len/unit:8,Buffer2/binary>> = <<B1:1,B2:7,Bs/binary>>, + Size = size(Bin), + <<N:Size/unit:8>> = <<B2,Bs/binary>>, + Int = N - (1 bsl (8 * size(Bin) -1)), + {Int,Buffer2,RemovedBytes}. diff --git a/lib/compiler/test/compilation_SUITE_data/bin_syntax_4.erl b/lib/compiler/test/compilation_SUITE_data/bin_syntax_4.erl new file mode 100644 index 0000000000..fe0ce80270 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/bin_syntax_4.erl @@ -0,0 +1,32 @@ +%% +%% %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% +%% +-module(bin_syntax_4). +-export([?MODULE/0,f4b/2,f4c/2]). + +?MODULE() -> + ok. + +f4b(X, Y) -> + fun (<< A:Y >>, Y, B) -> fum(A, X, Y, B) end. + +f4c(X, Y) -> + fun (Y, << A:Y >>, B) -> fum(A, X, Y, B) end. + +fum(A, B, C, D) -> + {A,B,C,D}. diff --git a/lib/compiler/test/compilation_SUITE_data/bin_syntax_6.erl b/lib/compiler/test/compilation_SUITE_data/bin_syntax_6.erl new file mode 100644 index 0000000000..8de3a9094f --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/bin_syntax_6.erl @@ -0,0 +1,39 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2005-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(bin_syntax_6). +-export([?MODULE/0,x/1,y/1]). + +?MODULE() -> + ok. + +x(X) -> + blurf(), + B = {X,"OK",<<>>}, + catch b({a,B}). + +y(X) -> + blurf(), + B = {X,"OK",<<42>>}, + catch b({a,B}). + +blurf() -> + ok. + +b(_) -> + ok. diff --git a/lib/compiler/test/compilation_SUITE_data/catch_in_catch.erl b/lib/compiler/test/compilation_SUITE_data/catch_in_catch.erl new file mode 100644 index 0000000000..c732a912f0 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/catch_in_catch.erl @@ -0,0 +1,51 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2003-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +-module(catch_in_catch). + +-export([?MODULE/0,do_start/1]). + +?MODULE() -> + process_flag(trap_exit, true), + Pid = spawn_link(?MODULE, do_start, [x]), + receive + {'EXIT',Pid,good_exit} -> ok; + Other -> + io:format("Unexpected: ~p\n", [Other]), + error + after 32000 -> + io:format("No message received\n"), + error + end. + +do_start(Param) -> + init(Param), + exit(good_exit). + +init(Param) -> + process_flag(trap_exit, true), + %% The catches were improperly nested, causing a "No catch found" crash. + (catch begin + foo(Param), + (catch exit(bar)) + end + ), + ignore. + +foo(_) -> + ok. diff --git a/lib/compiler/test/compilation_SUITE_data/compiler_1.erl b/lib/compiler/test/compilation_SUITE_data/compiler_1.erl new file mode 100644 index 0000000000..6dbd80d962 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/compiler_1.erl @@ -0,0 +1,742 @@ +%% +%% %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(compiler_1). +-compile([export_all]). + +compiler_1() -> ok. + +-define(log(Format,Args),mnesia_test_lib:log(Format,Args,?FILE,?LINE)). +-define(warning(Format,Args),?log("<WARNING> " ++ Format,Args)). +-define(error(Format,Args), + mnesia_test_lib:note_error(Format,Args,?FILE,?LINE), + ?log("<ERROR> " ++ Format,Args)). + +-define(match(ExpectedRes,Expr), + fun() -> + AcTuAlReS = (catch (Expr)), + case AcTuAlReS of + ExpectedRes -> + ?log("ok, result as expected: ~p~n",[AcTuAlReS]), + {success,AcTuAlReS}; + _ -> + ?error("actual result was: ~p~n",[AcTuAlReS]), + {fail,AcTuAlReS} + end + end()). + +-define(match_inverse(NotExpectedRes,Expr), + fun() -> + AcTuAlReS = (catch (Expr)), + case AcTuAlReS of + NotExpectedRes -> + ?error("actual result was: ~p~n",[AcTuAlReS]), + {fail,AcTuAlReS}; + _ -> + ?log("ok, result as expected: ~p~n",[AcTuAlReS]), + {success,AcTuAlReS} + end + end()). + +-define(match_receive(ExpectedMsg), + ?match(ExpectedMsg,mnesia_test_lib:pick_msg())). + +%% ExpectedMsgs must be completely bound +-define(match_multi_receive(ExpectedMsgs), + fun() -> + TmPeXpCtEdMsGs = lists:sort(ExpectedMsgs), + ?match(TmPeXpCtEdMsGs, + lists:sort(lists:map(fun(_) -> + mnesia_test_lib:pick_msg() + end, + TmPeXpCtEdMsGs))) + end()). + +-define(setup(), mnesia_test_lib:setup(?FILE,?LINE)). + +-define(start_activities(Nodes), + fun() -> + AcTiViTyPiDs = + lists:map(fun(Node) -> + spawn_link(Node, + mnesia_test_lib, + activity_evaluator, + [self()]) + end, + Nodes), + ?match_multi_receive(AcTiViTyPiDs) + end()). + +-define(start_transactions(Pids), + ?match_multi_receive(lists:map(fun(Pid) -> + Pid ! begin_trans, + {Pid,begin_trans} + end, + Pids))). + +-define(acquire_nodes(N,Nodes), + mnesia_test_lib:acquire_nodes(N,Nodes,?FILE,?LINE)). + + + +%%% Copyright (C) 1996, Ellemtel Telecommunications Systems Laboratories +%%% Author: Hakan Mattsson [email protected] +%%% Purpose: Evil usage of the API +%%% +%%% Invoke all functions in the API and try to cover all legal uses +%%% cases as well the illegal dito. This is a complement to the +%%% other more explicit test cases. +%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% +%%% show/0 +%%% +%%% Prints out the complete test case structure +%%% +%%% show/1 +%%% +%%% Prints out parts of the test case structure +%%% +%%% test/0 +%%% +%%% Run the complete test suite. +%%% Reads Nodes from nodes.profile and starts them if neccessary. +%%% Kills Mnesia and wipes out the Mnesia directories as a starter. +%%% +%%% test/1 +%%% +%%% Run parts of the test suite. +%%% Reads Nodes from nodes.profile and starts them if neccessary. +%%% Kills Mnesia and wipes out the Mnesia directories as a starter. +%%% +%%% test/2 +%%% +%%% Run parts of the test suite on the given Nodes, +%%% assuming that the nodes are up and running. +%%% Kills Mnesia and wipes out the Mnesia directories as a starter. +%%% +%%% test/3 +%%% +%%% Run parts of the test suite on permutations of the given Nodes, +%%% assuming that the nodes are up and running. Uses test/2. +%%% Kills Mnesia and wipes out the Mnesia directories as a starter. +%%% +%%% See the module mnesia_test_lib for further information. +%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +show() -> mnesia_test_lib:show([{?MODULE,all}]). +show(TestCases) -> mnesia_test_lib:show([{?MODULE,TestCases}]). +test() -> mnesia_test_lib:test([{?MODULE,all}]). +test(TestCases) -> mnesia_test_lib:test([{?MODULE,TestCases}]). +test(TestCases,Nodes) -> mnesia_test_lib:test([{?MODULE,TestCases}],Nodes). +test(TestCases,Nodes,Config) -> mnesia_test_lib:test([{?MODULE,TestCases}],Nodes,Config). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +old_all(suite) -> + [ + system_info, table_info, error_description, + db_node_lifecycle, start_and_stop, transaction, checkpoint, backup, + table_lifecycle, replica_management, replica_location, index_lifecycle, + trans_access, dirty_access, table_sync, snmp_access, debug_support + ]. + +trans_access(suite) -> + [ {mnesia_dirty_access_test,all} ]. + +dirty_access(suite) -> + [ {mnesia_trans_access_test,all} ]. + +%% Get meta info about Mnesia +system_info(suite) -> []; +system_info(Nodes) -> + ?match(yes,mnesia:system_info(is_running)), + ?match(Nodes,mnesia:system_info(db_nodes)), + ?match(Nodes,mnesia:system_info(running_db_nodes)), + ?match(true,mnesia:system_info(have_disc)), + ?match(A when atom(A),mnesia:system_info(debug)), + ?match(L when list(L),mnesia:system_info(directory)), + ?match(L when list(L),mnesia:system_info(log_version)), + ?match({_,_},mnesia:system_info(schema_version)), + ?match(L when list(L),mnesia:system_info(tables)), + ?match(L when list(L),mnesia:system_info(local_tables)), + ?match(L when list(L),mnesia:system_info(held_locks)), + ?match(L when list(L),mnesia:system_info(lock_queue)), + ?match(L when list(L),mnesia:system_info(transactions)), + ?match(I when integer(I),mnesia:system_info(transaction_failures)), + ?match(I when integer(I),mnesia:system_info(transaction_commits)), + ?match(I when integer(I),mnesia:system_info(transaction_restarts)), + ?match(L when list(L),mnesia:system_info(checkpoints)), + ?match(A when atom(A),mnesia:system_info(backup_module)), + ?match(true,mnesia:system_info(auto_repair)), + ?match({_,_},mnesia:system_info(dump_log_interval)), + ?match(A when atom(A),mnesia:system_info(dump_log_update_in_place)), + ?match(I when integer(I),mnesia:system_info(transaction_log_writes)), + ?match({'EXIT',{aborted,badarg}},mnesia:system_info(ali_baba)), + done. + +%% Get meta info about table +table_info(suite) -> []; +table_info(Nodes) -> + [Node1,Node2,Node3] = ?acquire_nodes(3,Nodes), + + Tab = table_info, + Type = bag, + ValPos = 3, + Attrs = [k,v], + Arity = length(Attrs) +1, + Schema = [{name,Tab},{type,Type},{attributes,Attrs},{index,[ValPos]}, + {disc_only_copies,[Node1]},{ram_copies,[Node2]},{disc_copies,[Node3]}], + ?match({atomic,ok}, mnesia:create_table(Schema)), + + Size = 10, + Keys = lists:seq(1,Size), + Records = [{Tab,A,7} || A <- Keys], + lists:foreach(fun(Rec) -> ?match(ok,mnesia:dirty_write(Rec)) end,Records), + ?match(Mem when integer(Mem),mnesia:table_info(Tab,memory)), + ?match(Size,mnesia:table_info(Tab,size)), + ?match(Type,mnesia:table_info(Tab,type)), + ?match([Node3],mnesia:table_info(Tab,disc_copies)), + ?match([Node2],mnesia:table_info(Tab,ram_copies)), + ?match([Node1],mnesia:table_info(Tab,disc_only_copies)), + Read = [Node1,Node2,Node3], + ?match(true,lists:member(mnesia:table_info(Tab,where_to_read),Read)), + Write = lists:sort([Node1,Node2,Node3]), + ?match(Write,lists:sort(mnesia:table_info(Tab,where_to_write))), + WriteLock = lists:sort([Node2,Node3]), + ?match([ValPos],mnesia:table_info(Tab,index)), + ?match(Arity,mnesia:table_info(Tab,arity)), + ?match(Attrs,mnesia:table_info(Tab,attributes)), + ?match({Tab,'_','_'},mnesia:table_info(Tab,wild_pattern)), + ?match({atomic,Attrs}, mnesia:transaction(fun() -> + mnesia:table_info(Tab,attributes) end)), + + done. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Add and drop db nodes + +db_node_lifecycle(suite) -> []; +db_node_lifecycle(Nodes) -> + [Node1,Node2] = ?acquire_nodes(2,Nodes), + Tab = db_node_lifecycle, + + Schema = [{name,Tab},{ram_copies,[Node1,Node2]}], + ?match({atomic,ok}, mnesia:create_table(Schema)), + ?match({aborted,active}, rpc:call(Node1,mnesia,del_db_node,[Node2])), + + ?match([], mnesia_test_lib:stop_mnesia(Nodes)), + ?match(ok, mnesia:delete_schema(Nodes)), + ?match({error,_}, mnesia:create_schema(foo)), + ?match({error,_}, mnesia:create_schema([foo])), + ?match({error,_}, mnesia:create_schema([foo@bar])), + ?match({error,_}, mnesia:start()), + + ?match(ok, mnesia:create_schema(Nodes)), + ?match([],mnesia_test_lib:start_mnesia(Nodes)), + ?match({atomic,ok}, rpc:call(Node1,mnesia,del_db_node,[Node2])), + ?match({aborted,no_exists}, rpc:call(Node1,mnesia,del_db_node,[Node2])), + ?match({aborted,no_exists}, rpc:call(Node1,mnesia,del_db_node,[foo])), + ?match({aborted,no_exists}, rpc:call(Node1,mnesia,del_db_node,[foo@bar])), + + ?match([], mnesia_test_lib:stop_mnesia([Node2])), + ?match(ok,mnesia:delete_schema([Node2])), + AddFun = fun() -> ?match({aborted,nested_transaction}, + mnesia:add_db_node(Node2)), ok end, + ?match({atomic,ok},rpc:call(Node1,mnesia,transaction,[AddFun])), + DelFun = fun() -> ?match({aborted,nested_transaction}, + mnesia:del_db_node(Node2)), ok end, + ?match({atomic,ok},rpc:call(Node1,mnesia,transaction,[DelFun])), + + ?match({atomic,ok}, rpc:call(Node1,mnesia,add_db_node,[Node2])), + ?match({aborted,already_exists}, rpc:call(Node1,mnesia,add_db_node,[Node2])), + ?match([],mnesia_test_lib:start_mnesia([Node2])), + ?match({atomic,ok}, mnesia:create_table(Schema)), + done. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Start and stop the system + +start_and_stop(suite) -> []; +start_and_stop(Nodes) -> + [Node1] = ?acquire_nodes(1,Nodes), + + ?match(stopped, rpc:call(Node1,mnesia,stop,[])), + ?match(stopped, rpc:call(Node1,mnesia,stop,[])), + ?match({started,_}, rpc:call(Node1,mnesia,start,[])), + ?match({started,_}, rpc:call(Node1,mnesia,start,[])), + ?match(stopped, rpc:call(Node1,mnesia,stop,[])), + ?match([],mnesia_test_lib:start_mnesia(Nodes)), + done. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Checkpoints and backup management + +checkpoint(suite) -> []; +checkpoint(Nodes) -> + OneNode = ?acquire_nodes(1,Nodes), + checkpoint(OneNode,Nodes), + TwoNodes = ?acquire_nodes(2,Nodes), + checkpoint(TwoNodes,Nodes). + +checkpoint(TabNodes,Nodes) -> + [Node1] = ?acquire_nodes(1,TabNodes), + CreateTab = fun(Type,N,Ns) -> + Tab0 = lists:concat(["local_checkpoint_",Type,N]), + Tab = list_to_atom(Tab0), + Schema = [{name,Tab},{Type,Ns}], + ?match({atomic,ok},mnesia:delete_table(Tab)), + ?match({atomic,ok},mnesia:create_table(Schema)), + Tab + end, + CreateTabs = fun(Type) -> + CreateTab(Type,1,hd(TabNodes)), + CreateTab(Type,2,TabNodes), + CreateTab(Type,3,lists:last(TabNodes)) + end, + Types = [ram_copies,disc_copies,disc_only_copies], + Tabs = lists:append(lists:map(CreateTabs,Types)), + Recs = lists:sort([{T,N,N} || T <- Tabs,N <- lists:seq(1,10)]), + lists:foreach(fun(R) -> ?match(ok,mnesia:dirty_write(R)) end,Recs), + + CpName = a_checkpoint_name, + MinArgs = [{name,CpName},{min,Tabs},{allow_remote,false}], + ?match({ok,CpName,[Node1]}, + rpc:call(Node1,mnesia,activate_checkpoint,[MinArgs])), + ?match(ok,rpc:call(Node1,mnesia,deactivate_checkpoint,[CpName])), + + MaxArgs = [{name,CpName},{max,Tabs},{allow_remote,true}], + ?match({ok,CpName,[Node1]}, + rpc:call(Node1,mnesia,activate_checkpoint,[MaxArgs])), + ?match(ok,rpc:call(Node1,mnesia,deactivate_checkpoint,[CpName])), + + Args = [{name,CpName},{min,Tabs},{allow_remote,false}], + ?match({ok,CpName,[Node1]}, + rpc:call(Node1,mnesia,activate_checkpoint,[Args])), + Recs2 = lists:sort([{T,K,0} || {T,K,_} <- Recs]), + lists:foreach(fun(R) -> ?match(ok,mnesia:dirty_write(R)) end,Recs2), + ?match({atomic,ok},rpc:call(Node1,mnesia,deactivate_checkpoint,[CpName])), + + ?match({error,no_exists},mnesia:deactivate_checkpoint(CpName)), + ?match({error,badarg},mnesia:activate_checkpoint(foo)), + ?match({error,badarg},mnesia:activate_checkpoint([{foo,foo}])), + ?match({error,badarg},mnesia:activate_checkpoint([{max,foo}])), + ?match({error,badarg},mnesia:activate_checkpoint([{min,foo}])), + ?match({error,no_exists},mnesia:activate_checkpoint([{min,[foo@bar]}])), + ?match({error,badarg},mnesia:activate_checkpoint([{allow_remote,foo}])), + + Fun = fun(Tab) -> ?match({atomic,ok},mnesia:delete_table(Tab)) end, + lists:foreach(Fun,Tabs), + done. + +backup(suite) -> + [ + backup_schema, restore_schema, backup_checkpoint, restore_tables + ]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Use and misuse transactions + +transaction(suite) -> []; +transaction(Nodes) -> + [Node1] = ?acquire_nodes(1,Nodes), + ?match({atomic,ali_baba}, mnesia:transaction(fun() -> ali_baba end)), + ?match({aborted,_}, mnesia:transaction(no_fun)), + ?match({aborted,_}, mnesia:transaction(?MODULE,no_fun,[foo])), + + {success,[A,B,C,D,E,F,G,H]} = ?start_activities(lists:duplicate(8,Node1)), + ?start_transactions([A,B,C,D,E,F,G,H]), + + A ! fun() -> mnesia:abort(abort_bad_trans) end, + ?match_receive({A,{aborted,abort_bad_trans}}), + + B ! fun() -> 1 = 2 end, + ?match_receive({B,{aborted,_}}), + + C ! fun() -> throw(throw_bad_trans) end, + ?match_receive({C,{aborted,{throw,throw_bad_trans}}}), + + D ! fun() -> exit(exit_bad_trans) end, + ?match_receive({D,{aborted,exit_bad_trans}}), + + E ! fun() -> exit(normal) end, + ?match_receive({E,{aborted,normal}}), + + F ! fun() -> exit(abnormal) end, + ?match_receive({F,{aborted,abnormal}}), + + G ! fun() -> exit(G,abnormal) end, + ?match_receive({'EXIT',G,abnormal}), + + H ! fun() -> exit(H,kill) end, + ?match_receive({'EXIT',H,killed}), + + ?match({atomic,ali_baba}, + mnesia:transaction(fun() -> ali_baba end,infinity)), + ?match({atomic,ali_baba},mnesia:transaction(fun() -> ali_baba end,1)), + ?match({atomic,ali_baba},mnesia:transaction(fun() -> ali_baba end,0)), + ?match({atomic,ali_baba},mnesia:transaction(fun() -> ali_baba end,-1)), + ?match({atomic,ali_baba},mnesia:transaction(fun() -> ali_baba end,foo)), + Fun = fun() -> ?match({aborted,nested_transaction}, + mnesia:transaction(fun() -> ok end)), ok end, + ?match({atomic,ok},mnesia:transaction(Fun)), + done. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Create and delete tables + +%% Get meta info about table + +replica_location(suite) -> []; +replica_location(Nodes) -> + [Node1,Node2,Node3] = ?acquire_nodes(3,Nodes), + Tab = replica_location, + + %% Create three replicas + Schema = [{name,Tab},{disc_only_copies,[Node1]}, + {ram_copies,[Node2]},{disc_copies,[Node3]}], + ?match({atomic,ok}, mnesia:create_table(Schema)), + mnesia_test_lib:verify_replica_location(Tab,[Node1],[Node2],[Node3],Nodes), + + %% Delete one replica + ?match({atomic,ok}, mnesia:del_table_copy(Tab, Node2)), + mnesia_test_lib:verify_replica_location(Tab,[Node1],[],[Node3],Nodes), + + %% Move one replica + ?match({atomic,ok}, mnesia:move_table_copy(Tab, Node1, Node2)), + mnesia_test_lib:verify_replica_location(Tab,[Node2],[],[Node3],Nodes), + + %% Change replica type + ?match({atomic,ok}, mnesia:change_table_copy_type(Tab, Node2,ram_copies)), + mnesia_test_lib:verify_replica_location(Tab,[],[Node2],[Node3],Nodes), + + done. + +table_lifecycle(suite) -> []; +table_lifecycle(Nodes) -> + [Node1,Node2] = ?acquire_nodes(2,Nodes), + + ?match({atomic,ok}, mnesia:create_table([{type,bag}, + {ram_copies,[Node1]}, + {attributes,[rajtan,tajtan]}, + {name,order_of_args}])), + ?match([],mnesia:dirty_read({order_of_args,4711})), + ?match({atomic,ok}, mnesia:create_table([{name,already_exists}, + {ram_copies,[Node1]}])), + ?match({aborted,already_exists}, + mnesia:create_table([{name,already_exists},{ram_copies,[Node1]}])), + ?match({aborted,not_a_db_node}, + mnesia:create_table([{name,no_node},{ram_copies,[foo]}])), + ?match({aborted,not_a_db_node}, + mnesia:create_table([{name,no_host},{ram_copies,[foo@bar]}])), + ?match({aborted,badarg}, + mnesia:create_table([{name,zero_arity},{attributes,[]}])), + ?match({aborted,badarg}, mnesia:create_table([])), + ?match({aborted,badarg}, mnesia:create_table(atom)), + ?match({aborted,badarg}, + mnesia:create_table({cstruct,table_name_as_atom})), + ?match({aborted,bad_type}, + mnesia:create_table([{name,no_host},{ram_copies,foo}])), + ?match({aborted,bad_type}, + mnesia:create_table([{name,no_host},{disc_only_copies,foo}])), + ?match({aborted,bad_type}, + mnesia:create_table([{name,no_host},{disc_copies,foo}])), + + CreateFun = + fun() -> ?match({aborted,nested_transaction}, + mnesia:create_table([{name,nested_trans}])), ok + end, + ?match({atomic,ok},mnesia:transaction(CreateFun)), + ?match({atomic,ok},mnesia:create_table([{name,remote_tab}, + {ram_copies,[Node2]}])), + + ?match({atomic,ok}, mnesia:create_table([{name,a_brand_new_tab}, + {ram_copies,[Node1]}])), + ?match([],mnesia:dirty_read({a_brand_new_tab,4711})), + ?match({atomic,ok}, mnesia:delete_table(a_brand_new_tab)), + ?match({'EXIT',{aborted,no_exists}}, + mnesia:dirty_read({a_brand_new_tab,4711})), + ?match({aborted,no_exists}, mnesia:delete_table(a_brand_new_tab)), + ?match({aborted,badarg}, mnesia:create_table([])), + + ?match({atomic,ok}, mnesia:create_table([{name,nested_del_trans}, + {ram_copies,[Node1]}])), + DeleteFun = fun() -> ?match({aborted,nested_transaction}, + mnesia:delete_table(nested_del_trans)), ok end, + ?match({atomic,ok}, mnesia:transaction(DeleteFun)), + + ?match({aborted,bad_type}, + mnesia:create_table([{name,create_with_index},{index,2}])), + ?match({aborted,bad_index}, + mnesia:create_table([{name,create_with_index},{index,[-1]}])), + ?match({aborted,bad_index}, + mnesia:create_table([{name,create_with_index},{index,[0]}])), + ?match({aborted,bad_index}, + mnesia:create_table([{name,create_with_index},{index,[1]}])), + ?match({aborted,bad_index}, + mnesia:create_table([{name,create_with_index},{index,[2]}])), + ?match({atomic,ok}, + mnesia:create_table([{name,create_with_index},{index,[3]}, + {ram_copies,[Node1]}])), + done. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Add, drop and move replicas, change storage types +%% Change table layout (only arity change supported) + +replica_management(suite) -> []; +replica_management(Nodes) -> + %% add_table_copy/3, del_table_copy/2, move_table_copy/3, + %% change_table_copy_type/3, transform_table/3 + + [Node1,Node2,Node3] = ?acquire_nodes(3,Nodes), + + Tab = replica_management, + Attrs = [k,v], + + %% + %% Add, delete and change replicas + %% + ?match({atomic,ok}, + mnesia:create_table([{name,Tab},{attributes,Attrs}, + {ram_copies,[Node1]}])), + mnesia_test_lib:verify_replica_location(Tab,[],[Node1],[],Nodes), + %% R - - + ?match({aborted,combine_error}, + mnesia:add_table_copy(Tab, Node2, disc_copies)), + ?match({aborted,combine_error}, + mnesia:change_table_copy_type(Tab, Node1, disc_copies)), + ?match({atomic,ok}, mnesia:del_table_copy(Tab,Node1)), + mnesia_test_lib:verify_replica_location(Tab,[],[],[],Nodes), + %% - - - + ?match({aborted,no_exists}, + mnesia:add_table_copy(Tab, Node3, ram_copies)), + + ?match({atomic,ok}, mnesia:create_table([{name,Tab}, + {attributes,Attrs}, + {disc_copies,[Node1]}])), + mnesia_test_lib:verify_replica_location(Tab,[],[],[Node1],Nodes), + %% D - - + ?match({aborted,badarg}, + mnesia:add_table_copy(Tab, Node2, bad_storage_type)), + ?match({atomic,ok}, mnesia:add_table_copy(Tab, Node2, disc_only_copies)), + mnesia_test_lib:verify_replica_location(Tab,[Node2],[],[Node1],Nodes), + %% D DO - + ?match({atomic,ok}, mnesia:add_table_copy(Tab, Node3, ram_copies)), + mnesia_test_lib:verify_replica_location(Tab,[Node2],[Node3],[Node1],Nodes), + %% D DO R + ?match({atomic,ok}, + mnesia:change_table_copy_type(Tab, Node1, disc_only_copies)), + mnesia_test_lib:verify_replica_location(Tab,[Node1,Node2],[Node3],[],Nodes), + %% DO DO R + ?match({aborted,already_exists}, + mnesia:add_table_copy(Tab, Node3, ram_copies)), + ?match({atomic,ok}, mnesia:del_table_copy(Tab, Node1)), + mnesia_test_lib:verify_replica_location(Tab,[Node2],[Node3],[],Nodes), + %% - DO R + ?match({aborted,_}, mnesia:del_table_copy(Tab, Node1)), + ?match({atomic,ok}, mnesia:add_table_copy(Tab, Node1, disc_copies)), + mnesia_test_lib:verify_replica_location(Tab,[Node2],[Node3],[Node1],Nodes), + %% D DO R + ?match({atomic,ok}, + mnesia:change_table_copy_type(Tab, Node3, disc_only_copies)), + mnesia_test_lib:verify_replica_location(Tab,[Node2,Node3],[],[Node1],Nodes), + %% D DO DO + ?match({atomic,ok}, mnesia:del_table_copy(Tab, Node2)), + mnesia_test_lib:verify_replica_location(Tab,[Node3],[],[Node1],Nodes), + %% D - DO + ?match({aborted,already_exists}, + mnesia:change_table_copy_type(Tab, Node1, disc_copies)), + + %% + %% Move replica + %% + ?match({atomic,ok}, mnesia:move_table_copy(Tab,Node1,Node2)), + mnesia_test_lib:verify_replica_location(Tab,[Node3],[],[Node2],Nodes), + %% - D DO + ?match({aborted,_}, mnesia:move_table_copy(Tab,Node1,Node2)), + ?match([], mnesia_test_lib:stop_mnesia([Node3])), + mnesia_test_lib:verify_replica_location(Tab,[Node3],[],[Node2], + Nodes -- [Node3]), + %% - D DO + ?match({atomic,ok}, mnesia:move_table_copy(Tab,Node3,Node1)), + mnesia_test_lib:verify_replica_location(Tab,[Node1],[],[Node2], + Nodes -- [Node3]), + %% DO D - + ?match([],mnesia_test_lib:start_mnesia([Node3])), + mnesia_test_lib:verify_replica_location(Tab,[Node1],[],[Node2],Nodes), + %% DO D - + + %% + %% Transformer + %% + + NewAttrs = Attrs ++ [extra], + Transformer = + fun(Rec) -> list_to_tuple(tuple_to_list(Rec) ++ [initial_value]) end, + ?match({atomic,ok}, mnesia:transform_table(Tab, Transformer,NewAttrs)), + ?match({atomic,ok}, mnesia:transform_table(Tab, fun(R) -> R end, Attrs)), + ?match({aborted,bad_type}, mnesia:transform_table(Tab, Transformer, 0)), + ?match({aborted,bad_type}, mnesia:transform_table(Tab, Transformer, -1)), + ?match({aborted,badarg}, mnesia:transform_table(Tab, Transformer, [])), + ?match({aborted,bad_type}, mnesia:transform_table(Tab, no_fun, NewAttrs)), + + NestedFun = + fun() -> + ?match({aborted,_}, + mnesia:move_table_copy(Tab,Node1,Node2)), + ?match({aborted,_}, + mnesia:add_table_copy(Tab,Node1,ram_copies)), + ?match({aborted,_}, + mnesia:del_table_copy(Tab,Node1)), + T = fun(_) -> 4711 end, + ?match({aborted,_}, + mnesia:transform_table(Tab,Transformer, T)), + ok + end, + ?match({atomic,ok},mnesia:transaction(NestedFun)), + done. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Add and drop indecies + +index_lifecycle(suite) -> + [ add_table_index, create_live_table_index, del_table_index ]. + +%% Add table index + +add_table_index(suite) -> []; +add_table_index(Nodes) -> + [Node1] = ?acquire_nodes(1,Nodes), + Tab = add_table_index, + Schema = [{name,Tab},{attributes,[k,v]},{ram_copies,[Node1]}], + ?match({atomic,ok}, mnesia:create_table(Schema)), + ValPos = 3, + BadValPos = ValPos + 1, + ?match({aborted,bad_index}, mnesia:add_table_index(Tab,BadValPos)), + ?match({aborted,bad_index}, mnesia:add_table_index(Tab,2)), + ?match({aborted,bad_index}, mnesia:add_table_index(Tab,1)), + ?match({aborted,bad_index}, mnesia:add_table_index(Tab,0)), + ?match({aborted,bad_index}, mnesia:add_table_index(Tab,-1)), + ?match({atomic,ok}, mnesia:add_table_index(Tab,ValPos)), + ?match({aborted,already_exists}, mnesia:add_table_index(Tab,ValPos)), + + NestedFun = fun() -> + ?match({aborted,nested_transaction}, + mnesia:add_table_index(Tab,ValPos)), + + ok + end, + ?match({atomic,ok},mnesia:transaction(NestedFun)), + done. + +create_live_table_index(suite) -> []; +create_live_table_index(Nodes) -> + [Node1] = ?acquire_nodes(1,Nodes), + Tab = create_live_table_index, + Schema = [{name,Tab},{attributes,[k,v]},{ram_copies,[Node1]}], + ?match({atomic,ok}, mnesia:create_table(Schema)), + ValPos = 3, + mnesia:dirty_write({Tab,1,2}), + + Fun = fun() -> + ?match(ok, mnesia:write({Tab,2,2})), + ok + end, + ?match({atomic,ok},mnesia:transaction(Fun)), + ?match({atomic,ok}, mnesia:add_table_index(Tab,ValPos)), + done. + +%% Drop table index + +del_table_index(suite) ->[]; +del_table_index(Nodes) -> + [Node1] = ?acquire_nodes(1,Nodes), + Tab = del_table_index, + Schema = [{name,Tab},{attributes,[k,v]},{ram_copies,[Node1]}], + ?match({atomic,ok}, mnesia:create_table(Schema)), + ValPos = 3, + BadValPos = ValPos + 1, + ?match({atomic,ok}, mnesia:add_table_index(Tab,ValPos)), + ?match({aborted,no_exists}, + mnesia:del_table_index(Tab,BadValPos)), + ?match({atomic,ok}, mnesia:del_table_index(Tab,ValPos)), + + NestedFun = + fun() -> + ?match({aborted,nested_transaction}, + mnesia:del_table_index(Tab,ValPos)), + ok + end, + ?match({atomic,ok},mnesia:transaction(NestedFun)), + done. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Syncronize table with log or disc +%% +table_sync(suite) -> + [ dump_tables, dump_log, change_dump_log_config, wait_for_tables, force_load_table ]. + +%% Dump ram tables on disc +dump_tables(suite) -> []; +dump_tables(Nodes) -> + [Node1,Node2] = ?acquire_nodes(2,Nodes), + Tab = dump_tables, + Schema = [{name,Tab},{attributes,[k,v]},{ram_copies,[Node2]}], + ?match({atomic,ok}, mnesia:create_table(Schema)), + + %% Dump 10 records + Size = 10, + Keys = lists:seq(1,Size), + Records = [{Tab,A,7} || A <- Keys], + lists:foreach(fun(Rec) -> ?match(ok,mnesia:dirty_write(Rec)) end,Records), + AllKeys = fun() -> lists:sort(mnesia:all_keys(Tab)) end, + + ?match({atomic,Keys}, mnesia:transaction(AllKeys)), + ?match(ok, mnesia:dump_tables(Tab)), + + %% Delete one record + ?match(ok,mnesia:dirty_delete({Tab,5})), + Keys2 = lists:delete(5,Keys), + ?match({atomic,Keys2}, mnesia:transaction(AllKeys)), + + %% Check that all 10 is restored after a stop + ?match([], mnesia_test_lib:stop_mnesia([Node1,Node2])), + ?match([],mnesia_test_lib:start_mnesia([Node1,Node2])), + ?match(ok,mnesia:wait_for_tables([Tab],infinity)), + ?match({atomic,Keys}, mnesia:transaction(AllKeys)), + + ?match(ok, mnesia:dump_tables([foo])), + done. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Make Mnesia table accessible via SNMP + +snmp_access(suite) -> + [ + snmp_open_table, snmp_close_table, + snmp_get_row, snmp_get_next_index, snmp_get_mnesia_key + ]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Check that the debug support has not decayed + +debug_support(suite) -> + [ info, schema, schema, kill, lkill ]. + diff --git a/lib/compiler/test/compilation_SUITE_data/compiler_3.erl b/lib/compiler/test/compilation_SUITE_data/compiler_3.erl new file mode 100644 index 0000000000..47891a22b5 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/compiler_3.erl @@ -0,0 +1,33 @@ +%% +%% %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(compiler_3). +-export([compiler_3/0]). +-record(rec,{a}). + +compiler_3() -> + guard_record(). + +guard_record() -> + 1=func(#rec{}), + {'EXIT',_} = (catch func({rec})), + ok. + +func(X) when record(X, +rec) -> + 1. diff --git a/lib/compiler/test/compilation_SUITE_data/compiler_5.erl b/lib/compiler/test/compilation_SUITE_data/compiler_5.erl new file mode 100644 index 0000000000..c2a0c2064f --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/compiler_5.erl @@ -0,0 +1,49 @@ +%% +%% %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(compiler_5). +-export([compiler_5/0]). + +compiler_5() -> + f0(), + f1(), + f2(), + ok. + +%% compiler treats records with 1 and 2 fields differently... +-record(nil, {}). +-record(foo, {hello=1}). +-record(bar, {hello=2,there=3}). + +f0() -> + R1 = #nil{}, + R2 = R1#nil{}, %% stupid code, but compiler shouldn't crash + R1 = R2, + ok. + +f1() -> + R1 = #foo{}, + R2 = R1#foo{}, %% stupid code, but compiler shouldn't crash + R1 = R2, + ok. + +f2() -> + R1 = #bar{}, + R2 = R1#bar{}, %% stupid code, but compiler shouldn't crash + R1 = R2, + ok. diff --git a/lib/compiler/test/compilation_SUITE_data/complex_guard.erl b/lib/compiler/test/compilation_SUITE_data/complex_guard.erl new file mode 100644 index 0000000000..961aa6a460 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/complex_guard.erl @@ -0,0 +1,31 @@ +%% +%% %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(complex_guard). + +-compile(export_all). + +?MODULE() -> + ok. + +f(X1,Y1,Z1) -> + if + ((X1 =:= 4) or (X1 =:= 5)) and ((Y1 =:= 4) or (Y1 =:= 5)) and ((Z1 =:= 4) or (Z1 =:= 5)) or ((X1 =:= 1) or (X1 =:= 2) or (X1 =:= 3)) and ((Y1 =:= 1) or (Y1 =:= 2) or (Y1 =:= 3)) and ((Z1 =:= 1) or (Z1 =:= 2) or (Z1 =:= 3)) -> + true + end. + diff --git a/lib/compiler/test/compilation_SUITE_data/const_list_256.erl b/lib/compiler/test/compilation_SUITE_data/const_list_256.erl new file mode 100644 index 0000000000..0baf427911 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/const_list_256.erl @@ -0,0 +1,282 @@ +%% +%% %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% +%% +-module(const_list_256). +-export([?MODULE/0]). + +?MODULE() -> + put_list(x), + ok. + +put_list(A) -> + [{A, 255}, + {A, 254}, + {A, 253}, + {A, 252}, + {A, 251}, + {A, 250}, + {A, 249}, + {A, 248}, + {A, 247}, + {A, 246}, + {A, 245}, + {A, 244}, + {A, 243}, + {A, 242}, + {A, 241}, + {A, 240}, + {A, 239}, + {A, 238}, + {A, 237}, + {A, 236}, + {A, 235}, + {A, 234}, + {A, 233}, + {A, 232}, + {A, 231}, + {A, 230}, + {A, 229}, + {A, 228}, + {A, 227}, + {A, 226}, + {A, 225}, + {A, 224}, + {A, 223}, + {A, 222}, + {A, 221}, + {A, 220}, + {A, 219}, + {A, 218}, + {A, 217}, + {A, 216}, + {A, 215}, + {A, 214}, + {A, 213}, + {A, 212}, + {A, 211}, + {A, 210}, + {A, 209}, + {A, 208}, + {A, 207}, + {A, 206}, + {A, 205}, + {A, 204}, + {A, 203}, + {A, 202}, + {A, 201}, + {A, 200}, + {A, 199}, + {A, 198}, + {A, 197}, + {A, 196}, + {A, 195}, + {A, 194}, + {A, 193}, + {A, 192}, + {A, 191}, + {A, 190}, + {A, 189}, + {A, 188}, + {A, 187}, + {A, 186}, + {A, 185}, + {A, 184}, + {A, 183}, + {A, 182}, + {A, 181}, + {A, 180}, + {A, 179}, + {A, 178}, + {A, 177}, + {A, 176}, + {A, 175}, + {A, 174}, + {A, 173}, + {A, 172}, + {A, 171}, + {A, 170}, + {A, 169}, + {A, 168}, + {A, 167}, + {A, 166}, + {A, 165}, + {A, 164}, + {A, 163}, + {A, 162}, + {A, 161}, + {A, 160}, + {A, 159}, + {A, 158}, + {A, 157}, + {A, 156}, + {A, 155}, + {A, 154}, + {A, 153}, + {A, 152}, + {A, 151}, + {A, 150}, + {A, 149}, + {A, 148}, + {A, 147}, + {A, 146}, + {A, 145}, + {A, 144}, + {A, 143}, + {A, 142}, + {A, 141}, + {A, 140}, + {A, 139}, + {A, 138}, + {A, 137}, + {A, 136}, + {A, 135}, + {A, 134}, + {A, 133}, + {A, 132}, + {A, 131}, + {A, 130}, + {A, 129}, + {A, 128}, + {A, 127}, + {A, 126}, + {A, 125}, + {A, 124}, + {A, 123}, + {A, 122}, + {A, 121}, + {A, 120}, + {A, 119}, + {A, 118}, + {A, 117}, + {A, 116}, + {A, 115}, + {A, 114}, + {A, 113}, + {A, 112}, + {A, 111}, + {A, 110}, + {A, 109}, + {A, 108}, + {A, 107}, + {A, 106}, + {A, 105}, + {A, 104}, + {A, 103}, + {A, 102}, + {A, 101}, + {A, 100}, + {A, 99}, + {A, 98}, + {A, 97}, + {A, 96}, + {A, 95}, + {A, 94}, + {A, 93}, + {A, 92}, + {A, 91}, + {A, 90}, + {A, 89}, + {A, 88}, + {A, 87}, + {A, 86}, + {A, 85}, + {A, 84}, + {A, 83}, + {A, 82}, + {A, 81}, + {A, 80}, + {A, 79}, + {A, 78}, + {A, 77}, + {A, 76}, + {A, 75}, + {A, 74}, + {A, 73}, + {A, 72}, + {A, 71}, + {A, 70}, + {A, 69}, + {A, 68}, + {A, 67}, + {A, 66}, + {A, 65}, + {A, 64}, + {A, 63}, + {A, 62}, + {A, 61}, + {A, 60}, + {A, 59}, + {A, 58}, + {A, 57}, + {A, 56}, + {A, 55}, + {A, 54}, + {A, 53}, + {A, 52}, + {A, 51}, + {A, 50}, + {A, 49}, + {A, 48}, + {A, 47}, + {A, 46}, + {A, 45}, + {A, 44}, + {A, 43}, + {A, 42}, + {A, 41}, + {A, 40}, + {A, 39}, + {A, 38}, + {A, 37}, + {A, 36}, + {A, 35}, + {A, 34}, + {A, 33}, + {A, 32}, + {A, 31}, + {A, 30}, + {A, 29}, + {A, 28}, + {A, 27}, + {A, 26}, + {A, 25}, + {A, 24}, + {A, 23}, + {A, 22}, + {A, 21}, + {A, 20}, + {A, 19}, + {A, 18}, + {A, 17}, + {A, 16}, + {A, 15}, + {A, 14}, + {A, 13}, + {A, 12}, + {A, 11}, + {A, 10}, + {A, 9}, + {A, 8}, + {A, 7}, + {A, 6}, + {A, 5}, + {A, 4}, + {A, 3}, + {A, 2}, + {A, 1}, + {A, 0}]. diff --git a/lib/compiler/test/compilation_SUITE_data/convopts.erl b/lib/compiler/test/compilation_SUITE_data/convopts.erl new file mode 100644 index 0000000000..429c683ca9 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/convopts.erl @@ -0,0 +1,159 @@ +%% +%% %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(convopts). + +-export([?MODULE/0]). + +-define(UINT32_MAX, ((1 bsl 32) - 1)). + +?MODULE() -> + Type = 12345, + Inst = 1, + Zone = 0, + case convopts([{dest, {tipc_name, Type, Inst, Zone}}]) of + {ok, [{$B, <<Type:32, Inst:32, Zone:32>>}]} -> + ok; + Other -> + {error, Other} + end. + + + +convopts(Opts) -> + catch + case getopts(Opts, [active, recvfrom, importance, distribution, + dest]) of + {[Active, Recvfrom, Importance, Distribution, + Dest], []} -> + {R, RR} = + case {Active, Recvfrom} of + {[], [recvfrom]} -> + throw({error, einval}); + {_, [recvfrom]} -> + {$r, $R}; + {_, _} -> + {$e, $E} + end, + {ok, + lists:flatten( + [case Active of + [{active, true}] -> + [{R, <<?UINT32_MAX:32>>}]; + [{active, N}] when integer(N), + 0 =< N, N < ?UINT32_MAX -> + [{R, <<N:32>>}]; + [{active, N}] when integer(N), + -?UINT32_MAX < N, N < 0 -> + [{RR, <<-N:32>>}]; + [{active, once}] -> + [{R, <<1:32>>}]; + [{active, false}] -> + [{R, <<0:32>>}]; + [] -> + []; + _ -> + throw({error, einval}) + end, + case Importance of + [{importance, normal}] -> + [{$i, []}]; + [{importance, high}] -> + [{$I, []}]; + [] -> + []; + _ -> + throw({error, einval}) + end, + case Distribution of + [distribution] -> + [{$d, []}]; + [] -> + []; + _ -> + throw({error, einval}) + end, + case Dest of + %% Port addressed message + [{dest, {tipc_port_id, Port, Proc}}] + when binary(Port), + integer(Proc), 0 =< Proc, Proc =< ?UINT32_MAX + ; + list(Port), + integer(Proc), 0 =< Proc, Proc =< ?UINT32_MAX -> + [{$p, [Port | <<Proc:32>>]}]; + %% Name addressed message + [{dest, {tipc_name, Type, Inst, Zone}}] + when integer(Type), 0 =< Type, Type =< ?UINT32_MAX, + integer(Inst), 0 =< Inst, Inst =< ?UINT32_MAX, + integer(Zone), 0 =< Zone, Zone =< ?UINT32_MAX -> + [{$B, <<Type:32, Inst:32, Zone:32>>}]; + %% + %% This undocumented clause uses an undocumented + %% feature of the TIPC socket interface that takes + %% advantage of some gory internals of the protocol. + %% It is protocol implementation dependant and + %% breaks the whole idea of location transparency + %% for name addressed messages. Therefore it should + %% only be used when all other possibilities are + %% exhausted. + %% + [{dest, {tipc_name, Type, Inst, + {tipc_processor_id, + Zone, Subnetwork, Processor}}}] + when integer(Type), 0 =< Type, Type =< ?UINT32_MAX, + integer(Inst), 0 =< Inst, Inst =< ?UINT32_MAX, + integer(Zone), + 0 =< Zone, Zone < 16#FF, + integer(Subnetwork), + 0 =< Subnetwork, Subnetwork < 16#FFF, + integer(Processor), + 0 =< Processor, Processor < 16#FFF -> + [{$B, <<Type:32, + Inst:32, + Zone:8, Subnetwork:12, Processor:12>>}]; + [] -> + []; + _ -> + throw({error, einval}) + end + ])}; + _ -> + throw({error, einval}) + end. + + + +getopts(List, Options) when list(List), list(Options) -> + getopts_1(Options, List, []). + +getopts_1([], List, Result) -> + {lists:reverse(Result), List}; +getopts_1([Option | Options], List, Result) -> + {Optvals, Remaining} = getopts_2(List, Option, [], []), + getopts_1(Options, Remaining, [Optvals | Result]). + +getopts_2([], _Option, Result, Remaining) -> + {lists:reverse(Result), lists:reverse(Remaining)}; +getopts_2([Option | Tail], Option, Result, Remaining) -> + getopts_2(Tail, Option, [Option | Result], Remaining); +getopts_2([Optval | Tail], Option, Result, Remaining) + when element(1, Optval) == Option -> + getopts_2(Tail, Option, [Optval | Result], Remaining); +getopts_2([Other | Tail], Option, Result, Remaining) -> + getopts_2(Tail, Option, Result, [Other | Remaining]). diff --git a/lib/compiler/test/compilation_SUITE_data/guards.erl b/lib/compiler/test/compilation_SUITE_data/guards.erl new file mode 100644 index 0000000000..84e41b8ede --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/guards.erl @@ -0,0 +1,106 @@ +%% +%% %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% +%% +-module(guards). + +-export([guards/0]). + +guards() -> + ok = t(), + ok = f(), + ok = ct(1), + ok = multi(1), + ok = multi(2), + ok = multi(3). + +%% The following tests are always true. +t() when integer(42) -> + ok; +t() when float(2.0) -> + ok; +t() when number(7) -> + ok; +t() when number(3.14) -> + ok; +t() when atom(error) -> + ok; +t() when list([a]) -> + ok; +t() when tuple({}) -> + ok; +t() when tuple({1, 2}) -> + ok. + +%% The following tests are always false. +f() when integer(a) -> + ok; +f() when float(b) -> + ok; +f() when number(c) -> + ok; +f() when atom(42) -> + ok; +f() when list(33) -> + ok; +f() when list({}) -> + ok; +f() when list({1, 2}) -> + ok; +f() when tuple(33) -> + ok; +f() when tuple([a]) -> + ok; +f() when tuple([]) -> + ok; +f() when tuple(35) -> + ok; +f() -> + ok. + +%% The following tests are always true. +ct(X) -> + case X of + Y when integer(42) -> + ok; + Y when float(2.0) -> + ok; + Y when number(7) -> + ok; + Y when number(3.14) -> + ok; + Y when atom(error) -> + ok; + Y when list([a]) -> + ok; + Y when tuple({}) -> + ok; + Y when tuple({1, 2}) -> + ok + end. + +multi(X) -> + case X of + Y when float(Y) ; integer(Y) -> + ok; + Y when Y > 1, Y < 10 ; atom(Y) -> + ok; + Y when Y == 4, number(Y) ; list(Y) -> + pannkaka; + Y when Y==3 ; Y==5 ; Y==6 -> + ok + end. diff --git a/lib/compiler/test/compilation_SUITE_data/live_var.erl b/lib/compiler/test/compilation_SUITE_data/live_var.erl new file mode 100644 index 0000000000..483eec0630 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/live_var.erl @@ -0,0 +1,30 @@ +%% +%% %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(live_var). +-export([?MODULE/0,start/0]). + +?MODULE() -> + ok. + +start() -> + receive + after 3000 -> + A = 5 + end, + A. diff --git a/lib/compiler/test/compilation_SUITE_data/long_string.erl b/lib/compiler/test/compilation_SUITE_data/long_string.erl new file mode 100644 index 0000000000..b3cf77b13f --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/long_string.erl @@ -0,0 +1,670 @@ +%% +%% %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(long_string). + +-export([?MODULE/0]). + +?MODULE() -> + Options = "some stupid long string", + 49252 = length(generate(Options, "348927432097sfkjfkljf329")), + ok. + +generate(Options, Glurf) -> + "asdhfaslfdjhhwleirsk e4kjhr430usduy fdk;///s llsjkf;laskjfsdfkjasdfkj +sdkljflasdfkjasldkfjasd" ++ Options ++ +"CSAgICAgICBWZXJzaW9uIDIsIEp1bmUgMTk5MQoKIENvcHlyaWdodCAoQykgMTk4OSwgMTk5MSBG +cmVlIFNvZnR3YXJlIEZvdW5kYXRpb24sIEluYy4KICAgICAgICAgICAgICAgICAgICAgICA1OSBU +ZW1wbGUgUGxhY2UsIFN1aXRlIDMzMCwgQm9zdG9uLCBNQSAgMDIxMTEtMTMwNyAgVVNBCiBFdmVy +eW9uZSBpcyBwZXJtaXR0ZWQgdG8gY29weSBhbmQgZGlzdHJpYnV0ZSB2ZXJiYXRpbSBjb3BpZXMK +IG9mIHRoaXMgbGljZW5zZSBkb2N1bWVudCwgYnV0IGNoYW5naW5nIGl0IGlzIG5vdCBhbGxvd2Vk +LgoKCQkJICAgIFByZWFtYmxlCgogIFRoZSBsaWNlbnNlcyBmb3IgbW9zdCBzb2Z0d2FyZSBhcmUg +ZGVzaWduZWQgdG8gdGFrZSBhd2F5IHlvdXIKZnJlZWRvbSB0byBzaGFyZSBhbmQgY2hhbmdlIGl0 +LiAgQnkgY29udHJhc3QsIHRoZSBHTlUgR2VuZXJhbCBQdWJsaWMKTGljZW5zZSBpcyBpbnRlbmRl +ZCB0byBndWFyYW50ZWUgeW91ciBmcmVlZG9tIHRvIHNoYXJlIGFuZCBjaGFuZ2UgZnJlZQpzb2Z0 +d2FyZS0tdG8gbWFrZSBzdXJlIHRoZSBzb2Z0d2FyZSBpcyBmcmVlIGZvciBhbGwgaXRzIHVzZXJz +LiAgVGhpcwpHZW5lcmFsIFB1YmxpYyBMaWNlbnNlIGFwcGxpZXMgdG8gbW9zdCBvZiB0aGUgRnJl +ZSBTb2Z0d2FyZQpGb3VuZGF0aW9uJ3Mgc29mdHdhcmUgYW5kIHRvIGFueSBvdGhlciBwcm9ncmFt +IHdob3NlIGF1dGhvcnMgY29tbWl0IHRvCnVzaW5nIGl0LiAgKFNvbWUgb3RoZXIgRnJlZSBTb2Z0 +d2FyZSBGb3VuZGF0aW9uIHNvZnR3YXJlIGlzIGNvdmVyZWQgYnkKdGhlIEdOVSBMaWJyYXJ5IEdl +bmVyYWwgUHVibGljIExpY2Vuc2UgaW5zdGVhZC4pICBZb3UgY2FuIGFwcGx5IGl0IHRvCnlvdXIg +cHJvZ3JhbXMsIHRvby4KCiAgV2hlbiB3ZSBzcGVhayBvZiBmcmVlIHNvZnR3YXJlLCB3ZSBhcmUg +cmVmZXJyaW5nIHRvIGZyZWVkb20sIG5vdApwcmljZS4gIE91ciBHZW5lcmFsIFB1YmxpYyBMaWNl +bnNlcyBhcmUgZGVzaWduZWQgdG8gbWFrZSBzdXJlIHRoYXQgeW91CmhhdmUgdGhlIGZyZWVkb20g +dG8gZGlzdHJpYnV0ZSBjb3BpZXMgb2YgZnJlZSBzb2Z0d2FyZSAoYW5kIGNoYXJnZSBmb3IKdGhp +cyBzZXJ2aWNlIGlmIHlvdSB3aXNoKSwgdGhhdCB5b3UgcmVjZWl2ZSBzb3VyY2UgY29kZSBvciBj +YW4gZ2V0IGl0CmlmIHlvdSB3YW50IGl0LCB0aGF0IHlvdSBjYW4gY2hhbmdlIHRoZSBzb2Z0d2Fy +ZSBvciB1c2UgcGllY2VzIG9mIGl0CmluIG5ldyBmcmVlIHByb2dyYW1zOyBhbmQgdGhhdCB5b3Ug +a25vdyB5b3UgY2FuIGRvIHRoZXNlIHRoaW5ncy4KCiAgVG8gcHJvdGVjdCB5b3VyIHJpZ2h0cywg +d2UgbmVlZCB0byBtYWtlIHJlc3RyaWN0aW9ucyB0aGF0IGZvcmJpZAphbnlvbmUgdG8gZGVueSB5 +b3UgdGhlc2UgcmlnaHRzIG9yIHRvIGFzayB5b3UgdG8gc3VycmVuZGVyIHRoZSByaWdodHMuClRo +ZXNlIHJlc3RyaWN0aW9ucyB0cmFuc2xhdGUgdG8gY2VydGFpbiByZXNwb25zaWJpbGl0aWVzIGZv +ciB5b3UgaWYgeW91CmRpc3RyaWJ1dGUgY29waWVzIG9mIHRoZSBzb2Z0d2FyZSwgb3IgaWYgeW91 +IG1vZGlmeSBpdC4KCiAgRm9yIGV4YW1wbGUsIGlmIHlvdSBkaXN0cmlidXRlIGNvcGllcyBvZiBz +dWNoIGEgcHJvZ3JhbSwgd2hldGhlcgpncmF0aXMgb3IgZm9yIGEgZmVlLCB5b3UgbXVzdCBnaXZl +IHRoZSByZWNpcGllbnRzIGFsbCB0aGUgcmlnaHRzIHRoYXQKeW91IGhhdmUuICBZb3UgbXVzdCBt +YWtlIHN1cmUgdGhhdCB0aGV5LCB0b28sIHJlY2VpdmUgb3IgY2FuIGdldCB0aGUKc291cmNlIGNv +ZGUuICBBbmQgeW91IG11c3Qgc2hvdyB0aGVtIHRoZXNlIHRlcm1zIHNvIHRoZXkga25vdyB0aGVp +cgpyaWdodHMuCgogIFdlIHByb3RlY3QgeW91ciByaWdodHMgd2l0aCB0d28gc3RlcHM6ICgxKSBj +b3B5cmlnaHQgdGhlIHNvZnR3YXJlLCBhbmQKKDIpIG9mZmVyIHlvdSB0aGlzIGxpY2Vuc2Ugd2hp +Y2ggZ2l2ZXMgeW91IGxlZ2FsIHBlcm1pc3Npb24gdG8gY29weSwKZGlzdHJpYnV0ZSBhbmQvb3Ig +bW9kaWZ5IHRoZSBzb2Z0d2FyZS4KCiAgQWxzbywgZm9yIGVhY2ggYXV0aG9yJ3MgcHJvdGVjdGlv +biBhbmQgb3Vycywgd2Ugd2FudCB0byBtYWtlIGNlcnRhaW4KdGhhdCBldmVyeW9uZSB1bmRlcnN0 +YW5kcyB0aGF0IHRoZXJlIGlzIG5vIHdhcnJhbnR5IGZvciB0aGlzIGZyZWUKc29mdHdhcmUuICBJ +ZiB0aGUgc29mdHdhcmUgaXMgbW9kaWZpZWQgYnkgc29tZW9uZSBlbHNlIGFuZCBwYXNzZWQgb24s +IHdlCndhbnQgaXRzIHJlY2lwaWVudHMgdG8ga25vdyB0aGF0IHdoYXQgdGhleSBoYXZlIGlzIG5v +dCB0aGUgb3JpZ2luYWwsIHNvCnRoYXQgYW55IHByb2JsZW1zIGludHJvZHVjZWQgYnkgb3RoZXJz +IHdpbGwgbm90IHJlZmxlY3Qgb24gdGhlIG9yaWdpbmFsCmF1dGhvcnMnIHJlcHV0YXRpb25zLgoK +ICBGaW5hbGx5LCBhbnkgZnJlZSBwcm9ncmFtIGlzIHRocmVhdGVuZWQgY29uc3RhbnRseSBieSBz +b2Z0d2FyZQpwYXRlbnRzLiAgV2Ugd2lzaCB0byBhdm9pZCB0aGUgZGFuZ2VyIHRoYXQgcmVkaXN0 +cmlidXRvcnMgb2YgYSBmcmVlCnByb2dyYW0gd2lsbCBpbmRpdmlkdWFsbHkgb2J0YWluIHBhdGVu +dCBsaWNlbnNlcywgaW4gZWZmZWN0IG1ha2luZyB0aGUKcHJvZ3JhbSBwcm9wcmlldGFyeS4gIFRv +IHByZXZlbnQgdGhpcywgd2UgaGF2ZSBtYWRlIGl0IGNsZWFyIHRoYXQgYW55CnBhdGVudCBtdXN0 +IGJlIGxpY2Vuc2VkIGZvciBldmVyeW9uZSdzIGZyZWUgdXNlIG9yIG5vdCBsaWNlbnNlZCBhdCBh +bGwuCgogIFRoZSBwcmVjaXNlIHRlcm1zIGFuZCBjb25kaXRpb25zIGZvciBjb3B5aW5nLCBkaXN0 +cmlidXRpb24gYW5kCm1vZGlmaWNhdGlvbiBmb2xsb3cuCgwKCQkgICAgR05VIEdFTkVSQUwgUFVC +TElDIExJQ0VOU0UKICAgVEVSTVMgQU5EIENPTkRJVElPTlMgRk9SIENPUFlJTkcsIERJU1RSSUJV +VElPTiBBTkQgTU9ESUZJQ0FUSU9OCgogIDAuIFRoaXMgTGljZW5zZSBhcHBsaWVzIHRvIGFueSBw +cm9ncmFtIG9yIG90aGVyIHdvcmsgd2hpY2ggY29udGFpbnMKYSBub3RpY2UgcGxhY2VkIGJ5IHRo +ZSBjb3B5cmlnaHQgaG9sZGVyIHNheWluZyBpdCBtYXkgYmUgZGlzdHJpYnV0ZWQKdW5kZXIgdGhl +IHRlcm1zIG9mIHRoaXMgR2VuZXJhbCBQdWJsaWMgTGljZW5zZS4gIFRoZSAiUHJvZ3JhbSIsIGJl +bG93LApyZWZlcnMgdG8gYW55IHN1Y2ggcHJvZ3JhbSBvciB3b3JrLCBhbmQgYSAid29yayBiYXNl +ZCBvbiB0aGUgUHJvZ3JhbSIKbWVhbnMgZWl0aGVyIHRoZSBQcm9ncmFtIG9yIGFueSBkZXJpdmF0 +aXZlIHdvcmsgdW5kZXIgY29weXJpZ2h0IGxhdzoKdGhhdCBpcyB0byBzYXksIGEgd29yayBjb250 +YWluaW5nIHRoZSBQcm9ncmFtIG9yIGEgcG9ydGlvbiBvZiBpdCwKZWl0aGVyIHZlcmJhdGltIG9y +IHdpdGggbW9kaWZpY2F0aW9ucyBhbmQvb3IgdHJhbnNsYXRlZCBpbnRvIGFub3RoZXIKbGFuZ3Vh +Z2UuICAoSGVyZWluYWZ0ZXIsIHRyYW5zbGF0aW9uIGlzIGluY2x1ZGVkIHdpdGhvdXQgbGltaXRh +dGlvbiBpbgp0aGUgdGVybSAibW9kaWZpY2F0aW9uIi4pICBFYWNoIGxpY2Vuc2VlIGlzIGFkZHJl +c3NlZCBhcyAieW91Ii4KCkFjdGl2aXRpZXMgb3RoZXIgdGhhbiBjb3B5aW5nLCBkaXN0cmlidXRp +b24gYW5kIG1vZGlmaWNhdGlvbiBhcmUgbm90CmNvdmVyZWQgYnkgdGhpcyBMaWNlbnNlOyB0aGV5 +IGFyZSBvdXRzaWRlIGl0cyBzY29wZS4gIFRoZSBhY3Qgb2YKcnVubmluZyB0aGUgUHJvZ3JhbSBp +cyBub3QgcmVzdHJpY3RlZCwgYW5kIHRoZSBvdXRwdXQgZnJvbSB0aGUgUHJvZ3JhbQppcyBjb3Zl +cmVkIG9ubHkgaWYgaXRzIGNvbnRlbnRzIGNvbnN0aXR1dGUgYSB3b3JrIGJhc2VkIG9uIHRoZQpQ +cm9ncmFtIChpbmRlcGVuZGVudCBvZiBoYXZpbmcgYmVlbiBtYWRlIGJ5IHJ1bm5pbmcgdGhlIFBy +b2dyYW0pLgpXaGV0aGVyIHRoYXQgaXMgdHJ1ZSBkZXBlbmRzIG9uIHdoYXQgdGhlIFByb2dyYW0g +ZG9lcy4KCiAgMS4gWW91IG1heSBjb3B5IGFuZCBkaXN0cmlidXRlIHZlcmJhdGltIGNvcGllcyBv +ZiB0aGUgUHJvZ3JhbSdzCnNvdXJjZSBjb2RlIGFzIHlvdSByZWNlaXZlIGl0LCBpbiBhbnkgbWVk +aXVtLCBwcm92aWRlZCB0aGF0IHlvdQpjb25zcGljdW91c2x5IGFuZCBhcHByb3ByaWF0ZWx5IHB1 +Ymxpc2ggb24gZWFjaCBjb3B5IGFuIGFwcHJvcHJpYXRlCmNvcHlyaWdodCBub3RpY2UgYW5kIGRp +c2NsYWltZXIgb2Ygd2FycmFudHk7IGtlZXAgaW50YWN0IGFsbCB0aGUKbm90aWNlcyB0aGF0IHJl +ZmVyIHRvIHRoaXMgTGljZW5zZSBhbmQgdG8gdGhlIGFic2VuY2Ugb2YgYW55IHdhcnJhbnR5Owph +bmQgZ2l2ZSBhbnkgb3RoZXIgcmVjaXBpZW50cyBvZiB0aGUgUHJvZ3JhbSBhIGNvcHkgb2YgdGhp +cyBMaWNlbnNlCmFsb25nIHdpdGggdGhlIFByb2dyYW0uCgpZb3UgbWF5IGNoYXJnZSBhIGZlZSBm +b3IgdGhlIHBoeXNpY2FsIGFjdCBvZiB0cmFuc2ZlcnJpbmcgYSBjb3B5LCBhbmQKeW91IG1heSBh +dCB5b3VyIG9wdGlvbiBvZmZlciB3YXJyYW50eSBwcm90ZWN0aW9uIGluIGV4Y2hhbmdlIGZvciBh +IGZlZS4KCiAgMi4gWW91IG1heSBtb2RpZnkgeW91ciBjb3B5IG9yIGNvcGllcyBvZiB0aGUgUHJv +Z3JhbSBvciBhbnkgcG9ydGlvbgpvZiBpdCwgdGh1cyBmb3JtaW5nIGEgd29yayBiYXNlZCBvbiB0 +aGUgUHJvZ3JhbSwgYW5kIGNvcHkgYW5kCmRpc3RyaWJ1dGUgc3VjaCBtb2RpZmljYXRpb25zIG9y +IHdvcmsgdW5kZXIgdGhlIHRlcm1zIG9mIFNlY3Rpb24gMQphYm92ZSwgcHJvdmlkZWQgdGhhdCB5 +b3UgYWxzbyBtZWV0IGFsbCBvZiB0aGVzZSBjb25kaXRpb25zOgoKICAgIGEpIFlvdSBtdXN0IGNh +dXNlIHRoZSBtb2RpZmllZCBmaWxlcyB0byBjYXJyeSBwcm9taW5lbnQgbm90aWNlcwogICAgc3Rh +dGluZyB0aGF0IHlvdSBjaGFuZ2VkIHRoZSBmaWxlcyBhbmQgdGhlIGRhdGUgb2YgYW55IGNoYW5n +ZS4KCiAgICBiKSBZb3UgbXVzdCBjYXVzZSBhbnkgd29yayB0aGF0IHlvdSBkaXN0cmlidXRlIG9y +IHB1Ymxpc2gsIHRoYXQgaW4KICAgIHdob2xlIG9yIGluIHBhcnQgY29udGFpbnMgb3IgaXMgZGVy +aXZlZCBmcm9tIHRoZSBQcm9ncmFtIG9yIGFueQogICAgcGFydCB0aGVyZW9mLCB0byBiZSBsaWNl +bnNlZCBhcyBhIHdob2xlIGF0IG5vIGNoYXJnZSB0byBhbGwgdGhpcmQKICAgIHBhcnRpZXMgdW5k +ZXIgdGhlIHRlcm1zIG9mIHRoaXMgTGljZW5zZS4KCiAgICBjKSBJZiB0aGUgbW9kaWZpZWQgcHJv +Z3JhbSBub3JtYWxseSByZWFkcyBjb21tYW5kcyBpbnRlcmFjdGl2ZWx5CiAgICB3aGVuIHJ1biwg +eW91IG11c3QgY2F1c2UgaXQsIHdoZW4gc3RhcnRlZCBydW5uaW5nIGZvciBzdWNoCiAgICBpbnRl +cmFjdGl2ZSB1c2UgaW4gdGhlIG1vc3Qgb3JkaW5hcnkgd2F5LCB0byBwcmludCBvciBkaXNwbGF5 +IGFuCiAgICBhbm5vdW5jZW1lbnQgaW5jbHVkaW5nIGFuIGFwcHJvcHJpYXRlIGNvcHlyaWdodCBu +b3RpY2UgYW5kIGEKICAgIG5vdGljZSB0aGF0IHRoZXJlIGlzIG5vIHdhcnJhbnR5IChvciBlbHNl +LCBzYXlpbmcgdGhhdCB5b3UgcHJvdmlkZQogICAgYSB3YXJyYW50eSkgYW5kIHRoYXQgdXNlcnMg +bWF5IHJlZGlzdHJpYnV0ZSB0aGUgcHJvZ3JhbSB1bmRlcgogICAgdGhlc2UgY29uZGl0aW9ucywg +YW5kIHRlbGxpbmcgdGhlIHVzZXIgaG93IHRvIHZpZXcgYSBjb3B5IG9mIHRoaXMKICAgIExpY2Vu +c2UuICAoRXhjZXB0aW9uOiBpZiB0aGUgUHJvZ3JhbSBpdHNlbGYgaXMgaW50ZXJhY3RpdmUgYnV0 +CiAgICBkb2VzIG5vdCBub3JtYWxseSBwcmludCBzdWNoIGFuIGFubm91bmNlbWVudCwgeW91ciB3 +b3JrIGJhc2VkIG9uCiAgICB0aGUgUHJvZ3JhbSBpcyBub3QgcmVxdWlyZWQgdG8gcHJpbnQgYW4g +YW5ub3VuY2VtZW50LikKDApUaGVzZSByZXF1aXJlbWVudHMgYXBwbHkgdG8gdGhlIG1vZGlmaWVk +IHdvcmsgYXMgYSB3aG9sZS4gIElmCmlkZW50aWZpYWJsZSBzZWN0aW9ucyBvZiB0aGF0IHdvcmsg +YXJlIG5vdCBkZXJpdmVkIGZyb20gdGhlIFByb2dyYW0sCmFuZCBjYW4gYmUgcmVhc29uYWJseSBj +b25zaWRlcmVkIGluZGVwZW5kZW50IGFuZCBzZXBhcmF0ZSB3b3JrcyBpbgp0aGVtc2VsdmVzLCB0 +aGVuIHRoaXMgTGljZW5zZSwgYW5kIGl0cyB0ZXJtcywgZG8gbm90IGFwcGx5IHRvIHRob3NlCnNl +Y3Rpb25zIHdoZW4geW91IGRpc3RyaWJ1dGUgdGhlbSBhcyBzZXBhcmF0ZSB3b3Jrcy4gIEJ1dCB3 +aGVuIHlvdQpkaXN0cmlidXRlIHRoZSBzYW1lIHNlY3Rpb25zIGFzIHBhcnQgb2YgYSB3aG9sZSB3 +aGljaCBpcyBhIHdvcmsgYmFzZWQKb24gdGhlIFByb2dyYW0sIHRoZSBkaXN0cmlidXRpb24gb2Yg +dGhlIHdob2xlIG11c3QgYmUgb24gdGhlIHRlcm1zIG9mCnRoaXMgTGljZW5zZSwgd2hvc2UgcGVy +bWlzc2lvbnMgZm9yIG90aGVyIGxpY2Vuc2VlcyBleHRlbmQgdG8gdGhlCmVudGlyZSB3aG9sZSwg +YW5kIHRodXMgdG8gZWFjaCBhbmQgZXZlcnkgcGFydCByZWdhcmRsZXNzIG9mIHdobyB3cm90ZSBp +dC4KClRodXMsIGl0IGlzIG5vdCB0aGUgaW50ZW50IG9mIHRoaXMgc2VjdGlvbiB0byBjbGFpbSBy +aWdodHMgb3IgY29udGVzdAp5b3VyIHJpZ2h0cyB0byB3b3JrIHdyaXR0ZW4gZW50aXJlbHkgYnkg +eW91OyByYXRoZXIsIHRoZSBpbnRlbnQgaXMgdG8KZXhlcmNpc2UgdGhlIHJpZ2h0IHRvIGNvbnRy +b2wgdGhlIGRpc3RyaWJ1dGlvbiBvZiBkZXJpdmF0aXZlIG9yCmNvbGxlY3RpdmUgd29ya3MgYmFz +ZWQgb24gdGhlIFByb2dyYW0uCgpJbiBhZGRpdGlvbiwgbWVyZSBhZ2dyZWdhdGlvbiBvZiBhbm90 +aGVyIHdvcmsgbm90IGJhc2VkIG9uIHRoZSBQcm9ncmFtCndpdGggdGhlIFByb2dyYW0gKG9yIHdp +dGggYSB3b3JrIGJhc2VkIG9uIHRoZSBQcm9ncmFtKSBvbiBhIHZvbHVtZSBvZgphIHN0b3JhZ2Ug +b3IgZGlzdHJpYnV0aW9uIG1lZGl1bSBkb2VzIG5vdCBicmluZyB0aGUgb3RoZXIgd29yayB1bmRl +cgp0aGUgc2NvcGUgb2YgdGhpcyBMaWNlbnNlLgoKICAzLiBZb3UgbWF5IGNvcHkgYW5kIGRpc3Ry +aWJ1dGUgdGhlIFByb2dyYW0gKG9yIGEgd29yayBiYXNlZCBvbiBpdCwKdW5kZXIgU2VjdGlvbiAy +KSBpbiBvYmplY3QgY29kZSBvciBleGVjdXRhYmxlIGZvcm0gdW5kZXIgdGhlIHRlcm1zIG9mClNl +Y3Rpb25zIDEgYW5kIDIgYWJvdmUgcHJvdmlkZWQgdGhhdCB5b3UgYWxzbyBkbyBvbmUgb2YgdGhl +IGZvbGxvd2luZzoKCiAgICBhKSBBY2NvbXBhbnkgaXQgd2l0aCB0aGUgY29tcGxldGUgY29ycmVz +cG9uZGluZyBtYWNoaW5lLXJlYWRhYmxlCiAgICBzb3VyY2UgY29kZSwgd2hpY2ggbXVzdCBiZSBk +aXN0cmlidXRlZCB1bmRlciB0aGUgdGVybXMgb2YgU2VjdGlvbnMKICAgIDEgYW5kIDIgYWJvdmUg +b24gYSBtZWRpdW0gY3VzdG9tYXJpbHkgdXNlZCBmb3Igc29mdHdhcmUgaW50ZXJjaGFuZ2U7IG9y +LAoKICAgIGIpIEFjY29tcGFueSBpdCB3aXRoIGEgd3JpdHRlbiBvZmZlciwgdmFsaWQgZm9yIGF0 +IGxlYXN0IHRocmVlCiAgICB5ZWFycywgdG8gZ2l2ZSBhbnkgdGhpcmQgcGFydHksIGZvciBhIGNo +YXJnZSBubyBtb3JlIHRoYW4geW91cgogICAgY29zdCBvZiBwaHlzaWNhbGx5IHBlcmZvcm1pbmcg +c291cmNlIGRpc3RyaWJ1dGlvbiwgYSBjb21wbGV0ZQogICAgbWFjaGluZS1yZWFkYWJsZSBjb3B5 +IG9mIHRoZSBjb3JyZXNwb25kaW5nIHNvdXJjZSBjb2RlLCB0byBiZQogICAgZGlzdHJpYnV0ZWQg +dW5kZXIgdGhlIHRlcm1zIG9mIFNlY3Rpb25zIDEgYW5kIDIgYWJvdmUgb24gYSBtZWRpdW0KICAg +IGN1c3RvbWFyaWx5IHVzZWQgZm9yIHNvZnR3YXJlIGludGVyY2hhbmdlOyBvciwKCiAgICBjKSBB +Y2NvbXBhbnkgaXQgd2l0aCB0aGUgaW5mb3JtYXRpb24geW91IHJlY2VpdmVkIGFzIHRvIHRoZSBv +ZmZlcgogICAgdG8gZGlzdHJpYnV0ZSBjb3JyZXNwb25kaW5nIHNvdXJjZSBjb2RlLiAgKFRoaXMg +YWx0ZXJuYXRpdmUgaXMKICAgIGFsbG93ZWQgb25seSBmb3Igbm9uY29tbWVyY2lhbCBkaXN0cmli +dXRpb24gYW5kIG9ubHkgaWYgeW91CiAgICByZWNlaXZlZCB0aGUgcHJvZ3JhbSBpbiBvYmplY3Qg +Y29kZSBvciBleGVjdXRhYmxlIGZvcm0gd2l0aCBzdWNoCiAgICBhbiBvZmZlciwgaW4gYWNjb3Jk +IHdpdGggU3Vic2VjdGlvbiBiIGFib3ZlLikKClRoZSBzb3VyY2UgY29kZSBmb3IgYSB3b3JrIG1l +YW5zIHRoZSBwcmVmZXJyZWQgZm9ybSBvZiB0aGUgd29yayBmb3IKbWFraW5nIG1vZGlmaWNhdGlv +bnMgdG8gaXQuICBGb3IgYW4gZXhlY3V0YWJsZSB3b3JrLCBjb21wbGV0ZSBzb3VyY2UKY29kZSBt +ZWFucyBhbGwgdGhlIHNvdXJjZSBjb2RlIGZvciBhbGwgbW9kdWxlcyBpdCBjb250YWlucywgcGx1 +cyBhbnkKYXNzb2NpYXRlZCBpbnRlcmZhY2UgZGVmaW5pdGlvbiBmaWxlcywgcGx1cyB0aGUgc2Ny +aXB0cyB1c2VkIHRvCmNvbnRyb2wgY29tcGlsYXRpb24gYW5kIGluc3RhbGxhdGlvbiBvZiB0aGUg +ZXhlY3V0YWJsZS4gIEhvd2V2ZXIsIGFzIGEKc3BlY2lhbCBleGNlcHRpb24sIHRoZSBzb3VyY2Ug +Y29kZSBkaXN0cmlidXRlZCBuZWVkIG5vdCBpbmNsdWRlCmFueXRoaW5nIHRoYXQgaXMgbm9ybWFs +bHkgZGlzdHJpYnV0ZWQgKGluIGVpdGhlciBzb3VyY2Ugb3IgYmluYXJ5CmZvcm0pIHdpdGggdGhl +IG1ham9yIGNvbXBvbmVudHMgKGNvbXBpbGVyLCBrZXJuZWwsIGFuZCBzbyBvbikgb2YgdGhlCm9w +ZXJhdGluZyBzeXN0ZW0gb24gd2hpY2ggdGhlIGV4ZWN1dGFibGUgcnVucywgdW5sZXNzIHRoYXQg +Y29tcG9uZW50Cml0c2VsZiBhY2NvbXBhbmllcyB0aGUgZXhlY3V0YWJsZS4KCklmIGRpc3RyaWJ1 +dGlvbiBvZiBleGVjdXRhYmxlIG9yIG9iamVjdCBjb2RlIGlzIG1hZGUgYnkgb2ZmZXJpbmcKYWNj +ZXNzIHRvIGNvcHkgZnJvbSBhIGRlc2lnbmF0ZWQgcGxhY2UsIHRoZW4gb2ZmZXJpbmcgZXF1aXZh +bGVudAphY2Nlc3MgdG8gY29weSB0aGUgc291cmNlIGNvZGUgZnJvbSB0aGUgc2FtZSBwbGFjZSBj +b3VudHMgYXMKZGlzdHJpYnV0aW9uIG9mIHRoZSBzb3VyY2UgY29kZSwgZXZlbiB0aG91Z2ggdGhp +cmQgcGFydGllcyBhcmUgbm90CmNvbXBlbGxlZCB0byBjb3B5IHRoZSBzb3VyY2UgYWxvbmcgd2l0 +aCB0aGUgb2JqZWN0IGNvZGUuCgwKICA0LiBZb3UgbWF5IG5vdCBjb3B5LCBtb2RpZnksIHN1Ymxp +Y2Vuc2UsIG9yIGRpc3RyaWJ1dGUgdGhlIFByb2dyYW0KZXhjZXB0IGFzIGV4cHJlc3NseSBwcm92 +aWRlZCB1bmRlciB0aGlzIExpY2Vuc2UuICBBbnkgYXR0ZW1wdApvdGhlcndpc2UgdG8gY29weSwg +bW9kaWZ5LCBzdWJsaWNlbnNlIG9yIGRpc3RyaWJ1dGUgdGhlIFByb2dyYW0gaXMKdm9pZCwgYW5k +IHdpbGwgYXV0b21hdGljYWxseSB0ZXJtaW5hdGUgeW91ciByaWdodHMgdW5kZXIgdGhpcyBMaWNl +bnNlLgpIb3dldmVyLCBwYXJ0aWVzIHdobyBoYXZlIHJlY2VpdmVkIGNvcGllcywgb3IgcmlnaHRz +LCBmcm9tIHlvdSB1bmRlcgp0aGlzIExpY2Vuc2Ugd2lsbCBub3QgaGF2ZSB0aGVpciBsaWNlbnNl +cyB0ZXJtaW5hdGVkIHNvIGxvbmcgYXMgc3VjaApwYXJ0aWVzIHJlbWFpbiBpbiBmdWxsIGNvbXBs +aWFuY2UuCgogIDUuIFlvdSBhcmUgbm90IHJlcXVpcmVkIHRvIGFjY2VwdCB0aGlzIExpY2Vuc2Us +IHNpbmNlIHlvdSBoYXZlIG5vdApzaWduZWQgaXQuICBIb3dldmVyLCBub3RoaW5nIGVsc2UgZ3Jh +bnRzIHlvdSBwZXJtaXNzaW9uIHRvIG1vZGlmeSBvcgpkaXN0cmlidXRlIHRoZSBQcm9ncmFtIG9y +IGl0cyBkZXJpdmF0aXZlIHdvcmtzLiAgVGhlc2UgYWN0aW9ucyBhcmUKcHJvaGliaXRlZCBieSBs +YXcgaWYgeW91IGRvIG5vdCBhY2NlcHQgdGhpcyBMaWNlbnNlLiAgVGhlcmVmb3JlLCBieQptb2Rp +Znlpbmcgb3IgZGlzdHJpYnV0aW5nIHRoZSBQcm9ncmFtIChvciBhbnkgd29yayBiYXNlZCBvbiB0 +aGUKUHJvZ3JhbSksIHlvdSBpbmRpY2F0ZSB5b3VyIGFjY2VwdGFuY2Ugb2YgdGhpcyBMaWNlbnNl +IHRvIGRvIHNvLCBhbmQKYWxsIGl0cyB0ZXJtcyBhbmQgY29uZGl0aW9ucyBmb3IgY29weWluZywg +ZGlzdHJpYnV0aW5nIG9yIG1vZGlmeWluZwp0aGUgUHJvZ3JhbSBvciB3b3JrcyBiYXNlZCBvbiBp +dC4KCiAgNi4gRWFjaCB0aW1lIHlvdSByZWRpc3RyaWJ1dGUgdGhlIFByb2dyYW0gKG9yIGFueSB3 +b3JrIGJhc2VkIG9uIHRoZQpQcm9ncmFtKSwgdGhlIHJlY2lwaWVudCBhdXRvbWF0aWNhbGx5IHJl +Y2VpdmVzIGEgbGljZW5zZSBmcm9tIHRoZQpvcmlnaW5hbCBsaWNlbnNvciB0byBjb3B5LCBkaXN0 +cmlidXRlIG9yIG1vZGlmeSB0aGUgUHJvZ3JhbSBzdWJqZWN0IHRvCnRoZXNlIHRlcm1zIGFuZCBj +b25kaXRpb25zLiAgWW91IG1heSBub3QgaW1wb3NlIGFueSBmdXJ0aGVyCnJlc3RyaWN0aW9ucyBv +biB0aGUgcmVjaXBpZW50cycgZXhlcmNpc2Ugb2YgdGhlIHJpZ2h0cyBncmFudGVkIGhlcmVpbi4K +WW91IGFyZSBub3QgcmVzcG9uc2libGUgZm9yIGVuZm9yY2luZyBjb21wbGlhbmNlIGJ5IHRoaXJk +IHBhcnRpZXMgdG8KdGhpcyBMaWNlbnNlLgoKICA3LiBJZiwgYXMgYSBjb25zZXF1ZW5jZSBvZiBh +IGNvdXJ0IGp1ZGdtZW50IG9yIGFsbGVnYXRpb24gb2YgcGF0ZW50CmluZnJpbmdlbWVudCBvciBm +b3IgYW55IG90aGVyIHJlYXNvbiAobm90IGxpbWl0ZWQgdG8gcGF0ZW50IGlzc3VlcyksCmNvbmRp +dGlvbnMgYXJlIGltcG9zZWQgb24geW91ICh3aGV0aGVyIGJ5IGNvdXJ0IG9yZGVyLCBhZ3JlZW1l +bnQgb3IKb3RoZXJ3aXNlKSB0aGF0IGNvbnRyYWRpY3QgdGhlIGNvbmRpdGlvbnMgb2YgdGhpcyBM +aWNlbnNlLCB0aGV5IGRvIG5vdApleGN1c2UgeW91IGZyb20gdGhlIGNvbmRpdGlvbnMgb2YgdGhp +cyBMaWNlbnNlLiAgSWYgeW91IGNhbm5vdApkaXN0cmlidXRlIHNvIGFzIHRvIHNhdGlzZnkgc2lt +dWx0YW5lb3VzbHkgeW91ciBvYmxpZ2F0aW9ucyB1bmRlciB0aGlzCkxpY2Vuc2UgYW5kIGFueSBv +dGhlciBwZXJ0aW5lbnQgb2JsaWdhdGlvbnMsIHRoZW4gYXMgYSBjb25zZXF1ZW5jZSB5b3UKbWF5 +IG5vdCBkaXN0cmlidXRlIHRoZSBQcm9ncmFtIGF0IGFsbC4gIEZvciBleGFtcGxlLCBpZiBhIHBh +dGVudApsaWNlbnNlIHdvdWxkIG5vdCBwZXJtaXQgcm95YWx0eS1mcmVlIHJlZGlzdHJpYnV0aW9u +IG9mIHRoZSBQcm9ncmFtIGJ5CmFsbCB0aG9zZSB3aG8gcmVjZWl2ZSBjb3BpZXMgZGlyZWN0bHkg +b3IgaW5kaXJlY3RseSB0aHJvdWdoIHlvdSwgdGhlbgp0aGUgb25seSB3YXkgeW91IGNvdWxkIHNh +dGlzZnkgYm90aCBpdCBhbmQgdGhpcyBMaWNlbnNlIHdvdWxkIGJlIHRvCnJlZnJhaW4gZW50aXJl +bHkgZnJvbSBkaXN0cmlidXRpb24gb2YgdGhlIFByb2dyYW0uCgpJZiBhbnkgcG9ydGlvbiBvZiB0 +aGlzIHNlY3Rpb24gaXMgaGVsZCBpbnZhbGlkIG9yIHVuZW5mb3JjZWFibGUgdW5kZXIKYW55IHBh +cnRpY3VsYXIgY2lyY3Vtc3RhbmNlLCB0aGUgYmFsYW5jZSBvZiB0aGUgc2VjdGlvbiBpcyBpbnRl +bmRlZCB0bwphcHBseSBhbmQgdGhlIHNlY3Rpb24gYXMgYSB3aG9sZSBpcyBpbnRlbmRlZCB0byBh +cHBseSBpbiBvdGhlcgpjaXJjdW1zdGFuY2VzLgoKSXQgaXMgbm90IHRoZSBwdXJwb3NlIG9mIHRo +aXMgc2VjdGlvbiB0byBpbmR1Y2UgeW91IHRvIGluZnJpbmdlIGFueQpwYXRlbnRzIG9yIG90aGVy +IHByb3BlcnR5IHJpZ2h0IGNsYWltcyBvciB0byBjb250ZXN0IHZhbGlkaXR5IG9mIGFueQpzdWNo +IGNsYWltczsgdGhpcyBzZWN0aW9uIGhhcyB0aGUgc29sZSBwdXJwb3NlIG9mIHByb3RlY3Rpbmcg +dGhlCmludGVncml0eSBvZiB0aGUgZnJlZSBzb2Z0d2FyZSBkaXN0cmlidXRpb24gc3lzdGVtLCB3 +aGljaCBpcwppbXBsZW1lbnRlZCBieSBwdWJsaWMgbGljZW5zZSBwcmFjdGljZXMuICBNYW55IHBl +b3BsZSBoYXZlIG1hZGUKZ2VuZXJvdXMgY29udHJpYnV0aW9ucyB0byB0aGUgd2lkZSByYW5nZSBv +ZiBzb2Z0d2FyZSBkaXN0cmlidXRlZAp0aHJvdWdoIHRoYXQgc3lzdGVtIGluIHJlbGlhbmNlIG9u +IGNvbnNpc3RlbnQgYXBwbGljYXRpb24gb2YgdGhhdApzeXN0ZW07IGl0IGlzIHVwIHRvIHRoZSBh +dXRob3IvZG9ub3IgdG8gZGVjaWRlIGlmIGhlIG9yIHNoZSBpcyB3aWxsaW5nCnRvIGRpc3RyaWJ1 +dGUgc29mdHdhcmUgdGhyb3VnaCBhbnkgb3RoZXIgc3lzdGVtIGFuZCBhIGxpY2Vuc2VlIGNhbm5v +dAppbXBvc2UgdGhhdCBjaG9pY2UuCgpUaGlzIHNlY3Rpb24gaXMgaW50ZW5kZWQgdG8gbWFrZSB0 +aG9yb3VnaGx5IGNsZWFyIHdoYXQgaXMgYmVsaWV2ZWQgdG8KYmUgYSBjb25zZXF1ZW5jZSBvZiB0 +aGUgcmVzdCBvZiB0aGlzIExpY2Vuc2UuCgwKICA4LiBJZiB0aGUgZGlzdHJpYnV0aW9uIGFuZC9v +ciB1c2Ugb2YgdGhlIFByb2dyYW0gaXMgcmVzdHJpY3RlZCBpbgpjZXJ0YWluIGNvdW50cmllcyBl +aXRoZXIgYnkgcGF0ZW50cyBvciBieSBjb3B5cmlnaHRlZCBpbnRlcmZhY2VzLCB0aGUKb3JpZ2lu +YWwgY29weXJpZ2h0IGhvbGRlciB3aG8gcGxhY2VzIHRoZSBQcm9ncmFtIHVuZGVyIHRoaXMgTGlj +ZW5zZQptYXkgYWRkIGFuIGV4cGxpY2l0IGdlb2dyYXBoaWNhbCBkaXN0cmlidXRpb24gbGltaXRh +dGlvbiBleGNsdWRpbmcKdGhvc2UgY291bnRyaWVzLCBzbyB0aGF0IGRpc3RyaWJ1dGlvbiBpcyBw +ZXJtaXR0ZWQgb25seSBpbiBvciBhbW9uZwpjb3VudHJpZXMgbm90IHRodXMgZXhjbHVkZWQuICBJ +biBzdWNoIGNhc2UsIHRoaXMgTGljZW5zZSBpbmNvcnBvcmF0ZXMKdGhlIGxpbWl0YXRpb24gYXMg +aWYgd3JpdHRlbiBpbiB0aGUgYm9keSBvZiB0aGlzIExpY2Vuc2UuCgogIDkuIFRoZSBGcmVlIFNv +ZnR3YXJlIEZvdW5kYXRpb24gbWF5IHB1Ymxpc2ggcmV2aXNlZCBhbmQvb3IgbmV3IHZlcnNpb25z +Cm9mIHRoZSBHZW5lcmFsIFB1YmxpYyBMaWNlbnNlIGZyb20gdGltZSB0byB0aW1lLiAgU3VjaCBu +ZXcgdmVyc2lvbnMgd2lsbApiZSBzaW1pbGFyIGluIHNwaXJpdCB0byB0aGUgcHJlc2VudCB2ZXJz +aW9uLCBidXQgbWF5IGRpZmZlciBpbiBkZXRhaWwgdG8KYWRkcmVzcyBuZXcgcHJvYmxlbXMgb3Ig +Y29uY2VybnMuCgpFYWNoIHZlcnNpb24gaXMgZ2l2ZW4gYSBkaXN0aW5ndWlzaGluZyB2ZXJzaW9u +IG51bWJlci4gIElmIHRoZSBQcm9ncmFtCnNwZWNpZmllcyBhIHZlcnNpb24gbnVtYmVyIG9mIHRo +aXMgTGljZW5zZSB3aGljaCBhcHBsaWVzIHRvIGl0IGFuZCAiYW55CmxhdGVyIHZlcnNpb24iLCB5 +b3UgaGF2ZSB0aGUgb3B0aW9uIG9mIGZvbGxvd2luZyB0aGUgdGVybXMgYW5kIGNvbmRpdGlvbnMK +ZWl0aGVyIG9mIHRoYXQgdmVyc2lvbiBvciBvZiBhbnkgbGF0ZXIgdmVyc2lvbiBwdWJsaXNoZWQg +YnkgdGhlIEZyZWUKU29mdHdhcmUgRm91bmRhdGlvbi4gIElmIHRoZSBQcm9ncmFtIGRvZXMgbm90 +IHNwZWNpZnkgYSB2ZXJzaW9uIG51bWJlciBvZgp0aGlzIExpY2Vuc2UsIHlvdSBtYXkgY2hvb3Nl +IGFueSB2ZXJzaW9uIGV2ZXIgcHVibGlzaGVkIGJ5IHRoZSBGcmVlIFNvZnR3YXJlCkZvdW5kYXRp +b24uCgogIDEwLiBJZiB5b3Ugd2lzaCB0byBpbmNvcnBvcmF0ZSBwYXJ0cyBvZiB0aGUgUHJvZ3Jh +bSBpbnRvIG90aGVyIGZyZWUKcHJvZ3JhbXMgd2hvc2UgZGlzdHJpYnV0aW9uIGNvbmRpdGlvbnMg +YXJlIGRpZmZlcmVudCwgd3JpdGUgdG8gdGhlIGF1dGhvcgp0byBhc2sgZm9yIHBlcm1pc3Npb24u +ICBGb3Igc29mdHdhcmUgd2hpY2ggaXMgY29weXJpZ2h0ZWQgYnkgdGhlIEZyZWUKU29mdHdhcmUg +Rm91bmRhdGlvbiwgd3JpdGUgdG8gdGhlIEZyZWUgU29mdHdhcmUgRm91bmRhdGlvbjsgd2Ugc29t +ZXRpbWVzCm1ha2UgZXhjZXB0aW9ucyBmb3IgdGhpcy4gIE91ciBkZWNpc2lvbiB3aWxsIGJlIGd1 +aWRlZCBieSB0aGUgdHdvIGdvYWxzCm9mIHByZXNlcnZpbmcgdGhlIGZyZWUgc3RhdHVzIG9mIGFs +bCBkZXJpdmF0aXZlcyBvZiBvdXIgZnJlZSBzb2Z0d2FyZSBhbmQKb2YgcHJvbW90aW5nIHRoZSBz +aGFyaW5nIGFuZCByZXVzZSBvZiBzb2Z0d2FyZSBnZW5lcmFsbHkuCgoJCQkgICAgTk8gV0FSUkFO +VFkKCiAgMTEuIEJFQ0FVU0UgVEhFIFBST0dSQU0gSVMgTElDRU5TRUQgRlJFRSBPRiBDSEFSR0Us +IFRIRVJFIElTIE5PIFdBUlJBTlRZCkZPUiBUSEUgUFJPR1JBTSwgVE8gVEhFIEVYVEVOVCBQRVJN +SVRURUQgQlkgQVBQTElDQUJMRSBMQVcuICBFWENFUFQgV0hFTgpPVEhFUldJU0UgU1RBVEVEIElO +IFdSSVRJTkcgVEhFIENPUFlSSUdIVCBIT0xERVJTIEFORC9PUiBPVEhFUiBQQVJUSUVTClBST1ZJ +REUgVEhFIFBST0dSQU0gIkFTIElTIiBXSVRIT1VUIFdBUlJBTlRZIE9GIEFOWSBLSU5ELCBFSVRI +RVIgRVhQUkVTU0VECk9SIElNUExJRUQsIElOQ0xVRElORywgQlVUIE5PVCBMSU1JVEVEIFRPLCBU +SEUgSU1QTElFRCBXQVJSQU5USUVTIE9GCk1FUkNIQU5UQUJJTElUWSBBTkQgRklUTkVTUyBGT1Ig +QSBQQVJUSUNVTEFSIFBVUlBPU0UuICBUSEUgRU5USVJFIFJJU0sgQVMKVE8gVEhFIFFVQUxJVFkg +QU5EIFBFUkZPUk1BTkNFIE9GIFRIRSBQUk9HUkFNIElTIFdJVEggWU9VLiAgU0hPVUxEIFRIRQpQ +Uk9HUkFNIFBST1ZFIERFRkVDVElWRSwgWU9VIEFTU1VNRSBUSEUgQ09TVCBPRiBBTEwgTkVDRVNT +QVJZIFNFUlZJQ0lORywKUkVQQUlSIE9SIENPUlJFQ1RJT04uCgogIDEyLiBJTiBOTyBFVkVOVCBV +TkxFU1MgUkVRVUlSRUQgQlkgQVBQTElDQUJMRSBMQVcgT1IgQUdSRUVEIFRPIElOIFdSSVRJTkcK +V0lMTCBBTlkgQ09QWVJJR0hUIEhPTERFUiwgT1IgQU5ZIE9USEVSIFBBUlRZIFdITyBNQVkgTU9E +SUZZIEFORC9PUgpSRURJU1RSSUJVVEUgVEhFIFBST0dSQU0gQVMgUEVSTUlUVEVEIEFCT1ZFLCBC +RSBMSUFCTEUgVE8gWU9VIEZPUiBEQU1BR0VTLApJTkNMVURJTkcgQU5ZIEdFTkVSQUwsIFNQRUNJ +QUwsIElOQ0lERU5UQUwgT1IgQ09OU0VRVUVOVElBTCBEQU1BR0VTIEFSSVNJTkcKT1VUIE9GIFRI +RSBVU0UgT1IgSU5BQklMSVRZIFRPIFVTRSBUSEUgUFJPR1JBTSAoSU5DTFVESU5HIEJVVCBOT1Qg +TElNSVRFRApUTyBMT1NTIE9GIERBVEEgT1IgREFUQSBCRUlORyBSRU5ERVJFRCBJTkFDQ1VSQVRF +IE9SIExPU1NFUyBTVVNUQUlORUQgQlkKWU9VIE9SIFRISVJEIFBBUlRJRVMgT1IgQSBGQUlMVVJF +IE9GIFRIRSBQUk9HUkFNIFRPIE9QRVJBVEUgV0lUSCBBTlkgT1RIRVIKUFJPR1JBTVMpLCBFVkVO +IElGIFNVQ0ggSE9MREVSIE9SIE9USEVSIFBBUlRZIEhBUyBCRUVOIEFEVklTRUQgT0YgVEhFClBP +U1NJQklMSVRZIE9GIFNVQ0ggREFNQUdFUy4KCgkJICAgICBFTkQgT0YgVEVSTVMgQU5EIENPTkRJ +VElPTlMKDAoJICAgIEhvdyB0byBBcHBseSBUaGVzZSBUZXJtcyB0byBZb3VyIE5ldyBQcm9ncmFt +cwoKICBJZiB5b3UgZGV2ZWxvcCBhIG5ldyBwcm9ncmFtLCBhbmQgeW91IHdhbnQgaXQgdG8gYmUg +b2YgdGhlIGdyZWF0ZXN0CnBvc3NpYmxlIHVzZSB0byB0aGUgcHVibGljLCB0aGUgYmVzdCB3YXkg +dG8gYWNoaWV2ZSB0aGlzIGlzIHRvIG1ha2UgaXQKZnJlZSBzb2Z0d2FyZSB3aGljaCBldmVyeW9u +ZSBjYW4gcmVkaXN0cmlidXRlIGFuZCBjaGFuZ2UgdW5kZXIgdGhlc2UgdGVybXMuCgogIFRvIGRv +IHNvLCBhdHRhY2ggdGhlIGZvbGxvd2luZyBub3RpY2VzIHRvIHRoZSBwcm9ncmFtLiAgSXQgaXMg +c2FmZXN0CnRvIGF0dGFjaCB0aGVtIHRvIHRoZSBzdGFydCBvZiBlYWNoIHNvdXJjZSBmaWxlIHRv +IG1vc3QgZWZmZWN0aXZlbHkKY29udmV5IHRoZSBleGNsdXNpb24gb2Ygd2FycmFudHk7IGFuZCBl +YWNoIGZpbGUgc2hvdWxkIGhhdmUgYXQgbGVhc3QKdGhlICJjb3B5cmlnaHQiIGxpbmUgYW5kIGEg +cG9pbnRlciB0byB3aGVyZSB0aGUgZnVsbCBub3RpY2UgaXMgZm91bmQuCgogICAgPG9uZSBsaW5l +IHRvIGdpdmUgdGhlIHByb2dyYW0ncyBuYW1lIGFuZCBhIGJyaWVmIGlkZWEgb2Ygd2hhdCBpdCBk +b2VzLj4KICAgIENvcHlyaWdodCAoQykgPHllYXI+ICA8bmFtZSBvZiBhdXRob3I+CgogICAgVGhp +cyBwcm9ncmFtIGlzIGZyZWUgc29mdHdhcmU7IHlvdSBjYW4gcmVkaXN0cmlidXRlIGl0IGFuZC9v +ciBtb2RpZnkKICAgIGl0IHVuZGVyIHRoZSB0ZXJtcyBvZiB0aGUgR05VIEdlbmVyYWwgUHVibGlj +IExpY2Vuc2UgYXMgcHVibGlzaGVkIGJ5CiAgICB0aGUgRnJlZSBTb2Z0d2FyZSBGb3VuZGF0aW9u +OyBlaXRoZXIgdmVyc2lvbiAyIG9mIHRoZSBMaWNlbnNlLCBvcgogICAgKGF0IHlvdXIgb3B0aW9u +KSBhbnkgbGF0ZXIgdmVyc2lvbi4KCiAgICBUaGlzIHByb2dyYW0gaXMgZGlzdHJpYnV0ZWQgaW4g +dGhlIGhvcGUgdGhhdCBpdCB3aWxsIGJlIHVzZWZ1bCwKICAgIGJ1dCBXSVRIT1VUIEFOWSBXQVJS +QU5UWTsgd2l0aG91dCBldmVuIHRoZSBpbXBsaWVkIHdhcnJhbnR5IG9mCiAgICBNRVJDSEFOVEFC +SUxJVFkgb3IgRklUTkVTUyBGT1IgQSBQQVJUSUNVTEFSIFBVUlBPU0UuICBTZWUgdGhlCiAgICBH +TlUgR2VuZXJhbCBQdWJsaWMgTGljZW5zZSBmb3IgbW9yZSBkZXRhaWxzLgoKICAgIFlvdSBzaG91 +bGQgaGF2ZSByZWNlaXZlZCBhIGNvcHkgb2YgdGhlIEdOVSBHZW5lcmFsIFB1YmxpYyBMaWNlbnNl +CiAgICBhbG9uZyB3aXRoIHRoaXMgcHJvZ3JhbTsgaWYgbm90LCB3cml0ZSB0byB0aGUgRnJlZSBT +b2Z0d2FyZQogICAgRm91bmRhdGlvbiwgSW5jLiwgNTkgVGVtcGxlIFBsYWNlLCBTdWl0ZSAzMzAs +IEJvc3RvbiwgTUEgIDAyMTExLTEzMDcgIFVTQQoKCkFsc28gYWRkIGluZm9ybWF0aW9uIG9uIGhv +dyB0byBjb250YWN0IHlvdSBieSBlbGVjdHJvbmljIGFuZCBwYXBlciBtYWlsLgoKSWYgdGhlIHBy +b2dyYW0gaXMgaW50ZXJhY3RpdmUsIG1ha2UgaXQgb3V0cHV0IGEgc2hvcnQgbm90aWNlIGxpa2Ug +dGhpcwp3aGVuIGl0IHN0YXJ0cyBpbiBhbiBpbnRlcmFjdGl2ZSBtb2RlOgoKICAgIEdub21vdmlz +aW9uIHZlcnNpb24gNjksIENvcHlyaWdodCAoQykgeWVhciBuYW1lIG9mIGF1dGhvcgogICAgR25v +bW92aXNpb24gY29tZXMgd2l0aCBBQlNPTFVURUxZIE5PIFdBUlJBTlRZOyBmb3IgZGV0YWlscyB0 +eXBlIGBzaG93IHcnLgogICAgVGhpcyBpcyBmcmVlIHNvZnR3YXJlLCBhbmQgeW91IGFyZSB3ZWxj +b21lIHRvIHJlZGlzdHJpYnV0ZSBpdAogICAgdW5kZXIgY2VydGFpbiBjb25kaXRpb25zOyB0eXBl +IGBzaG93IGMnIGZvciBkZXRhaWxzLgoKVGhlIGh5cG90aGV0aWNhbCBjb21tYW5kcyBgc2hvdyB3 +JyBhbmQgYHNob3cgYycgc2hvdWxkIHNob3cgdGhlIGFwcHJvcHJpYXRlCnBhcnRzIG9mIHRoZSBH +ZW5lcmFsIFB1YmxpYyBMaWNlbnNlLiAgT2YgY291cnNlLCB0aGUgY29tbWFuZHMgeW91IHVzZSBt +YXkKYmUgY2FsbGVkIHNvbWV0aGluZyBvdGhlciB0aGFuIGBzaG93IHcnIGFuZCBgc2hvdyBjJzsg +dGhleSBjb3VsZCBldmVuIGJlCm1vdXNlLWNsaWNrcyBvciBtZW51IGl0ZW1zLS13aGF0ZXZlciBz +dWl0cyB5b3VyIHByb2dyYW0uCgpZb3Ugc2hvdWxkIGFsc28gZ2V0IHlvdXIgZW1wbG95ZXIgKGlm +IHlvdSB3b3JrIGFzIGEgcHJvZ3JhbW1lcikgb3IgeW91cgpzY2hvb2wsIGlmIGFueSwgdG8gc2ln +biBhICJjb3B5cmlnaHQgZGlzY2xhaW1lciIgZm9yIHRoZSBwcm9ncmFtLCBpZgpuZWNlc3Nhcnku +ICBIZXJlIGlzIGEgc2FtcGxlOyBhbHRlciB0aGUgbmFtZXM6CgogIFlveW9keW5lLCBJbmMuLCBo +ZXJlYnkgZGlzY2xhaW1zIGFsbCBjb3B5cmlnaHQgaW50ZXJlc3QgaW4gdGhlIHByb2dyYW0KICBg +R25vbW92aXNpb24nICh3aGljaCBtYWtlcyBwYXNzZXMgYXQgY29tcGlsZXJzKSB3cml0dGVuIGJ5 +IEphbWVzIEhhY2tlci4KCiAgPHNpZ25hdHVyZSBvZiBUeSBDb29uPiwgMSBBcHJpbCAxOTg5CiAg +VHkgQ29vbiwgUHJlc2lkZW50IG9mIFZpY2UKClRoaXMgR2VuZXJhbCBQdWJsaWMgTGljZW5zZSBk +b2VzIG5vdCBwZXJtaXQgaW5jb3Jwb3JhdGluZyB5b3VyIHByb2dyYW0gaW50bwpwcm9wcmlldGFy +eSBwcm9ncmFtcy4gIElmIHlvdXIgcHJvZ3JhbSBpcyBhIHN1YnJvdXRpbmUgbGlicmFyeSwgeW91 +IG1heQpjb25zaWRlciBpdCBtb3JlIHVzZWZ1bCB0byBwZXJtaXQgbGlua2luZyBwcm9wcmlldGFy +eSBhcHBsaWNhdGlvbnMgd2l0aCB0aGUKbGlicmFyeS4gIElmIHRoaXMgaXMgd2hhdCB5b3Ugd2Fu +dCB0byBkbywgdXNlIHRoZSBHTlUgTGlicmFyeSBHZW5lcmFsClB1YmxpYyBMaWNlbnNlIGluc3Rl +YWQgb2YgdGhpcyBMaWNlbnNlLgo= +ClxjaGFwdGVye1RoZSBHTlUgR2VuZXJhbCBQdWJsaWMgTGljZW5zZX0KClxiZWdpbntjZW50ZXJ9 +CntccGFyaW5kZW50IDBpbgoKVmVyc2lvbiAyLCBKdW5lIDE5OTEKCkNvcHlyaWdodCBcY29weXJp +Z2h0XCAxOTg5LCAxOTkxIEZyZWUgU29mdHdhcmUgRm91bmRhdGlvbiwgSW5jLgoKXGJpZ3NraXAK +CjU5IFRlbXBsZSBQbGFjZSAtIFN1aXRlIDMzMCwgQm9zdG9uLCBNQSAgMDIxMTEtMTMwNywgVVNB +CgpcYmlnc2tpcAoKRXZlcnlvbmUgaXMgcGVybWl0dGVkIHRvIGNvcHkgYW5kIGRpc3RyaWJ1dGUg +dmVyYmF0aW0gY29waWVzCm9mIHRoaXMgbGljZW5zZSBkb2N1bWVudCwgYnV0IGNoYW5naW5nIGl0 +IGlzIG5vdCBhbGxvd2VkLgp9ClxlbmR7Y2VudGVyfQoKXGJlZ2lue2NlbnRlcn0Ke1xiZlxsYXJn +ZSBQcmVhbWJsZX0KXGVuZHtjZW50ZXJ9CgoKVGhlIGxpY2Vuc2VzIGZvciBtb3N0IHNvZnR3YXJl +IGFyZSBkZXNpZ25lZCB0byB0YWtlIGF3YXkgeW91ciBmcmVlZG9tIHRvCnNoYXJlIGFuZCBjaGFu +Z2UgaXQuICBCeSBjb250cmFzdCwgdGhlIEdOVSBHZW5lcmFsIFB1YmxpYyBMaWNlbnNlIGlzCmlu +dGVuZGVkIHRvIGd1YXJhbnRlZSB5b3VyIGZyZWVkb20gdG8gc2hhcmUgYW5kIGNoYW5nZSBmcmVl +IHNvZnR3YXJlLS0tdG8KbWFrZSBzdXJlIHRoZSBzb2Z0d2FyZSBpcyBmcmVlIGZvciBhbGwgaXRz +IHVzZXJzLiAgVGhpcyBHZW5lcmFsIFB1YmxpYwpMaWNlbnNlIGFwcGxpZXMgdG8gbW9zdCBvZiB0 +aGUgRnJlZSBTb2Z0d2FyZSBGb3VuZGF0aW9uJ3Mgc29mdHdhcmUgYW5kIHRvCmFueSBvdGhlciBw +cm9ncmFtIHdob3NlIGF1dGhvcnMgY29tbWl0IHRvIHVzaW5nIGl0LiAgKFNvbWUgb3RoZXIgRnJl +ZQpTb2Z0d2FyZSBGb3VuZGF0aW9uIHNvZnR3YXJlIGlzIGNvdmVyZWQgYnkgdGhlIEdOVSBMaWJy +YXJ5IEdlbmVyYWwgUHVibGljCkxpY2Vuc2UgaW5zdGVhZC4pICBZb3UgY2FuIGFwcGx5IGl0IHRv +IHlvdXIgcHJvZ3JhbXMsIHRvby4KCldoZW4gd2Ugc3BlYWsgb2YgZnJlZSBzb2Z0d2FyZSwgd2Ug +YXJlIHJlZmVycmluZyB0byBmcmVlZG9tLCBub3QgcHJpY2UuCk91ciBHZW5lcmFsIFB1YmxpYyBM +aWNlbnNlcyBhcmUgZGVzaWduZWQgdG8gbWFrZSBzdXJlIHRoYXQgeW91IGhhdmUgdGhlCmZyZWVk +b20gdG8gZGlzdHJpYnV0ZSBjb3BpZXMgb2YgZnJlZSBzb2Z0d2FyZSAoYW5kIGNoYXJnZSBmb3Ig +dGhpcyBzZXJ2aWNlCmlmIHlvdSB3aXNoKSwgdGhhdCB5b3UgcmVjZWl2ZSBzb3VyY2UgY29kZSBv +ciBjYW4gZ2V0IGl0IGlmIHlvdSB3YW50IGl0LAp0aGF0IHlvdSBjYW4gY2hhbmdlIHRoZSBzb2Z0 +d2FyZSBvciB1c2UgcGllY2VzIG9mIGl0IGluIG5ldyBmcmVlIHByb2dyYW1zOwphbmQgdGhhdCB5 +b3Uga25vdyB5b3UgY2FuIGRvIHRoZXNlIHRoaW5ncy4KClRvIHByb3RlY3QgeW91ciByaWdodHMs +IHdlIG5lZWQgdG8gbWFrZSByZXN0cmljdGlvbnMgdGhhdCBmb3JiaWQgYW55b25lIHRvCmRlbnkg +eW91IHRoZXNlIHJpZ2h0cyBvciB0byBhc2sgeW91IHRvIHN1cnJlbmRlciB0aGUgcmlnaHRzLiAg +VGhlc2UKcmVzdHJpY3Rpb25zIHRyYW5zbGF0ZSB0byBjZXJ0YWluIHJlc3BvbnNpYmlsaXRpZXMg +Zm9yIHlvdSBpZiB5b3UKZGlzdHJpYnV0ZSBjb3BpZXMgb2YgdGhlIHNvZnR3YXJlLCBvciBpZiB5 +b3UgbW9kaWZ5IGl0LgoKRm9yIGV4YW1wbGUsIGlmIHlvdSBkaXN0cmlidXRlIGNvcGllcyBvZiBz +dWNoIGEgcHJvZ3JhbSwgd2hldGhlciBncmF0aXMgb3IKZm9yIGEgZmVlLCB5b3UgbXVzdCBnaXZl +IHRoZSByZWNpcGllbnRzIGFsbCB0aGUgcmlnaHRzIHRoYXQgeW91IGhhdmUuICBZb3UKbXVzdCBt +YWtlIHN1cmUgdGhhdCB0aGV5LCB0b28sIHJlY2VpdmUgb3IgY2FuIGdldCB0aGUgc291cmNlIGNv +ZGUuICBBbmQKeW91IG11c3Qgc2hvdyB0aGVtIHRoZXNlIHRlcm1zIHNvIHRoZXkga25vdyB0aGVp +ciByaWdodHMuCgpXZSBwcm90ZWN0IHlvdXIgcmlnaHRzIHdpdGggdHdvIHN0ZXBzOiAoMSkgY29w +eXJpZ2h0IHRoZSBzb2Z0d2FyZSwgYW5kICgyKQpvZmZlciB5b3UgdGhpcyBsaWNlbnNlIHdoaWNo +IGdpdmVzIHlvdSBsZWdhbCBwZXJtaXNzaW9uIHRvIGNvcHksCmRpc3RyaWJ1dGUgYW5kL29yIG1v +ZGlmeSB0aGUgc29mdHdhcmUuCgpBbHNvLCBmb3IgZWFjaCBhdXRob3IncyBwcm90ZWN0aW9uIGFu +ZCBvdXJzLCB3ZSB3YW50IHRvIG1ha2UgY2VydGFpbiB0aGF0CmV2ZXJ5b25lIHVuZGVyc3RhbmRz +IHRoYXQgdGhlcmUgaXMgbm8gd2FycmFudHkgZm9yIHRoaXMgZnJlZSBzb2Z0d2FyZS4gIElmCnRo +ZSBzb2Z0d2FyZSBpcyBtb2RpZmllZCBieSBzb21lb25lIGVsc2UgYW5kIHBhc3NlZCBvbiwgd2Ug +d2FudCBpdHMKcmVjaXBpZW50cyB0byBrbm93IHRoYXQgd2hhdCB0aGV5IGhhdmUgaXMgbm90IHRo +ZSBvcmlnaW5hbCwgc28gdGhhdCBhbnkKcHJvYmxlbXMgaW50cm9kdWNlZCBieSBvdGhlcnMgd2ls +bCBub3QgcmVmbGVjdCBvbiB0aGUgb3JpZ2luYWwgYXV0aG9ycycKcmVwdXRhdGlvbnMuCgpGaW5h +bGx5LCBhbnkgZnJlZSBwcm9ncmFtIGlzIHRocmVhdGVuZWQgY29uc3RhbnRseSBieSBzb2Z0d2Fy +ZSBwYXRlbnRzLgpXZSB3aXNoIHRvIGF2b2lkIHRoZSBkYW5nZXIgdGhhdCByZWRpc3RyaWJ1dG9y +cyBvZiBhIGZyZWUgcHJvZ3JhbSB3aWxsCmluZGl2aWR1YWxseSBvYnRhaW4gcGF0ZW50IGxpY2Vu +c2VzLCBpbiBlZmZlY3QgbWFraW5nIHRoZSBwcm9ncmFtCnByb3ByaWV0YXJ5LiAgVG8gcHJldmVu +dCB0aGlzLCB3ZSBoYXZlIG1hZGUgaXQgY2xlYXIgdGhhdCBhbnkgcGF0ZW50IG11c3QKYmUgbGlj +ZW5zZWQgZm9yIGV2ZXJ5b25lJ3MgZnJlZSB1c2Ugb3Igbm90IGxpY2Vuc2VkIGF0IGFsbC4KClRo +ZSBwcmVjaXNlIHRlcm1zIGFuZCBjb25kaXRpb25zIGZvciBjb3B5aW5nLCBkaXN0cmlidXRpb24g +YW5kCm1vZGlmaWNhdGlvbiBmb2xsb3cuCgpcYmVnaW57Y2VudGVyfQp7XExhcmdlIFxzYyBUZXJt +cyBhbmQgQ29uZGl0aW9ucyBGb3IgQ29weWluZywgRGlzdHJpYnV0aW9uIGFuZAogIE1vZGlmaWNh +dGlvbn0KXGVuZHtjZW50ZXJ9CgoKJVxyZW5ld2NvbW1hbmR7XHRoZWVudW1pfXtcYWxwaGF7ZW51 +bWl9fQpcYmVnaW57ZW51bWVyYXRlfQoKXGFkZHRvY291bnRlcntlbnVtaX17LTF9CgpcaXRlbSAK +ClRoaXMgTGljZW5zZSBhcHBsaWVzIHRvIGFueSBwcm9ncmFtIG9yIG90aGVyIHdvcmsgd2hpY2gg +Y29udGFpbnMgYSBub3RpY2UKcGxhY2VkIGJ5IHRoZSBjb3B5cmlnaHQgaG9sZGVyIHNheWluZyBp +dCBtYXkgYmUgZGlzdHJpYnV0ZWQgdW5kZXIgdGhlCnRlcm1zIG9mIHRoaXMgR2VuZXJhbCBQdWJs +aWMgTGljZW5zZS4gIFRoZSBgYFByb2dyYW0nJywgYmVsb3csIHJlZmVycyB0bwphbnkgc3VjaCBw +cm9ncmFtIG9yIHdvcmssIGFuZCBhIGBgd29yayBiYXNlZCBvbiB0aGUgUHJvZ3JhbScnIG1lYW5z +IGVpdGhlcgp0aGUgUHJvZ3JhbSBvciBhbnkgZGVyaXZhdGl2ZSB3b3JrIHVuZGVyIGNvcHlyaWdo +dCBsYXc6IHRoYXQgaXMgdG8gc2F5LCBhCndvcmsgY29udGFpbmluZyB0aGUgUHJvZ3JhbSBvciBh +IHBvcnRpb24gb2YgaXQsIGVpdGhlciB2ZXJiYXRpbSBvciB3aXRoCm1vZGlmaWNhdGlvbnMgYW5k +L29yIHRyYW5zbGF0ZWQgaW50byBhbm90aGVyIGxhbmd1YWdlLiAgKEhlcmVpbmFmdGVyLAp0cmFu +c2xhdGlvbiBpcyBpbmNsdWRlZCB3aXRob3V0IGxpbWl0YXRpb24gaW4gdGhlIHRlcm0gYGBtb2Rp +ZmljYXRpb24nJy4pCkVhY2ggbGljZW5zZWUgaXMgYWRkcmVzc2VkIGFzIGBgeW91JycuCgpBY3Rp +dml0aWVzIG90aGVyIHRoYW4gY29weWluZywgZGlzdHJpYnV0aW9uIGFuZCBtb2RpZmljYXRpb24g +YXJlIG5vdApjb3ZlcmVkIGJ5IHRoaXMgTGljZW5zZTsgdGhleSBhcmUgb3V0c2lkZSBpdHMgc2Nv +cGUuICBUaGUgYWN0IG9mCnJ1bm5pbmcgdGhlIFByb2dyYW0gaXMgbm90IHJlc3RyaWN0ZWQsIGFu +ZCB0aGUgb3V0cHV0IGZyb20gdGhlIFByb2dyYW0KaXMgY292ZXJlZCBvbmx5IGlmIGl0cyBjb250 +ZW50cyBjb25zdGl0dXRlIGEgd29yayBiYXNlZCBvbiB0aGUKUHJvZ3JhbSAoaW5kZXBlbmRlbnQg +b2YgaGF2aW5nIGJlZW4gbWFkZSBieSBydW5uaW5nIHRoZSBQcm9ncmFtKS4KV2hldGhlciB0aGF0 +IGlzIHRydWUgZGVwZW5kcyBvbiB3aGF0IHRoZSBQcm9ncmFtIGRvZXMuCgpcaXRlbSBZb3UgbWF5 +IGNvcHkgYW5kIGRpc3RyaWJ1dGUgdmVyYmF0aW0gY29waWVzIG9mIHRoZSBQcm9ncmFtJ3Mgc291 +cmNlCiAgY29kZSBhcyB5b3UgcmVjZWl2ZSBpdCwgaW4gYW55IG1lZGl1bSwgcHJvdmlkZWQgdGhh +dCB5b3UgY29uc3BpY3VvdXNseQogIGFuZCBhcHByb3ByaWF0ZWx5IHB1Ymxpc2ggb24gZWFjaCBj +b3B5IGFuIGFwcHJvcHJpYXRlIGNvcHlyaWdodCBub3RpY2UKICBhbmQgZGlzY2xhaW1lciBvZiB3 +YXJyYW50eTsga2VlcCBpbnRhY3QgYWxsIHRoZSBub3RpY2VzIHRoYXQgcmVmZXIgdG8KICB0aGlz +IExpY2Vuc2UgYW5kIHRvIHRoZSBhYnNlbmNlIG9mIGFueSB3YXJyYW50eTsgYW5kIGdpdmUgYW55 +IG90aGVyCiAgcmVjaXBpZW50cyBvZiB0aGUgUHJvZ3JhbSBhIGNvcHkgb2YgdGhpcyBMaWNlbnNl +IGFsb25nIHdpdGggdGhlIFByb2dyYW0uCgpZb3UgbWF5IGNoYXJnZSBhIGZlZSBmb3IgdGhlIHBo +eXNpY2FsIGFjdCBvZiB0cmFuc2ZlcnJpbmcgYSBjb3B5LCBhbmQgeW91Cm1heSBhdCB5b3VyIG9w +dGlvbiBvZmZlciB3YXJyYW50eSBwcm90ZWN0aW9uIGluIGV4Y2hhbmdlIGZvciBhIGZlZS4KClxp +dGVtCgpZb3UgbWF5IG1vZGlmeSB5b3VyIGNvcHkgb3IgY29waWVzIG9mIHRoZSBQcm9ncmFtIG9y +IGFueSBwb3J0aW9uCm9mIGl0LCB0aHVzIGZvcm1pbmcgYSB3b3JrIGJhc2VkIG9uIHRoZSBQcm9n +cmFtLCBhbmQgY29weSBhbmQKZGlzdHJpYnV0ZSBzdWNoIG1vZGlmaWNhdGlvbnMgb3Igd29yayB1 +bmRlciB0aGUgdGVybXMgb2YgU2VjdGlvbiAxCmFib3ZlLCBwcm92aWRlZCB0aGF0IHlvdSBhbHNv +IG1lZXQgYWxsIG9mIHRoZXNlIGNvbmRpdGlvbnM6CgpcYmVnaW57ZW51bWVyYXRlfQoKXGl0ZW0g +CgpZb3UgbXVzdCBjYXVzZSB0aGUgbW9kaWZpZWQgZmlsZXMgdG8gY2FycnkgcHJvbWluZW50IG5v +dGljZXMgc3RhdGluZyB0aGF0CnlvdSBjaGFuZ2VkIHRoZSBmaWxlcyBhbmQgdGhlIGRhdGUgb2Yg +YW55IGNoYW5nZS4KClxpdGVtCgpZb3UgbXVzdCBjYXVzZSBhbnkgd29yayB0aGF0IHlvdSBkaXN0 +cmlidXRlIG9yIHB1Ymxpc2gsIHRoYXQgaW4Kd2hvbGUgb3IgaW4gcGFydCBjb250YWlucyBvciBp +cyBkZXJpdmVkIGZyb20gdGhlIFByb2dyYW0gb3IgYW55CnBhcnQgdGhlcmVvZiwgdG8gYmUgbGlj +ZW5zZWQgYXMgYSB3aG9sZSBhdCBubyBjaGFyZ2UgdG8gYWxsIHRoaXJkCnBhcnRpZXMgdW5kZXIg +dGhlIHRlcm1zIG9mIHRoaXMgTGljZW5zZS4KClxpdGVtCklmIHRoZSBtb2RpZmllZCBwcm9ncmFt +IG5vcm1hbGx5IHJlYWRzIGNvbW1hbmRzIGludGVyYWN0aXZlbHkKd2hlbiBydW4sIHlvdSBtdXN0 +IGNhdXNlIGl0LCB3aGVuIHN0YXJ0ZWQgcnVubmluZyBmb3Igc3VjaAppbnRlcmFjdGl2ZSB1c2Ug +aW4gdGhlIG1vc3Qgb3JkaW5hcnkgd2F5LCB0byBwcmludCBvciBkaXNwbGF5IGFuCmFubm91bmNl +bWVudCBpbmNsdWRpbmcgYW4gYXBwcm9wcmlhdGUgY29weXJpZ2h0IG5vdGljZSBhbmQgYQpub3Rp +Y2UgdGhhdCB0aGVyZSBpcyBubyB3YXJyYW50eSAob3IgZWxzZSwgc2F5aW5nIHRoYXQgeW91IHBy +b3ZpZGUKYSB3YXJyYW50eSkgYW5kIHRoYXQgdXNlcnMgbWF5IHJlZGlzdHJpYnV0ZSB0aGUgcHJv +Z3JhbSB1bmRlcgp0aGVzZSBjb25kaXRpb25zLCBhbmQgdGVsbGluZyB0aGUgdXNlciBob3cgdG8g +dmlldyBhIGNvcHkgb2YgdGhpcwpMaWNlbnNlLiAgKEV4Y2VwdGlvbjogaWYgdGhlIFByb2dyYW0g +aXRzZWxmIGlzIGludGVyYWN0aXZlIGJ1dApkb2VzIG5vdCBub3JtYWxseSBwcmludCBzdWNoIGFu +IGFubm91bmNlbWVudCwgeW91ciB3b3JrIGJhc2VkIG9uCnRoZSBQcm9ncmFtIGlzIG5vdCByZXF1 +aXJlZCB0byBwcmludCBhbiBhbm5vdW5jZW1lbnQuKQoKXGVuZHtlbnVtZXJhdGV9CgoKVGhlc2Ug +cmVxdWlyZW1lbnRzIGFwcGx5IHRvIHRoZSBtb2RpZmllZCB3b3JrIGFzIGEgd2hvbGUuICBJZgpp +ZGVudGlmaWFibGUgc2VjdGlvbnMgb2YgdGhhdCB3b3JrIGFyZSBub3QgZGVyaXZlZCBmcm9tIHRo +ZSBQcm9ncmFtLAphbmQgY2FuIGJlIHJlYXNvbmFibHkgY29uc2lkZXJlZCBpbmRlcGVuZGVudCBh +bmQgc2VwYXJhdGUgd29ya3MgaW4KdGhlbXNlbHZlcywgdGhlbiB0aGlzIExpY2Vuc2UsIGFuZCBp +dHMgdGVybXMsIGRvIG5vdCBhcHBseSB0byB0aG9zZQpzZWN0aW9ucyB3aGVuIHlvdSBkaXN0cmli +dXRlIHRoZW0gYXMgc2VwYXJhdGUgd29ya3MuICBCdXQgd2hlbiB5b3UKZGlzdHJpYnV0ZSB0aGUg +c2FtZSBzZWN0aW9ucyBhcyBwYXJ0IG9mIGEgd2hvbGUgd2hpY2ggaXMgYSB3b3JrIGJhc2VkCm9u +IHRoZSBQcm9ncmFtLCB0aGUgZGlzdHJpYnV0aW9uIG9mIHRoZSB3aG9sZSBtdXN0IGJlIG9uIHRo +ZSB0ZXJtcyBvZgp0aGlzIExpY2Vuc2UsIHdob3NlIHBlcm1pc3Npb25zIGZvciBvdGhlciBsaWNl +bnNlZXMgZXh0ZW5kIHRvIHRoZQplbnRpcmUgd2hvbGUsIGFuZCB0aHVzIHRvIGVhY2ggYW5kIGV2 +ZXJ5IHBhcnQgcmVnYXJkbGVzcyBvZiB3aG8gd3JvdGUgaXQuCgpUaHVzLCBpdCBpcyBub3QgdGhl +IGludGVudCBvZiB0aGlzIHNlY3Rpb24gdG8gY2xhaW0gcmlnaHRzIG9yIGNvbnRlc3QKeW91ciBy +aWdodHMgdG8gd29yayB3cml0dGVuIGVudGlyZWx5IGJ5IHlvdTsgcmF0aGVyLCB0aGUgaW50ZW50 +IGlzIHRvCmV4ZXJjaXNlIHRoZSByaWdodCB0byBjb250cm9sIHRoZSBkaXN0cmlidXRpb24gb2Yg +ZGVyaXZhdGl2ZSBvcgpjb2xsZWN0aXZlIHdvcmtzIGJhc2VkIG9uIHRoZSBQcm9ncmFtLgoKSW4g +YWRkaXRpb24sIG1lcmUgYWdncmVnYXRpb24gb2YgYW5vdGhlciB3b3JrIG5vdCBiYXNlZCBvbiB0 +aGUgUHJvZ3JhbQp3aXRoIHRoZSBQcm9ncmFtIChvciB3aXRoIGEgd29yayBiYXNlZCBvbiB0aGUg +UHJvZ3JhbSkgb24gYSB2b2x1bWUgb2YKYSBzdG9yYWdlIG9yIGRpc3RyaWJ1dGlvbiBtZWRpdW0g +ZG9lcyBub3QgYnJpbmcgdGhlIG90aGVyIHdvcmsgdW5kZXIKdGhlIHNjb3BlIG9mIHRoaXMgTGlj +ZW5zZS4KClxpdGVtCllvdSBtYXkgY29weSBhbmQgZGlzdHJpYnV0ZSB0aGUgUHJvZ3JhbSAob3Ig +YSB3b3JrIGJhc2VkIG9uIGl0LAp1bmRlciBTZWN0aW9uIDIpIGluIG9iamVjdCBjb2RlIG9yIGV4 +ZWN1dGFibGUgZm9ybSB1bmRlciB0aGUgdGVybXMgb2YKU2VjdGlvbnMgMSBhbmQgMiBhYm92ZSBw +cm92aWRlZCB0aGF0IHlvdSBhbHNvIGRvIG9uZSBvZiB0aGUgZm9sbG93aW5nOgoKXGJlZ2lue2Vu +dW1lcmF0ZX0KClxpdGVtCgpBY2NvbXBhbnkgaXQgd2l0aCB0aGUgY29tcGxldGUgY29ycmVzcG9u +ZGluZyBtYWNoaW5lLXJlYWRhYmxlCnNvdXJjZSBjb2RlLCB3aGljaCBtdXN0IGJlIGRpc3RyaWJ1 +dGVkIHVuZGVyIHRoZSB0ZXJtcyBvZiBTZWN0aW9ucwoxIGFuZCAyIGFib3ZlIG9uIGEgbWVkaXVt +IGN1c3RvbWFyaWx5IHVzZWQgZm9yIHNvZnR3YXJlIGludGVyY2hhbmdlOyBvciwKClxpdGVtCgpB +Y2NvbXBhbnkgaXQgd2l0aCBhIHdyaXR0ZW4gb2ZmZXIsIHZhbGlkIGZvciBhdCBsZWFzdCB0aHJl +ZQp5ZWFycywgdG8gZ2l2ZSBhbnkgdGhpcmQgcGFydHksIGZvciBhIGNoYXJnZSBubyBtb3JlIHRo +YW4geW91cgpjb3N0IG9mIHBoeXNpY2FsbHkgcGVyZm9ybWluZyBzb3VyY2UgZGlzdHJpYnV0aW9u +LCBhIGNvbXBsZXRlCm1hY2hpbmUtcmVhZGFibGUgY29weSBvZiB0aGUgY29ycmVzcG9uZGluZyBz +b3VyY2UgY29kZSwgdG8gYmUKZGlzdHJpYnV0ZWQgdW5kZXIgdGhlIHRlcm1zIG9mIFNlY3Rpb25z +IDEgYW5kIDIgYWJvdmUgb24gYSBtZWRpdW0KY3VzdG9tYXJpbHkgdXNlZCBmb3Igc29mdHdhcmUg +aW50ZXJjaGFuZ2U7IG9yLAoKXGl0ZW0KCkFjY29tcGFueSBpdCB3aXRoIHRoZSBpbmZvcm1hdGlv +biB5b3UgcmVjZWl2ZWQgYXMgdG8gdGhlIG9mZmVyCnRvIGRpc3RyaWJ1dGUgY29ycmVzcG9uZGlu +ZyBzb3VyY2UgY29kZS4gIChUaGlzIGFsdGVybmF0aXZlIGlzCmFsbG93ZWQgb25seSBmb3Igbm9u +Y29tbWVyY2lhbCBkaXN0cmlidXRpb24gYW5kIG9ubHkgaWYgeW91CnJlY2VpdmVkIHRoZSBwcm9n +cmFtIGluIG9iamVjdCBjb2RlIG9yIGV4ZWN1dGFibGUgZm9ybSB3aXRoIHN1Y2gKYW4gb2ZmZXIs +IGluIGFjY29yZCB3aXRoIFN1YnNlY3Rpb24gYiBhYm92ZS4pCgpcZW5ke2VudW1lcmF0ZX0KCgpU +aGUgc291cmNlIGNvZGUgZm9yIGEgd29yayBtZWFucyB0aGUgcHJlZmVycmVkIGZvcm0gb2YgdGhl +IHdvcmsgZm9yCm1ha2luZyBtb2RpZmljYXRpb25zIHRvIGl0LiAgRm9yIGFuIGV4ZWN1dGFibGUg +d29yaywgY29tcGxldGUgc291cmNlCmNvZGUgbWVhbnMgYWxsIHRoZSBzb3VyY2UgY29kZSBmb3Ig +YWxsIG1vZHVsZXMgaXQgY29udGFpbnMsIHBsdXMgYW55CmFzc29jaWF0ZWQgaW50ZXJmYWNlIGRl +ZmluaXRpb24gZmlsZXMsIHBsdXMgdGhlIHNjcmlwdHMgdXNlZCB0bwpjb250cm9sIGNvbXBpbGF0 +aW9uIGFuZCBpbnN0YWxsYXRpb24gb2YgdGhlIGV4ZWN1dGFibGUuICBIb3dldmVyLCBhcyBhCnNw +ZWNpYWwgZXhjZXB0aW9uLCB0aGUgc291cmNlIGNvZGUgZGlzdHJpYnV0ZWQgbmVlZCBub3QgaW5j +bHVkZQphbnl0aGluZyB0aGF0IGlzIG5vcm1hbGx5IGRpc3RyaWJ1dGVkIChpbiBlaXRoZXIgc291 +cmNlIG9yIGJpbmFyeQpmb3JtKSB3aXRoIHRoZSBtYWpvciBjb21wb25lbnRzIChjb21waWxlciwg +a2VybmVsLCBhbmQgc28gb24pIG9mIHRoZQpvcGVyYXRpbmcgc3lzdGVtIG9uIHdoaWNoIHRoZSBl +eGVjdXRhYmxlIHJ1bnMsIHVubGVzcyB0aGF0IGNvbXBvbmVudAppdHNlbGYgYWNjb21wYW5pZXMg +dGhlIGV4ZWN1dGFibGUuCgpJZiBkaXN0cmlidXRpb24gb2YgZXhlY3V0YWJsZSBvciBvYmplY3Qg +Y29kZSBpcyBtYWRlIGJ5IG9mZmVyaW5nCmFjY2VzcyB0byBjb3B5IGZyb20gYSBkZXNpZ25hdGVk +IHBsYWNlLCB0aGVuIG9mZmVyaW5nIGVxdWl2YWxlbnQKYWNjZXNzIHRvIGNvcHkgdGhlIHNvdXJj +ZSBjb2RlIGZyb20gdGhlIHNhbWUgcGxhY2UgY291bnRzIGFzCmRpc3RyaWJ1dGlvbiBvZiB0aGUg +c291cmNlIGNvZGUsIGV2ZW4gdGhvdWdoIHRoaXJkIHBhcnRpZXMgYXJlIG5vdApjb21wZWxsZWQg +dG8gY29weSB0aGUgc291cmNlIGFsb25nIHdpdGggdGhlIG9iamVjdCBjb2RlLgoKXGl0ZW0KWW91 +IG1heSBub3QgY29weSwgbW9kaWZ5LCBzdWJsaWNlbnNlLCBvciBkaXN0cmlidXRlIHRoZSBQcm9n +cmFtCmV4Y2VwdCBhcyBleHByZXNzbHkgcHJvdmlkZWQgdW5kZXIgdGhpcyBMaWNlbnNlLiAgQW55 +IGF0dGVtcHQKb3RoZXJ3aXNlIHRvIGNvcHksIG1vZGlmeSwgc3VibGljZW5zZSBvciBkaXN0cmli +dXRlIHRoZSBQcm9ncmFtIGlzCnZvaWQsIGFuZCB3aWxsIGF1dG9tYXRpY2FsbHkgdGVybWluYXRl +IHlvdXIgcmlnaHRzIHVuZGVyIHRoaXMgTGljZW5zZS4KSG93ZXZlciwgcGFydGllcyB3aG8gaGF2 +ZSByZWNlaXZlZCBjb3BpZXMsIG9yIHJpZ2h0cywgZnJvbSB5b3UgdW5kZXIKdGhpcyBMaWNlbnNl +IHdpbGwgbm90IGhhdmUgdGhlaXIgbGljZW5zZXMgdGVybWluYXRlZCBzbyBsb25nIGFzIHN1Y2gK +cGFydGllcyByZW1haW4gaW4gZnVsbCBjb21wbGlhbmNlLgoKXGl0ZW0KWW91IGFyZSBub3QgcmVx +dWlyZWQgdG8gYWNjZXB0IHRoaXMgTGljZW5zZSwgc2luY2UgeW91IGhhdmUgbm90CnNpZ25lZCBp +dC4gIEhvd2V2ZXIsIG5vdGhpbmcgZWxzZSBncmFudHMgeW91IHBlcm1pc3Npb24gdG8gbW9kaWZ5 +IG9yCmRpc3RyaWJ1dGUgdGhlIFByb2dyYW0gb3IgaXRzIGRlcml2YXRpdmUgd29ya3MuICBUaGVz +ZSBhY3Rpb25zIGFyZQpwcm9oaWJpdGVkIGJ5IGxhdyBpZiB5b3UgZG8gbm90IGFjY2VwdCB0aGlz +IExpY2Vuc2UuICBUaGVyZWZvcmUsIGJ5Cm1vZGlmeWluZyBvciBkaXN0cmlidXRpbmcgdGhlIFBy +b2dyYW0gKG9yIGFueSB3b3JrIGJhc2VkIG9uIHRoZQpQcm9ncmFtKSwgeW91IGluZGljYXRlIHlv +dXIgYWNjZXB0YW5jZSBvZiB0aGlzIExpY2Vuc2UgdG8gZG8gc28sIGFuZAphbGwgaXRzIHRlcm1z +IGFuZCBjb25kaXRpb25zIGZvciBjb3B5aW5nLCBkaXN0cmlidXRpbmcgb3IgbW9kaWZ5aW5nCnRo +ZSBQcm9ncmFtIG9yIHdvcmtzIGJhc2VkIG9uIGl0LgoKXGl0ZW0KRWFjaCB0aW1lIHlvdSByZWRp +c3RyaWJ1dGUgdGhlIFByb2dyYW0gKG9yIGFueSB3b3JrIGJhc2VkIG9uIHRoZQpQcm9ncmFtKSwg +dGhlIHJlY2lwaWVudCBhdXRvbWF0aWNhbGx5IHJlY2VpdmVzIGEgbGljZW5zZSBmcm9tIHRoZQpv +cmlnaW5hbCBsaWNlbnNvciB0byBjb3B5LCBkaXN0cmlidXRlIG9yIG1vZGlmeSB0aGUgUHJvZ3Jh +bSBzdWJqZWN0IHRvCnRoZXNlIHRlcm1zIGFuZCBjb25kaXRpb25zLiAgWW91IG1heSBub3QgaW1w +b3NlIGFueSBmdXJ0aGVyCnJlc3RyaWN0aW9ucyBvbiB0aGUgcmVjaXBpZW50cycgZXhlcmNpc2Ug +b2YgdGhlIHJpZ2h0cyBncmFudGVkIGhlcmVpbi4KWW91IGFyZSBub3QgcmVzcG9uc2libGUgZm9y +IGVuZm9yY2luZyBjb21wbGlhbmNlIGJ5IHRoaXJkIHBhcnRpZXMgdG8KdGhpcyBMaWNlbnNlLgoK +XGl0ZW0KSWYsIGFzIGEgY29uc2VxdWVuY2Ugb2YgYSBjb3VydCBqdWRnbWVudCBvciBhbGxlZ2F0 +aW9uIG9mIHBhdGVudAppbmZyaW5nZW1lbnQgb3IgZm9yIGFueSBvdGhlciByZWFzb24gKG5vdCBs +aW1pdGVkIHRvIHBhdGVudCBpc3N1ZXMpLApjb25kaXRpb25zIGFyZSBpbXBvc2VkIG9uIHlvdSAo +d2hldGhlciBieSBjb3VydCBvcmRlciwgYWdyZWVtZW50IG9yCm90aGVyd2lzZSkgdGhhdCBjb250 +cmFkaWN0IHRoZSBjb25kaXRpb25zIG9mIHRoaXMgTGljZW5zZSwgdGhleSBkbyBub3QKZXhjdXNl +IHlvdSBmcm9tIHRoZSBjb25kaXRpb25zIG9mIHRoaXMgTGljZW5zZS4gIElmIHlvdSBjYW5ub3QK +ZGlzdHJpYnV0ZSBzbyBhcyB0byBzYXRpc2Z5IHNpbXVsdGFuZW91c2x5IHlvdXIgb2JsaWdhdGlv +bnMgdW5kZXIgdGhpcwpMaWNlbnNlIGFuZCBhbnkgb3RoZXIgcGVydGluZW50IG9ibGlnYXRpb25z +LCB0aGVuIGFzIGEgY29uc2VxdWVuY2UgeW91Cm1heSBub3QgZGlzdHJpYnV0ZSB0aGUgUHJvZ3Jh +bSBhdCBhbGwuICBGb3IgZXhhbXBsZSwgaWYgYSBwYXRlbnQKbGljZW5zZSB3b3VsZCBub3QgcGVy +bWl0IHJveWFsdHktZnJlZSByZWRpc3RyaWJ1dGlvbiBvZiB0aGUgUHJvZ3JhbSBieQphbGwgdGhv +c2Ugd2hvIHJlY2VpdmUgY29waWVzIGRpcmVjdGx5IG9yIGluZGlyZWN0bHkgdGhyb3VnaCB5b3Us +IHRoZW4KdGhlIG9ubHkgd2F5IHlvdSBjb3VsZCBzYXRpc2Z5IGJvdGggaXQgYW5kIHRoaXMgTGlj +ZW5zZSB3b3VsZCBiZSB0bwpyZWZyYWluIGVudGlyZWx5IGZyb20gZGlzdHJpYnV0aW9uIG9mIHRo +ZSBQcm9ncmFtLgoKSWYgYW55IHBvcnRpb24gb2YgdGhpcyBzZWN0aW9uIGlzIGhlbGQgaW52YWxp +ZCBvciB1bmVuZm9yY2VhYmxlIHVuZGVyCmFueSBwYXJ0aWN1bGFyIGNpcmN1bXN0YW5jZSwgdGhl +IGJhbGFuY2Ugb2YgdGhlIHNlY3Rpb24gaXMgaW50ZW5kZWQgdG8KYXBwbHkgYW5kIHRoZSBzZWN0 +aW9uIGFzIGEgd2hvbGUgaXMgaW50ZW5kZWQgdG8gYXBwbHkgaW4gb3RoZXIKY2lyY3Vtc3RhbmNl +cy4KCkl0IGlzIG5vdCB0aGUgcHVycG9zZSBvZiB0aGlzIHNlY3Rpb24gdG8gaW5kdWNlIHlvdSB0 +byBpbmZyaW5nZSBhbnkKcGF0ZW50cyBvciBvdGhlciBwcm9wZXJ0eSByaWdodCBjbGFpbXMgb3Ig +dG8gY29udGVzdCB2YWxpZGl0eSBvZiBhbnkKc3VjaCBjbGFpbXM7IHRoaXMgc2VjdGlvbiBoYXMg +dGhlIHNvbGUgcHVycG9zZSBvZiBwcm90ZWN0aW5nIHRoZQppbnRlZ3JpdHkgb2YgdGhlIGZyZWUg +c29mdHdhcmUgZGlzdHJpYnV0aW9uIHN5c3RlbSwgd2hpY2ggaXMKaW1wbGVtZW50ZWQgYnkgcHVi +bGljIGxpY2Vuc2UgcHJhY3RpY2VzLiAgTWFueSBwZW9wbGUgaGF2ZSBtYWRlCmdlbmVyb3VzIGNv +bnRyaWJ1dGlvbnMgdG8gdGhlIHdpZGUgcmFuZ2Ugb2Ygc29mdHdhcmUgZGlzdHJpYnV0ZWQKdGhy +b3VnaCB0aGF0IHN5c3RlbSBpbiByZWxpYW5jZSBvbiBjb25zaXN0ZW50IGFwcGxpY2F0aW9uIG9m +IHRoYXQKc3lzdGVtOyBpdCBpcyB1cCB0byB0aGUgYXV0aG9yL2Rvbm9yIHRvIGRlY2lkZSBpZiBo +ZSBvciBzaGUgaXMgd2lsbGluZwp0byBkaXN0cmlidXRlIHNvZnR3YXJlIHRocm91Z2ggYW55IG90 +aGVyIHN5c3RlbSBhbmQgYSBsaWNlbnNlZSBjYW5ub3QKaW1wb3NlIHRoYXQgY2hvaWNlLgoKVGhp +cyBzZWN0aW9uIGlzIGludGVuZGVkIHRvIG1ha2UgdGhvcm91Z2hseSBjbGVhciB3aGF0IGlzIGJl +bGlldmVkIHRvCmJlIGEgY29uc2VxdWVuY2Ugb2YgdGhlIHJlc3Qgb2YgdGhpcyBMaWNlbnNlLgoK +XGl0ZW0KSWYgdGhlIGRpc3RyaWJ1dGlvbiBhbmQvb3IgdXNlIG9mIHRoZSBQcm9ncmFtIGlzIHJl +c3RyaWN0ZWQgaW4KY2VydGFpbiBjb3VudHJpZXMgZWl0aGVyIGJ5IHBhdGVudHMgb3IgYnkgY29w +eXJpZ2h0ZWQgaW50ZXJmYWNlcywgdGhlCm9yaWdpbmFsIGNvcHlyaWdodCBob2xkZXIgd2hvIHBs +YWNlcyB0aGUgUHJvZ3JhbSB1bmRlciB0aGlzIExpY2Vuc2UKbWF5IGFkZCBhbiBleHBsaWNpdCBn +ZW9ncmFwaGljYWwgZGlzdHJpYnV0aW9uIGxpbWl0YXRpb24gZXhjbHVkaW5nCnRob3NlIGNvdW50 +cmllcywgc28gdGhhdCBkaXN0cmlidXRpb24gaXMgcGVybWl0dGVkIG9ubHkgaW4gb3IgYW1vbmcK +Y291bnRyaWVzIG5vdCB0aHVzIGV4Y2x1ZGVkLiAgSW4gc3VjaCBjYXNlLCB0aGlzIExpY2Vuc2Ug +aW5jb3Jwb3JhdGVzCnRoZSBsaW1pdGF0aW9uIGFzIGlmIHdyaXR0ZW4gaW4gdGhlIGJvZHkgb2Yg +dGhpcyBMaWNlbnNlLgoKXGl0ZW0KVGhlIEZyZWUgU29mdHdhcmUgRm91bmRhdGlvbiBtYXkgcHVi +bGlzaCByZXZpc2VkIGFuZC9vciBuZXcgdmVyc2lvbnMKb2YgdGhlIEdlbmVyYWwgUHVibGljIExp +Y2Vuc2UgZnJvbSB0aW1lIHRvIHRpbWUuICBTdWNoIG5ldyB2ZXJzaW9ucyB3aWxsCmJlIHNpbWls +YXIgaW4gc3Bpcml0IHRvIHRoZSBwcmVzZW50IHZlcnNpb24sIGJ1dCBtYXkgZGlmZmVyIGluIGRl +dGFpbCB0bwphZGRyZXNzIG5ldyBwcm9ibGVtcyBvciBjb25jZXJucy4KCkVhY2ggdmVyc2lvbiBp +cyBnaXZlbiBhIGRpc3Rpbmd1aXNoaW5nIHZlcnNpb24gbnVtYmVyLiAgSWYgdGhlIFByb2dyYW0K +c3BlY2lmaWVzIGEgdmVyc2lvbiBudW1iZXIgb2YgdGhpcyBMaWNlbnNlIHdoaWNoIGFwcGxpZXMg +dG8gaXQgYW5kIGBgYW55CmxhdGVyIHZlcnNpb24nJywgeW91IGhhdmUgdGhlIG9wdGlvbiBvZiBm +b2xsb3dpbmcgdGhlIHRlcm1zIGFuZCBjb25kaXRpb25zCmVpdGhlciBvZiB0aGF0IHZlcnNpb24g +b3Igb2YgYW55IGxhdGVyIHZlcnNpb24gcHVibGlzaGVkIGJ5IHRoZSBGcmVlClNvZnR3YXJlIEZv +dW5kYXRpb24uICBJZiB0aGUgUHJvZ3JhbSBkb2VzIG5vdCBzcGVjaWZ5IGEgdmVyc2lvbiBudW1i +ZXIgb2YKdGhpcyBMaWNlbnNlLCB5b3UgbWF5IGNob29zZSBhbnkgdmVyc2lvbiBldmVyIHB1Ymxp +c2hlZCBieSB0aGUgRnJlZSBTb2Z0d2FyZQpGb3VuZGF0aW9uLgoKXGl0ZW0KSWYgeW91IHdpc2gg +dG8gaW5jb3Jwb3JhdGUgcGFydHMgb2YgdGhlIFByb2dyYW0gaW50byBvdGhlciBmcmVlCnByb2dy +YW1zIHdob3NlIGRpc3RyaWJ1dGlvbiBjb25kaXRpb25zIGFyZSBkaWZmZXJlbnQsIHdyaXRlIHRv +IHRoZSBhdXRob3IKdG8gYXNrIGZvciBwZXJtaXNzaW9uLiAgRm9yIHNvZnR3YXJlIHdoaWNoIGlz +IGNvcHlyaWdodGVkIGJ5IHRoZSBGcmVlClNvZnR3YXJlIEZvdW5kYXRpb24sIHdyaXRlIHRvIHRo +ZSBGcmVlIFNvZnR3YXJlIEZvdW5kYXRpb247IHdlIHNvbWV0aW1lcwptYWtlIGV4Y2VwdGlvbnMg +Zm9yIHRoaXMuICBPdXIgZGVjaXNpb24gd2lsbCBiZSBndWlkZWQgYnkgdGhlIHR3byBnb2Fscwpv +ZiBwcmVzZXJ2aW5nIHRoZSBmcmVlIHN0YXR1cyBvZiBhbGwgZGVyaXZhdGl2ZXMgb2Ygb3VyIGZy +ZWUgc29mdHdhcmUgYW5kCm9mIHByb21vdGluZyB0aGUgc2hhcmluZyBhbmQgcmV1c2Ugb2Ygc29m +dHdhcmUgZ2VuZXJhbGx5LgoKXGJlZ2lue2NlbnRlcn0Ke1xMYXJnZVxzYwpObyBXYXJyYW50eQp9 +ClxlbmR7Y2VudGVyfQoKXGl0ZW0Ke1xzYyBCZWNhdXNlIHRoZSBwcm9ncmFtIGlzIGxpY2Vuc2Vk +IGZyZWUgb2YgY2hhcmdlLCB0aGVyZSBpcyBubyB3YXJyYW50eQpmb3IgdGhlIHByb2dyYW0sIHRv +IHRoZSBleHRlbnQgcGVybWl0dGVkIGJ5IGFwcGxpY2FibGUgbGF3LiAgRXhjZXB0IHdoZW4Kb3Ro +ZXJ3aXNlIHN0YXRlZCBpbiB3cml0aW5nIHRoZSBjb3B5cmlnaHQgaG9sZGVycyBhbmQvb3Igb3Ro +ZXIgcGFydGllcwpwcm92aWRlIHRoZSBwcm9ncmFtIGBgYXMgaXMnJyB3aXRob3V0IHdhcnJhbnR5 +IG9mIGFueSBraW5kLCBlaXRoZXIgZXhwcmVzc2VkCm9yIGltcGxpZWQsIGluY2x1ZGluZywgYnV0 +IG5vdCBsaW1pdGVkIHRvLCB0aGUgaW1wbGllZCB3YXJyYW50aWVzIG9mCm1lcmNoYW50YWJpbGl0 +eSBhbmQgZml0bmVzcyBmb3IgYSBwYXJ0aWN1bGFyIHB1cnBvc2UuICBUaGUgZW50aXJlIHJpc2sg +YXMKdG8gdGhlIHF1YWxpdHkgYW5kIHBlcmZvcm1hbmNlIG9mIHRoZSBwcm9ncmFtIGlzIHdpdGgg +eW91LiAgU2hvdWxkIHRoZQpwcm9ncmFtIHByb3ZlIGRlZmVjdGl2ZSwgeW91IGFzc3VtZSB0aGUg +Y29zdCBvZiBhbGwgbmVjZXNzYXJ5IHNlcnZpY2luZywKcmVwYWlyIG9yIGNvcnJlY3Rpb24ufQoK +XGl0ZW0Ke1xzYyBJbiBubyBldmVudCB1bmxlc3MgcmVxdWlyZWQgYnkgYXBwbGljYWJsZSBsYXcg +b3IgYWdyZWVkIHRvIGluIHdyaXRpbmcKd2lsbCBhbnkgY29weXJpZ2h0IGhvbGRlciwgb3IgYW55 +IG90aGVyIHBhcnR5IHdobyBtYXkgbW9kaWZ5IGFuZC9vcgpyZWRpc3RyaWJ1dGUgdGhlIHByb2dy +YW0gYXMgcGVybWl0dGVkIGFib3ZlLCBiZSBsaWFibGUgdG8geW91IGZvciBkYW1hZ2VzLAppbmNs +dWRpbmcgYW55IGdlbmVyYWwsIHNwZWNpYWwsIGluY2lkZW50YWwgb3IgY29uc2VxdWVudGlhbCBk +YW1hZ2VzIGFyaXNpbmcKb3V0IG9mIHRoZSB1c2Ugb3IgaW5hYmlsaXR5IHRvIHVzZSB0aGUgcHJv +Z3JhbSAoaW5jbHVkaW5nIGJ1dCBub3QgbGltaXRlZAp0byBsb3NzIG9mIGRhdGEgb3IgZGF0YSBi +ZWluZyByZW5kZXJlZCBpbmFjY3VyYXRlIG9yIGxvc3NlcyBzdXN0YWluZWQgYnkKeW91IG9yIHRo +aXJkIHBhcnRpZXMgb3IgYSBmYWlsdXJlIG9mIHRoZSBwcm9ncmFtIHRvIG9wZXJhdGUgd2l0aCBh +bnkgb3RoZXIKcHJvZ3JhbXMpLCBldmVuIGlmIHN1Y2ggaG9sZGVyIG9yIG90aGVyIHBhcnR5IGhh +cyBiZWVuIGFkdmlzZWQgb2YgdGhlCnBvc3NpYmlsaXR5IG9mIHN1Y2ggZGFtYWdlcy59CgpcZW5k +e2VudW1lcmF0ZX0KCgpcYmVnaW57Y2VudGVyfQp7XExhcmdlXHNjIEVuZCBvZiBUZXJtcyBhbmQg +Q29uZGl0aW9uc30KXGVuZHtjZW50ZXJ9CgoKXHBhZ2VicmVha1syXQoKXHNlY3Rpb24qe0FwcGVu +ZGl4OiBIb3cgdG8gQXBwbHkgVGhlc2UgVGVybXMgdG8gWW91ciBOZXcgUHJvZ3JhbXN9CgpJZiB5 +b3UgZGV2ZWxvcCBhIG5ldyBwcm9ncmFtLCBhbmQgeW91IHdhbnQgaXQgdG8gYmUgb2YgdGhlIGdy +ZWF0ZXN0CnBvc3NpYmxlIHVzZSB0byB0aGUgcHVibGljLCB0aGUgYmVzdCB3YXkgdG8gYWNoaWV2 +ZSB0aGlzIGlzIHRvIG1ha2UgaXQKZnJlZSBzb2Z0d2FyZSB3aGljaCBldmVyeW9uZSBjYW4gcmVk +aXN0cmlidXRlIGFuZCBjaGFuZ2UgdW5kZXIgdGhlc2UKdGVybXMuCgogIFRvIGRvIHNvLCBhdHRh +Y2ggdGhlIGZvbGxvd2luZyBub3RpY2VzIHRvIHRoZSBwcm9ncmFtLiAgSXQgaXMgc2FmZXN0IHRv +CiAgYXR0YWNoIHRoZW0gdG8gdGhlIHN0YXJ0IG9mIGVhY2ggc291cmNlIGZpbGUgdG8gbW9zdCBl +ZmZlY3RpdmVseSBjb252ZXkKICB0aGUgZXhjbHVzaW9uIG9mIHdhcnJhbnR5OyBhbmQgZWFjaCBm +aWxlIHNob3VsZCBoYXZlIGF0IGxlYXN0IHRoZQogIGBgY29weXJpZ2h0JycgbGluZSBhbmQgYSBw +b2ludGVyIHRvIHdoZXJlIHRoZSBmdWxsIG5vdGljZSBpcyBmb3VuZC4KClxiZWdpbntxdW90ZX0K +b25lIGxpbmUgdG8gZ2l2ZSB0aGUgcHJvZ3JhbSdzIG5hbWUgYW5kIGEgYnJpZWYgaWRlYSBvZiB3 +aGF0IGl0IGRvZXMuIFxcCkNvcHlyaWdodCAoQykgeXl5eSAgbmFtZSBvZiBhdXRob3IgXFwKClRo +aXMgcHJvZ3JhbSBpcyBmcmVlIHNvZnR3YXJlOyB5b3UgY2FuIHJlZGlzdHJpYnV0ZSBpdCBhbmQv +b3IgbW9kaWZ5Cml0IHVuZGVyIHRoZSB0ZXJtcyBvZiB0aGUgR05VIEdlbmVyYWwgUHVibGljIExp +Y2Vuc2UgYXMgcHVibGlzaGVkIGJ5CnRoZSBGcmVlIFNvZnR3YXJlIEZvdW5kYXRpb247IGVpdGhl +ciB2ZXJzaW9uIDIgb2YgdGhlIExpY2Vuc2UsIG9yCihhdCB5b3VyIG9wdGlvbikgYW55IGxhdGVy +IHZlcnNpb24uCgpUaGlzIHByb2dyYW0gaXMgZGlzdHJpYnV0ZWQgaW4gdGhlIGhvcGUgdGhhdCBp +dCB3aWxsIGJlIHVzZWZ1bCwKYnV0IFdJVEhPVVQgQU5ZIFdBUlJBTlRZOyB3aXRob3V0IGV2ZW4g +dGhlIGltcGxpZWQgd2FycmFudHkgb2YKTUVSQ0hBTlRBQklMSVRZIG9yIEZJVE5FU1MgRk9SIEEg +UEFSVElDVUxBUiBQVVJQT1NFLiAgU2VlIHRoZQpHTlUgR2VuZXJhbCBQdWJsaWMgTGljZW5zZSBm +b3IgbW9yZSBkZXRhaWxzLgoKWW91IHNob3VsZCBoYXZlIHJlY2VpdmVkIGEgY29weSBvZiB0aGUg +R05VIEdlbmVyYWwgUHVibGljIExpY2Vuc2UKYWxvbmcgd2l0aCB0aGlzIHByb2dyYW07IGlmIG5v +dCwgd3JpdGUgdG8gdGhlIEZyZWUgU29mdHdhcmUKRm91bmRhdGlvbiwgSW5jLiwgNTkgVGVtcGxl +IFBsYWNlIC0gU3VpdGUgMzMwLCBCb3N0b24sIE1BICAwMjExMS0xMzA3LCBVU0EuClxlbmR7cXVv +dGV9CgpBbHNvIGFkZCBpbmZvcm1hdGlvbiBvbiBob3cgdG8gY29udGFjdCB5b3UgYnkgZWxlY3Ry +b25pYyBhbmQgcGFwZXIgbWFpbC4KCklmIHRoZSBwcm9ncmFtIGlzIGludGVyYWN0aXZlLCBtYWtl +IGl0IG91dHB1dCBhIHNob3J0IG5vdGljZSBsaWtlIHRoaXMKd2hlbiBpdCBzdGFydHMgaW4gYW4g +aW50ZXJhY3RpdmUgbW9kZToKClxiZWdpbntxdW90ZX0KR25vbW92aXNpb24gdmVyc2lvbiA2OSwg +Q29weXJpZ2h0IChDKSB5eXl5ICBuYW1lIG9mIGF1dGhvciBcXApHbm9tb3Zpc2lvbiBjb21lcyB3 +aXRoIEFCU09MVVRFTFkgTk8gV0FSUkFOVFk7IGZvciBkZXRhaWxzIHR5cGUgYHNob3cgdycuIFxc +ClRoaXMgaXMgZnJlZSBzb2Z0d2FyZSwgYW5kIHlvdSBhcmUgd2VsY29tZSB0byByZWRpc3RyaWJ1 +dGUgaXQKdW5kZXIgY2VydGFpbiBjb25kaXRpb25zOyB0eXBlIGBzaG93IGMnIGZvciBkZXRhaWxz +LgpcZW5ke3F1b3RlfQoKClRoZSBoeXBvdGhldGljYWwgY29tbWFuZHMge1x0dCBzaG93IHd9IGFu +ZCB7XHR0IHNob3cgY30gc2hvdWxkIHNob3cgdGhlCmFwcHJvcHJpYXRlIHBhcnRzIG9mIHRoZSBH +ZW5lcmFsIFB1YmxpYyBMaWNlbnNlLiAgT2YgY291cnNlLCB0aGUgY29tbWFuZHMKeW91IHVzZSBt +YXkgYmUgY2FsbGVkIHNvbWV0aGluZyBvdGhlciB0aGFuIHtcdHQgc2hvdyB3fSBhbmQge1x0dCBz +aG93IGN9Owp0aGV5IGNvdWxkIGV2ZW4gYmUgbW91c2UtY2xpY2tzIG9yIG1lbnUgaXRlbXMtLS13 +aGF0ZXZlciBzdWl0cyB5b3VyCnByb2dyYW0uCgpZb3Ugc2hvdWxkIGFsc28gZ2V0IHlvdXIgZW1w +bG95ZXIgKGlmIHlvdSB3b3JrIGFzIGEgcHJvZ3JhbW1lcikgb3IgeW91cgpzY2hvb2wsIGlmIGFu +eSwgdG8gc2lnbiBhIGBgY29weXJpZ2h0IGRpc2NsYWltZXInJyBmb3IgdGhlIHByb2dyYW0sIGlm +Cm5lY2Vzc2FyeS4gIEhlcmUgaXMgYSBzYW1wbGU7IGFsdGVyIHRoZSBuYW1lczoKClxiZWdpbntx +dW90ZX0KWW95b2R5bmUsIEluYy4sIGhlcmVieSBkaXNjbGFpbXMgYWxsIGNvcHlyaWdodCBpbnRl +cmVzdCBpbiB0aGUgcHJvZ3JhbSBcXApgR25vbW92aXNpb24nICh3aGljaCBtYWtlcyBwYXNzZXMg +YXQgY29tcGlsZXJzKSB3cml0dGVuIGJ5IEphbWVzIEhhY2tlci4gXFwKCnNpZ25hdHVyZSBvZiBU +eSBDb29uLCAxIEFwcmlsIDE5ODkgXFwKVHkgQ29vbiwgUHJlc2lkZW50IG9mIFZpY2UKXGVuZHtx +dW90ZX0KCgpUaGlzIEdlbmVyYWwgUHVibGljIExpY2Vuc2UgZG9lcyBub3QgcGVybWl0IGluY29y +cG9yYXRpbmcgeW91ciBwcm9ncmFtCmludG8gcHJvcHJpZXRhcnkgcHJvZ3JhbXMuICBJZiB5b3Vy +IHByb2dyYW0gaXMgYSBzdWJyb3V0aW5lIGxpYnJhcnksIHlvdQptYXkgY29uc2lkZXIgaXQgbW9y +ZSB1c2VmdWwgdG8gcGVybWl0IGxpbmtpbmcgcHJvcHJpZXRhcnkgYXBwbGljYXRpb25zCndpdGgg +dGhlIGxpYnJhcnkuICBJZiB0aGlzIGlzIHdoYXQgeW91IHdhbnQgdG8gZG8sIHVzZSB0aGUgR05V +IExpYnJhcnkKR2VuZXJhbCBQdWJsaWMgTGljZW5zZSBpbnN0ZWFkIG9mIHRoaXMgTGljZW5zZS4K +Cgo= +" ++ Glurf ++ lists:reverse(Glurf++"kalle"). diff --git a/lib/compiler/test/compilation_SUITE_data/nested_tuples_in_case_expr.erl b/lib/compiler/test/compilation_SUITE_data/nested_tuples_in_case_expr.erl new file mode 100644 index 0000000000..62402c10b7 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/nested_tuples_in_case_expr.erl @@ -0,0 +1,36 @@ +%% +%% %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% +%% +-module(nested_tuples_in_case_expr). +-export([nested_tuples_in_case_expr/0,t/2]). + +nested_tuples_in_case_expr() -> + ok. + +t(A, B) -> + case {{element(1, A),element(2, B)},{element(2, A),element(2, B)}} of + {Same,Same} -> ok; + {{0,1},{up,X}} -> bar(X); + {_,{X,_}} -> bar(X) + end. + +bar(X) -> X. + + + + diff --git a/lib/compiler/test/compilation_SUITE_data/on_load.erl b/lib/compiler/test/compilation_SUITE_data/on_load.erl new file mode 100644 index 0000000000..92bcf74624 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/on_load.erl @@ -0,0 +1,18 @@ +-module(on_load). +-export([?MODULE/0]). + +-on_load(do_on_load/0). + +%% Only test that the compiler is able to compile a module +%% with an on_load attribute. (There will be more thorough tests +%% of the functionality in code_SUITE in the Kernel application.) + +?MODULE() -> + ok. + +do_on_load() -> + local_function(), + true. + +local_function() -> + ok. diff --git a/lib/compiler/test/compilation_SUITE_data/opt_crash.erl b/lib/compiler/test/compilation_SUITE_data/opt_crash.erl new file mode 100644 index 0000000000..3a1d625c28 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/opt_crash.erl @@ -0,0 +1,65 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2005-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(opt_crash). +-export([?MODULE/0,test/0]). + +?MODULE() -> + ok. + +test() -> + URI_Before = + {absoluteURI, + {scheme,fun() -> nil end}, + {'hier-part', + {'net-path', + {srvr, + {userinfo,nil}, + fun() -> nil end}, + nil}, + {'query',nil}}}, + + {absoluteURI, + {scheme,_}, + {'hier-part', + {'net-path', + {srvr, + {userinfo,nil}, + HostportBefore}, + nil}, + {'query',nil}}} = URI_Before, + + %% ... some funky code ommitted, not relevant ... + + {absoluteURI, + {scheme,_}, + {'hier-part', + {'net-path', + {srvr, + {userinfo,nil}, + HostportAfter}, + nil}, + {'query',nil}}} = URI_Before, + %% NOTE: I intended to write URI_After instead of URI_Before + %% but the accident revealed that when you add the line below, + %% it causes internal error in v3_codegen on compilation + {hostport,{hostname,"HostName"},{port,nil}} = HostportAfter, + + ok. + + diff --git a/lib/compiler/test/compilation_SUITE_data/other/vsn_1.erl b/lib/compiler/test/compilation_SUITE_data/other/vsn_1.erl new file mode 100644 index 0000000000..7cb0778b95 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/other/vsn_1.erl @@ -0,0 +1,19 @@ +%% +%% %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% +%% +-module(vsn_1). diff --git a/lib/compiler/test/compilation_SUITE_data/other/vsn_3.erl b/lib/compiler/test/compilation_SUITE_data/other/vsn_3.erl new file mode 100644 index 0000000000..3870e0704d --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/other/vsn_3.erl @@ -0,0 +1,24 @@ +%% +%% %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% +%% +-module(vsn_3). + +-export([f/1]). + +f(X) -> + 2*X. diff --git a/lib/compiler/test/compilation_SUITE_data/otp_2141.erl b/lib/compiler/test/compilation_SUITE_data/otp_2141.erl new file mode 100644 index 0000000000..3e766546be --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_2141.erl @@ -0,0 +1,24 @@ +%% +%% %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% +%% +-module(otp_2141). +-export([otp_2141/0]). + + +otp_2141() -> + ok. diff --git a/lib/compiler/test/compilation_SUITE_data/otp_2173.erl b/lib/compiler/test/compilation_SUITE_data/otp_2173.erl new file mode 100644 index 0000000000..7e9d4c417b --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_2173.erl @@ -0,0 +1,31 @@ +%% +%% %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% +%% +-module(otp_2173). +-compile(export_all). + +-record(t, {a = fun(X) -> X*X end}). + +otp_2173() -> + ok. + +t() -> + #t{}. + + + diff --git a/lib/compiler/test/compilation_SUITE_data/otp_2330.erl b/lib/compiler/test/compilation_SUITE_data/otp_2330.erl new file mode 100644 index 0000000000..f5f6717968 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_2330.erl @@ -0,0 +1,35 @@ +%% +%% %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% +%% +-module(otp_2330). +-export([otp_2330/0, handle_interface/1]). + +otp_2330() -> + ok. + +handle_interface(Data)-> + Ctrl = 1, + case Data of + ok -> + case Ctrl of + [Viar]->integer_to_list(Viar); + _ -> [] + + end + end. + diff --git a/lib/compiler/test/compilation_SUITE_data/otp_2380.erl b/lib/compiler/test/compilation_SUITE_data/otp_2380.erl new file mode 100644 index 0000000000..db2028b347 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_2380.erl @@ -0,0 +1,36 @@ +%% +%% %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% +%% +-module(otp_2380). +-export([test/0, otp_2380/0]). + +otp_2380() -> + ok. + +-define(FUNC(Name), + case Name of + dpCh -> 5; + dpEvent -> 1; + dpc -> 4; + dpFm -> 6; + dpFm1 -> 6; + _ -> false + end). + +test() -> + N = ?FUNC(dpCh). diff --git a/lib/compiler/test/compilation_SUITE_data/otp_4790.erl b/lib/compiler/test/compilation_SUITE_data/otp_4790.erl new file mode 100644 index 0000000000..130ee44e80 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_4790.erl @@ -0,0 +1,63 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2003-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +-module(otp_4790). + +-export([?MODULE/0]). + +?MODULE() -> + pan_test(). + + +% --------------------------- OTP Ticket -------------------------------- +% *Id: OTP-4790 +% *Notes: In the code below, the compiler incorrectly assumes +% wings_pref:get_value(pan_speed) returns a float, +% causing a crash at run-time. + +% The same error could cause tuple tests to be removed, +% but that would propbably only cause a crash if the +% Erlang code was incorrect or if it depended on a catch +% to catch exceptions. Therefore, I consider it unlikely +% that Erlang programs that don't use floating point +% arithmetic are likely to be bitten by this bug. +% ----------------------------------------------------------------------- + +-record(view, {pan_x,pan_y,distance}). + +pan_test() -> + pan(13, 3). + +pan(Dx0, Dy0) -> + #view{pan_x=PanX0,pan_y=PanY0,distance=D} = View = current(), + S = D*(1/8)/(51-pref_get_value(pan_speed)), + Dx = Dx0*S, + Dy = Dy0*S, + PanX = PanX0 + Dx, + PanY = PanY0 - Dy, + set_current(View#view{pan_x=PanX,pan_y=PanY}). + +current() -> + #view{pan_x=2.0,pan_y=9.75,distance=25.3}. + +set_current(#view{pan_x=X,pan_y=Y,distance=D}) + when is_float(X), is_float(Y), is_float(D) -> + io:format("X=~p Y=~p D=~p\n", [X,Y,D]). + +pref_get_value(pan_speed) -> + 32. diff --git a/lib/compiler/test/compilation_SUITE_data/otp_5076.erl b/lib/compiler/test/compilation_SUITE_data/otp_5076.erl new file mode 100644 index 0000000000..f05a4e1148 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_5076.erl @@ -0,0 +1,27 @@ +%% +%% %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(otp_5076). +-export([?MODULE/0]). + +?MODULE() -> + [] = t(), + ok. + +t() -> + [3 || {3=4} <- []]. diff --git a/lib/compiler/test/compilation_SUITE_data/otp_5092.erl b/lib/compiler/test/compilation_SUITE_data/otp_5092.erl new file mode 100644 index 0000000000..e445e5e1e9 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_5092.erl @@ -0,0 +1,39 @@ +%% +%% %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(otp_5092). +-export([?MODULE/0]). + +?MODULE() -> + [] = t(), + [] = t2(), + [t] = t4(), + [] = t5(), + ok. + +t() -> + [t || {C=D}={_,_} <- []]. + +t2() -> + [X || {X,{Y}={X,X}} <- []]. + +t4() -> + [t || "a"++"b" = "ab" <- ["ab"]]. + +t5() -> + [{X,Y} || {X} <- [], begin Y = X, Y =:= X end]. diff --git a/lib/compiler/test/compilation_SUITE_data/otp_5151.erl b/lib/compiler/test/compilation_SUITE_data/otp_5151.erl new file mode 100644 index 0000000000..2dccb979df --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_5151.erl @@ -0,0 +1,61 @@ +%% +%% %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(otp_5151). + +-export([?MODULE/0]). +-export([read_variables/1,read_variables_1/1,read_variables_2/1, + read_variables_3/1,read_variables_4/1]). + +?MODULE() -> + ok. + +read_variables(Name) -> + case file:consult(Name) of + {ok,Vars} -> Vars; + {error,Reason} -> + erlang:error({bad_installation,file:format_error(Reason)}, [Name]) + end. + +read_variables_1(Name) -> + case file:consult(Name) of + {ok,Vars} -> Vars; + {error,Reason} -> + erlang:error({bad_installation,file:format_error(Reason)}) + end. + +read_variables_2(Name) -> + case file:consult(Name) of + {ok,Vars} -> Vars; + {error,Reason} -> + erlang:error({bad_installation,file:format_error(Reason)}, [Name]) + end. + +read_variables_3(Name) -> + case file:consult(Name) of + {ok,Vars} -> Vars; + {error,Reason} -> + erlang:error({bad_installation,file:format_error(Reason)}) + end. + +read_variables_4(Name) -> + case file:consult(Name) of + {ok,Vars} -> Vars; + {error,Reason} -> + exit({bad_installation,file:format_error(Reason)}) + end. diff --git a/lib/compiler/test/compilation_SUITE_data/otp_5235.erl b/lib/compiler/test/compilation_SUITE_data/otp_5235.erl new file mode 100644 index 0000000000..1c918cdf9d --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_5235.erl @@ -0,0 +1,84 @@ +%% +%% %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(otp_5235). +-export([?MODULE/0]). + +-record(commit, {node, + decision, % presume_commit | Decision + ram_copies = [], + disc_copies = [], + disc_only_copies = [], + snmp = [], + schema_ops = [self(),make_ref()] + }). + +?MODULE() -> + process_flag(trap_exit, true), + N = 1024, + clone(N), + wait(N). + +wait(0) -> ok; +wait(N) -> + receive + {'EXIT',_,normal} -> + wait(N-1); + Other -> + exit(Other) + end. + +clone(0) -> ok; +clone(N) -> + spawn_link(fun worker/0), + clone(N-1). + +worker() -> + Seq = lists:seq(1, 10), + PidList = [{N,self()} || N <- Seq], + Commit = #commit{ram_copies=PidList,disc_copies=[], + disc_only_copies=[],snmp=[]}, + List = lists:duplicate(2, Commit), + verify(run(2, List)). + +verify([#commit{node=true,ram_copies=L}|T]) -> + verify_1(L, 1), + verify(T); +verify([]) -> ok. + +verify_1([{N,Pid}|T], N) when Pid =:= self() -> + verify_1(T, N+1); +verify_1([], _) -> ok. + +run(0, L) -> L; +run(N, L) -> run(N-1, reverse(L)). + +reverse([]) -> []; +reverse([H|R]) when record(H, commit) -> + [H#commit{ + ram_copies = lists:reverse(H#commit.ram_copies), + disc_copies = lists:reverse(H#commit.disc_copies), + disc_only_copies = lists:reverse(H#commit.disc_only_copies), + snmp = lists:reverse(H#commit.snmp), + node = erlang:yield() + } + | reverse(R)]. + + + + diff --git a/lib/compiler/test/compilation_SUITE_data/otp_5244.erl b/lib/compiler/test/compilation_SUITE_data/otp_5244.erl new file mode 100644 index 0000000000..30849c6b5e --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_5244.erl @@ -0,0 +1,47 @@ +%% +%% %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(otp_5244). +-export([?MODULE/0]). + +?MODULE() -> + L = [{stretch,0,0}, + {bad,[]}, + {bad,atom}, + {bad,0}, + {bad,16#AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA}, + {bad,16#555555555555555555555555555555555555555555555555555}], + remove_failure(L, unit, 0). + +remove_failure([], _Unit, _MaxFailure) -> + ok; +remove_failure([{bad,Bad}|_], _Unit, _MaxFailure) -> + Bad; +remove_failure([{stretch,_,Mi}=Stretch | Specs], Unit, _MaxFailure) -> + {MinMax,NewMaxFailure} = max_failure(), + case {MinMax,remove_failure(Specs, Unit, NewMaxFailure)} of + {min,{NewMaxFailure,Rest}} -> + {done,[{fixed,Mi} | Rest]}; + {min,_} when Specs =/= [] -> + remove_failure([Stretch|tl(Specs)], Unit, NewMaxFailure); + {min,_} -> + ok + end. + +max_failure() -> + {min,1}. diff --git a/lib/compiler/test/compilation_SUITE_data/otp_5404.erl b/lib/compiler/test/compilation_SUITE_data/otp_5404.erl new file mode 100644 index 0000000000..2de147c082 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_5404.erl @@ -0,0 +1,51 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2005-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(otp_5404). +-compile(export_all). + +%% Thanks to Martin Bjorklund. + +?MODULE() -> + ok. + +-record(bar, {status, vs = []}). + +y() -> + x({foo, 1, []}). + +get_bar() -> + #bar{status = 1}. + +x(Trans) -> + {foo, Barno, _} = Trans, + case get_bar() of + Bar when Bar#bar.status /= 2 -> + if 1 == 1 -> + mnesia:dirty_delete({bar, Barno}), + Vs = [1,2] ++ Bar#bar.vs, + Bar33 = Bar#bar{status = 1}, + Bar1 = Bar#bar{status = 3, + vs = Vs}, + [{payment, Barno}]; + true -> + Barno + end; + _ -> + Trans + end. diff --git a/lib/compiler/test/compilation_SUITE_data/otp_5436.erl b/lib/compiler/test/compilation_SUITE_data/otp_5436.erl new file mode 100644 index 0000000000..4df8d50647 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_5436.erl @@ -0,0 +1,201 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2005-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(otp_5436). +-compile(export_all). + +?MODULE() -> + ok. + +-record(readerState, {action_index, + log_index, + log_name, + time_period, + rec_id_period, + result_format, + action_status, + filter_type, + event_list, + sender_list, + read_status}). + +handle_call(delete,_From,State) -> + case catch debug:filter(console,logReader) of + true -> + case io:format([io_lib:format("~nSYS_DBG {~p,~p,~p}, ~w ~s:~n-- ",[logReader,306,console,self(),sysAssert:format_time2(erlang:now())])|"delete, State: ~p ~n"],[State]) of + ok -> + ok; + _ -> + io:format("*** Bad format (~p, ~p) ***~n",["delete, State: ~p ~n",[State]]), + ok + end; + false -> + disabled; + {'EXIT',{undef,_}} -> + case io:format([io_lib:format("~nSYS_DBG {~p,~p,~p}, ~w ~s:~n-- ",[logReader,306,console,self(),sysAssert:format_time2(erlang:now())])|"delete, State: ~p ~n"],[State]) of + ok -> + ok; + _ -> + io:format("*** Bad format (~p, ~p) ***~n",["delete, State: ~p ~n",[State]]), + ok + end; + {'EXIT',_} -> + debug:filter(console,logReader); + _ -> + exit({badmatch,{{debug,filter,[console,logReader]},debug:filter(console,logReader)}}) + end, + ?MODULE:clean_result(State), + {stop,normal,ok,State}; +handle_call(die,_,State) -> + {stop,normal,ok,State}; +handle_call(_Action,_From,#readerState{action_status = 2} = State) -> + {reply,error,State}; +handle_call(update_action_attr,_From,State) -> + NewState = ?MODULE:handle_update_action_attr(State), + case catch debug:filter(console,logReader) of + true -> + case io:format([io_lib:format("~nSYS_DBG {~p,~p,~p}, ~w ~s:~n-- ",[logReader,317,console,self(),sysAssert:format_time2(erlang:now())])|"update_action_attr, State: ~p ~n"],[NewState]) of + ok -> + ok; + _ -> + io:format("*** Bad format (~p, ~p) ***~n",["update_action_attr, State: ~p ~n",[NewState]]), + ok + end; + false -> + disabled; + {'EXIT',{undef,_}} -> + case io:format([io_lib:format("~nSYS_DBG {~p,~p,~p}, ~w ~s:~n-- ",[logReader,317,console,self(),sysAssert:format_time2(erlang:now())])|"update_action_attr, State: ~p ~n"],[NewState]) of + ok -> + ok; + _ -> + io:format("*** Bad format (~p, ~p) ***~n",["update_action_attr, State: ~p ~n",[NewState]]), + ok + end; + {'EXIT',_} -> + debug:filter(console,logReader); + _ -> + exit({badmatch,{{debug,filter,[console,logReader]},debug:filter(console,logReader)}}) + end, + {reply,ok,NewState}; +handle_call(update_event_filter,_From,State) -> + NewState = State#readerState{event_list = ?MODULE:get_event_list(State#readerState.action_index)}, + case catch debug:filter(console,logReader) of + true -> + case io:format([io_lib:format("~nSYS_DBG {~p,~p,~p}, ~w ~s:~n-- ",[logReader,323,console,self(),sysAssert:format_time2(erlang:now())])|"update_event_filter, State: ~p ~n"],[NewState]) of + ok -> + ok; + _ -> + io:format("*** Bad format (~p, ~p) ***~n",["update_event_filter, State: ~p ~n",[NewState]]), + ok + end; + false -> + disabled; + {'EXIT',{undef,_}} -> + case io:format([io_lib:format("~nSYS_DBG {~p,~p,~p}, ~w ~s:~n-- ",[logReader,323,console,self(),sysAssert:format_time2(erlang:now())])|"update_event_filter, State: ~p ~n"],[NewState]) of + ok -> + ok; + _ -> + io:format("*** Bad format (~p, ~p) ***~n",["update_event_filter, State: ~p ~n",[NewState]]), + ok + end; + {'EXIT',_} -> + debug:filter(console,logReader); + _ -> + exit({badmatch,{{debug,filter,[console,logReader]},debug:filter(console,logReader)}}) + end, + {reply,ok,NewState}; +handle_call(update_sender_filter,_From,State) -> + NewState = State#readerState{sender_list = ?MODULE:get_sender_list(State#readerState.action_index)}, + case catch debug:filter(console,logReader) of + true -> + case io:format([io_lib:format("~nSYS_DBG {~p,~p,~p}, ~w ~s:~n-- ",[logReader,329,console,self(),sysAssert:format_time2(erlang:now())])|"update_sender_filter, State: ~p ~n"],[NewState]) of + ok -> + ok; + _ -> + io:format("*** Bad format (~p, ~p) ***~n",["update_sender_filter, State: ~p ~n",[NewState]]), + ok + end; + false -> + disabled; + {'EXIT',{undef,_}} -> + case io:format([io_lib:format("~nSYS_DBG {~p,~p,~p}, ~w ~s:~n-- ",[logReader,329,console,self(),sysAssert:format_time2(erlang:now())])|"update_sender_filter, State: ~p ~n"],[NewState]) of + ok -> + ok; + _ -> + io:format("*** Bad format (~p, ~p) ***~n",["update_sender_filter, State: ~p ~n",[NewState]]), + ok + end; + {'EXIT',_} -> + debug:filter(console,logReader); + _ -> + exit({badmatch,{{debug,filter,[console,logReader]},debug:filter(console,logReader)}}) + end, + {reply,ok,NewState}; +handle_call(Request,_From,State) -> + case catch debug:filter(console,logReader) of + true -> + case io:format([io_lib:format("~nSYS_DBG {~p,~p,~p}, ~w ~s:~n-- ",[logReader,332,console,self(),sysAssert:format_time2(erlang:now())])|"Call ~p, State: ~p ~n"],[Request,State]) of + ok -> + ok; + _ -> + io:format("*** Bad format (~p, ~p) ***~n",["Call ~p, State: ~p ~n",[Request,State]]), + ok + end; + false -> + disabled; + {'EXIT',{undef,_}} -> + case io:format([io_lib:format("~nSYS_DBG {~p,~p,~p}, ~w ~s:~n-- ",[logReader,332,console,self(),sysAssert:format_time2(erlang:now())])|"Call ~p, State: ~p ~n"],[Request,State]) of + ok -> + ok; + _ -> + io:format("*** Bad format (~p, ~p) ***~n",["Call ~p, State: ~p ~n",[Request,State]]), + ok + end; + {'EXIT',_} -> + debug:filter(console,logReader); + _ -> + exit({badmatch,{{debug,filter,[console,logReader]},debug:filter(console,logReader)}}) + end, + {stop,{error,unknown,Request},State}. + +handle_info(Request,State) -> + case catch debug:filter(readlog,logReader) of + true -> + case io:format([io_lib:format("~nSYS_DBG {~p,~p,~p}, ~w ~s:~n-- ",[logReader,345,readlog,self(),sysAssert:format_time2(erlang:now())])|"Info ~p, State: ~p ~n"],[Request,State]) of + ok -> + ok; + _ -> + io:format("*** Bad format (~p, ~p) ***~n",["Info ~p, State: ~p ~n",[Request,State]]), + ok + end; + false -> + disabled; + {'EXIT',{undef,_}} -> + case io:format([io_lib:format("~nSYS_DBG {~p,~p,~p}, ~w ~s:~n-- ",[logReader,345,readlog,self(),sysAssert:format_time2(erlang:now())])|"Info ~p, State: ~p ~n"],[Request,State]) of + ok -> + ok; + _ -> + io:format("*** Bad format (~p, ~p) ***~n",["Info ~p, State: ~p ~n",[Request,State]]), + ok + end; + {'EXIT',_} -> + debug:filter(readlog,logReader); + _ -> + exit({badmatch,{{debug,filter,[readlog,logReader]},debug:filter(readlog,logReader)}}) + end, + {stop,{error,unknown,Request},State}. diff --git a/lib/compiler/test/compilation_SUITE_data/otp_5481.erl b/lib/compiler/test/compilation_SUITE_data/otp_5481.erl new file mode 100644 index 0000000000..5cf114ac4e --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_5481.erl @@ -0,0 +1,527 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2005-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(otp_5481). + +-export([?MODULE/0,encode_cc_clpn/1,get_oper_status/2,foo/0]). + +?MODULE() -> + ok. + +-record(pchVp, {vplEntry, + vplLastChange, + vplReceiveTrafficDescrIndex = 0, + vplTransmitTrafficDescrIndex = 0, + vplConnId, + vplGroupShapingId}). + +-record(pchVc, {vclEntry, + vclLastChange, + vplConnId, + vclConnId, + vclShapingMode = 1}). +-record(spvcVpc, {spvcVpcEntry, + currentState, + spvcRerCap = false, + spvcRerStatus = false}). +-record(spvcVpcPerm, {spvcVpcEntry, + spvcVpcTargetAddress, + spvcVpcTargetSelectType, + spvcVpcUserName, + spvcVpcProviderName, + spvcVpcApplication}). +-record(spvcVcc, {spvcVccEntry, + spvcVccTargetAddress, + spvcVccTargetSelectType, + spvcVccTargetVpi, + spvcVccApplication, + spvcVccFrKey, + spvcVccTranslationMode, + spvcRerCap = false, + currentState, + spvcRerStatus = false}). +-record(spvcVccPerm, {spvcVccEntry, + spvcVccTargetAddress, + spvcVccTargetSelectType, + spvcVccTargetVpi, + spvcVccTargetType, + spvcVccApplication, + spvcVccFrKey, + spvcVccTranslationMode = 2}). +-record(spvcObj, {spvcEntry, + spvcTargetAddress, + spvcTargetSelectType, + spvcTargetVpi, + spvcTargetVci, + spvcLastReleaseCause, + spvcLastReleaseDiagnostic, + spvcRetryInterval = 1000, + spvcRetryTimer = 0, + spvcRetryThreshold = 1, + spvcRetryFailures = 0, + spvcRetryLimit = 15, + spvcFrKey, + spvcVccTranslationMode = 2, + spvcRerCap = false, + spvcRerStatus = false}). +-record(spvcTargetVc, {entry, + userName = [], + providerName = [], + opState, + rowStatus}). + +-record(spvcTargetVp, {entry, + userName = [], + providerName = [], + opState, + rowStatus}). + +-record(spvcFr, {spvcFrEntry, + spvcFrAtmEntry, + spvcFrTargetAddress, + spvcFrTargetSelectType, + spvcFrProviderName, + currentState}). + +-record(spvcFrPerm, {spvcFrEntry, + spvcFrAtmEntry, + spvcFrAtmTranslation, + spvcFrAdminStatus, + spvcFrConnect}). + +-record(hci_clpn, {hci_pci, + hci_type_of_number, + hci_numbering_plan_indicator, + hci_presentation_indicator, + hci_screening_indicator, + hci_number_digits, + hci_incomplete_indicator = 0, + hci_binary}). + +encode_cc_clpn(Spvc) when Spvc#spvcObj.spvcFrKey == undefined -> + If = case Spvc of + Spvc when record(Spvc,spvcObj) -> + case Spvc#spvcObj.spvcEntry of + {If_Value,_,_,_} -> + If_Value; + {If_Value,_,_} -> + If_Value + end; + Spvc when record(Spvc,spvcVcc) -> + {If_Value,_,_,_} = Spvc#spvcVcc.spvcVccEntry, + If_Value; + Spvc when record(Spvc,spvcVpc) -> + {If_Value,_,_} = Spvc#spvcVpc.spvcVpcEntry, + If_Value; + Spvc when record(Spvc,spvcVpcPerm) -> + {If_Value,_,_} = Spvc#spvcVpcPerm.spvcVpcEntry, + If_Value; + Spvc when record(Spvc,spvcVccPerm) -> + {If_Value,_,_,_} = Spvc#spvcVccPerm.spvcVccEntry, + If_Value; + Spvc when record(Spvc,spvcTargetVc) -> + {If_Value,_,_} = Spvc#spvcTargetVc.entry, + If_Value; + Spvc when record(Spvc,spvcTargetVp) -> + {If_Value,_} = Spvc#spvcTargetVp.entry, + If_Value; + Spvc when record(Spvc,pchVc) -> + {If_Value,_,_} = Spvc#pchVc.vclEntry, + If_Value; + Spvc when record(Spvc,pchVp) -> + {If_Value,_} = Spvc#pchVp.vplEntry, + If_Value; + Spvc when record(Spvc,spvcFr) -> + {If_Value,_} = Spvc#spvcFr.spvcFrEntry, + If_Value; + Spvc when record(Spvc,spvcFrPerm) -> + {If_Value,_} = Spvc#spvcFrPerm.spvcFrEntry, + If_Value; + {If_Value,_,_,_} -> + If_Value; + {If_Value,_,_} -> + If_Value; + {If_Value,_} -> + If_Value; + [If_Value|_] -> + If_Value; + _ -> + error + end, + Col = [2], + SpvcAddress = case x:x(get_next,[If],Col) of + [{[2,If,20|Address],_}] -> + Address; + _ -> + lists:duplicate(20,0) + end, + #hci_clpn{hci_type_of_number = 0, + hci_numbering_plan_indicator = 2, + hci_presentation_indicator = 0, + hci_screening_indicator = 1, + hci_number_digits = SpvcAddress}; +encode_cc_clpn(Spvc) -> + {If,_} = Spvc#spvcObj.spvcFrKey, + Col = [4], + SpvcFrAddress = case x:x(get_next,[If],Col) of + [{[4,If,20|Address],_}] -> + Address; + _ -> + lists:duplicate(20,0) + end, + #hci_clpn{hci_type_of_number = 0, + hci_numbering_plan_indicator = 2, + hci_presentation_indicator = 0, + hci_screening_indicator = 1, + hci_number_digits = SpvcFrAddress}. + + + +get_oper_status(spvcVpc,Obj) when record(Obj,spvcVpc) -> + State = Obj#spvcVpc.currentState, + LinkState = get_link_opstate(case Obj of + Obj when record(Obj,spvcObj) -> + case Obj#spvcObj.spvcEntry of + {If_Value,_,_,_} -> + If_Value; + {If_Value,_,_} -> + If_Value + end; + Obj when record(Obj,spvcVcc) -> + {If_Value,_,_,_} = +Obj#spvcVcc.spvcVccEntry, + If_Value; + Obj when record(Obj,spvcVpc) -> + {If_Value,_,_} = Obj#spvcVpc.spvcVpcEntry, + If_Value; + Obj when record(Obj,spvcVpcPerm) -> + {If_Value,_,_} = +Obj#spvcVpcPerm.spvcVpcEntry, + If_Value; + Obj when record(Obj,spvcVccPerm) -> + {If_Value,_,_,_} = +Obj#spvcVccPerm.spvcVccEntry, + If_Value; + Obj when record(Obj,spvcTargetVc) -> + {If_Value,_,_} = Obj#spvcTargetVc.entry, + If_Value; + Obj when record(Obj,spvcTargetVp) -> + {If_Value,_} = Obj#spvcTargetVp.entry, + If_Value; + Obj when record(Obj,pchVc) -> + {If_Value,_,_} = Obj#pchVc.vclEntry, + If_Value; + Obj when record(Obj,pchVp) -> + {If_Value,_} = Obj#pchVp.vplEntry, + If_Value; + Obj when record(Obj,spvcFr) -> + {If_Value,_} = Obj#spvcFr.spvcFrEntry, + If_Value; + Obj when record(Obj,spvcFrPerm) -> + {If_Value,_} = Obj#spvcFrPerm.spvcFrEntry, + If_Value; + {If_Value,_,_,_} -> + If_Value; + {If_Value,_,_} -> + If_Value; + {If_Value,_} -> + If_Value; + [If_Value|_] -> + If_Value; + _ -> + error + end), + debug_disabled, + case {State,LinkState} of + {not_in_service,_} -> + 10; + {created,_} -> + 10; + {_,disabled} -> + 6; + {wait,_} -> + 2; + {outgoing_callproceeding,_} -> + 2; + {release_at_restart,_} -> + 2; + {active,_} -> + 3; + {rest_in_peace,_} -> + 4; + {_Other,_} -> + 1 + end; +get_oper_status(spvcVpc,_) -> + debug_disabled, + 1; +get_oper_status(spvcVcc,Obj) when record(Obj,spvcVcc) -> + State = Obj#spvcVcc.currentState, + LinkState = get_link_opstate(case Obj of + Obj when record(Obj,spvcObj) -> + case Obj#spvcObj.spvcEntry of + {If_Value,_,_,_} -> + If_Value; + {If_Value,_,_} -> + If_Value + end; + Obj when record(Obj,spvcVcc) -> + {If_Value,_,_,_} = +Obj#spvcVcc.spvcVccEntry, + If_Value; + Obj when record(Obj,spvcVpc) -> + {If_Value,_,_} = Obj#spvcVpc.spvcVpcEntry, + If_Value; + Obj when record(Obj,spvcVpcPerm) -> + {If_Value,_,_} = +Obj#spvcVpcPerm.spvcVpcEntry, + If_Value; + Obj when record(Obj,spvcVccPerm) -> + {If_Value,_,_,_} = +Obj#spvcVccPerm.spvcVccEntry, + If_Value; + Obj when record(Obj,spvcTargetVc) -> + {If_Value,_,_} = Obj#spvcTargetVc.entry, + If_Value; + Obj when record(Obj,spvcTargetVp) -> + {If_Value,_} = Obj#spvcTargetVp.entry, + If_Value; + Obj when record(Obj,pchVc) -> + {If_Value,_,_} = Obj#pchVc.vclEntry, + If_Value; + Obj when record(Obj,pchVp) -> + {If_Value,_} = Obj#pchVp.vplEntry, + If_Value; + Obj when record(Obj,spvcFr) -> + {If_Value,_} = Obj#spvcFr.spvcFrEntry, + If_Value; + Obj when record(Obj,spvcFrPerm) -> + {If_Value,_} = Obj#spvcFrPerm.spvcFrEntry, + If_Value; + {If_Value,_,_,_} -> + If_Value; + {If_Value,_,_} -> + If_Value; + {If_Value,_} -> + If_Value; + [If_Value|_] -> + If_Value; + _ -> + error + end), + debug_disabled, + case {State,LinkState} of + {not_in_service,_} -> + 10; + {created,_} -> + 10; + {_,disabled} -> + 6; + {wait,_} -> + 2; + {outgoing_callproceeding,_} -> + 2; + {release_at_restart,_} -> + 2; + {active,_} -> + 3; + {rest_in_peace,_} -> + 4; + {_Other,_} -> + 1 + end; +get_oper_status(spvcVcc,_) -> + debug_disabled, + 1; +get_oper_status(spvcTargetVp,Obj) when record(Obj,spvcTargetVp) -> + debug_disabled, + Key = Obj#spvcTargetVp.entry, + case get_link_opstate(case Key of + Key when record(Key,spvcObj) -> + case Key#spvcObj.spvcEntry of + {If_Value,_,_,_} -> + If_Value; + {If_Value,_,_} -> + If_Value + end; + Key when record(Key,spvcVcc) -> + {If_Value,_,_,_} = Key#spvcVcc.spvcVccEntry, + If_Value; + Key when record(Key,spvcVpc) -> + {If_Value,_,_} = Key#spvcVpc.spvcVpcEntry, + If_Value; + Key when record(Key,spvcVpcPerm) -> + {If_Value,_,_} = Key#spvcVpcPerm.spvcVpcEntry, + If_Value; + Key when record(Key,spvcVccPerm) -> + {If_Value,_,_,_} = Key#spvcVccPerm.spvcVccEntry, + If_Value; + Key when record(Key,spvcTargetVc) -> + {If_Value,_,_} = Key#spvcTargetVc.entry, + If_Value; + Key when record(Key,spvcTargetVp) -> + {If_Value,_} = Key#spvcTargetVp.entry, + If_Value; + Key when record(Key,pchVc) -> + {If_Value,_,_} = Key#pchVc.vclEntry, + If_Value; + Key when record(Key,pchVp) -> + {If_Value,_} = Key#pchVp.vplEntry, + If_Value; + Key when record(Key,spvcFr) -> + {If_Value,_} = Key#spvcFr.spvcFrEntry, + If_Value; + Key when record(Key,spvcFrPerm) -> + {If_Value,_} = Key#spvcFrPerm.spvcFrEntry, + If_Value; + {If_Value,_,_,_} -> + If_Value; + {If_Value,_,_} -> + If_Value; + {If_Value,_} -> + If_Value; + [If_Value|_] -> + If_Value; + _ -> + error + end) of + disabled -> + debug_disabled, + 4; + enabled -> + debug_disabled, + case (x:x({pchVp,Key}))#pchVp.vplConnId of + undefined -> + debug_disabled, + 3; + _ -> + debug_disabled, + 2 + end + end; +get_oper_status(spvcTargetVp,_) -> + debug_disabled, + 1; +get_oper_status(spvcTargetVc,Obj) when record(Obj,spvcTargetVc) -> + debug_disabled, + Key = Obj#spvcTargetVc.entry, + case get_link_opstate(case Key of + Key when record(Key,spvcObj) -> + case Key#spvcObj.spvcEntry of + {If_Value,_,_,_} -> + If_Value; + {If_Value,_,_} -> + If_Value + end; + Key when record(Key,spvcVcc) -> + {If_Value,_,_,_} = Key#spvcVcc.spvcVccEntry, + If_Value; + Key when record(Key,spvcVpc) -> + {If_Value,_,_} = Key#spvcVpc.spvcVpcEntry, + If_Value; + Key when record(Key,spvcVpcPerm) -> + {If_Value,_,_} = Key#spvcVpcPerm.spvcVpcEntry, + If_Value; + Key when record(Key,spvcVccPerm) -> + {If_Value,_,_,_} = Key#spvcVccPerm.spvcVccEntry, + If_Value; + Key when record(Key,spvcTargetVc) -> + {If_Value,_,_} = Key#spvcTargetVc.entry, + If_Value; + Key when record(Key,spvcTargetVp) -> + {If_Value,_} = Key#spvcTargetVp.entry, + If_Value; + Key when record(Key,pchVc) -> + {If_Value,_,_} = Key#pchVc.vclEntry, + If_Value; + Key when record(Key,pchVp) -> + {If_Value,_} = Key#pchVp.vplEntry, + If_Value; + Key when record(Key,spvcFr) -> + {If_Value,_} = Key#spvcFr.spvcFrEntry, + If_Value; + Key when record(Key,spvcFrPerm) -> + {If_Value,_} = Key#spvcFrPerm.spvcFrEntry, + If_Value; + {If_Value,_,_,_} -> + If_Value; + {If_Value,_,_} -> + If_Value; + {If_Value,_} -> + If_Value; + [If_Value|_] -> + If_Value; + _ -> + error + end) of + disabled -> + debug_disabled, + 4; + enabled -> + debug_disabled, + case (x:x({pchVc,Key}))#pchVc.vclConnId of + undefined -> + debug_disabled, + 3; + _ -> + debug_disabled, + 2 + end + end; +get_oper_status(spvcTargetVc,_) -> + debug_disabled, + 1. + +get_link_opstate(If) -> + debug_disabled, + case x:x(x:x(If),cnhChi,get_link_opstate,[If]) of + {genError,_} -> + debug_disabled, + disabled; + Return -> + debug_disabled, + Return + end. + +-record(record_A,{ + field_1, + field_2, + field_3, + field_4, + field_5 + }). +-record(record_B, { field_1 }). +-record(record_C, { }). + +foo() -> + case something of + [#record_A{} = A] -> + B = foo3(#record_C{}), + C = element(B, A), + foo2(A), + D = C#record_B.field_1, + foo4(A#record_A.field_4, + B, + #record_C{}, + D) + end. + +foo2(_) -> ok. +foo3(_) -> 1. +foo4(_,_,_,_) -> ok. + diff --git a/lib/compiler/test/compilation_SUITE_data/otp_5553.erl b/lib/compiler/test/compilation_SUITE_data/otp_5553.erl new file mode 100644 index 0000000000..9a7004a980 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_5553.erl @@ -0,0 +1,82 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2005-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(otp_5553). + +-export([?MODULE/0,test/0,handle_cast/2]). + +?MODULE() -> + ok. + +split_quoted_string([34 | _Rest]) -> %% 34 is '"' + ok. + +test() -> + %% does not start with quote + io:format("test: split_quoted_string/1 - 5~n"), + try split_quoted_string("foo \"bar\"") of + SQS_Res5 -> throw({error, test_case_failed, SQS_Res5}) + catch + error: does_not_start_with_quote -> ok + end, + + %% no ending quote + io:format("test: split_quoted_string/1 - 6~n"), + try split_quoted_string("\"foo ") of + SQS_Res6 -> throw({error, test_case_failed, SQS_Res6}) + catch + error: no_end_quote -> ok + end, + + ok. + +test2() -> + try split_quoted_string("") of + SQS_Res5 -> throw({error, test_case_failed, SQS_Res5}) + catch + error: does_not_start_with_quote -> ok + after + ok + end, + try split_quoted_string("") of + SQS_Res6 -> throw({error, test_case_failed, SQS_Res6}) + catch + error: no_end_quote -> ok + after + ok + end, + ok. + +-record(state, {connect_all, known = [], synced = [], + lockers = [], syncers = [], node_name = node(), + the_locker, the_deleter}). + +handle_cast({in_sync, Node, IsKnown}, S) -> + NewS = cancel_locker(Node, S, get({sync_tag_my, Node})), + NKnown = case lists:member(Node, Known = NewS#state.known) of + false when IsKnown == true -> +1/0, + gen_server:cast({global_name_server, Node}, + {in_sync, node(), false}), + [Node | Known]; + _ -> + Known + end. + +cancel_locker(Node, S, Tag) -> + ok. diff --git a/lib/compiler/test/compilation_SUITE_data/otp_5632.erl b/lib/compiler/test/compilation_SUITE_data/otp_5632.erl new file mode 100644 index 0000000000..ebf8e47ca2 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_5632.erl @@ -0,0 +1,230 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2005-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(otp_5632). +-export([?MODULE/0]). +-export([pstnproxy_add_headers/2,macosx_workaround/0,fast_cut/3,test/1,test2/1, + create_int_jumper_cables/1]). + +-import(lists, [foldl/3,last/1,member/2,reverse/1,reverse/2,seq/2,sort/1]). + +?MODULE() -> + ok. + +-record(request, { + header + }). + + +-record(siporigin, { + proto + }). + + +%% Test a problem in beam_jump.erl. +pstnproxy_add_headers(Request, Origin) when is_record(Request, request), + is_record(Origin, siporigin) -> + NewHeaders1 = Request#request.header, + NewHeaders2 = + case (Origin#siporigin.proto == tls) or (Origin#siporigin.proto == tls6) of + true -> + keylist:delete("X-Foo2", NewHeaders1); + false -> + keylist:delete("X-Foo2", NewHeaders1) + end, + NewHeaders3 = + case (Origin#siporigin.proto == tls) or (Origin#siporigin.proto == tls6) of + true -> + keylist:delete("X-Foo3", NewHeaders2); + false -> + keylist:delete("X-Foo3", NewHeaders2) + end, + Request#request{header = NewHeaders3}. + +%% Test a problem in beam_validator.erl. +macosx_workaround() -> + try 1.0/zero() + catch + error:_ -> ok + end. + +zero() -> 0.0. + +-record(we, {id, + perm = 0, + name, + es, + fs, + he, + vc, + vp, + mat = default, + next_id, + mode, + mirror = none, + light = none, + has_shape = true}). + +-record(edge, {vs, + ve, + a = none, + b = none, + lf, + rf, + ltpr, + ltsu, + rtpr, + rtsu}). + + +fast_cut(Edge,Pos0,We0) -> + {NewEdge = NewV,We} = wings_we:new_ids(1,We0), + #we{es = Etab0, + vc = Vct0, + vp = Vtab0, + he = Htab0} = We, + Template = gb_trees:get(Edge,Etab0), + #edge{vs = Vstart, + ve = Vend, + a = ACol, + b = BCol, + lf = Lf, + rf = Rf, + ltpr = EdgeA, + rtsu = EdgeB, + rtpr = NextBCol} = Template, + VendPos = gb_trees:get(Vend,Vtab0), + Vct1 = gb_trees:update(Vend,NewEdge,Vct0), + VstartPos = wings_vertex:pos(Vstart,Vtab0), + if + Pos0 =:= default -> + NewVPos0 = e3d_vec:average([VstartPos,VendPos]); + true -> + NewVPos0 = Pos0 + end, + NewVPos = wings_util:share(NewVPos0), + Vct = gb_trees:insert(NewV,NewEdge,Vct1), + Vtab = gb_trees:insert(NewV,NewVPos,Vtab0), + AColOther = ?MODULE:get_vtx_color(EdgeA,Lf,Etab0), + BColOther = ?MODULE:get_vtx_color(NextBCol,Rf,Etab0), + Weight = if + Pos0 == default -> + 0.500000; + true -> + ADist = e3d_vec:dist(Pos0,VstartPos), + BDist = e3d_vec:dist(Pos0,VendPos), + try + ADist / (ADist + BDist) + catch + error:badarith -> + 0.500000 + end + end, + NewColA = wings_color:mix(Weight,AColOther,ACol), + NewColB = wings_color:mix(Weight,BCol,BColOther), + NewEdgeRec = Template#edge{vs = NewV, + a = NewColA, + ltsu = Edge, + rtpr = Edge}, + Etab1 = gb_trees:insert(NewEdge,NewEdgeRec,Etab0), + Etab2 = ?MODULE:patch_edge(EdgeA,NewEdge,Edge,Etab1), + Etab3 = ?MODULE:patch_edge(EdgeB,NewEdge,Edge,Etab2), + EdgeRec = Template#edge{ve = NewV, + b = NewColB, + rtsu = NewEdge, + ltpr = NewEdge}, + Etab = gb_trees:update(Edge,EdgeRec,Etab3), + Htab = case gb_sets:is_member(Edge,Htab0) of + false -> + Htab0; + true -> + gb_sets:insert(NewEdge,Htab0) + end, + {We#we{es = Etab, + vc = Vct, + vp = Vtab, + he = Htab},NewV}. + +%% A problem in beam_bool. + +-record(a, {a,b,c}). + +test(As) -> + case As of + A when A#a.b == []; A#a.b == undefined -> + true; + _ -> + false + end. + +test2(As) -> + case As of + A when A#a.b == {a,b,c}; A#a.b == undefined -> + true; + _ -> + false + end. + +%% Record updating problems. + +-record(int_jumper_cable, {id, + connectionFieldRef, + aiuPlugInUnitRef, + connFieldConnector, + aiuConnector, + dlAttenuation = 1, + ulAttenuation = 1, + electricalDlDelay = 100, + electricalUlDelay = 100, + optionals = []}). + +create_int_jumper_cables(_Config) -> + ct_line:line({{ccl_setup_SUITE,create_int_jumper_cables},637}), + ct:comment("Create IntJumperCable MO"), + ct_line:line({{ccl_setup_SUITE,create_int_jumper_cables},639}), + Parent = "ManagedElement=1,Equipment=1", + ct_line:line({{ccl_setup_SUITE,create_int_jumper_cables},641}), + I1 = #int_jumper_cable{id = 1, + connectionFieldRef = Parent ++ ",ConnectionField=1", + aiuPlugInUnitRef = Parent ++ ",Subrack=2,Slot=6,PlugInUnit=1", + connFieldConnector = "J1", + aiuConnector = 1}, + ct_line:line({{ccl_setup_SUITE,create_int_jumper_cables},650}), + I2 = I1#int_jumper_cable{id = 2, + connFieldConnector = "H1", + aiuConnector = 2}, + ct_line:line({{ccl_setup_SUITE,create_int_jumper_cables},657}), + I3 = I1#int_jumper_cable{id = 3, + aiuPlugInUnitRef = Parent ++ ",Subrack=2,Slot=9,PlugInUnit=1", + connFieldConnector = "J2"}, + ct_line:line({{ccl_setup_SUITE,create_int_jumper_cables},663}), + I4 = I3#int_jumper_cable{id = 4, + connFieldConnector = "H2", + aiuConnector = 2}, + ct_line:line({{ccl_setup_SUITE,create_int_jumper_cables},670}), + I5 = I1#int_jumper_cable{id = 5, + aiuPlugInUnitRef = Parent ++ ",Subrack=2,Slot=12,PlugInUnit=1", + connFieldConnector = "J3"}, + ct_line:line({{ccl_setup_SUITE,create_int_jumper_cables},677}), + I6 = I5#int_jumper_cable{id = 6, + connFieldConnector = "H3", + aiuConnector = 2}, + ct_line:line({{ccl_setup_SUITE,create_int_jumper_cables},684}), + [_MO1,_MO2,_MO3,_MO4,_MO5,_MO6] = mub_util:create(mp_mub,Parent,[I1,I2,I3,I4,I5,I6]), + ct_line:line({{ccl_setup_SUITE,create_int_jumper_cables},686}), + ok. diff --git a/lib/compiler/test/compilation_SUITE_data/otp_5714.erl b/lib/compiler/test/compilation_SUITE_data/otp_5714.erl new file mode 100644 index 0000000000..5aefa0a803 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_5714.erl @@ -0,0 +1,46 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2005-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(otp_5714). +-export([?MODULE/0,foo/1,mktree_text/1]). +-binary(<<1,2,3>>). + +?MODULE() -> + [<<1,2,3>>] = proplists:get_value(binary, ?MODULE:module_info(attributes)), + ok. + +-record(foo_record, {key,blabla}). +foo(A) -> + hd(tl(element(2,element(2,catch erlang:error(apa))))), + case A of + A -> + B = #foo_record{ key = key1}, + C = B#foo_record{ key = key2}, + {X,Y} = {a,b} + end. + +mktree_text(Val) -> + case erlang:is_integer(Val) of + _A = IsInteger -> + _A; + _A -> + IsInteger = erlang:exit({{bug,mktree_text,4},{line,34},match,[_A]}) + end, + ok; +mktree_text(_A1) -> + erlang:exit({{bug,mktree_text,4},{line,33},function_clause,[_A1]}). diff --git a/lib/compiler/test/compilation_SUITE_data/otp_5872.erl b/lib/compiler/test/compilation_SUITE_data/otp_5872.erl new file mode 100644 index 0000000000..cada7ad994 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_5872.erl @@ -0,0 +1,46 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2006-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(otp_5872). +-export([?MODULE/0,chunk_request_body/3]). + +?MODULE() -> + ok. + +chunk_request_body(Body,_ChunkSize,Acc) when Body == <<>>; Body == [] -> + LastChunk = "0\r\n", + lists:reverse(["\r\n",LastChunk|Acc]); +chunk_request_body(Body,ChunkSize,Acc) when binary(Body), size(Body) >= ChunkSize -> + <<ChunkBody:ChunkSize/binary, + Rest/binary>> = Body, + Chunk = [ibrowse_lib:dec2hex(4,ChunkSize),"\r\n",ChunkBody,"\r\n"], + chunk_request_body(Rest,ChunkSize,[Chunk|Acc]); +chunk_request_body(Body,_ChunkSize,Acc) when binary(Body) -> + BodySize = size(Body), + Chunk = [ibrowse_lib:dec2hex(4,BodySize),"\r\n",Body,"\r\n"], + LastChunk = "0\r\n", + lists:reverse(["\r\n",LastChunk,Chunk|Acc]); +chunk_request_body(Body,ChunkSize,Acc) when list(Body), length(Body) >= ChunkSize -> + {ChunkBody,Rest} = ?MODULE:split_list_at(Body,ChunkSize), + Chunk = [ibrowse_lib:dec2hex(4,ChunkSize),"\r\n",ChunkBody,"\r\n"], + chunk_request_body(Rest,ChunkSize,[Chunk|Acc]); +chunk_request_body(Body,_ChunkSize,Acc) when list(Body) -> + BodySize = length(Body), + Chunk = [ibrowse_lib:dec2hex(4,BodySize),"\r\n",Body,"\r\n"], + LastChunk = "0\r\n", + lists:reverse(["\r\n",LastChunk,Chunk|Acc]). diff --git a/lib/compiler/test/compilation_SUITE_data/otp_6121.erl b/lib/compiler/test/compilation_SUITE_data/otp_6121.erl new file mode 100644 index 0000000000..c71f7806a0 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_6121.erl @@ -0,0 +1,48 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2006-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(otp_6121). +-export([?MODULE/0]). + +?MODULE() -> + 42 = digit_map_timer(<<1>>, 42), + test(), + Beam = code:which(?MODULE), + Sz = filelib:file_size(Beam), + io:format("Size of Beam file: ~p\n", [Sz]), + if + 100 < Sz, Sz < 100000 -> + ok + end. + +test() -> + %% Make sure that the compiler does not make an unreasonable + %% expansion when trying to optimize the following expressions. + <<0:(8*128*1024)>> = id(<<0:(8*128*1024)>>), + <<100:(8*128*1024)>> = id(<<100:(8*128*1024)>>), + <<1009797879398749873879789879388:(8*128*1024)>> = + id(<<1009797879398749873879789879388:(8*128*1024)>>), + <<7:(8*128*1024)/little>> = id(<<7:(8*128*1024)/little>>), + ok. + +id(I) -> I. + +digit_map_timer(<<_:8>>, Int) when is_integer(Int) andalso Int >= 0 -> + Int; +digit_map_timer(_, _) -> + error. diff --git a/lib/compiler/test/compilation_SUITE_data/otp_6121a.erl b/lib/compiler/test/compilation_SUITE_data/otp_6121a.erl new file mode 100644 index 0000000000..caed631aa2 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_6121a.erl @@ -0,0 +1,32 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2006-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(otp_6121a). +-export([?MODULE/0]). + +%% Thanks to Martin Bjorklund. + +?MODULE() -> + G = fun() -> ok end, + try + fun() -> ok end + after + fun({A, B}) -> A + B end + end, + ok. + diff --git a/lib/compiler/test/compilation_SUITE_data/otp_6121b.erl b/lib/compiler/test/compilation_SUITE_data/otp_6121b.erl new file mode 100644 index 0000000000..967f078942 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_6121b.erl @@ -0,0 +1,33 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2006-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(otp_6121b). +-export([?MODULE/0]). + +%% Thanks to Tim Rath. + +?MODULE() -> + A = {6}, + try + io:fwrite("") + after + fun () -> + fun () -> {B} = A end + end + end. + diff --git a/lib/compiler/test/compilation_SUITE_data/otp_7202.erl b/lib/compiler/test/compilation_SUITE_data/otp_7202.erl new file mode 100644 index 0000000000..9dca244aa5 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/otp_7202.erl @@ -0,0 +1,48 @@ +%% +%% %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(otp_7202). +-export([?MODULE/0]). + +?MODULE() -> + test(). + +test() -> + List = [a], + Error = case func() of + no_value -> true; + {ok, V} -> V + end, + %% Liveness calculation for the make_fun2 instruction was wrong - + %% it looked like Error would not be needed by the make_fun2 instruction. + lists:foreach(fun(_E) -> + case Error of + true -> + ok; + false -> + ok + end + end, List). + +func() -> + no_value. + + + + + diff --git a/lib/compiler/test/compilation_SUITE_data/pattern_expr.erl b/lib/compiler/test/compilation_SUITE_data/pattern_expr.erl new file mode 100644 index 0000000000..02eacced81 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/pattern_expr.erl @@ -0,0 +1,30 @@ +%% +%% %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% +%% +-module(pattern_expr). + +-export(pattern_expr/0). + +pattern_expr() -> + f(). + +f() -> + case 4 of + 2+2 -> + ok + end. diff --git a/lib/compiler/test/compilation_SUITE_data/trycatch_4.erl b/lib/compiler/test/compilation_SUITE_data/trycatch_4.erl new file mode 100644 index 0000000000..7ea710856f --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/trycatch_4.erl @@ -0,0 +1,50 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2005-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(trycatch_4). +-export([trycatch_4/0]). +-record(state, {foo}). + +trycatch_4() -> + handle_info({foo}, #state{}), + ok. + +handle_info({_}, State) -> + foo(), + State#state{foo = bar}, + case ok of + _ -> + case catch foo() of + ok -> + {stop, State} + end + end; +handle_info(_, State) -> + (catch begin + foo(), + State#state{foo = bar} + end), + case ok of + _ -> + case catch foo() of + ok -> + {stop, State} + end + end. + +foo() -> ok. diff --git a/lib/compiler/test/compilation_SUITE_data/vsn_1.erl b/lib/compiler/test/compilation_SUITE_data/vsn_1.erl new file mode 100644 index 0000000000..a9e23f7c25 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/vsn_1.erl @@ -0,0 +1,21 @@ +%% +%% %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% +%% +-module(vsn_1). + +-hubbub(himmap). diff --git a/lib/compiler/test/compilation_SUITE_data/vsn_2.erl b/lib/compiler/test/compilation_SUITE_data/vsn_2.erl new file mode 100644 index 0000000000..4833458cf4 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/vsn_2.erl @@ -0,0 +1,21 @@ +%% +%% %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% +%% +-module(vsn_2). + +-vsn(34). diff --git a/lib/compiler/test/compilation_SUITE_data/vsn_3.erl b/lib/compiler/test/compilation_SUITE_data/vsn_3.erl new file mode 100644 index 0000000000..7b970b2b75 --- /dev/null +++ b/lib/compiler/test/compilation_SUITE_data/vsn_3.erl @@ -0,0 +1,22 @@ +%% +%% %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% +%% +-module(vsn_3). + +f(X) -> + 2*X. diff --git a/lib/compiler/test/compile_SUITE.erl b/lib/compiler/test/compile_SUITE.erl new file mode 100644 index 0000000000..7c3990a855 --- /dev/null +++ b/lib/compiler/test/compile_SUITE.erl @@ -0,0 +1,722 @@ +%% +%% %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(compile_SUITE). + +%% Tests compile:file/1 and compile:file/2 with various options. + +-include("test_server.hrl"). + +-export([all/1, + app_test/1, + file_1/1, module_mismatch/1, big_file/1, outdir/1, + binary/1, cond_and_ifdef/1, listings/1, listings_big/1, + other_output/1, package_forms/1, encrypted_abstr/1, + bad_record_use/1, bad_record_use1/1, bad_record_use2/1, strict_record/1, + missing_testheap/1, cover/1, env/1, core/1, asm/1]). + +-export([init/3]). + + +%% To cover the stripping of 'type' and 'spec' in beam_asm. +-type all_return_type() :: [atom()]. +-spec all('suite' | [_]) -> all_return_type(). + +all(suite) -> + test_lib:recompile(?MODULE), + [app_test, + file_1, module_mismatch, big_file, outdir, binary, + cond_and_ifdef, listings, listings_big, + other_output, package_forms, + encrypted_abstr, + bad_record_use, strict_record, + missing_testheap, cover, env, core, asm]. + + +%% Test that the Application file has no `basic' errors."; +app_test(Config) when is_list(Config) -> + ?line ?t:app_test(compiler). + +%% Tests that we can compile and run a simple Erlang program, +%% using compile:file/1. + +file_1(Config) when is_list(Config) -> + ?line Dog = test_server:timetrap(test_server:minutes(5)), + ?line {Simple, Target} = files(Config, "file_1"), + ?line {ok, Cwd} = file:get_cwd(), + ?line ok = file:set_cwd(filename:dirname(Target)), + ?line {ok,simple} = compile:file(Simple), %Smoke test only. + ?line {ok,simple} = compile:file(Simple, [slim]), %Smoke test only. + ?line {ok,simple} = compile:file(Simple, [native,report]), %Smoke test. + ?line {ok,simple} = compile:file(Target, [native,from_beam]), %Smoke test. + ?line {ok,simple} = compile:file(Simple, [debug_info]), + ?line ok = file:set_cwd(Cwd), + ?line true = exists(Target), + ?line passed = run(Target, test, []), + + %% Cleanup. + ?line ok = file:delete(Target), + ?line ok = file:del_dir(filename:dirname(Target)), + ?line test_server:timetrap_cancel(Dog), + ok. + +module_mismatch(Config) when is_list(Config) -> + ?line DataDir = ?config(data_dir, Config), + ?line File = filename:join(DataDir, "wrong_module_name.erl"), + ?line {error,[{"wrong_module_name.beam", + [{compile,{module_name,arne,"wrong_module_name"}}]}], + []} = compile:file(File, [return]), + ?line error = compile:file(File, [report]), + + ?line {ok,arne,[]} = compile:file(File, + [return,no_error_module_mismatch]), + + ok. + +big_file(Config) when is_list(Config) -> + ?line Dog = test_server:timetrap(test_server:minutes(5)), + ?line DataDir = ?config(data_dir, Config), + ?line PrivDir = ?config(priv_dir, Config), + ?line Big = filename:join(DataDir, "big.erl"), + ?line Target = filename:join(PrivDir, "big.beam"), + ?line ok = file:set_cwd(PrivDir), + ?line {ok,big} = compile:file(Big, []), + ?line {ok,big} = compile:file(Big, [r9,debug_info]), + ?line {ok,big} = compile:file(Big, [no_postopt]), + ?line true = exists(Target), + + %% Cleanup. + ?line ok = file:delete(Target), + ?line test_server:timetrap_cancel(Dog), + ok. + +%% Tests that the {outdir, Dir} option works. + +outdir(Config) when is_list(Config) -> + ?line Dog = test_server:timetrap(test_server:seconds(60)), + ?line {Simple, Target} = files(Config, "outdir"), + ?line {ok, simple} = compile:file(Simple, [{outdir, filename:dirname(Target)}]), + ?line true = exists(Target), + ?line passed = run(Target, test, []), + ?line ok = file:delete(Target), + ?line ok = file:del_dir(filename:dirname(Target)), + ?line test_server:timetrap_cancel(Dog), + ok. + +%% Tests that the binary option works. + +binary(Config) when is_list(Config) -> + ?line Dog = test_server:timetrap(test_server:seconds(60)), + ?line {Simple, Target} = files(Config, "binary"), + ?line {ok, simple, Binary} = compile:file(Simple, [binary]), + ?line code:load_binary(simple, Target, Binary), + ?line passed = simple:test(), + ?line true = code:delete(simple), + ?line false = code:purge(simple), + ?line ok = file:del_dir(filename:dirname(Target)), + ?line test_server:timetrap_cancel(Dog), + ok. + +%% Tests that conditional compilation, defining values, including files work. + +cond_and_ifdef(Config) when is_list(Config) -> + ?line Dog = test_server:timetrap(test_server:seconds(60)), + ?line {Simple, Target} = files(Config, "cond_and_ifdef"), + ?line IncludeDir = filename:join(filename:dirname(Simple), "include"), + ?line Options = [{outdir, filename:dirname(Target)}, + {d, need_foo}, {d, foo_value, 42}, + {i, IncludeDir}, report], + ?line {ok, simple} = compile:file(Simple, Options), + ?line true = exists(Target), + ?line {hiker, 42} = run(Target, foo, []), + ?line ok = file:delete(Target), + ?line ok = file:del_dir(filename:dirname(Target)), + ?line test_server:timetrap_cancel(Dog), + ok. + +listings(Config) when is_list(Config) -> + ?line Dog = test_server:timetrap(test_server:minutes(8)), + ?line DataDir = ?config(data_dir, Config), + ?line PrivDir = ?config(priv_dir, Config), + ?line Simple = filename:join(DataDir, simple), + ?line TargetDir = filename:join(PrivDir, listings), + ?line ok = file:make_dir(TargetDir), + + %% Test all dedicated listing options. + ?line do_listing(Simple, TargetDir, 'S'), + ?line do_listing(Simple, TargetDir, 'E'), + ?line do_listing(Simple, TargetDir, 'P'), + ?line do_listing(Simple, TargetDir, dpp, ".pp"), + ?line do_listing(Simple, TargetDir, dabstr, ".abstr"), + ?line do_listing(Simple, TargetDir, dexp, ".expand"), + ?line do_listing(Simple, TargetDir, dcore, ".core"), + ?line do_listing(Simple, TargetDir, doldinline, ".oldinline"), + ?line do_listing(Simple, TargetDir, dinline, ".inline"), + ?line do_listing(Simple, TargetDir, dcore, ".core"), + ?line do_listing(Simple, TargetDir, dcopt, ".copt"), + ?line do_listing(Simple, TargetDir, dsetel, ".dsetel"), + ?line do_listing(Simple, TargetDir, dkern, ".kernel"), + ?line do_listing(Simple, TargetDir, dlife, ".life"), + ?line do_listing(Simple, TargetDir, dcg, ".codegen"), + ?line do_listing(Simple, TargetDir, dblk, ".block"), + ?line do_listing(Simple, TargetDir, dbool, ".bool"), + ?line do_listing(Simple, TargetDir, dtype, ".type"), + ?line do_listing(Simple, TargetDir, ddead, ".dead"), + ?line do_listing(Simple, TargetDir, djmp, ".jump"), + ?line do_listing(Simple, TargetDir, dclean, ".clean"), + ?line do_listing(Simple, TargetDir, dpeep, ".peep"), + ?line do_listing(Simple, TargetDir, dopt, ".optimize"), + + %% First clean up. + ?line Listings = filename:join(PrivDir, listings), + ?line lists:foreach(fun(F) -> ok = file:delete(F) end, + filelib:wildcard(filename:join(Listings, "*"))), + + %% Test options that produce a listing file if 'binary' is not given. + ?line do_listing(Simple, TargetDir, to_pp, ".P"), + ?line do_listing(Simple, TargetDir, to_exp, ".E"), + ?line do_listing(Simple, TargetDir, to_core0, ".core"), + ?line ok = file:delete(filename:join(Listings, "simple.core")), + ?line do_listing(Simple, TargetDir, to_core, ".core"), + ?line do_listing(Simple, TargetDir, to_kernel, ".kernel"), + + %% Final clean up. + ?line lists:foreach(fun(F) -> ok = file:delete(F) end, + filelib:wildcard(filename:join(Listings, "*"))), + ?line ok = file:del_dir(Listings), + ?line test_server:timetrap_cancel(Dog), + ok. + +listings_big(Config) when is_list(Config) -> + ?line Dog = test_server:timetrap(test_server:minutes(10)), + ?line DataDir = ?config(data_dir, Config), + ?line PrivDir = ?config(priv_dir, Config), + ?line Big = filename:join(DataDir, big), + ?line TargetDir = filename:join(PrivDir, listings_big), + ?line ok = file:make_dir(TargetDir), + ?line do_listing(Big, TargetDir, 'S'), + ?line do_listing(Big, TargetDir, 'E'), + ?line do_listing(Big, TargetDir, 'P'), + ?line do_listing(Big, TargetDir, dkern, ".kernel"), + + ?line Target = filename:join(TargetDir, big), + ?line {ok,big} = compile:file(Target, [asm,{outdir,TargetDir}]), + + %% Cleanup. + ?line ok = file:delete(Target ++ ".beam"), + ?line lists:foreach(fun(F) -> ok = file:delete(F) end, + filelib:wildcard(filename:join(TargetDir, "*"))), + ?line ok = file:del_dir(TargetDir), + ?line test_server:timetrap_cancel(Dog), + ok. + +other_output(Config) when is_list(Config) -> + ?line Dog = test_server:timetrap(test_server:minutes(8)), + ?line DataDir = ?config(data_dir, Config), + ?line PrivDir = ?config(priv_dir, Config), + ?line Simple = filename:join(DataDir, simple), + ?line TargetDir = filename:join(PrivDir, other_output), + ?line ok = file:make_dir(TargetDir), + + io:put_chars("to_pp"), + ?line {ok,[],PP} = compile:file(Simple, [to_pp,binary,time]), + ?line [] = [E || E <- PP, + begin + case element(1, E) of + attribute -> false; + function -> false; + eof -> false + end + end], + + io:put_chars("to_exp (file)"), + ?line {ok,simple,Expand} = compile:file(Simple, [to_exp,binary,time]), + ?line case Expand of + {simple,Exports,Forms} when is_list(Exports), is_list(Forms) -> ok + end, + io:put_chars("to_exp (forms)"), + ?line {ok,simple,Expand} = compile:forms(PP, [to_exp,binary,time]), + + io:put_chars("to_core (file)"), + ?line {ok,simple,Core} = compile:file(Simple, [to_core,binary,time]), + ?line c_module = element(1, Core), + ?line {ok,_} = core_lint:module(Core), + io:put_chars("to_core (forms)"), + ?line {ok,simple,Core} = compile:forms(PP, [to_core,binary,time]), + + io:put_chars("to_kernel (file)"), + ?line {ok,simple,Kernel} = compile:file(Simple, [to_kernel,binary,time]), + ?line k_mdef = element(1, Kernel), + io:put_chars("to_kernel (forms)"), + ?line {ok,simple,Kernel} = compile:forms(PP, [to_kernel,binary,time]), + + io:put_chars("to_asm (file)"), + ?line {ok,simple,Asm} = compile:file(Simple, [to_asm,binary,time]), + ?line {simple,_,_,_,_} = Asm, + io:put_chars("to_asm (forms)"), + ?line {ok,simple,Asm} = compile:forms(PP, [to_asm,binary,time]), + + ?line test_server:timetrap_cancel(Dog), + ok. + +package_forms(Config) when is_list(Config) -> + Fs = [{attribute,1,file,{"./p.erl",1}}, + {attribute,1,module,[p,p]}, + {attribute,3,compile,export_all}, + {attribute,1,file, + {"/clearcase/otp/erts/lib/stdlib/include/qlc.hrl",1}}, + {attribute,6,file,{"./p.erl",6}}, + {function,7,q,0, + [{clause,7,[],[], + [{call,8, + {remote,8,{atom,8,qlc},{atom,8,q}}, + [{tuple,-8, + [{atom,-8,qlc_lc}, + {'fun',-8, + {clauses, + [{clause,-8,[],[], + [{tuple,-8, + [{atom,-8,simple_v1}, + {atom,-8,'X'}, + {'fun',-8,{clauses,[{clause,-8,[],[],[{nil,8}]}]}}, + {integer,-8,8}]}]}]}}, + {atom,-8,undefined}]}]}]}]}, + {eof,9}], + {ok,'p.p',_} = compile:forms(Fs, ['S',report]), + ok. + +encrypted_abstr(Config) when is_list(Config) -> + ?line Dog = test_server:timetrap(test_server:minutes(10)), + ?line {Simple,Target} = files(Config, "encrypted_abstr"), + + Res = case has_crypto() of + no -> + %% No crypto. + ?line encrypted_abstr_no_crypto(Simple, Target), + {comment,"The crypto application is missing or broken"}; + yes -> + %% Simulate not having crypto by removing + %% the crypto application from the path. + ?line OldPath = code:get_path(), + try + ?line NewPath = OldPath -- [filename:dirname(code:which(crypto))], + ?line (catch crypto:stop()), + ?line code:delete(crypto), + ?line code:purge(crypto), + ?line code:set_path(NewPath), + ?line encrypted_abstr_no_crypto(Simple, Target) + after + code:set_path(OldPath) + end, + + %% Now run the tests that require crypto. + ?line encrypted_abstr_1(Simple, Target), + ?line ok = file:delete(Target), + ?line ok = file:del_dir(filename:dirname(Target)) + end, + + %% Cleanup. + ?line test_server:timetrap_cancel(Dog), + Res. + +encrypted_abstr_1(Simple, Target) -> + ?line TargetDir = filename:dirname(Target), + ?line Key = "ablurf123BX#$;3", + ?line install_crypto_key(Key), + ?line {ok,simple} = compile:file(Simple, + [debug_info,{debug_info_key,Key}, + {outdir,TargetDir}]), + ?line verify_abstract(Target), + + ?line {ok,simple} = compile:file(Simple, + [{debug_info_key,Key}, + {outdir,TargetDir}]), + ?line verify_abstract(Target), + + ?line {ok,simple} = compile:file(Simple, + [debug_info,{debug_info_key,{des3_cbc,Key}}, + {outdir,TargetDir}]), + ?line verify_abstract(Target), + + ?line {ok,{simple,[{compile_info,CInfo}]}} = + beam_lib:chunks(Target, [compile_info]), + ?line {value,{_,Opts}} = lists:keysearch(options, 1, CInfo), + ?line {value,{_,'********'}} = lists:keysearch(debug_info_key, 1, Opts), + + %% Try some illegal forms of crypto keys. + ?line error = compile:file(Simple, + [debug_info,{debug_info_key,{blurf,"ss"}},report]), + ?line error = compile:file(Simple, + [debug_info,{debug_info_key,{blurf,1,"ss"}},report]), + ?line error = compile:file(Simple, + [debug_info,{debug_info_key,42},report]), + + %% Place the crypto key in .erlang.crypt. + ?line beam_lib:clear_crypto_key_fun(), + ?line {ok,OldCwd} = file:get_cwd(), + ?line ok = file:set_cwd(TargetDir), + + ?line error = compile:file(Simple, [encrypt_debug_info,report]), + + ?line NewKey = "better use another key here", + ?line write_crypt_file(["[{debug_info,des3_cbc,simple,\"",NewKey,"\"}].\n"]), + ?line {ok,simple} = compile:file(Simple, [encrypt_debug_info,report]), + ?line verify_abstract("simple.beam"), + ?line ok = file:delete(".erlang.crypt"), + ?line beam_lib:clear_crypto_key_fun(), + ?line {error,beam_lib,{key_missing_or_invalid,"simple.beam",abstract_code}} = + beam_lib:chunks("simple.beam", [abstract_code]), + ?line ok = file:set_cwd(OldCwd), + ok. + + +write_crypt_file(Contents0) -> + Contents = list_to_binary([Contents0]), + io:format("~s\n", [binary_to_list(Contents)]), + ok = file:write_file(".erlang.crypt", Contents). + +encrypted_abstr_no_crypto(Simple, Target) -> + ?line TargetDir = filename:dirname(Target), + ?line Key = "ablurf123BX#$;3", + ?line error = compile:file(Simple, + [debug_info,{debug_info_key,Key}, + {outdir,TargetDir},report]), + ok. + +verify_abstract(Target) -> + {ok,{simple,[Chunk]}} = beam_lib:chunks(Target, [abstract_code]), + {abstract_code,{raw_abstract_v1,_}} = Chunk. + +has_crypto() -> + try + crypto:start(), + crypto:info(), + crypto:stop(), + yes + catch + error:_ -> no + end. + +install_crypto_key(Key) -> + F = fun (init) -> ok; + ({debug_info,des3_cbc,_,_}) -> Key; + (clear) -> ok + end, + ok = beam_lib:crypto_key_fun(F). + +%% Miscellanous tests, mainly to get better coverage. +cover(Config) when is_list(Config) -> + ?line io:format("~p\n", [compile:options()]), + ok. + +do_listing(Source, TargetDir, Type) -> + do_listing(Source, TargetDir, Type, "." ++ atom_to_list(Type)). + +do_listing(Source, TargetDir, Type, Ext) -> + io:format("Source: ~p TargetDir: ~p\n Type: ~p Ext: ~p\n", + [Source, TargetDir, Type, Ext]), + case compile:file(Source, [Type, time, {outdir, TargetDir}]) of + {ok, _} -> ok; + Other -> test_server:fail({unexpected_result, Other}) + end, + SourceBase = filename:rootname(filename:basename(Source)), + + Target = filename:join(TargetDir, SourceBase ++ Ext), + true = exists(Target). + +files(Config, Name) -> + ?line code:delete(simple), + ?line code:purge(simple), + ?line DataDir = ?config(data_dir, Config), + ?line PrivDir = ?config(priv_dir, Config), + ?line Simple = filename:join(DataDir, "simple"), + ?line TargetDir = filename:join(PrivDir, Name), + ?line ok = file:make_dir(TargetDir), + ?line Target = filename:join(TargetDir, "simple"++code:objfile_extension()), + {Simple, Target}. + + +run(Target, Func, Args) -> + ?line Module = list_to_atom(filename:rootname(filename:basename(Target))), + ?line {module, Module} = code:load_abs(filename:rootname(Target)), + ?line Result = (catch apply(Module, Func, Args)), + ?line true = code:delete(Module), + ?line false = code:purge(Module), + Result. + +exists(Name) -> + case file:read_file_info(Name) of + {ok, _} -> true; + {error, _} -> false + end. + +bad_record_use(suite) -> [bad_record_use1, bad_record_use2]. + +%% Tests that the compiler does not accept +%% bad use of records. +bad_record_use1(Config) when is_list(Config) -> + ?line {ok, Cwd} = file:get_cwd(), + ?line file:set_cwd(?config(data_dir, Config)), + ?line true=exists("bad_record_use.erl"), + ?line Ret=c:c(bad_record_use), + ?line file:set_cwd(Cwd), + ?line error=Ret, + ok. + +%% Tests that the compiler does not accept +%% bad use of records. +bad_record_use2(Config) when is_list(Config) -> + ?line {ok, Cwd} = file:get_cwd(), + ?line file:set_cwd(?config(data_dir, Config)), + ?line true=exists("bad_record_use2.erl"), + ?line Ret=c:c(bad_record_use), + ?line file:set_cwd(Cwd), + ?line error=Ret, + ok. + +strict_record(Config) when is_list(Config) -> + ?line Priv = ?config(priv_dir, Config), + ?line file:set_cwd(?config(data_dir, Config)), + ?line Opts = [{outdir,Priv},report_errors], + M = record_access, + + ?line {ok,M} = c:c(M, [strict_record_tests|Opts]), + ?line Turtle = test_strict(), + + ?line {ok,M} = c:c(M, [no_strict_record_tests|Opts]), + ?line Turtle = test_sloppy(), + + %% The option first given wins. + ?line {ok,M} = c:c(M, [no_strict_record_tests,strict_record_tests|Opts]), + ?line Turtle = test_sloppy(), + ?line {ok,M} = c:c(M, [strict_record_tests,no_strict_record_tests|Opts]), + ?line Turtle = test_strict(), + + %% Default (possibly influenced by ERL_COMPILER_OPTIONS). + ?line {ok,M} = c:c(M, [{outdir,Priv},report_errors]), + ?line try + {1,2} = record_access:test(Turtle), + {comment,"Default: no_strict_record_tests"} + catch + error:{badrecord,tortoise} -> + {comment,"Default: strict_record_tests"} + end. + +test_strict() -> + Turtle = record_access:turtle(), + ?line try + record_access:test(Turtle) + catch + error:{badrecord,tortoise} -> + ok + end, + Turtle. + +test_sloppy() -> + Turtle = record_access:turtle(), + {1,2} = record_access:test(Turtle), + Turtle. + +missing_testheap(Config) when is_list(Config) -> + DataDir = ?config(data_dir, Config), + PrivDir = ?config(priv_dir, Config), + Opts = [{outdir,PrivDir}], + OldPath = code:get_path(), + try + code:add_patha(PrivDir), + c:c(filename:join(DataDir, "missing_testheap1"), Opts), + c:c(filename:join(DataDir, "missing_testheap2"), Opts), + ?line ok = test(fun() -> + missing_testheap1:f({a,self()},{state,true,b}) + end, {a,b}), + ?line ok = test(fun() -> + missing_testheap2:f({a,self()},16#80000000) end, + bigger) + after + code:set_path(OldPath), + file:delete(filename:join(PrivDir, "missing_testheap1.beam")), + file:delete(filename:join(PrivDir, "missing_testheap2.beam")) + end, + ok. + +test(Fun, Result) -> + test(500, Fun, Result, []). + +test(0, _, _, _) -> + ok; +test(Iter, Fun, Result, Filler) -> + spawn(?MODULE, init, [self(), Fun, list_to_tuple(Filler)]), + receive + {result, Result} -> + test(Iter-1, Fun, Result, [0|Filler]); + {result, Other} -> + io:format("Expected ~p; got ~p~n", [Result, Other]), + test_server:fail() + end. + +init(ReplyTo, Fun, _Filler) -> + ReplyTo ! {result, Fun()}. + +env(Config) when is_list(Config) -> + ?line {Simple,Target} = files(Config, "file_1"), + ?line {ok,Cwd} = file:get_cwd(), + ?line ok = file:set_cwd(filename:dirname(Target)), + + true = os:putenv("ERL_COMPILER_OPTIONS", "binary"), + try + env_1(Simple, Target) + after + true = os:putenv("ERL_COMPILER_OPTIONS", "ignore_me"), + file:set_cwd(Cwd), + file:delete(Target), + file:del_dir(filename:dirname(Target)) + end, + ok. + +env_1(Simple, Target) -> + %% file + ?line {ok,simple,<<_/binary>>} = compile:file(Simple), + ?line {ok,simple} = compile:noenv_file(Simple, [debug_info]), + ?line true = exists(Target), + ?line {ok,{simple,[{abstract_code,Abstr0}]}} = + beam_lib:chunks(Target, [abstract_code]), + ?line {raw_abstract_v1,Forms} = Abstr0, + + %% forms + ?line true = os:putenv("ERL_COMPILER_OPTIONS", "strong_validation"), + ?line {ok,simple} = compile:forms(Forms), + ?line {ok,simple,<<"FOR1",_/binary>>} = compile:noenv_forms(Forms, []), + + %% output_generated + ?line false = compile:output_generated([]), + ?line true = compile:noenv_output_generated([]), + + ?line ok = file:delete(Target), + + ok. + +%% Test pretty-printing in Core Erlang format and then try to +%% compile the generated Core Erlang files. + +core(Config) when is_list(Config) -> + ?line Dog = test_server:timetrap(test_server:minutes(5)), + ?line PrivDir = ?config(priv_dir, Config), + ?line Outdir = filename:join(PrivDir, "core"), + ?line ok = file:make_dir(Outdir), + + ?line Wc = filename:join(filename:dirname(code:which(?MODULE)), "*.beam"), + ?line TestBeams = filelib:wildcard(Wc), + ?line Abstr = [begin {ok,{Mod,[{abstract_code, + {raw_abstract_v1,Abstr}}]}} = + beam_lib:chunks(Beam, [abstract_code]), + {Mod,Abstr} end || Beam <- TestBeams], + ?line Res = p_run(fun(F) -> do_core(F, Outdir) end, Abstr), + ?line test_server:timetrap_cancel(Dog), + Res. + + +do_core({M,A}, Outdir) -> + try + {ok,M,Core} = compile:forms(A, [to_core,report]), + CoreFile = filename:join(Outdir, atom_to_list(M)++".core"), + CorePP = core_pp:format(Core), + ok = file:write_file(CoreFile, CorePP), + case compile:file(CoreFile, [clint,from_core,binary]) of + {ok,M,_} -> + ok = file:delete(CoreFile); + Other -> + io:format("*** core_lint failure '~p' for ~s\n", + [Other,CoreFile]), + error + end + catch Class:Error -> + io:format("~p: ~p ~p\n~p\n", + [M,Class,Error,erlang:get_stacktrace()]), + error + end. + +%% Compile to Beam assembly language (.S) and the try to +%% run .S throught the compiler again. + +asm(Config) when is_list(Config) -> + ?line Dog = test_server:timetrap(test_server:minutes(20)), + ?line PrivDir = ?config(priv_dir, Config), + ?line Outdir = filename:join(PrivDir, "asm"), + ?line ok = file:make_dir(Outdir), + + ?line Wc = filename:join(filename:dirname(code:which(?MODULE)), "*.beam"), + ?line TestBeams = filelib:wildcard(Wc), + ?line Res = p_run(fun(F) -> do_asm(F, Outdir) end, TestBeams), + ?line test_server:timetrap_cancel(Dog), + Res. + + +do_asm(Beam, Outdir) -> + {ok,{M,[{abstract_code,{raw_abstract_v1,A}}]}} = + beam_lib:chunks(Beam, [abstract_code]), + try + {ok,M,Asm} = compile:forms(A, ['S']), + AsmFile = filename:join(Outdir, atom_to_list(M)++".S"), + {ok,Fd} = file:open(AsmFile, [write]), + beam_listing:module(Fd, Asm), + ok = file:close(Fd), + case compile:file(AsmFile, [from_asm,no_postopt,binary,report]) of + {ok,M,_} -> + ok = file:delete(AsmFile); + Other -> + io:format("*** failure '~p' for ~s\n", + [Other,AsmFile]), + error + end + catch Class:Error -> + io:format("~p: ~p ~p\n~p\n", + [M,Class,Error,erlang:get_stacktrace()]), + error + end. + +%% p_run(fun() -> ok|error, List) -> ok +%% Will fail the test case if there were any errors. + +p_run(Test, List) -> + N = erlang:system_info(schedulers) + 1, + p_run_loop(Test, List, N, [], 0, 0). + +p_run_loop(_, [], _, [], Errors, Ws) -> + case Errors of + 0 -> + case Ws of + 0 -> ok; + 1 -> {comment,"1 core_lint failure"}; + N -> {comment,integer_to_list(N)++" core_lint failures"} + end; + N -> ?t:fail({N,errors}) + end; +p_run_loop(Test, [H|T], N, Refs, Errors, Ws) when length(Refs) < N -> + {_,Ref} = erlang:spawn_monitor(fun() -> exit(Test(H)) end), + p_run_loop(Test, T, N, [Ref|Refs], Errors, Ws); +p_run_loop(Test, List, N, Refs0, Errors0, Ws0) -> + receive + {'DOWN',Ref,process,_,Res} -> + {Errors,Ws} = case Res of + ok -> {Errors0,Ws0}; + error -> {Errors0+1,Ws0}; + warning -> {Errors0,Ws0+1} + end, + Refs = Refs0 -- [Ref], + p_run_loop(Test, List, N, Refs, Errors, Ws) + end. diff --git a/lib/compiler/test/compile_SUITE_data/bad_record_use.erl b/lib/compiler/test/compile_SUITE_data/bad_record_use.erl new file mode 100644 index 0000000000..c2adbfa8de --- /dev/null +++ b/lib/compiler/test/compile_SUITE_data/bad_record_use.erl @@ -0,0 +1,28 @@ +%% +%% %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% +%% +-module(bad_record_use). +-export([test/0]). + +-record(bad_use, {a=undefined, + b=undefined, + c=undefined}). + +test() -> + NewRecord=#bad_use{a=1, b=2, a=2}. + diff --git a/lib/compiler/test/compile_SUITE_data/bad_record_use2.erl b/lib/compiler/test/compile_SUITE_data/bad_record_use2.erl new file mode 100644 index 0000000000..1de44b2df4 --- /dev/null +++ b/lib/compiler/test/compile_SUITE_data/bad_record_use2.erl @@ -0,0 +1,29 @@ +%% +%% %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% +%% +-module(bad_record_use2). +-export([test/0]). + +-record(bad_use, {a=undefined, + b=undefined, + c=undefined}). + +test() -> + R=#bad_use{a=1, b=2}, + R2=R#bad_use{a=1, b=2, a=2}, + ok. diff --git a/lib/compiler/test/compile_SUITE_data/big.erl b/lib/compiler/test/compile_SUITE_data/big.erl new file mode 100644 index 0000000000..4cd8e15f13 --- /dev/null +++ b/lib/compiler/test/compile_SUITE_data/big.erl @@ -0,0 +1,742 @@ +%% +%% %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(big). +-compile([export_all]). + +compiler_1() -> ok. + +-define(log(Format,Args),mnesia_test_lib:log(Format,Args,?FILE,?LINE)). +-define(warning(Format,Args),?log("<WARNING> " ++ Format,Args)). +-define(error(Format,Args), + mnesia_test_lib:note_error(Format,Args,?FILE,?LINE), + ?log("<ERROR> " ++ Format,Args)). + +-define(match(ExpectedRes,Expr), + fun() -> + AcTuAlReS = (catch (Expr)), + case AcTuAlReS of + ExpectedRes -> + ?log("ok, result as expected: ~p~n",[AcTuAlReS]), + {success,AcTuAlReS}; + _ -> + ?error("actual result was: ~p~n",[AcTuAlReS]), + {fail,AcTuAlReS} + end + end()). + +-define(match_inverse(NotExpectedRes,Expr), + fun() -> + AcTuAlReS = (catch (Expr)), + case AcTuAlReS of + NotExpectedRes -> + ?error("actual result was: ~p~n",[AcTuAlReS]), + {fail,AcTuAlReS}; + _ -> + ?log("ok, result as expected: ~p~n",[AcTuAlReS]), + {success,AcTuAlReS} + end + end()). + +-define(match_receive(ExpectedMsg), + ?match(ExpectedMsg,mnesia_test_lib:pick_msg())). + +%% ExpectedMsgs must be completely bound +-define(match_multi_receive(ExpectedMsgs), + fun() -> + TmPeXpCtEdMsGs = lists:sort(ExpectedMsgs), + ?match(TmPeXpCtEdMsGs, + lists:sort(lists:map(fun(_) -> + mnesia_test_lib:pick_msg() + end, + TmPeXpCtEdMsGs))) + end()). + +-define(setup(), mnesia_test_lib:setup(?FILE,?LINE)). + +-define(start_activities(Nodes), + fun() -> + AcTiViTyPiDs = + lists:map(fun(Node) -> + spawn_link(Node, + mnesia_test_lib, + activity_evaluator, + [self()]) + end, + Nodes), + ?match_multi_receive(AcTiViTyPiDs) + end()). + +-define(start_transactions(Pids), + ?match_multi_receive(lists:map(fun(Pid) -> + Pid ! begin_trans, + {Pid,begin_trans} + end, + Pids))). + +-define(acquire_nodes(N,Nodes), + mnesia_test_lib:acquire_nodes(N,Nodes,?FILE,?LINE)). + + + +%%% Copyright (C) 1996, Ellemtel Telecommunications Systems Laboratories +%%% Author: Hakan Mattsson [email protected] +%%% Purpose: Evil usage of the API +%%% +%%% Invoke all functions in the API and try to cover all legal uses +%%% cases as well the illegal dito. This is a complement to the +%%% other more explicit test cases. +%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% +%%% show/0 +%%% +%%% Prints out the complete test case structure +%%% +%%% show/1 +%%% +%%% Prints out parts of the test case structure +%%% +%%% test/0 +%%% +%%% Run the complete test suite. +%%% Reads Nodes from nodes.profile and starts them if neccessary. +%%% Kills Mnesia and wipes out the Mnesia directories as a starter. +%%% +%%% test/1 +%%% +%%% Run parts of the test suite. +%%% Reads Nodes from nodes.profile and starts them if neccessary. +%%% Kills Mnesia and wipes out the Mnesia directories as a starter. +%%% +%%% test/2 +%%% +%%% Run parts of the test suite on the given Nodes, +%%% assuming that the nodes are up and running. +%%% Kills Mnesia and wipes out the Mnesia directories as a starter. +%%% +%%% test/3 +%%% +%%% Run parts of the test suite on permutations of the given Nodes, +%%% assuming that the nodes are up and running. Uses test/2. +%%% Kills Mnesia and wipes out the Mnesia directories as a starter. +%%% +%%% See the module mnesia_test_lib for further information. +%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +show() -> mnesia_test_lib:show([{?MODULE,all}]). +show(TestCases) -> mnesia_test_lib:show([{?MODULE,TestCases}]). +test() -> mnesia_test_lib:test([{?MODULE,all}]). +test(TestCases) -> mnesia_test_lib:test([{?MODULE,TestCases}]). +test(TestCases,Nodes) -> mnesia_test_lib:test([{?MODULE,TestCases}],Nodes). +test(TestCases,Nodes,Config) -> mnesia_test_lib:test([{?MODULE,TestCases}],Nodes,Config). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +old_all(suite) -> + [ + system_info, table_info, error_description, + db_node_lifecycle, start_and_stop, transaction, checkpoint, backup, + table_lifecycle, replica_management, replica_location, index_lifecycle, + trans_access, dirty_access, table_sync, snmp_access, debug_support + ]. + +trans_access(suite) -> + [ {mnesia_dirty_access_test,all} ]. + +dirty_access(suite) -> + [ {mnesia_trans_access_test,all} ]. + +%% Get meta info about Mnesia +system_info(suite) -> []; +system_info(Nodes) -> + ?match(yes,mnesia:system_info(is_running)), + ?match(Nodes,mnesia:system_info(db_nodes)), + ?match(Nodes,mnesia:system_info(running_db_nodes)), + ?match(true,mnesia:system_info(have_disc)), + ?match(A when atom(A),mnesia:system_info(debug)), + ?match(L when list(L),mnesia:system_info(directory)), + ?match(L when list(L),mnesia:system_info(log_version)), + ?match({_,_},mnesia:system_info(schema_version)), + ?match(L when list(L),mnesia:system_info(tables)), + ?match(L when list(L),mnesia:system_info(local_tables)), + ?match(L when list(L),mnesia:system_info(held_locks)), + ?match(L when list(L),mnesia:system_info(lock_queue)), + ?match(L when list(L),mnesia:system_info(transactions)), + ?match(I when integer(I),mnesia:system_info(transaction_failures)), + ?match(I when integer(I),mnesia:system_info(transaction_commits)), + ?match(I when integer(I),mnesia:system_info(transaction_restarts)), + ?match(L when list(L),mnesia:system_info(checkpoints)), + ?match(A when atom(A),mnesia:system_info(backup_module)), + ?match(true,mnesia:system_info(auto_repair)), + ?match({_,_},mnesia:system_info(dump_log_interval)), + ?match(A when atom(A),mnesia:system_info(dump_log_update_in_place)), + ?match(I when integer(I),mnesia:system_info(transaction_log_writes)), + ?match({'EXIT',{aborted,badarg}},mnesia:system_info(ali_baba)), + done. + +%% Get meta info about table +table_info(suite) -> []; +table_info(Nodes) -> + [Node1,Node2,Node3] = ?acquire_nodes(3,Nodes), + + Tab = table_info, + Type = bag, + ValPos = 3, + Attrs = [k,v], + Arity = length(Attrs) +1, + Schema = [{name,Tab},{type,Type},{attributes,Attrs},{index,[ValPos]}, + {disc_only_copies,[Node1]},{ram_copies,[Node2]},{disc_copies,[Node3]}], + ?match({atomic,ok}, mnesia:create_table(Schema)), + + Size = 10, + Keys = lists:seq(1,Size), + Records = [{Tab,A,7} || A <- Keys], + lists:foreach(fun(Rec) -> ?match(ok,mnesia:dirty_write(Rec)) end,Records), + ?match(Mem when integer(Mem),mnesia:table_info(Tab,memory)), + ?match(Size,mnesia:table_info(Tab,size)), + ?match(Type,mnesia:table_info(Tab,type)), + ?match([Node3],mnesia:table_info(Tab,disc_copies)), + ?match([Node2],mnesia:table_info(Tab,ram_copies)), + ?match([Node1],mnesia:table_info(Tab,disc_only_copies)), + Read = [Node1,Node2,Node3], + ?match(true,lists:member(mnesia:table_info(Tab,where_to_read),Read)), + Write = lists:sort([Node1,Node2,Node3]), + ?match(Write,lists:sort(mnesia:table_info(Tab,where_to_write))), + WriteLock = lists:sort([Node2,Node3]), + ?match([ValPos],mnesia:table_info(Tab,index)), + ?match(Arity,mnesia:table_info(Tab,arity)), + ?match(Attrs,mnesia:table_info(Tab,attributes)), + ?match({Tab,'_','_'},mnesia:table_info(Tab,wild_pattern)), + ?match({atomic,Attrs}, mnesia:transaction(fun() -> + mnesia:table_info(Tab,attributes) end)), + + done. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Add and drop db nodes + +db_node_lifecycle(suite) -> []; +db_node_lifecycle(Nodes) -> + [Node1,Node2] = ?acquire_nodes(2,Nodes), + Tab = db_node_lifecycle, + + Schema = [{name,Tab},{ram_copies,[Node1,Node2]}], + ?match({atomic,ok}, mnesia:create_table(Schema)), + ?match({aborted,active}, rpc:call(Node1,mnesia,del_db_node,[Node2])), + + ?match([], mnesia_test_lib:stop_mnesia(Nodes)), + ?match(ok, mnesia:delete_schema(Nodes)), + ?match({error,_}, mnesia:create_schema(foo)), + ?match({error,_}, mnesia:create_schema([foo])), + ?match({error,_}, mnesia:create_schema([foo@bar])), + ?match({error,_}, mnesia:start()), + + ?match(ok, mnesia:create_schema(Nodes)), + ?match([],mnesia_test_lib:start_mnesia(Nodes)), + ?match({atomic,ok}, rpc:call(Node1,mnesia,del_db_node,[Node2])), + ?match({aborted,no_exists}, rpc:call(Node1,mnesia,del_db_node,[Node2])), + ?match({aborted,no_exists}, rpc:call(Node1,mnesia,del_db_node,[foo])), + ?match({aborted,no_exists}, rpc:call(Node1,mnesia,del_db_node,[foo@bar])), + + ?match([], mnesia_test_lib:stop_mnesia([Node2])), + ?match(ok,mnesia:delete_schema([Node2])), + AddFun = fun() -> ?match({aborted,nested_transaction}, + mnesia:add_db_node(Node2)), ok end, + ?match({atomic,ok},rpc:call(Node1,mnesia,transaction,[AddFun])), + DelFun = fun() -> ?match({aborted,nested_transaction}, + mnesia:del_db_node(Node2)), ok end, + ?match({atomic,ok},rpc:call(Node1,mnesia,transaction,[DelFun])), + + ?match({atomic,ok}, rpc:call(Node1,mnesia,add_db_node,[Node2])), + ?match({aborted,already_exists}, rpc:call(Node1,mnesia,add_db_node,[Node2])), + ?match([],mnesia_test_lib:start_mnesia([Node2])), + ?match({atomic,ok}, mnesia:create_table(Schema)), + done. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Start and stop the system + +start_and_stop(suite) -> []; +start_and_stop(Nodes) -> + [Node1] = ?acquire_nodes(1,Nodes), + + ?match(stopped, rpc:call(Node1,mnesia,stop,[])), + ?match(stopped, rpc:call(Node1,mnesia,stop,[])), + ?match({started,_}, rpc:call(Node1,mnesia,start,[])), + ?match({started,_}, rpc:call(Node1,mnesia,start,[])), + ?match(stopped, rpc:call(Node1,mnesia,stop,[])), + ?match([],mnesia_test_lib:start_mnesia(Nodes)), + done. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Checkpoints and backup management + +checkpoint(suite) -> []; +checkpoint(Nodes) -> + OneNode = ?acquire_nodes(1,Nodes), + checkpoint(OneNode,Nodes), + TwoNodes = ?acquire_nodes(2,Nodes), + checkpoint(TwoNodes,Nodes). + +checkpoint(TabNodes,Nodes) -> + [Node1] = ?acquire_nodes(1,TabNodes), + CreateTab = fun(Type,N,Ns) -> + Tab0 = lists:concat(["local_checkpoint_",Type,N]), + Tab = list_to_atom(Tab0), + Schema = [{name,Tab},{Type,Ns}], + ?match({atomic,ok},mnesia:delete_table(Tab)), + ?match({atomic,ok},mnesia:create_table(Schema)), + Tab + end, + CreateTabs = fun(Type) -> + CreateTab(Type,1,hd(TabNodes)), + CreateTab(Type,2,TabNodes), + CreateTab(Type,3,lists:last(TabNodes)) + end, + Types = [ram_copies,disc_copies,disc_only_copies], + Tabs = lists:append(lists:map(CreateTabs,Types)), + Recs = lists:sort([{T,N,N} || T <- Tabs,N <- lists:seq(1,10)]), + lists:foreach(fun(R) -> ?match(ok,mnesia:dirty_write(R)) end,Recs), + + CpName = a_checkpoint_name, + MinArgs = [{name,CpName},{min,Tabs},{allow_remote,false}], + ?match({ok,CpName,[Node1]}, + rpc:call(Node1,mnesia,activate_checkpoint,[MinArgs])), + ?match(ok,rpc:call(Node1,mnesia,deactivate_checkpoint,[CpName])), + + MaxArgs = [{name,CpName},{max,Tabs},{allow_remote,true}], + ?match({ok,CpName,[Node1]}, + rpc:call(Node1,mnesia,activate_checkpoint,[MaxArgs])), + ?match(ok,rpc:call(Node1,mnesia,deactivate_checkpoint,[CpName])), + + Args = [{name,CpName},{min,Tabs},{allow_remote,false}], + ?match({ok,CpName,[Node1]}, + rpc:call(Node1,mnesia,activate_checkpoint,[Args])), + Recs2 = lists:sort([{T,K,0} || {T,K,_} <- Recs]), + lists:foreach(fun(R) -> ?match(ok,mnesia:dirty_write(R)) end,Recs2), + ?match({atomic,ok},rpc:call(Node1,mnesia,deactivate_checkpoint,[CpName])), + + ?match({error,no_exists},mnesia:deactivate_checkpoint(CpName)), + ?match({error,badarg},mnesia:activate_checkpoint(foo)), + ?match({error,badarg},mnesia:activate_checkpoint([{foo,foo}])), + ?match({error,badarg},mnesia:activate_checkpoint([{max,foo}])), + ?match({error,badarg},mnesia:activate_checkpoint([{min,foo}])), + ?match({error,no_exists},mnesia:activate_checkpoint([{min,[foo@bar]}])), + ?match({error,badarg},mnesia:activate_checkpoint([{allow_remote,foo}])), + + Fun = fun(Tab) -> ?match({atomic,ok},mnesia:delete_table(Tab)) end, + lists:foreach(Fun,Tabs), + done. + +backup(suite) -> + [ + backup_schema, restore_schema, backup_checkpoint, restore_tables + ]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Use and misuse transactions + +transaction(suite) -> []; +transaction(Nodes) -> + [Node1] = ?acquire_nodes(1,Nodes), + ?match({atomic,ali_baba}, mnesia:transaction(fun() -> ali_baba end)), + ?match({aborted,_}, mnesia:transaction(no_fun)), + ?match({aborted,_}, mnesia:transaction(?MODULE,no_fun,[foo])), + + {success,[A,B,C,D,E,F,G,H]} = ?start_activities(lists:duplicate(8,Node1)), + ?start_transactions([A,B,C,D,E,F,G,H]), + + A ! fun() -> mnesia:abort(abort_bad_trans) end, + ?match_receive({A,{aborted,abort_bad_trans}}), + + B ! fun() -> 1 = 2 end, + ?match_receive({B,{aborted,_}}), + + C ! fun() -> throw(throw_bad_trans) end, + ?match_receive({C,{aborted,{throw,throw_bad_trans}}}), + + D ! fun() -> exit(exit_bad_trans) end, + ?match_receive({D,{aborted,exit_bad_trans}}), + + E ! fun() -> exit(normal) end, + ?match_receive({E,{aborted,normal}}), + + F ! fun() -> exit(abnormal) end, + ?match_receive({F,{aborted,abnormal}}), + + G ! fun() -> exit(G,abnormal) end, + ?match_receive({'EXIT',G,abnormal}), + + H ! fun() -> exit(H,kill) end, + ?match_receive({'EXIT',H,killed}), + + ?match({atomic,ali_baba}, + mnesia:transaction(fun() -> ali_baba end,infinity)), + ?match({atomic,ali_baba},mnesia:transaction(fun() -> ali_baba end,1)), + ?match({atomic,ali_baba},mnesia:transaction(fun() -> ali_baba end,0)), + ?match({atomic,ali_baba},mnesia:transaction(fun() -> ali_baba end,-1)), + ?match({atomic,ali_baba},mnesia:transaction(fun() -> ali_baba end,foo)), + Fun = fun() -> ?match({aborted,nested_transaction}, + mnesia:transaction(fun() -> ok end)), ok end, + ?match({atomic,ok},mnesia:transaction(Fun)), + done. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Create and delete tables + +%% Get meta info about table + +replica_location(suite) -> []; +replica_location(Nodes) -> + [Node1,Node2,Node3] = ?acquire_nodes(3,Nodes), + Tab = replica_location, + + %% Create three replicas + Schema = [{name,Tab},{disc_only_copies,[Node1]}, + {ram_copies,[Node2]},{disc_copies,[Node3]}], + ?match({atomic,ok}, mnesia:create_table(Schema)), + mnesia_test_lib:verify_replica_location(Tab,[Node1],[Node2],[Node3],Nodes), + + %% Delete one replica + ?match({atomic,ok}, mnesia:del_table_copy(Tab, Node2)), + mnesia_test_lib:verify_replica_location(Tab,[Node1],[],[Node3],Nodes), + + %% Move one replica + ?match({atomic,ok}, mnesia:move_table_copy(Tab, Node1, Node2)), + mnesia_test_lib:verify_replica_location(Tab,[Node2],[],[Node3],Nodes), + + %% Change replica type + ?match({atomic,ok}, mnesia:change_table_copy_type(Tab, Node2,ram_copies)), + mnesia_test_lib:verify_replica_location(Tab,[],[Node2],[Node3],Nodes), + + done. + +table_lifecycle(suite) -> []; +table_lifecycle(Nodes) -> + [Node1,Node2] = ?acquire_nodes(2,Nodes), + + ?match({atomic,ok}, mnesia:create_table([{type,bag}, + {ram_copies,[Node1]}, + {attributes,[rajtan,tajtan]}, + {name,order_of_args}])), + ?match([],mnesia:dirty_read({order_of_args,4711})), + ?match({atomic,ok}, mnesia:create_table([{name,already_exists}, + {ram_copies,[Node1]}])), + ?match({aborted,already_exists}, + mnesia:create_table([{name,already_exists},{ram_copies,[Node1]}])), + ?match({aborted,not_a_db_node}, + mnesia:create_table([{name,no_node},{ram_copies,[foo]}])), + ?match({aborted,not_a_db_node}, + mnesia:create_table([{name,no_host},{ram_copies,[foo@bar]}])), + ?match({aborted,badarg}, + mnesia:create_table([{name,zero_arity},{attributes,[]}])), + ?match({aborted,badarg}, mnesia:create_table([])), + ?match({aborted,badarg}, mnesia:create_table(atom)), + ?match({aborted,badarg}, + mnesia:create_table({cstruct,table_name_as_atom})), + ?match({aborted,bad_type}, + mnesia:create_table([{name,no_host},{ram_copies,foo}])), + ?match({aborted,bad_type}, + mnesia:create_table([{name,no_host},{disc_only_copies,foo}])), + ?match({aborted,bad_type}, + mnesia:create_table([{name,no_host},{disc_copies,foo}])), + + CreateFun = + fun() -> ?match({aborted,nested_transaction}, + mnesia:create_table([{name,nested_trans}])), ok + end, + ?match({atomic,ok},mnesia:transaction(CreateFun)), + ?match({atomic,ok},mnesia:create_table([{name,remote_tab}, + {ram_copies,[Node2]}])), + + ?match({atomic,ok}, mnesia:create_table([{name,a_brand_new_tab}, + {ram_copies,[Node1]}])), + ?match([],mnesia:dirty_read({a_brand_new_tab,4711})), + ?match({atomic,ok}, mnesia:delete_table(a_brand_new_tab)), + ?match({'EXIT',{aborted,no_exists}}, + mnesia:dirty_read({a_brand_new_tab,4711})), + ?match({aborted,no_exists}, mnesia:delete_table(a_brand_new_tab)), + ?match({aborted,badarg}, mnesia:create_table([])), + + ?match({atomic,ok}, mnesia:create_table([{name,nested_del_trans}, + {ram_copies,[Node1]}])), + DeleteFun = fun() -> ?match({aborted,nested_transaction}, + mnesia:delete_table(nested_del_trans)), ok end, + ?match({atomic,ok}, mnesia:transaction(DeleteFun)), + + ?match({aborted,bad_type}, + mnesia:create_table([{name,create_with_index},{index,2}])), + ?match({aborted,bad_index}, + mnesia:create_table([{name,create_with_index},{index,[-1]}])), + ?match({aborted,bad_index}, + mnesia:create_table([{name,create_with_index},{index,[0]}])), + ?match({aborted,bad_index}, + mnesia:create_table([{name,create_with_index},{index,[1]}])), + ?match({aborted,bad_index}, + mnesia:create_table([{name,create_with_index},{index,[2]}])), + ?match({atomic,ok}, + mnesia:create_table([{name,create_with_index},{index,[3]}, + {ram_copies,[Node1]}])), + done. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Add, drop and move replicas, change storage types +%% Change table layout (only arity change supported) + +replica_management(suite) -> []; +replica_management(Nodes) -> + %% add_table_copy/3, del_table_copy/2, move_table_copy/3, + %% change_table_copy_type/3, transform_table/3 + + [Node1,Node2,Node3] = ?acquire_nodes(3,Nodes), + + Tab = replica_management, + Attrs = [k,v], + + %% + %% Add, delete and change replicas + %% + ?match({atomic,ok}, + mnesia:create_table([{name,Tab},{attributes,Attrs}, + {ram_copies,[Node1]}])), + mnesia_test_lib:verify_replica_location(Tab,[],[Node1],[],Nodes), + %% R - - + ?match({aborted,combine_error}, + mnesia:add_table_copy(Tab, Node2, disc_copies)), + ?match({aborted,combine_error}, + mnesia:change_table_copy_type(Tab, Node1, disc_copies)), + ?match({atomic,ok}, mnesia:del_table_copy(Tab,Node1)), + mnesia_test_lib:verify_replica_location(Tab,[],[],[],Nodes), + %% - - - + ?match({aborted,no_exists}, + mnesia:add_table_copy(Tab, Node3, ram_copies)), + + ?match({atomic,ok}, mnesia:create_table([{name,Tab}, + {attributes,Attrs}, + {disc_copies,[Node1]}])), + mnesia_test_lib:verify_replica_location(Tab,[],[],[Node1],Nodes), + %% D - - + ?match({aborted,badarg}, + mnesia:add_table_copy(Tab, Node2, bad_storage_type)), + ?match({atomic,ok}, mnesia:add_table_copy(Tab, Node2, disc_only_copies)), + mnesia_test_lib:verify_replica_location(Tab,[Node2],[],[Node1],Nodes), + %% D DO - + ?match({atomic,ok}, mnesia:add_table_copy(Tab, Node3, ram_copies)), + mnesia_test_lib:verify_replica_location(Tab,[Node2],[Node3],[Node1],Nodes), + %% D DO R + ?match({atomic,ok}, + mnesia:change_table_copy_type(Tab, Node1, disc_only_copies)), + mnesia_test_lib:verify_replica_location(Tab,[Node1,Node2],[Node3],[],Nodes), + %% DO DO R + ?match({aborted,already_exists}, + mnesia:add_table_copy(Tab, Node3, ram_copies)), + ?match({atomic,ok}, mnesia:del_table_copy(Tab, Node1)), + mnesia_test_lib:verify_replica_location(Tab,[Node2],[Node3],[],Nodes), + %% - DO R + ?match({aborted,_}, mnesia:del_table_copy(Tab, Node1)), + ?match({atomic,ok}, mnesia:add_table_copy(Tab, Node1, disc_copies)), + mnesia_test_lib:verify_replica_location(Tab,[Node2],[Node3],[Node1],Nodes), + %% D DO R + ?match({atomic,ok}, + mnesia:change_table_copy_type(Tab, Node3, disc_only_copies)), + mnesia_test_lib:verify_replica_location(Tab,[Node2,Node3],[],[Node1],Nodes), + %% D DO DO + ?match({atomic,ok}, mnesia:del_table_copy(Tab, Node2)), + mnesia_test_lib:verify_replica_location(Tab,[Node3],[],[Node1],Nodes), + %% D - DO + ?match({aborted,already_exists}, + mnesia:change_table_copy_type(Tab, Node1, disc_copies)), + + %% + %% Move replica + %% + ?match({atomic,ok}, mnesia:move_table_copy(Tab,Node1,Node2)), + mnesia_test_lib:verify_replica_location(Tab,[Node3],[],[Node2],Nodes), + %% - D DO + ?match({aborted,_}, mnesia:move_table_copy(Tab,Node1,Node2)), + ?match([], mnesia_test_lib:stop_mnesia([Node3])), + mnesia_test_lib:verify_replica_location(Tab,[Node3],[],[Node2], + Nodes -- [Node3]), + %% - D DO + ?match({atomic,ok}, mnesia:move_table_copy(Tab,Node3,Node1)), + mnesia_test_lib:verify_replica_location(Tab,[Node1],[],[Node2], + Nodes -- [Node3]), + %% DO D - + ?match([],mnesia_test_lib:start_mnesia([Node3])), + mnesia_test_lib:verify_replica_location(Tab,[Node1],[],[Node2],Nodes), + %% DO D - + + %% + %% Transformer + %% + + NewAttrs = Attrs ++ [extra], + Transformer = + fun(Rec) -> list_to_tuple(tuple_to_list(Rec) ++ [initial_value]) end, + ?match({atomic,ok}, mnesia:transform_table(Tab, Transformer,NewAttrs)), + ?match({atomic,ok}, mnesia:transform_table(Tab, fun(R) -> R end, Attrs)), + ?match({aborted,bad_type}, mnesia:transform_table(Tab, Transformer, 0)), + ?match({aborted,bad_type}, mnesia:transform_table(Tab, Transformer, -1)), + ?match({aborted,badarg}, mnesia:transform_table(Tab, Transformer, [])), + ?match({aborted,bad_type}, mnesia:transform_table(Tab, no_fun, NewAttrs)), + + NestedFun = + fun() -> + ?match({aborted,_}, + mnesia:move_table_copy(Tab,Node1,Node2)), + ?match({aborted,_}, + mnesia:add_table_copy(Tab,Node1,ram_copies)), + ?match({aborted,_}, + mnesia:del_table_copy(Tab,Node1)), + T = fun(_) -> 4711 end, + ?match({aborted,_}, + mnesia:transform_table(Tab,Transformer, T)), + ok + end, + ?match({atomic,ok},mnesia:transaction(NestedFun)), + done. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Add and drop indecies + +index_lifecycle(suite) -> + [ add_table_index, create_live_table_index, del_table_index ]. + +%% Add table index + +add_table_index(suite) -> []; +add_table_index(Nodes) -> + [Node1] = ?acquire_nodes(1,Nodes), + Tab = add_table_index, + Schema = [{name,Tab},{attributes,[k,v]},{ram_copies,[Node1]}], + ?match({atomic,ok}, mnesia:create_table(Schema)), + ValPos = 3, + BadValPos = ValPos + 1, + ?match({aborted,bad_index}, mnesia:add_table_index(Tab,BadValPos)), + ?match({aborted,bad_index}, mnesia:add_table_index(Tab,2)), + ?match({aborted,bad_index}, mnesia:add_table_index(Tab,1)), + ?match({aborted,bad_index}, mnesia:add_table_index(Tab,0)), + ?match({aborted,bad_index}, mnesia:add_table_index(Tab,-1)), + ?match({atomic,ok}, mnesia:add_table_index(Tab,ValPos)), + ?match({aborted,already_exists}, mnesia:add_table_index(Tab,ValPos)), + + NestedFun = fun() -> + ?match({aborted,nested_transaction}, + mnesia:add_table_index(Tab,ValPos)), + + ok + end, + ?match({atomic,ok},mnesia:transaction(NestedFun)), + done. + +create_live_table_index(suite) -> []; +create_live_table_index(Nodes) -> + [Node1] = ?acquire_nodes(1,Nodes), + Tab = create_live_table_index, + Schema = [{name,Tab},{attributes,[k,v]},{ram_copies,[Node1]}], + ?match({atomic,ok}, mnesia:create_table(Schema)), + ValPos = 3, + mnesia:dirty_write({Tab,1,2}), + + Fun = fun() -> + ?match(ok, mnesia:write({Tab,2,2})), + ok + end, + ?match({atomic,ok},mnesia:transaction(Fun)), + ?match({atomic,ok}, mnesia:add_table_index(Tab,ValPos)), + done. + +%% Drop table index + +del_table_index(suite) ->[]; +del_table_index(Nodes) -> + [Node1] = ?acquire_nodes(1,Nodes), + Tab = del_table_index, + Schema = [{name,Tab},{attributes,[k,v]},{ram_copies,[Node1]}], + ?match({atomic,ok}, mnesia:create_table(Schema)), + ValPos = 3, + BadValPos = ValPos + 1, + ?match({atomic,ok}, mnesia:add_table_index(Tab,ValPos)), + ?match({aborted,no_exists}, + mnesia:del_table_index(Tab,BadValPos)), + ?match({atomic,ok}, mnesia:del_table_index(Tab,ValPos)), + + NestedFun = + fun() -> + ?match({aborted,nested_transaction}, + mnesia:del_table_index(Tab,ValPos)), + ok + end, + ?match({atomic,ok},mnesia:transaction(NestedFun)), + done. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Syncronize table with log or disc +%% +table_sync(suite) -> + [ dump_tables, dump_log, change_dump_log_config, wait_for_tables, force_load_table ]. + +%% Dump ram tables on disc +dump_tables(suite) -> []; +dump_tables(Nodes) -> + [Node1,Node2] = ?acquire_nodes(2,Nodes), + Tab = dump_tables, + Schema = [{name,Tab},{attributes,[k,v]},{ram_copies,[Node2]}], + ?match({atomic,ok}, mnesia:create_table(Schema)), + + %% Dump 10 records + Size = 10, + Keys = lists:seq(1,Size), + Records = [{Tab,A,7} || A <- Keys], + lists:foreach(fun(Rec) -> ?match(ok,mnesia:dirty_write(Rec)) end,Records), + AllKeys = fun() -> lists:sort(mnesia:all_keys(Tab)) end, + + ?match({atomic,Keys}, mnesia:transaction(AllKeys)), + ?match(ok, mnesia:dump_tables(Tab)), + + %% Delete one record + ?match(ok,mnesia:dirty_delete({Tab,5})), + Keys2 = lists:delete(5,Keys), + ?match({atomic,Keys2}, mnesia:transaction(AllKeys)), + + %% Check that all 10 is restored after a stop + ?match([], mnesia_test_lib:stop_mnesia([Node1,Node2])), + ?match([],mnesia_test_lib:start_mnesia([Node1,Node2])), + ?match(ok,mnesia:wait_for_tables([Tab],infinity)), + ?match({atomic,Keys}, mnesia:transaction(AllKeys)), + + ?match(ok, mnesia:dump_tables([foo])), + done. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Make Mnesia table accessible via SNMP + +snmp_access(suite) -> + [ + snmp_open_table, snmp_close_table, + snmp_get_row, snmp_get_next_index, snmp_get_mnesia_key + ]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Check that the debug support has not decayed + +debug_support(suite) -> + [ info, schema, schema, kill, lkill ]. + diff --git a/lib/compiler/test/compile_SUITE_data/include/simple.hrl b/lib/compiler/test/compile_SUITE_data/include/simple.hrl new file mode 100644 index 0000000000..cbe6e4f1a4 --- /dev/null +++ b/lib/compiler/test/compile_SUITE_data/include/simple.hrl @@ -0,0 +1,19 @@ +%% +%% %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% +%% +-define(included_value, hiker). diff --git a/lib/compiler/test/compile_SUITE_data/missing_testheap1.erl b/lib/compiler/test/compile_SUITE_data/missing_testheap1.erl new file mode 100644 index 0000000000..65ee11541d --- /dev/null +++ b/lib/compiler/test/compile_SUITE_data/missing_testheap1.erl @@ -0,0 +1,35 @@ +%% +%% %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% +%% +-module(missing_testheap1). + +-compile(export_all). +%%-export([Function/Arity, ...]). +-record(state,{e1,e2}). + +f({a,DpId},State) when State == +#state{e1=true, + e2=a} -> + {a,a}; + +f({a,DpId},State) when State == +#state{e1=true, + e2=b} -> + {a,b}. + + diff --git a/lib/compiler/test/compile_SUITE_data/missing_testheap2.erl b/lib/compiler/test/compile_SUITE_data/missing_testheap2.erl new file mode 100644 index 0000000000..014210fa5a --- /dev/null +++ b/lib/compiler/test/compile_SUITE_data/missing_testheap2.erl @@ -0,0 +1,29 @@ +%% +%% %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% +%% +-module(missing_testheap2). + +-compile(export_all). + +f({a,DpId},16#7fffffff) -> + big; + +f({a,DpId},16#80000000) -> + bigger. + + diff --git a/lib/compiler/test/compile_SUITE_data/record_access.erl b/lib/compiler/test/compile_SUITE_data/record_access.erl new file mode 100644 index 0000000000..c89f9ad7c7 --- /dev/null +++ b/lib/compiler/test/compile_SUITE_data/record_access.erl @@ -0,0 +1,29 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2005-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(record_access). +-export([turtle/0,test/1]). + +-record(turtle, {a,b,c}). +-record(tortoise, {a,b,c}). + +turtle() -> + #turtle{a=1,b=2,c=3}. + +test(T) -> + {T#tortoise.a,T#tortoise.b}. diff --git a/lib/compiler/test/compile_SUITE_data/simple.erl b/lib/compiler/test/compile_SUITE_data/simple.erl new file mode 100644 index 0000000000..2021056388 --- /dev/null +++ b/lib/compiler/test/compile_SUITE_data/simple.erl @@ -0,0 +1,39 @@ +%% +%% %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(simple). + +-export([test/0]). + +-ifdef(need_foo). +-export([foo/0]). +-endif. + +test() -> + passed. + +%% Conditional inclusion. +%% Compile with [{d, need_foo}, {d, foo_value, 42}]. + +-ifdef(need_foo). +-include("simple.hrl"). + +foo() -> + {?included_value, ?foo_value}. + +-endif. diff --git a/lib/compiler/test/compile_SUITE_data/wrong_module_name.erl b/lib/compiler/test/compile_SUITE_data/wrong_module_name.erl new file mode 100644 index 0000000000..ea437556a4 --- /dev/null +++ b/lib/compiler/test/compile_SUITE_data/wrong_module_name.erl @@ -0,0 +1,23 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 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(arne). +-export([?MODULE/0]). + +?MODULE() -> + ok. diff --git a/lib/compiler/test/compiler.cover b/lib/compiler/test/compiler.cover new file mode 100644 index 0000000000..5ec2408a35 --- /dev/null +++ b/lib/compiler/test/compiler.cover @@ -0,0 +1,3 @@ +%% -*- erlang -*- +{exclude,[sys_pre_attributes,core_parse]}. + diff --git a/lib/compiler/test/compiler.dynspec b/lib/compiler/test/compiler.dynspec new file mode 100644 index 0000000000..7e452cef6c --- /dev/null +++ b/lib/compiler/test/compiler.dynspec @@ -0,0 +1,10 @@ +%% -*- erlang -*- +%% You can test this file using this command. +%% file:script("compiler.dynspec", [{'Os',"Unix"}]). + +case Os of + "VxWorks" -> + [{skip,{compile_SUITE,listings,"VxWorks filesystem too slow"}}]; + _ -> + [] +end. diff --git a/lib/compiler/test/core_SUITE.erl b/lib/compiler/test/core_SUITE.erl new file mode 100644 index 0000000000..54cf799057 --- /dev/null +++ b/lib/compiler/test/core_SUITE.erl @@ -0,0 +1,59 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2006-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(core_SUITE). + +-export([all/1,init_per_testcase/2,fin_per_testcase/2, + dehydrated_itracer/1,nested_tries/1]). + +-include("test_server.hrl"). + +-define(comp(N), + N(Config) when is_list(Config) -> try_it(N, Config)). + +init_per_testcase(Case, Config) when is_atom(Case), is_list(Config) -> + Dog = test_server:timetrap(?t:minutes(5)), + [{watchdog,Dog}|Config]. + +fin_per_testcase(Case, Config) when is_atom(Case), is_list(Config) -> + Dog = ?config(watchdog, Config), + ?t:timetrap_cancel(Dog), + ok. + +all(suite) -> + test_lib:recompile(?MODULE), + [dehydrated_itracer,nested_tries]. + +?comp(dehydrated_itracer). +?comp(nested_tries). + +try_it(Mod, Conf) -> + ?line Src = filename:join(?config(data_dir, Conf), atom_to_list(Mod)), + ?line Out = ?config(priv_dir,Conf), + ?line io:format("Compiling: ~s\n", [Src]), + ?line CompRc0 = compile:file(Src, [from_core,{outdir,Out},report,time]), + ?line io:format("Result: ~p\n",[CompRc0]), + ?line {ok,Mod} = CompRc0, + + ?line {module,Mod} = code:load_abs(filename:join(Out, Mod)), + ?line ok = Mod:Mod(), + ok. + + + + diff --git a/lib/compiler/test/core_SUITE_data/dehydrated_itracer.core b/lib/compiler/test/core_SUITE_data/dehydrated_itracer.core new file mode 100644 index 0000000000..e64e981edc --- /dev/null +++ b/lib/compiler/test/core_SUITE_data/dehydrated_itracer.core @@ -0,0 +1,99 @@ +module 'dehydrated_itracer' ['dehydrated_itracer'/0, + 'module_info'/0, + 'module_info'/1] + attributes [] +'dehydrated_itracer'/0 = + %% Line 5 + fun () -> + case <> of + <> when 'true' -> + %% Line 6 + case apply 'itracer'/0 + () of + <{'vector',65536}> when 'true' -> + %% Line 7 + 'ok' + ( <_cor0> when 'true' -> + primop 'match_fail' + ({'badmatch',_cor0}) + -| ['compiler_generated'] ) + end + ( <> when 'true' -> + primop 'match_fail' + ({'function_clause'}) + -| ['compiler_generated'] ) + end +'itracer'/0 = + %% Line 8 + fun () -> + let <Dir> = + %% Line 9 + apply 'vcreate'/3 + (0, 0, 256) + in %% Line 10 + apply 'initialize'/1 + (Dir) +'initialize'/1 = + %% Line 12 + fun (_cor0) -> + %% Line 23 + case _cor0 of + <{'vector',_pre0}> when 'true' -> + let <_cor4> = + call 'erlang':'*' + (_pre0, 2) + in let <Up2> = {'vector',_cor4} + in case Up2 of + <{'vector',_pre0}> when 'true' -> + let <_cor4> = + call 'erlang':'*' + (_pre0, -1) + in let <Down> = {'vector',_cor4} + in case _cor0 of +%%% The case would be optimized away, and pre0 would be used directly, +%%% only it would be the wrong pre0. + <{'vector',_pre0}> when 'true' -> + let <_cor4> = + call 'erlang':'*' + (_pre0, 256) + in {'vector',_cor4} + <_cor7> when 'true' -> + call 'erlang':'error' + ({'badrecord','vector'}) + end + <_cor7> when 'true' -> + call 'erlang':'error' + ({'badrecord','vector'}) + end + <_cor7> when 'true' -> + call 'erlang':'error' + ({'badrecord','vector'}) + end +'vcreate'/3 = + %% Line 19 + fun (_cor2,_cor1,_cor0) -> + %% Line 20 + {'vector',_cor0} +'mul'/2 = + %% Line 22 + fun (_cor1,_cor0) -> + %% Line 23 + case _cor0 of + <{'vector',_pre0}> when 'true' -> + let <_cor4> = + call 'erlang':'*' + (_pre0, _cor1) + in {'vector',_cor4} + <_cor7> when 'true' -> + call 'erlang':'error' + ({'badrecord','vector'}) + end +'module_info'/0 = + fun () -> + call 'erlang':'get_module_info' + ('dehydrated_itracer') +'module_info'/1 = + fun (_cor0) -> + call 'erlang':'get_module_info' + ('dehydrated_itracer', _cor0) +end
\ No newline at end of file diff --git a/lib/compiler/test/core_SUITE_data/nested_tries.core b/lib/compiler/test/core_SUITE_data/nested_tries.core new file mode 100644 index 0000000000..d9010b808b --- /dev/null +++ b/lib/compiler/test/core_SUITE_data/nested_tries.core @@ -0,0 +1,36 @@ +module 'nested_tries' ['nested_tries'/0, 'reg'/2] + attributes [] + +'nested_tries'/0 = + fun () -> 'ok' + +'reg'/2 = + fun (_cor1,_cor0) -> + let <_X_var__238> = 1 + in case %% Line 4 + <_cor1,_cor0> of + <Id,Pid> + when call 'erlang':'and' + (try 'true' + of <_X_var__235> -> _X_var__235 + catch <_X_var__236,_X_var__237> -> 'false', + try + let <_cor2> = + try + call 'erlang':'and' + ('true', + call 'erlang':'is_integer'(call 'erlang':'element'(3, Pid))) + of <_X_var__232> -> _X_var__232 + catch <_X_var__233,_X_var__234> -> 'false' + in let <_cor4> = call 'erlang':'element'(2, Pid) + in let <_cor3> = _X_var__238 + in let <_cor5> = call 'erlang':'=='(_cor4, _cor3) + in call 'erlang':'and'(_cor2, _cor5) + of <Try> -> Try + catch <T,R> -> 'false') -> 'true' + <_cor7,_cor6> when 'true' -> + primop 'match_fail' + ({( 'function_clause' + -| [{'name',{'reg',2}}] ),_cor7,_cor6}) + end +end diff --git a/lib/compiler/test/core_fold_SUITE.erl b/lib/compiler/test/core_fold_SUITE.erl new file mode 100644 index 0000000000..5f2c905d4a --- /dev/null +++ b/lib/compiler/test/core_fold_SUITE.erl @@ -0,0 +1,233 @@ +%% +%% %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(core_fold_SUITE). + +-export([all/1, + t_element/1,setelement/1,t_length/1,append/1,t_apply/1,bifs/1, + eq/1,nested_call_in_case/1,coverage/1]). + +-export([foo/0,foo/1,foo/2,foo/3]). + +-include("test_server.hrl"). + +all(suite) -> + test_lib:recompile(?MODULE), + [t_element,setelement,t_length,append,t_apply,bifs, + eq,nested_call_in_case,coverage]. + +t_element(Config) when is_list(Config) -> + X = make_ref(), + ?line X = id(element(1, {X,y,z})), + ?line b = id(element(2, {a,b,c,d})), + + %% No optimization, but should work. + Tuple = id({x,y,z}), + Pos = id(3), + ?line x = id(element(1, Tuple)), + ?line c = id(element(Pos, {a,b,c,d})), + ?line X = id(element(Pos, {a,b,X,d})), + ?line z = id(element(Pos, Tuple)), + + %% Calls that will fail. + ?line {'EXIT',{badarg,_}} = (catch element(5, {a,b,c,d})), + ?line {'EXIT',{badarg,_}} = (catch element(5, {a,b,X,d})), + ?line {'EXIT',{badarg,_}} = (catch element(5.0, {a,b,X,d})), + case id({a,b,c}) of + {_,_,_}=Tup -> + ?line {'EXIT',{badarg,_}} = (catch element(4, Tup)) + end, + + ok. + +setelement(Config) when is_list(Config) -> + X = id(b), + New = id([1,2,3]), + ?line {y,b,c} = id(setelement(1, {a,b,c}, y)), + ?line {y,b,c} = id(setelement(1, {a,X,c}, y)), + ?line {a,y,c} = id(setelement(2, {a,X,c}, y)), + ?line {a,[1,2,3],c} = id(setelement(2, {a,b,c}, New)), + ?line {a,[1,2,3],c} = id(setelement(2, {a,X,c}, New)), + ?line {a,b,[1,2,3]} = id(setelement(3, {a,b,c}, New)), + ?line {a,b,[1,2,3]} = id(setelement(3, {a,X,c}, New)), + + ?line {'EXIT',{badarg,_}} = (catch setelement_crash({a,b,c,d,e,f})), + ?line error = setelement_crash_2({a,b,c,d,e,f}, <<42>>), + ok. + +setelement_crash(Tuple) -> + %% Used to crash the compiler because sys_core_dsetel did not notice that + %% X1 was used in bit syntax construction. + X1 = setelement(5, Tuple, new), + X2 = setelement(3, X1, new), + {X2,<<X1>>}. + +setelement_crash_2(Tuple, Bin) -> + %% Used to crash the compiler because sys_core_dsetel did not notice that + %% X1 was used as a size field in bit syntax matching. + X1 = setelement(5, Tuple, new), + X2 = setelement(3, X1, new), + case Bin of + <<42:X1>> -> X2; + _ -> error + end. + +t_length(Config) when is_list(Config) -> + Blurf = id({blurf,a,b}), + Tail = id([42,43,44,45]), + ?line 0 = id(length([])), + ?line 1 = id(length([x])), + ?line 2 = id(length([x,Blurf])), + ?line 4 = id(length([x,Blurf,a,b])), + + %% No or partial optimization. + ?line 4 = length(Tail), + ?line 5 = id(length([x|Tail])), + + %% Will fail. + ?line {'EXIT',{badarg,_}} = (catch id(length([a,b|c]))), + ?line {'EXIT',{badarg,_}} = (catch id(length([a,Blurf|c]))), + ?line {'EXIT',{badarg,_}} = (catch id(length(atom))), + + ok. + +-define(APPEND(A, B), (fun(Res) -> + Res = lists:append(A, B), + Res = erlang:append(A, B), + Res = erlang:'++'(A, B) + end)(A++B)). + +append(Config) when is_list(Config) -> + A = id(0), + ?line [a,b,c,d,e,f,g,h,i,j,k] = id(?APPEND([a,b,c,d,e,f],[g,h,i,j,k])), + ?line [a,b,c,d,e] = id(?APPEND([a,b,c],id([d,e]))), + ?line [0,1,2,3,4,5,6] = id(?APPEND([A,1,2,3],[4,5,6])), + ?line {'EXIT',{badarg,_}} = (catch id(?APPEND([A|blurf],[4,5,6]))), + ok. + +t_apply(Config) when is_list(Config) -> + ?line ok = apply(?MODULE, foo, []), + ?line 4 = apply(?MODULE, foo, [3]), + ?line 7 = apply(?MODULE, foo, [3,4]), + ?line 12 = apply(?MODULE, foo, [id(8),4]), + ?line 21 = apply(?MODULE, foo, [8,id(9),4]), + ?line 20 = apply(?MODULE, foo, [8,8,id(4)]), + ?line 24 = apply(?MODULE, foo, [id(10),10,4]), + + M = id(?MODULE), + ?line ok = apply(M, foo, []), + ?line 4 = apply(M, foo, [3]), + ?line 16.0 = apply(M, foo, [12.0,4]), + + %% Will fail. + ?line {'EXIT',{badarg,_}} = (catch apply([a,b,c], foo, [])), + ?line {'EXIT',{badarg,_}} = (catch apply(42, foo, [])), + ?line {'EXIT',{badarg,_}} = (catch apply(?MODULE, 45, [xx])), + ?line {'EXIT',{badarg,_}} = (catch apply(?MODULE, foo, {a,b})), + ?line {'EXIT',{badarg,_}} = (catch apply(M, M, [1009|10010])), + ?line {'EXIT',{badarg,_}} = (catch apply(?MODULE, foo, [10000|9999])), + ?line {'EXIT',{badarg,_}} = (catch apply(?MODULE, foo, a)), + + ok. + +foo() -> + ok. + +foo(A) -> + A+1. + +foo(A, B) -> + A + B. + +foo(A, B, C) -> + A + B + C. + +bifs(Config) when is_list(Config) -> + ?line <<1,2,3,4>> = id(list_to_binary([1,2,3,4])), + ok. + +-define(CMP_SAME(A0, B), (fun(A) -> true = A == B, false = A /= B end)(id(A0))). +-define(CMP_DIFF(A0, B), (fun(A) -> false = A == B, true = A /= B end)(id(A0))). + +eq(Config) when is_list(Config) -> + ?line ?CMP_SAME([a,b,c], [a,b,c]), + ?line ?CMP_SAME([42.0], [42.0]), + ?line ?CMP_SAME([42], [42]), + ?line ?CMP_SAME([42.0], [42]), + + ?line ?CMP_DIFF(a, [a]), + ?line ?CMP_DIFF(a, {1,2,3}), + + ok. + +%% OTP-7117. +nested_call_in_case(Config) when is_list(Config) -> + ?line PrivDir = ?config(priv_dir, Config), + ?line Dir = filename:dirname(code:which(?MODULE)), + ?line Core = filename:join(Dir, "nested_call_in_case"), + ?line Opts = [from_core,{outdir,PrivDir}|test_lib:opt_opts(?MODULE)], + ?line io:format("~p", [Opts]), + ?line {ok,Mod} = c:c(Core, Opts), + ?line yes = Mod:a([1,2,3], 2), + ?line no = Mod:a([1,2,3], 4), + ?line {'EXIT',_} = (catch Mod:a(not_a_list, 42)), + ok. + +coverage(Config) when is_list(Config) -> + ?line {'EXIT',{{case_clause,{a,b,c}},_}} = + (catch cover_will_match_list_type({a,b,c})), + ?line {'EXIT',{{case_clause,{a,b,c,d}},_}} = + (catch cover_will_match_list_type({a,b,c,d})), + ?line a = cover_remove_non_vars_alias({a,b,c}), + ?line error = cover_will_match_lit_list(), + + %% Make sure that we don't attempt to make literals + %% out of pids. (Putting a pid into a #c_literal{} + %% would crash later compiler passes.) + case list_to_pid("<0.42.0>") of + Pid when is_pid(Pid) -> ok + end, + ok. + +cover_will_match_list_type(A) -> + case A of + {a,_,_} -> %Set type of A to {a,_,_}. + case A of + {a,_,_,_} -> ok %Compare type and pattern. + end + end. + +%% Make sure the remove_non_vars/4 can handle aliases in the type argument. +cover_remove_non_vars_alias(X) -> + case X of + {a=Y,_,_} -> %Set type of A to {a=Y,_,_}. + case X of + {_,_,_} -> %Compare type and pattern. + Y + end + end. + +cover_will_match_lit_list() -> + case {1,2,3} of %Literal case expression. + {_,$A,$A} -> %Pattern that does not match. + ok; + _ -> + error + end. + +id(I) -> I. diff --git a/lib/compiler/test/error_SUITE.erl b/lib/compiler/test/error_SUITE.erl new file mode 100644 index 0000000000..477730c3ac --- /dev/null +++ b/lib/compiler/test/error_SUITE.erl @@ -0,0 +1,114 @@ +%% +%% %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% +%% +-module(error_SUITE). + +-include("test_server.hrl"). + +-export([all/1, + head_mismatch_line/1,r11b_binaries/1]). + +all(suite) -> + test_lib:recompile(?MODULE), + [head_mismatch_line,r11b_binaries]. + +%% Tests that a head mismatch is reported on the correct line (OTP-2125). +head_mismatch_line(Config) when is_list(Config) -> + ?line [E|_] = get_compilation_errors(Config, "head_mismatch_line"), + ?line {26, Mod, Reason} = E, + ?line Mod:format_error(Reason), + ok. + +%% Compiles a test file and returns the list of errors. + +get_compilation_errors(Config, Filename) -> + ?line DataDir = ?config(data_dir, Config), + ?line File = filename:join(DataDir, Filename), + ?line {error, [{_Name, E}|_], []} = compile:file(File, [return_errors]), + E. + +r11b_binaries(Config) when is_list(Config) -> + Ts = [{r11b_binaries, + <<" + t1(Bin) -> + case Bin of + _ when size(Bin) > 20 -> erlang:error(too_long); + <<_,T/binary>> -> t1(T); + <<>> -> ok + end. + + t2(<<_,T/bytes>>) -> + split_binary(T, 4). + + t3(X) -> + <<42,X/binary>>. + + t4(X) -> + <<N:32>> = X, + N. + ">>, + [r11], + {error, + [{5,v3_core,no_binaries}, + {6,v3_core,no_binaries}, + {9,v3_core,no_binaries}, + {13,v3_core,no_binaries}, + {16,v3_core,no_binaries}], + []} }], + ?line [] = run(Config, Ts), + ok. + + +run(Config, Tests) -> + F = fun({N,P,Ws,E}, BadL) -> + case catch run_test(Config, P, Ws) of + E -> + BadL; + Bad -> + ?t:format("~nTest ~p failed. Expected~n ~p~n" + "but got~n ~p~n", [N, E, Bad]), + fail() + end + end, + lists:foldl(F, [], Tests). + + +%% Compiles a test module and returns the list of errors and warnings. + +run_test(Conf, Test0, Warnings) -> + Filename = 'errors_test.erl', + ?line DataDir = ?config(priv_dir, Conf), + ?line Test = ["-module(errors_test). ", Test0], + ?line File = filename:join(DataDir, Filename), + ?line Opts = [binary,export_all,return|Warnings], + ?line ok = file:write_file(File, Test), + + %% Compile once just to print all errors and warnings. + ?line compile:file(File, [binary,export_all,report|Warnings]), + + %% Test result of compilation. + ?line Res = case compile:file(File, Opts) of + {error,[{_File,Es}],Ws} -> + {error,Es,Ws} + end, + file:delete(File), + Res. + +fail() -> + io:format("failed~n"), + ?t:fail(). diff --git a/lib/compiler/test/error_SUITE_data/head_mismatch_line.erl b/lib/compiler/test/error_SUITE_data/head_mismatch_line.erl new file mode 100644 index 0000000000..619c1329a4 --- /dev/null +++ b/lib/compiler/test/error_SUITE_data/head_mismatch_line.erl @@ -0,0 +1,30 @@ +%% +%% %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% +%% +-module(head_mismatch_line). + +-export([foo/1, bar/2]). + +foo(a) -> + ok; + +bar(x) -> % The mismatch should be here. + ok; +bar(y) -> + ok. + diff --git a/lib/compiler/test/float_SUITE.erl b/lib/compiler/test/float_SUITE.erl new file mode 100644 index 0000000000..3d2dbf47e9 --- /dev/null +++ b/lib/compiler/test/float_SUITE.erl @@ -0,0 +1,120 @@ +%% +%% %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(float_SUITE). +-export([all/1,pending/1,bif_calls/1,math_functions/1,mixed_float_and_int/1]). + +-include("test_server.hrl"). + +all(suite) -> + test_lib:recompile(?MODULE), + [pending,bif_calls,math_functions,mixed_float_and_int]. + +%% Thanks to Tobias Lindahl <[email protected]> +%% Shows the effect of pending exceptions on the x86. + +pending(Config) when is_list(Config) -> + ?line case catch float_mul(1, 1.1e300, 3.14e300) of + {'EXIT',{badarith,_}} -> ok; + Other -> ?t:fail({expected_exception,Other}) + end, + ?line 0.0 = float_sub(2.0). + +float_sub(A)-> + catch A - 2.0. + +float_mul(0, _, _)-> + ok; +float_mul(Iter, A, B) when is_float(A), is_float(B) -> + A*B, + float_mul(Iter-1, A, B). + +%% Thanks to Mikael Pettersson and Tobias Lindahl (HiPE). + +bif_calls(Config) when is_list(Config) -> + ?line {'EXIT',{badarith,_}} = (catch bad_arith(2.0, 1.7)), + ?line {'EXIT',{badarith,_}} = (catch bad_arith_again(2.0, [])), + ?line {'EXIT',{badarith,_}} = (catch bad_arith_xor(2.0, [])), + ?line {'EXIT',{badarith,_}} = (catch bad_arith_hd(2.0, [])), + ?line {'EXIT',{badarith,_}} = (catch bad_negate(2.0, 1.7)), + ok. + +bad_arith(X, Y) when is_float(X) -> + X1 = X * 1.7e+308, + X2 = X1 + 1.0, + Y1 = Y * 2, %Calls erts_mixed_times/2. + %(A BIF call.) + {X2, Y1}. + +bad_arith_xor(X, Y) when is_float(X) -> + X1 = X * 1.7e+308, + Y1 = Y xor true, %A failing BIF call. + {X1 + 1.0, Y1}. + +bad_arith_hd(X, Y) when is_float(X) -> + X1 = X * 1.7e+308, + Y1 = hd(Y), %A failing BIF call. + {X1 + 1.0, Y1}. + +bad_arith_again(X, Y) when is_float(X) -> + X1 = X * 1.7e+308, + Y1 = element(1, Y), %A failing BIF call. + {X1 + 1.0, Y1}. + +bad_negate(X, Y) when is_float(X) -> + X1 = X * 1.7e+308, + X2 = X1 + 1.0, + Y1 = -Y, %BIF call. + {X2, Y1}. + +math_functions(Config) when is_list(Config) -> + %% Mostly silly coverage. + ?line 0.0 = math:tan(0), + ?line 0.0 = math:atan2(0, 1), + ?line 0.0 = math:sinh(0), + ?line 1.0 = math:cosh(0), + ?line 0.0 = math:tanh(0), + ?line 1.0 = math:log10(10), + ?line -1.0 = math:cos(math:pi()), + ?line 1.0 = math:exp(0), + ?line 1.0 = math:pow(math:pi(), 0), + + ?line 0.0 = math:tan(id(0)), + ?line 0.0 = math:atan2(id(0), 1), + ?line 0.0 = math:sinh(id(0)), + ?line 1.0 = math:cosh(id(0)), + ?line 0.0 = math:tanh(id(0)), + ?line 1.0 = math:log10(id(10)), + ?line 1.0 = math:exp(id(0)), + + %% Only for coverage (of beam_type.erl). + ?line {'EXIT',{undef,_}} = (catch math:fnurfla(0)), + ?line {'EXIT',{undef,_}} = (catch math:fnurfla(0, 0)), + ?line {'EXIT',{badarg,_}} = (catch float(kalle)), + ?line {'EXIT',{badarith,_}} = (catch name/1), + ok. + +mixed_float_and_int(Config) when is_list(Config) -> + ?line 129.0 = pc(77, 23, 5), + ok. + +pc(Cov, NotCov, X) -> + round(Cov/(Cov+NotCov)*100) + 42 + 2.0*X. + +id(I) -> I. + diff --git a/lib/compiler/test/fun_SUITE.erl b/lib/compiler/test/fun_SUITE.erl new file mode 100644 index 0000000000..fb2667245a --- /dev/null +++ b/lib/compiler/test/fun_SUITE.erl @@ -0,0 +1,136 @@ +%% +%% %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% +%% +-module(fun_SUITE). + +-export([all/1, + test1/1,overwritten_fun/1,otp_7202/1,bif_fun/1]). + +-include("test_server.hrl"). + +all(suite) -> + test_lib:recompile(?MODULE), + [test1,overwritten_fun,otp_7202,bif_fun]. + +%%% The help functions below are copied from emulator:bs_construct_SUITE. + +-define(T(B, L), {B, ??B, L}). + +l1() -> + [ + ?T((begin A = 3, F = fun(A) -> 1; (_) -> 2 end, F(2) end), 1), + ?T((begin G = fun(1=0) -> ok end, {'EXIT',_} = (catch G(2)), ok end), ok) + ]. + +test1(suite) -> []; +test1(Config) when is_list(Config) -> + ?line lists:foreach(fun one_test/1, eval_list(l1(), [])), + ok. + +evaluate(Str, Vars) -> + {ok,Tokens,_} = + erl_scan:string(Str ++ " . "), + {ok, [Expr]} = erl_parse:parse_exprs(Tokens), + case erl_eval:expr(Expr, Vars) of + {value, Result, _} -> + Result + end. + +eval_list([], _Vars) -> + []; +eval_list([{C_bin, Str, Bytes} | Rest], Vars) -> + case catch evaluate(Str, Vars) of + {'EXIT', Error} -> + io:format("Evaluation error: ~p, ~p, ~p~n", [Str, Vars, Error]), + exit(Error); + E_bin -> + [{C_bin, E_bin, Str, Bytes} | eval_list(Rest, Vars)] + end. + +one_test({C, E, Str, Correct}) -> + io:format(" ~s, ~p~n", [Str, Correct]), + if + C == Correct -> + ok; + true -> + io:format("ERROR: Compiled: ~p. Expected ~p. Got ~p.~n", + [Str, Correct, C]), + test_server:fail(comp) + end, + if + E == Correct -> + ok; + true -> + io:format("ERROR: Interpreted: ~p. Expected ~p. Got ~p.~n", + [Str, Correct, E]), + test_server:fail(comp) + end. + +-record(b, {c}). + +%% OTP-7102. (Thanks to Simon Cornish.) + +overwritten_fun(Config) when is_list(Config) -> + ?line {a2,a} = overwritten_fun_1(a), + ?line {a2,{b,c}} = overwritten_fun_1(#b{c=c}), + ?line one = overwritten_fun_1(#b{c=[]}), + ok. + +overwritten_fun_1(A) -> + F = fun() -> + {ok, A} + end, + if A#b.c == [] -> + one; + true -> + case F() of + {ok, A2} -> + {a2, A2}; + _ -> + three + end + end. + +%% OTP-7202. The liveness calculation for the make_fun2 instruction was wrong. + +otp_7202(Config) when is_list(Config) -> + otp_7202(). + +otp_7202() -> + List = [a], + Error = case otp_7202_func() of + no_value -> true; + {ok, V} -> V + end, + lists:foreach(fun(_E) -> + case Error of + true -> + ok; + false -> + ok + end + end, List). + +otp_7202_func() -> + no_value. + +bif_fun(Config) when is_list(Config) -> + ?line F = fun abs/1, + ?line 5 = F(-5), + ok. + diff --git a/lib/compiler/test/guard_SUITE.erl b/lib/compiler/test/guard_SUITE.erl new file mode 100644 index 0000000000..5ae41f13e7 --- /dev/null +++ b/lib/compiler/test/guard_SUITE.erl @@ -0,0 +1,1376 @@ +%% +%% %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% +%% +-module(guard_SUITE). + +-include("test_server.hrl"). + +-export([all/1, + misc/1,const_cond/1,basic_not/1,complex_not/1,nested_nots/1, + semicolon/1,complex_semicolon/1,comma/1, + or_guard/1,more_or_guards/1, + complex_or_guards/1,and_guard/1, + xor_guard/1,more_xor_guards/1, + old_guard_tests/1, + build_in_guard/1,gbif/1, + t_is_boolean/1,is_function_2/1, + tricky/1,rel_ops/1,literal_type_tests/1, + basic_andalso_orelse/1,traverse_dcd/1, + check_qlc_hrl/1,andalso_semi/1,tuple_size/1]). + +all(suite) -> + test_lib:recompile(?MODULE), + [misc,const_cond,basic_not,complex_not,nested_nots, + semicolon,complex_semicolon, + comma,or_guard,more_or_guards, + complex_or_guards,and_guard, + xor_guard,more_xor_guards, + build_in_guard,old_guard_tests,gbif, + t_is_boolean,is_function_2,tricky,rel_ops,literal_type_tests, + basic_andalso_orelse,traverse_dcd,check_qlc_hrl,andalso_semi, + tuple_size]. + +misc(Config) when is_list(Config) -> + ?line 42 = case id(42) of + X when -X -> ok; + X -> X + end, + ?line {a,b,c} = misc_1([{{a,b,c}},{[4]},{[3]},{-2}]), + ?line none = misc_1([{{a,b,c}},{[4]},{[3]},{-3}]), + ?line none = misc_1([{{a,b,c}},{[4]},{[7]},{-2}]), + ?line none = misc_1([{{a,b,c}},{[4]},{[3]},{[1,2,3]}]), + + ?line {ok,buf,<<>>} = get_data({o,true,raw}, 0, buf), + ?line {ok,buf,<<>>} = get_data({o,true,raw}, 42, buf), + ?line {ok,buf,<<>>} = get_data({o,false,raw}, 0, buf), + ?line error = get_data({o,false,raw}, 42, buf), + ?line {ok,buf,<<>>} = get_data({o,true,0}, 0, buf), + ?line {ok,buf,<<>>} = get_data({o,true,0}, 42, buf), + ?line {ok,buf,<<>>} = get_data({o,false,0}, 0, buf), + ?line error = get_data({o,false,0}, 42, buf), + ok. + + +misc_1([{W},{X},{Y},{Z}]) -> + if + X > Y andalso abs(Z) =:= 2 -> + id(W); + true -> + none + end. + +get_data({o,Active,Raw}, BytesToRead, Buffer) + when Raw =:= raw; Raw =:= 0 -> + if + Active =/= false orelse BytesToRead =:= 0 -> + {ok,Buffer,<<>>}; + true -> + error + end. + +const_cond(Config) when is_list(Config) -> + ?line ok = const_cond({}, 0), + ?line ok = const_cond({a}, 1), + ?line error = const_cond({a,b}, 3), + ?line error = const_cond({a}, 0), + ?line error = const_cond({a,b}, 1), + ok. + +const_cond(T, Sz) -> + case T of + _X when false -> never; + _X when tuple(T), eq == eq, tuple_size(T) == Sz -> ok; + _X when tuple(T), eq == leq, tuple_size(T) =< Sz -> ok; + _X -> error + end. + +basic_not(Config) when is_list(Config) -> + True = id(true), + False = id(false), + Glurf = id(glurf), + A = id(5), + B = id(37.5), + C = id(-1), + D = id(5), + ATuple = {False,True,Glurf}, + + ?line check(fun() -> if not false -> ok; true -> error end end, ok), + ?line check(fun() -> if not true -> ok; true -> error end end, error), + ?line check(fun() -> if not False -> ok; true -> error end end, ok), + ?line check(fun() -> if not True -> ok; true -> error end end, error), + + ?line check(fun() -> if A > B -> gt; A < B -> lt; A == B -> eq end end, lt), + ?line check(fun() -> if A > C -> gt; A < C -> lt; A == C -> eq end end, gt), + ?line check(fun() -> if A > D -> gt; A < D -> lt; A == D -> eq end end, eq), + + ?line check(fun() -> if not (7 > 453) -> le; not (7 < 453) -> ge; + not (7 == 453) -> ne; true -> eq end end, le), + ?line check(fun() -> if not (7 > -8) -> le; not (7 < -8) -> ge; + not (7 == -8) -> ne; true -> eq end end, ge), + ?line check(fun() -> if not (7 > 7) -> le; not (7 < 7) -> ge; + not (7 == 7) -> ne; true -> eq end end, le), + + ?line check(fun() -> if not (A > B) -> le; not (A < B) -> ge; + not (A == B) -> ne; true -> eq end end, le), + ?line check(fun() -> if not (A > C) -> le; not (A < C) -> ge; + not (A == C) -> ne; true -> eq end end, ge), + ?line check(fun() -> if not (A > D) -> le; not (A < D) -> ge; + not (A == D) -> ne; true -> eq end end, le), + + ?line check(fun() -> if not element(1, ATuple) -> ok; true -> error end end, ok), + ?line check(fun() -> if not element(2, ATuple) -> ok; true -> error end end, error), + ?line check(fun() -> if not element(3, ATuple) -> ok; true -> error end end, error), + + ?line check(fun() -> if not glurf -> ok; true -> error end end, error), + ?line check(fun() -> if not Glurf -> ok; true -> error end end, error), + + ok. + +complex_not(Config) when is_list(Config) -> + ATuple = id({false,true,gurka}), + ?line check(fun() -> if not(element(1, ATuple)) -> ok; true -> error end end, ok), + ?line check(fun() -> if not(element(2, ATuple)) -> ok; true -> error end end, error), + + ?line check(fun() -> if not(element(3, ATuple) == gurka) -> ok; + true -> error end end, error), + ?line check(fun() -> if not(element(3, ATuple) =/= gurka) -> ok; + true -> error end end, ok), + + ?line check(fun() -> if {a,not(element(2, ATuple))} == {a,false} -> ok; + true -> error end end, ok), + ?line check(fun() -> if {a,not(element(1, ATuple))} == {a,false} -> ok; + true -> error end end, error), + + ?line check(fun() -> if not(element(1, ATuple) or element(3, ATuple)) -> ok; + true -> error end end, error), + + %% orelse + ?line check(fun() -> if not(element(1, ATuple) orelse element(3, ATuple)) -> ok; + true -> error end end, error), + + ok. + +nested_nots(Config) when is_list(Config) -> + ?line true = nested_not_1(0, 0), + ?line true = nested_not_1(0, 1), + ?line true = nested_not_1(a, b), + ?line true = nested_not_1(10, 0), + ?line false = nested_not_1(z, a), + ?line false = nested_not_1(3.4, {anything,goes}), + ?line false = nested_not_1(3.4, atom), + ?line true = nested_not_1(3.0, [list]), + + ?line true = nested_not_2(false, false, 42), + ?line true = nested_not_2(false, true, 42), + ?line true = nested_not_2(true, false, 42), + ?line true = nested_not_2(true, true, 42), + ?line true = nested_not_2(false, false, atom), + ?line false = nested_not_2(false, true, atom), + ?line false = nested_not_2(true, false, atom), + ?line false = nested_not_2(true, true, atom), + ok. + +nested_not_1(X, Y) when not (((X>Y) or not(is_atom(X))) and + (is_atom(Y) or (X==3.4))) -> + true; +nested_not_1(_, _) -> + false. + +nested_not_2(X, Y, Z) -> + nested_not_2(X, Y, Z, true). + +nested_not_2(X, Y, Z, True) + when not(True and not((not(X) and not(Y)) or not(is_atom(Z)))) -> + true; +nested_not_2(_, _, _, _) -> + false. + +semicolon(Config) when is_list(Config) -> + + %% True/false combined using ';' (literal atoms). + + ?line check(fun() -> if true; false -> ok end end, ok), + ?line check(fun() -> if false; true -> ok end end, ok), + ?line check(fun() -> if true; true -> ok end end, ok), + ?line check(fun() -> if false; false -> ok; true -> error end end, error), + ?line check(fun() -> + {'EXIT',{if_clause,_}} = (catch if false; false -> ok end), + exit + end, exit), + + %% True/false combined used ';'. + + True = id(true), + False = id(false), + + ?line check(fun() -> if True; False -> ok end end, ok), + ?line check(fun() -> if False; True -> ok end end, ok), + ?line check(fun() -> if True; True -> ok end end, ok), + ?line check(fun() -> if False; False -> ok; true -> error end end, error), + ?line check(fun() -> + {'EXIT',{if_clause,_}} = (catch if False; False -> ok end), + exit + end, exit), + + %% Combine true/false with a non-boolean value. + Glurf = id(glurf), + + + ?line check(fun() -> if True; Glurf -> ok end end, ok), + ?line check(fun() -> if Glurf; True -> ok end end, ok), + ?line check(fun() -> if Glurf; Glurf -> ok; true -> error end end, error), + ?line check(fun() -> if False; Glurf -> ok; true -> error end end, error), + ?line check(fun() -> if Glurf; False -> ok; true -> error end end, error), + ?line check(fun() -> + {'EXIT',{if_clause,_}} = (catch if Glurf; Glurf -> ok end), + exit + end, exit), + + %% Combine true/false with errors. + + ATuple = id({false,true,gurka}), + + ?line check(fun() -> if True; element(42, ATuple) -> ok end end, ok), + ?line check(fun() -> if element(42, ATuple); True -> ok end end, ok), + ?line check(fun() -> if element(42, ATuple); element(42, ATuple) -> ok; + true -> error end end, error), + ?line check(fun() -> if False; element(42, ATuple) -> ok; + true -> error end end, error), + ?line check(fun() -> if element(42, ATuple); + False -> ok; true -> error end end, error), + ?line check(fun() -> + {'EXIT',{if_clause,_}} = + (catch if element(42, ATuple); + element(42, ATuple) -> ok end), + exit + end, exit), + + ok. + +complex_semicolon(Config) when is_list(Config) -> + ?line ok = csemi1(int, {blurf}), + ?line ok = csemi1(string, {blurf}), + ?line ok = csemi1(float, [a]), + ?line error = csemi1(35, 42), + + %% 2 + ?line ok = csemi2({}, {a,b,c}), + ?line ok = csemi2({1,3.5}, {a,b,c}), + ?line ok = csemi2(dum, {a,b,c}), + + ?line ok = csemi2({45,-19.3}, {}), + ?line ok = csemi2({45,-19.3}, {dum}), + ?line ok = csemi2({45,-19.3}, {dum,dum}), + + ?line error = csemi2({45}, {dum}), + ?line error = csemi2([], {dum}), + ?line error = csemi2({dum}, []), + ?line error = csemi2([], []), + + %% 3 + ?line csemi3(fun csemi3a/4), + ?line csemi3(fun csemi3b/4), + ?line csemi3(fun csemi3c/4), + + %% 4 + ?line csemi4(fun csemi4a/4), + ?line csemi4(fun csemi4b/4), + ?line csemi4(fun csemi4c/4), + ?line csemi4(fun csemi4d/4), + + %% 4, 'orelse' instead of 'or' + ?line csemi4_orelse(fun csemi4_orelse_a/4), + ?line csemi4_orelse(fun csemi4_orelse_b/4), + ?line csemi4_orelse(fun csemi4_orelse_c/4), + ?line csemi4_orelse(fun csemi4_orelse_d/4), + + %% 5 + ?line error = csemi5(0, 0), + ?line ok = csemi5(5, 0), + ?line ok = csemi5(4, -4), + ?line ok = csemi5(10, -4), + + %% 6 + ?line error = csemi6({a}, 0), + ?line ok = csemi6({a,b}, 0), + ?line ok = csemi6({}, 3), + ?line ok = csemi6({a,b,c}, 3), + + ok. + +csemi1(Type, Val) when is_list(Val), Type == float; + Type == int; Type == string -> ok; +csemi1(_, _) -> error. + +csemi2(A, B) when tuple_size(A) > 1; tuple_size(B) > 2 -> ok; +csemi2(_, _) -> error. + +csemi3(Csemi3) -> + ok = Csemi3({}, {a,b,c}, [0], [0]), + ok = Csemi3({1,3.5}, {a,b,c}, -1, -1), + ok = Csemi3(dum, {a,b,c}, 0.0, 0.0), + ok = Csemi3(dum, {c}, b, a), + ok = Csemi3(dum, <<1,2,3>>, 0.0, 0.0), + ok = Csemi3(<<3.5/float>>, {a,b,c}, -1, -1), + + ok = Csemi3({45,-19.3}, {}, [], []), + ok = Csemi3({45,-19.3}, {dum}, 42, 42), + ok = Csemi3({45,-19.3}, {dum,dum}, 33, 33), + + ok = Csemi3({45}, {dum}, 1.0, 0), + ok = Csemi3([a], {dum}, 1.0, 0), + ok = Csemi3({dum}, [], 1.0, 0), + ok = Csemi3([], [], 1.0, 0), + ok = Csemi3(blurf, {dum}, 1.0, 0), + ok = Csemi3({a}, blurf, 1.0, 0), + ok = Csemi3([a], [dum], 1.0, 0), + ok = Csemi3({dum}, [], 1.0, 0), + ok = Csemi3([], [], 1.0, 0), + + error = Csemi3({45}, {dum}, 0, 0), + error = Csemi3([a], {dum}, 0, 0), + error = Csemi3({dum}, [], 0, 0), + error = Csemi3([], [], 0, 0), + + ok. + +csemi3a(A, B, X, Y) when X > Y; size(A) > 1; size(B) > 2 -> ok; +csemi3a(_, _, _, _) -> error. + +csemi3b(A, B, X, Y) when size(A) > 1; X > Y; size(B) > 2 -> ok; +csemi3b(_, _, _, _) -> error. + +csemi3c(A, B, X, Y) when size(A) > 1; size(B) > 2; X > Y -> ok; +csemi3c(_, _, _, _) -> error. + + +csemi4(Test) -> + ok = Test({a,b}, 2, {c,d}, 2), + ok = Test({1,2,3}, 0, [], 0), + ok = Test({}, 2, blurf, 0), + ok = Test({}, 2, {1}, 2), + + error = Test([], 4, {}, 0), + error = Test({}, 0, [a,b], 4), + error = Test({}, 0, [a,b], 0), + error = Test([], 0, {}, 0), + error = Test({}, 0, {}, 0), + + ok. + +csemi4a(A, X, B, Y) when (tuple_size(A) > 1) or (X > 1); + (tuple_size(B) > 1) or (Y > 1) -> ok; +csemi4a(_, _, _, _) -> error. + +csemi4b(A, X, B, Y) when (X > 1) or (tuple_size(A) > 1); + (tuple_size(B) > 1) or (Y > 1) -> ok; +csemi4b(_, _, _, _) -> error. + +csemi4c(A, X, B, Y) when (tuple_size(A) > 1) or (X > 1); + (Y > 1) or (tuple_size(B) > 1) -> ok; +csemi4c(_, _, _, _) -> error. + +csemi4d(A, X, B, Y) when (X > 1) or (tuple_size(A) > 1); + (Y > 1) or (tuple_size(B) > 1) -> ok; +csemi4d(_, _, _, _) -> error. + + +csemi4_orelse(Test) -> + ok = Test({a,b}, 2, {c,d}, 2), + ok = Test({1,2,3}, 0, [], 0), + ok = Test({}, 2, blurf, 0), + ok = Test({}, 2, {1}, 2), + + ?line error = Test([], 1, {}, 0), + + ok. + +csemi4_orelse_a(A, X, B, Y) when (tuple_size(A) > 1) orelse (X > 1); + (tuple_size(B) > 1) orelse (Y > 1) -> ok; +csemi4_orelse_a(_, _, _, _) -> error. + +csemi4_orelse_b(A, X, B, Y) when (X > 1) orelse (tuple_size(A) > 1); + (tuple_size(B) > 1) orelse (Y > 1) -> ok; +csemi4_orelse_b(_, _, _, _) -> error. + +csemi4_orelse_c(A, X, B, Y) when (tuple_size(A) > 1) orelse (X > 1); + (Y > 1) orelse (tuple_size(B) > 1) -> ok; +csemi4_orelse_c(_, _, _, _) -> error. + +csemi4_orelse_d(A, X, B, Y) when (X > 1) or (tuple_size(A) > 1); + (Y > 1) or (tuple_size(B) > 1) -> ok; +csemi4_orelse_d(_, _, _, _) -> error. + +csemi5(A, B) when hd([A+B]) > 1; abs(B) > 2 -> ok; +csemi5(_, _) -> error. + +csemi6(A, B) when hd([tuple_size(A)]) > 1; abs(B) > 2 -> ok; +csemi6(_, _) -> error. + +comma(Config) when is_list(Config) -> + + %% ',' combinations of literal true/false. + + ?line check(fun() -> if true, false -> ok; true -> error end end, error), + ?line check(fun() -> if false, true -> ok; true -> error end end, error), + ?line check(fun() -> if true, true -> ok end end, ok), + ?line check(fun() -> if false, false -> ok; true -> error end end, error), + ?line check(fun() -> + {'EXIT',{if_clause,_}} = + (catch if true, false -> ok; + false, true -> ok; + false, false -> ok + end), + exit + end, exit), + + %% ',' combinations of true/false in variables. + + True = id(true), + False = id(false), + + ?line check(fun() -> if True, False -> ok; true -> error end end, error), + ?line check(fun() -> if False, True -> ok; true -> error end end, error), + ?line check(fun() -> if True, True -> ok end end, ok), + ?line check(fun() -> if False, False -> ok; true -> error end end, error), + ?line check(fun() -> + {'EXIT',{if_clause,_}} = + (catch if True, False -> ok; + False, True -> ok; + False, False -> ok + end), + exit + end, exit), + + %% ',' combinations of true/false, and non-boolean in variables. + + Glurf = id(glurf), + + ?line check(fun() -> if True, Glurf -> ok; true -> error end end, error), + ?line check(fun() -> if Glurf, True -> ok; true -> error end end, error), + ?line check(fun() -> if True, True -> ok end end, ok), + ?line check(fun() -> if Glurf, Glurf -> ok; true -> error end end, error), + ?line check(fun() -> + {'EXIT',{if_clause,_}} = + (catch if True, Glurf -> ok; + Glurf, True -> ok; + Glurf, Glurf -> ok + end), + exit + end, exit), + + %% ',' combinations of true/false with errors. + ATuple = id({a,b,c}), + + ?line check(fun() -> if True, element(42, ATuple) -> ok; + true -> error end end, error), + ?line check(fun() -> if element(42, ATuple), True -> ok; + true -> error end end, error), + ?line check(fun() -> if True, True -> ok end end, ok), + ?line check(fun() -> if element(42, ATuple), element(42, ATuple) -> ok; + true -> error end end, error), + ?line check(fun() -> + {'EXIT',{if_clause,_}} = + (catch if True, element(42, ATuple) -> ok; + element(42, ATuple), True -> ok; + element(42, ATuple), element(42, ATuple) -> ok + end), + exit + end, exit), + + ok. + +or_guard(Config) when is_list(Config) -> + True = id(true), + False = id(false), + Glurf = id(glurf), + + %% 'or' combinations of literal true/false. + ?line check(fun() -> if true or false -> ok end end, ok), + ?line check(fun() -> if false or true -> ok end end, ok), + ?line check(fun() -> if true or true -> ok end end, ok), + ?line check(fun() -> if false or false -> ok; true -> error end end, error), + + ?line check(fun() -> if glurf or true -> ok; true -> error end end, error), + ?line check(fun() -> if true or glurf -> ok; true -> error end end, error), + ?line check(fun() -> if glurf or glurf -> ok; true -> error end end, error), + + ?line check(fun() -> + {'EXIT',{if_clause,_}} = (catch if false or false -> ok end), + exit + end, exit), + + + %% 'or' combinations using variables containing true/false. + ?line check(fun() -> if True or False -> ok end end, ok), + ?line check(fun() -> if False or True -> ok end end, ok), + ?line check(fun() -> if True or True -> ok end end, ok), + ?line check(fun() -> if False or False -> ok; true -> error end end, error), + + ?line check(fun() -> if True or Glurf -> ok; true -> error end end, error), + ?line check(fun() -> if Glurf or True -> ok; true -> error end end, error), + ?line check(fun() -> if Glurf or Glurf -> ok; true -> error end end, error), + + ?line check(fun() -> + {'EXIT',{if_clause,_}} = (catch if False or False -> ok end), + exit + end, exit), + + ok. + +more_or_guards(Config) when is_list(Config) -> + True = id(true), + False = id(false), + ATuple = id({false,true,gurka}), + + ?line check(fun() -> + if element(42, ATuple) or False -> ok; + true -> error end + end, error), + + ?line check(fun() -> + if False or element(42, ATuple) -> ok; + true -> error end + end, error), + + ?line check(fun() -> + if element(18, ATuple) or element(42, ATuple) -> ok; + true -> error end + end, error), + + ?line check(fun() -> + if True or element(42, ATuple) -> ok; + true -> error end + end, error), + + ?line check(fun() -> + if element(42, ATuple) or True -> ok; + true -> error end + end, error), + + ?line check(fun() -> + if element(1, ATuple) or element(42, ATuple) or True -> ok; + true -> error end + end, error), + + ?line check(fun() -> + if element(1, ATuple) or True or element(42, ATuple) -> ok; + true -> error end + end, error), + + ?line check(fun() -> + if + (<<False:8>> == <<0>>) or element(2, ATuple) -> ok; + true -> error end + end, error), + + ?line check(fun() -> + if + element(2, ATuple) or (<<True:8>> == <<1>>) -> ok; + true -> error end + end, error), + + ?line check(fun() -> + if element(2, ATuple) or element(42, ATuple) -> ok; + true -> error end + end, error), + + ?line check(fun() -> + if + element(1, ATuple) or + element(2, ATuple) or + element(19, ATuple) -> ok; + true -> error end + end, error), + ok. + +complex_or_guards(Config) when is_list(Config) -> + %% complex_or_1/2 + ?line ok = complex_or_1({a,b,c,d}, {1,2,3}), + ?line ok = complex_or_1({a,b,c,d}, {1}), + ?line ok = complex_or_1({a}, {1,2,3}), + ?line error = complex_or_1({a}, {1}), + + ?line error = complex_or_1(1, 2), + ?line error = complex_or_1([], {a,b,c,d}), + ?line error = complex_or_1({a,b,c,d}, []), + + + %% complex_or_2/1 + ?line ok = complex_or_2({true,{}}), + ?line ok = complex_or_2({false,{a}}), + ?line ok = complex_or_2({false,{a,b,c}}), + ?line ok = complex_or_2({true,{a,b,c,d}}), + + ?line error = complex_or_2({blurf,{a,b,c}}), + + ?line error = complex_or_2({true}), + ?line error = complex_or_2({true,no_tuple}), + ?line error = complex_or_2({true,[]}), + + %% complex_or_3/2 + ?line ok = complex_or_3({true}, {}), + ?line ok = complex_or_3({false}, {a}), + ?line ok = complex_or_3({false}, {a,b,c}), + ?line ok = complex_or_3({true}, {a,b,c,d}), + ?line ok = complex_or_3({false}, <<1,2,3>>), + ?line ok = complex_or_3({true}, <<1,2,3,4>>), + + ?line error = complex_or_3(blurf, {a,b,c}), + + ?line error = complex_or_3({false}, <<1,2,3,4>>), + ?line error = complex_or_3([], <<1,2>>), + ?line error = complex_or_3({true}, 45), + ?line error = complex_or_3(<<>>, <<>>), + + %% complex_or_4/2 + ?line ok = complex_or_4(<<1,2,3>>, {true}), + ?line ok = complex_or_4(<<1,2,3>>, {false}), + ?line ok = complex_or_4(<<1,2,3>>, {true}), + ?line ok = complex_or_4({1,2,3}, {true}), + ?line error = complex_or_4({1,2,3,4}, {false}), + + ?line error = complex_or_4(<<1,2,3,4>>, []), + ?line error = complex_or_4([], {true}), + + %% complex_or_5/2 + ?line ok = complex_or_5(<<1>>, {false}), + ?line ok = complex_or_5(<<1,2,3>>, {true}), + ?line ok = complex_or_5(<<1,2,3,4>>, {false}), + ?line ok = complex_or_5({1,2,3}, {false}), + ?line ok = complex_or_5({1,2,3,4}, {false}), + + ?line error = complex_or_5(blurf, {false}), + ?line error = complex_or_5(<<1>>, klarf), + ?line error = complex_or_5(blurf, klarf), + + %% complex_or_6/2 + ?line ok = complex_or_6({true,true}, {1,2,3,4}), + ?line ok = complex_or_6({true,true}, <<1,2,3,4>>), + ?line ok = complex_or_6({false,false}, <<1,2,3,4>>), + ?line ok = complex_or_6({false,true}, <<1>>), + ?line ok = complex_or_6({true,false}, {1}), + ?line ok = complex_or_6({true,true}, {1}), + + ?line error = complex_or_6({false,false}, {1}), + + ?line error = complex_or_6({true}, {1,2,3,4}), + ?line error = complex_or_6({}, {1,2,3,4}), + ?line error = complex_or_6([], {1,2,3,4}), + ?line error = complex_or_6([], {1,2,3,4}), + ?line error = complex_or_6({true,false}, klurf), + + ok. + +complex_or_1(A, B) -> + if + ((3 < tuple_size(A)) and (tuple_size(A) < 9)) or + ((2 < tuple_size(B)) and (tuple_size(B) < 7)) -> ok; + true -> error + end. + +complex_or_2(Tuple) -> + if + element(1, Tuple) or not (tuple_size(element(2, Tuple)) > 3) -> ok; + true -> error + end. + +complex_or_3(A, B) -> + if + not (size(B) > 3) or element(1, A) -> ok; + true -> error + end. + +complex_or_4(A, B) -> + if + not (is_tuple(A) and (size(A) > 3)) or element(1, B) -> ok; + true -> error + end. + +complex_or_5(A, B) -> + if + not (is_tuple(A) or (size(A) > 3)) or not element(1, B) -> ok; + true -> error + end. + +complex_or_6(A, B) -> + if + not (not element(1, A) and not element(2, A)) or + not (not (size(B) > 3)) -> ok; + true -> error + end. + +and_guard(Config) when is_list(Config) -> + + %% 'and' combinations of literal true/false. + + ?line check(fun() -> if true and false -> ok; true -> error end end, error), + ?line check(fun() -> if false and true -> ok; true -> error end end, error), + ?line check(fun() -> if true and true -> ok end end, ok), + ?line check(fun() -> if false and false -> ok; true -> error end end, error), + + ?line check(fun() -> if glurf and true -> ok; true -> error end end, error), + ?line check(fun() -> if true and glurf -> ok; true -> error end end, error), + ?line check(fun() -> if glurf and glurf -> ok; true -> error end end, error), + + ?line check(fun() -> + {'EXIT',{if_clause,_}} = + (catch if true and false -> ok; + false and true -> ok; + false and false -> ok + end), + exit + end, exit), + + %% 'and' combinations of true/false in variables. + + True = id(true), + False = id(false), + + ?line check(fun() -> if True and False -> ok; true -> error end end, error), + ?line check(fun() -> if False and True -> ok; true -> error end end, error), + ?line check(fun() -> if True and True -> ok end end, ok), + ?line check(fun() -> if False and False -> ok; true -> error end end, error), + ?line check(fun() -> + {'EXIT',{if_clause,_}} = + (catch if True and False -> ok; + False and True -> ok; + False and False -> ok + end), + exit + end, exit), + + %% 'and' combinations of true/false and a non-boolean in variables. + + Glurf = id(glurf), + + ?line check(fun() -> if True and Glurf -> ok; true -> error end end, error), + ?line check(fun() -> if Glurf and True -> ok; true -> error end end, error), + ?line check(fun() -> if True and True -> ok end end, ok), + ?line check(fun() -> if Glurf and Glurf -> ok; true -> error end end, error), + ?line check(fun() -> + {'EXIT',{if_clause,_}} = + (catch if True and Glurf -> ok; + Glurf and True -> ok; + Glurf and Glurf -> ok + end), + exit + end, exit), + + %% 'and' combinations of true/false with errors. + ATuple = id({a,b,c}), + + ?line check(fun() -> if True and element(42, ATuple) -> ok; + true -> error end end, error), + ?line check(fun() -> if element(42, ATuple) and True -> ok; + true -> error end end, error), + ?line check(fun() -> if True and True -> ok end end, ok), + ?line check(fun() -> if element(42, ATuple) and element(42, ATuple) -> ok; + true -> error end end, error), + ?line check(fun() -> + {'EXIT',{if_clause,_}} = + (catch if True and element(42, ATuple) -> ok; + element(42, ATuple) and True -> ok; + element(42, ATuple) and element(42, ATuple) -> ok + end), + exit + end, exit), + + ?line ok = relprod({'Set',a,b}, {'Set',a,b}), + + ok. + +relprod(R1, R2) when (erlang:size(R1) =:= 3) and (erlang:element(1,R1) =:= 'Set'), (erlang:size(R2) =:= 3) and (erlang:element(1,R2) =:= 'Set') -> + ok. + + +xor_guard(Config) when is_list(Config) -> + + %% 'xor' combinations of literal true/false. + ?line check(fun() -> if true xor false -> ok end end, ok), + ?line check(fun() -> if false xor true -> ok end end, ok), + ?line check(fun() -> if true xor true -> ok; true -> error end end, error), + ?line check(fun() -> if false xor false -> ok; true -> error end end, error), + ?line check(fun() -> + {'EXIT',{if_clause,_}} = (catch if false xor false -> ok end), + exit + end, exit), + ?line check(fun() -> + {'EXIT',{if_clause,_}} = (catch if true xor true -> ok end), + exit + end, exit), + + + %% 'xor' combinations using variables containing true/false. + + True = id(true), + False = id(false), + + ?line check(fun() -> if True xor False -> ok end end, ok), + ?line check(fun() -> if False xor True -> ok end end, ok), + ?line check(fun() -> if True xor True -> ok; true -> error end end, error), + ?line check(fun() -> if False xor False -> ok; true -> error end end, error), + ?line check(fun() -> + {'EXIT',{if_clause,_}} = (catch if False xor False -> ok end), + exit + end, exit), + ?line check(fun() -> + {'EXIT',{if_clause,_}} = (catch if True xor True -> ok end), + exit + end, exit), + + ok. + +more_xor_guards(Config) when is_list(Config) -> + True = id(true), + False = id(false), + ATuple = id({false,true,gurka}), + + ?line check(fun() -> + if element(42, ATuple) xor False -> ok; + true -> error end + end, error), + + ?line check(fun() -> + if False xor element(42, ATuple) xor False -> ok; + true -> error end + end, error), + + ?line check(fun() -> + if element(18, ATuple) xor element(42, ATuple) -> ok; + true -> error end + end, error), + + ?line check(fun() -> + if True xor element(42, ATuple) -> ok; + true -> error end + end, error), + + ?line check(fun() -> + if element(42, ATuple) xor True -> ok; + true -> error end + end, error), + ok. + +build_in_guard(Config) when is_list(Config) -> + SubBin = <<5.0/float>>, + ?line B = <<1,SubBin/binary,3.5/float>>, + ?line if + B =:= <<1,SubBin/binary,3.5/float>> -> ok + end. + +old_guard_tests(Config) when list(Config) -> + %% Check that all the old guard tests are still recognized. + ?line list = og(Config), + ?line atom = og(an_atom), + ?line binary = og(<<1,2>>), + ?line float = og(3.14), + ?line integer = og(43), + ?line a_function = og(fun() -> ok end), + ?line pid = og(self()), + ?line reference = og(make_ref()), + ?line tuple = og({}), + + ?line number = on(45.333), + ?line number = on(-19), + ok. + +og(V) when atom(V) -> atom; +og(V) when binary(V) -> binary; +og(V) when float(V) -> float; +og(V) when integer(V) -> integer; +og(V) when function(V) -> a_function; +og(V) when list(V) -> list; +og(V) when pid(V) -> pid; +og(V) when port(V) -> port; +og(V) when reference(V) -> reference; +og(V) when tuple(V) -> tuple; +og(_) -> what. + +on(V) when number(V) -> number; +on(_) -> not_number. + +gbif(Config) when is_list(Config) -> + ?line error = gbif_1(1, {false,true}), + ?line ok = gbif_1(2, {false,true}), + ok. + +gbif_1(P, T) when element(P, T) -> ok; +gbif_1(_, _) -> error. + + +t_is_boolean(Config) when is_list(Config) -> + ?line true = is_boolean(true), + ?line true = is_boolean(false), + ?line true = is_boolean(id(true)), + ?line true = is_boolean(id(false)), + + ?line false = is_boolean(glurf), + ?line false = is_boolean(id(glurf)), + + ?line false = is_boolean([]), + ?line false = is_boolean(id([])), + ?line false = is_boolean(42), + ?line false = is_boolean(id(-42)), + + ?line false = is_boolean(math:pi()), + ?line false = is_boolean(384793478934378924978439789873478934897), + + ?line false = is_boolean(id(self())), + ?line false = is_boolean(id({x,y,z})), + ?line false = is_boolean(id([a,b,c])), + ?line false = is_boolean(id(make_ref())), + ?line false = is_boolean(id(<<1,2,3>>)), + ?line false = is_boolean({id(x),y,z}), + ?line false = is_boolean([id(a),b,c]), + + ?line ok = bool(true), + ?line ok = bool(false), + ?line ok = bool(id(true)), + ?line ok = bool(id(false)), + + ?line error = bool(glurf), + ?line error = bool(id(glurf)), + + ?line error = bool([]), + ?line error = bool(id([])), + ?line error = bool(42), + ?line error = bool(id(-42)), + + ?line error = bool(math:pi()), + ?line error = bool(384793478934378924978439789873478934897), + + ?line error = bool(id(self())), + ?line error = bool(id({x,y,z})), + ?line error = bool(id([a,b,c])), + ?line error = bool(id(make_ref())), + ?line error = bool(id(<<1,2,3>>)), + + ?line true = my_is_bool(true), + ?line true = my_is_bool(false), + ?line false = my_is_bool([]), + ?line false = my_is_bool([1,2,3,4]), + ?line false = my_is_bool({a,b,c}), + + ok. + +bool(X) when is_boolean(X) -> ok; +bool(_) -> error. + +my_is_bool(V) -> + Res = my_is_bool_a(V), + Res = my_is_bool_b(V). + +my_is_bool_a(V) -> + case V of + true -> true; + false -> true; + _ -> false + end. + +my_is_bool_b(V) -> + case V of + false -> true; + true -> true; + _ -> false + end. + +is_function_2(Config) when is_list(Config) -> + true = is_function(id(fun ?MODULE:all/1), 1), + true = is_function(id(fun() -> ok end), 0), + false = is_function(id(fun ?MODULE:all/1), 0), + false = is_function(id(fun() -> ok end), 1), + + F = fun(_) -> ok end, + if + is_function(F, 1) -> ok + end. + +tricky(Config) when is_list(Config) -> + ?line not_ok = tricky_1(1, 2), + ?line not_ok = tricky_1(1, blurf), + ?line not_ok = tricky_1(foo, 2), + ?line not_ok = tricky_1(a, b), + + ?line error = tricky_2(0.5), + ?line error = tricky_2(a), + ?line error = tricky_2({a,b,c}), + + ?line false = rb(100000, [1], 42), + ?line true = rb(100000, [], 42), + ?line true = rb(555, [a,b,c], 19), + ok. + +tricky_1(X, Y) when abs((X == 1) or (Y == 2)) -> ok; +tricky_1(_, _) -> not_ok. + +tricky_2(X) when float(X) or float(X) -> ok; +tricky_2(_) -> error. + +%% From dets_v9:read_buckets/11, simplified. + +rb(Size, ToRead, SoFar) when SoFar + Size < 81920; ToRead == [] -> true; +rb(_, _, _) -> false. + + +-define(T(Op,A,B), + ok = if A Op B -> ok; true -> error end, + ok = if not (A Op B) -> error; true -> ok end, + (fun(X, Y, True, False) -> + ok = if X Op Y -> ok; true -> error end, + ok = if False; X Op Y; False -> ok; true -> error end, + ok = if X Op Y, True -> ok; true -> error end, + ok = if not (X Op Y) -> error; true -> ok end, + ok = if False; not (X Op Y); False -> error; true -> ok end + end)(id(A), id(B), id(true), id(false))). + +-define(F(Op,A,B), + ok = if A Op B -> error; true -> ok end, + ok = if not (A Op B) -> ok; true -> error end, + (fun(X, Y, True, False) -> + ok = if X Op Y -> error; true -> ok end, + ok = if False; X Op Y; False -> error; true -> ok end, + ok = if not (X Op Y); False -> ok; true -> error end, + ok = if not (X Op Y), True -> ok; true -> error end + end)(id(A), id(B), id(true), id(false))). + + +rel_ops(Config) when is_list(Config) -> + ?line ?T(=/=, 1, 1.0), + ?line ?F(=/=, 2, 2), + ?line ?F(=/=, {a}, {a}), + + ?line ?F(/=, a, a), + ?line ?F(/=, 0, 0.0), + ?line ?T(/=, 0, 1), + ?line ?F(/=, {a}, {a}), + + ?line ?T(==, 1, 1.0), + ?line ?F(==, a, {}), + + ?line ?F(=:=, 1, 1.0), + ?line ?T(=:=, 42.0, 42.0), + + ?line ?F(>, a, b), + ?line ?T(>, 42, 1.0), + ?line ?F(>, 42, 42.0), + + ?line ?T(<, a, b), + ?line ?F(<, 42, 1.0), + ?line ?F(<, 42, 42.0), + + ?line ?T(=<, 1.5, 5), + ?line ?F(=<, -9, -100.344), + ?line ?T(=<, 42, 42.0), + + ?line ?T(>=, 42, 42.0), + ?line ?F(>=, a, b), + ?line ?T(>=, 1.0, 0), + + %% Coverage of beam_block:is_exact_eq_ok/1 and collect/1. + ?line true = any_atom /= id(42), + ?line true = [] /= id(42), + + ok. + +-undef(TestOp). + + +%% Test type tests on literal values. (From emulator test suites.) +literal_type_tests(Config) when is_list(Config) -> + case ?MODULE of + guard_SUITE -> literal_type_tests_1(Config); + _ -> {skip,"Enough to run this case once."} + end. + +literal_type_tests_1(Config) -> + %% Generate an Erlang module with all different type of type tests. + ?line Tests = make_test([{T,L} || T <- type_tests(), L <- literals()] ++ + [{is_function,L1,L2} || + L1 <- literals(), L2 <- literals()]), + ?line Mod = literal_test, + ?line Func = {function, 0, test, 0, [{clause,0,[],[],Tests}]}, + ?line Form = [{attribute,0,module,Mod}, + {attribute,0,compile,export_all}, + Func, {eof,0}], + + %% Print generated code for inspection. + ?line lists:foreach(fun (F) -> io:put_chars([erl_pp:form(F),"\n"]) end, Form), + + %% Test compile:form/1. This implies full optimization (default). + ?line {ok,Mod,Code1} = compile:forms(Form), + ?line smoke_disasm(Config, Mod, Code1), + ?line {module,Mod} = code:load_binary(Mod, Mod, Code1), + ?line Mod:test(), + ?line true = code:delete(Mod), + ?line code:purge(Mod), + + %% Test compile:form/2. Turn off all optimizations. + ?line {ok,Mod,Code2} = compile:forms(Form, [binary,report,time, + no_copt,no_postopt]), + ?line smoke_disasm(Config, Mod, Code2), + ?line {module,Mod} = code:load_binary(Mod, Mod, Code2), + ?line Mod:test(), + ?line true = code:delete(Mod), + ?line code:purge(Mod), + ok. + +make_test([{T,L1,L2}|Ts]) -> + [test(T, L1, L2)|make_test(Ts)]; +make_test([{T,L}|Ts]) -> + [test(T, L)|make_test(Ts)]; +make_test([]) -> []. + +test(T, L) -> + S0 = io_lib:format("begin io:format(\"~~p~~n\", [{~p,~p}]), if ~w(~w) -> true; true -> false end end. ", [T,L,T,L]), + S = lists:flatten(S0), + {ok,Toks,_Line} = erl_scan:string(S), + {ok,E} = erl_parse:parse_exprs(Toks), + {value,Val,_Bs} = erl_eval:exprs(E, []), + {match,0,{atom,0,Val},hd(E)}. + +test(T, L1, L2) -> + S0 = io_lib:format("begin io:format(\"~~p~~n\", [{~p,~p,~p}]), if ~w(~w, ~w) -> true; true -> false end end. ", [T,L1,L2,T,L1,L2]), + S = lists:flatten(S0), + {ok,Toks,_Line} = erl_scan:string(S), + {ok,E} = erl_parse:parse_exprs(Toks), + {value,Val,_Bs} = erl_eval:exprs(E, []), + {match,0,{atom,0,Val},hd(E)}. + +smoke_disasm(Config, Mod, Bin) -> + Priv = ?config(priv_dir, Config), + File = filename:join(Priv, atom_to_list(Mod)++".beam"), + ok = file:write_file(File, Bin), + test_lib:smoke_disasm(File). + +literals() -> + [42, + 3.14, + -3, + 32982724987789283473473838474, + [], + xxxx, + {a,b,c}, + [a,list], + <<1,2,3>>, + <<42:17>>]. + +type_tests() -> + [is_boolean, + is_integer, + is_float, + is_number, + is_atom, + is_list, + is_tuple, + is_pid, + is_reference, + is_port, + is_binary, + is_function]. + +basic_andalso_orelse(Config) when is_list(Config) -> + ?line T = id({type,integers,23,42}), + ?line 65 = if + ((element(1, T) =:= type) andalso (tuple_size(T) =:= 4) andalso + element(2, T)) == integers -> + element(3, T) + element(4, T); + true -> error + end, + ?line 65 = case [] of + [] when ((element(1, T) =:= type) andalso (tuple_size(T) =:= 4) andalso + element(2, T)) == integers -> + element(3, T) + element(4, T) + end, + + ?line 42 = basic_rt({type,integers,40,2}), + ?line 5.0 = basic_rt({vector,{3.0,4.0}}), + ?line 20 = basic_rt(['+',3,7]), + ?line {'Set',a,b} = basic_rt({{'Set',a,b},{'Set',a,b}}), + ?line 12 = basic_rt({klurf,4}), + + ?line error = basic_rt({type,integers,40,2,3}), + ?line error = basic_rt({kalle,integers,40,2}), + ?line error = basic_rt({kalle,integers,40,2}), + ?line error = basic_rt({1,2}), + ?line error = basic_rt([]), + + RelProdBody = + fun(R1, R2) -> + if + (erlang:size(R1) =:= 3) andalso (erlang:element(1,R1) =:= 'Set'), + (erlang:size(R2) =:= 3) andalso (erlang:element(1,R2) =:= 'Set') -> + ok + end + end, + + ?line ok = RelProdBody({'Set',a,b}, {'Set',a,b}), + + %% 'andalso'/'orelse' with calls known to fail already at compile time. + %% Used to crash the code generator. + error = (fun() -> + R = {vars,true}, + if + is_record(R, vars, 2) andalso element(99, R) -> ok; + true -> error + end + end)(), + error = (fun(X) -> + L = {a,b,c}, + if + is_list(X) andalso length(L) > 4 -> ok; + true -> error + end + end)([]), + ok. + +basic_rt(T) when is_tuple(T) andalso tuple_size(T) =:= 4 andalso element(1, T) =:= type andalso + element(2, T) == integers -> + element(3, T) + element(4, T); +basic_rt(T) when is_tuple(T) andalso tuple_size(T) =:= 2 andalso element(1, T) =:= vector -> + {X,Y} = element(2, T), + if + is_float(X), is_float(Y) -> + math:sqrt(X*X+Y*Y) + end; +basic_rt(['+',A,B]) -> + 2*id(A+B); +basic_rt({R1,R2}) when erlang:size(R1) =:= 3 andalso erlang:element(1,R1) =:= 'Set', + erlang:size(R2) =:= 3 andalso erlang:element(1,R2) =:= 'Set' -> + R1 = id(R1), + R2 = id(R2), + R1; +basic_rt(T) when is_tuple(T) andalso tuple_size(T) =:= 2 andalso element(1, T) =:= klurf -> + 3*id(element(2, T)); +basic_rt(_) -> + error. + +traverse_dcd(Config) when is_list(Config) -> + L0 = [{log_header,dcd_log,"1.0",a,b,c},{log_header,dcd_log,"2.0",a,b,c}, + {log_header,dcd_log,"0.0",a,b,c},blurf], + {cont,[{log_header,dcd_log,"0.0",a,b,c},blurf],log,funny} = + traverse_dcd({cont,L0}, log, funny), + L1 = [{log_header,dcd_log,"1.0"}], + {cont,L1,log,funny} = traverse_dcd({cont,L1}, log, funny), + L2 = [{a,tuple}], + {cont,L2,log,funny} = traverse_dcd({cont,L2}, log, funny), + ok. + +%% The function starts out with 3 arguments in {x,0}, {x,1}, {x,2}. +%% The outer match of a two tuple will places the first element in {x,3} and +%% second in {x,4}. The guard for the first clause must make ensure that all of those +%% registers are restored before entering the second clause. +%% +%% (From mnesia_checkpoint.erl, modified.) + +traverse_dcd({Cont,[LogH|Rest]},Log,Fun) + when is_tuple(LogH) andalso tuple_size(LogH) =:= 6 andalso element(1, LogH) =:= log_header +andalso erlang:element(2,LogH) == dcd_log, +is_tuple(LogH) andalso tuple_size(LogH) =:= 6 andalso element(1, LogH) =:= log_header +andalso erlang:element(3,LogH) >= "1.0" -> + traverse_dcd({Cont,Rest},Log,Fun); +traverse_dcd({Cont,Recs},Log,Fun) -> + {Cont,Recs,Log,Fun}. + + +check_qlc_hrl(Config) when is_list(Config) -> + St = {r1,false,dum}, + ?line foo = cqlc(qlc, q, [{lc,1,2,3}], St), + ?line foo = cqlc(qlc, q, [{lc,1,2,3},b], St), + ?line St = cqlc(qlc, q, [], St), + ?line St = cqlc(qlc, blurf, [{lc,1,2,3},b], St), + ?line St = cqlc(q, q, [{lc,1,2,3},b], St), + ?line St = cqlc(qlc, q, [{lc,1,2,3},b,c], St), + ?line St = cqlc(qlc, q, [a,b], St), + ?line {r1,true,kalle} = cqlc(qlc, q, [{lc,1,2,3},b], {r1,true,kalle}), + ok. + +%% From erl_lint.erl; original name was check_qlc_hrl/4. +cqlc(M, F, As, St) -> + Arity = length(As), + case As of + [{lc,_L,_E,_Qs}|_] when M =:= qlc, F =:= q, + Arity < 3, + not (((element(1, St) =:= r1) orelse fail) and (tuple_size(St) =:= 3) and element(2, St)) -> + foo; + _ -> + St + end. + +%% OTP-7679: Thanks to Hunter Morris. +andalso_semi(Config) when is_list(Config) -> + ?line ok = andalso_semi_foo(0), + ?line ok = andalso_semi_foo(1), + ?line {'EXIT',{function_clause,_}} = (catch andalso_semi_foo(2)), + + ?line ok = andalso_semi_bar([a,b,c]), + ?line ok = andalso_semi_bar(1), + ?line {'EXIT',{function_clause,_}} = (catch andalso_semi_bar([a,b])), + ok. + +andalso_semi_foo(Bar) when is_integer(Bar) andalso Bar =:= 0; Bar =:= 1 -> + ok. + +andalso_semi_bar(Bar) when is_list(Bar) andalso length(Bar) =:= 3; Bar =:= 1 -> + ok. + + +tuple_size(Config) when is_list(Config) -> + ?line 10 = do_tuple_size({1,2,3,4}), + ?line {'EXIT',{function_clause,_}} = (catch do_tuple_size({1,2,3})), + ?line {'EXIT',{function_clause,_}} = (catch do_tuple_size(42)), + + ?line error = ludicrous_tuple_size({a,b,c}), + ?line error = ludicrous_tuple_size([a,b,c]), + + %% Test the "unsafe case" - the register assigned the tuple size is + %% not killed. + ?line DataDir = test_lib:get_data_dir(Config), + ?line File = filename:join(DataDir, "guard_SUITE_tuple_size"), + ?line {ok,Mod,Code} = compile:file(File, [from_asm,binary]), + ?line code:load_binary(Mod, File, Code), + ?line 14 = Mod:t({1,2,3,4}), + + ok. + +do_tuple_size(T) when tuple_size(T) =:= 4 -> + {A,B,C,D} = T, + A+B+C+D. + +ludicrous_tuple_size(T) + when tuple_size(T) =:= 16#7777777777777777777777777777777777 -> ok; +ludicrous_tuple_size(T) + when tuple_size(T) =:= 16#10000000000000000 -> ok; +ludicrous_tuple_size(T) + when tuple_size(T) =:= (1 bsl 64) - 1 -> ok; +ludicrous_tuple_size(T) + when tuple_size(T) =:= 16#FFFFFFFFFFFFFFFF -> ok; +ludicrous_tuple_size(_) -> error. + + +%% Call this function to turn off constant propagation. +id(I) -> I. + +check(F, Result) -> + case F() of + Result -> ok; + Other -> + io:format("Expected: ~p\n", [Result]), + io:format(" Got: ~p\n", [Other]), + test_server:fail() + end. diff --git a/lib/compiler/test/guard_SUITE_data/guard_SUITE_tuple_size.S b/lib/compiler/test/guard_SUITE_data/guard_SUITE_tuple_size.S new file mode 100644 index 0000000000..c0bf04ed8f --- /dev/null +++ b/lib/compiler/test/guard_SUITE_data/guard_SUITE_tuple_size.S @@ -0,0 +1,30 @@ +{module, guard_SUITE_tuple_size}. %% version = 0 + +{exports, [{t,1}]}. + +{attributes, []}. + +{labels, 5}. + + +{function, t, 1, 2}. + {label,1}. + {func_info,{atom,guard_SUITE_tuple_size},{atom,t},1}. + {label,2}. + {bif,tuple_size,{f,4},[{x,0}],{x,1}}. + {test,is_eq_exact,{f,4},[{x,1},{integer,4}]}. + {test,is_tuple,{f,3},[{x,0}]}. + {test,test_arity,{f,3},[{x,0},4]}. + {get_tuple_element,{x,0},0,{x,5}}. + {get_tuple_element,{x,0},1,{x,2}}. + {get_tuple_element,{x,0},2,{x,3}}. + {get_tuple_element,{x,0},3,{x,4}}. + {gc_bif,'+',{f,0},5,[{x,1},{x,2}],{x,0}}. + {gc_bif,'+',{f,0},5,[{x,0},{x,3}],{x,0}}. + {gc_bif,'+',{f,0},5,[{x,0},{x,4}],{x,0}}. + {gc_bif,'+',{f,0},5,[{x,0},{x,5}],{x,0}}. + return. + {label,3}. + {badmatch,{x,0}}. + {label,4}. + {jump,{f,1}}. diff --git a/lib/compiler/test/inline_SUITE.erl b/lib/compiler/test/inline_SUITE.erl new file mode 100644 index 0000000000..396fb450b7 --- /dev/null +++ b/lib/compiler/test/inline_SUITE.erl @@ -0,0 +1,280 @@ +%% +%% %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 : Tests inlining. + +-module(inline_SUITE). + +-include("test_server.hrl"). + +-compile(export_all). +-compile({inline,[badarg/2]}). + +%% Needed by test case `lists'. +-compile(inline_list_funcs). + +all(suite) -> + test_lib:recompile(?MODULE), + [attribute,bsdecode,bsdes,barnes2,decode1,smith,itracer,pseudoknot,lists, + really_inlined,otp_7223,coverage]. + +attribute(Config) when is_list(Config) -> + Name = "attribute", + ?line Src = filename:join(?config(data_dir, Config), Name), + ?line Out = ?config(priv_dir,Config), + + ?line {ok,attribute=Mod} = compile:file(Src, [{outdir,Out},report,time]), + ?line Outfile = filename:join(Out, Name++".beam"), + ?line {ok,{Mod,[{locals,Locals}]}} = beam_lib:chunks(Outfile, [locals]), + ?line io:format("locals: ~p\n", [Locals]), + + %% The inliner should have removed all local functions. + ?line [] = Locals, + + ok. + +-define(comp(Name), + Name(Config) when list(Config) -> + try_inline(Name, Config)). + +?comp(bsdecode). +?comp(bsdes). +?comp(barnes2). +?comp(decode1). +?comp(smith). +?comp(itracer). +?comp(pseudoknot). + +try_inline(Mod, Config) -> + ?line Src = filename:join(?config(data_dir, Config), atom_to_list(Mod)), + ?line Out = ?config(priv_dir,Config), + + %% Normal compilation. + ?line io:format("Compiling: ~s\n", [Src]), + ?line {ok,Mod} = compile:file(Src, [{outdir,Out},report,bin_opt_info,clint]), + + ?line Dog = test_server:timetrap(test_server:minutes(10)), + ?line Pa = "-pa " ++ filename:dirname(code:which(?MODULE)), + ?line {ok,Node} = start_node(compiler, Pa), + ?line NormalResult = rpc:call(Node, ?MODULE, load_and_call, [Out,Mod]), + ?line test_server:timetrap_cancel(Dog), + + %% Inlining. + ?line io:format("Compiling with old inliner: ~s\n", [Src]), + ?line {ok,Mod} = compile:file(Src, [{outdir,Out},report,bin_opt_info, + {inline,1000},clint]), + + %% Run inlined code. + ?line Dog3 = test_server:timetrap(test_server:minutes(10)), + ?line OldInlinedResult = rpc:call(Node, ?MODULE, load_and_call, [Out,Mod]), + ?line test_server:timetrap_cancel(Dog3), + + %% Compare results. + ?line compare(NormalResult, OldInlinedResult), + ?line NormalResult = OldInlinedResult, + + %% Inlining. + ?line io:format("Compiling with new inliner: ~s\n", [Src]), + ?line {ok,Mod} = compile:file(Src, [{outdir,Out},report, + bin_opt_info,inline,clint]), + + %% Run inlined code. + ?line Dog4 = test_server:timetrap(test_server:minutes(10)), + ?line InlinedResult = rpc:call(Node, ?MODULE, load_and_call, [Out,Mod]), + ?line test_server:timetrap_cancel(Dog4), + + %% Compare results. + ?line compare(NormalResult, InlinedResult), + ?line NormalResult = InlinedResult, + + %% Delete Beam file. + ?line ok = file:delete(filename:join(Out, atom_to_list(Mod)++code:objfile_extension())), + + ?line ?t:stop_node(Node), + ok. + +compare(Same, Same) -> ok; +compare([Same|T1], [Same|T2]) -> + compare(T1, T2); +compare([{X,Y,RGB1}|T1], [{X,Y,RGB2}|T2]) -> + io:format("X = ~p, Y = ~p, RGB normal = ~p, RGB inlined ~p\n", [X,Y,RGB1,RGB2]), + compare(T1, T2); +compare([H1|_], [H2|_]) -> + io:format("Normal = ~p, Inlined = ~p\n", [H1,H2]), + ?t:fail(); +compare([], []) -> ok. + +start_node(Name, Args) -> + case test_server:start_node(Name, slave, [{args,Args}]) of + {ok,Node} -> {ok, Node}; + Error -> ?line test_server:fail(Error) + end. + +load_and_call(Out, Module) -> + ?line io:format("Loading...\n",[]), + ?line code:purge(Module), + ?line LoadRc = code:load_abs(filename:join(Out, Module)), + ?line {module,Module} = LoadRc, + + ?line io:format("Calling...\n",[]), + ?line {Time,CallResult} = timer:tc(Module, Module, []), + ?line io:format("Time: ~p\n", [Time]), + CallResult. + +%% Macros used by lists/1 below. + +-define(TestHighOrder_2(Name, Body, List), + begin + put(?MODULE, []), + (fun({Res,Res2}) -> + {Res,Res2} = my_apply(lists, Name, [Body,List], []) + end)(begin + (fun(R) -> + {R,get(?MODULE)} + end)(lists:Name(Body, List)) + end) + end). + +-define(TestHighOrder_3(Name, Body, Init, List), + begin + put(?MODULE, []), + (fun({Res,Res2}) -> + {Res,Res2} = my_apply(lists, Name, [Body,Init,List], []) + end)(begin + (fun(R) -> + {R,get(?MODULE)} + end)(lists:Name(Body, Init, List)) + end) + end). + +%% For each high order function in the lists module, verify +%% that the inlined version produces the same result and is evaluated +%% in the same order as the function in the lists module. +%% +%% Note: This module must be compiled with the inline_lists_funcs option. + +lists(Config) when is_list(Config) -> + ?line List = lists:seq(1, 20), + + %% lists:map/2 + ?line ?TestHighOrder_2(map, (fun(E) -> + R = E band 16#ff, + put(?MODULE, [E|get(?MODULE)]), + R + end), List), + + %% lists:flatmap/2 + ?line ?TestHighOrder_2(flatmap, (fun(E) -> + R = lists:duplicate(E, E), + put(?MODULE, [E|get(?MODULE)]), + R + end), List), + + %% lists:foreach/2 + ?line ?TestHighOrder_2(foreach, + (fun(E) -> + put(?MODULE, [E bor 7|get(?MODULE)]) + end), List), + + %% lists:filter/2 + ?line ?TestHighOrder_2(filter, (fun(E) -> + put(?MODULE, [E|get(?MODULE)]), + (E bsr 1) band 1 =/= 0 + end), List), + + %% lists:any/2 + ?line ?TestHighOrder_2(any, (fun(E) -> + put(?MODULE, [E|get(?MODULE)]), + false %Force it to go through all. + end), List), + + %% lists:all/2 + ?line ?TestHighOrder_2(all, (fun(E) -> + put(?MODULE, [E|get(?MODULE)]), + true %Force it to go through all. + end), List), + + %% lists:foldl/3 + ?line ?TestHighOrder_3(foldl, (fun(E, A) -> + put(?MODULE, [E|get(?MODULE)]), + A bxor E + end), 0, List), + + %% lists:foldr/3 + ?line ?TestHighOrder_3(foldr, (fun(E, A) -> + put(?MODULE, [E|get(?MODULE)]), + A bxor (bnot E) + end), 0, List), + + %% lists:mapfoldl/3 + ?line ?TestHighOrder_3(mapfoldl, (fun(E, A) -> + put(?MODULE, [E|get(?MODULE)]), + {bnot E,A bxor (bnot E)} + end), 0, List), + + %% lists:mapfoldr/3 + ?line ?TestHighOrder_3(mapfoldr, (fun(E, A) -> + put(?MODULE, [E|get(?MODULE)]), + {bnot E,A bxor (bnot E)} + end), 0, List), + + %% Cleanup. + erase(?MODULE), + ok. + +my_apply(M, F, A, Init) -> + put(?MODULE, Init), + Res = apply(M, F, A), + {Res,get(?MODULE)}. + +really_inlined(Config) when is_list(Config) -> + %% Make sure that badarg/2 really gets inlined. + {'EXIT',{badarg,[{?MODULE,fail_me_now,[]}|_]}} = (catch fail_me_now()), + ok. + +fail_me_now() -> + badarg(foo(bar), []). + +foo(_X) -> + badarg. + +%% Inlined. +badarg(badarg, A) -> + erlang:error(badarg, A); +badarg(Reply, _A) -> + Reply. + +otp_7223(Config) when is_list(Config) -> + ?line {'EXIT', {{case_clause,{1}},_}} = (catch otp_7223_1(1)), + ok. + +-compile({inline,[{otp_7223_1,1}]}). +otp_7223_1(X) -> + otp_7223_2(X). + +-compile({inline,[{otp_7223_2,1}]}). +otp_7223_2({a}) -> + 1. + +coverage(Config) when is_list(Config) -> + ?line Src = filename:join(?config(data_dir, Config), bsdecode), + ?line Out = ?config(priv_dir,Config), + ?line {ok,Mod} = compile:file(Src, [{outdir,Out},report,{inline,0},clint]), + ?line {ok,Mod} = compile:file(Src, [{outdir,Out},report,{inline,20},verbose,clint]), + ?line ok = file:delete(filename:join(Out, "bsdecode"++code:objfile_extension())), + ok. diff --git a/lib/compiler/test/inline_SUITE_data/attribute.erl b/lib/compiler/test/inline_SUITE_data/attribute.erl new file mode 100644 index 0000000000..961086a888 --- /dev/null +++ b/lib/compiler/test/inline_SUITE_data/attribute.erl @@ -0,0 +1,31 @@ +%% +%% %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(attribute). +-export([test/1]). +-compile(inline). + +%% If -compile(inline) above is recognized, the local function add/2 +%% will not be present in the Beam file. + +test(X) -> add(X, 2). + +add(X, Y) -> X+Y. + + + diff --git a/lib/compiler/test/inline_SUITE_data/barnes2.erl b/lib/compiler/test/inline_SUITE_data/barnes2.erl new file mode 100644 index 0000000000..a986331060 --- /dev/null +++ b/lib/compiler/test/inline_SUITE_data/barnes2.erl @@ -0,0 +1,160 @@ +% file: "barnes.erl" + +-module(barnes2). +-export([?MODULE/0]). + +?MODULE() -> + Stars = create_scenario(1000, 1.0), + R = hd(loop(10,1000.0,Stars,0)), + Str = lists:flatten(io:lib_format("~s", [R])), + {R,Str =:= {1.00000,-1.92269e+4,-1.92269e+4,2.86459e-2,2.86459e-2}}. + +create_scenario(N, M) -> + create_scenario0(0, 0, trunc(math:sqrt(N)), M). + +create_scenario0(_X, _SN, _SN, _M) -> + []; +create_scenario0(SN, Y, SN, M) -> + create_scenario0(0, Y+1, SN, M); +create_scenario0(X, Y, SN, M) -> + XPos0 = (((20000.0 * 2) / SN) * X) - 20000.0, + YPos0 = (((20000.0 * 2) / SN) * Y) - 20000.0, + Calibrate = ((20000.0 * 2) / SN) / 2, + XPos = XPos0 + Calibrate, + YPos = YPos0 + Calibrate, + [{M, XPos, YPos, 0.0, 0.0} | create_scenario0(X+1, Y, SN, M)]. + +relpos_to_quadrant(DX, DY) when DX >= 0 -> + if + DY >= 0 -> 0; + true -> 3 + end; +relpos_to_quadrant(_, DY) -> + if + DY >= 0 -> 1; + true -> 2 + end. + +quadrant_to_dx(0, D) -> D; +quadrant_to_dx(1, D) -> -D; +quadrant_to_dx(2, D) -> -D; +quadrant_to_dx(3, D) -> D. + +quadrant_to_dy(Q,D) -> + if + Q < 2 -> D; + true -> -D + end. + +create_tree(Stars) -> + create_tree0(Stars, empty). + +create_tree0([],Tree) -> + Tree; +create_tree0([{M,X,Y,_,_} | Stars], Tree) -> + create_tree0(Stars, insert_tree_element(Tree, M, X, Y, 0.0, 0.0, 20000.0)). + +insert_tree_element(empty, M, X, Y, _OX, _OY, _D) -> + {body,M,X,Y}; +insert_tree_element({branch,M0,SubTree}, M, X, Y, OX, OY, D) -> + Q = relpos_to_quadrant(X-OX,Y-OY), + D2 = D / 2, + DX = quadrant_to_dx(Q,D2), + DY = quadrant_to_dy(Q,D2), + {branch,M0+M,setelement(Q+1,SubTree, + insert_tree_element(element(Q+1,SubTree), + M, X, Y, OX+DX, OY+DY,D2))}; +insert_tree_element({body,M0,X0,Y0},M,X,Y,OX,OY,D) -> + resolve_body_conflict(M,X,Y,M0,X0,Y0,OX,OY,D). + +resolve_body_conflict(M0, X0, Y0, M1, X1, Y1, OX, OY, D) -> + T = {empty,empty,empty,empty}, + Q0 = relpos_to_quadrant(X0-OX,Y0-OY), + Q1 = relpos_to_quadrant(X1-OX,Y1-OY), + D2 = D / 2, + if + Q0 == Q1 -> DX = quadrant_to_dx(Q0,D2), + DY = quadrant_to_dy(Q1,D2), + {branch,M0+M1,setelement(Q0+1,T, + resolve_body_conflict(M0,X0,Y0, + M1,X1,Y1, + OX+DX,OY+DY, + D2))} ; + true -> {branch,M0+M1, setelement(Q1+1, + setelement(Q0+1,T,{body,M0,X0,Y0}), + {body,M1,X1,Y1})} + end. + +compute_acceleration(empty, _, _, _, _, _,L) -> + {{0.0, 0.0},L+1}; +compute_acceleration({body,BM,BX,BY}, _D, _OX, _OY, X, Y,L) -> + DX = BX - X, + DY = BY - Y, + R2 = (DX * DX) + (DY * DY), + Divisor = R2 * math:sqrt(R2), + if + Divisor < 0.000001 -> % was: Divisor < ?EPSILON -> + {{0.0, 0.0},L+1}; + true -> + Expr = BM / Divisor, + {{DX * Expr, DY * Expr},L+1} + end; +compute_acceleration({branch,M,SubTree}, D, OX, OY, X, Y,L) -> + DX = OX - X, + DY = OY - Y, + R2 = (DX * DX) + (DY * DY), + DD = D*D, + R2_THETA2 = 0.09 * R2, % TRY 2.0 *R2, !!! was: R2_THETA2 = ?THETA2*R2, + if + % Ok to approximate? + DD < R2_THETA2 -> + Divisor = R2 * math:sqrt(R2), + if + Divisor < 0.000001 -> + {{0.0,0.0},L}; + true -> + Expr = M / Divisor, + {{DX*Expr, DY*Expr},L+1} + end; + % Not ok to approximate... + true -> + D2 = D / 2, + {{AX0, AY0},L1} = compute_acceleration(element(1,SubTree), + D2, OX + quadrant_to_dx(0,D2), + OY + quadrant_to_dy(0,D2),X,Y,L), + {{AX1, AY1},L2} = compute_acceleration(element(2,SubTree), + D2, OX + quadrant_to_dx(1,D2), + OY + quadrant_to_dy(1,D2),X,Y,L1), + {{AX2, AY2},L3} = compute_acceleration(element(3,SubTree), + D2,OX + quadrant_to_dx(2,D2), + OY + quadrant_to_dy(2,D2),X,Y,L2), + {{AX3, AY3},L4} = compute_acceleration(element(4,SubTree), + D2, OX + quadrant_to_dx(3,D2), + OY + quadrant_to_dy(3,D2),X,Y,L3), + {{AX0+AX1+AX2+AX3, AY0+AY1+AY2+AY3},L4+1} + end. + +compute_star_accelerations(_Tree,[],L) -> + {[],L}; +compute_star_accelerations(Tree,[{_,X, Y,_,_}|Stars],L) -> + {A,AL} = compute_acceleration(Tree, 20000.0, 0.0, 0.0, X, Y,L), + {B,BL} = compute_star_accelerations(Tree, Stars,AL), + {[A | B],BL}. + +compute_next_state([],_,_) -> + []; +compute_next_state([{M,X,Y,VX,VY}|Stars],[{AX,AY}|Accs],Time) -> + VX0 = VX + (AX * Time), + VY0 = VY + (AY * Time), + [{M,X+(VX*Time),Y+(VY*Time),VX0,VY0} | compute_next_state(Stars,Accs,Time)]. + +advance_time(Time,Stars,L) -> + Tree = create_tree(Stars), + {Acc,NL} = compute_star_accelerations(Tree, Stars,L), + {compute_next_state(Stars, Acc, Time),NL}. + +loop(0,_Time,Stars,_L) -> + Stars; +loop(N,Time,Stars,L) -> + {NS,NL} = advance_time(Time,Stars,L), + loop(N-1,Time,NS,NL). diff --git a/lib/compiler/test/inline_SUITE_data/bsdecode.erl b/lib/compiler/test/inline_SUITE_data/bsdecode.erl new file mode 100644 index 0000000000..ae134ad02e --- /dev/null +++ b/lib/compiler/test/inline_SUITE_data/bsdecode.erl @@ -0,0 +1,1188 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2006-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(bsdecode). +-export([?MODULE/0]). + +-record(protocolErrors, {invalidManIE = false, + outOfSequence = false, + incorrectOptIE = false}). + +-record(mvsT_msisdn, {value}). + + +-record(mvsgT_pdpAddressType, {pdpTypeNbr, + address}). + +-record(mvsgT_ipAddress, {version, + a1, + a2, + a3, + a4, + a5, + a6, + a7, + a8}). + +-record(mvsgT_imsi, {value}). + +-record(mvsgT_tid, {imsi, + nsapi}). + +-record(sesT_qualityOfServiceV0, {delayClass, + reliabilityClass, + peakThroughput, + precedenceClass, + meanThroughput}). + +-record(sesT_deleteReqV0, {tid}). + +-record(sesT_deleteResV0, {tid, + cause}). + +-record(sesT_createReqV0, {tid, + tidRaw, + qos, + recovery, + selMode, + flowLblData, + flowLblSig, + endUserAdd, + accPointName, + protConOpt, + sgsnAddSig, + sgsnAddUser, + msisdn}). + +-record(sesT_updateReqV0, {tid, + tidRaw, + qos, + recovery, + flowLblData, + flowLblSig, + sgsnAddSig, + sgsnAddUser}). + +-record(masT_ipcpData, {type, + ipAddress, + rawMessage}). + +-record(masT_ipcp, {exists, + code, + id, + ipcpList}). + +-record(masT_pap, {exists, + code, + id, + username, + password}). + +-record(masT_chap, {code, + id, + value, + name}). + +-record(masT_protocolConfigOptions, {chap, + pap, + ipcp}). + +?MODULE() -> + Res = test(), + {Res,Res =:= + {ok,{sesT_createReqV0,{mvsgT_tid,{mvsgT_imsi,<<81,67,101,7,0,0,0,240>>},6}, + [81,67,101,7,0,0,0,96], + {sesT_qualityOfServiceV0,1,4,9,2,18},0, + subscribed,0,0,{mvsgT_pdpAddressType,ietf_ipv4,[]}, + [<<97,112,110,48,49,51,97>>,<<101,114,105,99,115,115,111,110>>,<<115,101>>], + {masT_protocolConfigOptions,[], + {masT_pap,true,1,5,[117,115,101,114,53],[112,97,115,115,53]},[]}, + {mvsgT_ipAddress,ipv4,172,28,12,1,0,0,0,0}, + {mvsgT_ipAddress,ipv4,172,28,12,3,0,0,0,0}, + {mvsT_msisdn,<<145,148,113,129,0,0,0,0>>}},1}}. + +test() -> + Pdu = <<30, + 16, + 0, + 90, + 0, + 1, + 0, + 0, + 255, + 255, + 255, + 255, + 81, + 67, + 101, + 7, + 0, + 0, + 0, + 96, + 6, + 12, + 146, + 18, + 14, + 0, + 15, + 252, + 16, + 0, + 0, + 17, + 0, + 0, + 128, + 0, + 2, + 241, + 33, + 131, + 0, + 20, + 7, + 97, + 112, + 110, + 48, + 49, + 51, + 97, + 8, + 101, + 114, + 105, + 99, + 115, + 115, + 111, + 110, + 2, + 115, + 101, + 132, + 0, + 20, + 128, + 192, + 35, + 16, + 1, + 5, + 0, + 16, + 5, + 117, + 115, + 101, + 114, + 53, + 5, + 112, + 97, + 115, + 115, + 53, + 133, + 0, + 4, + 172, + 28, + 12, + 1, + 133, + 0, + 4, + 172, + 28, + 12, + 3, + 134, + 0, + 8, + 145, + 148, + 113, + 129, + 0, + 0, + 0, + 0>>, + decode_v0_opt(10,Pdu). + +decode_v0_opt(0,Pdu) -> + decode_gtpc_msg(Pdu); +decode_v0_opt(N,Pdu) -> + decode_gtpc_msg(Pdu), + decode_v0_opt(N - 1,Pdu). + +decode_gtpc_msg(<<0:3, + _:4, + 0:1, + 16:8, + _Length:16, + SequenceNumber:16, + _FlowLabel:16, + _SNDCP_N_PDU_Number:8, + _:3/binary-unit:8, + TID:8/binary-unit:8, + InformationElements/binary>>) -> + Errors = #protocolErrors{}, + {ok,TID2} = tid_internal_storage(TID,[]), + EmptyCreateReq = #sesT_createReqV0{tid = TID2, + tidRaw = binary_to_list(TID)}, + case catch decode_ie_create(InformationElements,0,Errors,EmptyCreateReq) of + {ok,CreateReq} -> + {ok,CreateReq,SequenceNumber}; + {fault,Cause,CreateReq} -> + {fault,Cause,CreateReq,SequenceNumber}; + {'EXIT',_Reason} -> + {fault,193,EmptyCreateReq,SequenceNumber} + end; +decode_gtpc_msg(<<0:3, + _:4, + 0:1, + 18:8, + _Length:16, + SequenceNumber:16, + _FlowLabel:16, + _SNDCP_N_PDU_Number:8, + _:3/binary-unit:8, + TID:8/binary-unit:8, + InformationElements/binary>>) -> + io:format("hej",[]), + Errors = #protocolErrors{}, + {ok,TID2} = tid_internal_storage(TID,[]), + EmptyUpdateReq = #sesT_updateReqV0{tid = TID2, + tidRaw = binary_to_list(TID)}, + case catch decode_ie_update(InformationElements,0,Errors,EmptyUpdateReq) of + {ok,UpdateReq} -> + {ok,UpdateReq,SequenceNumber}; + {fault,Cause,UpdateReq} -> + {fault,Cause,UpdateReq,SequenceNumber}; + {'EXIT',Reason} -> + io:format("hej",[]), + {fault,193,EmptyUpdateReq,SequenceNumber,Reason} + end; +decode_gtpc_msg(<<0:3, + _:4, + 0:1, + 20:8, + _Length:16, + SequenceNumber:16, + _FlowLabel:16, + _SNDCP_N_PDU_Number:8, + _:3/binary-unit:8, + TID:8/binary-unit:8, + _InformationElements/binary>>) -> + {ok,TID2} = tid_internal_storage(TID,[]), + DeleteReq = #sesT_deleteReqV0{tid = TID2}, + {ok,DeleteReq,SequenceNumber}; +decode_gtpc_msg(<<0:3, + _:4, + 0:1, + 21:8, + _Length:16, + SequenceNumber:16, + _FlowLabel:16, + _SNDCP_N_PDU_Number:8, + _:3/binary-unit:8, + TID:8/binary-unit:8, + InformationElements/binary>>) -> + Errors = #protocolErrors{}, + {ok,TID2} = tid_internal_storage(TID,[]), + EmptyDeleteRes = #sesT_deleteResV0{tid = TID2}, + case catch decode_ie_delete_res(InformationElements,0,Errors,EmptyDeleteRes) of + {ok,DeleteRes} -> + {ok,DeleteRes,SequenceNumber}; + {fault,Cause,DeleteRes} -> + {fault,Cause,DeleteRes,SequenceNumber}; + {'EXIT',_Reason} -> + {fault,193,EmptyDeleteRes,SequenceNumber} + end; +decode_gtpc_msg(_GTP_C_Message) -> + {fault}. + +decode_ie_create(<<>>,PresentIEs,Errors,CreateReq) -> + if + PresentIEs band 1917 /= 1917 -> + {fault,202,CreateReq}; + true -> + case Errors of + #protocolErrors{invalidManIE = true} -> + {fault,201,CreateReq}; + #protocolErrors{outOfSequence = true} -> + {fault,193,CreateReq}; + #protocolErrors{incorrectOptIE = true} -> + {fault,203,CreateReq}; + _ -> + {ok,CreateReq} + end + end; +decode_ie_create(<<6:8, + QoSElement:3/binary-unit:8, + Rest/binary>>,PresentIEs,Errors,CreateReq) -> + if + PresentIEs band 1 == 1 -> + decode_ie_create(Rest,PresentIEs,Errors,CreateReq); + PresentIEs > 1 -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true}, + <<_:2, + DelayClass:3, + ReliabilityClass:3, + PeakThroughput:4, + _:1, + PrecedenceClass:3, + _:3, + MeanThroughput:5>> = QoSElement, + QoS = #sesT_qualityOfServiceV0{delayClass = DelayClass, + reliabilityClass = ReliabilityClass, + peakThroughput = PeakThroughput, + precedenceClass = PrecedenceClass, + meanThroughput = MeanThroughput}, + UpdatedCreateReq = CreateReq#sesT_createReqV0{qos = QoS}, + decode_ie_create(Rest,PresentIEs bor 1,UpdatedErrors,UpdatedCreateReq); + true -> + <<_:2, + DelayClass:3, + ReliabilityClass:3, + PeakThroughput:4, + _:1, + PrecedenceClass:3, + _:3, + MeanThroughput:5>> = QoSElement, + QoS = #sesT_qualityOfServiceV0{delayClass = DelayClass, + reliabilityClass = ReliabilityClass, + peakThroughput = PeakThroughput, + precedenceClass = PrecedenceClass, + meanThroughput = MeanThroughput}, + UpdatedCreateReq = CreateReq#sesT_createReqV0{qos = QoS}, + decode_ie_create(Rest,PresentIEs bor 1,Errors,UpdatedCreateReq) + end; +decode_ie_create(<<14:8, + Recovery:8, + Rest/binary>>,PresentIEs,Errors,CreateReq) -> + if + PresentIEs band 2 == 2 -> + decode_ie_create(Rest,PresentIEs,Errors,CreateReq); + PresentIEs > 2 -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true}, + UpdatedCreateReq = CreateReq#sesT_createReqV0{recovery = Recovery}, + decode_ie_create(Rest,PresentIEs bor 2,UpdatedErrors,UpdatedCreateReq); + true -> + UpdatedCreateReq = CreateReq#sesT_createReqV0{recovery = Recovery}, + decode_ie_create(Rest,PresentIEs bor 2,Errors,UpdatedCreateReq) + end; +decode_ie_create(<<15:8, + _:6, + SelectionMode:2, + Rest/binary>>,PresentIEs,Errors,CreateReq) -> + if + PresentIEs band 4 == 4 -> + decode_ie_create(Rest,PresentIEs,Errors,CreateReq); + PresentIEs > 4 -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true}, + UpdatedCreateReq = CreateReq#sesT_createReqV0{selMode = selection_mode_internal_storage(SelectionMode)}, + decode_ie_create(Rest,PresentIEs bor 4,UpdatedErrors,UpdatedCreateReq); + true -> + UpdatedCreateReq = CreateReq#sesT_createReqV0{selMode = selection_mode_internal_storage(SelectionMode)}, + decode_ie_create(Rest,PresentIEs bor 4,Errors,UpdatedCreateReq) + end; +decode_ie_create(<<16:8, + FlowLabel:16, + Rest/binary>>,PresentIEs,Errors,CreateReq) -> + if + PresentIEs band 8 == 8 -> + decode_ie_create(Rest,PresentIEs,Errors,CreateReq); + PresentIEs > 8 -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true}, + UpdatedCreateReq = CreateReq#sesT_createReqV0{flowLblData = FlowLabel}, + decode_ie_create(Rest,PresentIEs bor 8,UpdatedErrors,UpdatedCreateReq); + true -> + UpdatedCreateReq = CreateReq#sesT_createReqV0{flowLblData = FlowLabel}, + decode_ie_create(Rest,PresentIEs bor 8,Errors,UpdatedCreateReq) + end; +decode_ie_create(<<17:8, + FlowLabel:16, + Rest/binary>>,PresentIEs,Errors,CreateReq) -> + if + PresentIEs band 16 == 16 -> + decode_ie_create(Rest,PresentIEs,Errors,CreateReq); + PresentIEs > 16 -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true}, + UpdatedCreateReq = CreateReq#sesT_createReqV0{flowLblSig = FlowLabel}, + decode_ie_create(Rest,PresentIEs bor 16,UpdatedErrors,UpdatedCreateReq); + true -> + UpdatedCreateReq = CreateReq#sesT_createReqV0{flowLblSig = FlowLabel}, + decode_ie_create(Rest,PresentIEs bor 16,Errors,UpdatedCreateReq) + end; +decode_ie_create(<<128:8, + Length:16, + More/binary>>,PresentIEs,Errors,CreateReq) -> + <<PDPElement:Length/binary-unit:8, + Rest/binary>> = More, + if + PresentIEs band 32 == 32 -> + decode_ie_create(Rest,PresentIEs,Errors,CreateReq); + PresentIEs > 32 -> + case pdp_addr_internal_storage(PDPElement) of + {ok,PDPAddress} -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true}, + UpdatedCreateReq = CreateReq#sesT_createReqV0{endUserAdd = PDPAddress}, + decode_ie_create(Rest,PresentIEs bor 32,UpdatedErrors,UpdatedCreateReq); + {fault} -> + UpdatedErrors = Errors#protocolErrors{invalidManIE = true, + outOfSequence = true}, + decode_ie_create(Rest,PresentIEs bor 32,UpdatedErrors,CreateReq) + end; + true -> + case pdp_addr_internal_storage(PDPElement) of + {ok,PDPAddress} -> + UpdatedCreateReq = CreateReq#sesT_createReqV0{endUserAdd = PDPAddress}, + decode_ie_create(Rest,PresentIEs bor 32,Errors,UpdatedCreateReq); + {fault} -> + UpdatedErrors = Errors#protocolErrors{invalidManIE = true}, + decode_ie_create(Rest,PresentIEs bor 32,UpdatedErrors,CreateReq) + end + end; +decode_ie_create(<<131:8, + Length:16, + More/binary>>,PresentIEs,Errors,CreateReq) -> + <<APNElement:Length/binary-unit:8, + Rest/binary>> = More, + if + PresentIEs band 64 == 64 -> + decode_ie_create(Rest,PresentIEs,Errors,CreateReq); + PresentIEs > 64 -> + case catch apn_internal_storage(APNElement,[]) of + {ok,APN} -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true}, + UpdatedCreateReq = CreateReq#sesT_createReqV0{accPointName = APN}, + decode_ie_create(Rest,PresentIEs bor 64,UpdatedErrors,UpdatedCreateReq); + _ -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true, + invalidManIE = true}, + decode_ie_create(Rest,PresentIEs bor 64,UpdatedErrors,CreateReq) + end; + true -> + case catch apn_internal_storage(APNElement,[]) of + {ok,APN} -> + UpdatedCreateReq = CreateReq#sesT_createReqV0{accPointName = APN}, + decode_ie_create(Rest,PresentIEs bor 64,Errors,UpdatedCreateReq); + _ -> + UpdatedErrors = Errors#protocolErrors{invalidManIE = true}, + decode_ie_create(Rest,PresentIEs bor 64,UpdatedErrors,CreateReq) + end + end; +decode_ie_create(<<132:8, + Length:16, + More/binary>>,PresentIEs,Errors,CreateReq) -> + <<ConfigurationElement:Length/binary-unit:8, + Rest/binary>> = More, + if + PresentIEs band 128 == 128 -> + decode_ie_create(Rest,PresentIEs,Errors,CreateReq); + PresentIEs > 128 -> + case catch pco_internal_storage(ConfigurationElement) of + {ok,PCO} -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true}, + UpdatedCreateReq = CreateReq#sesT_createReqV0{protConOpt = PCO}, + decode_ie_create(Rest,PresentIEs bor 128,UpdatedErrors,UpdatedCreateReq); + _ -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true, + incorrectOptIE = true}, + decode_ie_create(Rest,PresentIEs bor 128,UpdatedErrors,CreateReq) + end; + true -> + case catch pco_internal_storage(ConfigurationElement) of + {ok,PCO} -> + UpdatedCreateReq = CreateReq#sesT_createReqV0{protConOpt = PCO}, + decode_ie_create(Rest,PresentIEs bor 128,Errors,UpdatedCreateReq); + _ -> + UpdatedErrors = Errors#protocolErrors{incorrectOptIE = true}, + decode_ie_create(Rest,PresentIEs bor 128,UpdatedErrors,CreateReq) + end + end; +decode_ie_create(<<133:8, + Length:16, + More/binary>>,PresentIEs,Errors,CreateReq) -> + <<AddressElement:Length/binary-unit:8, + Rest/binary>> = More, + if + PresentIEs band 768 == 768 -> + decode_ie_create(Rest,PresentIEs,Errors,CreateReq); + PresentIEs > 512 -> + if + PresentIEs band 256 == 0 -> + case gsn_addr_internal_storage(AddressElement) of + {ok,GSNAddr} -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true}, + UpdatedCreateReq = CreateReq#sesT_createReqV0{sgsnAddSig = GSNAddr}, + decode_ie_create(Rest,PresentIEs bor 256,UpdatedErrors,UpdatedCreateReq); + {fault} -> + UpdatedErrors = Errors#protocolErrors{invalidManIE = true, + outOfSequence = true}, + decode_ie_create(Rest,PresentIEs bor 256,UpdatedErrors,CreateReq) + end; + true -> + case gsn_addr_internal_storage(AddressElement) of + {ok,GSNAddr} -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true}, + UpdatedCreateReq = CreateReq#sesT_createReqV0{sgsnAddUser = GSNAddr}, + decode_ie_create(Rest,PresentIEs bor 512,UpdatedErrors,UpdatedCreateReq); + {fault} -> + UpdatedErrors = Errors#protocolErrors{invalidManIE = true, + outOfSequence = true}, + decode_ie_create(Rest,PresentIEs bor 512,UpdatedErrors,CreateReq) + end + end; + PresentIEs < 256 -> + case gsn_addr_internal_storage(AddressElement) of + {ok,GSNAddr} -> + UpdatedCreateReq = CreateReq#sesT_createReqV0{sgsnAddSig = GSNAddr}, + decode_ie_create(Rest,PresentIEs bor 256,Errors,UpdatedCreateReq); + {fault} -> + UpdatedErrors = Errors#protocolErrors{invalidManIE = true}, + decode_ie_create(Rest,PresentIEs bor 256,UpdatedErrors,CreateReq) + end; + true -> + case gsn_addr_internal_storage(AddressElement) of + {ok,GSNAddr} -> + UpdatedCreateReq = CreateReq#sesT_createReqV0{sgsnAddUser = GSNAddr}, + decode_ie_create(Rest,PresentIEs bor 512,Errors,UpdatedCreateReq); + {fault} -> + UpdatedErrors = Errors#protocolErrors{invalidManIE = true}, + decode_ie_create(Rest,PresentIEs bor 512,UpdatedErrors,CreateReq) + end + end; +decode_ie_create(<<134:8, + Length:16, + More/binary>>,PresentIEs,Errors,CreateReq) -> + <<MSISDNElement:Length/binary-unit:8, + Rest/binary>> = More, + if + PresentIEs band 1024 == 1024 -> + decode_ie_create(Rest,PresentIEs,Errors,CreateReq); + PresentIEs > 1024 -> + case msisdn_internal_storage(MSISDNElement,[]) of + {ok,MSISDN} -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true}, + UpdatedCreateReq = CreateReq#sesT_createReqV0{msisdn = MSISDN}, + decode_ie_create(Rest,PresentIEs bor 1024,UpdatedErrors,UpdatedCreateReq); + {fault} -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true, + invalidManIE = true}, + decode_ie_create(Rest,PresentIEs bor 1024,UpdatedErrors,CreateReq) + end; + true -> + UpdatedCreateReq = CreateReq#sesT_createReqV0{msisdn = #mvsT_msisdn{value = MSISDNElement}}, + decode_ie_create(Rest,PresentIEs bor 1024,Errors,UpdatedCreateReq) + end; +decode_ie_create(UnexpectedIE,PresentIEs,Errors,CreateReq) -> + case check_ie(UnexpectedIE) of + {defined_ie,Rest} -> + decode_ie_create(Rest,PresentIEs,Errors,CreateReq); + {handled_ie,Rest} -> + decode_ie_create(Rest,PresentIEs,Errors,CreateReq); + {unhandled_ie} -> + {fault,193,CreateReq} + end. + +decode_ie_update(<<>>,PresentIEs,Errors,UpdateReq) -> + if + PresentIEs band 61 /= 61 -> + {fault,202,UpdateReq}; + true -> + case Errors of + #protocolErrors{invalidManIE = true} -> + {fault,201,UpdateReq}; + #protocolErrors{outOfSequence = true} -> + {fault,193,UpdateReq}; + #protocolErrors{incorrectOptIE = true} -> + {fault,203,UpdateReq}; + _ -> + {ok,UpdateReq} + end + end; +decode_ie_update(<<6:8, + QoSElement:3/binary-unit:8, + Rest/binary>>,PresentIEs,Errors,UpdateReq) -> + if + PresentIEs band 1 == 1 -> + decode_ie_update(Rest,PresentIEs,Errors,UpdateReq); + PresentIEs > 1 -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true}, + <<_:2, + DelayClass:3, + ReliabilityClass:3, + PeakThroughput:4, + _:1, + PrecedenceClass:3, + _:3, + MeanThroughput:5>> = QoSElement, + QoS = #sesT_qualityOfServiceV0{delayClass = DelayClass, + reliabilityClass = ReliabilityClass, + peakThroughput = PeakThroughput, + precedenceClass = PrecedenceClass, + meanThroughput = MeanThroughput}, + UpdatedUpdateReq = UpdateReq#sesT_updateReqV0{qos = QoS}, + decode_ie_update(Rest,PresentIEs bor 1,UpdatedErrors,UpdatedUpdateReq); + true -> + <<_:2, + DelayClass:3, + ReliabilityClass:3, + PeakThroughput:4, + _:1, + PrecedenceClass:3, + _:3, + MeanThroughput:5>> = QoSElement, + QoS = #sesT_qualityOfServiceV0{delayClass = DelayClass, + reliabilityClass = ReliabilityClass, + peakThroughput = PeakThroughput, + precedenceClass = PrecedenceClass, + meanThroughput = MeanThroughput}, + UpdatedUpdateReq = UpdateReq#sesT_updateReqV0{qos = QoS}, + decode_ie_update(Rest,PresentIEs bor 1,Errors,UpdatedUpdateReq) + end; +decode_ie_update(<<14:8, + Recovery:8, + Rest/binary>>,PresentIEs,Errors,UpdateReq) -> + if + PresentIEs band 2 == 2 -> + decode_ie_update(Rest,PresentIEs,Errors,UpdateReq); + PresentIEs > 2 -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true}, + UpdatedUpdateReq = UpdateReq#sesT_updateReqV0{recovery = Recovery}, + decode_ie_update(Rest,PresentIEs bor 2,UpdatedErrors,UpdatedUpdateReq); + true -> + UpdatedUpdateReq = UpdateReq#sesT_updateReqV0{recovery = Recovery}, + decode_ie_update(Rest,PresentIEs bor 2,Errors,UpdatedUpdateReq) + end; +decode_ie_update(<<16:8, + FlowLabel:16, + Rest/binary>>,PresentIEs,Errors,UpdateReq) -> + if + PresentIEs band 4 == 4 -> + decode_ie_update(Rest,PresentIEs,Errors,UpdateReq); + PresentIEs > 4 -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true}, + UpdatedUpdateReq = UpdateReq#sesT_updateReqV0{flowLblData = FlowLabel}, + decode_ie_update(Rest,PresentIEs bor 4,UpdatedErrors,UpdatedUpdateReq); + true -> + UpdatedUpdateReq = UpdateReq#sesT_updateReqV0{flowLblData = FlowLabel}, + decode_ie_update(Rest,PresentIEs bor 4,Errors,UpdatedUpdateReq) + end; +decode_ie_update(<<17:8, + FlowLabel:16, + Rest/binary>>,PresentIEs,Errors,UpdateReq) -> + if + PresentIEs band 8 == 8 -> + decode_ie_update(Rest,PresentIEs,Errors,UpdateReq); + PresentIEs > 8 -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true}, + UpdatedUpdateReq = UpdateReq#sesT_updateReqV0{flowLblSig = FlowLabel}, + decode_ie_update(Rest,PresentIEs bor 8,UpdatedErrors,UpdatedUpdateReq); + true -> + UpdatedUpdateReq = UpdateReq#sesT_updateReqV0{flowLblSig = FlowLabel}, + decode_ie_update(Rest,PresentIEs bor 8,Errors,UpdatedUpdateReq) + end; +decode_ie_update(<<133:8, + Length:16, + More/binary>>,PresentIEs,Errors,UpdateReq) -> + <<AddressElement:Length/binary-unit:8, + Rest/binary>> = More, + if + PresentIEs band 48 == 48 -> + decode_ie_update(Rest,PresentIEs,Errors,UpdateReq); + PresentIEs > 32 -> + if + PresentIEs band 16 == 0 -> + case gsn_addr_internal_storage(AddressElement) of + {ok,GSNAddr} -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true}, + UpdatedUpdateReq = UpdateReq#sesT_updateReqV0{sgsnAddSig = GSNAddr}, + decode_ie_update(Rest,PresentIEs bor 16,UpdatedErrors,UpdatedUpdateReq); + {fault} -> + UpdatedErrors = Errors#protocolErrors{invalidManIE = true, + outOfSequence = true}, + decode_ie_update(Rest,PresentIEs bor 16,UpdatedErrors,UpdateReq) + end; + true -> + case gsn_addr_internal_storage(AddressElement) of + {ok,GSNAddr} -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true}, + UpdatedUpdateReq = UpdateReq#sesT_updateReqV0{sgsnAddUser = GSNAddr}, + decode_ie_update(Rest,PresentIEs bor 32,UpdatedErrors,UpdatedUpdateReq); + {fault} -> + UpdatedErrors = Errors#protocolErrors{invalidManIE = true, + outOfSequence = true}, + decode_ie_update(Rest,PresentIEs bor 32,UpdatedErrors,UpdateReq) + end + end; + PresentIEs < 16 -> + case gsn_addr_internal_storage(AddressElement) of + {ok,GSNAddr} -> + UpdatedUpdateReq = UpdateReq#sesT_updateReqV0{sgsnAddSig = GSNAddr}, + decode_ie_update(Rest,PresentIEs bor 16,Errors,UpdatedUpdateReq); + {fault} -> + UpdatedErrors = Errors#protocolErrors{invalidManIE = true}, + decode_ie_update(Rest,PresentIEs bor 16,UpdatedErrors,UpdateReq) + end; + true -> + case gsn_addr_internal_storage(AddressElement) of + {ok,GSNAddr} -> + UpdatedUpdateReq = UpdateReq#sesT_updateReqV0{sgsnAddUser = GSNAddr}, + decode_ie_update(Rest,PresentIEs bor 32,Errors,UpdatedUpdateReq); + {fault} -> + UpdatedErrors = Errors#protocolErrors{invalidManIE = true}, + decode_ie_update(Rest,PresentIEs bor 32,UpdatedErrors,UpdateReq) + end + end; +decode_ie_update(UnexpectedIE,PresentIEs,Errors,UpdateReq) -> + case check_ie(UnexpectedIE) of + {defined_ie,Rest} -> + decode_ie_update(Rest,PresentIEs,Errors,UpdateReq); + {handled_ie,Rest} -> + decode_ie_update(Rest,PresentIEs,Errors,UpdateReq); + {unhandled_ie} -> + {fault,193,UpdateReq} + end. + +decode_ie_delete_res(<<>>,PresentIEs,Errors,DeleteRes) -> + if + PresentIEs band 1 /= 1 -> + {fault,202,DeleteRes}; + true -> + case Errors of + #protocolErrors{invalidManIE = true} -> + {fault,201,DeleteRes}; + #protocolErrors{outOfSequence = true} -> + {fault,193,DeleteRes}; + #protocolErrors{incorrectOptIE = true} -> + {fault,203,DeleteRes}; + _ -> + {ok,DeleteRes} + end + end; +decode_ie_delete_res(<<1:8, + Cause:8, + Rest/binary>>,PresentIEs,Errors,DeleteRes) -> + if + PresentIEs band 1 == 1 -> + decode_ie_delete_res(Rest,PresentIEs,Errors,DeleteRes); + PresentIEs > 1 -> + UpdatedErrors = Errors#protocolErrors{outOfSequence = true}, + UpdatedDeleteRes = DeleteRes#sesT_deleteResV0{cause = Cause}, + decode_ie_delete_res(Rest,PresentIEs bor 1,UpdatedErrors,UpdatedDeleteRes); + true -> + UpdatedDeleteRes = DeleteRes#sesT_deleteResV0{cause = Cause}, + decode_ie_delete_res(Rest,PresentIEs bor 1,Errors,UpdatedDeleteRes) + end; +decode_ie_delete_res(UnexpectedIE,PresentIEs,Errors,DeleteRes) -> + case check_ie(UnexpectedIE) of + {defined_ie,Rest} -> + decode_ie_delete_res(Rest,PresentIEs,Errors,DeleteRes); + {handled_ie,Rest} -> + decode_ie_delete_res(Rest,PresentIEs,Errors,DeleteRes); + {unhandled_ie} -> + {fault,193,DeleteRes} + end. + +check_ie(<<1:8, + _:8, + Rest/binary>>) -> + {defined_ie,Rest}; +check_ie(<<2:8, + _:8/binary-unit:8, + Rest/binary>>) -> + {defined_ie,Rest}; +check_ie(<<3:8, + _:6/binary-unit:8, + Rest/binary>>) -> + {defined_ie,Rest}; +check_ie(<<4:8, + _:4/binary-unit:8, + Rest/binary>>) -> + {defined_ie,Rest}; +check_ie(<<5:8, + _:4/binary-unit:8, + Rest/binary>>) -> + {defined_ie,Rest}; +check_ie(<<6:8, + _:3/binary-unit:8, + Rest/binary>>) -> + {defined_ie,Rest}; +check_ie(<<8:8, + _:8, + Rest/binary>>) -> + {defined_ie,Rest}; +check_ie(<<9:8, + _:28/binary-unit:8, + Rest/binary>>) -> + {defined_ie,Rest}; +check_ie(<<11:8, + _:8, + Rest/binary>>) -> + {defined_ie,Rest}; +check_ie(<<12:8, + _:3/binary-unit:8, + Rest/binary>>) -> + {defined_ie,Rest}; +check_ie(<<13:8, + _:8, + Rest/binary>>) -> + {defined_ie,Rest}; +check_ie(<<14:8, + _:8, + Rest/binary>>) -> + {defined_ie,Rest}; +check_ie(<<15:8, + _:8, + Rest/binary>>) -> + {defined_ie,Rest}; +check_ie(<<16:8, + _:16, + Rest/binary>>) -> + {defined_ie,Rest}; +check_ie(<<17:8, + _:16, + Rest/binary>>) -> + {defined_ie,Rest}; +check_ie(<<18:8, + _:32, + Rest/binary>>) -> + {defined_ie,Rest}; +check_ie(<<19:8, + _:8, + Rest/binary>>) -> + {defined_ie,Rest}; +check_ie(<<127:8, + _:4/binary-unit:8, + Rest/binary>>) -> + {defined_ie,Rest}; +check_ie(<<1:1, + _:7, + Length:16, + More/binary>>) -> + if + Length > size(More) -> + {unhandled_ie}; + true -> + <<_:Length/binary-unit:8, + Rest/binary>> = More, + {handled_ie,Rest} + end; +check_ie(_UnhandledIE) -> + {unhandled_ie}. + +tid_internal_storage(Bin,_) -> + Size = size(Bin) - 1, + <<Front:Size/binary, + NSAPI:4, + DigitN:4>> = Bin, + Result = case DigitN of + 15 -> + #mvsgT_tid{imsi = #mvsgT_imsi{value = Front}, + nsapi = NSAPI}; + _ -> + #mvsgT_tid{imsi = #mvsgT_imsi{value = <<Front/binary, + 15:4, + DigitN:4>>}, + nsapi = NSAPI} + end, + {ok,Result}. + +selection_mode_internal_storage(0) -> + subscribed; +selection_mode_internal_storage(1) -> + msRequested; +selection_mode_internal_storage(2) -> + sgsnSelected; +selection_mode_internal_storage(3) -> + sgsnSelected. + +pdp_addr_internal_storage(<<_:4, + 0:4, + 1:8>>) -> + {ok,#mvsgT_pdpAddressType{pdpTypeNbr = etsi_ppp, + address = []}}; +pdp_addr_internal_storage(<<_:4, + 0:4, + 2:8>>) -> + {ok,#mvsgT_pdpAddressType{pdpTypeNbr = etsi_osp_ihoss, + address = []}}; +pdp_addr_internal_storage(<<_:4, + 1:4, + 33:8>>) -> + {ok,#mvsgT_pdpAddressType{pdpTypeNbr = ietf_ipv4, + address = []}}; +pdp_addr_internal_storage(<<_:4, + 1:4, + 33:8, + IP_A:8, + IP_B:8, + IP_C:8, + IP_D:8>>) -> + {ok,#mvsgT_pdpAddressType{pdpTypeNbr = ietf_ipv4, + address = [IP_A,IP_B,IP_C,IP_D]}}; +pdp_addr_internal_storage(<<_:4, + 1:4, + 87:8, + IP_A:16, + IP_B:16, + IP_C:16, + IP_D:16, + IP_E:16, + IP_F:16, + IP_G:16, + IP_H:16>>) -> + {ok,#mvsgT_pdpAddressType{pdpTypeNbr = ietf_ipv6, + address = [IP_A,IP_B,IP_C,IP_D,IP_E,IP_F,IP_G,IP_H]}}; +pdp_addr_internal_storage(_PDP_ADDR) -> + {fault}. + +apn_internal_storage(<<>>,APN) -> + {ok,lists:reverse(APN)}; +apn_internal_storage(<<Length:8, + Rest/binary>>,APN) -> + <<Label:Length/binary-unit:8, + MoreAPNLabels/binary>> = Rest, + apn_internal_storage(MoreAPNLabels,[Label|APN]). + +pco_internal_storage(<<1:1, + _:4, + 0:3, + PPPConfigurationOptions/binary>>) -> + case ppp_configuration_options(PPPConfigurationOptions,#masT_pap{exists = false},[],[]) of + {ok,PAP,CHAP,IPCP} -> + {ok,#masT_protocolConfigOptions{pap = PAP, + chap = CHAP, + ipcp = IPCP}}; + {fault} -> + {fault} + end; +pco_internal_storage(<<1:1, + _:4, + 1:3, + _OSP_IHOSSConfigurationOptions/binary>>) -> + {ok,osp_ihoss}; +pco_internal_storage(_UnknownConfigurationOptions) -> + {fault}. + +ppp_configuration_options(<<>>,PAP,CHAP,IPCP) -> + {ok,PAP,CHAP,IPCP}; +ppp_configuration_options(<<49185:16, + Length:8, + More/binary>>,PAP,CHAP,IPCP) -> + <<_LCP:Length/binary-unit:8, + Rest/binary>> = More, + ppp_configuration_options(Rest,PAP,CHAP,IPCP); +ppp_configuration_options(<<49187:16, + _Length:8, + 1:8, + Identifier:8, + DataLength:16, + More/binary>>,_PAP,CHAP,IPCP) -> + ActualDataLength = DataLength - 4, + <<Data:ActualDataLength/binary-unit:8, + Rest/binary>> = More, + <<PeerIDLength:8, + PeerData/binary>> = Data, + <<PeerID:PeerIDLength/binary-unit:8, + PasswdLength:8, + PasswordData/binary>> = PeerData, + <<Password:PasswdLength/binary, + _Padding/binary>> = PasswordData, + ppp_configuration_options(Rest,#masT_pap{exists = true, + code = 1, + id = Identifier, + username = binary_to_list(PeerID), + password = binary_to_list(Password)},CHAP,IPCP); +ppp_configuration_options(<<49187:16, + Length:8, + More/binary>>,PAP,CHAP,IPCP) -> + <<PAP:Length/binary-unit:8, + Rest/binary>> = More, + ppp_configuration_options(Rest,PAP,CHAP,IPCP); +ppp_configuration_options(<<49699:16, + _Length:8, + 1:8, + Identifier:8, + DataLength:16, + More/binary>>,PAP,CHAP,IPCP) -> + ActualDataLength = DataLength - 4, + <<Data:ActualDataLength/binary-unit:8, + Rest/binary>> = More, + <<ValueSize:8, + ValueAndName/binary>> = Data, + <<Value:ValueSize/binary-unit:8, + Name/binary>> = ValueAndName, + ppp_configuration_options(Rest,PAP,[#masT_chap{code = 1, + id = Identifier, + value = binary_to_list(Value), + name = binary_to_list(Name)}|CHAP],IPCP); +ppp_configuration_options(<<49699:16, + _Length:8, + 2:8, + Identifier:8, + DataLength:16, + More/binary>>,PAP,CHAP,IPCP) -> + ActualDataLength = DataLength - 4, + <<Data:ActualDataLength/binary-unit:8, + Rest/binary>> = More, + <<ValueSize:8, + ValueAndName/binary>> = Data, + <<Value:ValueSize/binary-unit:8, + Name/binary>> = ValueAndName, + ppp_configuration_options(Rest,PAP,[#masT_chap{code = 2, + id = Identifier, + value = binary_to_list(Value), + name = binary_to_list(Name)}|CHAP],IPCP); +ppp_configuration_options(<<49699:16, + Length:8, + More/binary>>,PAP,CHAP,IPCP) -> + <<CHAP:Length/binary-unit:8, + Rest/binary>> = More, + ppp_configuration_options(Rest,PAP,CHAP,IPCP); +ppp_configuration_options(<<32801:16, + _Length:8, + 1:8, + Identifier:8, + OptionsLength:16, + More/binary>>,PAP,CHAP,IPCP) -> + ActualOptionsLength = OptionsLength - 4, + <<Options:ActualOptionsLength/binary-unit:8, + Rest/binary>> = More, + case Options of + <<3:8, + 6:8, + A1:8, + A2:8, + A3:8, + A4:8>> -> + ppp_configuration_options(Rest,PAP,CHAP,[#masT_ipcp{exists = true, + code = 1, + id = Identifier, + ipcpList = [#masT_ipcpData{type = 3, + ipAddress = #mvsgT_ipAddress{version = ipv4, + a1 = A1, + a2 = A2, + a3 = A3, + a4 = A4, + a5 = 0, + a6 = 0, + a7 = 0, + a8 = 0}, + rawMessage = binary_to_list(Options)}]}|IPCP]); + <<129:8, + 6:8, + B1:8, + B2:8, + B3:8, + B4:8>> -> + ppp_configuration_options(Rest,PAP,CHAP,[#masT_ipcp{exists = true, + code = 1, + id = Identifier, + ipcpList = [#masT_ipcpData{type = 129, + ipAddress = #mvsgT_ipAddress{version = ipv4, + a1 = B1, + a2 = B2, + a3 = B3, + a4 = B4}, + rawMessage = binary_to_list(Options)}]}|IPCP]); + <<131:8, + 6:8, + C1:8, + C2:8, + C3:8, + C4:8>> -> + ppp_configuration_options(Rest,PAP,CHAP,[#masT_ipcp{exists = true, + code = 1, + id = Identifier, + ipcpList = [#masT_ipcpData{type = 131, + ipAddress = #mvsgT_ipAddress{version = ipv4, + a1 = C1, + a2 = C2, + a3 = C3, + a4 = C4}, + rawMessage = binary_to_list(Options)}]}|IPCP]); + _ -> + ppp_configuration_options(Rest,PAP,CHAP,IPCP) + end; +ppp_configuration_options(<<_UnknownProtocolID:16, + Length:8, + More/binary>>,PAP,CHAP,IPCP) -> + <<_Skipped:Length/binary-unit:8, + Rest/binary>> = More, + ppp_configuration_options(Rest,PAP,CHAP,IPCP); +ppp_configuration_options(_Unhandled,_PAP,_CHAP,_IPCP) -> + {fault}. + +gsn_addr_internal_storage(<<IP_A:8, + IP_B:8, + IP_C:8, + IP_D:8>>) -> + {ok,#mvsgT_ipAddress{version = ipv4, + a1 = IP_A, + a2 = IP_B, + a3 = IP_C, + a4 = IP_D, + a5 = 0, + a6 = 0, + a7 = 0, + a8 = 0}}; +gsn_addr_internal_storage(<<IP_A:16, + IP_B:16, + IP_C:16, + IP_D:16, + IP_E:16, + IP_F:16, + IP_G:16, + IP_H:16>>) -> + {ok,#mvsgT_ipAddress{version = ipv6, + a1 = IP_A, + a2 = IP_B, + a3 = IP_C, + a4 = IP_D, + a5 = IP_E, + a6 = IP_F, + a7 = IP_G, + a8 = IP_H}}; +gsn_addr_internal_storage(_GSN_ADDR) -> + {fault}. + +msisdn_internal_storage(<<>>,MSISDN) -> + {ok,#mvsT_msisdn{value = lists:reverse(MSISDN)}}; +msisdn_internal_storage(<<255:8, + _Rest/binary>>,MSISDN) -> + {ok,#mvsT_msisdn{value = lists:reverse(MSISDN)}}; +msisdn_internal_storage(<<15:4, + DigitN:4, + _Rest/binary>>,MSISDN) when DigitN < 10 -> + {ok,#mvsT_msisdn{value = lists:reverse([DigitN bor 240|MSISDN])}}; +msisdn_internal_storage(<<DigitNplus1:4, + DigitN:4, + Rest/binary>>,MSISDN) when DigitNplus1 < 10, DigitN < 10 -> + NewMSISDN = [DigitNplus1 bsl 4 bor DigitN|MSISDN], + msisdn_internal_storage(Rest,NewMSISDN); +msisdn_internal_storage(_Rest,_MSISDN) -> + {fault}. diff --git a/lib/compiler/test/inline_SUITE_data/bsdes.erl b/lib/compiler/test/inline_SUITE_data/bsdes.erl new file mode 100644 index 0000000000..8d2d1a8287 --- /dev/null +++ b/lib/compiler/test/inline_SUITE_data/bsdes.erl @@ -0,0 +1,747 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2006-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(bsdes). +-export([?MODULE/0]). + +-define(ITERATIONS, 100). %% for benchmarking use a higher number + +?MODULE() -> + Res = test(), + {Res,Res =:= <<0,0,0,0,0,0,0,1>>}. + +test() -> + Bin = <<1:64>>, + Size= size(Bin), + Key = <<4704650607608769871263876:64>>, + Jumbled = run_encode(?ITERATIONS, Bin, Key), + Unjumbled = run_decode(?ITERATIONS, Jumbled, Key), + <<Bin:Size/binary,_/binary>> = Unjumbled. + +run_encode(1, Bin, Key) -> + encode(Bin, Key); +run_encode(N, Bin, Key) -> + encode(Bin, Key), + run_encode(N-1, Bin, Key). + +run_decode(1, Bin, Key) -> + decode(Bin, Key); +run_decode(N, Bin, Key) -> + decode(Bin, Key), + run_decode(N-1, Bin, Key). + +encode(Data, Key) -> + Keys = schedule(Key), + list_to_binary(encode_data(Data, Keys)). + +decode(Data, Key) -> + Keys = lists:reverse(schedule(Key)), + list_to_binary(decode_data(Data, Keys)). + +encode_data(<<Data:8/binary, Rest/binary>>, Keys) -> + [ipinv(des_core(ip(Data), Keys))|encode_data(Rest, Keys)]; +encode_data(<<Rest/binary>>, Keys) -> + case size(Rest) of + 0 -> []; + X -> + Y = 8-X, + Data = <<Rest/binary, 0:Y/integer-unit:8>>, + [ipinv(des_core(ip(Data), Keys))] + end. + +decode_data(<<Data:8/binary, Rest/binary>>, Keys) -> + [ipinv(dechiper(ip(Data), Keys))|decode_data(Rest, Keys)]; +decode_data(_, _Keys) -> + []. + +schedule(Key) -> + NewKey=pc1(Key), + subkeys(NewKey, 1). + +subkeys(_Key, 17) -> + []; +subkeys(Key, N) -> + TmpKey = + case rotate(N) of + 1 -> + <<X1:1, L:27, X2:1, R:27>> = Key, + <<L:27, X1:1, R:27, X2:1>>; + 2 -> + <<X1:2, L:26, X2:2, R:26>> = Key, + <<L:26, X1:2, R:26, X2:2>>; + _ -> + error + end, + [pc2(TmpKey)|subkeys(TmpKey, N+1)]. + +pc2(<<I1:1, I2:1, I3:1, I4:1, I5:1, I6:1, I7:1, I8:1, + _I9:1, I10:1, I11:1, I12:1, I13:1, I14:1, I15:1, I16:1, + I17:1, _I18:1, I19:1, I20:1, I21:1, _I22:1, I23:1, I24:1, + _I25:1, I26:1, I27:1, I28:1, I29:1, I30:1, I31:1, I32:1, + I33:1, I34:1, _I35:1, I36:1, I37:1, _I38:1, I39:1, I40:1, + I41:1, I42:1, _I43:1, I44:1, I45:1, I46:1, I47:1, I48:1, + I49:1, I50:1, I51:1, I52:1, I53:1, _I54:1, I55:1, I56:1>>) -> + <<I14:1, I17:1, I11:1, I24:1, I1:1, I5:1, I3:1, I28:1, + I15:1, I6:1, I21:1, I10:1, I23:1, I19:1, I12:1, I4:1, + I26:1, I8:1, I16:1, I7:1, I27:1, I20:1, I13:1, I2:1, + I41:1, I52:1, I31:1, I37:1, I47:1, I55:1, I30:1, I40:1, + I51:1, I45:1, I33:1, I48:1, I44:1, I49:1, I39:1, I56:1, + I34:1, I53:1, I46:1, I42:1, I50:1, I36:1, I29:1, I32:1>>. + +pc1(<<I1:1, I2:1, I3:1, I4:1, I5:1, I6:1, I7:1, _:1, + I9:1, I10:1, I11:1, I12:1, I13:1, I14:1, I15:1, _:1, + I17:1, I18:1, I19:1, I20:1, I21:1, I22:1, I23:1, _:1, + I25:1, I26:1, I27:1, I28:1, I29:1, I30:1, I31:1, _:1, + I33:1, I34:1, I35:1, I36:1, I37:1, I38:1, I39:1, _:1, + I41:1, I42:1, I43:1, I44:1, I45:1, I46:1, I47:1, _:1, + I49:1, I50:1, I51:1, I52:1, I53:1, I54:1, I55:1, _:1, + I57:1, I58:1, I59:1, I60:1, I61:1, I62:1, I63:1, _:1>>) -> + <<I57:1, I49:1, I41:1, I33:1, I25:1, I17:1, I9:1, I1:1, + I58:1, I50:1, I42:1, I34:1, I26:1, I18:1, I10:1, I2:1, + I59:1, I51:1, I43:1, I35:1, I27:1, I19:1, I11:1, I3:1, + I60:1, I52:1, I44:1, I36:1, I63:1, I55:1, I47:1, I39:1, + I31:1, I23:1, I15:1, I7:1, I62:1, I54:1, I46:1, I38:1, + I30:1, I22:1, I14:1, I6:1, I61:1, I53:1, I45:1, I37:1, + I29:1, I21:1, I13:1, I5:1, I28:1, I20:1, I12:1, I4:1>>. + +ip(<<I1:1, I2:1, I3:1, I4:1, I5:1, I6:1, I7:1, I8:1, + I9:1, I10:1, I11:1, I12:1, I13:1, I14:1, I15:1, I16:1, + I17:1, I18:1, I19:1, I20:1, I21:1, I22:1, I23:1, I24:1, + I25:1, I26:1, I27:1, I28:1, I29:1, I30:1, I31:1, I32:1, + I33:1, I34:1, I35:1, I36:1, I37:1, I38:1, I39:1, I40:1, + I41:1, I42:1, I43:1, I44:1, I45:1, I46:1, I47:1, I48:1, + I49:1, I50:1, I51:1, I52:1, I53:1, I54:1, I55:1, I56:1, + I57:1, I58:1, I59:1, I60:1, I61:1, I62:1, I63:1, I64:1>>) -> + <<I58:1, I50:1, I42:1, I34:1, I26:1, I18:1, I10:1, I2:1, + I60:1, I52:1, I44:1, I36:1, I28:1, I20:1, I12:1, I4:1, + I62:1, I54:1, I46:1, I38:1, I30:1, I22:1, I14:1, I6:1, + I64:1, I56:1, I48:1, I40:1, I32:1, I24:1, I16:1, I8:1, + I57:1, I49:1, I41:1, I33:1, I25:1, I17:1, I9:1, I1:1, + I59:1, I51:1, I43:1, I35:1, I27:1, I19:1, I11:1, I3:1, + I61:1, I53:1, I45:1, I37:1, I29:1, I21:1, I13:1, I5:1, + I63:1, I55:1, I47:1, I39:1, I31:1, I23:1, I15:1, I7:1>>. + +ipinv(<<I58:1, I50:1, I42:1, I34:1, I26:1, I18:1, I10:1, I2:1, + I60:1, I52:1, I44:1, I36:1, I28:1, I20:1, I12:1, I4:1, + I62:1, I54:1, I46:1, I38:1, I30:1, I22:1, I14:1, I6:1, + I64:1, I56:1, I48:1, I40:1, I32:1, I24:1, I16:1, I8:1, + I57:1, I49:1, I41:1, I33:1, I25:1, I17:1, I9:1, I1:1, + I59:1, I51:1, I43:1, I35:1, I27:1, I19:1, I11:1, I3:1, + I61:1, I53:1, I45:1, I37:1, I29:1, I21:1, I13:1, I5:1, + I63:1, I55:1, I47:1, I39:1, I31:1, I23:1, I15:1, I7:1>>) -> + <<I1:1, I2:1, I3:1, I4:1, I5:1, I6:1, I7:1, I8:1, + I9:1, I10:1, I11:1, I12:1, I13:1, I14:1, I15:1, I16:1, + I17:1, I18:1, I19:1, I20:1, I21:1, I22:1, I23:1, I24:1, + I25:1, I26:1, I27:1, I28:1, I29:1, I30:1, I31:1, I32:1, + I33:1, I34:1, I35:1, I36:1, I37:1, I38:1, I39:1, I40:1, + I41:1, I42:1, I43:1, I44:1, I45:1, I46:1, I47:1, I48:1, + I49:1, I50:1, I51:1, I52:1, I53:1, I54:1, I55:1, I56:1, + I57:1, I58:1, I59:1, I60:1, I61:1, I62:1, I63:1, I64:1>>. + +dechiper(<<L:4/binary, R:4/binary>>, Keys) -> + dechiper(L, R, Keys, 16). + +dechiper(L, R, [], 0) -> + <<L:4/binary, R:4/binary>>; +dechiper(L, R, [Key|Rest], I) -> + NewL=ebit(L), + XorL=xor48(NewL, Key), + Sboxed=sboxing(XorL), + Ped=p(Sboxed), + EndL = xor32(Ped, R), + dechiper(EndL,L,Rest,I-1). + +des_core(<<L:4/binary, R:4/binary>>, Keys) -> + des_core(L, R, Keys, 0). + +des_core(L, R, [], 16) -> + <<L:4/binary, R:4/binary>>; +des_core(L, R, [Key|Rest], I) when I<16 -> + NewR=ebit(R), + XorR=xor48(NewR, Key), + Sboxed=sboxing(XorR), + Ped=p(Sboxed), + EndR = xor32(Ped, L), + des_core(R, EndR, Rest, I+1). + +ebit(<<I1:1, I2:2, I3:2,I4:2,I5:2,I6:2, + I7:2,I8:2,I9:2,I10:2,I11:2,I12:2, + I13:2,I14:2,I15:2,I16:2,I17:1>>) -> + <<I17:1, I1:1, I2:2, I3:2, I3:2, + I4:2, I5:2, I5:2, I6:2, + I7:2, I7:2, I8:2, I9:2, + I9:2, I10:2, I11:2, I11:2, + I12:2, I13:2, I13:2, I14:2, + I15:2, I15:2, I16:2, I17:1, I1:1>>. + +p(<<I1:1, I2:1, I3:1, I4:1, I5:1, I6:1, I7:1, I8:1, + I9:1, I10:1, I11:1, I12:1, I13:1, I14:1, I15:1, I16:1, + I17:1, I18:1, I19:1, I20:1, I21:1, I22:1, I23:1, I24:1, + I25:1, I26:1, I27:1, I28:1, I29:1, I30:1, I31:1, I32:1>>) -> + <<I16:1, I7:1, I20:1, I21:1, I29:1, I12:1, I28:1, I17:1, + I1:1, I15:1, I23:1, I26:1, I5:1, I18:1, I31:1, I10:1, + I2:1, I8:1, I24:1, I14:1, I32:1, I27:1, I3:1, I9:1, + I19:1, I13:1, I30:1, I6:1, I22:1, I11:1, I4:1, I25:1>>. + +rotate(1) -> 1; +rotate(2) -> 1; +rotate(9) -> 1; +rotate(16) -> 1; +rotate(N) when N>0, N<17 -> 2. + +%xor64(<<I1:16, I2:16, I3:16, I4:16>>,<<J1:16, J2:16, J3:16, J4:16>>) -> +% K1 = I1 bxor J1, +% K2 = I2 bxor J2, +% K3 = I3 bxor J3, +% K4 = I4 bxor J4, +% <<K1:16, K2:16, K3:16, K4:16>>. + +xor48(<<I1:16, I2:16, I3:16>>,<<J1:16, J2:16, J3:16>>) -> + K1 = I1 bxor J1, + K2 = I2 bxor J2, + K3 = I3 bxor J3, + <<K1:16, K2:16, K3:16>>. + +xor32(<<I1:16, I2:16>>,<<J1:16, J2:16>>) -> + K1 = I1 bxor J1, + K2 = I2 bxor J2, + <<K1:16, K2:16>>. + +sboxing(<<A1:6, A2:6, A3:6, A4:6, A5:6, A6:6, A7:6, A8:6>>) -> + S1=sbox(A1, 1), + S2=sbox(A2, 2), + S3=sbox(A3, 3), + S4=sbox(A4, 4), + S5=sbox(A5, 5), + S6=sbox(A6, 6), + S7=sbox(A7, 7), + S8=sbox(A8, 8), + <<S1:4,S2:4,S3:4,S4:4,S5:4,S6:4,S7:4,S8:4>>. + +sbox(0,1) -> 14; +sbox(1,1) -> 0; +sbox(2,1) -> 4; +sbox(3,1) -> 15; +sbox(4,1) -> 13; +sbox(5,1) -> 7; +sbox(6,1) -> 1; +sbox(7,1) -> 4; +sbox(8,1) -> 2; +sbox(9,1) -> 14; +sbox(10,1) -> 15; +sbox(11,1) -> 2; +sbox(12,1) -> 11; +sbox(13,1) -> 13; +sbox(14,1) -> 8; +sbox(15,1) -> 1; +sbox(16,1) -> 3; +sbox(17,1) -> 10; +sbox(18,1) -> 10; +sbox(19,1) -> 6; +sbox(20,1) -> 6; +sbox(21,1) -> 12; +sbox(22,1) -> 12; +sbox(23,1) -> 11; +sbox(24,1) -> 5; +sbox(25,1) -> 9; +sbox(26,1) -> 9; +sbox(27,1) -> 5; +sbox(28,1) -> 0; +sbox(29,1) -> 3; +sbox(30,1) -> 7; +sbox(31,1) -> 8; +sbox(32,1) -> 4; +sbox(33,1) -> 15; +sbox(34,1) -> 1; +sbox(35,1) -> 12; +sbox(36,1) -> 14; +sbox(37,1) -> 8; +sbox(38,1) -> 8; +sbox(39,1) -> 2; +sbox(40,1) -> 13; +sbox(41,1) -> 4; +sbox(42,1) -> 6; +sbox(43,1) -> 9; +sbox(44,1) -> 2; +sbox(45,1) -> 1; +sbox(46,1) -> 11; +sbox(47,1) -> 7; +sbox(48,1) -> 15; +sbox(49,1) -> 5; +sbox(50,1) -> 12; +sbox(51,1) -> 11; +sbox(52,1) -> 9; +sbox(53,1) -> 3; +sbox(54,1) -> 7; +sbox(55,1) -> 14; +sbox(56,1) -> 3; +sbox(57,1) -> 10; +sbox(58,1) -> 10; +sbox(59,1) -> 0; +sbox(60,1) -> 5; +sbox(61,1) -> 6; +sbox(62,1) -> 0; +sbox(63,1) -> 13; +sbox(0,2) -> 15; +sbox(1,2) -> 3; +sbox(2,2) -> 1; +sbox(3,2) -> 13; +sbox(4,2) -> 8; +sbox(5,2) -> 4; +sbox(6,2) -> 14; +sbox(7,2) -> 7; +sbox(8,2) -> 6; +sbox(9,2) -> 15; +sbox(10,2) -> 11; +sbox(11,2) -> 2; +sbox(12,2) -> 3; +sbox(13,2) -> 8; +sbox(14,2) -> 4; +sbox(15,2) -> 14; +sbox(16,2) -> 9; +sbox(17,2) -> 12; +sbox(18,2) -> 7; +sbox(19,2) -> 0; +sbox(20,2) -> 2; +sbox(21,2) -> 1; +sbox(22,2) -> 13; +sbox(23,2) -> 10; +sbox(24,2) -> 12; +sbox(25,2) -> 6; +sbox(26,2) -> 0; +sbox(27,2) -> 9; +sbox(28,2) -> 5; +sbox(29,2) -> 11; +sbox(30,2) -> 10; +sbox(31,2) -> 5; +sbox(32,2) -> 0; +sbox(33,2) -> 13; +sbox(34,2) -> 14; +sbox(35,2) -> 8; +sbox(36,2) -> 7; +sbox(37,2) -> 10; +sbox(38,2) -> 11; +sbox(39,2) -> 1; +sbox(40,2) -> 10; +sbox(41,2) -> 3; +sbox(42,2) -> 4; +sbox(43,2) -> 15; +sbox(44,2) -> 13; +sbox(45,2) -> 4; +sbox(46,2) -> 1; +sbox(47,2) -> 2; +sbox(48,2) -> 5; +sbox(49,2) -> 11; +sbox(50,2) -> 8; +sbox(51,2) -> 6; +sbox(52,2) -> 12; +sbox(53,2) -> 7; +sbox(54,2) -> 6; +sbox(55,2) -> 12; +sbox(56,2) -> 9; +sbox(57,2) -> 0; +sbox(58,2) -> 3; +sbox(59,2) -> 5; +sbox(60,2) -> 2; +sbox(61,2) -> 14; +sbox(62,2) -> 15; +sbox(63,2) -> 9; +sbox(0,3) -> 10; +sbox(1,3) -> 13; +sbox(2,3) -> 0; +sbox(3,3) -> 7; +sbox(4,3) -> 9; +sbox(5,3) -> 0; +sbox(6,3) -> 14; +sbox(7,3) -> 9; +sbox(8,3) -> 6; +sbox(9,3) -> 3; +sbox(10,3) -> 3; +sbox(11,3) -> 4; +sbox(12,3) -> 15; +sbox(13,3) -> 6; +sbox(14,3) -> 5; +sbox(15,3) -> 10; +sbox(16,3) -> 1; +sbox(17,3) -> 2; +sbox(18,3) -> 13; +sbox(19,3) -> 8; +sbox(20,3) -> 12; +sbox(21,3) -> 5; +sbox(22,3) -> 7; +sbox(23,3) -> 14; +sbox(24,3) -> 11; +sbox(25,3) -> 12; +sbox(26,3) -> 4; +sbox(27,3) -> 11; +sbox(28,3) -> 2; +sbox(29,3) -> 15; +sbox(30,3) -> 8; +sbox(31,3) -> 1; +sbox(32,3) -> 13; +sbox(33,3) -> 1; +sbox(34,3) -> 6; +sbox(35,3) -> 10; +sbox(36,3) -> 4; +sbox(37,3) -> 13; +sbox(38,3) -> 9; +sbox(39,3) -> 0; +sbox(40,3) -> 8; +sbox(41,3) -> 6; +sbox(42,3) -> 15; +sbox(43,3) -> 9; +sbox(44,3) -> 3; +sbox(45,3) -> 8; +sbox(46,3) -> 0; +sbox(47,3) -> 7; +sbox(48,3) -> 11; +sbox(49,3) -> 4; +sbox(50,3) -> 1; +sbox(51,3) -> 15; +sbox(52,3) -> 2; +sbox(53,3) -> 14; +sbox(54,3) -> 12; +sbox(55,3) -> 3; +sbox(56,3) -> 5; +sbox(57,3) -> 11; +sbox(58,3) -> 10; +sbox(59,3) -> 5; +sbox(60,3) -> 14; +sbox(61,3) -> 2; +sbox(62,3) -> 7; +sbox(63,3) -> 12; +sbox(0,4) -> 7; +sbox(1,4) -> 13; +sbox(2,4) -> 13; +sbox(3,4) -> 8; +sbox(4,4) -> 14; +sbox(5,4) -> 11; +sbox(6,4) -> 3; +sbox(7,4) -> 5; +sbox(8,4) -> 0; +sbox(9,4) -> 6; +sbox(10,4) -> 6; +sbox(11,4) -> 15; +sbox(12,4) -> 9; +sbox(13,4) -> 0; +sbox(14,4) -> 10; +sbox(15,4) -> 3; +sbox(16,4) -> 1; +sbox(17,4) -> 4; +sbox(18,4) -> 2; +sbox(19,4) -> 7; +sbox(20,4) -> 8; +sbox(21,4) -> 2; +sbox(22,4) -> 5; +sbox(23,4) -> 12; +sbox(24,4) -> 11; +sbox(25,4) -> 1; +sbox(26,4) -> 12; +sbox(27,4) -> 10; +sbox(28,4) -> 4; +sbox(29,4) -> 14; +sbox(30,4) -> 15; +sbox(31,4) -> 9; +sbox(32,4) -> 10; +sbox(33,4) -> 3; +sbox(34,4) -> 6; +sbox(35,4) -> 15; +sbox(36,4) -> 9; +sbox(37,4) -> 0; +sbox(38,4) -> 0; +sbox(39,4) -> 6; +sbox(40,4) -> 12; +sbox(41,4) -> 10; +sbox(42,4) -> 11; +sbox(43,4) -> 1; +sbox(44,4) -> 7; +sbox(45,4) -> 13; +sbox(46,4) -> 13; +sbox(47,4) -> 8; +sbox(48,4) -> 15; +sbox(49,4) -> 9; +sbox(50,4) -> 1; +sbox(51,4) -> 4; +sbox(52,4) -> 3; +sbox(53,4) -> 5; +sbox(54,4) -> 14; +sbox(55,4) -> 11; +sbox(56,4) -> 5; +sbox(57,4) -> 12; +sbox(58,4) -> 2; +sbox(59,4) -> 7; +sbox(60,4) -> 8; +sbox(61,4) -> 2; +sbox(62,4) -> 4; +sbox(63,4) -> 14; +sbox(0,5) -> 2; +sbox(1,5) -> 14; +sbox(2,5) -> 12; +sbox(3,5) -> 11; +sbox(4,5) -> 4; +sbox(5,5) -> 2; +sbox(6,5) -> 1; +sbox(7,5) -> 12; +sbox(8,5) -> 7; +sbox(9,5) -> 4; +sbox(10,5) -> 10; +sbox(11,5) -> 7; +sbox(12,5) -> 11; +sbox(13,5) -> 13; +sbox(14,5) -> 6; +sbox(15,5) -> 1; +sbox(16,5) -> 8; +sbox(17,5) -> 5; +sbox(18,5) -> 5; +sbox(19,5) -> 0; +sbox(20,5) -> 3; +sbox(21,5) -> 15; +sbox(22,5) -> 15; +sbox(23,5) -> 10; +sbox(24,5) -> 13; +sbox(25,5) -> 3; +sbox(26,5) -> 0; +sbox(27,5) -> 9; +sbox(28,5) -> 14; +sbox(29,5) -> 8; +sbox(30,5) -> 9; +sbox(31,5) -> 6; +sbox(32,5) -> 4; +sbox(33,5) -> 11; +sbox(34,5) -> 2; +sbox(35,5) -> 8; +sbox(36,5) -> 1; +sbox(37,5) -> 12; +sbox(38,5) -> 11; +sbox(39,5) -> 7; +sbox(40,5) -> 10; +sbox(41,5) -> 1; +sbox(42,5) -> 13; +sbox(43,5) -> 14; +sbox(44,5) -> 7; +sbox(45,5) -> 2; +sbox(46,5) -> 8; +sbox(47,5) -> 13; +sbox(48,5) -> 15; +sbox(49,5) -> 6; +sbox(50,5) -> 9; +sbox(51,5) -> 15; +sbox(52,5) -> 12; +sbox(53,5) -> 0; +sbox(54,5) -> 5; +sbox(55,5) -> 9; +sbox(56,5) -> 6; +sbox(57,5) -> 10; +sbox(58,5) -> 3; +sbox(59,5) -> 4; +sbox(60,5) -> 0; +sbox(61,5) -> 5; +sbox(62,5) -> 14; +sbox(63,5) -> 3; +sbox(0,6) -> 12; +sbox(1,6) -> 10; +sbox(2,6) -> 1; +sbox(3,6) -> 15; +sbox(4,6) -> 10; +sbox(5,6) -> 4; +sbox(6,6) -> 15; +sbox(7,6) -> 2; +sbox(8,6) -> 9; +sbox(9,6) -> 7; +sbox(10,6) -> 2; +sbox(11,6) -> 12; +sbox(12,6) -> 6; +sbox(13,6) -> 9; +sbox(14,6) -> 8; +sbox(15,6) -> 5; +sbox(16,6) -> 0; +sbox(17,6) -> 6; +sbox(18,6) -> 13; +sbox(19,6) -> 1; +sbox(20,6) -> 3; +sbox(21,6) -> 13; +sbox(22,6) -> 4; +sbox(23,6) -> 14; +sbox(24,6) -> 14; +sbox(25,6) -> 0; +sbox(26,6) -> 7; +sbox(27,6) -> 11; +sbox(28,6) -> 5; +sbox(29,6) -> 3; +sbox(30,6) -> 11; +sbox(31,6) -> 8; +sbox(32,6) -> 9; +sbox(33,6) -> 4; +sbox(34,6) -> 14; +sbox(35,6) -> 3; +sbox(36,6) -> 15; +sbox(37,6) -> 2; +sbox(38,6) -> 5; +sbox(39,6) -> 12; +sbox(40,6) -> 2; +sbox(41,6) -> 9; +sbox(42,6) -> 8; +sbox(43,6) -> 5; +sbox(44,6) -> 12; +sbox(45,6) -> 15; +sbox(46,6) -> 3; +sbox(47,6) -> 10; +sbox(48,6) -> 7; +sbox(49,6) -> 11; +sbox(50,6) -> 0; +sbox(51,6) -> 14; +sbox(52,6) -> 4; +sbox(53,6) -> 1; +sbox(54,6) -> 10; +sbox(55,6) -> 7; +sbox(56,6) -> 1; +sbox(57,6) -> 6; +sbox(58,6) -> 13; +sbox(59,6) -> 0; +sbox(60,6) -> 11; +sbox(61,6) -> 8; +sbox(62,6) -> 6; +sbox(63,6) -> 13; +sbox(0,7) -> 4; +sbox(1,7) -> 13; +sbox(2,7) -> 11; +sbox(3,7) -> 0; +sbox(4,7) -> 2; +sbox(5,7) -> 11; +sbox(6,7) -> 14; +sbox(7,7) -> 7; +sbox(8,7) -> 15; +sbox(9,7) -> 4; +sbox(10,7) -> 0; +sbox(11,7) -> 9; +sbox(12,7) -> 8; +sbox(13,7) -> 1; +sbox(14,7) -> 13; +sbox(15,7) -> 10; +sbox(16,7) -> 3; +sbox(17,7) -> 14; +sbox(18,7) -> 12; +sbox(19,7) -> 3; +sbox(20,7) -> 9; +sbox(21,7) -> 5; +sbox(22,7) -> 7; +sbox(23,7) -> 12; +sbox(24,7) -> 5; +sbox(25,7) -> 2; +sbox(26,7) -> 10; +sbox(27,7) -> 15; +sbox(28,7) -> 6; +sbox(29,7) -> 8; +sbox(30,7) -> 1; +sbox(31,7) -> 6; +sbox(32,7) -> 1; +sbox(33,7) -> 6; +sbox(34,7) -> 4; +sbox(35,7) -> 11; +sbox(36,7) -> 11; +sbox(37,7) -> 13; +sbox(38,7) -> 13; +sbox(39,7) -> 8; +sbox(40,7) -> 12; +sbox(41,7) -> 1; +sbox(42,7) -> 3; +sbox(43,7) -> 4; +sbox(44,7) -> 7; +sbox(45,7) -> 10; +sbox(46,7) -> 14; +sbox(47,7) -> 7; +sbox(48,7) -> 10; +sbox(49,7) -> 9; +sbox(50,7) -> 15; +sbox(51,7) -> 5; +sbox(52,7) -> 6; +sbox(53,7) -> 0; +sbox(54,7) -> 8; +sbox(55,7) -> 15; +sbox(56,7) -> 0; +sbox(57,7) -> 14; +sbox(58,7) -> 5; +sbox(59,7) -> 2; +sbox(60,7) -> 9; +sbox(61,7) -> 3; +sbox(62,7) -> 2; +sbox(63,7) -> 12; +sbox(0,8) -> 13; +sbox(1,8) -> 1; +sbox(2,8) -> 2; +sbox(3,8) -> 15; +sbox(4,8) -> 8; +sbox(5,8) -> 13; +sbox(6,8) -> 4; +sbox(7,8) -> 8; +sbox(8,8) -> 6; +sbox(9,8) -> 10; +sbox(10,8) -> 15; +sbox(11,8) -> 3; +sbox(12,8) -> 11; +sbox(13,8) -> 7; +sbox(14,8) -> 1; +sbox(15,8) -> 4; +sbox(16,8) -> 10; +sbox(17,8) -> 12; +sbox(18,8) -> 9; +sbox(19,8) -> 5; +sbox(20,8) -> 3; +sbox(21,8) -> 6; +sbox(22,8) -> 14; +sbox(23,8) -> 11; +sbox(24,8) -> 5; +sbox(25,8) -> 0; +sbox(26,8) -> 0; +sbox(27,8) -> 14; +sbox(28,8) -> 12; +sbox(29,8) -> 9; +sbox(30,8) -> 7; +sbox(31,8) -> 2; +sbox(32,8) -> 7; +sbox(33,8) -> 2; +sbox(34,8) -> 11; +sbox(35,8) -> 1; +sbox(36,8) -> 4; +sbox(37,8) -> 14; +sbox(38,8) -> 1; +sbox(39,8) -> 7; +sbox(40,8) -> 9; +sbox(41,8) -> 4; +sbox(42,8) -> 12; +sbox(43,8) -> 10; +sbox(44,8) -> 14; +sbox(45,8) -> 8; +sbox(46,8) -> 2; +sbox(47,8) -> 13; +sbox(48,8) -> 0; +sbox(49,8) -> 15; +sbox(50,8) -> 6; +sbox(51,8) -> 12; +sbox(52,8) -> 10; +sbox(53,8) -> 9; +sbox(54,8) -> 13; +sbox(55,8) -> 0; +sbox(56,8) -> 15; +sbox(57,8) -> 3; +sbox(58,8) -> 3; +sbox(59,8) -> 5; +sbox(60,8) -> 5; +sbox(61,8) -> 6; +sbox(62,8) -> 8; +sbox(63,8) -> 11. diff --git a/lib/compiler/test/inline_SUITE_data/decode1.erl b/lib/compiler/test/inline_SUITE_data/decode1.erl new file mode 100644 index 0000000000..d51bedcb2e --- /dev/null +++ b/lib/compiler/test/inline_SUITE_data/decode1.erl @@ -0,0 +1,402 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2006-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% +%% +%---------------------------------------------------------------------- +% decode1.erl (new version) +%---------------------------------------------------------------------- +% -*- Erlang -*- +% File: decode1.erl (~jb/decode/decode1.erl) +% Author: Johan Bevemyr +% Created: Tue Jan 14 09:33:49 1997 +% Purpose: +% Notes: Rewritten for use in ETOS. (Happi) + +-module(decode1). + +-export([?MODULE/0, + decode_ie_heads_setup/1, + run_dummy/2, + run_orig/2]). + +?MODULE() -> + FrameList = [89,128,0,8,132,0,26,133,133,0,38,148,94, + 128,0,2,129,128,92,128,0,2,0,0,112,128,0, + 10,194,69,0,0,0,0,0,18,52,95], + Frame = concat_binary([list_to_binary([89]),list_to_binary([128]), + list_to_binary([0]),list_to_binary([8]), + list_to_binary([132]),list_to_binary([0]), + list_to_binary([26]),list_to_binary([133]), + list_to_binary([133]),list_to_binary([0]), + list_to_binary([38]),list_to_binary([148]), + list_to_binary([94]),list_to_binary([128]), + list_to_binary([0]),list_to_binary([2]), + list_to_binary([129]),list_to_binary([128]), + list_to_binary([92]),list_to_binary([128]), + list_to_binary([0]),list_to_binary([2]), + list_to_binary([0]),list_to_binary([0]), + list_to_binary([112]),list_to_binary([128]), + list_to_binary([0]),list_to_binary([10]), + list_to_binary([194]),list_to_binary([69]), + list_to_binary([0]),list_to_binary([0]), + list_to_binary([0]),list_to_binary([0]), + list_to_binary([0]),list_to_binary([18]), + list_to_binary([52]),list_to_binary([95])]), + + R = loop(2,0,Frame), + {R,R =:= {0,[{ie,112,itu_t_standard,ignore,10,<<194,69,0,0,0,0,0,18,52,95>>}, + {ie,92,itu_t_standard,ignore,2,<<0,0>>}, + {ie,94,itu_t_standard,ignore,2,<<129,128>>}, + {ie,89,itu_t_standard,ignore,8,<<132,0,26,133,133,0,38,148>>}]}}. + +loop(0,R,_) -> R; +loop(N,R,Frame) -> loop(N-1, decode1:decode_ie_heads_setup(Frame),Frame). + +run_dummy(0,Frame) -> + done; +run_dummy(N,Frame) -> + parse_dummy(Frame), + run_dummy(N-1,Frame). + +parse_dummy(Frame) -> true. + +run_orig(0,Frame) -> + done; +run_orig(N,Frame) -> + decode1:decode_ie_heads_setup(Frame), + run_orig(N-1,Frame). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Macros +% + +-define(VALID_ACTION(Flag), if ((Flag) band 16#10) == 16#10 -> true; + true -> false + end). +-define(GET_ACTION(Flag), ((Flag) band 16#03)). + +-define(getint16(X1,X0), (16#100*X1 + X0)). + +-define(IS_EXTENDED(X), (if ((X) band 16#80) == 16#80 -> false; + true -> true + end)). + + +%%% ---------------------------------------------------------- +%%% # ie +%%% Description: Used to encapsulate the ie head +%%% ---------------------------------------------------------- + + +-record(ie,{identifier, + coding, + action_ind, + length, + ie_body = binary}). + +%%% ---------------------------------------------------------- +%%% # bbc +%%% Description: BROADBAND BEARER CAPABILITY +%%% ---------------------------------------------------------- + +-record(scct_bbc, + {scct_pci, % parameter compatibility info + scct_bearer_class, + scct_atm_transfer_capability, + scct_user_plane_connection_configuration, + scct_susceptibility_to_clipping}). + + +%%% ---------------------------------------------------------- +%%% # cause +%%% Description: CAUSE +%%% ---------------------------------------------------------- + +-record(scct_cause, + {scct_pci, % parameter compatibility info + scct_location, + scct_cause_value, + scct_diagnostics_list = []}). + + +%%% ---------------------------------------------------------- +%%% # release_complete_uni +%%% Description: +%%% ---------------------------------------------------------- + +-record(release_complete_uni, + {scct_cause_list=[], % Cause IE's in a list where each element + % is a record of scct_cause{} + scct_geidt_list=[]}). % Generic Identifier Transport IE's in a list + % where each element is a record of scct_geidt{} + + +-define(IE_BB_BEARER_CAPABILITY, 16#5e). +-define(SCCT_PUB_NETW_SERV_LOCAL_USR, 2). +-define(SCCT_ERR_INVALID_IE_CONT, 100). +-define(DECRES_THROW_RELCOMP, error_throw_relcomp). + +-define(SCCT_P_TO_P, 0). +-define(SCCT_P_TO_MP, 1). + +-define(IE_ENDPT_REF, 16#54). +-define(IE_BB_REPEAT_INDICATOR, 16#63). + +-define(SCCT_ERR_MAND_IE_MISSING, 96). + +-define(A_CLEAR_CALL, 0). +-define(A_DISCARD_PROCEED, 1). +-define(A_DISCARD_PROCEED_STATUS, 2). + +-define(SCCT_BCOB_A, 1). +-define(SCCT_BCOB_C, 3). +-define(SCCT_BCOB_X, 16). +-define(SCCT_TRANSP_VP_SERV, 24). + +-define(SCCT_CBR, 5). +-define(SCCT_CBR_WITH_CLR_CLP_0_1, 7). +-define(SCCT_RT_VBR, 9). +-define(SCCT_RT_VBR_WITH_CLR_CLP_0_1, 19). +-define(SCCT_NON_RT_VBR, 10). +-define(SCCT_NON_RT_VBR_WITH_CLR_CLP_0_1, 11). +-define(SCCT_ABR, 12). +-define(SCCT_NOT_SUSCEPT_TO_CLIPPING, 0). +-define(SCCT_SUSCEPT_TO_CLIPPING, 1). + + + +%%% ---------------------------------------------------------- +%%% -type decode_ie_heads_setup(Bin)-> +%%% +%%% Input: Binary to body of incoming Message +%%% Output: +%%% +%%% Exceptions: +%%% Description:decode_ie_heads_setup is used both p-p and p-mp setup +%%% Never fails. Needs to be exported to be able to check +%%% if setup is p-p or p-mp. +%%% Note that if broadband rep indicator is present +%%% order must be incoming IE's must be preserved, this +%%% only applicable in msg setup +%%% ---------------------------------------------------------- +decode_ie_heads_setup(Bin)-> + decode_ie_heads_setup(Bin,no_bbc_ie,no_epr,[],no_brep). + +decode_ie_heads_setup(Bin,TypeOfCall,EprFlag,IEList,BrepFlag) when is_binary(Bin),size(Bin) >= 4 -> + {Bin1,Bin2} = split_binary(Bin,4), + [Id,F,L1,L0]= binary_to_list(Bin1), + Action = decode_action(F), + Coding = decode_ie_coding(F), + case ?getint16(L1,L0) of + Len when Len >0 -> + %%catch needed we cannot trust indata + case catch split_binary(Bin2,Len) of + {'EXIT',_} -> %%binary unpacked as far as possible + decode_ie_heads_setup(not_a_binary,TypeOfCall,EprFlag, + IEList,BrepFlag); + {Bin3,Bin4} -> + IE= #ie {identifier = Id, + coding = Coding, + action_ind= Action, + length= Len, + ie_body= Bin3}, + case Id of + ?IE_BB_BEARER_CAPABILITY -> + BbcRec=#scct_bbc{}, + %%catch needed we cannot trust indata + case catch + dec_bearer_capability(BbcRec, + binary_to_list(Bin3)) of + {'EXIT',_} -> %mand content error + CauseRec=#scct_cause{scct_location= + ?SCCT_PUB_NETW_SERV_LOCAL_USR, + scct_cause_value= + ?SCCT_ERR_INVALID_IE_CONT, + scct_diagnostics_list= + [?IE_BB_BEARER_CAPABILITY]}, + RelCompUniMsg = + #release_complete_uni{scct_cause_list= + [CauseRec]}, + {?DECRES_THROW_RELCOMP,RelCompUniMsg}; + NewBbcRec -> + case NewBbcRec + #scct_bbc.scct_user_plane_connection_configuration of + ?SCCT_P_TO_P -> + decode_ie_heads_setup(Bin4, + ?SCCT_P_TO_P, + EprFlag, + [IE|IEList], + BrepFlag); + ?SCCT_P_TO_MP -> + decode_ie_heads_setup(Bin4, + ?SCCT_P_TO_MP, + EprFlag, + [IE|IEList], + BrepFlag) + end + end; + ?IE_ENDPT_REF -> + decode_ie_heads_setup(Bin4,TypeOfCall,yes_epr, + [IE|IEList],BrepFlag); + ?IE_BB_REPEAT_INDICATOR -> + decode_ie_heads_setup(Bin4,TypeOfCall,EprFlag, + [IE|IEList],yes_brep); + _ -> + decode_ie_heads_setup(Bin4,TypeOfCall,EprFlag, + [IE|IEList],BrepFlag) + end + end; + Len when Len == 0 ->%ie body empty, treat as if whole ie was missing + decode_ie_heads_setup(Bin2,TypeOfCall,EprFlag,IEList,BrepFlag) + end; +decode_ie_heads_setup(_,?SCCT_P_TO_MP,yes_epr,IEList,no_brep) -> + {?SCCT_P_TO_MP,IEList}; +decode_ie_heads_setup(_,?SCCT_P_TO_MP,yes_epr,IEList,yes_brep) -> +%Order of incoming IEs must be preserved since BroadB Repeat Ind is present + {?SCCT_P_TO_MP,reverse(IEList)}; +decode_ie_heads_setup(_,?SCCT_P_TO_MP,no_epr,_,no_brep) -> + CauseRec=#scct_cause{scct_location=?SCCT_PUB_NETW_SERV_LOCAL_USR, + scct_cause_value=?SCCT_ERR_MAND_IE_MISSING, + scct_diagnostics_list=[?IE_ENDPT_REF]}, + RelCompUniMsg =#release_complete_uni{scct_cause_list=[CauseRec]}, + {?DECRES_THROW_RELCOMP,RelCompUniMsg}; +decode_ie_heads_setup(_,?SCCT_P_TO_P,_,IEList,no_brep) -> + {?SCCT_P_TO_P,IEList}; +decode_ie_heads_setup(_,?SCCT_P_TO_P,_,IEList,yes_brep) -> +%Order of incoming IEs must be preserved since BrodB Repeat Ind is present + {?SCCT_P_TO_P,reverse(IEList)}; +decode_ie_heads_setup(_,no_bbc_ie,_,_,_) -> + CauseRec=#scct_cause{scct_location=?SCCT_PUB_NETW_SERV_LOCAL_USR, + scct_cause_value=?SCCT_ERR_MAND_IE_MISSING, + scct_diagnostics_list=[?IE_BB_BEARER_CAPABILITY]}, + RelCompUniMsg =#release_complete_uni{scct_cause_list=[CauseRec]}, + {?DECRES_THROW_RELCOMP,RelCompUniMsg}. + + + +%%% +%%% Decode message type and header +%%% + +decode_action(Flag) -> + case ?VALID_ACTION(Flag) of + true -> + case ?GET_ACTION(Flag) of + ?A_CLEAR_CALL -> clear_call; + ?A_DISCARD_PROCEED -> discard_proceed; + ?A_DISCARD_PROCEED_STATUS -> discard_proceed_status; + _ -> undefined + end; + false -> + ignore + end. + + +%%% +%%% Decode ie coding +%%% + +decode_ie_coding(F) -> + case F band 16#60 of + 0 -> itu_t_standard; + 16#60 -> atm_forum_specific; + _ -> undefined + end. + + +%%% -------------------------------------------------------------------------- +%%% +%%% Decode of INFORMATION ELEMENT: Broadband Bearer Capability +%%% +%%% -------------------------------------------------------------------------- + +dec_bearer_capability(BbcRec, [Octet5 | Rest]) -> + NewBbcRec = + case Octet5 band 16#1f of + 16#01 -> + BbcRec#scct_bbc{scct_bearer_class = ?SCCT_BCOB_A}; + 16#03 -> + BbcRec#scct_bbc{scct_bearer_class = ?SCCT_BCOB_C}; + 16#10 -> + BbcRec#scct_bbc{scct_bearer_class = ?SCCT_BCOB_X}; + 16#18 -> + BbcRec#scct_bbc{scct_bearer_class = ?SCCT_TRANSP_VP_SERV} + end, + + case ?IS_EXTENDED(Octet5) of + true -> + dec_bearer_capability_5a(NewBbcRec, Rest); + false -> + dec_bearer_capability_6(NewBbcRec, Rest) + end. + +dec_bearer_capability_5a(BbcRec,[Octet5a | Rest]) -> + NewBbcRec = + case Octet5a band 16#7f of + 16#05 -> + BbcRec#scct_bbc{scct_atm_transfer_capability = + ?SCCT_CBR}; + 16#07 -> + BbcRec#scct_bbc{scct_atm_transfer_capability = + ?SCCT_CBR_WITH_CLR_CLP_0_1}; + 16#09 -> + BbcRec#scct_bbc{scct_atm_transfer_capability = + ?SCCT_RT_VBR}; + 16#13 -> + BbcRec#scct_bbc{scct_atm_transfer_capability = + ?SCCT_RT_VBR_WITH_CLR_CLP_0_1}; + 16#0a -> + BbcRec#scct_bbc{scct_atm_transfer_capability = + ?SCCT_NON_RT_VBR}; + 16#0b -> + BbcRec#scct_bbc{scct_atm_transfer_capability = + ?SCCT_NON_RT_VBR_WITH_CLR_CLP_0_1}; + 16#0c -> + BbcRec#scct_bbc{scct_atm_transfer_capability = + ?SCCT_ABR} + end, + dec_bearer_capability_6(NewBbcRec,Rest). + + +dec_bearer_capability_6(BbcRec, [Octet6]) -> + STC = + case (Octet6 bsr 5) band 16#03 of + 16#00 -> + ?SCCT_NOT_SUSCEPT_TO_CLIPPING; + 16#01 -> + ?SCCT_SUSCEPT_TO_CLIPPING + end, + + UPCC = + case Octet6 band 16#03 of + 16#00 -> + ?SCCT_P_TO_P; + 16#01 -> + ?SCCT_P_TO_MP + end, + + NewBbcRec = BbcRec#scct_bbc{scct_susceptibility_to_clipping = STC, + scct_user_plane_connection_configuration = UPCC}. + + +reverse(L) -> + reverse(L,[]). + +reverse([E|Rest],Acc) -> + reverse(Rest,[E|acc]); +reverse([],Acc) -> Acc. diff --git a/lib/compiler/test/inline_SUITE_data/itracer.erl b/lib/compiler/test/inline_SUITE_data/itracer.erl new file mode 100644 index 0000000000..93f24e9bb1 --- /dev/null +++ b/lib/compiler/test/inline_SUITE_data/itracer.erl @@ -0,0 +1,407 @@ +%% +%% %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% +%% +-module(itracer). +-export([itracer/0]). + +%%%--------------------------------------------------------------------------- +%%% +%%% This is a little raytracer. +%%% +%%%--------------------------------------------------------------------------- + + +%%---------------------------------------------------------------------------- +%% Constructors. +%%---------------------------------------------------------------------------- + + +%%---------------------------------------------------------------------------- +%% +%%---------------------------------------------------------------------------- + +itracer() -> + C1 = ccreate(), + C2 = set_width(C1,100), + C3 = set_height(C2,100), + C4 = initialize(C3), + Sphere1 = screate(40,vcreate(35,10,0),{1,0,0}), + Sphere2 = screate(35,vcreate(-25,-25,50),{0,1,0}), + PL = traceloop(C4,50,50,[Sphere1,Sphere2]). + + +%%---------------------------------------------------------------------------- +%% +%%---------------------------------------------------------------------------- + +overflow_prevent(A) when A<1 -> A; +overflow_prevent(_) -> 1. + + +%%---------------------------------------------------------------------------- +%% +%%---------------------------------------------------------------------------- + +traceloop(Camera,Width,Height,Scene) -> + traceloop(Camera,Width,Height,0,0,Scene,[]). + + +traceloop(_,_,Height,_,Y,_,PL) when Height=<Y -> + PL; + +traceloop(Camera,Width,Height,X,Y,Scene,PL) when Width=<X -> + traceloop(Camera,Width,Height,0,Y+1,Scene,PL); + +traceloop(Camera,Width,Height,X,Y,Scene,PL) -> + Ray = ray(Camera,X/Width,Y/Height), + {R1,G1,B1} = traceray(Ray,Scene,1), + R2 = overflow_prevent(R1), + G2 = overflow_prevent(G1), + B2 = overflow_prevent(B1), + P = {trunc(R2*255), trunc(G2*255), trunc(B2*255)}, + traceloop(Camera,Width,Height,X+1,Y,Scene,[{X,Y,P}|PL]). + + +%%---------------------------------------------------------------------------- +%% +%%---------------------------------------------------------------------------- + +traceray(Ray,Scene,Level) -> + Hit = findintersection(Ray,Scene,Level), + case Hit of + nohit -> {0,0,0}; + {[T|Ts],Object} -> shaderay(Ray,Scene,Level,T,Object) + end. + + +%%---------------------------------------------------------------------------- +%% +%%---------------------------------------------------------------------------- + +% Here we loop through all the objects in the scene to find the +% closest intersection. + +findintersection(_,[],_) -> nohit; + +findintersection(Ray,[Object|Objects],Level) -> + Ts = intersection(Object,Ray), + Hit1 = findintersection(Ray,Objects,Level), + Hit2 = closesthit(Ts,Object,Hit1). + + +closesthit(nohit,_,nohit) -> nohit; +closesthit(nohit,_,{[T|Ts],Obj}) when T>0 -> {[T|Ts],Obj}; +closesthit(nohit,_,_) -> nohit; +closesthit([T|Ts],Obj,nohit) when T>0 -> {[T|Ts],Obj}; +closesthit(_,_,nohit) -> nohit; +closesthit([T1|Ts1],Obj1,{[T2|Ts2],Obj2}) when T1>0,T1<T2 -> {[T1|Ts1],Obj1}; +closesthit([T1|Ts1],Obj1,{[T2|Ts2],Obj2}) when T2>0,T2<T1 -> {[T2|Ts2],Obj2}; +closesthit(_,_,_) -> nohit. + + + +%%---------------------------------------------------------------------------- +%% +%%---------------------------------------------------------------------------- + +shaderay(Ray,Scene,Level,T,Object) -> + Direction = get_direction(Ray), + Origin = get_origin(Ray), + Point = add(Origin, mul(T, Direction)), + Normal = calcnormal(Object, Point), + Diffuse = -dot(Normal, Direction), + ReflectionVector = reflection(Ray,Normal), + NewOrigin = add(Point, mul(0.0001, Normal)), + ReflectionRay = rcreate(NewOrigin,ReflectionVector), + {Red1,Green1,Blue1} = get_color(Object), + if + Level<4, Diffuse>0 -> + {Red2,Green2,Blue2} = traceray(ReflectionRay,Scene,Level+1), + {Diffuse*Red1 + 0.5*Red2, + Diffuse*Green1 + 0.5*Green2, + Diffuse*Blue1 + 0.5*Blue2}; + Level<4, Diffuse<0 -> + {0,0,0}; + true -> + {0,0,0} + end. + + +%%---------------------------------------------------------------------------- +%% Har nedan foljer bara ett gang testfunktioner.... +%%---------------------------------------------------------------------------- +-record(camera,{width,height,zoom,position,lookat,up,right,down,corner}). + +%%%--------------------------------------------------------------------------- +%%% +%%% Useful camera operations. +%%% +%%%--------------------------------------------------------------------------- + + +%%---------------------------------------------------------------------------- +%% Constructors. +%%---------------------------------------------------------------------------- + +ccreate() -> + #camera{width=100, height=100, zoom=256, + position = vcreate(0,0,-256), + lookat = vcreate(0,0,0), + up = vcreate(0,1,0)}. + + + +%%---------------------------------------------------------------------------- +%% Selectors and modifiers. +%%---------------------------------------------------------------------------- + +set_width(C,Width) -> C#camera{width=Width}. +set_height(C,Height) -> C#camera{height=Height}. +set_zoom(C,Zoom) -> C#camera{zoom=Zoom}. +cset_position(C,Pos) -> C#camera{position=Pos}. +set_lookat(C,Lookat) -> C#camera{lookat=Lookat}. +set_up(C,Up) -> C#camera{up=Up}. + +get_width(C) -> C#camera.width. +get_height(C) -> C#camera.height. +get_zoom(C) -> C#camera.zoom. +cget_position(C) -> C#camera.position. +get_lookat(C) -> C#camera.lookat. +get_up(C) -> C#camera.up. + + + +%%---------------------------------------------------------------------------- +%% Operators. +%%---------------------------------------------------------------------------- + +initialize(C) -> + Dir = normalize(sub(C#camera.lookat, C#camera.position)), + Up1 = normalize(C#camera.up), + D = dot(Up1, Dir), + Up2 = normalize(sub(Up1, mul(D, Dir))), + Down = mul(-1, Up2), + Right = normalize(cross(Up2,Dir)), + Corner1 = mul(C#camera.zoom, Dir), + Corner2 = add(Corner1, mul(-C#camera.width/2, Right)), + Corner3 = add(Corner2, mul(-C#camera.height/2, Down)), + C2 = C#camera{down=Down, right=Right, corner=Corner3}. + + +% +% X och Y ska ligga i intervallet [0..1] +% +ray(C,X,Y) -> + Right = mul(C#camera.width*X, C#camera.right), + Down = mul(C#camera.height*Y, C#camera.down), + Point = add(C#camera.corner, add(Right,Down)), + rcreate(C#camera.position,normalize(Point)). + + + +%%---------------------------------------------------------------------------- +%% E N D O F F I L E +%%---------------------------------------------------------------------------- +-record(vector,{x,y,z}). + + +%%%--------------------------------------------------------------------------- +%%% +%%% Useful vector operations. +%%% +%%%--------------------------------------------------------------------------- + + +%%---------------------------------------------------------------------------- +%% Constructors. +%%---------------------------------------------------------------------------- + +vcreate() -> + #vector{x=0,y=0,z=0}. + + +vcreate(X,Y,Z) -> + #vector{x=X,y=Y,z=Z}. + + + +%%---------------------------------------------------------------------------- +%% Selectors and modifiers. +%%---------------------------------------------------------------------------- + +set_x(V,X) -> V#vector{x=X}. +set_y(V,Y) -> V#vector{y=Y}. +set_z(V,Z) -> V#vector{z=Z}. + +get_x(V) -> V#vector.x. +get_y(V) -> V#vector.y. +get_z(V) -> V#vector.z. + + + +%%---------------------------------------------------------------------------- +%% Operators. +%%---------------------------------------------------------------------------- + +add(A,B) -> + #vector{x=A#vector.x+B#vector.x, + y=A#vector.y+B#vector.y, + z=A#vector.z+B#vector.z}. + + +sub(A,B) -> + #vector{x=A#vector.x-B#vector.x, + y=A#vector.y-B#vector.y, + z=A#vector.z-B#vector.z}. + + +mul(T,A) -> + #vector{x=A#vector.x * T, + y=A#vector.y * T, + z=A#vector.z * T}. + + +dot(A,B) -> + A#vector.x*B#vector.x + + A#vector.y*B#vector.y + + A#vector.z*B#vector.z. + + +normalize(A) -> + S = 1 / math:sqrt(dot(A,A)), + vcreate(A#vector.x * S, A#vector.y * S, A#vector.z * S). + + +cross(A,B) -> + #vector{x = A#vector.y*B#vector.z - A#vector.z*B#vector.y, + y = A#vector.z*B#vector.x - A#vector.x*B#vector.z, + z = A#vector.x*B#vector.y - A#vector.y*B#vector.x}. + + +%%---------------------------------------------------------------------------- +%% E N D O F F I L E +%%---------------------------------------------------------------------------- +-record(ray,{origin,direction}). + +%%%--------------------------------------------------------------------------- +%%% +%%% Useful ray stuff. +%%% +%%%--------------------------------------------------------------------------- + + +%%---------------------------------------------------------------------------- +%% Constructors. +%%---------------------------------------------------------------------------- + +rcreate() -> + #ray{origin=vcreate(0,0,0), direction=vcreate(0,0,1)}. + + +rcreate(Origin,Direction) -> + #ray{origin=Origin, direction=Direction}. + + + +%%---------------------------------------------------------------------------- +%% Selectors and modifiers. +%%---------------------------------------------------------------------------- + +set_origin(R,Origin) -> R#ray{origin=Origin}. +set_direction(R,Direction) -> R#ray{direction=Direction}. + +get_origin(R) -> R#ray.origin. +get_direction(R) -> R#ray.direction. + + + +%%---------------------------------------------------------------------------- +%% +%%---------------------------------------------------------------------------- + +reflection(R,N) -> + A = mul(2*dot(N, R#ray.direction), N), + normalize(sub(R#ray.direction, A)). + + + +%%---------------------------------------------------------------------------- +%% E N D O F F I L E +%%---------------------------------------------------------------------------- +-record(sphere,{radius,position,color}). + +%%%--------------------------------------------------------------------------- +%%% +%%% Useful sphere operations. +%%% +%%%--------------------------------------------------------------------------- + + +%%---------------------------------------------------------------------------- +%% Constructors. +%%---------------------------------------------------------------------------- + +screate() -> + #sphere{radius=1, position=vcreate(0,0,0), color={1,1,1}}. + + +screate(Radius,Position,Color) -> + #sphere{radius=Radius, position=Position, color=Color}. + + + +%%---------------------------------------------------------------------------- +%% Selectors and modifiers. +%%---------------------------------------------------------------------------- + +set_radius(S,Radius) -> S#sphere{radius=Radius}. +sset_position(S,Position) -> S#sphere{position=Position}. +set_color(S,Color) -> S#sphere{color=Color}. + +get_radius(S) -> S#sphere.radius. +sget_position(S) -> S#sphere.position. +get_color(S) -> S#sphere.color. + + + +%%---------------------------------------------------------------------------- +%% Calculates the intersection between a ray and the sphere. +%%---------------------------------------------------------------------------- + +intersection(S,Ray) -> + SR = sub(S#sphere.position,get_origin(Ray)), + B = dot(SR,get_direction(Ray)), + C = dot(SR,SR), + Root = B*B-C + S#sphere.radius * S#sphere.radius, + if + Root>0 -> + SquareRoot = math:sqrt(Root), + [B-SquareRoot,B+SquareRoot]; + true -> + nohit + end. + +calcnormal(S,P) -> + normalize(sub(P, S#sphere.position)). + %mul(1/S#sphere.radius, sub(P, S#sphere.position)). + + + +%%---------------------------------------------------------------------------- +%% E N D O F F I L E +%%---------------------------------------------------------------------------- diff --git a/lib/compiler/test/inline_SUITE_data/pseudoknot.erl b/lib/compiler/test/inline_SUITE_data/pseudoknot.erl new file mode 100644 index 0000000000..5b2bf1694a --- /dev/null +++ b/lib/compiler/test/inline_SUITE_data/pseudoknot.erl @@ -0,0 +1,2575 @@ +-module(pseudoknot). + +-export([?MODULE/0]). + +?MODULE() -> + R = loop(1, 0), + abs(R-33.7976) < 0.0001. + +append([H|T], Z) -> + [H|append(T, Z)]; +append([], X) -> + X. + +atan2(Y,X) when X>0.0 -> + math:atan(Y/X); +atan2(Y,X) when Y<0.0 -> + if + X == 0.0 -> -1.57079632679489661923; + true -> math:atan(Y/X) - 3.14159265358979323846 + end; +atan2(Y,X) -> + if + X == 0.0 -> 1.57079632679489661923; + true -> math:atan(Y/X) + 3.14159265358979323846 + end. + +% -- POINTS ------------------------------------------------------------------ + +%pt ::= {X, Y, Z} where X,Y,Z are floats + +pt_sub({X1, Y1, Z1}, {X2, Y2, Z2}) + when is_float(X1), is_float(Y1), is_float(Z1), + is_float(X2), is_float(Y2), is_float(Z2) -> + {X1 - X2, Y1 - Y2, Z1 - Z2}. + +pt_dist({X1, Y1, Z1}, {X2, Y2, Z2}) + when is_float(X1), is_float(Y1), is_float(Z1), + is_float(X2), is_float(Y2), is_float(Z2) -> + Dx = X1 - X2, + Dy = Y1 - Y2, + Dz = Z1 - Z2, + math:sqrt(Dx * Dx + Dy * Dy + Dz * Dz). + +pt_phi({X, Y, Z}) + when is_float(X), is_float(Z) -> + B = atan2(X, Z), + atan2(math:cos(B) * Z + math:sin(B) * X, Y). + +pt_theta ({X, _, Z}) -> + atan2(X, Z). + +% -- COORDINATE TRANSFORMATIONS ---------------------------------------------- + +% The notation for the transformations follows "Paul, R.P. (1981) Robot +% Manipulators. MIT Press." with the exception that our transformation +% matrices don't have the perspective terms and are the transpose of +% Paul's one. See also "M\"antyl\"a, M. (1985) An Introduction to +% Solid Modeling, Computer Science Press" Appendix A. +% +% The components of a transformation matrix are named like this: +% +% a b c +% d e f +% g h i +% tx ty tz +% +% The components tx, ty, and tz are the translation vector. + +%tfo ::= {A,B,C,D,E,F,G,H,I,Tx,Ty,Tz} where all elements are floats + +tfo_id() -> {1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0}. + +% The function "tfo-apply" multiplies a transformation matrix, tfo, by a +% point vector, p. The result is a new point. + +tfo_apply ({A,B,C,D,E,F,G,H,I,Tx,Ty,Tz}, {X,Y,Z}) + when is_float(A), is_float(B), is_float(C), is_float(D), is_float(E), + is_float(F), is_float(G), is_float(H), is_float(I), + is_float(Tx), is_float(Ty), is_float(Tz), is_float(X), is_float(Y), is_float(Z) -> + {X * A + Y * D + Z * G + Tx, + X * B + Y * E + Z * H + Ty, + X * C + Y * F + Z * I + Tz}. + +% The function "tfo-combine" multiplies two transformation matrices A and B. +% The result is a new matrix which cumulates the transformations described +% by A and B. + +tfo_combine({A_a,A_b,A_c,A_d,A_e,A_f,A_g,A_h,A_i,A_tx,A_ty,A_tz}, + {B_a,B_b,B_c,B_d,B_e,B_f,B_g,B_h,B_i,B_tx,B_ty,B_tz}) + when is_float(A_a), is_float(A_b), is_float(A_c), is_float(A_d), is_float(A_e), + is_float(A_f), is_float(A_g), is_float(A_h), is_float(A_i), is_float(A_tx), + is_float(A_ty), is_float(A_tz), + is_float(B_a), is_float(B_b), is_float(B_c), is_float(B_d), is_float(B_e), + is_float(B_f), is_float(B_g), is_float(B_h), is_float(B_i), is_float(B_tx), + is_float(B_ty), is_float(B_tz) -> + {A_a * B_a + A_b * B_d + A_c * B_g, + A_a * B_b + A_b * B_e + A_c * B_h, + A_a * B_c + A_b * B_f + A_c * B_i, + A_d * B_a + A_e * B_d + A_f * B_g, + A_d * B_b + A_e * B_e + A_f * B_h, + A_d * B_c + A_e * B_f + A_f * B_i, + A_g * B_a + A_h * B_d + A_i * B_g, + A_g * B_b + A_h * B_e + A_i * B_h, + A_g * B_c + A_h * B_f + A_i * B_i, + A_tx * B_a + A_ty * B_d + A_tz * B_g + B_tx, + A_tx * B_b + A_ty * B_e + A_tz * B_h + B_ty, + A_tx * B_c + A_ty * B_f + A_tz * B_i + B_tz}. + +% The function "tfo-inv-ortho" computes the inverse of a homogeneous +% transformation matrix. + +tfo_inv_ortho({A,B,C,D,E,F,G,H,I,Tx,Ty,Tz}) + when is_float(A), is_float(B), is_float(C), is_float(D), is_float(E), is_float(F), + is_float(G), is_float(H), is_float(I), is_float(Tx), is_float(Ty), is_float(Tz) -> + {A,D,G, + B,E,H, + C,F,I, + -(A * Tx + B * Ty + C * Tz), + -(D * Tx + E * Ty + F * Tz), + -(G * Tx + H * Ty + I * Tz)}. + +% Given three points p1, p2, and p3, the function "tfo-align" computes +% a transformation matrix such that point p1 gets mapped to (0,0,0), p2 gets +% mapped to the Y axis and p3 gets mapped to the YZ plane. + +tfo_align({X1,Y1,Z1},{X2,Y2,Z2},{X3,Y3,Z3}) + when is_float(X1), is_float(Y1), is_float(Z1), + is_float(X2), is_float(Y2), is_float(Z2), + is_float(X3), is_float(Y3), is_float(Z3) -> + X31 = X3 - X1, + Y31 = Y3 - Y1, + Z31 = Z3 - Z1, + Rotpy = pt_sub({X2,Y2,Z2},{X1,Y1,Z1}), + Phi = pt_phi(Rotpy), + Theta = pt_theta(Rotpy), + Sinp = math:sin(Phi), + Sint = math:sin(Theta), + Cosp = math:cos(Phi), + Cost = math:cos(Theta), + Sinpsint = Sinp * Sint, + Sinpcost = Sinp * Cost, + Cospsint = Cosp * Sint, + Cospcost = Cosp * Cost, + Rotpz = {Cost * X31 - Sint * Z31, + Sinpsint * X31 + Cosp * Y31 + Sinpcost * Z31, + Cospsint * X31 - Sinp * Y31 + Cospcost * Z31}, + Rho = pt_theta(Rotpz), + Cosr = math:cos(Rho), + Sinr = math:sin(Rho), + X = Z1 * Sint - X1 * Cost, + Y = -X1 * Sinpsint - Y1 * Cosp - Z1 * Sinpcost, + Z = Y1 * Sinp - Z1 * Cospcost - X1 * Cospsint, + {Cost * Cosr - Cospsint * Sinr, + Sinpsint, + Cost * Sinr + Cospsint * Cosr, + Sinp * Sinr, + Cosp, + -Sinp * Cosr, + -Sint * Cosr - Cospcost * Sinr, + Sinpcost, + Cospcost * Cosr - Sint * Sinr, + X * Cosr - Z * Sinr, + Y, + X * Sinr + Z * Cosr}. + +% -- NUCLEIC ACID CONFORMATIONS DATA BASE ------------------------------------ + +% Numbering of atoms follows the paper: +% +% IUPAC-IUB Joint Commission on Biochemical Nomenclature (JCBN) +% (1983) Abbreviations and Symbols for the Description of +% Conformations of Polynucleotide Chains. Eur. J. Biochem 131, +% 9-15. + +% Define part common to all 4 nucleotide types. + +%nuc ::= { +% tfo,tfo,tfo,tfo, +% pt,pt,pt,pt,pt,pt,pt,pt,pt,pt,pt,pt,pt, +% pt,pt,pt,pt,pt,pt,pt,pt,pt,pt,pt,pt, +% A/C/G/U, +% nuc_specific +% } + +% dgf_base_tfo ; defines the standard position for wc and wc_dumas +% p_o3'_275_tfo ; defines the standard position for the connect function +% p_o3'_180_tfo +% p_o3'_60_tfo +% p o1p o2p o5' c5' h5' h5'' c4' h4' o4' c1' h1' c2' h2'' o2' h2' c3' +% h3' o3' n1 n3 c2 c4 c5 c6 + +type({_,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,X, + _}) -> X. + +nuc_C1_({_,_,_,_,_,_,_,_,_,_, + _,_,_,_,X,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _}) -> X. + +nuc_C2({_,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,X,_,_,_,_, + _}) -> X. + +nuc_C3_({_,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + X,_,_,_,_,_,_,_,_,_, + _}) -> X. + +nuc_C4({_,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,X,_,_,_, + _}) -> X. + +nuc_C4_({_,_,_,_,_,_,_,_,_,_, + _,X,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _}) -> X. + +nuc_N1({_,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _,_,_,X,_,_,_,_,_,_, + _}) -> X. + +nuc_O3_({_,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _,_,X,_,_,_,_,_,_,_, + _}) -> X. + +nuc_P({_,_,_,_,X,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _}) -> X. + +nuc_dgf_base_tfo({X,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _}) -> X. + +nuc_p_o3__180_tfo({_,_,X,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _}) -> X. + +nuc_p_o3__275_tfo({_,X,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _}) -> X. + +nuc_p_o3__60_tfo({_,_,_,X,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _}) -> X. + +rA_N9({_,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,a, + {_,_,X,_,_,_,_,_}}) -> X. + +rG_N9({_,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,g, + {_,_,X,_,_,_,_,_,_}}) -> X. + + +%nuc ::= { +% tfo,tfo,tfo,tfo, +% pt,pt,pt,pt,pt,pt,pt,pt,pt,pt,pt,pt,pt, +% pt,pt,pt,pt,pt,pt,pt,pt,pt,pt,pt,pt, +% A/C/G/U, +% nuc_specific +% } + +% Define remaining atoms for each nucleotide type. + +%nuc_specific +% a {N6,N7,N9,C8,H2,H61,H62,H8} +% c {N4,O2,H41,H42,H5,H6} +% g {N2,N7,N9,C8,O6,H1,H21,H22,H8} +% u {O2,O4,H3,H5,H6} + +% Database of nucleotide conformations: + +rA() -> + { + {-0.0018, -0.8207, 0.5714, % dgf_base_tfo + 0.2679, -0.5509, -0.7904, + 0.9634, 0.1517, 0.2209, + 0.0073, 8.4030, 0.6232}, + {-0.8143, -0.5091, -0.2788, % p_o3'_275_tfo + -0.0433, -0.4257, 0.9038, + -0.5788, 0.7480, 0.3246, + 1.5227, 6.9114, -7.0765}, + {0.3822, -0.7477, 0.5430, % p_o3'_180_tfo + 0.4552, 0.6637, 0.5935, + -0.8042, 0.0203, 0.5941, + -6.9472, -4.1186, -5.9108}, + {0.5640, 0.8007, -0.2022, % p_o3'_60_tfo + -0.8247, 0.5587, -0.0878, + 0.0426, 0.2162, 0.9754, + 6.2694, -7.0540, 3.3316}, + {2.8930, 8.5380, -3.3280}, % P + {1.6980, 7.6960, -3.5570}, % O1P + {3.2260, 9.5010, -4.4020}, % O2P + {4.1590, 7.6040, -3.0340}, % O5' + {5.4550, 8.2120, -2.8810}, % C5' + {5.4546, 8.8508, -1.9978}, % H5' + {5.7588, 8.6625, -3.8259}, % H5'' + {6.4970, 7.1480, -2.5980}, % C4' + {7.4896, 7.5919, -2.5214}, % H4' + {6.1630, 6.4860, -1.3440}, % O4' + {6.5400, 5.1200, -1.4190}, % C1' + {7.2763, 4.9681, -0.6297}, % H1' + {7.1940, 4.8830, -2.7770}, % C2' + {6.8667, 3.9183, -3.1647}, % H2'' + {8.5860, 5.0910, -2.6140}, % O2' + {8.9510, 4.7626, -1.7890}, % H2' + {6.5720, 6.0040, -3.6090}, % C3' + {5.5636, 5.7066, -3.8966}, % H3' + {7.3801, 6.3562, -4.7350}, % O3' + {4.7150, 0.4910, -0.1360}, % N1 + {6.3490, 2.1730, -0.6020}, % N3 + {5.9530, 0.9650, -0.2670}, % C2 + {5.2900, 2.9790, -0.8260}, % C4 + {3.9720, 2.6390, -0.7330}, % C5 + {3.6770, 1.3160, -0.3660}, % C6 + a, { + {2.4280, 0.8450, -0.2360}, % N6 + {3.1660, 3.7290, -1.0360}, % N7 + {5.3170, 4.2990, -1.1930}, % N9 + {4.0100, 4.6780, -1.2990}, % C8 + {6.6890, 0.1903, -0.0518}, % H2 + {1.6470, 1.4460, -0.4040}, % H61 + {2.2780, -0.1080, -0.0280}, % H62 + {3.4421, 5.5744, -1.5482}} % H8 + }. + +rA01() -> + { + {-0.0043, -0.8175, 0.5759, % dgf_base_tfo + 0.2617, -0.5567, -0.7884, + 0.9651, 0.1473, 0.2164, + 0.0359, 8.3929, 0.5532}, + {-0.8143, -0.5091, -0.2788, % p_o3'_275_tfo + -0.0433, -0.4257, 0.9038, + -0.5788, 0.7480, 0.3246, + 1.5227, 6.9114, -7.0765}, + {0.3822, -0.7477, 0.5430, % p_o3'_180_tfo + 0.4552, 0.6637, 0.5935, + -0.8042, 0.0203, 0.5941, + -6.9472, -4.1186, -5.9108}, + {0.5640, 0.8007, -0.2022, % p_o3'_60_tfo + -0.8247, 0.5587, -0.0878, + 0.0426, 0.2162, 0.9754, + 6.2694, -7.0540, 3.3316}, + {2.8930, 8.5380, -3.3280}, % P + {1.6980, 7.6960, -3.5570}, % O1P + {3.2260, 9.5010, -4.4020}, % O2P + {4.1590, 7.6040, -3.0340}, % O5' + {5.4352, 8.2183, -2.7757}, % C5' + {5.3830, 8.7883, -1.8481}, % H5' + {5.7729, 8.7436, -3.6691}, % H5'' + {6.4830, 7.1518, -2.5252}, % C4' + {7.4749, 7.5972, -2.4482}, % H4' + {6.1626, 6.4620, -1.2827}, % O4' + {6.5431, 5.0992, -1.3905}, % C1' + {7.2871, 4.9328, -0.6114}, % H1' + {7.1852, 4.8935, -2.7592}, % C2' + {6.8573, 3.9363, -3.1645}, % H2'' + {8.5780, 5.1025, -2.6046}, % O2' + {8.9516, 4.7577, -1.7902}, % H2' + {6.5522, 6.0300, -3.5612}, % C3' + {5.5420, 5.7356, -3.8459}, % H3' + {7.3487, 6.4089, -4.6867}, % O3' + {4.7442, 0.4514, -0.1390}, % N1 + {6.3687, 2.1459, -0.5926}, % N3 + {5.9795, 0.9335, -0.2657}, % C2 + {5.3052, 2.9471, -0.8125}, % C4 + {3.9891, 2.5987, -0.7230}, % C5 + {3.7016, 1.2717, -0.3647}, % C6 + a, { + {2.4553, 0.7925, -0.2390}, % N6 + {3.1770, 3.6859, -1.0198}, % N7 + {5.3247, 4.2695, -1.1710}, % N9 + {4.0156, 4.6415, -1.2759}, % C8 + {6.7198, 0.1618, -0.0547}, % H2 + {1.6709, 1.3900, -0.4039}, % H61 + {2.3107, -0.1627, -0.0373}, % H62 + {3.4426, 5.5361, -1.5199}} % H8 + }. + +rA02() -> + { + {0.5566, 0.0449, 0.8296, % dgf_base_tfo + 0.5125, 0.7673, -0.3854, + -0.6538, 0.6397, 0.4041, + -9.1161, -3.7679, -2.9968}, + {-0.8143, -0.5091, -0.2788, % p_o3'_275_tfo + -0.0433, -0.4257, 0.9038, + -0.5788, 0.7480, 0.3246, + 1.5227, 6.9114, -7.0765}, + {0.3822, -0.7477, 0.5430, % p_o3'_180_tfo + 0.4552, 0.6637, 0.5935, + -0.8042, 0.0203, 0.5941, + -6.9472, -4.1186, -5.9108}, + {0.5640, 0.8007, -0.2022, % p_o3'_60_tfo + -0.8247, 0.5587, -0.0878, + 0.0426, 0.2162, 0.9754, + 6.2694, -7.0540, 3.3316}, + {2.8930, 8.5380, -3.3280}, % P + {1.6980, 7.6960, -3.5570}, % O1P + {3.2260, 9.5010, -4.4020}, % O2P + {4.1590, 7.6040, -3.0340}, % O5' + {4.5778, 6.6594, -4.0364}, % C5' + {4.9220, 7.1963, -4.9204}, % H5' + {3.7996, 5.9091, -4.1764}, % H5'' + {5.7873, 5.8869, -3.5482}, % C4' + {6.0405, 5.0875, -4.2446}, % H4' + {6.9135, 6.8036, -3.4310}, % O4' + {7.7293, 6.4084, -2.3392}, % C1' + {8.7078, 6.1815, -2.7624}, % H1' + {7.1305, 5.1418, -1.7347}, % C2' + {7.2040, 5.1982, -0.6486}, % H2'' + {7.7417, 4.0392, -2.3813}, % O2' + {8.6785, 4.1443, -2.5630}, % H2' + {5.6666, 5.2728, -2.1536}, % C3' + {5.1747, 5.9805, -1.4863}, % H3' + {4.9997, 4.0086, -2.1973}, % O3' + {10.3245, 8.5459, 1.5467}, % N1 + {9.8051, 6.9432, -0.1497}, % N3 + {10.5175, 7.4328, 0.8408}, % C2 + {8.7523, 7.7422, -0.4228}, % C4 + {8.4257, 8.9060, 0.2099}, % C5 + {9.2665, 9.3242, 1.2540}, % C6 + a, { + {9.0664, 10.4462, 1.9610}, % N6 + {7.2750, 9.4537, -0.3428}, % N7 + {7.7962, 7.5519, -1.3859}, % N9 + {6.9479, 8.6157, -1.2771}, % C8 + {11.4063, 6.9047, 1.1859}, % H2 + {8.2845, 11.0341, 1.7552}, % H61 + {9.6584, 10.6647, 2.7198}, % H62 + {6.0430, 8.9853, -1.7594}} % H8 + }. + +rA03() -> + { + {-0.5021, 0.0731, 0.8617, % dgf_base_tfo + -0.8112, 0.3054, -0.4986, + -0.2996, -0.9494, -0.0940, + 6.4273, -5.1944, -3.7807}, + {-0.8143, -0.5091, -0.2788, % p_o3'_275_tfo + -0.0433, -0.4257, 0.9038, + -0.5788, 0.7480, 0.3246, + 1.5227, 6.9114, -7.0765}, + {0.3822, -0.7477, 0.5430, % p_o3'_180_tfo + 0.4552, 0.6637, 0.5935, + -0.8042, 0.0203, 0.5941, + -6.9472, -4.1186, -5.9108}, + {0.5640, 0.8007, -0.2022, % p_o3'_60_tfo + -0.8247, 0.5587, -0.0878, + 0.0426, 0.2162, 0.9754, + 6.2694, -7.0540, 3.3316}, + {2.8930, 8.5380, -3.3280}, % P + {1.6980, 7.6960, -3.5570}, % O1P + {3.2260, 9.5010, -4.4020}, % O2P + {4.1590, 7.6040, -3.0340}, % O5' + {4.1214, 6.7116, -1.9049}, % C5' + {3.3465, 5.9610, -2.0607}, % H5' + {4.0789, 7.2928, -0.9837}, % H5'' + {5.4170, 5.9293, -1.8186}, % C4' + {5.4506, 5.3400, -0.9023}, % H4' + {5.5067, 5.0417, -2.9703}, % O4' + {6.8650, 4.9152, -3.3612}, % C1' + {7.1090, 3.8577, -3.2603}, % H1' + {7.7152, 5.7282, -2.3894}, % C2' + {8.5029, 6.2356, -2.9463}, % H2'' + {8.1036, 4.8568, -1.3419}, % O2' + {8.3270, 3.9651, -1.6184}, % H2' + {6.7003, 6.7565, -1.8911}, % C3' + {6.5898, 7.5329, -2.6482}, % H3' + {7.0505, 7.2878, -0.6105}, % O3' + {9.6740, 4.7656, -7.6614}, % N1 + {9.0739, 4.3013, -5.3941}, % N3 + {9.8416, 4.2192, -6.4581}, % C2 + {7.9885, 5.0632, -5.6446}, % C4 + {7.6822, 5.6856, -6.8194}, % C5 + {8.5831, 5.5215, -7.8840}, % C6 + a, { + {8.4084, 6.0747, -9.0933}, % N6 + {6.4857, 6.3816, -6.7035}, % N7 + {6.9740, 5.3703, -4.7760}, % N9 + {6.1133, 6.1613, -5.4808}, % C8 + {10.7627, 3.6375, -6.4220}, % H2 + {7.6031, 6.6390, -9.2733}, % H61 + {9.1004, 5.9708, -9.7893}, % H62 + {5.1705, 6.6830, -5.3167}} % H8 + }. + +rA04() -> + { + {-0.5426, -0.8175, 0.1929, % dgf_base_tfo + 0.8304, -0.5567, -0.0237, + 0.1267, 0.1473, 0.9809, + -0.5075, 8.3929, 0.2229}, + {-0.8143, -0.5091, -0.2788, % p_o3'_275_tfo + -0.0433, -0.4257, 0.9038, + -0.5788, 0.7480, 0.3246, + 1.5227, 6.9114, -7.0765}, + {0.3822, -0.7477, 0.5430, % p_o3'_180_tfo + 0.4552, 0.6637, 0.5935, + -0.8042, 0.0203, 0.5941, + -6.9472, -4.1186, -5.9108}, + {0.5640, 0.8007, -0.2022, % p_o3'_60_tfo + -0.8247, 0.5587, -0.0878, + 0.0426, 0.2162, 0.9754, + 6.2694, -7.0540, 3.3316}, + {2.8930, 8.5380, -3.3280}, % P + {1.6980, 7.6960, -3.5570}, % O1P + {3.2260, 9.5010, -4.4020}, % O2P + {4.1590, 7.6040, -3.0340}, % O5' + {5.4352, 8.2183, -2.7757}, % C5' + {5.3830, 8.7883, -1.8481}, % H5' + {5.7729, 8.7436, -3.6691}, % H5'' + {6.4830, 7.1518, -2.5252}, % C4' + {7.4749, 7.5972, -2.4482}, % H4' + {6.1626, 6.4620, -1.2827}, % O4' + {6.5431, 5.0992, -1.3905}, % C1' + {7.2871, 4.9328, -0.6114}, % H1' + {7.1852, 4.8935, -2.7592}, % C2' + {6.8573, 3.9363, -3.1645}, % H2'' + {8.5780, 5.1025, -2.6046}, % O2' + {8.9516, 4.7577, -1.7902}, % H2' + {6.5522, 6.0300, -3.5612}, % C3' + {5.5420, 5.7356, -3.8459}, % H3' + {7.3487, 6.4089, -4.6867}, % O3' + {3.6343, 2.6680, 2.0783}, % N1 + {5.4505, 3.9805, 1.2446}, % N3 + {4.7540, 3.3816, 2.1851}, % C2 + {4.8805, 3.7951, 0.0354}, % C4 + {3.7416, 3.0925, -0.2305}, % C5 + {3.0873, 2.4980, 0.8606}, % C6 + a, { + {1.9600, 1.7805, 0.7462}, % N6 + {3.4605, 3.1184, -1.5906}, % N7 + {5.3247, 4.2695, -1.1710}, % N9 + {4.4244, 3.8244, -2.0953}, % C8 + {5.0814, 3.4352, 3.2234}, % H2 + {1.5423, 1.6454, -0.1520}, % H61 + {1.5716, 1.3398, 1.5392}, % H62 + {4.2675, 3.8876, -3.1721}} % H8 + }. + +rA05() -> + { + {-0.5891, 0.0449, 0.8068, % dgf_base_tfo + 0.5375, 0.7673, 0.3498, + -0.6034, 0.6397, -0.4762, + -0.3019, -3.7679, -9.5913}, + {-0.8143, -0.5091, -0.2788, % p_o3'_275_tfo + -0.0433, -0.4257, 0.9038, + -0.5788, 0.7480, 0.3246, + 1.5227, 6.9114, -7.0765}, + {0.3822, -0.7477, 0.5430, % p_o3'_180_tfo + 0.4552, 0.6637, 0.5935, + -0.8042, 0.0203, 0.5941, + -6.9472, -4.1186, -5.9108}, + {0.5640, 0.8007, -0.2022, % p_o3'_60_tfo + -0.8247, 0.5587, -0.0878, + 0.0426, 0.2162, 0.9754, + 6.2694, -7.0540, 3.3316}, + {2.8930, 8.5380, -3.3280}, % P + {1.6980, 7.6960, -3.5570}, % O1P + {3.2260, 9.5010, -4.4020}, % O2P + {4.1590, 7.6040, -3.0340}, % O5' + {4.5778, 6.6594, -4.0364}, % C5' + {4.9220, 7.1963, -4.9204}, % H5' + {3.7996, 5.9091, -4.1764}, % H5'' + {5.7873, 5.8869, -3.5482}, % C4' + {6.0405, 5.0875, -4.2446}, % H4' + {6.9135, 6.8036, -3.4310}, % O4' + {7.7293, 6.4084, -2.3392}, % C1' + {8.7078, 6.1815, -2.7624}, % H1' + {7.1305, 5.1418, -1.7347}, % C2' + {7.2040, 5.1982, -0.6486}, % H2'' + {7.7417, 4.0392, -2.3813}, % O2' + {8.6785, 4.1443, -2.5630}, % H2' + {5.6666, 5.2728, -2.1536}, % C3' + {5.1747, 5.9805, -1.4863}, % H3' + {4.9997, 4.0086, -2.1973}, % O3' + {10.2594, 10.6774, -1.0056}, % N1 + {9.7528, 8.7080, -2.2631}, % N3 + {10.4471, 9.7876, -1.9791}, % C2 + {8.7271, 8.5575, -1.3991}, % C4 + {8.4100, 9.3803, -0.3580}, % C5 + {9.2294, 10.5030, -0.1574}, % C6 + a, { + {9.0349, 11.3951, 0.8250}, % N6 + {7.2891, 8.9068, 0.3121}, % N7 + {7.7962, 7.5519, -1.3859}, % N9 + {6.9702, 7.8292, -0.3353}, % C8 + {11.3132, 10.0537, -2.5851}, % H2 + {8.2741, 11.2784, 1.4629}, % H61 + {9.6733, 12.1368, 0.9529}, % H62 + {6.0888, 7.3990, 0.1403}} % H8 + }. + +rA06() -> + { + {-0.9815, 0.0731, -0.1772, % dgf_base_tfo + 0.1912, 0.3054, -0.9328, + -0.0141, -0.9494, -0.3137, + 5.7506, -5.1944, 4.7470}, + {-0.8143, -0.5091, -0.2788, % p_o3'_275_tfo + -0.0433, -0.4257, 0.9038, + -0.5788, 0.7480, 0.3246, + 1.5227, 6.9114, -7.0765}, + {0.3822, -0.7477, 0.5430, % p_o3'_180_tfo + 0.4552, 0.6637, 0.5935, + -0.8042, 0.0203, 0.5941, + -6.9472, -4.1186, -5.9108}, + {0.5640, 0.8007, -0.2022, % p_o3'_60_tfo + -0.8247, 0.5587, -0.0878, + 0.0426, 0.2162, 0.9754, + 6.2694, -7.0540, 3.3316}, + {2.8930, 8.5380, -3.3280}, % P + {1.6980, 7.6960, -3.5570}, % O1P + {3.2260, 9.5010, -4.4020}, % O2P + {4.1590, 7.6040, -3.0340}, % O5' + {4.1214, 6.7116, -1.9049}, % C5' + {3.3465, 5.9610, -2.0607}, % H5' + {4.0789, 7.2928, -0.9837}, % H5'' + {5.4170, 5.9293, -1.8186}, % C4' + {5.4506, 5.3400, -0.9023}, % H4' + {5.5067, 5.0417, -2.9703}, % O4' + {6.8650, 4.9152, -3.3612}, % C1' + {7.1090, 3.8577, -3.2603}, % H1' + {7.7152, 5.7282, -2.3894}, % C2' + {8.5029, 6.2356, -2.9463}, % H2'' + {8.1036, 4.8568, -1.3419}, % O2' + {8.3270, 3.9651, -1.6184}, % H2' + {6.7003, 6.7565, -1.8911}, % C3' + {6.5898, 7.5329, -2.6482}, % H3' + {7.0505, 7.2878, -0.6105}, % O3' + {6.6624, 3.5061, -8.2986}, % N1 + {6.5810, 3.2570, -5.9221}, % N3 + {6.5151, 2.8263, -7.1625}, % C2 + {6.8364, 4.5817, -5.8882}, % C4 + {7.0116, 5.4064, -6.9609}, % C5 + {6.9173, 4.8260, -8.2361}, % C6 + a, { + {7.0668, 5.5163, -9.3763}, % N6 + {7.2573, 6.7070, -6.5394}, % N7 + {6.9740, 5.3703, -4.7760}, % N9 + {7.2238, 6.6275, -5.2453}, % C8 + {6.3146, 1.7741, -7.3641}, % H2 + {7.2568, 6.4972, -9.3456}, % H61 + {7.0437, 5.0478, -10.2446}, % H62 + {7.4108, 7.6227, -4.8418}} % H8 + }. + +rA07() -> + { + {0.2379, 0.1310, -0.9624, % dgf_base_tfo + -0.5876, -0.7696, -0.2499, + -0.7734, 0.6249, -0.1061, + 30.9870, -26.9344, 42.6416}, + {0.7529, 0.1548, 0.6397, % p_o3'_275_tfo + 0.2952, -0.9481, -0.1180, + 0.5882, 0.2777, -0.7595, + -58.8919, -11.3095, 6.0866}, + {-0.0239, 0.9667, -0.2546, % p_o3'_180_tfo + 0.9731, -0.0359, -0.2275, + -0.2290, -0.2532, -0.9399, + 3.5401, -29.7913, 52.2796}, + {-0.8912, -0.4531, 0.0242, % p_o3'_60_tfo + -0.1183, 0.1805, -0.9764, + 0.4380, -0.8730, -0.2145, + 19.9023, 54.8054, 15.2799}, + {41.8210, 8.3880, 43.5890}, % P + {42.5400, 8.0450, 44.8330}, % O1P + {42.2470, 9.6920, 42.9910}, % O2P + {40.2550, 8.2030, 43.7340}, % O5' + {39.3505, 8.4697, 42.6565}, % C5' + {39.1377, 7.5433, 42.1230}, % H5' + {39.7203, 9.3119, 42.0717}, % H5'' + {38.0405, 8.9195, 43.2869}, % C4' + {37.3687, 9.3036, 42.5193}, % H4' + {37.4319, 7.8146, 43.9387}, % O4' + {37.1959, 8.1354, 45.3237}, % C1' + {36.1788, 8.5202, 45.3970}, % H1' + {38.1721, 9.2328, 45.6504}, % C2' + {39.1555, 8.7939, 45.8188}, % H2'' + {37.7862, 10.0617, 46.7013}, % O2' + {37.3087, 9.6229, 47.4092}, % H2' + {38.1844, 10.0268, 44.3367}, % C3' + {39.1578, 10.5054, 44.2289}, % H3' + {37.0547, 10.9127, 44.3441}, % O3' + {34.8811, 4.2072, 47.5784}, % N1 + {35.1084, 6.1336, 46.1818}, % N3 + {34.4108, 5.1360, 46.7207}, % C2 + {36.3908, 6.1224, 46.6053}, % C4 + {36.9819, 5.2334, 47.4697}, % C5 + {36.1786, 4.1985, 48.0035}, % C6 + a, { + {36.6103, 3.2749, 48.8452}, % N6 + {38.3236, 5.5522, 47.6595}, % N7 + {37.3887, 7.0024, 46.2437}, % N9 + {38.5055, 6.6096, 46.9057}, % C8 + {33.3553, 5.0152, 46.4771}, % H2 + {37.5730, 3.2804, 49.1507}, % H61 + {35.9775, 2.5638, 49.1828}, % H62 + {39.5461, 6.9184, 47.0041}} % H8 + }. + +rA08() -> + { + {0.1084, -0.0895, -0.9901, % dgf_base_tfo + 0.9789, -0.1638, 0.1220, + -0.1731, -0.9824, 0.0698, + -2.9039, 47.2655, 33.0094}, + {0.7529, 0.1548, 0.6397, % p_o3'_275_tfo + 0.2952, -0.9481, -0.1180, + 0.5882, 0.2777, -0.7595, + -58.8919, -11.3095, 6.0866}, + {-0.0239, 0.9667, -0.2546, % p_o3'_180_tfo + 0.9731, -0.0359, -0.2275, + -0.2290, -0.2532, -0.9399, + 3.5401, -29.7913, 52.2796}, + {-0.8912, -0.4531, 0.0242, % p_o3'_60_tfo + -0.1183, 0.1805, -0.9764, + 0.4380, -0.8730, -0.2145, + 19.9023, 54.8054, 15.2799}, + {41.8210, 8.3880, 43.5890}, % P + {42.5400, 8.0450, 44.8330}, % O1P + {42.2470, 9.6920, 42.9910}, % O2P + {40.2550, 8.2030, 43.7340}, % O5' + {39.4850, 8.9301, 44.6977}, % C5' + {39.0638, 9.8199, 44.2296}, % H5' + {40.0757, 9.0713, 45.6029}, % H5'' + {38.3102, 8.0414, 45.0789}, % C4' + {37.7842, 8.4637, 45.9351}, % H4' + {37.4200, 7.9453, 43.9769}, % O4' + {37.2249, 6.5609, 43.6273}, % C1' + {36.3360, 6.2168, 44.1561}, % H1' + {38.4347, 5.8414, 44.1590}, % C2' + {39.2688, 5.9974, 43.4749}, % H2'' + {38.2344, 4.4907, 44.4348}, % O2' + {37.6374, 4.0386, 43.8341}, % H2' + {38.6926, 6.6079, 45.4637}, % C3' + {39.7585, 6.5640, 45.6877}, % H3' + {37.8238, 6.0705, 46.4723}, % O3' + {33.9162, 6.2598, 39.7758}, % N1 + {34.6709, 6.5759, 42.0215}, % N3 + {33.7257, 6.5186, 41.0858}, % C2 + {35.8935, 6.3324, 41.5018}, % C4 + {36.2105, 6.0601, 40.1932}, % C5 + {35.1538, 6.0151, 39.2537}, % C6 + a, { + {35.3088, 5.7642, 37.9649}, % N6 + {37.5818, 5.8677, 40.0507}, % N7 + {37.0932, 6.3197, 42.1810}, % N9 + {38.0509, 6.0354, 41.2635}, % C8 + {32.6830, 6.6898, 41.3532}, % H2 + {36.2305, 5.5855, 37.5925}, % H61 + {34.5056, 5.7512, 37.3528}, % H62 + {39.1318, 5.8993, 41.2285}} % H8 + }. + +rA09() -> + { + {0.8467, 0.4166, -0.3311, % dgf_base_tfo + -0.3962, 0.9089, 0.1303, + 0.3552, 0.0209, 0.9346, + -42.7319, -26.6223, -29.8163}, + {0.7529, 0.1548, 0.6397, % p_o3'_275_tfo + 0.2952, -0.9481, -0.1180, + 0.5882, 0.2777, -0.7595, + -58.8919, -11.3095, 6.0866}, + {-0.0239, 0.9667, -0.2546, % p_o3'_180_tfo + 0.9731, -0.0359, -0.2275, + -0.2290, -0.2532, -0.9399, + 3.5401, -29.7913, 52.2796}, + {-0.8912, -0.4531, 0.0242, % p_o3'_60_tfo + -0.1183, 0.1805, -0.9764, + 0.4380, -0.8730, -0.2145, + 19.9023, 54.8054, 15.2799}, + {41.8210, 8.3880, 43.5890}, % P + {42.5400, 8.0450, 44.8330}, % O1P + {42.2470, 9.6920, 42.9910}, % O2P + {40.2550, 8.2030, 43.7340}, % O5' + {39.3505, 8.4697, 42.6565}, % C5' + {39.1377, 7.5433, 42.1230}, % H5' + {39.7203, 9.3119, 42.0717}, % H5'' + {38.0405, 8.9195, 43.2869}, % C4' + {37.6479, 8.1347, 43.9335}, % H4' + {38.2691, 10.0933, 44.0524}, % O4' + {37.3999, 11.1488, 43.5973}, % C1' + {36.5061, 11.1221, 44.2206}, % H1' + {37.0364, 10.7838, 42.1836}, % C2' + {37.8636, 11.0489, 41.5252}, % H2'' + {35.8275, 11.3133, 41.7379}, % O2' + {35.6214, 12.1896, 42.0714}, % H2' + {36.9316, 9.2556, 42.2837}, % C3' + {37.1778, 8.8260, 41.3127}, % H3' + {35.6285, 8.9334, 42.7926}, % O3' + {38.1482, 15.2833, 46.4641}, % N1 + {37.3641, 13.0968, 45.9007}, % N3 + {37.5032, 14.1288, 46.7300}, % C2 + {37.9570, 13.3377, 44.7113}, % C4 + {38.6397, 14.4660, 44.3267}, % C5 + {38.7473, 15.5229, 45.2609}, % C6 + a, { + {39.3720, 16.6649, 45.0297}, % N6 + {39.1079, 14.3351, 43.0223}, % N7 + {38.0132, 12.4868, 43.6280}, % N9 + {38.7058, 13.1402, 42.6620}, % C8 + {37.0731, 14.0857, 47.7306}, % H2 + {39.8113, 16.8281, 44.1350}, % H61 + {39.4100, 17.3741, 45.7478}, % H62 + {39.0412, 12.9660, 41.6397}} % H8 + }. + +rA10() -> + { + {0.7063, 0.6317, -0.3196, % dgf_base_tfo + -0.0403, -0.4149, -0.9090, + -0.7068, 0.6549, -0.2676, + 6.4402, -52.1496, 30.8246}, + {0.7529, 0.1548, 0.6397, % p_o3'_275_tfo + 0.2952, -0.9481, -0.1180, + 0.5882, 0.2777, -0.7595, + -58.8919, -11.3095, 6.0866}, + {-0.0239, 0.9667, -0.2546, % p_o3'_180_tfo + 0.9731, -0.0359, -0.2275, + -0.2290, -0.2532, -0.9399, + 3.5401, -29.7913, 52.2796}, + {-0.8912, -0.4531, 0.0242, % p_o3'_60_tfo + -0.1183, 0.1805, -0.9764, + 0.4380, -0.8730, -0.2145, + 19.9023, 54.8054, 15.2799}, + {41.8210, 8.3880, 43.5890}, % P + {42.5400, 8.0450, 44.8330}, % O1P + {42.2470, 9.6920, 42.9910}, % O2P + {40.2550, 8.2030, 43.7340}, % O5' + {39.4850, 8.9301, 44.6977}, % C5' + {39.0638, 9.8199, 44.2296}, % H5' + {40.0757, 9.0713, 45.6029}, % H5'' + {38.3102, 8.0414, 45.0789}, % C4' + {37.7099, 7.8166, 44.1973}, % H4' + {38.8012, 6.8321, 45.6380}, % O4' + {38.2431, 6.6413, 46.9529}, % C1' + {37.3505, 6.0262, 46.8385}, % H1' + {37.8484, 8.0156, 47.4214}, % C2' + {38.7381, 8.5406, 47.7690}, % H2'' + {36.8286, 8.0368, 48.3701}, % O2' + {36.8392, 7.3063, 48.9929}, % H2' + {37.3576, 8.6512, 46.1132}, % C3' + {37.5207, 9.7275, 46.1671}, % H3' + {35.9985, 8.2392, 45.9032}, % O3' + {39.9117, 2.2278, 48.8527}, % N1 + {38.6207, 3.6941, 47.4757}, % N3 + {38.9872, 2.4888, 47.9057}, % C2 + {39.2961, 4.6720, 48.1174}, % C4 + {40.2546, 4.5307, 49.0912}, % C5 + {40.5932, 3.2189, 49.4985}, % C6 + a, { + {41.4938, 2.9317, 50.4229}, % N6 + {40.7195, 5.7755, 49.5060}, % N7 + {39.1730, 6.0305, 47.9170}, % N9 + {40.0413, 6.6250, 48.7728}, % C8 + {38.5257, 1.5960, 47.4838}, % H2 + {41.9907, 3.6753, 50.8921}, % H61 + {41.6848, 1.9687, 50.6599}, % H62 + {40.3571, 7.6321, 49.0452}} % H8 + }. + +rAs() -> [rA01(),rA02(),rA03(),rA04(),rA05(),rA06(),rA07(), + rA08(),rA09(),rA10()]. + +rC() -> + { + {-0.0359, -0.8071, 0.5894, % dgf_base_tfo + -0.2669, 0.5761, 0.7726, + -0.9631, -0.1296, -0.2361, + 0.1584, 8.3434, 0.5434}, + {-0.8313, -0.4738, -0.2906, % p_o3'_275_tfo + 0.0649, 0.4366, -0.8973, + 0.5521, -0.7648, -0.3322, + 1.6833, 6.8060, -7.0011}, + {0.3445, -0.7630, 0.5470, % p_o3'_180_tfo + -0.4628, -0.6450, -0.6082, + 0.8168, -0.0436, -0.5753, + -6.8179, -3.9778, -5.9887}, + {0.5855, 0.7931, -0.1682, % p_o3'_60_tfo + 0.8103, -0.5790, 0.0906, + -0.0255, -0.1894, -0.9816, + 6.1203, -7.1051, 3.1984}, + {2.6760, -8.4960, 3.2880}, % P + {1.4950, -7.6230, 3.4770}, % O1P + {2.9490, -9.4640, 4.3740}, % O2P + {3.9730, -7.5950, 3.0340}, % O5' + {5.2430, -8.2420, 2.8260}, % C5' + {5.1974, -8.8497, 1.9223}, % H5' + {5.5548, -8.7348, 3.7469}, % H5'' + {6.3140, -7.2060, 2.5510}, % C4' + {7.2954, -7.6762, 2.4898}, % H4' + {6.0140, -6.5420, 1.2890}, % O4' + {6.4190, -5.1840, 1.3620}, % C1' + {7.1608, -5.0495, 0.5747}, % H1' + {7.0760, -4.9560, 2.7270}, % C2' + {6.7770, -3.9803, 3.1099}, % H2'' + {8.4500, -5.1930, 2.5810}, % O2' + {8.8309, -4.8755, 1.7590}, % H2' + {6.4060, -6.0590, 3.5580}, % C3' + {5.4021, -5.7313, 3.8281}, % H3' + {7.1570, -6.4240, 4.7070}, % O3' + {5.2170, -4.3260, 1.1690}, % N1 + {4.2960, -2.2560, 0.6290}, % N3 + {5.4330, -3.0200, 0.7990}, % C2 + {2.9930, -2.6780, 0.7940}, % C4 + {2.8670, -4.0630, 1.1830}, % C5 + {3.9570, -4.8300, 1.3550}, % C6 + c, { + {2.0187, -1.8047, 0.5874}, % N4 + {6.5470, -2.5560, 0.6290}, % O2 + {1.0684, -2.1236, 0.7109}, % H41 + {2.2344, -0.8560, 0.3162}, % H42 + {1.8797, -4.4972, 1.3404}, % H5 + {3.8479, -5.8742, 1.6480}} % H6 + }. + +rC01() -> + { + {-0.0137, -0.8012, 0.5983, % dgf_base_tfo + -0.2523, 0.5817, 0.7733, + -0.9675, -0.1404, -0.2101, + 0.2031, 8.3874, 0.4228}, + {-0.8313, -0.4738, -0.2906, % p_o3'_275_tfo + 0.0649, 0.4366, -0.8973, + 0.5521, -0.7648, -0.3322, + 1.6833, 6.8060, -7.0011}, + {0.3445, -0.7630, 0.5470, % p_o3'_180_tfo + -0.4628, -0.6450, -0.6082, + 0.8168, -0.0436, -0.5753, + -6.8179, -3.9778, -5.9887}, + {0.5855, 0.7931, -0.1682, % p_o3'_60_tfo + 0.8103, -0.5790, 0.0906, + -0.0255, -0.1894, -0.9816, + 6.1203, -7.1051, 3.1984}, + {2.6760, -8.4960, 3.2880}, % P + {1.4950, -7.6230, 3.4770}, % O1P + {2.9490, -9.4640, 4.3740}, % O2P + {3.9730, -7.5950, 3.0340}, % O5' + {5.2416, -8.2422, 2.8181}, % C5' + {5.2050, -8.8128, 1.8901}, % H5' + {5.5368, -8.7738, 3.7227}, % H5'' + {6.3232, -7.2037, 2.6002}, % C4' + {7.3048, -7.6757, 2.5577}, % H4' + {6.0635, -6.5092, 1.3456}, % O4' + {6.4697, -5.1547, 1.4629}, % C1' + {7.2354, -5.0043, 0.7018}, % H1' + {7.0856, -4.9610, 2.8521}, % C2' + {6.7777, -3.9935, 3.2487}, % H2'' + {8.4627, -5.1992, 2.7423}, % O2' + {8.8693, -4.8638, 1.9399}, % H2' + {6.3877, -6.0809, 3.6362}, % C3' + {5.3770, -5.7562, 3.8834}, % H3' + {7.1024, -6.4754, 4.7985}, % O3' + {5.2764, -4.2883, 1.2538}, % N1 + {4.3777, -2.2062, 0.7229}, % N3 + {5.5069, -2.9779, 0.9088}, % C2 + {3.0693, -2.6246, 0.8500}, % C4 + {2.9279, -4.0146, 1.2149}, % C5 + {4.0101, -4.7892, 1.4017}, % C6 + c, { + {2.1040, -1.7437, 0.6331}, % N4 + {6.6267, -2.5166, 0.7728}, % O2 + {1.1496, -2.0600, 0.7287}, % H41 + {2.3303, -0.7921, 0.3815}, % H42 + {1.9353, -4.4465, 1.3419}, % H5 + {3.8895, -5.8371, 1.6762}} % H6 + }. + +rC02() -> + { + {0.5141, 0.0246, 0.8574, % dgf_base_tfo + -0.5547, -0.7529, 0.3542, + 0.6542, -0.6577, -0.3734, + -9.1111, -3.4598, -3.2939}, + {-0.8313, -0.4738, -0.2906, % p_o3'_275_tfo + 0.0649, 0.4366, -0.8973, + 0.5521, -0.7648, -0.3322, + 1.6833, 6.8060, -7.0011}, + {0.3445, -0.7630, 0.5470, % p_o3'_180_tfo + -0.4628, -0.6450, -0.6082, + 0.8168, -0.0436, -0.5753, + -6.8179, -3.9778, -5.9887}, + {0.5855, 0.7931, -0.1682, % p_o3'_60_tfo + 0.8103, -0.5790, 0.0906, + -0.0255, -0.1894, -0.9816, + 6.1203, -7.1051, 3.1984}, + {2.6760, -8.4960, 3.2880}, % P + {1.4950, -7.6230, 3.4770}, % O1P + {2.9490, -9.4640, 4.3740}, % O2P + {3.9730, -7.5950, 3.0340}, % O5' + {4.3825, -6.6585, 4.0489}, % C5' + {4.6841, -7.2019, 4.9443}, % H5' + {3.6189, -5.8889, 4.1625}, % H5'' + {5.6255, -5.9175, 3.5998}, % C4' + {5.8732, -5.1228, 4.3034}, % H4' + {6.7337, -6.8605, 3.5222}, % O4' + {7.5932, -6.4923, 2.4548}, % C1' + {8.5661, -6.2983, 2.9064}, % H1' + {7.0527, -5.2012, 1.8322}, % C2' + {7.1627, -5.2525, 0.7490}, % H2'' + {7.6666, -4.1249, 2.4880}, % O2' + {8.5944, -4.2543, 2.6981}, % H2' + {5.5661, -5.3029, 2.2009}, % C3' + {5.0841, -6.0018, 1.5172}, % H3' + {4.9062, -4.0452, 2.2042}, % O3' + {7.6298, -7.6136, 1.4752}, % N1 + {8.6945, -8.7046, -0.2857}, % N3 + {8.6943, -7.6514, 0.6066}, % C2 + {7.7426, -9.6987, -0.3801}, % C4 + {6.6642, -9.5742, 0.5722}, % C5 + {6.6391, -8.5592, 1.4526}, % C6 + c, { + {7.9033, -10.6371, -1.3010}, % N4 + {9.5840, -6.8186, 0.6136}, % O2 + {7.2009, -11.3604, -1.3619}, % H41 + {8.7058, -10.6168, -1.9140}, % H42 + {5.8585, -10.3083, 0.5822}, % H5 + {5.8197, -8.4773, 2.1667}} % H6 + }. + +rC03() -> + { + {-0.4993, 0.0476, 0.8651, % dgf_base_tfo + 0.8078, -0.3353, 0.4847, + 0.3132, 0.9409, 0.1290, + 6.2989, -5.2303, -3.8577}, + {-0.8313, -0.4738, -0.2906, % p_o3'_275_tfo + 0.0649, 0.4366, -0.8973, + 0.5521, -0.7648, -0.3322, + 1.6833, 6.8060, -7.0011}, + {0.3445, -0.7630, 0.5470, % p_o3'_180_tfo + -0.4628, -0.6450, -0.6082, + 0.8168, -0.0436, -0.5753, + -6.8179, -3.9778, -5.9887}, + {0.5855, 0.7931, -0.1682, % p_o3'_60_tfo + 0.8103, -0.5790, 0.0906, + -0.0255, -0.1894, -0.9816, + 6.1203, -7.1051, 3.1984}, + {2.6760, -8.4960, 3.2880}, % P + {1.4950, -7.6230, 3.4770}, % O1P + {2.9490, -9.4640, 4.3740}, % O2P + {3.9730, -7.5950, 3.0340}, % O5' + {3.9938, -6.7042, 1.9023}, % C5' + {3.2332, -5.9343, 2.0319}, % H5' + {3.9666, -7.2863, 0.9812}, % H5'' + {5.3098, -5.9546, 1.8564}, % C4' + {5.3863, -5.3702, 0.9395}, % H4' + {5.3851, -5.0642, 3.0076}, % O4' + {6.7315, -4.9724, 3.4462}, % C1' + {7.0033, -3.9202, 3.3619}, % H1' + {7.5997, -5.8018, 2.4948}, % C2' + {8.3627, -6.3254, 3.0707}, % H2'' + {8.0410, -4.9501, 1.4724}, % O2' + {8.2781, -4.0644, 1.7570}, % H2' + {6.5701, -6.8129, 1.9714}, % C3' + {6.4186, -7.5809, 2.7299}, % H3' + {6.9357, -7.3841, 0.7235}, % O3' + {6.8024, -5.4718, 4.8475}, % N1 + {7.9218, -5.5700, 6.8877}, % N3 + {7.8908, -5.0886, 5.5944}, % C2 + {6.9789, -6.3827, 7.4823}, % C4 + {5.8742, -6.7319, 6.6202}, % C5 + {5.8182, -6.2769, 5.3570}, % C6 + c, { + {7.1702, -6.7511, 8.7402}, % N4 + {8.7747, -4.3728, 5.1568}, % O2 + {6.4741, -7.3461, 9.1662}, % H41 + {7.9889, -6.4396, 9.2429}, % H42 + {5.0736, -7.3713, 6.9922}, % H5 + {4.9784, -6.5473, 4.7170}} % H6 + }. + +rC04() -> + { + {-0.5669, -0.8012, 0.1918, % dgf_base_tfo + -0.8129, 0.5817, 0.0273, + -0.1334, -0.1404, -0.9811, + -0.3279, 8.3874, 0.3355}, + {-0.8313, -0.4738, -0.2906, % p_o3'_275_tfo + 0.0649, 0.4366, -0.8973, + 0.5521, -0.7648, -0.3322, + 1.6833, 6.8060, -7.0011}, + {0.3445, -0.7630, 0.5470, % p_o3'_180_tfo + -0.4628, -0.6450, -0.6082, + 0.8168, -0.0436, -0.5753, + -6.8179, -3.9778, -5.9887}, + {0.5855, 0.7931, -0.1682, % p_o3'_60_tfo + 0.8103, -0.5790, 0.0906, + -0.0255, -0.1894, -0.9816, + 6.1203, -7.1051, 3.1984}, + {2.6760, -8.4960, 3.2880}, % P + {1.4950, -7.6230, 3.4770}, % O1P + {2.9490, -9.4640, 4.3740}, % O2P + {3.9730, -7.5950, 3.0340}, % O5' + {5.2416, -8.2422, 2.8181}, % C5' + {5.2050, -8.8128, 1.8901}, % H5' + {5.5368, -8.7738, 3.7227}, % H5'' + {6.3232, -7.2037, 2.6002}, % C4' + {7.3048, -7.6757, 2.5577}, % H4' + {6.0635, -6.5092, 1.3456}, % O4' + {6.4697, -5.1547, 1.4629}, % C1' + {7.2354, -5.0043, 0.7018}, % H1' + {7.0856, -4.9610, 2.8521}, % C2' + {6.7777, -3.9935, 3.2487}, % H2'' + {8.4627, -5.1992, 2.7423}, % O2' + {8.8693, -4.8638, 1.9399}, % H2' + {6.3877, -6.0809, 3.6362}, % C3' + {5.3770, -5.7562, 3.8834}, % H3' + {7.1024, -6.4754, 4.7985}, % O3' + {5.2764, -4.2883, 1.2538}, % N1 + {3.8961, -3.0896, -0.1893}, % N3 + {5.0095, -3.8907, -0.0346}, % C2 + {3.0480, -2.6632, 0.8116}, % C4 + {3.4093, -3.1310, 2.1292}, % C5 + {4.4878, -3.9124, 2.3088}, % C6 + c, { + {2.0216, -1.8941, 0.4804}, % N4 + {5.7005, -4.2164, -0.9842}, % O2 + {1.4067, -1.5873, 1.2205}, % H41 + {1.8721, -1.6319, -0.4835}, % H42 + {2.8048, -2.8507, 2.9918}, % H5 + {4.7491, -4.2593, 3.3085}} % H6 + }. + +rC05() -> + { + {-0.6298, 0.0246, 0.7763, % dgf_base_tfo + -0.5226, -0.7529, -0.4001, + 0.5746, -0.6577, 0.4870, + -0.0208, -3.4598, -9.6882}, + {-0.8313, -0.4738, -0.2906, % p_o3'_275_tfo + 0.0649, 0.4366, -0.8973, + 0.5521, -0.7648, -0.3322, + 1.6833, 6.8060, -7.0011}, + {0.3445, -0.7630, 0.5470, % p_o3'_180_tfo + -0.4628, -0.6450, -0.6082, + 0.8168, -0.0436, -0.5753, + -6.8179, -3.9778, -5.9887}, + {0.5855, 0.7931, -0.1682, % p_o3'_60_tfo + 0.8103, -0.5790, 0.0906, + -0.0255, -0.1894, -0.9816, + 6.1203, -7.1051, 3.1984}, + {2.6760, -8.4960, 3.2880}, % P + {1.4950, -7.6230, 3.4770}, % O1P + {2.9490, -9.4640, 4.3740}, % O2P + {3.9730, -7.5950, 3.0340}, % O5' + {4.3825, -6.6585, 4.0489}, % C5' + {4.6841, -7.2019, 4.9443}, % H5' + {3.6189, -5.8889, 4.1625}, % H5'' + {5.6255, -5.9175, 3.5998}, % C4' + {5.8732, -5.1228, 4.3034}, % H4' + {6.7337, -6.8605, 3.5222}, % O4' + {7.5932, -6.4923, 2.4548}, % C1' + {8.5661, -6.2983, 2.9064}, % H1' + {7.0527, -5.2012, 1.8322}, % C2' + {7.1627, -5.2525, 0.7490}, % H2'' + {7.6666, -4.1249, 2.4880}, % O2' + {8.5944, -4.2543, 2.6981}, % H2' + {5.5661, -5.3029, 2.2009}, % C3' + {5.0841, -6.0018, 1.5172}, % H3' + {4.9062, -4.0452, 2.2042}, % O3' + {7.6298, -7.6136, 1.4752}, % N1 + {8.5977, -9.5977, 0.7329}, % N3 + {8.5951, -8.5745, 1.6594}, % C2 + {7.7372, -9.7371, -0.3364}, % C4 + {6.7596, -8.6801, -0.4476}, % C5 + {6.7338, -7.6721, 0.4408}, % C6 + c, { + {7.8849, -10.7881, -1.1289}, % N4 + {9.3993, -8.5377, 2.5743}, % O2 + {7.2499, -10.8809, -1.9088}, % H41 + {8.6122, -11.4649, -0.9468}, % H42 + {6.0317, -8.6941, -1.2588}, % H5 + {5.9901, -6.8809, 0.3459}} % H6 + }. + +rC06() -> + { + {-0.9837, 0.0476, -0.1733, % dgf_base_tfo + -0.1792, -0.3353, 0.9249, + -0.0141, 0.9409, 0.3384, + 5.7793, -5.2303, 4.5997}, + {-0.8313, -0.4738, -0.2906, % p_o3'_275_tfo + 0.0649, 0.4366, -0.8973, + 0.5521, -0.7648, -0.3322, + 1.6833, 6.8060, -7.0011}, + {0.3445, -0.7630, 0.5470, % p_o3'_180_tfo + -0.4628, -0.6450, -0.6082, + 0.8168, -0.0436, -0.5753, + -6.8179, -3.9778, -5.9887}, + {0.5855, 0.7931, -0.1682, % p_o3'_60_tfo + 0.8103, -0.5790, 0.0906, + -0.0255, -0.1894, -0.9816, + 6.1203, -7.1051, 3.1984}, + {2.6760, -8.4960, 3.2880}, % P + {1.4950, -7.6230, 3.4770}, % O1P + {2.9490, -9.4640, 4.3740}, % O2P + {3.9730, -7.5950, 3.0340}, % O5' + {3.9938, -6.7042, 1.9023}, % C5' + {3.2332, -5.9343, 2.0319}, % H5' + {3.9666, -7.2863, 0.9812}, % H5'' + {5.3098, -5.9546, 1.8564}, % C4' + {5.3863, -5.3702, 0.9395}, % H4' + {5.3851, -5.0642, 3.0076}, % O4' + {6.7315, -4.9724, 3.4462}, % C1' + {7.0033, -3.9202, 3.3619}, % H1' + {7.5997, -5.8018, 2.4948}, % C2' + {8.3627, -6.3254, 3.0707}, % H2'' + {8.0410, -4.9501, 1.4724}, % O2' + {8.2781, -4.0644, 1.7570}, % H2' + {6.5701, -6.8129, 1.9714}, % C3' + {6.4186, -7.5809, 2.7299}, % H3' + {6.9357, -7.3841, 0.7235}, % O3' + {6.8024, -5.4718, 4.8475}, % N1 + {6.6920, -5.0495, 7.1354}, % N3 + {6.6201, -4.5500, 5.8506}, % C2 + {6.9254, -6.3614, 7.4926}, % C4 + {7.1046, -7.2543, 6.3718}, % C5 + {7.0391, -6.7951, 5.1106}, % C6 + c, { + {6.9614, -6.6648, 8.7815}, % N4 + {6.4083, -3.3696, 5.6340}, % O2 + {7.1329, -7.6280, 9.0324}, % H41 + {6.8204, -5.9469, 9.4777}, % H42 + {7.2954, -8.3135, 6.5440}, % H5 + {7.1753, -7.4798, 4.2735}} % H6 + }. + +rC07() -> + { + {0.0033, 0.2720, -0.9623, % dgf_base_tfo + 0.3013, -0.9179, -0.2584, + -0.9535, -0.2891, -0.0850, + 43.0403, 13.7233, 34.5710}, + {0.9187, 0.2887, 0.2694, % p_o3'_275_tfo + 0.0302, -0.7316, 0.6811, + 0.3938, -0.6176, -0.6808, + -48.4330, 26.3254, 13.6383}, + {-0.1504, 0.7744, -0.6145, % p_o3'_180_tfo + 0.7581, 0.4893, 0.4311, + 0.6345, -0.4010, -0.6607, + -31.9784, -13.4285, 44.9650}, + {-0.6236, -0.7810, -0.0337, % p_o3'_60_tfo + -0.6890, 0.5694, -0.4484, + 0.3694, -0.2564, -0.8932, + 12.1105, 30.8774, 46.0946}, + {33.3400, 11.0980, 46.1750}, % P + {34.5130, 10.2320, 46.4660}, % O1P + {33.4130, 12.3960, 46.9340}, % O2P + {31.9810, 10.3390, 46.4820}, % O5' + {30.8152, 11.1619, 46.2003}, % C5' + {30.4519, 10.9454, 45.1957}, % H5' + {31.0379, 12.2016, 46.4400}, % H5'' + {29.7081, 10.7448, 47.1428}, % C4' + {28.8710, 11.4416, 47.0982}, % H4' + {29.2550, 9.4394, 46.8162}, % O4' + {29.3907, 8.5625, 47.9460}, % C1' + {28.4416, 8.5669, 48.4819}, % H1' + {30.4468, 9.2031, 48.7952}, % C2' + {31.4222, 8.9651, 48.3709}, % H2'' + {30.3701, 8.9157, 50.1624}, % O2' + {30.0652, 8.0304, 50.3740}, % H2' + {30.1622, 10.6879, 48.6120}, % C3' + {31.0952, 11.2399, 48.7254}, % H3' + {29.1076, 11.1535, 49.4702}, % O3' + {29.7883, 7.2209, 47.5235}, % N1 + {29.1825, 5.0438, 46.8275}, % N3 + {28.8008, 6.2912, 47.2263}, % C2 + {30.4888, 4.6890, 46.7186}, % C4 + {31.5034, 5.6405, 47.0249}, % C5 + {31.1091, 6.8691, 47.4156}, % C6 + c, { + {30.8109, 3.4584, 46.3336}, % N4 + {27.6171, 6.5989, 47.3189}, % O2 + {31.7923, 3.2301, 46.2638}, % H41 + {30.0880, 2.7857, 46.1215}, % H42 + {32.5542, 5.3634, 46.9395}, % H5 + {31.8523, 7.6279, 47.6603}} % H6 + }. + +rC08() -> + { + {0.0797, -0.6026, -0.7941, % dgf_base_tfo + 0.7939, 0.5201, -0.3150, + 0.6028, -0.6054, 0.5198, + -36.8341, 41.5293, 1.6628}, + {0.9187, 0.2887, 0.2694, % p_o3'_275_tfo + 0.0302, -0.7316, 0.6811, + 0.3938, -0.6176, -0.6808, + -48.4330, 26.3254, 13.6383}, + {-0.1504, 0.7744, -0.6145, % p_o3'_180_tfo + 0.7581, 0.4893, 0.4311, + 0.6345, -0.4010, -0.6607, + -31.9784, -13.4285, 44.9650}, + {-0.6236, -0.7810, -0.0337, % p_o3'_60_tfo + -0.6890, 0.5694, -0.4484, + 0.3694, -0.2564, -0.8932, + 12.1105, 30.8774, 46.0946}, + {33.3400, 11.0980, 46.1750}, % P + {34.5130, 10.2320, 46.4660}, % O1P + {33.4130, 12.3960, 46.9340}, % O2P + {31.9810, 10.3390, 46.4820}, % O5' + {31.8779, 9.9369, 47.8760}, % C5' + {31.3239, 10.6931, 48.4322}, % H5' + {32.8647, 9.6624, 48.2489}, % H5'' + {31.0429, 8.6773, 47.9401}, % C4' + {31.0779, 8.2331, 48.9349}, % H4' + {29.6956, 8.9669, 47.5983}, % O4' + {29.2784, 8.1700, 46.4782}, % C1' + {28.8006, 7.2731, 46.8722}, % H1' + {30.5544, 7.7940, 45.7875}, % C2' + {30.8837, 8.6410, 45.1856}, % H2'' + {30.5100, 6.6007, 45.0582}, % O2' + {29.6694, 6.4168, 44.6326}, % H2' + {31.5146, 7.5954, 46.9527}, % C3' + {32.5255, 7.8261, 46.6166}, % H3' + {31.3876, 6.2951, 47.5516}, % O3' + {28.3976, 8.9302, 45.5933}, % N1 + {26.2155, 9.6135, 44.9910}, % N3 + {27.0281, 8.8961, 45.8192}, % C2 + {26.7044, 10.3489, 43.9595}, % C4 + {28.1088, 10.3837, 43.7247}, % C5 + {28.8978, 9.6708, 44.5535}, % C6 + c, { + {25.8715, 11.0249, 43.1749}, % N4 + {26.5733, 8.2371, 46.7484}, % O2 + {26.2707, 11.5609, 42.4177}, % H41 + {24.8760, 10.9939, 43.3427}, % H42 + {28.5089, 10.9722, 42.8990}, % H5 + {29.9782, 9.6687, 44.4097}} % H6 + }. + +rC09() -> + { + {0.8727, 0.4760, -0.1091, % dgf_base_tfo + -0.4188, 0.6148, -0.6682, + -0.2510, 0.6289, 0.7359, + -8.1687, -52.0761, -25.0726}, + {0.9187, 0.2887, 0.2694, % p_o3'_275_tfo + 0.0302, -0.7316, 0.6811, + 0.3938, -0.6176, -0.6808, + -48.4330, 26.3254, 13.6383}, + {-0.1504, 0.7744, -0.6145, % p_o3'_180_tfo + 0.7581, 0.4893, 0.4311, + 0.6345, -0.4010, -0.6607, + -31.9784, -13.4285, 44.9650}, + {-0.6236, -0.7810, -0.0337, % p_o3'_60_tfo + -0.6890, 0.5694, -0.4484, + 0.3694, -0.2564, -0.8932, + 12.1105, 30.8774, 46.0946}, + {33.3400, 11.0980, 46.1750}, % P + {34.5130, 10.2320, 46.4660}, % O1P + {33.4130, 12.3960, 46.9340}, % O2P + {31.9810, 10.3390, 46.4820}, % O5' + {30.8152, 11.1619, 46.2003}, % C5' + {30.4519, 10.9454, 45.1957}, % H5' + {31.0379, 12.2016, 46.4400}, % H5'' + {29.7081, 10.7448, 47.1428}, % C4' + {29.4506, 9.6945, 47.0059}, % H4' + {30.1045, 10.9634, 48.4885}, % O4' + {29.1794, 11.8418, 49.1490}, % C1' + {28.4388, 11.2210, 49.6533}, % H1' + {28.5211, 12.6008, 48.0367}, % C2' + {29.1947, 13.3949, 47.7147}, % H2'' + {27.2316, 13.0683, 48.3134}, % O2' + {27.0851, 13.3391, 49.2227}, % H2' + {28.4131, 11.5507, 46.9391}, % C3' + {28.4451, 12.0512, 45.9713}, % H3' + {27.2707, 10.6955, 47.1097}, % O3' + {29.8751, 12.7405, 50.0682}, % N1 + {30.7172, 13.1841, 52.2328}, % N3 + {30.0617, 12.3404, 51.3847}, % C2 + {31.1834, 14.3941, 51.8297}, % C4 + {30.9913, 14.8074, 50.4803}, % C5 + {30.3434, 13.9610, 49.6548}, % C6 + c, { + {31.8090, 15.1847, 52.6957}, % N4 + {29.6470, 11.2494, 51.7616}, % O2 + {32.1422, 16.0774, 52.3606}, % H41 + {31.9392, 14.8893, 53.6527}, % H42 + {31.3632, 15.7771, 50.1491}, % H5 + {30.1742, 14.2374, 48.6141}} % H6 + }. + +rC10() -> + { + {0.1549, 0.8710, -0.4663, % dgf_base_tfo + 0.6768, -0.4374, -0.5921, + -0.7197, -0.2239, -0.6572, + 25.2447, -14.1920, 50.3201}, + {0.9187, 0.2887, 0.2694, % p_o3'_275_tfo + 0.0302, -0.7316, 0.6811, + 0.3938, -0.6176, -0.6808, + -48.4330, 26.3254, 13.6383}, + {-0.1504, 0.7744, -0.6145, % p_o3'_180_tfo + 0.7581, 0.4893, 0.4311, + 0.6345, -0.4010, -0.6607, + -31.9784, -13.4285, 44.9650}, + {-0.6236, -0.7810, -0.0337, % p_o3'_60_tfo + -0.6890, 0.5694, -0.4484, + 0.3694, -0.2564, -0.8932, + 12.1105, 30.8774, 46.0946}, + {33.3400, 11.0980, 46.1750}, % P + {34.5130, 10.2320, 46.4660}, % O1P + {33.4130, 12.3960, 46.9340}, % O2P + {31.9810, 10.3390, 46.4820}, % O5' + {31.8779, 9.9369, 47.8760}, % C5' + {31.3239, 10.6931, 48.4322}, % H5' + {32.8647, 9.6624, 48.2489}, % H5'' + {31.0429, 8.6773, 47.9401}, % C4' + {30.0440, 8.8473, 47.5383}, % H4' + {31.6749, 7.6351, 47.2119}, % O4' + {31.9159, 6.5022, 48.0616}, % C1' + {31.0691, 5.8243, 47.9544}, % H1' + {31.9300, 7.0685, 49.4493}, % C2' + {32.9024, 7.5288, 49.6245}, % H2'' + {31.5672, 6.1750, 50.4632}, % O2' + {31.8416, 5.2663, 50.3200}, % H2' + {30.8618, 8.1514, 49.3749}, % C3' + {31.1122, 8.9396, 50.0850}, % H3' + {29.5351, 7.6245, 49.5409}, % O3' + {33.1890, 5.8629, 47.7343}, % N1 + {34.4004, 4.2636, 46.4828}, % N3 + {33.2062, 4.8497, 46.7851}, % C2 + {35.5600, 4.6374, 47.0822}, % C4 + {35.5444, 5.6751, 48.0577}, % C5 + {34.3565, 6.2450, 48.3432}, % C6 + c, { + {36.6977, 4.0305, 46.7598}, % N4 + {32.1661, 4.5034, 46.2348}, % O2 + {37.5405, 4.3347, 47.2259}, % H41 + {36.7033, 3.2923, 46.0706}, % H42 + {36.4713, 5.9811, 48.5428}, % H5 + {34.2986, 7.0426, 49.0839}} % H6 + }. + +rCs() -> [rC01(),rC02(),rC03(),rC04(),rC05(),rC06(),rC07(), + rC08(),rC09(),rC10()]. + +rG() -> + { + {-0.0018, -0.8207, 0.5714, % dgf_base_tfo + 0.2679, -0.5509, -0.7904, + 0.9634, 0.1517, 0.2209, + 0.0073, 8.4030, 0.6232}, + {-0.8143, -0.5091, -0.2788, % p_o3'_275_tfo + -0.0433, -0.4257, 0.9038, + -0.5788, 0.7480, 0.3246, + 1.5227, 6.9114, -7.0765}, + {0.3822, -0.7477, 0.5430, % p_o3'_180_tfo + 0.4552, 0.6637, 0.5935, + -0.8042, 0.0203, 0.5941, + -6.9472, -4.1186, -5.9108}, + {0.5640, 0.8007, -0.2022, % p_o3'_60_tfo + -0.8247, 0.5587, -0.0878, + 0.0426, 0.2162, 0.9754, + 6.2694, -7.0540, 3.3316}, + {2.8930, 8.5380, -3.3280}, % P + {1.6980, 7.6960, -3.5570}, % O1P + {3.2260, 9.5010, -4.4020}, % O2P + {4.1590, 7.6040, -3.0340}, % O5' + {5.4550, 8.2120, -2.8810}, % C5' + {5.4546, 8.8508, -1.9978}, % H5' + {5.7588, 8.6625, -3.8259}, % H5'' + {6.4970, 7.1480, -2.5980}, % C4' + {7.4896, 7.5919, -2.5214}, % H4' + {6.1630, 6.4860, -1.3440}, % O4' + {6.5400, 5.1200, -1.4190}, % C1' + {7.2763, 4.9681, -0.6297}, % H1' + {7.1940, 4.8830, -2.7770}, % C2' + {6.8667, 3.9183, -3.1647}, % H2'' + {8.5860, 5.0910, -2.6140}, % O2' + {8.9510, 4.7626, -1.7890}, % H2' + {6.5720, 6.0040, -3.6090}, % C3' + {5.5636, 5.7066, -3.8966}, % H3' + {7.3801, 6.3562, -4.7350}, % O3' + {4.7150, 0.4910, -0.1360}, % N1 + {6.3490, 2.1730, -0.6020}, % N3 + {5.9530, 0.9650, -0.2670}, % C2 + {5.2900, 2.9790, -0.8260}, % C4 + {3.9720, 2.6390, -0.7330}, % C5 + {3.6770, 1.3160, -0.3660}, % C6 + g, { + {6.8426, 0.0056, -0.0019}, % N2 + {3.1660, 3.7290, -1.0360}, % N7 + {5.3170, 4.2990, -1.1930}, % N9 + {4.0100, 4.6780, -1.2990}, % C8 + {2.4280, 0.8450, -0.2360}, % O6 + {4.6151, -0.4677, 0.1305}, % H1 + {6.6463, -0.9463, 0.2729}, % H21 + {7.8170, 0.2642, -0.0640}, % H22 + {3.4421, 5.5744, -1.5482}} % H8 + }. + +rU() -> + { + {-0.0359, -0.8071, 0.5894, % dgf_base_tfo + -0.2669, 0.5761, 0.7726, + -0.9631, -0.1296, -0.2361, + 0.1584, 8.3434, 0.5434}, + {-0.8313, -0.4738, -0.2906, % p_o3'_275_tfo + 0.0649, 0.4366, -0.8973, + 0.5521, -0.7648, -0.3322, + 1.6833, 6.8060, -7.0011}, + {0.3445, -0.7630, 0.5470, % p_o3'_180_tfo + -0.4628, -0.6450, -0.6082, + 0.8168, -0.0436, -0.5753, + -6.8179, -3.9778, -5.9887}, + {0.5855, 0.7931, -0.1682, % p_o3'_60_tfo + 0.8103, -0.5790, 0.0906, + -0.0255, -0.1894, -0.9816, + 6.1203, -7.1051, 3.1984}, + {2.6760, -8.4960, 3.2880}, % P + {1.4950, -7.6230, 3.4770}, % O1P + {2.9490, -9.4640, 4.3740}, % O2P + {3.9730, -7.5950, 3.0340}, % O5' + {5.2430, -8.2420, 2.8260}, % C5' + {5.1974, -8.8497, 1.9223}, % H5' + {5.5548, -8.7348, 3.7469}, % H5'' + {6.3140, -7.2060, 2.5510}, % C4' + {7.2954, -7.6762, 2.4898}, % H4' + {6.0140, -6.5420, 1.2890}, % O4' + {6.4190, -5.1840, 1.3620}, % C1' + {7.1608, -5.0495, 0.5747}, % H1' + {7.0760, -4.9560, 2.7270}, % C2' + {6.7770, -3.9803, 3.1099}, % H2'' + {8.4500, -5.1930, 2.5810}, % O2' + {8.8309, -4.8755, 1.7590}, % H2' + {6.4060, -6.0590, 3.5580}, % C3' + {5.4021, -5.7313, 3.8281}, % H3' + {7.1570, -6.4240, 4.7070}, % O3' + {5.2170, -4.3260, 1.1690}, % N1 + {4.2960, -2.2560, 0.6290}, % N3 + {5.4330, -3.0200, 0.7990}, % C2 + {2.9930, -2.6780, 0.7940}, % C4 + {2.8670, -4.0630, 1.1830}, % C5 + {3.9570, -4.8300, 1.3550}, % C6 + u, { + {6.5470, -2.5560, 0.6290}, % O2 + {2.0540, -1.9000, 0.6130}, % O4 + {4.4300, -1.3020, 0.3600}, % H3 + {1.9590, -4.4570, 1.3250}, % H5 + {3.8460, -5.7860, 1.6240}} % H6 + }. + +rU01() -> + { + {-0.0137, -0.8012, 0.5983, % dgf_base_tfo + -0.2523, 0.5817, 0.7733, + -0.9675, -0.1404, -0.2101, + 0.2031, 8.3874, 0.4228}, + {-0.8313, -0.4738, -0.2906, % p_o3'_275_tfo + 0.0649, 0.4366, -0.8973, + 0.5521, -0.7648, -0.3322, + 1.6833, 6.8060, -7.0011}, + {0.3445, -0.7630, 0.5470, % p_o3'_180_tfo + -0.4628, -0.6450, -0.6082, + 0.8168, -0.0436, -0.5753, + -6.8179, -3.9778, -5.9887}, + {0.5855, 0.7931, -0.1682, % p_o3'_60_tfo + 0.8103, -0.5790, 0.0906, + -0.0255, -0.1894, -0.9816, + 6.1203, -7.1051, 3.1984}, + {2.6760, -8.4960, 3.2880}, % P + {1.4950, -7.6230, 3.4770}, % O1P + {2.9490, -9.4640, 4.3740}, % O2P + {3.9730, -7.5950, 3.0340}, % O5' + {5.2416, -8.2422, 2.8181}, % C5' + {5.2050, -8.8128, 1.8901}, % H5' + {5.5368, -8.7738, 3.7227}, % H5'' + {6.3232, -7.2037, 2.6002}, % C4' + {7.3048, -7.6757, 2.5577}, % H4' + {6.0635, -6.5092, 1.3456}, % O4' + {6.4697, -5.1547, 1.4629}, % C1' + {7.2354, -5.0043, 0.7018}, % H1' + {7.0856, -4.9610, 2.8521}, % C2' + {6.7777, -3.9935, 3.2487}, % H2'' + {8.4627, -5.1992, 2.7423}, % O2' + {8.8693, -4.8638, 1.9399}, % H2' + {6.3877, -6.0809, 3.6362}, % C3' + {5.3770, -5.7562, 3.8834}, % H3' + {7.1024, -6.4754, 4.7985}, % O3' + {5.2764, -4.2883, 1.2538}, % N1 + {4.3777, -2.2062, 0.7229}, % N3 + {5.5069, -2.9779, 0.9088}, % C2 + {3.0693, -2.6246, 0.8500}, % C4 + {2.9279, -4.0146, 1.2149}, % C5 + {4.0101, -4.7892, 1.4017}, % C6 + u, { + {6.6267, -2.5166, 0.7728}, % O2 + {2.1383, -1.8396, 0.6581}, % O4 + {4.5223, -1.2489, 0.4716}, % H3 + {2.0151, -4.4065, 1.3290}, % H5 + {3.8886, -5.7486, 1.6535}} % H6 + }. + +rU02() -> + { + {0.5141, 0.0246, 0.8574, % dgf_base_tfo + -0.5547, -0.7529, 0.3542, + 0.6542, -0.6577, -0.3734, + -9.1111, -3.4598, -3.2939}, + {-0.8313, -0.4738, -0.2906, % p_o3'_275_tfo + 0.0649, 0.4366, -0.8973, + 0.5521, -0.7648, -0.3322, + 1.6833, 6.8060, -7.0011}, + {0.3445, -0.7630, 0.5470, % p_o3'_180_tfo + -0.4628, -0.6450, -0.6082, + 0.8168, -0.0436, -0.5753, + -6.8179, -3.9778, -5.9887}, + {0.5855, 0.7931, -0.1682, % p_o3'_60_tfo + 0.8103, -0.5790, 0.0906, + -0.0255, -0.1894, -0.9816, + 6.1203, -7.1051, 3.1984}, + {2.6760, -8.4960, 3.2880}, % P + {1.4950, -7.6230, 3.4770}, % O1P + {2.9490, -9.4640, 4.3740}, % O2P + {3.9730, -7.5950, 3.0340}, % O5' + {4.3825, -6.6585, 4.0489}, % C5' + {4.6841, -7.2019, 4.9443}, % H5' + {3.6189, -5.8889, 4.1625}, % H5'' + {5.6255, -5.9175, 3.5998}, % C4' + {5.8732, -5.1228, 4.3034}, % H4' + {6.7337, -6.8605, 3.5222}, % O4' + {7.5932, -6.4923, 2.4548}, % C1' + {8.5661, -6.2983, 2.9064}, % H1' + {7.0527, -5.2012, 1.8322}, % C2' + {7.1627, -5.2525, 0.7490}, % H2'' + {7.6666, -4.1249, 2.4880}, % O2' + {8.5944, -4.2543, 2.6981}, % H2' + {5.5661, -5.3029, 2.2009}, % C3' + {5.0841, -6.0018, 1.5172}, % H3' + {4.9062, -4.0452, 2.2042}, % O3' + {7.6298, -7.6136, 1.4752}, % N1 + {8.6945, -8.7046, -0.2857}, % N3 + {8.6943, -7.6514, 0.6066}, % C2 + {7.7426, -9.6987, -0.3801}, % C4 + {6.6642, -9.5742, 0.5722}, % C5 + {6.6391, -8.5592, 1.4526}, % C6 + u, { + {9.5840, -6.8186, 0.6136}, % O2 + {7.8505, -10.5925, -1.2223}, % O4 + {9.4601, -8.7514, -0.9277}, % H3 + {5.9281, -10.2509, 0.5782}, % H5 + {5.8831, -8.4931, 2.1028}} % H6 + }. + +rU03() -> + { + {-0.4993, 0.0476, 0.8651, % dgf_base_tfo + 0.8078, -0.3353, 0.4847, + 0.3132, 0.9409, 0.1290, + 6.2989, -5.2303, -3.8577}, + {-0.8313, -0.4738, -0.2906, % p_o3'_275_tfo + 0.0649, 0.4366, -0.8973, + 0.5521, -0.7648, -0.3322, + 1.6833, 6.8060, -7.0011}, + {0.3445, -0.7630, 0.5470, % p_o3'_180_tfo + -0.4628, -0.6450, -0.6082, + 0.8168, -0.0436, -0.5753, + -6.8179, -3.9778, -5.9887}, + {0.5855, 0.7931, -0.1682, % p_o3'_60_tfo + 0.8103, -0.5790, 0.0906, + -0.0255, -0.1894, -0.9816, + 6.1203, -7.1051, 3.1984}, + {2.6760, -8.4960, 3.2880}, % P + {1.4950, -7.6230, 3.4770}, % O1P + {2.9490, -9.4640, 4.3740}, % O2P + {3.9730, -7.5950, 3.0340}, % O5' + {3.9938, -6.7042, 1.9023}, % C5' + {3.2332, -5.9343, 2.0319}, % H5' + {3.9666, -7.2863, 0.9812}, % H5'' + {5.3098, -5.9546, 1.8564}, % C4' + {5.3863, -5.3702, 0.9395}, % H4' + {5.3851, -5.0642, 3.0076}, % O4' + {6.7315, -4.9724, 3.4462}, % C1' + {7.0033, -3.9202, 3.3619}, % H1' + {7.5997, -5.8018, 2.4948}, % C2' + {8.3627, -6.3254, 3.0707}, % H2'' + {8.0410, -4.9501, 1.4724}, % O2' + {8.2781, -4.0644, 1.7570}, % H2' + {6.5701, -6.8129, 1.9714}, % C3' + {6.4186, -7.5809, 2.7299}, % H3' + {6.9357, -7.3841, 0.7235}, % O3' + {6.8024, -5.4718, 4.8475}, % N1 + {7.9218, -5.5700, 6.8877}, % N3 + {7.8908, -5.0886, 5.5944}, % C2 + {6.9789, -6.3827, 7.4823}, % C4 + {5.8742, -6.7319, 6.6202}, % C5 + {5.8182, -6.2769, 5.3570}, % C6 + u, { + {8.7747, -4.3728, 5.1568}, % O2 + {7.1154, -6.7509, 8.6509}, % O4 + {8.7055, -5.3037, 7.4491}, % H3 + {5.1416, -7.3178, 6.9665}, % H5 + {5.0441, -6.5310, 4.7784}} % H6 + }. + +rU04() -> + { + {-0.5669, -0.8012, 0.1918, % dgf_base_tfo + -0.8129, 0.5817, 0.0273, + -0.1334, -0.1404, -0.9811, + -0.3279, 8.3874, 0.3355}, + {-0.8313, -0.4738, -0.2906, % p_o3'_275_tfo + 0.0649, 0.4366, -0.8973, + 0.5521, -0.7648, -0.3322, + 1.6833, 6.8060, -7.0011}, + {0.3445, -0.7630, 0.5470, % p_o3'_180_tfo + -0.4628, -0.6450, -0.6082, + 0.8168, -0.0436, -0.5753, + -6.8179, -3.9778, -5.9887}, + {0.5855, 0.7931, -0.1682, % p_o3'_60_tfo + 0.8103, -0.5790, 0.0906, + -0.0255, -0.1894, -0.9816, + 6.1203, -7.1051, 3.1984}, + {2.6760, -8.4960, 3.2880}, % P + {1.4950, -7.6230, 3.4770}, % O1P + {2.9490, -9.4640, 4.3740}, % O2P + {3.9730, -7.5950, 3.0340}, % O5' + {5.2416, -8.2422, 2.8181}, % C5' + {5.2050, -8.8128, 1.8901}, % H5' + {5.5368, -8.7738, 3.7227}, % H5'' + {6.3232, -7.2037, 2.6002}, % C4' + {7.3048, -7.6757, 2.5577}, % H4' + {6.0635, -6.5092, 1.3456}, % O4' + {6.4697, -5.1547, 1.4629}, % C1' + {7.2354, -5.0043, 0.7018}, % H1' + {7.0856, -4.9610, 2.8521}, % C2' + {6.7777, -3.9935, 3.2487}, % H2'' + {8.4627, -5.1992, 2.7423}, % O2' + {8.8693, -4.8638, 1.9399}, % H2' + {6.3877, -6.0809, 3.6362}, % C3' + {5.3770, -5.7562, 3.8834}, % H3' + {7.1024, -6.4754, 4.7985}, % O3' + {5.2764, -4.2883, 1.2538}, % N1 + {3.8961, -3.0896, -0.1893}, % N3 + {5.0095, -3.8907, -0.0346}, % C2 + {3.0480, -2.6632, 0.8116}, % C4 + {3.4093, -3.1310, 2.1292}, % C5 + {4.4878, -3.9124, 2.3088}, % C6 + u, { + {5.7005, -4.2164, -0.9842}, % O2 + {2.0800, -1.9458, 0.5503}, % O4 + {3.6834, -2.7882, -1.1190}, % H3 + {2.8508, -2.8721, 2.9172}, % H5 + {4.7188, -4.2247, 3.2295}} % H6 + }. + +rU05() -> + { + {-0.6298, 0.0246, 0.7763, % dgf_base_tfo + -0.5226, -0.7529, -0.4001, + 0.5746, -0.6577, 0.4870, + -0.0208, -3.4598, -9.6882}, + {-0.8313, -0.4738, -0.2906, % p_o3'_275_tfo + 0.0649, 0.4366, -0.8973, + 0.5521, -0.7648, -0.3322, + 1.6833, 6.8060, -7.0011}, + {0.3445, -0.7630, 0.5470, % p_o3'_180_tfo + -0.4628, -0.6450, -0.6082, + 0.8168, -0.0436, -0.5753, + -6.8179, -3.9778, -5.9887}, + {0.5855, 0.7931, -0.1682, % p_o3'_60_tfo + 0.8103, -0.5790, 0.0906, + -0.0255, -0.1894, -0.9816, + 6.1203, -7.1051, 3.1984}, + {2.6760, -8.4960, 3.2880}, % P + {1.4950, -7.6230, 3.4770}, % O1P + {2.9490, -9.4640, 4.3740}, % O2P + {3.9730, -7.5950, 3.0340}, % O5' + {4.3825, -6.6585, 4.0489}, % C5' + {4.6841, -7.2019, 4.9443}, % H5' + {3.6189, -5.8889, 4.1625}, % H5'' + {5.6255, -5.9175, 3.5998}, % C4' + {5.8732, -5.1228, 4.3034}, % H4' + {6.7337, -6.8605, 3.5222}, % O4' + {7.5932, -6.4923, 2.4548}, % C1' + {8.5661, -6.2983, 2.9064}, % H1' + {7.0527, -5.2012, 1.8322}, % C2' + {7.1627, -5.2525, 0.7490}, % H2'' + {7.6666, -4.1249, 2.4880}, % O2' + {8.5944, -4.2543, 2.6981}, % H2' + {5.5661, -5.3029, 2.2009}, % C3' + {5.0841, -6.0018, 1.5172}, % H3' + {4.9062, -4.0452, 2.2042}, % O3' + {7.6298, -7.6136, 1.4752}, % N1 + {8.5977, -9.5977, 0.7329}, % N3 + {8.5951, -8.5745, 1.6594}, % C2 + {7.7372, -9.7371, -0.3364}, % C4 + {6.7596, -8.6801, -0.4476}, % C5 + {6.7338, -7.6721, 0.4408}, % C6 + u, { + {9.3993, -8.5377, 2.5743}, % O2 + {7.8374, -10.6990, -1.1008}, % O4 + {9.2924, -10.3081, 0.8477}, % H3 + {6.0932, -8.6982, -1.1929}, % H5 + {6.0481, -6.9515, 0.3446}} % H6 + }. + +rU06() -> + { + {-0.9837, 0.0476, -0.1733, % dgf_base_tfo + -0.1792, -0.3353, 0.9249, + -0.0141, 0.9409, 0.3384, + 5.7793, -5.2303, 4.5997}, + {-0.8313, -0.4738, -0.2906, % p_o3'_275_tfo + 0.0649, 0.4366, -0.8973, + 0.5521, -0.7648, -0.3322, + 1.6833, 6.8060, -7.0011}, + {0.3445, -0.7630, 0.5470, % p_o3'_180_tfo + -0.4628, -0.6450, -0.6082, + 0.8168, -0.0436, -0.5753, + -6.8179, -3.9778, -5.9887}, + {0.5855, 0.7931, -0.1682, % p_o3'_60_tfo + 0.8103, -0.5790, 0.0906, + -0.0255, -0.1894, -0.9816, + 6.1203, -7.1051, 3.1984}, + {2.6760, -8.4960, 3.2880}, % P + {1.4950, -7.6230, 3.4770}, % O1P + {2.9490, -9.4640, 4.3740}, % O2P + {3.9730, -7.5950, 3.0340}, % O5' + {3.9938, -6.7042, 1.9023}, % C5' + {3.2332, -5.9343, 2.0319}, % H5' + {3.9666, -7.2863, 0.9812}, % H5'' + {5.3098, -5.9546, 1.8564}, % C4' + {5.3863, -5.3702, 0.9395}, % H4' + {5.3851, -5.0642, 3.0076}, % O4' + {6.7315, -4.9724, 3.4462}, % C1' + {7.0033, -3.9202, 3.3619}, % H1' + {7.5997, -5.8018, 2.4948}, % C2' + {8.3627, -6.3254, 3.0707}, % H2'' + {8.0410, -4.9501, 1.4724}, % O2' + {8.2781, -4.0644, 1.7570}, % H2' + {6.5701, -6.8129, 1.9714}, % C3' + {6.4186, -7.5809, 2.7299}, % H3' + {6.9357, -7.3841, 0.7235}, % O3' + {6.8024, -5.4718, 4.8475}, % N1 + {6.6920, -5.0495, 7.1354}, % N3 + {6.6201, -4.5500, 5.8506}, % C2 + {6.9254, -6.3614, 7.4926}, % C4 + {7.1046, -7.2543, 6.3718}, % C5 + {7.0391, -6.7951, 5.1106}, % C6 + u, { + {6.4083, -3.3696, 5.6340}, % O2 + {6.9679, -6.6901, 8.6800}, % O4 + {6.5626, -4.3957, 7.8812}, % H3 + {7.2781, -8.2254, 6.5350}, % H5 + {7.1657, -7.4312, 4.3503}} % H6 + }. + +rU07() -> + { + {-0.9434, 0.3172, 0.0971, % dgf_base_tfo + 0.2294, 0.4125, 0.8816, + 0.2396, 0.8539, -0.4619, + 8.3625, -52.7147, 1.3745}, + {0.2765, -0.1121, -0.9545, % p_o3'_275_tfo + -0.8297, 0.4733, -0.2959, + 0.4850, 0.8737, 0.0379, + -14.7774, -45.2464, 21.9088}, + {0.1063, -0.6334, -0.7665, % p_o3'_180_tfo + -0.5932, -0.6591, 0.4624, + -0.7980, 0.4055, -0.4458, + 43.7634, 4.3296, 28.4890}, + {0.7136, -0.5032, -0.4873, % p_o3'_60_tfo + 0.6803, 0.3317, 0.6536, + -0.1673, -0.7979, 0.5791, + -17.1858, 41.4390, -27.0751}, + {21.3880, 15.0780, 45.5770}, % P + {21.9980, 14.5500, 46.8210}, % O1P + {21.1450, 14.0270, 44.5420}, % O2P + {22.1250, 16.3600, 44.9460}, % O5' + {21.5037, 16.8594, 43.7323}, % C5' + {20.8147, 17.6663, 43.9823}, % H5' + {21.1086, 16.0230, 43.1557}, % H5'' + {22.5654, 17.4874, 42.8616}, % C4' + {22.1584, 17.7243, 41.8785}, % H4' + {23.0557, 18.6826, 43.4751}, % O4' + {24.4788, 18.6151, 43.6455}, % C1' + {24.9355, 19.0840, 42.7739}, % H1' + {24.7958, 17.1427, 43.6474}, % C2' + {24.5652, 16.7400, 44.6336}, % H2'' + {26.1041, 16.8773, 43.2455}, % O2' + {26.7516, 17.5328, 43.5149}, % H2' + {23.8109, 16.5979, 42.6377}, % C3' + {23.5756, 15.5686, 42.9084}, % H3' + {24.2890, 16.7447, 41.2729}, % O3' + {24.9420, 19.2174, 44.8923}, % N1 + {25.2655, 20.5636, 44.8883}, % N3 + {25.1663, 21.2219, 43.8561}, % C2 + {25.6911, 21.1219, 46.0494}, % C4 + {25.8051, 20.4068, 47.2048}, % C5 + {26.2093, 20.9962, 48.2534}, % C6 + u, { + {25.4692, 19.0221, 47.2053}, % O2 + {25.0502, 18.4827, 46.0370}, % O4 + {25.9599, 22.1772, 46.0966}, % H3 + {25.5545, 18.4409, 48.1234}, % H5 + {24.7854, 17.4265, 45.9883}} % H6 + }. + +rU08() -> + { + {-0.0080, -0.7928, 0.6094, % dgf_base_tfo + -0.7512, 0.4071, 0.5197, + -0.6601, -0.4536, -0.5988, + 44.1482, 30.7036, 2.1088}, + {0.2765, -0.1121, -0.9545, % p_o3'_275_tfo + -0.8297, 0.4733, -0.2959, + 0.4850, 0.8737, 0.0379, + -14.7774, -45.2464, 21.9088}, + {0.1063, -0.6334, -0.7665, % p_o3'_180_tfo + -0.5932, -0.6591, 0.4624, + -0.7980, 0.4055, -0.4458, + 43.7634, 4.3296, 28.4890}, + {0.7136, -0.5032, -0.4873, % p_o3'_60_tfo + 0.6803, 0.3317, 0.6536, + -0.1673, -0.7979, 0.5791, + -17.1858, 41.4390, -27.0751}, + {21.3880, 15.0780, 45.5770}, % P + {21.9980, 14.5500, 46.8210}, % O1P + {21.1450, 14.0270, 44.5420}, % O2P + {22.1250, 16.3600, 44.9460}, % O5' + {23.5096, 16.1227, 44.5783}, % C5' + {23.5649, 15.8588, 43.5222}, % H5' + {23.9621, 15.4341, 45.2919}, % H5'' + {24.2805, 17.4138, 44.7151}, % C4' + {25.3492, 17.2309, 44.6030}, % H4' + {23.8497, 18.3471, 43.7208}, % O4' + {23.4090, 19.5681, 44.3321}, % C1' + {24.2595, 20.2496, 44.3524}, % H1' + {23.0418, 19.1813, 45.7407}, % C2' + {22.0532, 18.7224, 45.7273}, % H2'' + {23.1307, 20.2521, 46.6291}, % O2' + {22.8888, 21.1051, 46.2611}, % H2' + {24.0799, 18.1326, 46.0700}, % C3' + {23.6490, 17.4370, 46.7900}, % H3' + {25.3329, 18.7227, 46.5109}, % O3' + {22.2515, 20.1624, 43.6698}, % N1 + {22.4760, 21.0609, 42.6406}, % N3 + {23.6229, 21.3462, 42.3061}, % C2 + {21.3986, 21.6081, 42.0236}, % C4 + {20.1189, 21.3012, 42.3804}, % C5 + {19.1599, 21.8516, 41.7578}, % C6 + u, { + {19.8919, 20.3745, 43.4387}, % O2 + {20.9790, 19.8423, 44.0440}, % O4 + {21.5235, 22.3222, 41.2097}, % H3 + {18.8732, 20.1200, 43.7312}, % H5 + {20.8545, 19.1313, 44.8608}} % H6 + }. + +rU09() -> + { + {-0.0317, 0.1374, 0.9900, % dgf_base_tfo + -0.3422, -0.9321, 0.1184, + 0.9391, -0.3351, 0.0765, + -32.1929, 25.8198, -28.5088}, + {0.2765, -0.1121, -0.9545, % p_o3'_275_tfo + -0.8297, 0.4733, -0.2959, + 0.4850, 0.8737, 0.0379, + -14.7774, -45.2464, 21.9088}, + {0.1063, -0.6334, -0.7665, % p_o3'_180_tfo + -0.5932, -0.6591, 0.4624, + -0.7980, 0.4055, -0.4458, + 43.7634, 4.3296, 28.4890}, + {0.7136, -0.5032, -0.4873, % p_o3'_60_tfo + 0.6803, 0.3317, 0.6536, + -0.1673, -0.7979, 0.5791, + -17.1858, 41.4390, -27.0751}, + {21.3880, 15.0780, 45.5770}, % P + {21.9980, 14.5500, 46.8210}, % O1P + {21.1450, 14.0270, 44.5420}, % O2P + {22.1250, 16.3600, 44.9460}, % O5' + {21.5037, 16.8594, 43.7323}, % C5' + {20.8147, 17.6663, 43.9823}, % H5' + {21.1086, 16.0230, 43.1557}, % H5'' + {22.5654, 17.4874, 42.8616}, % C4' + {23.0565, 18.3036, 43.3915}, % H4' + {23.5375, 16.5054, 42.4925}, % O4' + {23.6574, 16.4257, 41.0649}, % C1' + {24.4701, 17.0882, 40.7671}, % H1' + {22.3525, 16.9643, 40.5396}, % C2' + {21.5993, 16.1799, 40.6133}, % H2'' + {22.4693, 17.4849, 39.2515}, % O2' + {23.0899, 17.0235, 38.6827}, % H2' + {22.0341, 18.0633, 41.5279}, % C3' + {20.9509, 18.1709, 41.5846}, % H3' + {22.7249, 19.3020, 41.2100}, % O3' + {23.8580, 15.0648, 40.5757}, % N1 + {25.1556, 14.5982, 40.4523}, % N3 + {26.1047, 15.3210, 40.7448}, % C2 + {25.3391, 13.3315, 40.0020}, % C4 + {24.2974, 12.5148, 39.6749}, % C5 + {24.5450, 11.3410, 39.2610}, % C6 + u, { + {22.9633, 12.9979, 39.8053}, % O2 + {22.8009, 14.2648, 40.2524}, % O4 + {26.3414, 12.9194, 39.8855}, % H3 + {22.1227, 12.3533, 39.5486}, % H5 + {21.7989, 14.6788, 40.3650}} % H6 + }. + +rU10() -> + { + {-0.9674, 0.1021, -0.2318, % dgf_base_tfo + -0.2514, -0.2766, 0.9275, + 0.0306, 0.9555, 0.2933, + 27.8571, -42.1305, -24.4563}, + {0.2765, -0.1121, -0.9545, % p_o3'_275_tfo + -0.8297, 0.4733, -0.2959, + 0.4850, 0.8737, 0.0379, + -14.7774, -45.2464, 21.9088}, + {0.1063, -0.6334, -0.7665, % p_o3'_180_tfo + -0.5932, -0.6591, 0.4624, + -0.7980, 0.4055, -0.4458, + 43.7634, 4.3296, 28.4890}, + {0.7136, -0.5032, -0.4873, % p_o3'_60_tfo + 0.6803, 0.3317, 0.6536, + -0.1673, -0.7979, 0.5791, + -17.1858, 41.4390, -27.0751}, + {21.3880, 15.0780, 45.5770}, % P + {21.9980, 14.5500, 46.8210}, % O1P + {21.1450, 14.0270, 44.5420}, % O2P + {22.1250, 16.3600, 44.9460}, % O5' + {23.5096, 16.1227, 44.5783}, % C5' + {23.5649, 15.8588, 43.5222}, % H5' + {23.9621, 15.4341, 45.2919}, % H5'' + {24.2805, 17.4138, 44.7151}, % C4' + {23.8509, 18.1819, 44.0720}, % H4' + {24.2506, 17.8583, 46.0741}, % O4' + {25.5830, 18.0320, 46.5775}, % C1' + {25.8569, 19.0761, 46.4256}, % H1' + {26.4410, 17.1555, 45.7033}, % C2' + {26.3459, 16.1253, 46.0462}, % H2'' + {27.7649, 17.5888, 45.6478}, % O2' + {28.1004, 17.9719, 46.4616}, % H2' + {25.7796, 17.2997, 44.3513}, % C3' + {25.9478, 16.3824, 43.7871}, % H3' + {26.2154, 18.4984, 43.6541}, % O3' + {25.7321, 17.6281, 47.9726}, % N1 + {25.5136, 18.5779, 48.9560}, % N3 + {25.2079, 19.7276, 48.6503}, % C2 + {25.6482, 18.1987, 50.2518}, % C4 + {25.9847, 16.9266, 50.6092}, % C5 + {26.0918, 16.6439, 51.8416}, % C6 + u, { + {26.2067, 15.9515, 49.5943}, % O2 + {26.0713, 16.3497, 48.3080}, % O4 + {25.4890, 18.9105, 51.0618}, % H3 + {26.4742, 14.9310, 49.8682}, % H5 + {26.2346, 15.6394, 47.4975}} % H6 + }. + +rUs() -> [rU01(),rU02(),rU03(),rU04(),rU05(),rU06(),rU07(), + rU08(),rU09(),rU10()]. + +rG_() -> + { + {-0.2067, -0.0264, 0.9780, % dgf_base_tfo + 0.9770, -0.0586, 0.2049, + 0.0519, 0.9979, 0.0379, + 1.0331, -46.8078, -36.4742}, + {-0.8644, -0.4956, -0.0851, % p_o3'_275_tfo + -0.0427, 0.2409, -0.9696, + 0.5010, -0.8345, -0.2294, + 4.0167, 54.5377, 12.4779}, + {0.3706, -0.6167, 0.6945, % p_o3'_180_tfo + -0.2867, -0.7872, -0.5460, + 0.8834, 0.0032, -0.4686, + -52.9020, 18.6313, -0.6709}, + {0.4155, 0.9025, -0.1137, % p_o3'_60_tfo + 0.9040, -0.4236, -0.0582, + -0.1007, -0.0786, -0.9918, + -7.6624, -25.2080, 49.5181}, + {31.3810, 0.1400, 47.5810}, % P + {29.9860, 0.6630, 47.6290}, % O1P + {31.7210, -0.6460, 48.8090}, % O2P + {32.4940, 1.2540, 47.2740}, % O5' + {32.1610, 2.2370, 46.2560}, % C5' + {31.2986, 2.8190, 46.5812}, % H5' + {32.0980, 1.7468, 45.2845}, % H5'' + {33.3476, 3.1959, 46.1947}, % C4' + {33.2668, 3.8958, 45.3630}, % H4' + {33.3799, 3.9183, 47.4216}, % O4' + {34.6515, 3.7222, 48.0398}, % C1' + {35.2947, 4.5412, 47.7180}, % H1' + {35.1756, 2.4228, 47.4827}, % C2' + {34.6778, 1.5937, 47.9856}, % H2'' + {36.5631, 2.2672, 47.4798}, % O2' + {37.0163, 2.6579, 48.2305}, % H2' + {34.6953, 2.5043, 46.0448}, % C3' + {34.5444, 1.4917, 45.6706}, % H3' + {35.6679, 3.3009, 45.3487}, % O3' + {37.4804, 4.0914, 52.2559}, % N1 + {36.9670, 4.1312, 49.9281}, % N3 + {37.8045, 4.2519, 50.9550}, % C2 + {35.7171, 3.8264, 50.3222}, % C4 + {35.2668, 3.6420, 51.6115}, % C5 + {36.2037, 3.7829, 52.6706}, % C6 + g, { + {39.0869, 4.5552, 50.7092}, % N2 + {33.9075, 3.3338, 51.6102}, % N7 + {34.6126, 3.6358, 49.5108}, % N9 + {33.5805, 3.3442, 50.3425}, % C8 + {35.9958, 3.6512, 53.8724}, % O6 + {38.2106, 4.2053, 52.9295}, % H1 + {39.8218, 4.6863, 51.3896}, % H21 + {39.3420, 4.6857, 49.7407}, % H22 + {32.5194, 3.1070, 50.2664}} % H8 + }. + +rU_() -> + { + {-0.0109, 0.5907, 0.8068, % dgf_base_tfo + 0.2217, -0.7853, 0.5780, + 0.9751, 0.1852, -0.1224, + -1.4225, -11.0956, -2.5217}, + {-0.8313, -0.4738, -0.2906, % p_o3'_275_tfo + 0.0649, 0.4366, -0.8973, + 0.5521, -0.7648, -0.3322, + 1.6833, 6.8060, -7.0011}, + {0.3445, -0.7630, 0.5470, % p_o3'_180_tfo + -0.4628, -0.6450, -0.6082, + 0.8168, -0.0436, -0.5753, + -6.8179, -3.9778, -5.9887}, + {0.5855, 0.7931, -0.1682, % p_o3'_60_tfo + 0.8103, -0.5790, 0.0906, + -0.0255, -0.1894, -0.9816, + 6.1203, -7.1051, 3.1984}, + {2.6760, -8.4960, 3.2880}, % P + {1.4950, -7.6230, 3.4770}, % O1P + {2.9490, -9.4640, 4.3740}, % O2P + {3.9730, -7.5950, 3.0340}, % O5' + {5.2430, -8.2420, 2.8260}, % C5' + {5.1974, -8.8497, 1.9223}, % H5' + {5.5548, -8.7348, 3.7469}, % H5'' + {6.3140, -7.2060, 2.5510}, % C4' + {5.8744, -6.2116, 2.4731}, % H4' + {7.2798, -7.2260, 3.6420}, % O4' + {8.5733, -6.9410, 3.1329}, % C1' + {8.9047, -6.0374, 3.6446}, % H1' + {8.4429, -6.6596, 1.6327}, % C2' + {9.2880, -7.1071, 1.1096}, % H2'' + {8.2502, -5.2799, 1.4754}, % O2' + {8.7676, -4.7284, 2.0667}, % H2' + {7.1642, -7.4416, 1.3021}, % C3' + {7.4125, -8.5002, 1.2260}, % H3' + {6.5160, -6.9772, 0.1267}, % O3' + {9.4531, -8.1107, 3.4087}, % N1 + {11.5931, -9.0015, 3.6357}, % N3 + {10.8101, -7.8950, 3.3748}, % C2 + {11.1439, -10.2744, 3.9206}, % C4 + {9.7056, -10.4026, 3.9332}, % C5 + {8.9192, -9.3419, 3.6833}, % C6 + u, { + {11.3013, -6.8063, 3.1326}, % O2 + {11.9431, -11.1876, 4.1375}, % O4 + {12.5840, -8.8673, 3.6158}, % H3 + {9.2891, -11.2898, 4.1313}, % H5 + {7.9263, -9.4537, 3.6977}} % H6 + }. + + +% -- PARTIAL INSTANTIATIONS -------------------------------------------------- + +%var ::= {Int, Tfo, Nuc} + +absolute_pos({_I,T,_N}, P) -> tfo_apply(T, P). + +atom_pos(Atom, {I,T,N}) -> + absolute_pos({I,T,N}, p_apply(Atom, N)). + +get_var(Id,[{Id,T,N}|_]) -> {Id,T,N}; +get_var(Id,[_|Lst]) -> get_var(Id,Lst). + + +% -- SEARCH ------------------------------------------------------------------ + +% Sequential backtracking algorithm + +search(Partial_inst,[],_) -> + [Partial_inst]; +search(Partial_inst,[{F,Arg0,Arg1}|T],Constraint) -> + try_assignments(p_apply(F, Arg0,Arg1,Partial_inst), + Constraint, + Partial_inst, + T); +search(Partial_inst,[{F,Arg0,Arg1,Arg2}|T],Constraint) -> + try_assignments(p_apply(F, Arg0,Arg1,Arg2,Partial_inst), + Constraint, + Partial_inst, + T). + +try_assignments([],_,_,_) -> []; +try_assignments([V|Vs], Constraint, Partial_inst,T) -> + case p_apply(Constraint, V, Partial_inst) of + true -> append(search([V|Partial_inst],T,Constraint), + try_assignments(Vs, Constraint, Partial_inst,T)); + _ -> try_assignments(Vs, Constraint, Partial_inst,T) + end. + + +% -- DOMAINS ----------------------------------------------------------------- + +% Primary structure: strand A CUGCCACGUCUG, strand B CAGACGUGGCAG +% +% Secondary structure: strand A CUGCCACGUCUG +% |||||| +% GACGGUGCAGAC strand B +% +% Tertiary structure: +% +% 5' end of strand A C1----G12 3' end of strand B +% U2-------A11 +% G3-------C10 +% C4-----G9 +% C5---G8 +% A6 +% G6-C7 +% C5----G8 +% A4-------U9 +% G3--------C10 +% A2-------U11 +% 5' end of strand B C1----G12 3' end of strand A +% +% "helix", "stacked" and "connected" describe the spatial relationship +% between two consecutive nucleotides. E.g. the nucleotides C1 and U2 +% from the strand A. +% +% "wc" (stands for Watson-Crick and is a type of base-pairing), +% and "wc-dumas" describe the spatial relationship between +% nucleotides from two chains that are growing in opposite directions. +% E.g. the nucleotides C1 from strand A and G12 from strand B. + +% Dynamic Domains + +% Given, +% "ref" a nucleotide which is already positioned, +% "nuc" the nucleotide to be placed, +% and "tfo" a transformation matrix which expresses the desired +% relationship between "ref" and "nuc", +% the function "dgf-base" computes the transformation matrix that +% places the nucleotide "nuc" in the given relationship to "ref". + +dgf_base(Tfo, V, Nuc) -> + {_I,_T,N} = V, + tfo_combine(nuc_dgf_base_tfo(Nuc), + tfo_combine(Tfo,tfo_inv_ortho(process_type(type(N),V)))). + +process_type(a,V) -> + tfo_align(atom_pos(nuc_C1_, V),atom_pos(rA_N9, V),atom_pos(nuc_C4, V)); +process_type(c,V) -> + tfo_align(atom_pos(nuc_C1_, V),atom_pos(nuc_N1, V),atom_pos(nuc_C2, V)); +process_type(g,V) -> + tfo_align(atom_pos(nuc_C1_, V),atom_pos(rG_N9, V),atom_pos(nuc_C4, V)); +process_type(_,V) -> + tfo_align(atom_pos(nuc_C1_, V),atom_pos(nuc_N1, V),atom_pos(nuc_C2, V)). + + +% Placement of first nucleotide. + +reference(Nuc,I,_) -> + [{I,tfo_id(),Nuc}]. + +% The transformation matrix for wc is from: +% +% Chandrasekaran R. et al (1989) A Re-Examination of the Crystal +% Structure of A-DNA Using Fiber Diffraction Data. J. Biomol. +% Struct. & Dynamics 6(6):1189-1202. + +wc_tfo() -> + { + -1.0000, 0.0028, -0.0019, + 0.0028, 0.3468, -0.9379, + -0.0019, -0.9379, -0.3468, + -0.0080, 6.0730, 8.7208 + }. + +wc(Nuc,I,J,Partial_inst) -> + [{I,dgf_base(wc_tfo(),get_var(J,Partial_inst),Nuc),Nuc}]. + +wc_dumas_tfo() -> + { + -0.9737, -0.1834, 0.1352, + -0.1779, 0.2417, -0.9539, + 0.1422, -0.9529, -0.2679, + 0.4837, 6.2649, 8.0285 + }. + +wc_dumas(Nuc,I,J,Partial_inst) -> + [{I,dgf_base(wc_dumas_tfo(),get_var(J,Partial_inst),Nuc),Nuc}]. + +helix5__tfo() -> + { + 0.9886, -0.0961, 0.1156, + 0.1424, 0.8452, -0.5152, + -0.0482, 0.5258, 0.8492, + -3.8737, 0.5480, 3.8024 + }. + +helix5_(Nuc,I,J,Partial_inst) -> + [{I,dgf_base(helix5__tfo(),get_var(J,Partial_inst),Nuc),Nuc}]. + +helix3__tfo() -> + { + 0.9886, 0.1424, -0.0482, + -0.0961, 0.8452, 0.5258, + 0.1156, -0.5152, 0.8492, + 3.4426, 2.0474, -3.7042 + }. + +helix3_(Nuc,I,J,Partial_inst) -> + [{I,dgf_base(helix3__tfo(),get_var(J,Partial_inst),Nuc),Nuc}]. + +g37_a38_tfo() -> + { + 0.9991, 0.0164, -0.0387, + -0.0375, 0.7616, -0.6470, + 0.0189, 0.6478, 0.7615, + -3.3018, 0.9975, 2.5585 + }. + +g37_a38(Nuc,I,J,Partial_inst) -> + {I,dgf_base(g37_a38_tfo(),get_var(J,Partial_inst),Nuc),Nuc}. + +stacked5_(Nuc,I,J,Partial_inst) -> + [g37_a38(Nuc,I,J,Partial_inst) | helix5_(Nuc,I,J,Partial_inst)]. + +a38_g37_tfo() -> + { + 0.9991, -0.0375, 0.0189, + 0.0164, 0.7616, 0.6478, + -0.0387, -0.6470, 0.7615, + 3.3819, 0.7718, -2.5321 + }. + +a38_g37(Nuc,I,J,Partial_inst) -> + {I,dgf_base(a38_g37_tfo(),get_var(J,Partial_inst),Nuc),Nuc}. + +stacked3_(Nuc,I,J,Partial_inst) -> + [a38_g37(Nuc,I,J,Partial_inst) | helix3_(Nuc,I,J,Partial_inst)]. + +p_o3_(Nucs,I,J,Partial_inst) -> + generate([],Nucs,I,J,Partial_inst). + + +generate(Domains,[],_,_,_) -> + Domains; +generate(Domains,[N|Ns],I,J,Partial_inst) -> + Ref = get_var(J,Partial_inst), + Align = tfo_inv_ortho(tfo_align(atom_pos(nuc_O3_,Ref), + atom_pos(nuc_C3_,Ref), + atom_pos(nuc_C4_,Ref))), + generate([{I,tfo_combine(nuc_p_o3__60_tfo(N),Align),N}, + {I,tfo_combine(nuc_p_o3__180_tfo(N),Align),N}, + {I,tfo_combine(nuc_p_o3__275_tfo(N),Align),N} | Domains], + Ns,I,J,Partial_inst). + + +% -- PROBLEM STATEMENT ------------------------------------------------------- + +% Define anticodon problem -- Science 253:1255 Figure 3a, 3b and 3c + +% anticodon_domains() -> +% [ +% {reference, rC(), 27}, +% {helix5_, rC(), 28, 27}, +% {helix5_, rA(), 29, 28}, +% {helix5_, rG(), 30, 29}, +% {helix5_, rA(), 31, 30}, +% {wc, rU(), 39, 31}, +% {helix5_, rC(), 40, 39}, +% {helix5_, rU(), 41, 40}, +% {helix5_, rG(), 42, 41}, +% {helix5_, rG(), 43, 42}, +% {stacked3_, rA(), 38, 39}, +% {stacked3_, rG(), 37, 38}, +% {stacked3_, rA(), 36, 37}, +% {stacked3_, rA(), 35, 36}, +% {stacked3_, rG(), 34, 35}, %<-. Distance +% {p_o3_, rCs(), 32, 31}, % | Constraint +% {p_o3_, rUs(), 33, 32} %<-' 3.0 Angstroms +% ]. + +% Anticodon constraint + +anticodon_constraint({33,T,N},Partial_inst) -> + check0(dist(34,{33,T,N},Partial_inst)); +anticodon_constraint(_,_) -> true. + +check0(Dist) when is_float(Dist), Dist =< 3.0 -> true; +check0(_) -> false. + +dist(J,V,Partial_inst) -> + pt_dist(atom_pos(nuc_P, get_var(J,Partial_inst)), + atom_pos(nuc_O3_,V)). + +% anticodon() -> search([], anticodon_domains(), anticodon_constraint). + +% Define pseudoknot problem -- Science 253:1255 Figure 4a and 4b +pseudoknot_domains() -> + [ + {reference, rA(), 23}, + {wc_dumas, rU(), 8, 23}, + {helix3_, rG(), 22, 23}, + {wc_dumas, rC(), 9, 22}, + {helix3_, rG(), 21, 22}, + {wc_dumas, rC(), 10, 21}, + {helix3_, rC(), 20, 21}, + {wc_dumas, rG(), 11, 20}, + {helix3_, rU_(), 19, 20}, %<-. + {wc_dumas, rA(), 12, 19}, % | Distance +% % | Constraint +% Helix 1 % | 4.0 Angstroms + {helix3_, rC(), 3, 19}, % | + {wc_dumas, rG(), 13, 3}, % | + {helix3_, rC(), 2, 3}, % | + {wc_dumas, rG(), 14, 2}, % | + {helix3_, rC(), 1, 2}, % | + {wc_dumas, rG_(), 15, 1}, % | +% % | +% L2 LOOP % | + {p_o3_, rUs(), 16, 15}, % | + {p_o3_, rCs(), 17, 16}, % | + {p_o3_, rAs(), 18, 17}, %<-' +% +% L1 LOOP + {helix3_, rU(), 7, 8}, %<-. + {p_o3_, rCs(), 4, 3}, % | Constraint + {stacked5_, rU(), 5, 4}, % | 4.5 Angstroms + {stacked5_, rC(), 6, 5} %<-' + ]. + +% Pseudoknot constraint + +pseudoknot_constraint({18,T,N}, Partial_inst) -> + check1(dist(19, {18,T,N}, Partial_inst)); +pseudoknot_constraint({6,T,N}, Partial_inst) -> + check2(dist(7, {6,T,N}, Partial_inst)); +pseudoknot_constraint(_,_) -> true. + +check1(Dist) when is_float(Dist), Dist =< 4.0 -> true; +check1(_) -> false. + +check2(Dist) when is_float(Dist), Dist =< 4.5 -> true; +check2(_) -> false. + +do_pseudoknot() -> search([], pseudoknot_domains(), pseudoknot_constraint). + +% -- TESTING ----------------------------------------------------------------- + +list_of_atoms(N) -> + append(list_of_common_atoms(N),list_of_specific_atoms(N)). + +list_of_common_atoms + ({ + _,_,_,_, + P,O1p,O2p,O5_,C5_,H5_,H5__,C4_,H4_,O4_,C1_,H1_,C2_,H2__,O2_,H2_, + C3_,H3_,O3_,N1,N3,C2,C4,C5,C6, + _,_ + }) -> + [P,O1p,O2p,O5_,C5_,H5_,H5__,C4_,H4_,O4_,C1_,H1_,C2_,H2__,O2_,H2_, + C3_,H3_,O3_,N1,N3,C2,C4,C5,C6]. + +list_of_specific_atoms({_,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,a, + {N6,N7,N9,C8,H2,H61,H62,H8}}) -> + [N6,N7,N9,C8,H2,H61,H62,H8]; +list_of_specific_atoms({_,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,c, + {N4,O2,H41,H42,H5,H6}}) -> + [N4,O2,H41,H42,H5,H6]; +list_of_specific_atoms({_,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,g, + {N2,N7,N9,C8,O6,H1,H21,H22,H8}}) -> + [N2,N7,N9,C8,O6,H1,H21,H22,H8]; +list_of_specific_atoms({_,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,_, + _,_,_,_,_,_,_,_,_,u, + {O2,O4,H3,H5,H6}}) -> + [O2,O4,H3,H5,H6]. + +var_most_distant_atom(V) -> + {_,_,N} = V, + maximum(map(distance,V,list_of_atoms(N))). + +distance(V,P) -> + {X,Y,Z} = absolute_pos(V,P), + distance(X,Y,Z). + +distance(X,Y,Z) when is_float(X), is_float(Y), is_float(Z) -> + math:sqrt(X * X + Y * Y + Z * Z). + +sol_most_distant_atom(S) -> + maximum(map(var_most_distant_atom,S)). + +most_distant_atom(Sols) -> + maximum(map(sol_most_distant_atom, Sols)). + +maximum([H|T]) -> + max(T,H). + +max([H|T],M) when is_float(H), is_float(M), H > M -> + max(T,H); +max([_|T],M) -> + max(T,M); +max([],M) -> M. + +%% +%% The map/2,3 functions rewritten to use a list comprehension, +%% just to cover the letrec handling in the inliner. +%% +map(Func, L) -> + [p_apply(Func, H) || H <- L]. + +map(Func, Arg, L) -> + [p_apply(Func, Arg, H) || H <- L]. + +% p_apply implements higher order functions +p_apply(sol_most_distant_atom, S) -> sol_most_distant_atom(S); +p_apply(var_most_distant_atom, V) -> var_most_distant_atom(V); +p_apply(nuc_C1_, X) -> nuc_C1_(X); +p_apply(nuc_C2, X) -> nuc_C2(X); +p_apply(nuc_C3_, X) -> nuc_C3_(X); +p_apply(nuc_C4, X) -> nuc_C4(X); +p_apply(nuc_C4_, X) -> nuc_C4_(X); +p_apply(nuc_N1, X) -> nuc_N1(X); +p_apply(nuc_O3_, X) -> nuc_O3_(X); +p_apply(nuc_P, X) -> nuc_P(X); +p_apply(nuc_dgf_base_tfo, X) -> nuc_dgf_base_tfo(X); +p_apply(nuc_p_o3__180_tfo, X) -> nuc_p_o3__180_tfo(X); +p_apply(nuc_p_o3__275_tfo, X) -> nuc_p_o3__275_tfo(X); +p_apply(nuc_p_o3__60_tfo, X) -> nuc_p_o3__60_tfo(X); +p_apply(rA_N9, X) -> rA_N9(X); +p_apply(rG_N9, X) -> rG_N9(X). + +p_apply(anticodon_constraint, V, P) -> anticodon_constraint(V, P); +p_apply(pseudoknot_constraint, V, P) -> pseudoknot_constraint(V, P); +p_apply(distance, V, P) -> distance(V, P). + +p_apply(reference, A1, A2, A3) -> reference(A1, A2, A3). + +p_apply(helix5_, A1, A2, A3, A4) -> helix5_(A1, A2, A3, A4); +p_apply(wc, A1, A2, A3, A4) -> wc(A1, A2, A3, A4); +p_apply(stacked3_, A1, A2, A3, A4) -> stacked3_(A1, A2, A3, A4); +p_apply(p_o3_, A1, A2, A3, A4) -> p_o3_(A1, A2, A3, A4); +p_apply(wc_dumas, A1, A2, A3, A4) -> wc_dumas(A1, A2, A3, A4); +p_apply(helix3_, A1, A2, A3, A4) -> helix3_(A1, A2, A3, A4); +p_apply(stacked5_, A1, A2, A3, A4) -> stacked5_(A1, A2, A3, A4). + +loop(0, R) -> R; +loop(N, _R) -> loop(N-1,most_distant_atom(do_pseudoknot())). diff --git a/lib/compiler/test/inline_SUITE_data/smith.erl b/lib/compiler/test/inline_SUITE_data/smith.erl new file mode 100644 index 0000000000..6aec7ad295 --- /dev/null +++ b/lib/compiler/test/inline_SUITE_data/smith.erl @@ -0,0 +1,95 @@ +% file: "smith.erl" + +-ifdef(ETOS). +-define(IS_INTEGER(X),is_integer(X)). +-else. +-define(IS_INTEGER(X),integer(X)). +-endif. + +-module(smith). +-export([?MODULE/0]). + +?MODULE() -> + Tops = generate_sequences(100,32,1), + Side = generate_sequence(32,0), + statistics(runtime), + R = loop(2,Tops,Side,0), + {R,R =:= 16}. + +max(A,B) when ?IS_INTEGER(A), ?IS_INTEGER(B) -> + if + A > B -> A; + true -> B + end. + +alpha_beta_penalty(A,B) when ?IS_INTEGER(A), ?IS_INTEGER(B) -> max(A-4,B-1). + +generate_sequence(Length,R) when ?IS_INTEGER(Length) -> + if + Length == 0 -> []; + true -> [R rem 10 | generate_sequence(Length-1, + (R * 11 + 1237501) + rem 10067)] + end. + +generate_sequences(0,_,_) -> []; +generate_sequences(N,Length,R) when ?IS_INTEGER(N), ?IS_INTEGER(Length) -> + [generate_sequence(Length, R) | generate_sequences(N-1,Length,R+1)]. + +match_entry(Top,Side,UpperLeft,Upper,Left) when ?IS_INTEGER(Top), ?IS_INTEGER(Side) -> + MeLeft = alpha_beta_penalty(element(3, Left), element(1, Left)), + MeUpper = alpha_beta_penalty(element(3, Upper), element(2, Upper)), + MeUpperLeft = + if + Top == Side -> + max(MeLeft, + max(MeUpper, + max(element(3,UpperLeft)+1,0))); + true -> + max(MeLeft, + max(MeUpper, + max(element(3,UpperLeft),0))) + end, + {MeLeft, MeUpper, MeUpperLeft, + max(MeUpperLeft, + max(element(4,Left), + max(element(4,Upper),element(4,UpperLeft))))}. + +match_zero_entry(Top,Side,{Left,_,UpperLeft,Max}) when ?IS_INTEGER(Top), ?IS_INTEGER(Side) -> + ELeft = alpha_beta_penalty(UpperLeft, Left), + Weight = max(1-abs(Side-Top),0), + EUpperLeft = max(max(ELeft,max(1-abs(Side-Top),0)),0), + EMax = max(max(Max,EUpperLeft),0), + {ELeft, -1, EUpperLeft, EMax}. + +match(Tops,Side,Prev,UpperLeft,Left) -> + match0(Tops, Side, Prev, UpperLeft, Left, [], none). + +match0([],_,_,_,_,Acc,Last) -> {Acc,Last}; +match0([Top|Tops],Side,[Upper|Prev],UpperLeft,Left,Acc,Last) when + ?IS_INTEGER(Top), ?IS_INTEGER(Side) -> + E = match_entry(Top, Side, UpperLeft, Upper, Left), + match0(Tops, Side, Prev, Upper, E, [E|Acc], E); +match0([Top|Tops],Side,none,UpperLeft,Left,Acc,Last) when + ?IS_INTEGER(Top), ?IS_INTEGER(Side) -> + E = match_zero_entry(Top, Side, Left), + match0(Tops, Side, none, UpperLeft, E, [E|Acc], E). + +match_two_seq(Side,Top,Prev) -> + match_two_seq0(Side, Top, Prev, none). + +match_two_seq0([],_,_,Result) -> Result; +match_two_seq0([S|Side],Top,Prev,Acc) when ?IS_INTEGER(S) -> + {Row,Result} = match(Top,S,Prev,{0,0,0,0},{0,0,0,0}), + match_two_seq0(Side, Top, Row, Result). + +match_sequences(Tops,Side) -> + match_sequences0(Tops, Side, -9999999). + +match_sequences0([],_,MaxResult) -> MaxResult; +match_sequences0([Top|Tops],Side,CrntResult) -> + Result = element(4, match_two_seq(Top, Side, none)), + match_sequences0(Tops, Side, max(CrntResult, Result)). + +loop(0,Tops,Side,R) -> R; +loop(N,Tops,Side,R) -> loop(N-1,Tops,Side,match_sequences(Tops,Side)). diff --git a/lib/compiler/test/lc_SUITE.erl b/lib/compiler/test/lc_SUITE.erl new file mode 100644 index 0000000000..e62b2cd77e --- /dev/null +++ b/lib/compiler/test/lc_SUITE.erl @@ -0,0 +1,162 @@ +%% +%% %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% +%% +-module(lc_SUITE). + +-author('[email protected]'). +-export([all/1,init_per_testcase/2,fin_per_testcase/2, + basic/1,deeply_nested/1,no_generator/1, + empty_generator/1]). + +-include("test_server.hrl"). + +all(suite) -> + test_lib:recompile(?MODULE), + [basic,deeply_nested,no_generator,empty_generator]. + +init_per_testcase(Case, Config) when is_atom(Case), is_list(Config) -> + Dog = test_server:timetrap(?t:minutes(1)), + [{watchdog,Dog}|Config]. + +fin_per_testcase(Case, Config) when is_atom(Case), is_list(Config) -> + Dog = ?config(watchdog, Config), + ?t:timetrap_cancel(Dog), + ok. + +basic(Config) when is_list(Config) -> + ?line L0 = lists:seq(1, 10), + ?line L1 = my_map(fun(X) -> {x,X} end, L0), + ?line L1 = [{x,X} || X <- L0], + ?line L0 = my_map(fun({x,X}) -> X end, L1), + ?line [1,2,3,4,5] = [X || X <- L0, X < 6], + ?line [4,5,6] = [X || X <- L0, X > 3, X < 7], + ?line [] = [X || X <- L0, X > 32, X < 7], + ?line [1,3,5,7,9] = [X || X <- L0, odd(X)], + ?line [2,4,6,8,10] = [X || X <- L0, not odd(X)], + ?line [1,3,5,9] = [X || X <- L0, odd(X), X =/= 7], + ?line [2,4,8,10] = [X || X <- L0, not odd(X), X =/= 6], + + %% Append is specially handled. + ?line [1,3,5,9,2,4,8,10] = [X || X <- L0, odd(X), X =/= 7] ++ + [X || X <- L0, not odd(X), X =/= 6], + + %% Guards BIFs are evaluated in guard context. Weird, but true. + ?line [{a,b,true},{x,y,true,true}] = [X || X <- tuple_list(), element(3, X)], + + %% Filter expressions with andalso/orelse. + ?line "abc123" = alphanum("?abc123.;"), + + %% Error cases. + ?line [] = [{xx,X} || X <- L0, element(2, X) == no_no_no], + ?line {'EXIT',_} = (catch [X || X <- L1, list_to_atom(X) == dum]), + ?line [] = [X || X <- L1, X+1 < 2], + ?line {'EXIT',_} = (catch [X || X <- L1, odd(X)]), + ?line {'EXIT',{function_clause,[{?MODULE,_,[x]}|_]}} = + (catch [E || E <- id(x)]), + ok. + +tuple_list() -> + [{a,b,true},[a,b,c],glurf,{a,b,false,xx},{a,b},{x,y,true,true},{a,b,d,ddd}]. + +my_map(F, L) -> + [F(X) || X <- L]. + +odd(X) -> + X rem 2 == 1. + +alphanum(Str) -> + [C || C <- Str, ((C >= $0) andalso (C =< $9)) + orelse ((C >= $a) andalso (C =< $z)) + orelse ((C >= $A) andalso (C =< $Z))]. + +deeply_nested(Config) when is_list(Config) -> + [[99,98,97,96,42,17,1764,12,11,10,9,8,7,6,5,4,3,7,2,1]] = deeply_nested_1(), + ok. + +deeply_nested_1() -> + %% This used to compile really, really SLOW before R11B-1... + [[X1,X2,X3,X4,X5,X6,X7(),X8,X9,X10,X11,X12,X13,X14,X15,X16,X17,X18(),X19,X20] || + X1 <- [99],X2 <- [98],X3 <- [97],X4 <- [96],X5 <- [42],X6 <- [17], + X7 <- [fun() -> X5*X5 end],X8 <- [12],X9 <- [11],X10 <- [10], + X11 <- [9],X12 <- [8],X13 <- [7],X14 <- [6],X15 <- [5], + X16 <- [4],X17 <- [3],X18 <- [fun() -> X16+X17 end],X19 <- [2],X20 <- [1]]. + +no_generator(Config) when is_list(Config) -> + ?line Seq = lists:seq(-10, 17), + ?line [no_gen_verify(no_gen(A, B), A, B) || A <- Seq, B <- Seq], + + %% Literal expression, for coverage. + ?line [a] = [a || true], + ?line [a,b,c] = [a || true] ++ [b,c], + ok. + +no_gen(A, B) -> + [{A,B} || A+B =:= 0] ++ + [{A,B} || A*B =:= 0] ++ + [{A,B} || A rem B =:= 3] ++ + [{A,B} || A =:= B] ++ + [{one_more,A,B} || no_gen_one_more(A, B)] ++ + [A || A =:= 1] ++ + [A || A =:= 2] ++ + [A || A =:= 3] ++ + [A || A =:= 4] ++ + [A || A =:= 5] ++ + [A || A =:= 6] ++ + [A || A =:= 7] ++ + [A || A =:= 8] ++ + [A || A =:= 9] ++ + [B || B =:= 1] ++ + [B || B =:= 2] ++ + [B || B =:= 3] ++ + [B || B =:= 4] ++ + [B || B =:= 5] ++ + [B || B =:= 6] ++ + [B || B =:= 7] ++ + [B || B =:= 8] ++ + [B || B =:= 9]. + +no_gen_verify(Res, A, B) -> + Pair = {A,B}, + ShouldBe = no_gen_eval(fun() -> A+B =:= 0 end, Pair) ++ + no_gen_eval(fun() -> A*B =:= 0 end, Pair) ++ + no_gen_eval(fun() -> B =/= 0 andalso A rem B =:= 3 end, Pair) ++ + no_gen_eval(fun() -> A =:= B end, Pair) ++ + no_gen_eval(fun() -> A + 1 =:= B end, {one_more,A,B}) ++ + no_gen_eval(fun() -> 1 =< A andalso A =< 9 end, A) ++ + no_gen_eval(fun() -> 1 =< B andalso B =< 9 end, B), + case Res of + ShouldBe -> ok; + _ -> + io:format("A = ~p; B = ~p; Expected = ~p, actual = ~p", [A,B,ShouldBe,Res]), + ?t:fail() + end. + +no_gen_eval(Fun, Res) -> + case Fun() of + true -> [Res]; + false -> [] + end. + +no_gen_one_more(A, B) -> A + 1 =:= B. + +empty_generator(Config) when is_list(Config) -> + ?line [] = [X || {X} <- [], (false or (X/0 > 3))], + ok. + +id(I) -> I. + diff --git a/lib/compiler/test/match_SUITE.erl b/lib/compiler/test/match_SUITE.erl new file mode 100644 index 0000000000..20969c0b26 --- /dev/null +++ b/lib/compiler/test/match_SUITE.erl @@ -0,0 +1,355 @@ +%% +%% %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(match_SUITE). + +-export([all/1, + pmatch/1,mixed/1,aliases/1,match_in_call/1, + untuplify/1,shortcut_boolean/1,letify_guard/1, + selectify/1]). + +-include("test_server.hrl"). + +all(suite) -> + test_lib:recompile(?MODULE), + [pmatch,mixed,aliases,match_in_call,untuplify,shortcut_boolean, + letify_guard,selectify]. + +pmatch(Config) when is_list(Config) -> + ?line ok = doit(1), + ?line ok = doit(2), + ?line {error,baz} = doit(3), + ?line {error,foobar} = doit(4), + ok. + +%% Thanks to Tobias Lindahl (HiPE). +-define(FOO(X), + case X of + 1 -> foo; + 2 -> bar; + 3 -> baz; + 4 -> foobar + end). + +doit(X) -> + case ?FOO(X) of + foo -> ok; + bar -> ok; + Other -> {error, Other} + end. + +mixed(Config) when is_list(Config) -> + ?line glufs = mixit(1), + ?line klafs = mixit(2), + ?line fnurra = mixit(3), + ?line usch = mixit(4), + ?line {error,blurf} = mixit(5), + ?line {error,87987987} = mixit(6), + ?line {error,{a,b,c}} = mixit(7), + ok. + +mixit(X) -> + case case X of + 1 -> a; + 2 -> b; + 3 -> 42; + 4 -> 77; + 5 -> blurf; + 6 -> 87987987; + 7 -> {a,b,c} + end of + a -> glufs; + b -> klafs; + 42 -> fnurra; + 77 -> usch; + Other -> {error,Other} + end. + +aliases(Config) when is_list(Config) -> + %% Lists/strings. + ?line ok = str_alias("abc"), + ?line ok = str_alias("def"), + ?line ok = str_alias("ghi"), + ?line ok = str_alias("klm"), + ?line ok = str_alias("qrs"), + ?line ok = str_alias("xy"), + ?line ok = str_alias(""), + ?line ok = str_alias([]), + ?line error = str_alias("blurf"), + + %% Characters/integers. + ?line ok = char_alias($v), + ?line ok = char_alias(118), + ?line ok = char_alias($w), + ?line ok = char_alias(119), + ?line ok = char_alias(42), + ?line ok = char_alias(3.0), + ?line error = char_alias($_), + ?line error = char_alias(0), + + ?line {42,42,42} = three(42), + + ?line {1,42,99,1,42,99} = tuple_alias({1,42,99}), + ?line {-10,20,-10,20,-10,20} = tuple_alias({-10,20}), + ?line 6 = tup_lit_alias({1,2,3}), + ?line 6 = tup_lit_alias_rev({1,2,3}), + + ?line {42,42,42,42} = multiple_aliases_1(42), + ?line {7,7,7} = multiple_aliases_2(7), + ?line {{a,b},{a,b},{a,b}} = multiple_aliases_3({a,b}), + ok. + +str_alias(V) -> + Res = str_alias_1(V), + Res = str_alias_2(V). + +str_alias_1([$a,$b,$c]="abc"="a"++[$b,$c]=[97,98,99]) -> ok; +str_alias_1([$d|"ef"]="def") -> ok; +str_alias_1([$g|"hi"]="g"++"hi"="gh"++"i"="ghi"++"") -> ok; +str_alias_1("k"++"lm"=[$k|"lm"]) -> ok; +str_alias_1([113,114,115]="qrs"=[$q,$r,$s]="q"++"r"++"s") -> ok; +str_alias_1([$x,$y]="xy") -> ok; +str_alias_1(""=[]) -> ok; +str_alias_1(_) -> error. + +%% Make sure that different line numbers do not matter. + +str_alias_2([$a,$b,$c]= + "abc"= + "a"++[$b,$c + ]= + [97,98,99 + ]) -> ok; +str_alias_2([$d|"ef"]= + "def") -> ok; +str_alias_2([$g|"hi"]= + "g"++"hi"= + "gh"++"i"= + "ghi"++"") -> ok; +str_alias_2("k"++"lm"= + [$k|"lm" + ]) -> ok; +str_alias_2([113,114,115]= + "qrs"=[$q,$r,$s + ]= + "q"++"r"++"s") -> ok; +str_alias_2([$x,$y]= + "xy") -> ok; +str_alias_2(""= + []) -> ok; +str_alias_2(_) -> error. + +char_alias(V) -> + Res = char_alias_1(V), + Res = char_alias_2(V). + +char_alias_1(118=$v) -> ok; +char_alias_1($w=119) -> ok; +char_alias_1(42=42) -> ok; +char_alias_1(3.0=3.0) -> ok; +char_alias_1(_) -> error. + +char_alias_2(118= + $v) -> ok; +char_alias_2($w= + 119) -> ok; +char_alias_2(42= + 42) -> ok; +char_alias_2(3.0= + 3.0) -> ok; +char_alias_2(_) -> error. + +three(V) -> + Res = three_1(V), + Res = three_2(V). + +three_1(A=B=C) -> + {A,B,C}. + +three_2(A= + B= + C) -> + {A,B,C}. + +tuple_alias({A,B,C}={X,Y,Z}) -> + {A,B,C,X,Y,Z}; +tuple_alias({A,B}={C,D}={E,F}) -> + {A,B,C,D,E,F}. + +tup_lit_alias({A,B,C}={1,2,3}) -> + A+B+C. + +tup_lit_alias_rev({1,2,3}={A,B,C}) -> + A+B+C. + +multiple_aliases_1((A=B)=(C=D)) -> + {A,B,C,D}. + +multiple_aliases_2((A=B)=(A=C)) -> + {A,B,C}. + +multiple_aliases_3((A={_,_}=B)={_,_}=C) -> + {A,B,C}. + +%% OTP-7018. + +match_in_call(Config) when is_list(Config) -> + ?line mac_a(0), + ?line mac_b(1), + ?line mac_c(42), + ?line mac_d(42), + ?line mac_e({gurka,42}), + + ?line [{2,2},{2,2}] = mac_lc([{2,any},{2,2}]), + ?line {'EXIT',_} = (catch mac_lc([{1,1}])), + + ok. + +mac_a(X) -> + id(_Gurka = {gurka,X}), + ok. + +mac_b(X) -> + id(Gurka = {gurka,X}), + gurka(Gurka, X), + ok. + +mac_c(X) -> + id(Gurka = Yxa = {gurka,X}), + id({Gurka,Yxa}), + ok. + +mac_d(X) -> + id({gurka,42} = {gurka,X}), + ok. + +mac_e(X) -> + id({gurka,42} = X), + ok. + +mac_lc(E) -> + Res = mac_lc1(E), + Res = mac_lc2(E). + +mac_lc1(E) -> + [{X,Y} || + {X,_} <- E, + (Y = X) =:= (Y = 1 + 1)]. + +mac_lc2(E) -> + [{X,Y} || + {X,_} <- E, + (Y = X) =:= (Y = 2)]. + +gurka({gurka,X}, X) -> ok. + + +untuplify(Config) when is_list(Config) -> + %% We do this to cover sys_core_fold:unalias_pat/1. + ?line {1,2,3,4,alias,{[1,2],{3,4},alias}} = untuplify_1([1,2], {3,4}, alias), + ?line error = untuplify_1([1,2], {3,4}, 42), + ok. + +untuplify_1(A, B, C) -> + case {A,B,C} of + {[X,Y],{Z,W},alias=Alias}=Top -> + {X,Y,Z,W,Alias,Top}; + [_,_]=CantMatch -> + CantMatch; + _ -> + error + end. + +%% Coverage of beam_dead:shortcut_boolean_label/4. +shortcut_boolean(Config) when is_list(Config) -> + ?line false = shortcut_boolean_1([0]), + ?line true = shortcut_boolean_1({42}), + ?line maybe = shortcut_boolean_1(self()), + ?line {'EXIT',_} = (catch shortcut_boolean_1([a,b])), + ?line {'EXIT',_} = (catch shortcut_boolean_1({a,b})), + ok. + +shortcut_boolean_1(X) -> + Outer = case not is_pid(X) of + true -> + V = case X of + [_] -> true; + {_} -> false + end, + not V; + false -> + maybe + end, + id(Outer). + + +%% Test sys_core_fold:letify_guard/3. +letify_guard(Config) when is_list(Config) -> + ?line {-15,a} = letify_guard(-15, a), + ?line 5 = letify_guard(2, 3), + ok. + +letify_guard(A, B) -> + case {A,B} of + %% The tuple will be built in the guard... + Z when tuple_size(Z) =:= 2, element(1, Z) < 0 -> + %% ... and again here. + Z; + {X,Y} -> X+Y + end. + +%% Test combining of is_eq_exact instructions to select_val +%% instructions in beam_dead and beam_peep. + +selectify(Config) when is_list(Config) -> + ?line integer = sel_different_types({r,42}), + ?line atom = sel_different_types({r,forty_two}), + ?line none = sel_different_types({r,18}), + ?line {'EXIT',_} = (catch sel_different_types([a,b,c])), + + ?line integer = sel_same_value({r,42}), + ?line error = sel_same_value({r,100}), + ?line error = sel_same_value(a), + + ?line integer42 = sel_same_value2(42), + ?line integer43 = sel_same_value2(43), + ?line error = sel_same_value2(44), + ok. + +sel_different_types({r,_}=T) when element(2, T) =:= forty_two -> + atom; +sel_different_types({r,_}=T) when element(2, T) =:= 42 -> + integer; +sel_different_types({r,_}) -> + none. + +sel_same_value({r,V}) when V =:= 42 -> + integer; +sel_same_value({r,V}) when V =:= 42 -> + integer42; +sel_same_value(_) -> + error. + +sel_same_value2(V) when V =:= 42 -> + integer42; +sel_same_value2(V) when V =:= 42; V =:= 43 -> + integer43; +sel_same_value2(_) -> + error. + +id(I) -> I. diff --git a/lib/compiler/test/misc_SUITE.erl b/lib/compiler/test/misc_SUITE.erl new file mode 100644 index 0000000000..e096571d50 --- /dev/null +++ b/lib/compiler/test/misc_SUITE.erl @@ -0,0 +1,241 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2006-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(misc_SUITE). + +-export([all/1,init_per_testcase/2,fin_per_testcase/2, + tobias/1,empty_string/1,md5/1,silly_coverage/1, + confused_literals/1,integer_encoding/1]). + +-include("test_server.hrl"). + +init_per_testcase(Case, Config) when is_atom(Case), is_list(Config) -> + Dog = test_server:timetrap(?t:minutes(10)), + [{watchdog,Dog}|Config]. + +fin_per_testcase(Case, Config) when is_atom(Case), is_list(Config) -> + Dog = ?config(watchdog, Config), + ?t:timetrap_cancel(Dog), + ok. + +all(suite) -> + test_lib:recompile(?MODULE), + [tobias,empty_string,md5,silly_coverage,confused_literals, + integer_encoding]. + +%% A bug reported by Tobias Lindahl for a development version of R11B. + +tobias(Config) when is_list(Config) -> + ?line 1 = tobias_1([1,2,3]), + ok. + +tobias_1([H|_T]) -> + %% In an R11B compiler, the move optimizer in beam_block would + %% confuse H and _T. + tobias_2(0, 0), + H. + +tobias_2(_, _) -> + 2. + + +%% A bug reported by Richard Carlsson. Used to crash beam_asm +%% because of a put_string instruction with an empty string. +%% The real problem was in sys_core_fold (empty strings should +%% be replaced by []). + +-record(r, {s = ""}). + +empty_string(Config) when is_list(Config) -> + ?line #r{s="x"} = empty_string_1(#r{}), + ok. + +empty_string_1(T) -> + case T of + #r{s = ""} -> T #r{s = "x"} + end. + +md5(Config) when is_list(Config) -> + case ?MODULE of + misc_SUITE -> md5(); + _ -> {skip,"Enough to run this case once."} + end. + +md5() -> + ?line Dir = filename:dirname(code:which(?MODULE)), + ?line Beams = filelib:wildcard(filename:join(Dir, "*.beam")), + ?line io:format("Found ~w beam files", [length(Beams)]), + ?line lists:foreach(fun md5_1/1, Beams). + +md5_1(Beam) -> + ?line {ok,{Mod,[Vsn]}} = beam_lib:version(Beam), + ?line {ok,Code} = file:read_file(Beam), + ?line {Mod,<<Vsn:128>>} = {Mod,code:module_md5(Code)}. + +%% Cover some code that handles internal errors. + +silly_coverage(Config) when is_list(Config) -> + %% sys_core_fold, sys_core_setel, v3_kernel + BadCoreErlang = {c_module,[], + name,exports,attrs, + [{{c_var,[],{foo,2}},seriously_bad_body}]}, + ?line expect_error(fun() -> sys_core_fold:module(BadCoreErlang, []) end), + ?line expect_error(fun() -> sys_core_dsetel:module(BadCoreErlang, []) end), + ?line expect_error(fun() -> v3_kernel:module(BadCoreErlang, []) end), + + %% v3_codgen + CodegenInput = {?MODULE,[{foo,0}],[],[{function,foo,0,[a|b],a,b}]}, + ?line expect_error(fun() -> v3_codegen:module(CodegenInput, []) end), + + %% beam_block + BlockInput = {?MODULE,[{foo,0}],[], + [{function,foo,0,2, + [{label,1}, + {func_info,{atom,?MODULE},{atom,foo},0}, + {label,2}|non_proper_list],99}]}, + ?line expect_error(fun() -> beam_block:module(BlockInput, []) end), + + %% beam_bool + BoolInput = {?MODULE,[{foo,0}],[], + [{function,foo,0,2, + [{label,1}, + {func_info,{atom,?MODULE},{atom,foo},0}, + {label,2}|non_proper_list]}],99}, + ?line expect_error(fun() -> beam_bool:module(BoolInput, []) end), + + %% beam_dead + DeadInput = {?MODULE,[{foo,0}],[], + [{function,foo,0,2, + [{label,1}, + {func_info,{atom,?MODULE},{atom,foo},0}, + {label,2}, + {jump,bad}]}],99}, + ?line expect_error(fun() -> beam_block:module(DeadInput, []) end), + + %% beam_clean + CleanInput = {?MODULE,[{foo,0}],[], + [{function,foo,0,2, + [{label,1}, + {func_info,{atom,?MODULE},{atom,foo},0}, + {label,2}, + {jump,{f,42}}]}],99}, + ?line expect_error(fun() -> beam_clean:module(CleanInput, []) end), + + %% beam_peep + PeepInput = {?MODULE,[{foo,0}],[], + [{function,foo,0,2, + [{label,1}, + {func_info,{atom,?MODULE},{atom,foo},0}, + {label,2}|non_proper_list]}],99}, + ?line expect_error(fun() -> beam_peep:module(PeepInput, []) end), + + %% beam_bsm. This is tricky. Our function must be sane enough to not crash + %% btb_index/1, but must crash the main optimization pass. + BsmInput = {?MODULE,[{foo,0}],[], + [{function,foo,0,2, + [{label,1}, + {func_info,{atom,?MODULE},{atom,foo},0}, + {label,2}, + {test,bs_get_binary2,{f,99},0,[{x,0},{atom,all},1,[]],{x,0}}, + {block,[a|b]}]}],0}, + ?line expect_error(fun() -> beam_bsm:module(BsmInput, []) end), + ok. + +expect_error(Fun) -> + try Fun() of + Any -> + io:format("~p", [Any]), + ?t:fail(call_was_supposed_to_fail) + catch + _:_ -> + io:format("~p\n", [erlang:get_stacktrace()]) + end. + +confused_literals(Config) when is_list(Config) -> + ?line {0,infinity} = confused_literals_1(int), + ?line {0.0,infinity} = confused_literals_1(float), + ok. + +confused_literals_1(int) -> {0,infinity}; +confused_literals_1(float) -> {0.0,infinity}. + +integer_encoding(Config) when is_list(Config) -> + case ?MODULE of + misc_SUITE -> integer_encoding_1(Config); + _ -> {skip,"Enough to run this case once."} + end. + +integer_encoding_1(Config) -> + Dog = test_server:timetrap(?t:minutes(4)), + ?line PrivDir = ?config(priv_dir, Config), + ?line SrcFile = filename:join(PrivDir, "misc_SUITE_integer_encoding.erl"), + ?line DataFile = filename:join(PrivDir, "integer_encoding.data"), + Mod = misc_SUITE_integer_encoding, + + %% Create files. + ?line {ok,Src} = file:open(SrcFile, [write]), + ?line {ok,Data} = file:open(DataFile, [write]), + io:format(Src, "-module(~s).\n", [Mod]), + io:put_chars(Src, "-export([t/1]).\n"), + io:put_chars(Src, "t(Last) ->[\n"), + io:put_chars(Data, "[\n"), + + ?line do_integer_encoding(-(id(1) bsl 10000), Src, Data), + ?line do_integer_encoding(id(1) bsl 10000, Src, Data), + ?line do_integer_encoding(2048, 0, Src, Data), + + io:put_chars(Src, "Last].\n\n"), + ?line ok = file:close(Src), + io:put_chars(Data, "0].\n\n"), + ?line ok = file:close(Data), + + %% Compile and load Erlang module. + ?line SrcRoot = filename:rootname(SrcFile), + ?line {ok,Mod,Binary} = compile:file(SrcRoot, [binary,report]), + ?line {module,Mod} = code:load_binary(Mod, SrcRoot, Binary), + + %% Compare lists. + ?line List = Mod:t(0), + ?line {ok,[List]} = file:consult(DataFile), + OneBsl10000 = id(1) bsl 10000, + ?line [-(1 bsl 10000),OneBsl10000|_] = List, + + %% Cleanup. + ?line file:delete(SrcFile), + ?line file:delete(DataFile), + ?t:timetrap_cancel(Dog), + ok. + +do_integer_encoding(0, _, _, _) -> ok; +do_integer_encoding(N, I0, Src, Data) -> + I1 = (I0 bsl 5) bor (random:uniform(32) - 1), + do_integer_encoding(I1, Src, Data), + I2 = -(I1 bxor (random:uniform(32) - 1)), + do_integer_encoding(I2, Src, Data), + do_integer_encoding(N-1, I1, Src, Data). + +do_integer_encoding(I, Src, Data) -> + Str = integer_to_list(I), + io:put_chars(Src, Str), + io:put_chars(Src, ", \n"), + io:put_chars(Data, Str), + io:put_chars(Data, ", \n"). + + +id(I) -> I. + diff --git a/lib/compiler/test/nested_call_in_case.core b/lib/compiler/test/nested_call_in_case.core new file mode 100644 index 0000000000..5c6b6909bd --- /dev/null +++ b/lib/compiler/test/nested_call_in_case.core @@ -0,0 +1,21 @@ +module 'nested_call_in_case' ['a'/2] + attributes [] + +'a'/2 = + fun (_x,_y) -> + case call 'erlang':'>' + (call 'erlang':'length' + (_x), _y) of + <'true'> when 'true' -> + 'yes' + <'false'> when 'true' -> + 'no' + ( <_omega> when 'true' -> + primop 'match_fail' + ('if_clause') + -| ['compiler_generated'] ) + end +end + + + diff --git a/lib/compiler/test/num_bif_SUITE.erl b/lib/compiler/test/num_bif_SUITE.erl new file mode 100644 index 0000000000..c246f56611 --- /dev/null +++ b/lib/compiler/test/num_bif_SUITE.erl @@ -0,0 +1,265 @@ +%% +%% %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(num_bif_SUITE). + +-include("test_server.hrl"). + +%% Tests optimization of the BIFs: +%% abs/1 +%% float/1 +%% float_to_list/1 +%% integer_to_list/1 +%% list_to_float/1 +%% list_to_integer/1 +%% round/1 +%% trunc/1 + +-export([all/1, t_abs/1, t_float/1, + t_float_to_list/1, t_integer_to_list/1, + t_list_to_integer/1, + t_list_to_float/1, t_list_to_float_safe/1, t_list_to_float_risky/1, + t_round/1, t_trunc/1]). + +all(suite) -> + test_lib:recompile(?MODULE), + [t_abs, t_float, t_float_to_list, t_integer_to_list, + t_list_to_float, t_list_to_integer, + t_round, t_trunc]. + +t_abs(Config) when is_list(Config) -> + %% Floats. + ?line 5.5 = abs(5.5), + ?line 0.0 = abs(0.0), + ?line 100.0 = abs(-100.0), + + %% Integers. + ?line 5 = abs(5), + ?line 0 = abs(0), + ?line 100 = abs(-100), + + %% The largest smallnum. OTP-3190. + ?line X = (1 bsl 27) - 1, + ?line X = abs(X), + ?line X = abs(X-1)+1, + ?line X = abs(X+1)-1, + ?line X = abs(-X), + ?line X = abs(-X-1)-1, + ?line X = abs(-X+1)+1, + + %% Bignums. + BigNum = 13984792374983749, + ?line BigNum = abs(BigNum), + ?line BigNum = abs(-BigNum), + ok. + +t_float(Config) when is_list(Config) -> + ?line 0.0 = float(0), + ?line 2.5 = float(2.5), + ?line 0.0 = float(0.0), + ?line -100.55 = float(-100.55), + ?line 42.0 = float(42), + ?line -100.0 = float(-100), + + %% Bignums. + ?line 4294967305.0 = float(4294967305), + ?line -4294967305.0 = float(-4294967305), + + %% Extremly big bignums. + ?line Big = list_to_integer(lists:duplicate(2000, $1)), + ?line {'EXIT', {badarg, _}} = (catch float(Big)), + + %% Invalid types and lists. + ?line {'EXIT', {badarg, _}} = (catch list_to_integer(atom)), + ?line {'EXIT', {badarg, _}} = (catch list_to_integer(123)), + ?line {'EXIT', {badarg, _}} = (catch list_to_integer([$1, [$2]])), + ?line {'EXIT', {badarg, _}} = (catch list_to_integer("1.2")), + ?line {'EXIT', {badarg, _}} = (catch list_to_integer("a")), + ?line {'EXIT', {badarg, _}} = (catch list_to_integer("")), + ok. + + +%% Tests float_to_list/1. + +t_float_to_list(Config) when is_list(Config) -> + ?line test_ftl("0.0e+0", 0.0), + ?line test_ftl("2.5e+1", 25.0), + ?line test_ftl("2.5e+0", 2.5), + ?line test_ftl("2.5e-1", 0.25), + ?line test_ftl("-3.5e+17", -350.0e15), + ok. + +test_ftl(Expect, Float) -> + %% No ?line on the next line -- we want the line number from t_float_to_list. + Expect = remove_zeros(lists:reverse(float_to_list(Float)), []). + +%% Removes any non-significant zeros in a floating point number. +%% Example: 2.500000e+01 -> 2.5e+1 + +remove_zeros([$+, $e|Rest], [$0, X|Result]) -> + remove_zeros([$+, $e|Rest], [X|Result]); +remove_zeros([$-, $e|Rest], [$0, X|Result]) -> + remove_zeros([$-, $e|Rest], [X|Result]); +remove_zeros([$0, $.|Rest], [$e|Result]) -> + remove_zeros(Rest, [$., $0, $e|Result]); +remove_zeros([$0|Rest], [$e|Result]) -> + remove_zeros(Rest, [$e|Result]); +remove_zeros([Char|Rest], Result) -> + remove_zeros(Rest, [Char|Result]); +remove_zeros([], Result) -> + Result. + +%% Tests integer_to_list/1. + +t_integer_to_list(Config) when is_list(Config) -> + ?line "0" = integer_to_list(0), + ?line "42" = integer_to_list(42), + ?line "-42" = integer_to_list(-42), + ?line "-42" = integer_to_list(-42), + ?line "32768" = integer_to_list(32768), + ?line "268435455" = integer_to_list(268435455), + ?line "-268435455" = integer_to_list(-268435455), + ?line "123456932798748738738" = integer_to_list(123456932798748738738), + ?line Big_List = lists:duplicate(2000, $1), + ?line Big = list_to_integer(Big_List), + ?line Big_List = integer_to_list(Big), + ok. + +%% Tests list_to_float/1. + +t_list_to_float(suite) -> [t_list_to_float_safe, t_list_to_float_risky]. + +t_list_to_float_safe(Config) when is_list(Config) -> + ?line 0.0 = list_to_float("0.0"), + ?line 0.0 = list_to_float("-0.0"), + ?line 0.5 = list_to_float("0.5"), + ?line -0.5 = list_to_float("-0.5"), + ?line 100.0 = list_to_float("1.0e2"), + ?line 127.5 = list_to_float("127.5"), + ?line -199.5 = list_to_float("-199.5"), + + ?line {'EXIT', {badarg, _}} = (catch list_to_float("0")), + ?line {'EXIT', {badarg, _}} = (catch list_to_float("0..0")), + ?line {'EXIT', {badarg, _}} = (catch list_to_float("0e12")), + ?line {'EXIT', {badarg, _}} = (catch list_to_float("--0.0")), +%% ?line {'EXIT', {badarg, _}} = (catch list_to_float("0.0e+99999999")), + + ok. + +%% This might crash the emulator... +%% (Known to crash the Unix version of Erlang 4.4.1) + +t_list_to_float_risky(Config) when is_list(Config) -> + ?line Many_Ones = lists:duplicate(25000, $1), + ?line list_to_float("2."++Many_Ones), + ?line {'EXIT', {badarg, _}} = (catch list_to_float("2"++Many_Ones)), + ok. + +%% Tests list_to_integer/1. + +t_list_to_integer(Config) when is_list(Config) -> + ?line 0 = list_to_integer("0"), + ?line 0 = list_to_integer("00"), + ?line 0 = list_to_integer("-0"), + ?line 1 = list_to_integer("1"), + ?line -1 = list_to_integer("-1"), + ?line 42 = list_to_integer("42"), + ?line -12 = list_to_integer("-12"), + ?line 32768 = list_to_integer("32768"), + ?line 268435455 = list_to_integer("268435455"), + ?line -268435455 = list_to_integer("-268435455"), + + %% Bignums. + ?line 123456932798748738738 = list_to_integer("123456932798748738738"), + ?line list_to_integer(lists:duplicate(2000, $1)), + ok. + +%% Tests round/1. + +t_round(Config) when is_list(Config) -> + ?line 0 = round(0.0), + ?line 0 = round(0.4), + ?line 1 = round(0.5), + ?line 0 = round(-0.4), + ?line -1 = round(-0.5), + ?line 255 = round(255.3), + ?line 256 = round(255.6), + ?line -1033 = round(-1033.3), + ?line -1034 = round(-1033.6), + + % OTP-3722: + ?line X = (1 bsl 27) - 1, + ?line MX = -X, + ?line MXm1 = -X-1, + ?line MXp1 = -X+1, + ?line F = X + 0.0, + ?line X = round(F), + ?line X = round(F+1)-1, + ?line X = round(F-1)+1, + ?line MX = round(-F), + ?line MXm1 = round(-F-1), + ?line MXp1 = round(-F+1), + + ?line X = round(F+0.1), + ?line X = round(F+1+0.1)-1, + ?line X = round(F-1+0.1)+1, + ?line MX = round(-F+0.1), + ?line MXm1 = round(-F-1+0.1), + ?line MXp1 = round(-F+1+0.1), + + ?line X = round(F-0.1), + ?line X = round(F+1-0.1)-1, + ?line X = round(F-1-0.1)+1, + ?line MX = round(-F-0.1), + ?line MXm1 = round(-F-1-0.1), + ?line MXp1 = round(-F+1-0.1), + + ?line 0.5 = abs(round(F+0.5)-(F+0.5)), + ?line 0.5 = abs(round(F-0.5)-(F-0.5)), + ?line 0.5 = abs(round(-F-0.5)-(-F-0.5)), + ?line 0.5 = abs(round(-F+0.5)-(-F+0.5)), + + %% Bignums. + ?line 4294967296 = round(4294967296.1), + ?line 4294967297 = round(4294967296.9), + ?line -4294967296 = -round(4294967296.1), + ?line -4294967297 = -round(4294967296.9), + ok. + +t_trunc(Config) when is_list(Config) -> + ?line 0 = trunc(0.0), + ?line 5 = trunc(5.3333), + ?line -10 = trunc(-10.978987), + % The largest smallnum, converted to float (OTP-3722): + ?line X = (1 bsl 27) - 1, + ?line F = X + 0.0, + io:format("X = ~p/~w/~w, F = ~p/~w/~w, trunc(F) = ~p/~w/~w~n", + [X, X, binary_to_list(term_to_binary(X)), + F, F, binary_to_list(term_to_binary(F)), + trunc(F), trunc(F), binary_to_list(term_to_binary(trunc(F)))]), + ?line X = trunc(F), + ?line X = trunc(F+1)-1, + ?line X = trunc(F-1)+1, + ?line X = -trunc(-F), + ?line X = -trunc(-F-1)-1, + ?line X = -trunc(-F+1)+1, + + %% Bignums. + ?line 4294967305 = trunc(4294967305.7), + ?line -4294967305 = trunc(-4294967305.7), + ok. diff --git a/lib/compiler/test/parteval_SUITE.erl b/lib/compiler/test/parteval_SUITE.erl new file mode 100644 index 0000000000..3ef84571b9 --- /dev/null +++ b/lib/compiler/test/parteval_SUITE.erl @@ -0,0 +1,46 @@ +%% +%% %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% +%% +-module(parteval_SUITE). + +-include("test_server.hrl"). + +-export([all/1, pe2/1]). + +all(suite) -> [pe2]. + +%% (This is more general than needed, since we once compiled the same +%% source code with and without a certain option.) +compile_and_load(Srcname, Outdir, Module, Options) -> + ?line Objname = filename:join(Outdir, "t1") ++ code:objfile_extension(), + ?line {ok, Module} = + compile:file(Srcname, + [{d, 'M', Module}, {outdir, Outdir}] ++ Options), + ?line {ok, B} = file:read_file(Objname), + ?line {module, Module} = code:load_binary(Module, Objname, B), + B. + +pe2(Config) when is_list(Config) -> + ?line DataDir = ?config(data_dir, Config), + ?line PrivDir = ?config(priv_dir, Config), + ?line Srcname = filename:join(DataDir, "t1.erl"), + ?line compile_and_load(Srcname, PrivDir, t1, []), + + ?line {Correct, Actual} = t1:run(), + ?line Correct = Actual, + ok. diff --git a/lib/compiler/test/parteval_SUITE_data/t1.erl b/lib/compiler/test/parteval_SUITE_data/t1.erl new file mode 100644 index 0000000000..5e4a40f103 --- /dev/null +++ b/lib/compiler/test/parteval_SUITE_data/t1.erl @@ -0,0 +1,140 @@ +%% +%% %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% +%% +-module(?M). + +-compile(export_all). + +%%% The arity-0 functions are all called from the test suite. + +f2() -> + size({1,2}). + +i() -> + case [] of + [] -> + ok; + X -> + hopp + end. + +e() -> + case 4+5 of +% X when X>10 -> kvock; % not removed by BEAM opt. + {X,X} when list(X) -> + kvack; + 9 -> + ok; + _ -> + ko + end. + +f() -> + element(2,{a,b,c,d}), + erlang:element(2,{a,b,c,d}), + "hej" ++ "hopp". + +g(X) -> + if + float(3.4) -> + hej; + X == 5, 4==4 -> + japp; + 4 == 4, size({1,2}) == 1 -> + ok + end. + +g() -> + {g(3),g(5)}. + +bliff() -> + if + 3==4 -> + himm + end. + +fi() -> + case 4 of + X when 4==3 -> + {X}; + 4 -> + 4; + _ -> + ok + end. + +iff() when 3==2 -> + if + 3 == 4 -> + baff; + 3 == 3 -> + nipp + end. + +sleep(I) -> receive after I -> ok end. + +sleep() -> + sleep(45). + +s() -> + case 4 of + 3 -> + ok + end. + +error_reason(R) when atom(R) -> + R; +error_reason(R) when tuple(R) -> + error_reason(element(1, R)). + +plusplus() -> + ?MODULE ++ " -> mindre snygg felhantering". + +call_it(F) -> + case (catch apply(?MODULE, F, [])) of + {'EXIT', R0} -> + {'EXIT', error_reason(R0)}; + V -> + V + end. + +run() -> + L = [{f2, 2}, + {i, ok}, + {e, ok}, + {f, "hejhopp"}, + {g, {hej, hej}}, + {bliff, {'EXIT', if_clause}}, + {fi, 4}, + {iff, {'EXIT', function_clause}}, + {sleep, ok}, + {s, {'EXIT', case_clause}, + {plusplus, {'EXIT', badarg}}}], + Actual = [call_it(F) || {F, _} <- L], + Correct = [C || {_, C} <- L], + {Correct, Actual}. + + +%%% Don't call, only compile. +t(A) -> + receive + A when 1==2 -> + ok; + B -> + B + end. diff --git a/lib/compiler/test/pmod_SUITE.erl b/lib/compiler/test/pmod_SUITE.erl new file mode 100644 index 0000000000..c8919e5539 --- /dev/null +++ b/lib/compiler/test/pmod_SUITE.erl @@ -0,0 +1,90 @@ +%% +%% %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(pmod_SUITE). + +-export([all/1,init_per_testcase/2,fin_per_testcase/2, + basic/1]). + +-include("test_server.hrl"). + +all(suite) -> + test_lib:recompile(?MODULE), + [basic]. + +init_per_testcase(Case, Config) when is_atom(Case), is_list(Config) -> + Dog = test_server:timetrap(?t:minutes(1)), + [{watchdog,Dog}|Config]. + +fin_per_testcase(Case, Config) when is_atom(Case), is_list(Config) -> + Dog = ?config(watchdog, Config), + ?t:timetrap_cancel(Dog), + ok. + +basic(Config) when is_list(Config) -> + ?line basic_1(Config, []), + ?line basic_1(Config, [inline]), + ?line basic_1(Config, [{inline,500}]), + ok. + +basic_1(Config, Opts) -> + io:format("Options: ~p\n", [Opts]), + ?line ok = compile_load(pmod_basic, Config, Opts), + + ?line Prop1 = pmod_basic:new([{a,xb},{b,true},{c,false}]), + ?line Prop2 = pmod_basic:new([{y,zz}]), + ?line io:format("Prop1 = ~p\n", [Prop1]), + ?line io:format("Prop2 = ~p\n", [Prop2]), + + ?line {a,xb} = Prop1:lookup(a), + ?line none = Prop1:lookup(glurf), + ?line false = Prop1:or_props([]), + ?line true = Prop1:or_props([b,c]), + ?line true = Prop1:or_props([b,d]), + ?line false = Prop1:or_props([d]), + + ?line none = Prop2:lookup(kalle), + ?line {y,zz} = Prop2:lookup(y), + ?line {a,xb} = Prop1:lookup(a), + + ?line Prop3 = Prop1:prepend({blurf,true}), + ?line io:format("Prop3 = ~p\n", [Prop3]), + ?line {blurf,true} = Prop3:lookup(blurf), + + Prop4 = Prop3:append(42), + ?line io:format("Prop4 = ~p\n", [Prop4]), + ?line {42,5} = Prop4:stupid_sum(), + + %% Some record guards. + ?line ok = Prop4:bar({s,0}), + ?line ok = Prop4:bar_bar({s,blurf}), + ?line error = Prop4:bar_bar({s,a,b}), + ?line error = Prop4:bar_bar([]), + + ok. + +compile_load(Module, Conf, Opts) -> + ?line Dir = ?config(data_dir,Conf), + ?line Src = filename:join(Dir, atom_to_list(Module)), + ?line Out = ?config(priv_dir,Conf), + ?line CompRc = compile:file(Src, [report,{outdir,Out}|Opts]), + ?line {ok,Module} = CompRc, + ?line code:purge(Module), + ?line {module,Module} = + code:load_abs(filename:join(Out, atom_to_list(Module))), + ok. diff --git a/lib/compiler/test/pmod_SUITE_data/pmod_basic.erl b/lib/compiler/test/pmod_SUITE_data/pmod_basic.erl new file mode 100644 index 0000000000..e6f4c63421 --- /dev/null +++ b/lib/compiler/test/pmod_SUITE_data/pmod_basic.erl @@ -0,0 +1,72 @@ +%% +%% %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(pmod_basic, [Props]). + +-export([lookup/1,or_props/1,prepend/1,append/1,stupid_sum/0]). +-export([bar/1,bar_bar/1]). + +lookup(Key) -> + proplists:lookup(Key, Props). + +or_props(Keys) -> + Res = or_props_1(Keys, false), + true = is_bool(Res), %is_bool/1 does not use Props. + Res. + +prepend(Term) -> + new([Term|Props]). + +append(Term) -> + pmod_basic:new(Props++[Term]). + +or_props_1([K|Ks], Acc) -> + or_props_1(Ks, proplists:get_bool(K, Props) or Acc); +or_props_1([], Acc) -> Acc. + +is_bool(true) -> true; +is_bool(false) -> true; +is_bool(_) -> false. + +stupid_sum() -> + put(counter, 0), + Res = stupid_sum_1(Props, 0), + {Res,get(counter)}. + +stupid_sum_1([H|T], Sum0) -> + try add(Sum0, H) of + Sum -> stupid_sum_1(T, Sum) + catch + error:_ -> stupid_sum_1(T, Sum0) + after + bump() + end; +stupid_sum_1([], Sum) -> Sum. + +bump() -> + put(counter, get(counter)+1). + +add(A, B) -> + A+B. + +-record(s, {a}). + +bar(S) when S#s.a == 0 -> ok. + +bar_bar(S) when is_record(S, s) -> ok; +bar_bar(_) -> error. diff --git a/lib/compiler/test/receive_SUITE.erl b/lib/compiler/test/receive_SUITE.erl new file mode 100644 index 0000000000..cb8833759a --- /dev/null +++ b/lib/compiler/test/receive_SUITE.erl @@ -0,0 +1,161 @@ +%% +%% %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 : Compiles various modules with tough code + +-module(receive_SUITE). + +-export([all/1,init_per_testcase/2,fin_per_testcase/2, + recv/1,coverage/1,otp_7980/1]). + +-include("test_server.hrl"). + +init_per_testcase(_Case, Config) -> + ?line Dog = test_server:timetrap(test_server:minutes(2)), + [{watchdog, Dog}|Config]. + +fin_per_testcase(_Case, Config) -> + Dog=?config(watchdog, Config), + test_server:timetrap_cancel(Dog), + ok. + +all(suite) -> + test_lib:recompile(?MODULE), + [recv,coverage,otp_7980]. + +-record(state, {ena = true}). + +recv(Config) when is_list(Config) -> + ?line Pid = spawn_link(fun() -> loop(#state{}) end), + Self = self(), + ?line Pid ! {Self,test}, + receive + {ok,test} -> ok; + {error,Other} -> + io:format("Got unpexected ~p", [Other]), + ?line ?t:fail() + after 10000 -> + ?line ?t:fail(no_answer) + end, + receive + X -> + io:format("Unexpected extra message: ~p", [X]), + ?line ?t:fail() + after 10 -> + ok + end, + ok. + +loop(S) -> + receive + _ when S#state.ena == false -> + loop(S); + {P,test} -> + P ! {ok,test}, + loop(S); + _X -> + loop(S) + end. + +coverage(Config) when is_list(Config) -> + do_link(self()), + do_unlink(self()), + do_monitor_node(node(), true), + do_monitor_node(node(), false), + do_group_leader(group_leader(), self()), + id(node(self())), + + erlang:'!'(self(), {a,10}), + self() ! {b,20}, + [{a,10},{b,20}] = receive_all(), + self() ! {c,42}, + receive + {c,42} -> + ok + after infinity -> + exit(cant_happen) + end, + + self() ! 17, + self() ! 19, + ?line 59 = tuple_to_values(infinity, x), + ?line 61 = tuple_to_values(999999, x), + ?line 0 = tuple_to_values(1, x), + ok. + +receive_all() -> + receive + Any -> + [Any|receive_all()] + after 0 -> + [] + end. + +do_monitor_node(Node, Bool) -> + monitor_node(Node, Bool). + +do_link(Pid) -> + link(Pid). + +do_unlink(Pid) -> + unlink(Pid). + +do_group_leader(Leader, Pid) -> + group_leader(Leader, Pid). + + +%% cover sys_core_fold:tuple_to_values/2 +tuple_to_values(infinity, X) -> + {A,B} = case X of + x -> + receive + Any -> + {42,Any} + end + end, + A+B; +tuple_to_values(Timeout, X) -> + {A,B} = case X of + x -> + receive + Any -> + {42,Any} + after Timeout -> + {0,0} + end + end, + A+B. + +%% OTP-7980. Thanks to Vincent de Phily. The following code would +%% be inccorrectly optimized by beam_jump. + +otp_7980(Config) when is_list(Config) -> + 7 = otp_7980_add_clients(10), + ok. + +otp_7980_add_clients(Count) -> + Timeout = 42, + lists:foldl(fun(_, N) -> + case N of + 1 -> ok; + _ -> receive after Timeout -> ok end + end, + N - 1 + end, Count, [1,2,3]). + +id(I) -> I. diff --git a/lib/compiler/test/record_SUITE.erl b/lib/compiler/test/record_SUITE.erl new file mode 100644 index 0000000000..bd2ffd7f65 --- /dev/null +++ b/lib/compiler/test/record_SUITE.erl @@ -0,0 +1,525 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2003-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +%%% Purpose : Test records. + +-module(record_SUITE). + +-include("test_server.hrl"). + +-export([all/1,init_per_testcase/2,fin_per_testcase/2, + errors/1,record_test_2/1,record_test_3/1,record_access_in_guards/1, + guard_opt/1,eval_once/1,foobar/1,missing_test_heap/1]). + +init_per_testcase(_Case, Config) -> + ?line Dog = test_server:timetrap(test_server:minutes(2)), + [{watchdog,Dog}|Config]. + +fin_per_testcase(_Case, Config) -> + Dog = ?config(watchdog, Config), + test_server:timetrap_cancel(Dog), + ok. + +all(suite) -> + test_lib:recompile(?MODULE), + [errors,record_test_2,record_test_3,record_access_in_guards, + guard_opt,eval_once,foobar,missing_test_heap]. + +-record(foo, {a,b,c,d}). +-record(bar, {a,b,c,d}). +-record(barf, {a,b,c,d,e}). + +errors(Config) when is_list(Config) -> + Foo = #foo{a=1,b=2,c=3,d=4}, + ?line #foo{a=19,b=42,c=3,d=4} = update_foo(Foo, 19, 42), + + ?line {'EXIT',{{badrecord,bar},_}} = (catch update_foo_bar(Foo, 19)), + ?line {'EXIT',{{badrecord,bar},_}} = (catch update_foo_bar(Foo, 19, 35)), + ?line {'EXIT',{{badrecord,bar},_}} = (catch update_foo_bar(Foo, 19, 35, 17)), + ?line {'EXIT',{{badrecord,bar},_}} = (catch update_foo_bar(Foo, 19, 35, 17, 42)), + + ?line {'EXIT',{{badrecord,barf},_}} = (catch update_foo_barf(Foo, 19)), + ?line {'EXIT',{{badrecord,barf},_}} = (catch update_foo_barf(Foo, 19, 35)), + ?line {'EXIT',{{badrecord,barf},_}} = (catch update_foo_barf(Foo, 19, 35, 17)), + ?line {'EXIT',{{badrecord,barf},_}} = (catch update_foo_barf(Foo, 19, 35, 17, 42)), + ?line {'EXIT',{{badrecord,barf},_}} = (catch update_foo_barf(Foo, 19, + 35, 17, 42, -2)), + + ok. + +update_foo(#foo{}=R, A, B) -> + R#foo{a=A,b=B}. + +update_foo_bar(#foo{}=R, A) -> + R#bar{a=A}. + +update_foo_bar(#foo{}=R, A, _B) -> + R#bar{a=A,b=A}. + +update_foo_bar(#foo{}=R, A, _B, C) -> + R#bar{a=A,b=A,c=C}. + +update_foo_bar(#foo{}=R, A, _B, C, D) -> + R#bar{a=A,b=A,c=C,d=D}. + +update_foo_barf(#foo{}=R, A) -> + R#barf{a=A}. + +update_foo_barf(#foo{}=R, A, _B) -> + R#barf{a=A,b=A}. + +update_foo_barf(#foo{}=R, A, _B, C) -> + R#barf{a=A,b=A,c=C}. + +update_foo_barf(#foo{}=R, A, _B, C, D) -> + R#barf{a=A,b=A,c=C,d=D}. + +update_foo_barf(#foo{}=R, A, _B, C, D, E) -> + R#barf{a=A,b=A,c=C,d=D,e=E}. + + +-define(TrueGuard(Expr), if Expr -> ok; true -> ?t:fail() end). +-define(FalseGuard(Expr), if Expr -> ?t:fail(); true -> ok end). + +record_test_2(Config) when is_list(Config) -> + ?line true = is_record(#foo{}, foo), + ?line false = is_record(#foo{}, barf), + ?line false = is_record({foo}, foo), + + ?line true = erlang:is_record(#foo{}, foo), + ?line false = erlang:is_record(#foo{}, barf), + ?line false = erlang:is_record({foo}, foo), + + ?line false = is_record([], foo), + ?line false = is_record(Config, foo), + + ?line ?TrueGuard(is_record(#foo{}, foo)), + ?line ?FalseGuard(is_record(#foo{}, barf)), + ?line ?FalseGuard(is_record({foo}, foo)), + + ?line ?TrueGuard(erlang:is_record(#foo{}, foo)), + ?line ?FalseGuard(erlang:is_record(#foo{}, barf)), + ?line ?FalseGuard(erlang:is_record({foo}, foo)), + + ?line ?FalseGuard(is_record([], foo)), + ?line ?FalseGuard(is_record(Config, foo)), + + %% 'not is_record/2' to test guard optimization. + + ?line ?FalseGuard(not is_record(#foo{}, foo)), + ?line ?TrueGuard(not is_record(#foo{}, barf)), + ?line ?TrueGuard(not is_record({foo}, foo)), + + ?line ?FalseGuard(not erlang:is_record(#foo{}, foo)), + ?line ?TrueGuard(not erlang:is_record(#foo{}, barf)), + ?line ?TrueGuard(not erlang:is_record({foo}, foo)), + + Foo = id(#foo{}), + ?line ?FalseGuard(not erlang:is_record(Foo, foo)), + ?line ?TrueGuard(not erlang:is_record(Foo, barf)), + + ?line ?TrueGuard(not is_record(Config, foo)), + + ?line ?TrueGuard(not is_record(a, foo)), + ?line ?TrueGuard(not is_record([], foo)), + + %% Pass non-literal first argument. + + ?line true = is_record(id(#foo{}), foo), + ?line false = is_record(id(#foo{}), barf), + ?line false = is_record(id({foo}), foo), + + ?line true = erlang:is_record(id(#foo{}), foo), + ?line false = erlang:is_record(id(#foo{}), barf), + ?line false = erlang:is_record(id({foo}), foo), + + NoRec1 = id(blurf), + NoRec2 = id([]), + + ?line ?TrueGuard(not is_record(NoRec1, foo)), + ?line ?TrueGuard(not is_record(NoRec2, foo)), + + %% The optimizer attempts to move expressions to guards, + %% but it must not move an is_record/2 call that is not + %% allowed in a guard in the first place. + + ?line ok = case is_record(id({a}), id(a)) of + true -> ok; + false -> error + end, + + %% Force the use of guard bifs by using the 'xor' operation. + + False = id(false), + ?line ?TrueGuard(is_record(#foo{}, foo) xor False), + ?line ?FalseGuard(is_record(#foo{}, barf) xor False), + ?line ?FalseGuard(is_record({foo}, foo) xor False ), + + ?line ?TrueGuard(is_record(Foo, foo) xor False), + ?line ?FalseGuard(is_record(Foo, barf) xor False), + + + %% Implicit guards by using a list comprehension. + + List = id([1,#foo{a=2},3,#bar{d=4},5,#foo{a=6},7]), + + ?line [#foo{a=2},#foo{a=6}] = [X || X <- List, is_record(X, foo)], + ?line [#bar{d=4}] = [X || X <- List, is_record(X, bar)], + ?line [1,#foo{a=2},3,5,#foo{a=6},7] = + [X || X <- List, not is_record(X, bar)], + ?line [1,3,5,7] = + [X || X <- List, ((not is_record(X, bar)) and (not is_record(X, foo)))], + ?line [#foo{a=2},#bar{d=4},#foo{a=6}] = + [X || X <- List, ((is_record(X, bar)) or (is_record(X, foo)))], + ?line [1,3,#bar{d=4}] = + [X || X <- List, ((is_record(X, bar)) or (X < 5))], + + ?line MyList = [#foo{a=3},x,[],{a,b}], + ?line [#foo{a=3}] = [X || X <- MyList, is_record(X, foo)], + ?line [x,[],{a,b}] = [X || X <- MyList, not is_record(X, foo)], + ?line [#foo{a=3}] = [X || X <- MyList, begin is_record(X, foo) end], + ?line [x,[],{a,b}] = [X || X <- MyList, begin not is_record(X, foo) end], + ?line [#foo{a=3},x,[],{a,b}] = [X || X <- MyList, is_record(X, foo) or + not is_binary(X)], + ?line [#foo{a=3},x,[],{a,b}] = [X || X <- MyList, not is_record(X, foo) or + not is_binary(X)], + ?line [#foo{a=3}] = [X || X <- MyList, is_record(X, foo) or is_reference(X)], + ?line [x,[],{a,b}] = [X || X <- MyList, not is_record(X, foo) or + is_reference(X)], + ?line [#foo{a=3},x,[],{a,b}] = [X || X <- MyList, + begin is_record(X, foo) or + not is_binary(X) end], + ?line [#foo{a=3},x,[],{a,b}] = [X || X <- MyList, + begin not is_record(X, foo) or + not is_binary(X) end], + ?line [#foo{a=3}] = [X || X <- MyList, + begin is_record(X, foo) or is_reference(X) end], + ?line [x,[],{a,b}] = [X || X <- MyList, + begin not is_record(X, foo) or + is_reference(X) end], + + %% Call is_record/2 with illegal arguments. + ?line [] = [X || X <- [], is_record(t, id(X))], + ?line {'EXIT',{badarg,_}} = (catch [X || X <- [1], is_record(t, id(X))]), + + %% Update several fields with a string literal. + ?line #barf{} = Barf0 = id(#barf{}), + ?line Barf = update_barf(Barf0), + ?line #barf{a="abc",b=1} = id(Barf), + + ok. + +record_test_3(Config) when is_list(Config) -> + ?line true = is_record(#foo{}, foo, 5), + ?line false = is_record(#foo{}, barf, 5), + ?line false = is_record(#foo{}, barf, 6), + ?line false = is_record({foo}, foo, 5), + + ?line true = erlang:is_record(#foo{}, foo, 5), + ?line false = erlang:is_record(#foo{}, barf, 5), + ?line false = erlang:is_record({foo}, foo, 5), + + ?line false = is_record([], foo), + ?line false = is_record(Config, foo), + + ?line ?TrueGuard(is_record(#foo{}, foo, 5)), + ?line ?FalseGuard(is_record(#foo{}, barf, 5)), + ?line ?FalseGuard(is_record(#foo{}, barf, 6)), + ?line ?FalseGuard(is_record({foo}, foo, 5)), + + ?line ?TrueGuard(erlang:is_record(#foo{}, foo, 5)), + ?line ?FalseGuard(erlang:is_record(#foo{}, barf, 5)), + ?line ?FalseGuard(erlang:is_record(#foo{}, barf, 6)), + ?line ?FalseGuard(erlang:is_record({foo}, foo, 5)), + + ?line ?FalseGuard(is_record([], foo, 5)), + ?line ?FalseGuard(is_record(Config, foo, 5)), + + %% 'not is_record/2' to test guard optimization. + + ?line ?FalseGuard(not is_record(#foo{}, foo, 5)), + ?line ?TrueGuard(not is_record(#foo{}, barf, 6)), + ?line ?TrueGuard(not is_record({foo}, foo, 5)), + + ?line ?FalseGuard(not erlang:is_record(#foo{}, foo, 5)), + ?line ?TrueGuard(not erlang:is_record(#foo{}, barf, 5)), + ?line ?TrueGuard(not erlang:is_record({foo}, foo, 5)), + + Foo = id(#foo{}), + ?line ?FalseGuard(not erlang:is_record(Foo, foo, 5)), + ?line ?TrueGuard(not erlang:is_record(Foo, barf, 6)), + + ?line ?TrueGuard(not is_record(Config, foo, 5)), + + ?line ?TrueGuard(not is_record(a, foo, 5)), + ?line ?TrueGuard(not is_record([], foo, 5)), + + %% Pass non-literal first argument. + + ?line true = is_record(id(#foo{}), foo, 5), + ?line false = is_record(id(#foo{}), barf, 6), + ?line false = is_record(id({foo}), foo, 5), + + ?line true = erlang:is_record(id(#foo{}), foo, 5), + ?line false = erlang:is_record(id(#foo{}), barf, 6), + ?line false = erlang:is_record(id({foo}), foo, 5), + + NoRec1 = id(blurf), + NoRec2 = id([]), + + ?line ?TrueGuard(not is_record(NoRec1, foo, 5)), + ?line ?TrueGuard(not is_record(NoRec2, foo, 5)), + + %% Force the use of guard bifs by using the 'xor' operation. + + False = id(false), + ?line ?TrueGuard(is_record(#foo{}, foo, 5) xor False), + ?line ?FalseGuard(is_record(#foo{}, barf, 6) xor False), + ?line ?FalseGuard(is_record({foo}, foo, 5) xor False ), + + ?line ?TrueGuard(is_record(Foo, foo, 5) xor False), + ?line ?FalseGuard(is_record(Foo, barf, 6) xor False), + + + %% Implicit guards by using a list comprehension. + + List = id([1,#foo{a=2},3,#bar{d=4},5,#foo{a=6},7]), + + ?line [#foo{a=2},#foo{a=6}] = [X || X <- List, is_record(X, foo, 5)], + ?line [#bar{d=4}] = [X || X <- List, is_record(X, bar, 5)], + ?line [1,#foo{a=2},3,5,#foo{a=6},7] = + [X || X <- List, not is_record(X, bar, 5)], + ?line [1,3,5,7] = + [X || X <- List, ((not is_record(X, bar, 5)) and (not is_record(X, foo, 5)))], + ?line [#foo{a=2},#bar{d=4},#foo{a=6}] = + [X || X <- List, ((is_record(X, bar, 5)) or (is_record(X, foo, 5)))], + ?line [1,3,#bar{d=4}] = + [X || X <- List, ((is_record(X, bar, 5)) or (X < 5))], + + ?line MyList = [#foo{a=3},x,[],{a,b}], + ?line [#foo{a=3}] = [X || X <- MyList, is_record(X, foo, 5)], + ?line [x,[],{a,b}] = [X || X <- MyList, not is_record(X, foo, 5)], + ?line [#foo{a=3}] = [X || X <- MyList, begin is_record(X, foo, 5) end], + ?line [x,[],{a,b}] = [X || X <- MyList, begin not is_record(X, foo, 5) end], + ?line [#foo{a=3},x,[],{a,b}] = [X || X <- MyList, is_record(X, foo, 5) or + not is_binary(X)], + ?line [#foo{a=3},x,[],{a,b}] = [X || X <- MyList, not is_record(X, foo, 5) or + not is_binary(X)], + ?line [#foo{a=3}] = [X || X <- MyList, is_record(X, foo) or is_reference(X)], + ?line [x,[],{a,b}] = [X || X <- MyList, not is_record(X, foo) or + is_reference(X)], + ?line [#foo{a=3},x,[],{a,b}] = [X || X <- MyList, + begin is_record(X, foo, 5) or + not is_binary(X) end], + ?line [#foo{a=3},x,[],{a,b}] = [X || X <- MyList, + begin not is_record(X, foo, 5) or + not is_binary(X) end], + ?line [#foo{a=3}] = [X || X <- MyList, + begin is_record(X, foo, 5) or is_reference(X) end], + ?line [x,[],{a,b}] = [X || X <- MyList, + begin not is_record(X, foo, 5) or + is_reference(X) end], + + %% Update several fields with a string literal. + ?line #barf{} = Barf0 = id(#barf{}), + ?line Barf = update_barf(Barf0), + ?line #barf{a="abc",b=1} = id(Barf), + + %% Non-literal arguments. + ?line true = is_record(id(#barf{}), id(barf), id(6)), + ?line false = is_record(id(#barf{}), id(barf), id(42)), + ?line false = is_record(id(#barf{}), id(foo), id(6)), + + ok. + +record_access_in_guards(Config) when is_list(Config) -> + ?line Priv = ?config(priv_dir, Config), + ?line file:set_cwd(test_lib:get_data_dir(Config)), + ?line Opts0 = [{outdir,Priv},report_errors|test_lib:opt_opts(?MODULE)], + M = record_access_in_guards, + + Opts = [strict_record_tests|Opts0], + ?line io:format("Options: ~p\n", [Opts]), + ?line {ok,M} = c:c(M, Opts), + ?line ok = M:t(), + ok. + + +%% Test optimization of record access and is_record/2 in guards. + +-record(r, {a = 4,b}). +-record(r1, {a,b}). +-record(r2, {a = #r1{},b,c=length([1,2,3])}). +-record(r3, {a = fun(_) -> #r1{} end(1), b}). + +guard_opt(Config) when is_list(Config) -> + ok = fun() -> + F = fun(F, [H,H|T]) when is_record(H, r) -> + [H|F(F, T)]; + (F, [H|T]) when is_record(H, r) -> + [H|F(F, T)]; + (_, []) -> [] + end, + [#r{a=4,b=7},#r{a=1,b=42}] = + F(F, [#r{a=4,b=7},#r{a=4,b=7},#r{a=1,b=42}]), + {'EXIT',_} = (catch F(F, [#r1{}])), + ok + end(), + + true = fun() -> + R = #r{}, + if is_record(R, r) -> true; true -> false end + end(), + + ok = fun() -> + F = fun(true, B) when B#r1.a -> ok; + (false, _) -> error + end, + ok = F(true, #r1{a=true}), + error = F(false, anything_goes), + {'EXIT',_} = (catch F(true, #r1{})), + {'EXIT',_} = (catch F(true, #r{})), + ok + end(), + + ok = fun() -> + F = fun([{a,R}=T]) when R#r.a =:= 42 -> + {ok,tuple_size(T)}; + ([{a,R}=T]) when R#r1.a =:= 7 -> + {ok,tuple_size(T)}; + (_) -> error + end, + {ok,2} = F([{a,#r{a=42}}]), + {ok,2} = F([{a,#r1{a=7}}]), + error = F([{a,#r1{}}]), + error = F({a,b,c}), + error = F([]), + ok + end(), + + ok = fun() -> + F = fun(X, Y, Z) when is_record(X, r1) andalso + (is_record(Y, r2) orelse + is_record(Z, r3)) -> true; + (_, _, _) -> false + end, + true = F(#r1{}, #r2{}, #r3{}), + true = F(#r1{}, #r2{}, blurf), + true = F(#r1{}, blurf, #r3{}), + false = F(#r1{}, blurf, blurf), + false = F(blurf, #r2{}, #r3{}), + false = F(blurf, #r2{}, blurf), + false = F(blurf, blurf, #r3{}), + false = F(blurf, blurf, blurf), + ok + end(), + + ok = fun() -> + F = fun(R=#r{a=42}) when R#r.b =:= 7 -> + {ok,R}; + (_) -> error + end, + {ok,#r{a=42,b=7}} = F(#r{a=42,b=7}), + error = F(#r{}), + error = F([a,b,c]), + ok + end(), + + ok. + +update_barf(R) -> + R#barf{a="abc",b=1}. + +eval_once(Config) when is_list(Config) -> + ?line once(fun(GetRec) -> + true = erlang:is_record(GetRec(), foo) + end, #foo{}), + ?line once(fun(GetRec) -> + (GetRec())#foo{a=1} + end, #foo{}), + ?line once(fun(GetRec) -> + (GetRec())#foo{a=1,b=2} + end, #foo{}), + ?line once(fun(GetRec) -> + (GetRec())#foo{a=1,b=2,c=3} + end, #foo{}), + ?line once(fun(GetRec) -> + (GetRec())#foo{a=1,b=2,c=3,d=4} + end, #foo{}), + ok. + +once(Test, Record) -> + put(?MODULE, 0), + GetRec = fun() -> + put(?MODULE, 1+get(?MODULE)), + Record + end, + Result = Test(GetRec), + case get(?MODULE) of + 1 -> ok; + N -> + io:format("Evaluated ~w times\n", [N]), + ?t:fail() + end, + Result. + +%% Thanks to Martin Bjorklund. + +-record(foobar, {status}). + +foobar(Config) when is_list(Config) -> + {ok,_,_} = x({foo, 1}), + ok. + +get_bar() -> + #foobar{status = 1}. + +x(Trans) -> + {foo, Barno} = Trans, + case get_bar() of + Bar when Bar#foobar.status == 1 -> + noop(Bar), + Bar33 = Bar#foobar{status = 1}, + {ok, Bar33, Barno}; + _ -> + Trans + end. + +noop(_) -> + ok. + +-record(foo_rec, + {foo_1, + foo_2 = 0, + foo_3 = 0}). + +missing_test_heap(Config) when is_list(Config) -> + #foo_rec{foo_2=2,foo_3=5} = missing_test_heap_1(#foo_rec{foo_2=1,foo_3=4}), + ok. + + +%% Two test_heap instructions would be incorrectly merged (not allowed +%% because of gc_bif instructions for addition). +missing_test_heap_1(A = #foo_rec {foo_1 = _B, + foo_3 = C, + foo_2 = D}) -> + A#foo_rec {foo_1 = {C, D}, + foo_3 = C + 1, + foo_2 = D + 1}. + +id(I) -> I. diff --git a/lib/compiler/test/record_SUITE_data/record_access_in_guards.erl b/lib/compiler/test/record_SUITE_data/record_access_in_guards.erl new file mode 100644 index 0000000000..c2b3ec2f34 --- /dev/null +++ b/lib/compiler/test/record_SUITE_data/record_access_in_guards.erl @@ -0,0 +1,177 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2006-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(record_access_in_guards). + +-export([t/0]). + +-record(r, {a = 4,b}). +-record(r1, {a,b}). +-record(r2, {a = #r1{},b,c=length([1,2,3])}). +-record(r3, {a = fun(_) -> #r1{} end(1), b}). + +t() -> + foo = fun(A) when A#r1.a > A#r1.b -> foo end(#r1{b = 2}), + 0 = fun(A) when A#r2.a -> 0 end(#r2{a = true}), + 1 = fun(A) when (#r1{a = A})#r1.a > 2 -> 1 end(3), + 2 = fun(N) when ((#r2{a = #r{a = 4}, b = length([a,b,c])})#r2.a)#r.a > N -> + 2 end(2), + 3 = fun(A) when (A#r2.a)#r1.a =:= 3 -> 3 end(#r2{a = #r1{a = 3}}), + ok = fun() -> + F = fun(A) when record(A#r.a, r1) -> 4; + (A) when record(A#r1.a, r1) -> 5 + end, + 5 = F(#r1{a = #r1{}}), + 4 = F(#r{a = #r1{}}), + ok + end(), + 3 = fun(A) when record(A#r1.a, r), + (A#r1.a)#r.a > 3 -> 3 + end(#r1{a = #r{a = 4}}), + 7 = fun(A) when record(A#r3.a, r1) -> 7 end(#r3{}), + [#r1{a = 2,b = 1}] = + fun() -> + [A || A <- [#r1{a = 1, b = 3}, + #r2{a = 2,b = 1}, + #r1{a = 2, b = 1}], + A#r1.a > + A#r1.b] + end(), + {[_],b} = + fun(L) -> + %% A is checked only once: + R1 = [{A,B} || A <- L, A#r1.a, B <- L, A#r1.b], + A = #r2{a = true}, + %% A is checked again: + B = if A#r1.a -> a; true -> b end, + {R1,B} + end([#r1{a = true, b = true}]), + + p = fun(A) when (A#r1.a =:= 2) or (A#r2.a =:= 1) -> o; + (_) -> p + end(#r1{a = 2}), + + o = fun(A) when (A#r1.a =:= 2) orelse (A#r2.a =:= 1) -> o; + (_) -> p + end(#r1{a = 2}), + + 3 = fun(A) when A#r1.a > 3, + record(A, r1) -> 3 + end(#r1{a = 5}), + + ok = fun() -> + F = fun(A) when (A#r2.a =:= 1) orelse (A#r2.a) -> 2; + (A) when (A#r1.a =:= 1) orelse (A#r1.a) -> 1; + (A) when (A#r2.a =:= 2) andalso (A#r2.b) -> 3 + end, + 1 = F(#r1{a = 1}), + 2 = F(#r2{a = true}), + 3 = F(#r2{a = 2, b = true}), + ok + end(), + + b = fun(A) when false or not (A#r.a =:= 1) -> a; + (_) -> b + end(#r1{a = 1}), + b = fun(A) when not (A#r.a =:= 1) or false -> a; + (_) -> b + end(#r1{a = 1}), + + ok = fun() -> + F = fun(A) when not (A#r.a =:= 1) -> yes; + (_) -> no + end, + no = F(#r1{a = 2}), + yes = F(#r{a = 2}), + no = F(#r{a = 1}), + ok + end(), + + a = fun(A) when record(A, r), + A#r.a =:= 1, + A#r.b =:= 2 ->a + end(#r{a = 1, b = 2}), + a = fun(A) when erlang:is_record(A, r), + A#r.a =:= 1, + A#r.b =:= 2 -> a + end(#r{a = 1, b = 2}), + a = fun(A) when is_record(A, r), + A#r.a =:= 1, + A#r.b =:= 2 -> a + end(#r{a = 1, b = 2}), + + nop = fun(A) when (is_record(A, r1) and (A#r1.a > 3)) or (A#r2.a < 1) -> + japp; + (_) -> + nop + end(#r2{a = 0}), + nop = fun(A) when (A#r1.a > 3) or (A#r2.a < 1) -> japp; + (_) -> + nop + end(#r2{a = 0}), + + ok = fun() -> + F = fun(A) when (A#r1.a =:= 2) or (A#r2.a =:= 1) -> o; + (_) -> p + end, + p = F(#r2{a = 1}), + p = F(#r1{a = 2}), + ok + end(), + + ok = fun() -> + F = fun(A) when fail, A#r1.a; A#r1.a -> ab; + (_) -> bu + end, + ab = F(#r1{a = true}), + bu = F(#r2{a = true}), + ok + end(), + + both = fun(A) when A#r.a, A#r.b -> both + end(#r{a = true, b = true}), + + ok = fun() -> + F = fun(A, B) when ((A#r1.a) orelse (B#r2.a)) + or (B#r2.b) or (A#r1.b) -> true; + (_, _) -> false + end, + true = F(#r1{a = false, b = false}, #r2{a = false, b = true}), + false = F(#r1{a = true, b = true}, #r1{a = false, b = true}), + ok + end(), + + ok = fun(R) -> + F = fun(Head, Version, Tab) -> + VersionOK = (Head#r.a =:= Version), + if + Tab =:= Head#r.b, VersionOK -> + ok; + true -> + error + end + end, + ok = F(R, 42, tab), + error = F(R, 42, a), + error = F(R, 0, tab), + {'EXIT',{{badrecord,r},_}} = (catch F({x,y,z}, 4, 5)), + ok + end(#r{a=42,b=tab}), + + ok. + diff --git a/lib/compiler/test/test_lib.erl b/lib/compiler/test/test_lib.erl new file mode 100644 index 0000000000..3099538071 --- /dev/null +++ b/lib/compiler/test/test_lib.erl @@ -0,0 +1,75 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2003-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +-module(test_lib). + +-include("test_server.hrl"). + +-export([recompile/1,opt_opts/1,get_data_dir/1,smoke_disasm/1]). + +recompile(Mod) when is_atom(Mod) -> + case whereis(cover_server) of + undefined -> ok; + _ -> + %% Re-compile the test suite if the cover server is running. + Beam = code:which(Mod), + Src = filename:rootname(Beam, ".beam") ++ ".erl", + Opts = [bin_opt_info|opt_opts(Mod)], + io:format("Recompiling ~p (~p)\n", [Mod,Opts]), + c:c(Src, [{outdir,filename:dirname(Src)}|Opts]) + end, + + %% Smoke-test of beam disassembler. + smoke_disasm(Mod). + +smoke_disasm(Mod) when is_atom(Mod) -> + smoke_disasm(code:which(Mod)); +smoke_disasm(File) when is_list(File) -> + Res = beam_disasm:file(File), + {beam_file,Mod} = {element(1, Res),element(2, Res)}. + +%% Retrieve the "interesting" compiler options (options for optimization +%% and compatibility) for the given module. + +opt_opts(Mod) -> + Comp = Mod:module_info(compile), + {value,{options,Opts}} = lists:keysearch(options, 1, Comp), + lists:filter(fun(no_copt) -> true; + (no_postopt) -> true; + (no_float_opt) -> true; + (no_new_funs) -> true; + (no_new_binaries) -> true; + (no_new_apply) -> true; + (no_gc_bifs) -> true; + (no_constant_pool) -> true; + (no_stack_trimming) -> true; + (no_binaries) -> true; + (debug_info) -> true; + (_) -> false + end, Opts). + +%% Some test suites gets cloned (e.g. to "record_SUITE" to "record_no_opt_SUITE"), +%% but the data directory is not cloned. This function retrieves the path to +%% the original data directory. + +get_data_dir(Config) -> + Data0 = ?config(data_dir, Config), + {ok,Data1,_} = regexp:sub(Data0, "_no_opt_SUITE", "_SUITE"), + {ok,Data2,_} = regexp:sub(Data1, "_post_opt_SUITE", "_SUITE"), + {ok,Data,_} = regexp:sub(Data2, "_r11_SUITE", "_SUITE"), + Data. diff --git a/lib/compiler/test/trycatch_SUITE.erl b/lib/compiler/test/trycatch_SUITE.erl new file mode 100644 index 0000000000..c2f6dc24be --- /dev/null +++ b/lib/compiler/test/trycatch_SUITE.erl @@ -0,0 +1,911 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2003-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +-module(trycatch_SUITE). + +-export([all/1,basic/1,lean_throw/1,try_of/1,try_after/1,%after_bind/1, + catch_oops/1,after_oops/1,eclectic/1,rethrow/1, + nested_of/1,nested_catch/1,nested_after/1, + nested_horrid/1,last_call_optimization/1,bool/1, + plain_catch_coverage/1,andalso_orelse/1]). + +-include("test_server.hrl"). + +all(suite) -> + test_lib:recompile(?MODULE), + [basic,lean_throw,try_of,try_after,%after_bind, + catch_oops,after_oops,eclectic,rethrow, + nested_of,nested_catch,nested_after, + nested_horrid,last_call_optimization, + bool,plain_catch_coverage,andalso_orelse]. + + +basic(Conf) when is_list(Conf) -> + ?line 2 = + try my_div(4, 2) + catch + Class:Reason -> {Class,Reason} + end, + ?line error = + try my_div(1, 0) + catch + error:badarith -> error + end, + ?line error = + try 1.0 / zero() + catch + error:badarith -> error + end, + ?line ok = + try my_add(53, atom) + catch + error:badarith -> ok + end, + ?line exit_nisse = + try exit(nisse) + catch + exit:nisse -> exit_nisse + end, + ?line ok = + try throw(kalle) + catch + kalle -> ok + end, + + %% Try some stuff where the compiler will optimize away the try. + + V = id({a,variable}), + ?line V = try V catch nisse -> error end, + ?line 42 = try 42 catch nisse -> error end, + ?line [V] = try [V] catch nisse -> error end, + ?line {ok,V} = try {ok,V} catch nisse -> error end, + + %% Same idea, but use an after too. + + ?line V = try V catch nisse -> error after after_call() end, + ?line after_clean(), + ?line 42 = try 42 after after_call() end, + ?line after_clean(), + ?line [V] = try [V] catch nisse -> error after after_call() end, + ?line after_clean(), + ?line {ok,V} = try {ok,V} after after_call() end, + + %% Try/of + ?line ok = try V of + {a,variable} -> ok + catch nisse -> erro + end, + + ok. + +after_call() -> + put(basic, after_was_called). + +after_clean() -> + after_was_called = erase(basic). + + +lean_throw(Conf) when is_list(Conf) -> + ?line {throw,kalle} = + try throw(kalle) + catch + Kalle -> {throw,Kalle} + end, + ?line {exit,kalle} = + try exit(kalle) + catch + Throw1 -> {throw,Throw1}; + exit:Reason1 -> {exit,Reason1} + end, + ?line {exit,kalle} = + try exit(kalle) + catch + exit:Reason2 -> {exit,Reason2}; + Throw2 -> {throw,Throw2} + end, + ?line {exit,kalle} = + try try exit(kalle) + catch + Throw3 -> {throw,Throw3} + end + catch + exit:Reason3 -> {exit,Reason3} + end, + ok. + + + +try_of(Conf) when is_list(Conf) -> + ?line {ok,{some,content}} = + try_of_1({value,{good,{some,content}}}), + ?line {error,[other,content]} = + try_of_1({value,{bad,[other,content]}}), + ?line {caught,{exit,{ex,it,[reason]}}} = + try_of_1({exit,{ex,it,[reason]}}), + ?line {caught,{throw,[term,{in,a,{tuple}}]}} = + try_of_1({throw,[term,{in,a,{tuple}}]}), + ?line {caught,{error,[bad,arg]}} = + try_of_1({error,[bad,arg]}), + ?line {caught,{error,badarith}} = + try_of_1({'div',{1,0}}), + ?line {caught,{error,badarith}} = + try_of_1({'add',{a,0}}), + ?line {caught,{error,badarg}} = + try_of_1({'abs',x}), + ?line {caught,{error,function_clause}} = + try_of_1(illegal), + ?line {error,{try_clause,{some,other_garbage}}} = + try try_of_1({value,{some,other_garbage}}) + catch error:Reason -> {error,Reason} + end, + ok. + +try_of_1(X) -> + try foo(X) of + {good,Y} -> {ok,Y}; + {bad,Y} -> {error,Y} + catch + Class:Reason -> + {caught,{Class,Reason}} + end. + + + +try_after(Conf) when is_list(Conf) -> + ?line {{ok,[some,value],undefined},finalized} = + try_after_1({value,{ok,[some,value]}},finalized), + ?line {{error,badarith,undefined},finalized} = + try_after_1({'div',{1,0}},finalized), + ?line {{error,badarith,undefined},finalized} = + try_after_1({'add',{1,a}},finalized), + ?line {{error,badarg,undefined},finalized} = + try_after_1({'abs',a},finalized), + ?line {{error,[the,{reason}],undefined},finalized} = + try_after_1({error,[the,{reason}]},finalized), + ?line {{throw,{thrown,[reason]},undefined},finalized} = + try_after_1({throw,{thrown,[reason]}},finalized), + ?line {{exit,{exited,{reason}},undefined},finalized} = + try_after_1({exit,{exited,{reason}}},finalized), + ?line {{error,function_clause,undefined},finalized} = + try_after_1(function_clause,finalized), + ?line ok = + try try_after_1({'add',{1,1}}, finalized) + catch + error:{try_clause,2} -> ok + end, + ?line finalized = erase(try_after), + ?line ok = + try try foo({exit,[reaso,{n}]}) + after put(try_after, finalized) + end + catch + exit:[reaso,{n}] -> ok + end, + ok. + +try_after_1(X, Y) -> + erase(try_after), + Try = + try foo(X) of + {ok,Value} -> {ok,Value,get(try_after)} + catch + Reason -> {throw,Reason,get(try_after)}; + error:Reason -> {error,Reason,get(try_after)}; + exit:Reason -> {exit,Reason,get(try_after)} + after + put(try_after, Y) + end, + {Try,erase(try_after)}. + + + +-ifdef(begone). + +after_bind(Conf) when is_list(Conf) -> + V = [make_ref(),self()|value], + ?line {value,{value,V}} = + after_bind_1({value,V}, V, {value,V}), + ok. + +after_bind_1(X, V, Y) -> + try + Try = + try foo(X) of + V -> value + catch + C1:V -> {caught,C1} + after + After = foo(Y) + end, + {Try,After} + of + V -> {value,V} + catch + C:D -> {caught,{C,D}} + end. + +-endif. + + + +catch_oops(Conf) when is_list(Conf) -> + V = {v,[a,l|u],{e},self()}, + ?line {value,V} = catch_oops_1({value,V}), + ?line {value,1} = catch_oops_1({'div',{1,1}}), + ?line {error,badarith} = catch_oops_1({'div',{1,0}}), + ?line {error,function_clause} = catch_oops_1(function_clause), + ?line {throw,V} = catch_oops_1({throw,V}), + ?line {exit,V} = catch_oops_1({exit,V}), + ok. + +catch_oops_1(X) -> + Ref = make_ref(), + try try foo({error,Ref}) + catch + error:Ref -> + foo(X) + end of + Value -> {value,Value} + catch + Class:Data -> {Class,Data} + end. + + + +after_oops(Conf) when is_list(Conf) -> + V = {self(),make_ref()}, + ?line {{value,V},V} = after_oops_1({value,V}, {value,V}), + ?line {{exit,V},V} = after_oops_1({exit,V}, {value,V}), + ?line {{error,V},undefined} = after_oops_1({value,V}, {error,V}), + ?line {{error,function_clause},undefined} = + after_oops_1({exit,V}, function_clause), + ok. + +after_oops_1(X, Y) -> + erase(after_oops), + Try = + try try foo(X) + after + put(after_oops, foo(Y)) + end of + V -> {value,V} + catch + C:D -> {C,D} + end, + {Try,erase(after_oops)}. + + + +eclectic(Conf) when is_list(Conf) -> + V = {make_ref(),3.1415926535,[[]|{}]}, + ?line {{value,{value,V},V},V} = + eclectic_1({foo,{value,{value,V}}}, undefined, {value,V}), + ?line {{'EXIT',{V,[{?MODULE,foo,1}|_]}},V} = + eclectic_1({catch_foo,{error,V}}, undefined, {value,V}), + ?line {{error,{exit,V},{'EXIT',V}},V} = + eclectic_1({foo,{error,{exit,V}}}, error, {value,V}), + ?line {{value,{value,V},V}, + {'EXIT',{badarith,[{?MODULE,my_add,2}|_]}}} = + eclectic_1({foo,{value,{value,V}}}, undefined, {'add',{0,a}}), + ?line {{'EXIT',V},V} = + eclectic_1({catch_foo,{exit,V}}, undefined, {throw,V}), + ?line {{error,{'div',{1,0}},{'EXIT',{badarith,[{?MODULE,my_div,2}|_]}}}, + {'EXIT',V}} = + eclectic_1({foo,{error,{'div',{1,0}}}}, error, {exit,V}), + ?line {{{error,V},{'EXIT',{V,[{?MODULE,foo,1}|_]}}}, + {'EXIT',V}} = + eclectic_1({catch_foo,{throw,{error,V}}}, undefined, {exit,V}), + %% + ?line {{value,{value,{value,V},V}},V} = + eclectic_2({value,{value,V}}, undefined, {value,V}), + ?line {{value,{throw,{value,V},V}},V} = + eclectic_2({throw,{value,V}}, throw, {value,V}), + ?line {{caught,{'EXIT',V}},undefined} = + eclectic_2({value,{value,V}}, undefined, {exit,V}), + ?line {{caught,{'EXIT',{V,[{?MODULE,foo,1}|_]}}},undefined} = + eclectic_2({error,{value,V}}, throw, {error,V}), + ?line {{caught,{'EXIT',{badarg,[{erlang,abs,[V]}|_]}}},V} = + eclectic_2({value,{'abs',V}}, undefined, {value,V}), + ?line {{caught,{'EXIT',{badarith,[{?MODULE,my_add,2}|_]}}},V} = + eclectic_2({exit,{'add',{0,a}}}, exit, {value,V}), + ?line {{caught,{'EXIT',V}},undefined} = + eclectic_2({value,{error,V}}, undefined, {exit,V}), + ?line {{caught,{'EXIT',{V,[{?MODULE,foo,1}|_]}}},undefined} = + eclectic_2({throw,{'div',{1,0}}}, throw, {error,V}), + ok. + +eclectic_1(X, C, Y) -> + erase(eclectic), + Done = make_ref(), + Try = + try case X of + {catch_foo,V} -> catch {Done,foo(V)}; + {foo,V} -> {Done,foo(V)} + end of + {Done,D} -> {value,D,catch foo(D)}; + {'EXIT',_}=Exit -> Exit; + D -> {D,catch foo(D)} + catch + C:D -> {C,D,catch foo(D)} + after + put(eclectic, catch foo(Y)) + end, + {Try,erase(eclectic)}. + +eclectic_2(X, C, Y) -> + Done = make_ref(), + erase(eclectic), + Catch = + case + catch + {Done, + try foo(X) of + V -> {value,V,foo(V)} + catch + C:D -> {C,D,foo(D)} + after + put(eclectic, foo(Y)) + end} of + {Done,Z} -> {value,Z}; + Z -> {caught,Z} + end, + {Catch,erase(eclectic)}. + + + +rethrow(Conf) when is_list(Conf) -> + V = {a,[b,{c,self()},make_ref]}, + ?line {value2,value1} = + rethrow_1({value,V}, V), + ?line {caught2,{error,V}} = + rethrow_2({error,V}, undefined), + ?line {caught2,{exit,V}} = + rethrow_1({exit,V}, error), + ?line {caught2,{throw,V}} = + rethrow_1({throw,V}, undefined), + ?line {caught2,{throw,V}} = + rethrow_2({throw,V}, undefined), + ?line {caught2,{error,badarith}} = + rethrow_1({'add',{0,a}}, throw), + ?line {caught2,{error,function_clause}} = + rethrow_2(function_clause, undefined), + ?line {caught2,{error,{try_clause,V}}} = + rethrow_1({value,V}, exit), + ?line {value2,{caught1,V}} = + rethrow_1({error,V}, error), + ?line {value2,{caught1,V}} = + rethrow_1({exit,V}, exit), + ?line {value2,caught1} = + rethrow_2({throw,V}, V), + ok. + +rethrow_1(X, C1) -> + try try foo(X) of + C1 -> value1 + catch + C1:D1 -> {caught1,D1} + end of + V2 -> {value2,V2} + catch + C2:D2 -> {caught2,{C2,D2}} + end. + +rethrow_2(X, C1) -> + try try foo(X) of + C1 -> value1 + catch + C1 -> caught1 % Implicit class throw: + end of + V2 -> {value2,V2} + catch + C2:D2 -> {caught2,{C2,D2}} + end. + + + +nested_of(Conf) when is_list(Conf) -> + V = {[self()|make_ref()],1.4142136}, + ?line {{value,{value1,{V,x2}}}, + {V,x3}, + {V,x4}, + finalized} = + nested_of_1({{value,{V,x1}},void,{V,x1}}, + {value,{V,x2}}, {value,{V,x3}}, {value,{V,x4}}), + ?line {{caught,{throw,{V,x2}}}, + {V,x3}, + {V,x4}, + finalized} = + nested_of_1({{value,{V,x1}},void,{V,x1}}, + {throw,{V,x2}}, {value,{V,x3}}, {value,{V,x4}}), + ?line {{caught,{error,badarith}}, + undefined, + {V,x4}, + finalized} = + nested_of_1({{value,{V,x1}},void,{V,x1}}, + {throw,{V,x2}}, {'div',{1,0}}, {value,{V,x4}}), + ?line {{caught,{error,badarith}}, + undefined, + undefined, + finalized} = + nested_of_1({{value,{V,x1}},void,{V,x1}}, + {throw,{V,x2}}, {'div',{1,0}}, {'add',{0,b}}), + %% + ?line {{caught,{error,{try_clause,{V,x1}}}}, + {V,x3}, + {V,x4}, + finalized} = + nested_of_1({{value,{V,x1}},void,try_clause}, + void, {value,{V,x3}}, {value,{V,x4}}), + ?line {{caught,{exit,{V,x3}}}, + undefined, + {V,x4}, + finalized} = + nested_of_1({{value,{V,x1}},void,try_clause}, + void, {exit,{V,x3}}, {value,{V,x4}}), + ?line {{caught,{throw,{V,x4}}}, + undefined, + undefined, + finalized} = + nested_of_1({{value,{V,x1}},void,try_clause}, + void, {exit,{V,x3}}, {throw,{V,x4}}), + %% + ?line {{value,{caught1,{V,x2}}}, + {V,x3}, + {V,x4}, + finalized} = + nested_of_1({{error,{V,x1}},error,{V,x1}}, + {value,{V,x2}}, {value,{V,x3}}, {value,{V,x4}}), + ?line {{caught,{error,badarith}}, + {V,x3}, + {V,x4}, + finalized} = + nested_of_1({{error,{V,x1}},error,{V,x1}}, + {'add',{1,c}}, {value,{V,x3}}, {value,{V,x4}}), + ?line {{caught,{error,badarith}}, + undefined, + {V,x4}, + finalized} = + nested_of_1({{error,{V,x1}},error,{V,x1}}, + {'add',{1,c}}, {'div',{17,0}}, {value,{V,x4}}), + ?line {{caught,{error,badarg}}, + undefined, + undefined, + finalized} = + nested_of_1({{error,{V,x1}},error,{V,x1}}, + {'add',{1,c}}, {'div',{17,0}}, {'abs',V}), + %% + ?line {{caught,{error,badarith}}, + {V,x3}, + {V,x4}, + finalized} = + nested_of_1({{'add',{2,c}},rethrow,void}, + void, {value,{V,x3}}, {value,{V,x4}}), + ?line {{caught,{error,badarg}}, + undefined, + {V,x4}, + finalized} = + nested_of_1({{'add',{2,c}},rethrow,void}, + void, {'abs',V}, {value,{V,x4}}), + ?line {{caught,{error,function_clause}}, + undefined, + undefined, + finalized} = + nested_of_1({{'add',{2,c}},rethrow,void}, + void, {'abs',V}, function_clause), + ok. + +nested_of_1({X1,C1,V1}, + X2, X3, X4) -> + erase(nested3), + erase(nested4), + erase(nested), + Self = self(), + Try = + try + try self() + of + Self -> + try + foo(X1) + of + V1 -> {value1,foo(X2)} + catch + C1:V1 -> {caught1,foo(X2)} + after + put(nested3, foo(X3)) + end + after + put(nested4, foo(X4)) + end + of + V -> {value,V} + catch + C:D -> {caught,{C,D}} + after + put(nested, finalized) + end, + {Try,erase(nested3),erase(nested4),erase(nested)}. + + + +nested_catch(Conf) when is_list(Conf) -> + V = {[make_ref(),1.4142136,self()]}, + ?line {{value,{value1,{V,x2}}}, + {V,x3}, + {V,x4}, + finalized} = + nested_catch_1({{value,{V,x1}},void,{V,x1}}, + {value,{V,x2}}, {value,{V,x3}}, {value,{V,x4}}), + ?line {{caught,{throw,{V,x2}}}, + {V,x3}, + {V,x4}, + finalized} = + nested_catch_1({{value,{V,x1}},void,{V,x1}}, + {throw,{V,x2}}, {value,{V,x3}}, {value,{V,x4}}), + ?line {{caught,{error,badarith}}, + undefined, + {V,x4}, + finalized} = + nested_catch_1({{value,{V,x1}},void,{V,x1}}, + {throw,{V,x2}}, {'div',{1,0}}, {value,{V,x4}}), + ?line {{caught,{error,badarith}}, + undefined, + undefined, + finalized} = + nested_catch_1({{value,{V,x1}},void,{V,x1}}, + {throw,{V,x2}}, {'div',{1,0}}, {'add',{0,b}}), + %% + ?line {{caught,{error,{try_clause,{V,x1}}}}, + {V,x3}, + {V,x4}, + finalized} = + nested_catch_1({{value,{V,x1}},void,try_clause}, + void, {value,{V,x3}}, {value,{V,x4}}), + ?line {{caught,{exit,{V,x3}}}, + undefined, + {V,x4}, + finalized} = + nested_catch_1({{value,{V,x1}},void,try_clause}, + void, {exit,{V,x3}}, {value,{V,x4}}), + ?line {{caught,{throw,{V,x4}}}, + undefined, + undefined, + finalized} = + nested_catch_1({{value,{V,x1}},void,try_clause}, + void, {exit,{V,x3}}, {throw,{V,x4}}), + %% + ?line {{value,{caught1,{V,x2}}}, + {V,x3}, + {V,x4}, + finalized} = + nested_catch_1({{error,{V,x1}},error,{V,x1}}, + {value,{V,x2}}, {value,{V,x3}}, {value,{V,x4}}), + ?line {{caught,{error,badarith}}, + {V,x3}, + {V,x4}, + finalized} = + nested_catch_1({{error,{V,x1}},error,{V,x1}}, + {'add',{1,c}}, {value,{V,x3}}, {value,{V,x4}}), + ?line {{caught,{error,badarith}}, + undefined, + {V,x4}, + finalized} = + nested_catch_1({{error,{V,x1}},error,{V,x1}}, + {'add',{1,c}}, {'div',{17,0}}, {value,{V,x4}}), + ?line {{caught,{error,badarg}}, + undefined, + undefined, + finalized} = + nested_catch_1({{error,{V,x1}},error,{V,x1}}, + {'add',{1,c}}, {'div',{17,0}}, {'abs',V}), + %% + ?line {{caught,{error,badarith}}, + {V,x3}, + {V,x4}, + finalized} = + nested_catch_1({{'add',{2,c}},rethrow,void}, + void, {value,{V,x3}}, {value,{V,x4}}), + ?line {{caught,{error,badarg}}, + undefined, + {V,x4}, + finalized} = + nested_catch_1({{'add',{2,c}},rethrow,void}, + void, {'abs',V}, {value,{V,x4}}), + ?line {{caught,{error,function_clause}}, + undefined, + undefined, + finalized} = + nested_catch_1({{'add',{2,c}},rethrow,void}, + void, {'abs',V}, function_clause), + ok. + +nested_catch_1({X1,C1,V1}, + X2, X3, X4) -> + erase(nested3), + erase(nested4), + erase(nested), + Throw = make_ref(), + Try = + try + try throw(Throw) + catch + Throw -> + try + foo(X1) + of + V1 -> {value1,foo(X2)} + catch + C1:V1 -> {caught1,foo(X2)} + after + put(nested3, foo(X3)) + end + after + put(nested4, foo(X4)) + end + of + V -> {value,V} + catch + C:D -> {caught,{C,D}} + after + put(nested, finalized) + end, + {Try,erase(nested3),erase(nested4),erase(nested)}. + + + +nested_after(Conf) when is_list(Conf) -> + V = [{make_ref(),1.4142136,self()}], + ?line {value, + {V,x3}, + {value1,{V,x2}}, + finalized} = + nested_after_1({{value,{V,x1}},void,{V,x1}}, + {value,{V,x2}}, {value,{V,x3}}), + ?line {{caught,{error,{V,x2}}}, + {V,x3}, + undefined, + finalized} = + nested_after_1({{value,{V,x1}},void,{V,x1}}, + {error,{V,x2}}, {value,{V,x3}}), + ?line {{caught,{exit,{V,x3}}}, + undefined, + undefined, + finalized} = + nested_after_1({{value,{V,x1}},void,{V,x1}}, + {error,{V,x2}}, {exit,{V,x3}}), + %% + ?line {{caught,{error,{try_clause,{V,x1}}}}, + {V,x3}, + undefined, + finalized} = + nested_after_1({{value,{V,x1}},void,try_clause}, + void, {value,{V,x3}}), + ?line {{caught,{error,badarith}}, + undefined, + undefined, + finalized} = + nested_after_1({{value,{V,x1}},void,try_clause}, + void, {'div',{17,0}}), + %% + ?line {value, + {V,x3}, + {caught1,{V,x2}}, + finalized} = + nested_after_1({{throw,{V,x1}},throw,{V,x1}}, + {value,{V,x2}}, {value,{V,x3}}), + ?line {{caught,{error,badarith}}, + {V,x3}, + undefined, + finalized} = + nested_after_1({{throw,{V,x1}},throw,{V,x1}}, + {'add',{a,b}}, {value,{V,x3}}), + ?line {{caught,{error,badarg}}, + undefined, + undefined, + finalized} = + nested_after_1({{throw,{V,x1}},throw,{V,x1}}, + {'add',{a,b}}, {'abs',V}), + %% + ?line {{caught,{throw,{V,x1}}}, + {V,x3}, + undefined, + finalized} = + nested_after_1({{throw,{V,x1}},rethrow,void}, + void, {value,{V,x3}}), + ?line {{caught,{error,badarith}}, + undefined, + undefined, + finalized} = + nested_after_1({{throw,{V,x1}},rethrow,void}, + void, {'div',{1,0}}), + ok. + +nested_after_1({X1,C1,V1}, + X2, X3) -> + erase(nested3), + erase(nested4), + erase(nested), + Self = self(), + Try = + try + try self() + after + After = + try + foo(X1) + of + V1 -> {value1,foo(X2)} + catch + C1:V1 -> {caught1,foo(X2)} + after + put(nested3, foo(X3)) + end, + put(nested4, After) + end + of + Self -> value + catch + C:D -> {caught,{C,D}} + after + put(nested, finalized) + end, + {Try,erase(nested3),erase(nested4),erase(nested)}. + + + +nested_horrid(Config) when is_list(Config) -> + _V = {make_ref(),nested_horrid,4.711}, + {[true,true],{[true,1.0],1.0}} = + nested_horrid_1({true,void,void}, 1.0), + ok. + +nested_horrid_1({X1,C1,V1}, X2) -> + try A1 = [X1,X1], + B1 = if X1 -> + A2 = [X1,X2], + B2 = foo(X2), + {A2,B2}; + true -> + A3 = [X2,X1], + B3 = foo(X2), + {A3,B3} + end, + {A1,B1} + catch + C1:V1 -> caught1 + end. + + + +foo({value,Value}) -> Value; +foo({'div',{A,B}}) -> + my_div(A, B); +foo({'add',{A,B}}) -> + my_add(A, B); +foo({'abs',X}) -> + my_abs(X); +foo({error,Error}) -> + erlang:error(Error); +foo({throw,Throw}) -> + erlang:throw(Throw); +foo({exit,Exit}) -> + erlang:exit(Exit); +foo({raise,{Class,Reason}}) -> + erlang:raise(Class, Reason); +foo(Term) when not is_atom(Term) -> Term. +%%foo(Atom) when is_atom(Atom) -> % must not be defined! + +my_div(A, B) -> + A div B. + +my_add(A, B) -> + A + B. + +my_abs(X) -> abs(X). + + +last_call_optimization(Config) when is_list(Config) -> + ?line error = in_tail(dum), + ?line StkSize0 = in_tail(0), + ?line StkSize = in_tail(50000), + io:format("StkSize0 = ~p", [StkSize0]), + io:format("StkSize = ~p", [StkSize]), + ?line StkSize = StkSize0, + ok. + +in_tail(E) -> + try erlang:abs(E) of + T -> + A = id([]), + B = id([]), + C = id([]), + id([A,B,C]), + do_tail(T) + catch error:badarg -> error + end. + +do_tail(0) -> + process_info(self(), stack_size); +do_tail(N) -> + in_tail(N-1). + +bool(Config) when is_list(Config) -> + ok = do_bool(false, false), + error = do_bool(false, true), + error = do_bool(true, false), + error = do_bool(true, true), + error = do_bool(true, blurf), + {'EXIT',_} = (catch do_bool(blurf, false)), + ok. + +%% The following function used to cause a crash in beam_bool. +do_bool(A0, B) -> + A = not A0, + try + id(42), + if + A, not B -> ok + end + catch + _:_ -> + error + end. + +plain_catch_coverage(Config) when is_list(Config) -> + %% Cover some code in beam_block:alloc_may_pass/1. + ?line {a,[42]} = do_plain_catch_list(42). + +do_plain_catch_list(X) -> + B = [X], + catch id({a,B}). + +andalso_orelse(Config) when is_list(Config) -> + ?line {2,{a,42}} = andalso_orelse_1(true, {a,42}), + ?line {b,{b}} = andalso_orelse_1(false, {b}), + ?line {catched,no_tuple} = andalso_orelse_1(false, no_tuple), + + ?line ok = andalso_orelse_2({type,[a]}), + ?line also_ok = andalso_orelse_2({type,[]}), + ?line also_ok = andalso_orelse_2({type,{a}}), + ok. + +andalso_orelse_1(A, B) -> + {try + if + A andalso element(1, B) =:= a -> + tuple_size(B); + true -> + element(1, B) + end + catch error:_ -> + catched + end,B}. + +id(I) -> I. + +andalso_orelse_2({Type,Keyval}) -> + try + if is_atom(Type) andalso length(Keyval) > 0 -> ok; + true -> also_ok + end + catch + _:_ -> fail + end. + +zero() -> + 0.0. diff --git a/lib/compiler/test/warnings_SUITE.erl b/lib/compiler/test/warnings_SUITE.erl new file mode 100644 index 0000000000..6e60ab88cb --- /dev/null +++ b/lib/compiler/test/warnings_SUITE.erl @@ -0,0 +1,554 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2003-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +-module(warnings_SUITE). + +%%-define(STANDALONE, true). + +-ifdef(STANDALONE). +-define(line, put(line, ?LINE), ). +-define(config(X,Y), foo). +-define(privdir, "warnings_SUITE_priv"). +-define(t, test_server). +-else. +-include("test_server.hrl"). +-define(datadir, ?config(data_dir, Conf)). +-define(privdir, ?config(priv_dir, Conf)). +-endif. + +-export([all/1,init_per_testcase/2,fin_per_testcase/2]). + +-export([pattern/1,pattern2/1,pattern3/1,pattern4/1, + guard/1,bad_arith/1,bool_cases/1,bad_apply/1, + files/1,effect/1,bin_opt_info/1,bin_construction/1]). + +% Default timetrap timeout (set in init_per_testcase). +-define(default_timeout, ?t:minutes(2)). + +init_per_testcase(_Case, Config) -> + ?line Dog = ?t:timetrap(?default_timeout), + [{watchdog, Dog} | Config]. + +fin_per_testcase(_Case, Config) -> + Dog = ?config(watchdog, Config), + test_server:timetrap_cancel(Dog), + ok. + +all(suite) -> + test_lib:recompile(?MODULE), + [pattern,pattern2,pattern3,pattern4, + guard,bad_arith,bool_cases,bad_apply,files,effect, + bin_opt_info,bin_construction]. + +pattern(Config) when is_list(Config) -> + %% Test warnings generated by v3_core. + Ts = [{pattern, + <<"%% Just a comment here. + f(a={glurf,2}=A) -> A. + + g(A) -> + case A of + a=[_|_] -> error; + Other -> true + end. + + foo(X) -> + a = {nisse,b} = X. + ">>, + [warn_unused_vars], + {warnings, + [{2,v3_core,nomatch}, + {6,v3_core,nomatch}, + {11,v3_core,nomatch} ] }}], + ?line [] = run(Config, Ts), + ok. + +pattern2(Config) when is_list(Config) -> + %% Test warnings generated by sys_core_fold. + %% If we disable Core Erlang optimizations, we expect that + %% v3_kernel should generate some of the warnings. + Source = <<"f(A) -> ok; + f(B) -> error. + t(A, B, C) -> + case {A,B,C} of + {a,B} -> ok; + {_,B} -> ok + end. + ">>, + + %% Test warnings from sys_core_fold. + Ts = [{pattern2, + Source, + [nowarn_unused_vars], + {warnings,[{2,sys_core_fold,{nomatch_shadow,1}}, + {5,sys_core_fold,nomatch_clause_type}, + {6,sys_core_fold,nomatch_clause_type}]}}], + ?line [] = run(Config, Ts), + + %% Disable Core Erlang optimizations. v3_kernel should produce + %% a warning for the clause that didn't match. + Ts2 = [{pattern2, + Source, + [nowarn_unused_vars,no_copt], + {warnings, + [{2,v3_kernel,{nomatch_shadow,1}}]}}], + ?line [] = run(Config, Ts2), + ok. + +pattern3(Config) when is_list(Config) -> + %% Test warnings generated by the pattern matching compiler + %% in v3_kernel. + + Ts = [{pattern3, + <<" + f({A,_}) -> {ok,A}; + f([_|_]=B) -> {ok,B}; + f({urk,nisse}) -> urka_glurka. + ">>, + [nowarn_unused_vars], + {warnings, + [{4,v3_kernel,{nomatch_shadow,2}}]}}], + ?line [] = run(Config, Ts), + + ok. + +pattern4(Config) when is_list(Config) -> + %% Test warnings for clauses that cannot possibly match. + + Ts = [{pattern4, + <<" + t() -> + case true of + false -> a; + true -> b + end. + + fi() -> + case true of + false -> a; + false -> b + end, + case true of + true -> a; + true -> b; + X -> X + end, + case boolean of + true -> a; + false -> b + end. + int() -> + case 42 of + [a|b] -> no; + <<1>> -> no; + <<X>> -> no; + 17 -> no; + [] -> no; + a -> no; + {a,b,c} -> no + end. + tuple() -> + case {x,y,z} of + \"xyz\" -> no; + [a|b] -> no; + <<1>> -> no; + <<X>> -> no; + 17 -> no; + [] -> no; + a -> no; + {a,b,c} -> no; + {x,y} -> no + end. + ">>, + [nowarn_unused_vars], + {warnings, + [{9,sys_core_fold,no_clause_match}, + {18,sys_core_fold,no_clause_match}, + {23,sys_core_fold,no_clause_match}, + {33,sys_core_fold,no_clause_match} + ]}}], + ?line [] = run(Config, Ts), + + ok. + +guard(Config) when is_list(Config) -> + %% Test warnings for false guards. + + Ts = [{guard, + <<" + t(A, B) when element(x, dum) -> ok. + + tt(A, B) when 1 == 2 -> ok. + + ttt() when element(x, dum) -> ok. + + t4(T, F) when element({F}, T) -> ok. + t5(T, F) when element([F], T) -> ok. + t6(Pos, F) when element(Pos, [F]) -> ok. + t7(Pos) when element(Pos, []) -> ok. + ">>, + [nowarn_unused_vars], + {warnings, + [{2,sys_core_fold,no_clause_match}, + {2,sys_core_fold,nomatch_guard}, + {2,sys_core_fold,{eval_failure,badarg}}, + {4,sys_core_fold,no_clause_match}, + {4,sys_core_fold,nomatch_guard}, + {6,sys_core_fold,no_clause_match}, + {6,sys_core_fold,nomatch_guard}, + {6,sys_core_fold,{eval_failure,badarg}}, + {8,sys_core_fold,no_clause_match}, + {8,sys_core_fold,nomatch_guard}, + {8,sys_core_fold,{eval_failure,badarg}}, + {9,sys_core_fold,no_clause_match}, + {9,sys_core_fold,nomatch_guard}, + {9,sys_core_fold,{eval_failure,badarg}}, + {10,sys_core_fold,no_clause_match}, + {10,sys_core_fold,nomatch_guard}, + {10,sys_core_fold,{eval_failure,badarg}}, + {11,sys_core_fold,no_clause_match}, + {11,sys_core_fold,nomatch_guard}, + {11,sys_core_fold,{eval_failure,badarg}} + ]}}], + ?line [] = run(Config, Ts), + + ok. + +bad_arith(Config) when is_list(Config) -> + Ts = [{bad_arith, + <<"f() -> + if + a + 3 > 3 -> ok; + true -> error + end. + + g(A) -> + if + is_integer(A), a + 3 > 3 -> ok; + a + 3 > 42, is_integer(A) -> ok; + true -> error + end. + + h(A) -> + a + 3 + A. + ">>, + [], + {warnings, + [{3,sys_core_fold,nomatch_guard}, + {3,sys_core_fold,{eval_failure,badarith}}, + {9,sys_core_fold,nomatch_guard}, + {9,sys_core_fold,{eval_failure,badarith}}, + {10,sys_core_fold,nomatch_guard}, + {10,sys_core_fold,{eval_failure,badarith}}, + {15,sys_core_fold,{eval_failure,badarith}} + ] }}], + ?line [] = run(Config, Ts), + ok. + +bool_cases(Config) when is_list(Config) -> + Ts = [{bool_cases, + <<" + f(A, B) -> + case A > B of + true -> true; + false -> false; + Other -> {error,not_bool} + end. + + g(A, B) -> + case A =/= B of + false -> false; + true -> true; + Other -> {error,not_bool} + end. + + h(Bool) -> + case not Bool of + maybe -> strange; + false -> ok; + true -> error + end. + ">>, + [nowarn_unused_vars], + {warnings, + [{6,sys_core_fold,nomatch_shadow}, + {13,sys_core_fold,nomatch_shadow}, + {18,sys_core_fold,nomatch_clause_type} ]} }], + ?line [] = run(Config, Ts), + ok. + +bad_apply(Config) when is_list(Config) -> + Ts = [{bad_apply, + <<" + t(1) -> 42:42(); + t(2) -> erlang:42(); + t(3) -> 42:start(); + t(4) -> []:start(); + t(5) -> erlang:[](). + ">>, + [], + {warnings, + [{2,v3_kernel,bad_call}, + {3,v3_kernel,bad_call}, + {4,v3_kernel,bad_call}, + {5,v3_kernel,bad_call}, + {6,v3_kernel,bad_call}]}}], + ?line [] = run(Config, Ts), + + %% Also verify that the generated code generates the correct error. + ?line try erlang:42() of + _ -> ?line ?t:fail() + catch + error:badarg -> ok + end, + ok. + +files(Config) when is_list(Config) -> + Ts = [{files_1, + <<" + -file(\"file1\", 14). + + t1() -> + 1/0. + + -file(\"file2\", 7). + + t2() -> + 1/0. + ">>, + [], + {warnings, + [{"file1",[{17,sys_core_fold,{eval_failure,badarith}}]}, + {"file2",[{10,sys_core_fold,{eval_failure,badarith}}]}]}}], + + ?line [] = run(Config, Ts), + ok. + +%% Test warnings for term construction and BIF calls in effect context. +effect(Config) when is_list(Config) -> + Ts = [{lc, + <<" + t(X) -> + case X of + warn_lc -> + [is_integer(Z) || Z <- [1,2,3]]; + warn_lc_2 -> + [{error,Z} || Z <- [1,2,3]]; + warn_lc_3 -> + [{error,abs(Z)} || Z <- [1,2,3]]; + no_warn_lc -> + [put(last_integer, Z) || Z <- [1,2,3]]; %no warning + unused_tuple_literal -> + {a,b,c}; + unused_list_literal -> + [1,2,3,4]; + unused_integer -> + 42; + unused_arith -> + X*X; + nested -> + [{ok,node(),?MODULE:foo(),self(),[time(),date()],time()}, + is_integer(X)]; + unused_bit_syntax -> + <<X:8>>; + unused_fun -> + fun() -> {ok,X} end; + unused_atom -> + ignore; %no warning + unused_nil -> + []; %no warning + comp_op -> + X =:= 2; + cookie -> + erlang:get_cookie() + end, + ok. + + %% No warnings should be generated in the following functions. + m1(X, Sz) -> + if + Sz =:= 0 -> X = 0; + true -> ok + end, + ok. + + m2(X, Sz) -> + if + Sz =:= 0 -> X = {a,Sz}; + true -> ok + end, + ok. + + m3(X, Sz) -> + if + Sz =:= 0 -> X = [a,Sz]; + true -> ok + end, + ok. + + m4(X, Sz, Var) -> + if + Sz =:= 0 -> X = Var; + true -> ok + end, + ok. + + m5(X, Sz) -> + if + Sz =:= 0 -> X = {a,b,c}; + true -> ok + end, + ok. + + m6(X, Sz) -> + if + Sz =:= 0 -> X = {a,Sz,[1,2,3]}; + true -> ok + end, + ok. + + m7(X, Sz) -> + if + Sz =:= 0 -> X = {a,Sz,[1,2,3],abs(Sz)}; + true -> ok + end, + ok. + ">>, + [], + {warnings,[{5,sys_core_fold,{no_effect,{erlang,is_integer,1}}}, + {7,sys_core_fold,useless_building}, + {9,sys_core_fold,result_ignored}, + {9,sys_core_fold,useless_building}, + {13,sys_core_fold,useless_building}, + {15,sys_core_fold,useless_building}, + {17,sys_core_fold,useless_building}, + {19,sys_core_fold,result_ignored}, + {21,sys_core_fold,useless_building}, + {21,sys_core_fold,{no_effect,{erlang,date,0}}}, + {21,sys_core_fold,{no_effect,{erlang,node,0}}}, + {21,sys_core_fold,{no_effect,{erlang,self,0}}}, + {21,sys_core_fold,{no_effect,{erlang,time,0}}}, + {22,sys_core_fold,useless_building}, + {22,sys_core_fold,{no_effect,{erlang,is_integer,1}}}, + {24,sys_core_fold,useless_building}, + {26,sys_core_fold,useless_building}, + {32,sys_core_fold,{no_effect,{erlang,'=:=',2}}}, + {34,sys_core_fold,{no_effect,{erlang,get_cookie,0}}}]}}], + ?line [] = run(Config, Ts), + ok. + +bin_opt_info(Config) when is_list(Config) -> + Code = <<" + t1(Bin) -> + case Bin of + _ when byte_size(Bin) > 20 -> erlang:error(too_long); + <<_,T/binary>> -> t1(T); + <<>> -> ok + end. + + t2(<<_,T/bytes>>) -> + split_binary(T, 4). + ">>, + Ts1 = [{bsm1, + Code, + [bin_opt_info], + {warnings, + [{4,sys_core_fold,orig_bin_var_used_in_guard}, + {5,beam_bsm,{no_bin_opt,{{t1,1},no_suitable_bs_start_match}}}, + {9,beam_bsm,{no_bin_opt, + {binary_used_in,{extfunc,erlang,split_binary,2}}}} ]}}], + ?line [] = run(Config, Ts1), + + %% For coverage: don't give the bin_opt_info option. + Ts2 = [{bsm2, + Code, + [], + []}], + ?line [] = run(Config, Ts2), + ok. + +bin_construction(Config) when is_list(Config) -> + Ts = [{bin_construction, + <<" + t() -> + Bin = <<1,2,3>>, + <<Bin:4/binary>>. + + x() -> + Bin = <<1,2,3,7:4>>, + <<Bin/binary>>. + ">>, + [], + {warnings,[{4,sys_core_fold,embedded_binary_size}, + {8,sys_core_fold,{embedded_unit,8,28}}]}}], + ?line [] = run(Config, Ts), + + ok. + +%%% +%%% End of test cases. +%%% + +run(Config, Tests) -> + F = fun({N,P,Ws,E}, BadL) -> + case catch run_test(Config, P, Ws) of + E -> + BadL; + Bad -> + ?t:format("~nTest ~p failed. Expected~n ~p~n" + "but got~n ~p~n", [N, E, Bad]), + fail() + end + end, + lists:foldl(F, [], Tests). + + +%% Compiles a test module and returns the list of errors and warnings. + +run_test(Conf, Test0, Warnings) -> + Filename = 'warnings_test.erl', + ?line DataDir = ?privdir, + ?line Test = ["-module(warnings_test). ", Test0], + ?line File = filename:join(DataDir, Filename), + ?line Opts = [binary,export_all,return|Warnings], + ?line ok = file:write_file(File, Test), + + %% Compile once just to print all warnings. + ?line compile:file(File, [binary,export_all,report|Warnings]), + + %% Test result of compilation. + ?line Res = case compile:file(File, Opts) of + {ok, _M, Bin, []} when is_binary(Bin) -> + []; + {ok, _M, Bin, Ws0} when is_binary(Bin) -> + %% We are not interested in warnings from + %% erl_lint here. + WsL = [{F,[W || {_,Mod,_}=W <- Ws, + Mod =/= erl_lint]} || + {F,Ws} <- Ws0], + case WsL of + [{_File,Ws}] -> {warnings, Ws}; + _ -> list_to_tuple([warnings, WsL]) + end + end, + file:delete(File), + Res. + +fail() -> + io:format("failed~n"), + ?t:fail(). diff --git a/lib/compiler/vsn.mk b/lib/compiler/vsn.mk new file mode 100644 index 0000000000..72abcdde10 --- /dev/null +++ b/lib/compiler/vsn.mk @@ -0,0 +1 @@ +COMPILER_VSN = 4.6.4 |
