pax_global_header00006660000000000000000000000064124125403450014512gustar00rootroot0000000000000052 comment=06281969dee2b17a0b56ccd1155dba61f0c6fe7f js_of_ocaml-2.5/000077500000000000000000000000001241254034500136335ustar00rootroot00000000000000js_of_ocaml-2.5/.gitignore000066400000000000000000000022571241254034500156310ustar00rootroot00000000000000# Boring file regexps: # C object files *.o *.a *.so # Ocaml object files *.cmi *.cmo *.cmx *.cma *.cmxa *.cmxs *.cmjs # backup files *~ # Specific to Js_of_ocaml *.byte *.tmpjs *.map lib/stubs.c lib/sys_js.ml runtime/runtime.js toplevel/toplevel.js toplevel/eval.js toplevel/toplevel-fs.js toplevel/*.cmis.js toplevel/server examples/wiki/wikicreole.ml examples/*/*.js compiler/js_of_ocaml compiler/jsoo_minify compiler/js_lexer.ml compiler/js_parser.ml compiler/js_parser.mli compiler/compiler_version.ml compiler/man jsoo_tools/jsoo_mktop jsoo_tools/jsoo_mkcmis jsoo_tools/jsoo_mktop.opt jsoo_tools/jsoo_mkcmis.opt compiler/util.ml compiler/annot_lexer.ml compiler/annot_parser.ml compiler/annot_parser.mli compiler/*.conflicts doc/api/html benchmarks/build benchmarks/results benchmarks/config lib/deriving_json/deriving_Json_lexer.ml Makefile.local # OCamlbuild dir ocamlbuild/_build/ doc/ocsigen.org-data doc/api/wiki/ doc/manual/files/boulderdash/ doc/manual/files/cubes/ doc/manual/files/graph_viewer/ doc/manual/files/hyperbolic/ doc/manual/files/minesweeper/ doc/manual/files/planet/ doc/manual/files/toplevel/ doc/manual/files/webgl/ doc/manual/files/wiki/ doc/manual/files/wysiwyg/ js_of_ocaml-2.5/.jenkins.sh000066400000000000000000000007341241254034500157120ustar00rootroot00000000000000 opam pin add --no-action js_of_ocaml . opam install deriving tyxml reactiveData opam install --deps-only js_of_ocaml opam install --verbose js_of_ocaml do_build_doc () { opam install ocp-indent.1.4.1 optcomp higlo base64 make -C doc clean make -C doc doc make -C doc wikidoc cp -Rf doc/manual/files/* ${MANUAL_FILES_DIR}/ cp -Rf doc/manual/src/* ${MANUAL_SRC_DIR}/ cp -Rf doc/api/wiki/*.wiki ${API_DIR}/ } do_remove () { opam remove --verbose js_of_ocaml } js_of_ocaml-2.5/.ocp-indent000066400000000000000000000000521241254034500156710ustar00rootroot00000000000000normal with=0 syntax=lwt mll max_indent=2 js_of_ocaml-2.5/CHANGES000066400000000000000000000276741241254034500146460ustar00rootroot00000000000000===== 2.5 (2014-09-30) ===== * Features/Changes ** Compiler: SourceMap improvement ** Compiler: remove registration of unused named value (wrt runtime) ** Compiler: Smarter inlining, Constant sharing, Switch generation ** Lib: Dom binding: *AttributeNS, *AttributeNode*, borderRadius ** Runtime: improve performence of string, array allocation * Misc: enable safestring for OCaml 4.02 * Commandline: switch to Cmdliner. Better -help + manpage * BugFixes ** Compiler: workaround a bug in ocaml 4.02 wrt debug section. ** Compiler: bug when generating minified JavaScript. ** Runtime: fix Obj.tag ** Runtime: fix internalmod wrt ocaml4.02 ===== 2.4.1 (2014-08-28) ===== * BugFixes ** Compiler: restore compatibility with ocaml 4.02 ** Runtime: fix caml_hash, Math.imul may give wrong results (#215) ** Lib: Graphics_js, update text drawing baseline ** Lib: Fix overuse of FormData in XmlHttpRequest (Tomohiro Matsuyama #214) ===== 2.4 (2014-08-08) ===== * Features/Changes ** Runtime: support for num (Ryan Goulden) ** Lib: initial support for Dom_svg ** Lib: introduce Jsonp module ** Lib: introduce JSON object binding ** Lib: introduce DomContentLoaded ** lib: introduce eventSource ** Lib: introduce js_of_ocaml.toplevel package ** Lib: various improvement: textContent,outerHTML,unload event,css properties ** Lib: complete binding of Js.array ** Lib: change signature of Sys_js.register_autoload ** Lib: sync js_of_ocaml.tyxml with latest tyxml ** Tools: helpers to build toplevel: jsoo_mktop, jsoo_mkcmis * BugFixes ** Compiler: generate js files with default permission, was 0o600 (#182) (Daniel Bünzli) ** Syntax: fix typing of method arguments ** Runtime: fix behaviour of Sys.argv (Tomohiro Matsuyama) ** Runtime: fix caml_js_meth_call ** Compiler: fix assert false when deadcode is off ** Compiler: fix compilation of Js.debugger ===== 2.3 (2014-06-30) ===== * Features/Changes ** Lib: remove deprecated Event_arrow ** Lib: introduce js_of_ocaml.tyxml ** Lib: introduce js_of_ocaml.weak (that loads weak.js) and remove predicate joo_weak ** Lib: introduce js_of_ocaml.log (Lwt logger) ** Lib: Dom_html.{range,selection} (Enguerrand Decorne) * BugFixes ** Compiler: fix traduction of Ult binop (#177) ** Compiler: fix the build of compiler.{cmxs,cma} (Stéphane Glondu) ** Compiler: fix traduction of logical shift right ** Runtime: fix marshaling (#176) ** Meta: update predicates (joo_* -> jsoo_*) ** Lib: fix class type Dom_html.optionElement ===== 2.2 (2014-05-15) ===== * Features/Changes ** Runtime: improve blit_string perf ** Compiler: option to warn about unused js variable ** Lib: audio/videoElement * BugFixes ** Syntax: catch exception in syntax extension (#158) ** Compiler: compat with Node.js (global object) (#160) ** Runtime: fix graphics.js ** Lib: fix Dom.event interface ===== 2.1 (2014-04-28) ===== * Features/Changes ** Runtime: bigarray comparison ** Compiler: allow to embed directory with -file dir_name=ext1,ext2:dest_path ** Compiler: can now output embeded files in a differant js file ** Lib: js_of_ocaml.graphics ** Lib: Js.Unsafe.expr to embed JavasScript expression to be used instead of Js.Unsafe.variable (or eval_string) ** Lib: Sys_js.js_of_ocaml_version && Sys_js.file_content ** OCamlbuild plugin: Add the OASIS support, document the API and add the tags sourcemap (included in the meta-tag debug) and tailcall (#148) (by Jacques-Pascal Deplaix) * BugFixes ** Syntax: Better type constraint (#84) ** Compiler: caml_failwith primitive was sometime missing (#147) ** Compiler: variable names used outside a program were not marked as reserved (#146) ** Lib: fix WebGl interface ===== 2.0 (2014-04-11) ===== * Features/Changes ** Compiler: generate shorter variable names ** Parsing and minifying of external javascript file (ie: runtime) (by Hugo Heuzard) ** Compiler: JavaScript strict mode enabled ** Runtime: add support for recursive module (by Hugo Heuzard) ** Compiler: use trampoline to implement tailcall optim (by Hugo Heuzard) ** Improved OCaml toplevel UI (by Hugo Heuzard) ** Toplevel: support dynamic loading of cmo and cma files ** Runtime: add Bigarray support (contributed by Andrew Ray) ** Library: switch from "float Js.t" to just "float" for typing JavaScript numbers ** Compiler: Add javascript file lookup using findlib (+mypkg/myfile.js will read myfile.js from mypkg findlib directory) (by Hugo Heuzard) ** Compiler: improve missing primitives & reserved name detection (by Hugo Heuzard) ** Compiler: static evaluation of constant ("staticeval" optimisation) (by Hugo Heuzard) ** Compiler: share constants (by Hugo Heuzard) ** Compiler: alias primitives (by Hugo Heuzard) ** Compiler: complete javacript ast (by Hugo Heuzard) ** Compiler: 'caml_format_int %d x' compiles to ""+x (by Hugo Heuzard) ** Add JavaScript file in META (to be used with ocamlfind) (by Hugo Heuzard) ** Add Ocamlbuild plugin js_of_ocaml.ocamlbuild (by Jacques-Pascal Deplaix) ** Add/Install classlist.js, weak.js ** Add Url.Current.protocol (by Vicent Balat) ** Dependency: deriving instead of deriving-ocsigen ** Runtime: log wrong string encoding issues to the console (by Hugo Heuzard) ** Add compiler_libs (by Pierre Chambart) ** Compile syntax extension to native code as well (by Hugo Heuzard) ** Add a JavaScript parser (extracted from facebook/pfff) ** Compiler: remove redundant 'var' (by Hugo Heuzard) ** Compiler: improve compact mode, remove unnecessary space, semicolon ** Runtime: Support in_channel and out_channel (by Hugo Heuzard) ** Compiler: option to embed files into the generated js such files can be read using open_in (by Hugo Heuzard) ** Runtime: add cache for method lookup (by Hugo Heuzard) ** Compiler: experimental sourcemap support (by Hugo Heuzard) ** JavaScript Errors are now wrapped inside OCaml exceptions (by Hugo Heuzard) * BugFixes ** Compiler: js file is not create in case of error (by Hugo Heuzard) ** Fix compatibility when using type covn (by Hugo Heuzard) ** Fix md5 : incorrect for string where (length % 64) E 56..59 (by Grégoire Henry) ** Fix caml_js_new: when called with more than 8 arguments ** Address a number of integer overflow issues (by Hugo Heuzard) ** Fix float comparisons (NaN was not compared correctly) ===== 1.4 (2013-12-03) ===== * Features/Changes ** Add missing primitives for OCaml 4.01 ** Improved Dom bindings (Hugo Heuzard and many other contributors) ** Add -linkall option to keep all provided primitives (Pierre Chambard) ** Improved tail-call optimization (Hugo Heuzard) ** Added optimization levels: -o {1,2,3} (Hugo Heuzard) * Bugfixes ** Fixed some incorrect Dom bindings ** Fixed hypot primitive (Pierre Chambard) ** Fixed tail call optimization bug (some incorrect code was generated when the number of arguments did not match the number of function parameters) ** Fixed a bug with empty strings ** Fixed weak.js (primitives for Weak module) ===== 1.3 (2012-11-28) ===== * Features/Changes ** Runtime and toplevel updates to support OCaml 4.0 ** Add WebSocket bindings ** Added -debuginfo option to output source code location information (patch by Kensuke Matsuzaki) ** Dom_html: added change, input and hashChange event bindings ** Adding Lwt_js_events.async_loop and buffered_loop * Bugfixes ** Fix array and string blitting with overlapping regions ** Url module: fix encoding of '+' ** Library: use 'this' instead of 'window' for better portability ** Dom_html: fix creation of elements with type or name attribute under IE 9 ** Compiler: small fix to bytecode parsing that could result in incorrect generated code ** Dom_html: fix mouse wheel event bindings ** Dom: fix the type of item methods ** Deriving_json: tail-recursive serialisation of lists (by Hugo Heuzard) ** Deriving_json: fix parsing of float arrays and polymorphic variants (by Hugo Heuzard) ===== 1.2 (2012-06-02) ===== * Bugfixes ** Fix #284 ** Fix return type of window##open_ * Features/Changes ** Improvements in the data-flow solver ** Add Dom_html.window##onscroll ** Dom_events.listen: handler should return boolean ** Add DOM drag/drop events ===== 1.1.1 (2012-03-15) ===== * Bugfixes: ** Url parsing. ** webgl binding types * webgl example ===== 1.1 (2012-02-24) ===== * Libraries: ** Lots of new dom bindings ** WebGL ** Typed arrays ** Many speed improvement (marshal, strings, regexps) ** Many bug fixed * Compiler: ** Add -I option to select directories containing cmi files ** Fix compilation of mutually recursive functions occuring in loops ** In Javascript output, parenthesize numbers when followed by a dot ** Fix order of evaluation bug ** Fix compilation of loops in 'try ... with' body (close #263) * hyperbolic tree example ===== 1.0.9 (2011-11-30) ===== * Bugfixe in polymorphic comparison. ===== 1.0.8 (2011-11-25) ===== * Compatibility with deriving-0.3 * Libraries: ** Adding Event_arrows.iter ** Events: adding Dom_html.stopPropagation and ?propagate parameter in Event_arrows ===== 1.0.7 (2011-11-18) ===== * Bugfixes: ** Deriving_json: fix string (un)marshaling (was broken for byte > 127) ** Do not emit string escape sequence \\v (not supported by IE8) ** Removed incorrect optimization of !(x < y) into (x >= y) ** Allow compilation on win32/msvc ** Open all files in binary mode * Libraries: ** Add Dom_html.buttonPressed ** Add functions to downcast Dom_html.event into mouseEvent, keyboardEvent, ... ** Add Dom.document.adoptNode ** removed Date.now() function, not supported by all browsers ** Allow to test the button associated to a Dom_html.mouseEvent ** Add localStorage and sessionStorage api ===== 1.0.6 (2011-09-28) ===== * Bugfixes: ** browser compatility for Regexp.search and check_headers (XmlHttpRequest.send). * Libraries: ** add Dom_html.iFrameEliom##width ** add Dom_html.window##scroll ** add Dom.document##importNode ===== 1.0.5 (2011-09-21) ===== * Bugfixes: ** array_get/set bound check * Libraries: ** XmlHttpRequest: allow to cancel ta XHR after receiving the HTTP headers ** Added the [CSS.Angle] module to handle angles in CSS ===== 1.0.4 (2011-09-07) ===== * Bugfixes: ** fix typo in 'greater than or equal to' ** marshaling, unmarshaling and comparison are not recursive anymore: avoid stack overflow ** use custom formatter to pretty print Javascript code to avoid newlines where it is forbidden. ** fix type of Dom.nodeList.item (was optdef, is now opt) ** fixes for internet explorer. ** fixes for bug exposed by Berke Durak's tool jsure. * Libraries: ** History API ** improvements of CSS module ** Add coercion and attribute manipulation functions in Dom module ===== 1.0.3 (2011-07-13) ===== * Bugfixes: ** 'caml_int_of_string' was incorrect for negative number ** Fixed misparenthesized Javascript 'new' expressions * Libraries: ** Add a CSS module ** export Form.form_elements ** add onsubmit method to Dom_html.formElement ** add classList property to dom elements ===== 1.0.2 (2011-04-13) ===== * Bugfixes: ** fix compilation of Int32/Nativeint ** fix compilation of self-recursive functions in loops ** fix to File module for when there is no FileReader class in the host browser ** fixed big in weak support * Compiler: ** Switch licence to LGPL ** API to generate a function instead of a standalone program ** option to compile an OCaml toplevel * Libraries: ** Add an optionnal JSON deriving class ** Add Math.random binding ** Add scrollWidth/scrollHeight element methods to the DOM ** Add coercion function Dom_html.CoerceTo.element ** Renaming functions in XmlHttpRequest: *** send -> perform *** send_string -> perform_raw_url ===== 1.0.1 (2011-01-26) ===== * Bugfixes: ** conversion of Int64 to string. ** typos. * Allow use of Lwt.pause. * Split ocamlfind packages in two: syntax and library. ===== 1.0 (2010-12-13) ===== Initial release js_of_ocaml-2.5/LICENSE000066400000000000000000001320061241254034500146420ustar00rootroot00000000000000In the following, "the Compiler and Library" refers to all files marked "Copyright CNRS Université Paris Diderot" in the following directories and their sub-directories: compiler, lib, runtime, toplevel, tools and "the Examples" refers to all files marked "Copyright CNRS Université Paris Diderot" in directory "examples" and its sub-directories. The Compiler and Library are distributed under the terms of the GNU Library General Public License version 2 (included below). The Examples are distributed under the terms of the GNU Library General Public License version 2 (included below). As a special exception to the GNU Library General Public License, you may link, statically or dynamically, a "work that uses the Library" with a publicly distributed version of the Library to produce an executable file containing portions of the Library, and distribute that executable file under terms of your choice, without any of the additional requirements listed in clause 6 of the GNU Library General Public License. By "a publicly distributed version of the Library", we mean either the unmodified Library, or a modified version of the Library that is distributed under the conditions defined in clause 3 of the GNU Library General Public License. This exception does not however invalidate any other reasons why the executable file might be covered by the GNU Library General Public License. ---------------------------------------------------------------------- GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Lesser General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. ---------------------------------------------------------------------- GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! js_of_ocaml-2.5/Makefile000066400000000000000000000044471241254034500153040ustar00rootroot00000000000000 all: no_examples examples no_examples: build doc build: check_lwt compiler library ocamlbuild runtime jsoo_tools toplevel_lib include Makefile.conf -include Makefile.local .PHONY: all no_examples compiler library ocamlbuild runtime examples check_lwt doc build jsoo_tools toplevel_lib toplevel compiler: $(MAKE) -C compiler all lib library: $(MAKE) -C lib runtime: $(MAKE) -C runtime jsoo_tools: compiler $(MAKE) -C jsoo_tools toplevel_lib: compiler $(MAKE) -C lib toplevel_lib ocamlbuild: $(MAKE) -C ocamlbuild examples: compiler library runtime $(MAKE) -C examples doc: library ocamlbuild $(MAKE) -C doc toplevel: $(MAKE) -C toplevel tests: compiler library runtime $(MAKE) -C tests phantomtests: compiler library runtime $(MAKE) -C tests phantom LWTERROR="Js_of_ocaml requires Lwt version 2.3.0 at least. Please upgrade." check_lwt: @if ocamlfind query lwt -l | ocaml tools/check_version.ml 2.3.0; then \ echo $(LWTERROR); exit 1; \ fi include Makefile.filelist VERSION := $(shell head -n 1 VERSION) install: install-lib install-bin install-lib: ocamlfind install -patch-version ${VERSION} $(LIBRARY) lib/META $(INTF) $(IMPL) $(OTHERS) $(DOC) $(COMP_INTF) $(COMP_IMPL) install-bin: install -d -m 755 $(BINDIR) install $(BIN) $(BINDIR) install $(TOOLS) $(BINDIR) uninstall: uninstall-lib uninstall-bin uninstall-lib: ocamlfind remove $(LIBRARY) uninstall-bin: rm -f $(BINDIR)/$(COMPILER) rm -f $(BINDIR)/$(MINIFIER) rm -f $(BINDIR)/$(MKTOP) rm -f $(BINDIR)/$(MKCMIS) reinstall: uninstall install depend: $(MAKE) -C compiler depend $(MAKE) -C lib depend clean: $(MAKE) -C compiler clean $(MAKE) -C jsoo_tools clean $(MAKE) -C lib clean $(MAKE) -C ocamlbuild clean $(MAKE) -C runtime clean $(MAKE) -C toplevel clean $(MAKE) -C examples clean ifeq ($(wildcard tests),tests) $(MAKE) -C tests clean $(MAKE) -C doc clean endif realclean: clean find . -name "*~" -print | xargs rm -f find . -name "*.tmpjs" -print | xargs rm -f find . -name "#*" -print | xargs rm -f dist: rm -rf /tmp/js_of_ocaml-${VERSION} &&\ cd /tmp &&\ git clone https://github.com/ocsigen/js_of_ocaml.git js_of_ocaml-${VERSION} &&\ (cd js_of_ocaml-${VERSION}; git checkout ${VERSION}) &&\ tar zcvf js_of_ocaml-${VERSION}.tar.gz js_of_ocaml-${VERSION} --exclude benchmarks --exclude .git --exclude tests js_of_ocaml-2.5/Makefile.conf000066400000000000000000000024671241254034500162300ustar00rootroot00000000000000 # Where binaries are installed: BINDIR := `dirname \`which ocamlc\`` #### LIBRARY := js_of_ocaml LIBNAME := js_of_ocaml$(LIBEXT) COMPILER := js_of_ocaml$(EXEEXT) MINIFIER := jsoo_minify$(EXEEXT) MKTOP := jsoo_mktop$(EXEEXT) MKCMIS := jsoo_mkcmis$(EXEEXT) # opt/byte BEST := opt DOCOPT := -colorize-code -short-functors -charset utf-8 #### EXEEXT := OBJEXT := .o LIBEXT := .a DLLEXT := .so ifeq ($(shell ocamlc -v | grep -q "version 4"; echo $$?),0) OCAML4:="YES" WITH_TOPLEVEL =YES endif ifeq ($(shell ocamlc -safe-string 2> /dev/null ; echo $$?),0) SAFESTRING=-safe-string else SAFESTRING=-package bytes endif ### Optional dependencies: deriving WITH_DERIVING ?= $(shell if [ -f `ocamlfind query deriving 2> /dev/null`/deriving.cma ]; then echo YES; else echo NO; fi) WITH_GRAPHICS ?= $(shell if [ -f `ocamlfind query graphics 2> /dev/null`/graphics.cmi ]; then echo YES; else echo NO; fi) WITH_REACT ?= $(shell if [ -f `ocamlfind query reactiveData 2> /dev/null`/reactiveData.cma ]; then echo YES; else echo NO; fi) WITH_TYXML ?= $(shell if [ -f `ocamlfind query tyxml 2> /dev/null`/tyxml_f.cma ]; then echo YES; else echo NO; fi) NATDYNLINK ?= $(shell if [ -f `ocamlc -where`/dynlink.cmxa ]; then echo YES; else echo NO; fi) METAOCAML ?= 0 VERSION_GIT := $(shell git log -n1 --pretty=format:%h 2> /dev/null) js_of_ocaml-2.5/Makefile.filelist000066400000000000000000000042111241254034500171030ustar00rootroot00000000000000BIN := compiler/${COMPILER} compiler/${MINIFIER} TOOLS := jsoo_tools/${MKTOP} jsoo_tools/${MKCMIS} INTF := lib/*.cmi IMPL := lib/$(LIBNAME).cma \ lib/syntax/pa_js.cmo \ lib/dll$(LIBNAME)$(DLLEXT) \ lib/lib$(LIBNAME)$(LIBEXT) INTF += lib/log/*.cmi IMPL += lib/log/logger.cma ifeq "${BEST}" "opt" ifeq "${NATDYNLINK}" "YES" IMPL += lib/syntax/pa_js.cmx lib/syntax/pa_js.cmxs endif endif ifeq "${WITH_GRAPHICS}" "YES" IMPL += lib/graphics/graphics.cma INTF += lib/graphics/*.cmi endif ifeq "${WITH_TYXML}${WITH_REACT}" "YESYES" IMPL += lib/tyxml/tyxml.cma INTF += lib/tyxml/*.cmi endif ifeq "${WITH_TOPLEVEL}" "YES" IMPL += lib/toplevel/jsooTop.cmo INTF += lib/toplevel/jsooTop.cmi endif OTHERS := runtime/runtime.js runtime/weak.js \ runtime/polyfill/classlist.js \ runtime/polyfill/array.js \ runtime/toplevel.js \ runtime/graphics.js \ runtime/nat.js \ COMP_INTF := compiler/compiler.cmi COMP_IMPL := compiler/compiler.cma COMP_NAT_IMPL := compiler/compiler.cmxa compiler/compiler.a compiler/compiler.cmx COMP_NATDYN_IMPL := compiler/compiler.cmxs OCAMLBUILD_IMPL := ocamlbuild_js_of_ocaml.cma INTF += ocamlbuild/_build/ocamlbuild_js_of_ocaml.cmi ifeq "${BEST}" "opt" OCAMLBUILD_IMPL += ocamlbuild_js_of_ocaml.cmxa ocamlbuild_js_of_ocaml.a ifeq "${NATDYNLINK}" "YES" OCAMLBUILD_IMPL += ocamlbuild_js_of_ocaml.cmxs endif endif IMPL += $(addprefix ocamlbuild/_build/,$(OCAMLBUILD_IMPL)) ifeq "${WITH_DERIVING}" "YES" JSON := lib/deriving_json/deriving_Json.cmi \ lib/deriving_json/deriving_Json_lexer.cmi INTF += $(JSON) INTF += lib/syntax/pa_deriving_Json.cmi IMPL += lib/syntax/pa_deriving_Json.cmo \ lib/syntax/pa_deriving_Json.cmi \ lib/deriving_json.cma NATIMPL := lib/deriving_json.cmxa \ lib/deriving_json.cmxs \ lib/deriving_json$(LIBEXT) \ NATIMPL += $(JSON:.cmi=.cmx) ifeq "${NATDYNLINK}" "YES" NATIMPL += lib/syntax/pa_deriving_Json.cmx \ lib/syntax/pa_deriving_Json.cmxs COMP_IMPL += $(COMP_NATDYN_IMPL) endif ifeq "$(BEST)" "opt" IMPL += $(NATIMPL) COMP_IMPL += $(COMP_NAT_IMPL) endif endif DOC := ${INTF:.cmi=.mli} js_of_ocaml-2.5/Makefile.toplevel000066400000000000000000000006651241254034500171330ustar00rootroot00000000000000 #opam pin add tyxml git@github.com:ocsigen/tyxml.git #opam pin add js_of_ocaml ./ BASE=camlp4 lwt menhir deriving tyxml ocamlfind optcomp higlo \ reactiveData react.1.2.0 base64 ocp-indent.1.4.2 current: @opam switch show opam install $(BASE) $(MAKE) METAOCAML=`(type -p metaocaml > /dev/null && echo 1)` toplevel mkdir -p toplevel/`opam switch show`/ cp toplevel/*.cmis.js toplevel/toplevel.js toplevel/`opam switch show`/ js_of_ocaml-2.5/README.md000066400000000000000000000077561241254034500151310ustar00rootroot00000000000000# Js_of_ocaml (jsoo) Js_of_ocaml is a compiler from OCaml bytecode to Javascript. It makes OCaml programs run on Web browsers. * It is easy to install and use as it works with an existing installation of OCaml, with no need to recompile any library. * It comes with bindings for a large part of the browser APIs. * According to our benchmarks, the generated programs runs typically faster than with the OCaml bytecode interpreter. * We believe this compiler will prove much easier to maintain than a retargeted OCaml compiler, as the bytecode provides a very stable API. ## Requirements * Findlib: **version 1.5.1** at least * Lwt: **version 2.3.0** at least * Menhir * Cmdliner ### optional * [deriving](https://github.com/ocsigen/deriving): **version 0.6** at least ### Toplevel requirements * optcomp, base64 * ocp-indent: needed to support indentation in the toplevel * higlo: needed to support Syntax highlighting in the toplevel * cohttp: needed to build the toplevel webserver ## Installation ###Opam ``` opam install deriving js_of_ocaml ``` ###Manual * edit `Makefile.conf` to change the default configuration * run `make` to compile * run `make install` as root to install the compiler and its libraries * run `make uninstall` as root to uninstall them You can run `make toplevel` if you want to build a Web-based OCaml toplevel as well. [Try the toplevel](http://ocsigen.github.io/js_of_ocaml/) ## Usage Your program must first be compiled using the OCaml bytecode compiler `ocamlc`. Javascript bindings are provided by the `js_of_ocaml` package. The syntax extension is provided by `js_of_ocaml.syntax` package. ``` ocamlfind ocamlc -package js_of_ocaml -syntax camlp4o -package js_of_ocaml.syntax -linkpkg -o cubes.byte cubes.ml ``` Then, run the `js_of_ocaml` compiler to produce Javascript code: ``` js_of_ocaml cubes.byte ``` ## Features Most of the OCaml standard library is supported. However, * Weak semantic cannot be implemented using javascript. A dummy implementation is available (use `+weak.js` option) * Most of the Sys module is not supported. Extra libraries distributed with Ocaml (such as Thread or Str) are not supported in general. However, * Bigarray: bigarrays are supported using Typed Arrays * Num: supported using `+nat.js` option * Graphics: partially supported using canvas (see also js_of_ocaml.graphics) * Unix: time related functions are supported Tail call is not optimized in general. However, mutually recursive functions are optimized: * self recursive functions (when the tail calls are the function itself) are compiled using a loop. * trampolines are used otherwise. Data representation differs from the usual one. Most notably, integers are 32 bits (rather than 31 bits or 63 bits), which is their natural size in JavaScript, and floats are not boxed. As a consequence, marshalling, polymorphic comparison, and hashing functions can yield results different from usual: * marshalling of floats is not supported (unmarshalling works); * the polymorphic hash function will not give the same results on datastructures containing floats; * these functions may be more prone to stack overflow. ## Toplevel * [Ocaml 4.01.0](http://ocsigen.github.io/js_of_ocaml/#version=4.01.0) * [Ocaml 4.01.0+BER](http://ocsigen.github.io/js_of_ocaml/#version=4.01.0+BER) : MetaOcaml * [Ocaml 4.02.0](http://ocsigen.github.io/js_of_ocaml/#version=4.02.0) ## Contents of the distribution | Filename | Description | |-----------|----------------------------------------------| | LICENSE | license and copyright notice | | README | this file | | compiler/ | compiler | | examples/ | small examples | | lib/ | library for interfacing with Javascript APIs | | runtime/ | runtime system | | toplevel/ | web-based OCaml toplevel | js_of_ocaml-2.5/TODO.txt000066400000000000000000000142501241254034500151430ustar00rootroot00000000000000Libraries ========= - object literals {:m = 1; n = "abcd":} : [> `m of int; `n of string] Js.record Js.t ==> usual rule for mapping field names; check for no duplicate. - array literals in particular, heterogeneous arrays... ('a, 'b, 'c) t ??? module Tuple : sig type 'a tuple val e : unit tuple val a : 'a tuple -> 'b -> ('a * 'b) tuple type ('a, 'b) acc val first : ('a * 'b, 'b) acc val next : ('a, 'b) acc -> ('c * 'a, 'b) acc val get : 'a tuple -> ('a, 'b) acc -> 'b val set : 'a tuple -> ('a, 'b) acc -> 'b -> unit end = struct type 'a tuple = 'a let e = () let a x y = (x, y) end <_0: t0; _1: t1; _n: tn> t Benchmarks/examples =================== - polishing - check canvas availability in examples - finish planet (no cpu when not moving / not visible) - take examples from http://shootout.alioth.debian.org/? - planets (+satellites?) ===> Runge-Kutta - 3D effects: http://gyu.que.jp/jscloth/ http://stackoverflow.com/questions/1584854/how-to-draw-3d-sphere Compiler optimizations ====================== - "unsafe" option: no check for division by zero / array access - per module options: we could apply "unsafe" and "inline" options selectively - fix control.ml - syntactic sugar for Javascript literal strings + optimization to avoid going through Caml strings - Can we avoid spurious conversions from boolean to integers??? ===> explicit conversion to boolean; specialized "if" that operates on booleans directly - constant hoisting (including functions, out of loops and functions) - inline also partially applied functions - we should check stack compatibility when parsing: when jumping somewhere, the stack should keep the same shape - Improved optimizations ==> cross-function optimizations ==> deadcode elimination inside blocks (for instance, elimination of function which are defined in a functor but are not used) ========================== ========================== Special case for shortcut boolean operations... 1 |\ | \2 | /\ |/ \ 3 4 ========================== MD5 === http://www.myersdaily.org/joseph/javascript/md5-speed-test.html http://code.google.com/p/crypto-js/source/browse/trunk/src/Crypto.js http://bitwiseshiftleft.github.com/sjcl/ Float <-> hex ============= http://babbage.cs.qc.edu/IEEE-754/js/IEEE-754.js http://snippets.dzone.com/posts/show/685 http://jsfromhell.com/classes/binary-parser Filling a string ================ function stringFill3(x, n) { var s = ''; for (;;) { if (n & 1) s += x; n >>= 1; if (n) x += x; else break; } return s; } Conversion string <-> array =========================== http://code.google.com/p/crypto-js/source/browse/trunk/src/Crypto.js Byte array ==> string ===================== int array --map--> string array --join--> string b[i] = toString[a[i]] where toString is a precomputed array of strings Bigint ====== http://www.leemon.com/crypto/BigInt.js ========================== BUGS ==== - ISINT is compiled to "not a block"; document this deviation (or document that we should not rely on the Obj module) PERFORMANCE =========== - should we rebind variables from a deeper level ? (only if used more than once...) var x = ... function () { var y = x; ... y .... y ... y .... } IMPROVEMENTS ============ - be more cautious regarding how we print floats... (is it accurate?) ==> gdtoa http://caml.inria.fr/pub/ml-archives/caml-list/2002/12/2813f8e8be115b0bad1bc16b1e41b744.en.html - explicit conversion from int to boolean - simplify conditional definition should be: Cond of Var.t * cont * cont (we need to eliminate unnecessary conversions from bool to integer for that) NEW FEATURES ============ - dynamic linking? (code generation from cmo files) - Can we use the debugger information to generate specialized code? (Use objects rather than arrays for tuples, ...) DATA REPRESENTATION =================== - should wrap Ocaml exceptions (more robust code)... ==> use Error object as base object, special "message" method DATA ANALYSIS ============= - interprocedural analysis COMPRESSION OPTIMIZATION ======================== - http://timepedia.blogspot.com/2009/08/on-reducing-size-of-compressed.html http://timepedia.blogspot.com/2009/11/traveling-salesman-problem-and.html ==> order functions by similarity ==> 7-zip is better at compressing than gzip, with the same algorithm... DOCUMENTATION ============= document as much as we can: * the representation of datas, closures, ... * the assumption we make regarding the bytecode ==> ISINT ================================ REFERENCES ========== http://blog.higher-order.net/2009/09/08/understanding-clojures-persistenthashmap-deftwice/ http://code.google.com/closure/compiler/ http://code.google.com/p/ocamljs/source/browse/#svn/trunk/src Inlining: see Manuel Serrano's paper Resolving and Exploiting the k-CFA Paradox Illuminating Functional vs. Object-Oriented Program Analysis Matthew Might Yannis Smaragdakis David Van Horn ================================== Use window.postMessage instead of setTimeout for yield (setTimeout always waits a bit!) ==> but window.postMessage is synchronous in IE8 + does not cooperate well with other users of message events ================================== Could we generate ocaml bytecode as well? (bytecode optimizer) LLVM code? Targeting JAVA / .net seem harder: not type information... ================================== http://www.pps.jussieu.fr/~montela/ocamil/ Note that the OCamIL compilers and tools are currently based on OCaml v3.06. An upgrade to the latest OCaml version is scheduled for the next release. [Never happened...] ocamldefun (on ocaml_beginners) I'd really like to play around ocamldefun, but it seems to only work with ocaml 3.06. Has anyone had luck setting this up in more recent versions of ocaml? OCamlexc (on caml list) So I was wondering if there is any current or recent projects (or interests) to resume OCamlExc development and complete the set of handled constructs, as I'm afraid I'll have neither the time nor the skills to do the job. js_of_ocaml-2.5/VERSION000066400000000000000000000000041241254034500146750ustar00rootroot000000000000002.5 js_of_ocaml-2.5/benchmarks/000077500000000000000000000000001241254034500157505ustar00rootroot00000000000000js_of_ocaml-2.5/benchmarks/Makefile000066400000000000000000000160221241254034500174110ustar00rootroot00000000000000# graphs without precompiled programs: GRAPHSNOPR = time.pdf time-optim.pdf time-ocamljs.pdf nativejs.pdf # graphs with precompiled programs: GRAPHSPR = size.pdf size-ocamljs.pdf size-optim.pdf compiletime.pdf # For full benchs: all: _perf graphsnopr graphspr _noperf graphsnopr: _noprecomp $(GRAPHSNOPR) graphspr: __precomp $(GRAPHSPR) # For fast benchs: test: _perf fastrun $(GRAPHS) _noperf exes= $(wildcard programs/*) exesnames = $(exes:programs/%=%) missingsizesml = $(exesnames:%=results/sizes/ml/%) missingsizesocamljs = $(exesnames:%=results/sizes/ocamljs/%) missingsizes=$(missingsizesml) $(missingsizesocamljs) missingcompiletimes = $(exesnames:%=results/compiletimes/`hostname`/byte/%) $(exesnames:%=results/compiletimes/`hostname`/opt/%) possiblymissingbenchs = results/times/`hostname`/nitro/js_of_ocaml/kb results/times/`hostname`/tm/js_of_ocaml/hamming results/times/`hostname`/tm/js_of_ocaml/splay OCAML=ocaml unix.cma RUN=$(OCAML) ./run.ml REPORT=$(OCAML) ./report.ml .PHONY: $(GRAPHSNOPR:.pdf=.svg) $(GRAPHSPR:.pdf=.svg) size.gpl _noprecomp # compile with precompiled programs for creating benchs __precomp: mkdir -p build/byte ln -sf $(exes:%=../../%) build/byte if [ ! -d precomptmp ] ; then $(RUN) -compile ; else cd precomptmp ; find . -type f -exec mv {} ../{} \; ; fi rm -rf precomptmp touch __precomp # for running the test we do not want precompiled programs __run: make _noprecomp $(RUN) -all make __possiblymissingbenchs touch __run fastrun: make _noprecomp echo "======================== WARNING: fast benchs!" $(RUN) -ffast -all make __possiblymissingbenchs touch __run _noprecomp: if [ -f __precomp ] ; \ then \ rm -f __precomp ;\ mkdir -p precomptmp/build/byte ;\ mkdir -p build ;\ mkdir -p results ;\ find build -type d -exec mkdir -p precomptmp/{} \; ;\ find results -type d -exec mkdir -p precomptmp/{} \; ;\ for i in $(exesnames) ; do if [ -f build/byte/$$i ] ; then mv -f build/byte/$$i precomptmp/build/byte/ ; fi ; done ;\ for i in $(exesnames) ; do for j in build/*/$$i.js ; do if [ -f $$j ] ; then mv $$j precomptmp/$$j ; fi ; done ; done ;\ for i in $(exesnames) ; do for j in results/sizes/js_of_ocaml/*/$$i ; do if [ -f $$j ] ; then mv $$j precomptmp/$$j ; fi ; done ; done ;\ for i in $(exesnames) ; do for j in results/sizes/*/$$i ; do if [ -f $$j ] ; then mv $$j precomptmp/$$j ; fi ;done ; done ;\ fi __missingcompiletimes: mkdir -p results/compiletimes/`hostname`/byte/ for i in $(missingcompiletimes) ; do if [ ! -f $$i ] ; then echo 0 > $$i ; fi ; done touch __missingcompiletimes __possiblymissingbenchs: for i in $(possiblymissingbenchs) ; do if [ ! -f $$i ] ; then echo 0 > $$i ; fi ; done touch __possiblymissingbenchs __missingsizes: __precomp for i in $(missingsizes) ; do if [ ! -f $$i ] ; then echo 0 > $$i ; fi ; done if [ -f results/sizes/ml/unison ] ; then echo 828471 > results/sizes/ml/unison ; fi if [ -f results/sizes/ml/ocamlc ] ; then echo 800771 > results/sizes/ml/ocamlc ; fi if [ -f results/sizes/ml/ocsigen_server ] ; then echo 0 > results/sizes/ml/ocsigen_server ; fi if [ -f results/sizes/ml/js_of_ocaml ] ; then echo 171361 > results/sizes/ml/js_of_ocaml ; fi if [ -f results/sizes/ml/boulderdash ] ; then echo 12920 > results/sizes/ml/boulderdash ; fi if [ -f results/sizes/ml/canvas ] ; then echo 740 > results/sizes/ml/canvas ; fi if [ -f results/sizes/ml/cubes ] ; then echo 3773 > results/sizes/ml/cubes ; fi if [ -f results/sizes/ml/minesweeper ] ; then echo 7106 > results/sizes/ml/minesweeper ; fi if [ -f results/sizes/ml/planet ] ; then echo 16488 > results/sizes/ml/planet ; fi if [ -f results/sizes/ml/sudoku ] ; then echo 2837 > results/sizes/ml/sudoku ; fi touch __missingsizes # file sizes (without comments and spaces) # find ../examples/sudoku/ -name "*.ml" -exec cat {} \; | perl /home/balat/kroko/js_of_ocaml/benchmarks/lib/remove_comments.pl | sed 's/^ *//g' | wc -c # To generate SVG, we first need to run the benchs, # then to add data for precompiled programs time.svg: __run $(REPORT) -config report-time.config \ -omit binary_trees -omit fannkuch_redux -omit loop \ -max 5.5 -svg 7 500 150 -edgecaption -ylabel "Execution time" \ > $@ size.svg: size.gpl gnuplot < $^ > $@ size.gpl: __run __missingsizes $(REPORT) -config report-size.config \ -omit binary_trees -omit fannkuch_redux -omit loop \ -omit fannkuch_redux_2 \ -omit boyer_no_exc -omit kb_no_exc \ -append boulderdash \ -append canvas \ -append cubes \ -append minesweeper \ -append planet \ -append sudoku \ -append js_of_ocaml \ -append ocsigen_server \ -append ocamlc \ -append unison \ -max 3 -ylabel Size -script \ -svg 7 650 150 \ | perl -pe 'BEGIN{undef $$/;} s/e\nplot/e\nset key at 23.75,1.80\nplot/smg' \ > $@ time-optim.svg: __run $(REPORT) -config report-time-optim.config \ -omit binary_trees -omit fannkuch_redux -omit loop \ -omit fannkuch_redux_2 \ -max 4 -svg 7 400 150 -edgecaption -ylabel "Execution time" \ > $@ size-optim.svg: __run __missingsizes $(REPORT) -config report-size-optim.config \ -omit binary_trees -omit fannkuch_redux -omit loop \ -omit fannkuch_redux_2 \ -omit boyer_no_exc -omit kb_no_exc \ -append boulderdash \ -append canvas \ -append cubes \ -append minesweeper \ -append planet \ -append sudoku \ -append js_of_ocaml \ -append ocsigen_server \ -append ocamlc \ -append unison \ -max 2.5 -svg 7 650 150 -edgecaption -ylabel Size \ > $@ time-ocamljs.svg: __run $(REPORT) -config report-time-ocamljs.config \ -omit binary_trees -omit fannkuch_redux -omit loop \ -omit fannkuch_redux_2 \ -max 5.5 -svg 7 500 150 -edgecaption -ylabel "Execution time" \ > $@ size-ocamljs.svg: __run __precomp $(REPORT) -config report-size-ocamljs.config -omit loop \ -omit binary_trees -omit fannkuch_redux \ -omit fannkuch_redux_2 \ -omit spectral_norm \ -omit boyer_no_exc -omit kb_no_exc \ -omit boulderdash \ -omit canvas \ -omit cubes \ -omit minesweeper \ -omit planet \ -omit sudoku \ -omit js_of_ocaml \ -omit ocsigen_server \ -omit ocamlc \ -omit unison \ -max 5.5 -svg 7 500 150 -edgecaption -ylabel Size \ > $@ compiletime.svg: __run __precomp __missingcompiletimes $(REPORT) -config report-compiletime.config \ -omit binary_trees -omit fannkuch_redux -omit loop \ -max 2 -svg 7 500 150 -edgecaption -ylabel "Compile time" \ > $@ nativejs.svg: __run $(REPORT) -config report-nativejs.config \ -omit binary_trees -omit fannkuch_redux -omit loop \ -max 2.8 -svg 7 200 150 -edgecaption -ylabel "Execution time" \ > $@ %.pdf: %.svg inkscape -D --export-pdf="$@" -w 210 -h 297 $< _perf: for i in /sys/devices/system/cpu/cpu* ; do if [ -f $$i/cpufreq/scaling_governor ] ; then sudo bash -c "echo performance > $$i/cpufreq/scaling_governor" ; fi ;done _noperf: for i in /sys/devices/system/cpu/cpu* ; do if [ -f $$i/cpufreq/scaling_governor ] ; then sudo bash -c "echo ondemand > $$i/cpufreq/scaling_governor" ; fi ; done clean: _noperf rm -rf results build __precomp __run *.svg *.pdf *~ precomptmp __missingsizes __missingcompiletimes __possiblymissingbenchs js_of_ocaml-2.5/benchmarks/lib/000077500000000000000000000000001241254034500165165ustar00rootroot00000000000000js_of_ocaml-2.5/benchmarks/lib/common.ml000066400000000000000000000145461241254034500203520ustar00rootroot00000000000000(* Js_of_ocaml benchmarks * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2011 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let (>>) x f = f x (****) let mean a = let s = ref 0. in for i = 0 to Array.length a - 1 do s := !s +. a.(i) done; !s /. float (Array.length a) let mean_variance a = let m = mean a in let s = ref 0. in for i = 0 to Array.length a - 1 do let d = a.(i) -. m in s := !s +. d *. d done; (m, !s /. float (Array.length a - 1)) (*90% 95% 98% 99% 99.5% 99.8% 99.9%*) let tinv_table = [|(1, [|6.314; 12.71; 31.82; 63.66; 127.3; 318.3; 636.6|]); (2, [|2.920; 4.303; 6.965; 9.925; 14.09; 22.33; 31.60|]); (3, [|2.353; 3.182; 4.541; 5.841; 7.453; 10.21; 12.92|]); (4, [|2.132; 2.776; 3.747; 4.604; 5.598; 7.173; 8.610|]); (5, [|2.015; 2.571; 3.365; 4.032; 4.773; 5.893; 6.869|]); (6, [|1.943; 2.447; 3.143; 3.707; 4.317; 5.208; 5.959|]); (7, [|1.895; 2.365; 2.998; 3.499; 4.029; 4.785; 5.408|]); (8, [|1.860; 2.306; 2.896; 3.355; 3.833; 4.501; 5.041|]); (9, [|1.833; 2.262; 2.821; 3.250; 3.690; 4.297; 4.781|]); (10, [|1.812; 2.228; 2.764; 3.169; 3.581; 4.144; 4.587|]); (11, [|1.796; 2.201; 2.718; 3.106; 3.497; 4.025; 4.437|]); (12, [|1.782; 2.179; 2.681; 3.055; 3.428; 3.930; 4.318|]); (13, [|1.771; 2.160; 2.650; 3.012; 3.372; 3.852; 4.221|]); (14, [|1.761; 2.145; 2.624; 2.977; 3.326; 3.787; 4.140|]); (15, [|1.753; 2.131; 2.602; 2.947; 3.286; 3.733; 4.073|]); (16, [|1.746; 2.120; 2.583; 2.921; 3.252; 3.686; 4.015|]); (17, [|1.740; 2.110; 2.567; 2.898; 3.222; 3.646; 3.965|]); (18, [|1.734; 2.101; 2.552; 2.878; 3.197; 3.610; 3.922|]); (19, [|1.729; 2.093; 2.539; 2.861; 3.174; 3.579; 3.883|]); (20, [|1.725; 2.086; 2.528; 2.845; 3.153; 3.552; 3.850|]); (21, [|1.721; 2.080; 2.518; 2.831; 3.135; 3.527; 3.819|]); (22, [|1.717; 2.074; 2.508; 2.819; 3.119; 3.505; 3.792|]); (23, [|1.714; 2.069; 2.500; 2.807; 3.104; 3.485; 3.767|]); (24, [|1.711; 2.064; 2.492; 2.797; 3.091; 3.467; 3.745|]); (25, [|1.708; 2.060; 2.485; 2.787; 3.078; 3.450; 3.725|]); (26, [|1.706; 2.056; 2.479; 2.779; 3.067; 3.435; 3.707|]); (27, [|1.703; 2.052; 2.473; 2.771; 3.057; 3.421; 3.690|]); (28, [|1.701; 2.048; 2.467; 2.763; 3.047; 3.408; 3.674|]); (29, [|1.699; 2.045; 2.462; 2.756; 3.038; 3.396; 3.659|]); (30, [|1.697; 2.042; 2.457; 2.750; 3.030; 3.385; 3.646|]); (40, [|1.684; 2.021; 2.423; 2.704; 2.971; 3.307; 3.551|]); (50, [|1.676; 2.009; 2.403; 2.678; 2.937; 3.261; 3.496|]); (60, [|1.671; 2.000; 2.390; 2.660; 2.915; 3.232; 3.460|]); (80, [|1.664; 1.990; 2.374; 2.639; 2.887; 3.195; 3.416|]); (100, [|1.660; 1.984; 2.364; 2.626; 2.871; 3.174; 3.390|]); (120, [|1.658; 1.980; 2.358; 2.617; 2.860; 3.160; 3.373|])|] let tinv_row n = let i = ref 1 in let l = Array.length tinv_table in while !i < l && fst tinv_table.(!i) <= n do incr i done; snd tinv_table.(!i - 1) let tinv95 n = (tinv_row n).(1) let tinv99 n = (tinv_row n).(3) let mean_with_confidence a = let (m, v) = mean_variance a in let l = Array.length a in (m, sqrt v /. sqrt (float l) *. tinv99 (l - 1)) (****) let src = "sources" let code = "build" let times = Filename.concat "results/times" (Unix.gethostname ()) let sizes = "results/sizes" let compiletimes = Filename.concat "results/compiletimes" (Unix.gethostname ()) let ml = ("ml", ".ml") let js = ("js", ".js") let byte = ("byte", "") let opt = ("opt", "") let js_of_ocaml = ("js_of_ocaml", ".js") let ocamljs = ("ocamljs", ".js") let byte_unsafe = ("unsafe/byte", "") let opt_unsafe = ("unsafe/opt", "") let js_of_ocaml_unsafe = ("unsafe/js_of_ocaml", ".js") let js_of_ocaml_inline = ("noinline", ".js") let js_of_ocaml_deadcode = ("nodeadcode", ".js") let js_of_ocaml_compact = ("notcompact", ".js") let js_of_ocaml_call = ("nooptcall", ".js") let ocamljs_unsafe = ("unsafe/ocamljs", ".js") (****) let no_ext (dir, _) = (dir, "") let file dir1 (dir2, ext) nm = Format.sprintf "%s/%s/%s%s" dir1 dir2 nm ext let dir dir1 (dir2, ext) = Format.sprintf "%s/%s" dir1 dir2 let sub_spec (dir, ext) loc = (Format.sprintf "%s/%s" dir loc, ext) (****) let rec mkdir d = if not (Sys.file_exists d) then begin mkdir (Filename.dirname d); Unix.mkdir d 0o777 end let need_update src dst = try let d = Unix.stat dst in d.Unix.st_kind <> Unix.S_REG || let s = Unix.stat src in d.Unix.st_mtime < s.Unix.st_mtime with Unix.Unix_error (Unix.ENOENT, _, _) -> true (****) let measures_need_update code meas spec nm = let p = file code spec nm in let m = file meas (no_ext spec) nm in need_update p m let read_measures meas spec nm = let m = file meas (no_ext spec) nm in let l = ref [] in if Sys.file_exists m then begin let ch = open_in m in begin try while true do l := float_of_string (input_line ch) :: !l done with End_of_file -> () end; close_in ch; !l end else [] let write_measures meas spec nm l = let m = file meas (no_ext spec) nm in let tmp = file meas (no_ext spec) "_tmp_" in mkdir (dir meas spec); let ch = open_out tmp in List.iter (fun t -> Printf.fprintf ch "%f\n" t) (List.rev l); close_out ch; Sys.rename tmp m (****) let benchs loc ((_, ext) as spec) = let dir = dir loc spec in Sys.readdir dir >> Array.to_list >> List.filter (fun nm -> let k = (Unix.stat (dir^"/"^nm)).Unix.st_kind in k = Unix.S_REG || k = Unix.S_LNK) >> List.filter (fun nm -> ext = "" || Filename.check_suffix nm ext) >> (if ext = "" then fun x -> x else List.map Filename.chop_extension) >> List.sort compare js_of_ocaml-2.5/benchmarks/lib/remove_comments.pl000077500000000000000000000001471241254034500222620ustar00rootroot00000000000000#!/usr/bin/perl $/ = undef; $_ = <>; s#\(\*[^*]*\*+([^)*][^*]*\*+)*\)#defined $2 ? $2 : ""#gse; print; js_of_ocaml-2.5/benchmarks/report-compiletime.config000066400000000000000000000006321241254034500227600ustar00rootroot00000000000000histogram compiletimes "" opt #729fcf ocamlopt histogram compiletimes "" byte #204a87 ocamlc histogramref compiletimes "" js_of_ocaml #d98e2d js_of_ocaml histogram compiletimes "" nodeadcode #fb3f00 No deadcode elimination histogram compiletimes "" noinline #fb7f1f No inlining histogram compiletimes "" nooptcall #a75f0c No call optimisation histogram compiletimes "" notcompact #fb5f0f No compact expression js_of_ocaml-2.5/benchmarks/report-js.config000066400000000000000000000001531241254034500210630ustar00rootroot00000000000000histogramref times v8 js_of_ocaml #d98e2d compiled to JS (V8) histogram times v8 js #d9112d native JS (V8) js_of_ocaml-2.5/benchmarks/report-nativejs.config000066400000000000000000000001531241254034500222720ustar00rootroot00000000000000histogram times v8 js #775588 native JS (V8) histogramref times v8 js_of_ocaml #fbaf4f compiled to JS (V8) js_of_ocaml-2.5/benchmarks/report-size-ocamljs.config000066400000000000000000000001751241254034500230530ustar00rootroot00000000000000histogramref sizes "" js_of_ocaml/gzipped #fbaf4f js_of_ocaml (gzipped) histogram sizes "" ocamljs #22bb22 Ocamljs (gzipped) js_of_ocaml-2.5/benchmarks/report-size-optim.config000066400000000000000000000007111241254034500225470ustar00rootroot00000000000000#histogram sizes "" unsafe/js_of_ocaml #fb9f3f Unsafe histogramref sizes "" js_of_ocaml/generated #fbaf4f Default #histogram sizes "" nooptcall #a75f0c no optimization of calls histogram sizes "" noinline #d98e2d no inlining histogram sizes "" notcompact #a75f0c no compact code histogram sizes "" nodeadcode #752d09 no dead code removal #histogram sizes "" ocamljs #227722 Ocamljs generated code #histogram sizes "" unsafe/ocamljs #229922 Ocamljs + unsafe js_of_ocaml-2.5/benchmarks/report-size.config000066400000000000000000000010011241254034500214120ustar00rootroot00000000000000histogram sizes "" ml #83afdf Source histogram sizes "" byte #204a87 Bytecode histogramref sizes "" js_of_ocaml/full #371f00 Runtime #histogram sizes "" ocamljs #22bb22 Ocamljs # second layer #histogram sizes "" ml #729fcf Source #histogram sizes "" byte #204a87 Bytecode #histogram sizes "" js_of_ocaml/generated #fbaf4f Generated code #histogram sizes "" ocamljs #22bb22 Ocamljs generated code histogram blank histogram blank histogram sizes "" js_of_ocaml/generated #fbaf4f Generated code #histogram blank js_of_ocaml-2.5/benchmarks/report-time-ocamljs.config000066400000000000000000000001531241254034500230330ustar00rootroot00000000000000histogramref times v8 js_of_ocaml #d98e2d js_of_ocaml (V8) histogram times v8 ocamljs #227722 ocamljs (V8) js_of_ocaml-2.5/benchmarks/report-time-optim.config000066400000000000000000000002411241254034500225310ustar00rootroot00000000000000histogramref times v8 js_of_ocaml #fbaf4f default histogram times v8 unsafe/js_of_ocaml #d98e2d unsafe histogram times v8 nooptcall #a75f0c No call optimisation js_of_ocaml-2.5/benchmarks/report-time.config000066400000000000000000000004221241254034500214040ustar00rootroot00000000000000histogram times "" opt #729fcf ocamlopt histogram times "" byte #204a87 ocamlc #histogram times oldv8 js_of_ocaml #fbaf4f old V8 histogramref times v8 js_of_ocaml #fbaf4f V8 histogram times nitro js_of_ocaml #96c296 Nitro histogram times tm js_of_ocaml #fb4f4f JaegerMonkey js_of_ocaml-2.5/benchmarks/report.config.sample000066400000000000000000000004201241254034500217260ustar00rootroot00000000000000histogram times "" opt #729fcf ocamlopt histogramref times "" byte #204a87 ocamlc histogram times oldv8 js_of_ocaml #fbaf4f old V8 histogram times v8 js_of_ocaml #d98e2d V8 histogram times nitro js_of_ocaml #a75f0c Nitro histogram times tm js_of_ocaml #a40000 TraceMonkey js_of_ocaml-2.5/benchmarks/report.ml000077500000000000000000000336271241254034500176330ustar00rootroot00000000000000#! /usr/bin/ocaml unix.cma (* Js_of_ocaml benchmarks * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2011 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) #use "lib/common.ml" (****) let reference = ref None let nreference = ref (-1) let maximum = ref (-1.) let gnuplot = ref true let table = ref false let omitted = ref [] let appended = ref [] let errors = ref false let script = ref false let conf = ref "report.config" let svg = ref false let svgfontsize = ref 7 let svgwidth = ref 500 let svgheight = ref 150 let edgecaption = ref false let ylabel = ref "" (****) let str_split s c = let i = ref (String.length s) in let r = ref [] in begin try while true do let j = String.rindex_from s (!i - 1) c in r := String.sub s (j + 1) (!i - j - 1) :: !r; i := j done with Not_found -> () end; String.sub s 0 !i :: !r (****) let rec merge f l1 l2 = match l1, l2 with [], _ | _, [] -> [] | (n1, v1) :: r1, (n2, v2) :: r2 -> if n1 < n2 then merge f r1 l2 else if n1 > n2 then merge f l1 r2 else (n1, f v1 v2) :: merge f r1 r2 let merge_blank l2 = List.map (fun (n2, v2) -> (n2, (0.0, 0.0) :: v2)) l2 let read_column ?title ?color meas spec refe = let l = List.map (fun nm -> let l = read_measures meas spec nm in let a = Array.of_list l in let (m, i) = mean_with_confidence a in (nm, [(m, i)])) (benchs meas (no_ext spec)) in let nm = match title with | Some nm -> nm | None -> dir meas (no_ext spec) in if refe then reference := Some l; Some ([Some (nm, color)], l) let read_blank_column () = None let rec list_create n a = if n = 0 then [] else a::list_create (n-1) a let merge_columns l old_table = let rec aux = function | [] | [None] -> ([], []) | [Some c] -> c | Some (h, c) :: r -> let (h', t) = aux r in (h @ h', merge (fun v1 v2 -> v1 @ v2) c t) | None :: r -> let (h', t) = aux r in (*VVV utile ? *) (None::h', merge_blank t) in let rec remove_head_blank = function | None :: l -> let (n, ll) = remove_head_blank l in (n+1, ll) | l -> (0, l) in let rec add_blanks n (h, t) = if n = 0 then (h, t) else let zeros = list_create n (0.0, 0.0) in (*VVV utile ? *) let nodisplays = list_create n None in (h @ nodisplays , List.map (fun (a, l) -> (a, l @ zeros)) t) in (* if there was an old table, we keep only the lines corresponding to entries in that table *) let l = match l, old_table with | [], _ -> [] | _, None -> l | (Some (h, c))::ll, Some o -> (Some (h, (merge (fun v1 v2 -> v1) c o)))::ll | None::ll, Some o -> (Some ([None], (List.map (fun (nm, _) -> (nm, [0.0, 0.0])) o)))::ll in let (nb_blanks, l) = remove_head_blank (List.rev l) in let l = List.rev l in add_blanks nb_blanks (aux l) let normalize (h, t) = match !reference with | None -> (h, t) | Some rr -> (h, List.map (fun (nm, l) -> let (r, _) = List.hd (List.assoc nm rr) in if r <> r then begin Format.eprintf "No reference available for '%s'@." nm; exit 1 end; (nm, List.map (fun (v, i) -> (v /. r, i /. r)) l)) t) let stats (h, t) = for i = 0 to List.length h - 1 do match List.nth h i with | Some (nm, _) -> let l = List.map (fun (_, l) -> fst (List.nth l i)) t in let a = Array.of_list l in Array.sort compare a; let p = List.fold_right (fun x p -> x *. p) l 1. in Format.eprintf "%s:@. %f %f@." nm (p ** (1. /. float (List.length l))) a.(Array.length a / 2) | None -> () done let text_output _no_header (h, t) = Format.printf "-"; List.iter (fun v -> let nm = match v with | Some (nm, _) -> nm | None -> "" in Format.printf " - \"%s\"" nm) h; Format.printf "@."; List.iter (fun (nm, l) -> Format.printf "%s" nm; List.iter (fun (m, i) -> Format.printf " %f %f" m i) l; Format.printf "@.") t let gnuplot_output ch no_header (h, t) = let n = List.length (snd (List.hd t)) in if not no_header then begin if !svg then Printf.fprintf ch "set terminal svg fsize %d size %d %d\n" !svgfontsize !svgwidth !svgheight; if !edgecaption then Printf.fprintf ch "set key tmargin horizontal Left left reverse\n"; Printf.fprintf ch "\ set multiplot\n\ set style data histograms\n\ set style fill solid 1 border rgb 'black'\n\ set style histogram errorbars gap 1%s\n\ set xtics border in scale 0,0 nomirror rotate by -30 \ offset character 0, 0, 0\n" (if !errors then " lw 1" else ""); if !ylabel <> "" then Printf.fprintf ch "set ylabel \"%s\"\n" !ylabel; if !maximum > 0. then Printf.fprintf ch "set yrange [0:%f]\n" !maximum else Printf.fprintf ch "set yrange [0:]\n"; end; (* labels *) for i = 0 to n - 1 do let nn = ref 0. in List.iter (fun (nm, l) -> let (v, ii) = List.nth l i in if !maximum > 0. && v > !maximum then Printf.fprintf ch "set label font \",5\" \"%.2f\" at %f,%f center\n" v (!nn +. float i /. float n -. 0.5 (* why? *)) (!maximum *. 1.04 +. 0.1); nn := !nn +. 1.) t; done; Printf.fprintf ch "plot"; for i = 0 to n - 1 do match List.nth h i with | Some (_, col) -> if i > 0 then Printf.fprintf ch ", \"-\" using 2:3 title columnhead lw 0" else Printf.fprintf ch " \"-\" using 2:3:xtic(1) title columnhead lw 0"; (match col with | Some c -> Printf.fprintf ch " lc rgb '%s'" c | None -> ()); | None -> if i > 0 then Printf.fprintf ch ", \"-\" using 2:3 title columnhead lw 0" else Printf.fprintf ch " \"-\" using 2:3:xtic(1) title columnhead lw 0"; (* notitle does not work ... I don't know why ... *) done; Printf.fprintf ch "\n"; for i = 0 to n - 1 do let nm = match List.nth h i with | Some (nm, _) -> nm | None -> "" in Printf.fprintf ch "- - \"%s\"\n" nm; List.iter (fun (nm, l) -> let (v, ii) = List.nth l i in Printf.fprintf ch "\"%s\" %f %f\n" nm v (if ii <> ii then 0. else ii)) t; Printf.fprintf ch "e\n" done let filter (h, t) = let l1 = List.filter (fun (nm, _) -> not ((List.mem nm !appended) || (List.mem nm !omitted))) t in let app = List.fold_left (fun beg nm -> try (nm, List.assoc nm t)::beg with Not_found -> beg) [] !appended in (h, l1 @ app) let output_table = let old_table = ref None in fun r (l: ((string * 'a option) option list * _) option list) f -> let t = merge_columns l !old_table in old_table := Some (snd t); let t = filter t in let t = normalize t in stats t; f t let output_tables r conf = let output_function, close = if !table then text_output, fun () -> () else if !script then gnuplot_output stdout, fun () -> () else begin let ch = Unix.open_process_out "gnuplot -persist" in (gnuplot_output ch, fun () -> close_out ch) end in let no_header = ref false in List.iter (fun conf -> output_table r (List.map (function | None -> read_blank_column () | Some (dir1, dir2, color, title, refe) -> read_column ~title ~color dir1 (dir2, "") refe) conf) (output_function !no_header); no_header := true; ) conf; close () (* let f _ = let c1 = read_column (times ^ "/v8") js_of_ocaml in let c2 = read_column (times ^ "/v8") ocamljs in output_table 1 [c1; c2] *) (* let f _ = let c1 = read_column times opt in let c2 = read_column times byte in let c3 = read_column (times ^ "/v8") js_of_ocaml in output_table 1 [c3; c2; c1] *) (* let f _ = let c1 = read_column (times ^ "/v8") js_of_ocaml in let c2 = read_column (times ^ "/v8") js_of_ocaml_unsafe in output_table 1 [c1; c2] let f _ = let o = read_column ~title:"ocamlopt" ~color:"#729fcf" times opt in let b = read_column ~title:"ocamlc" ~color:"#204a87" times byte in let c0 = read_column ~title:"old V8 (august?)" ~color:"#fbaf4f" (times ^ "/oldv8") js_of_ocaml in let c1 = read_column ~title:"V8" ~color:"#d98e2d" (times ^ "/v8") js_of_ocaml in let c2 = read_column ~title:"Nitro" ~color:"#a75f0c" (times ^ "/nitro") js_of_ocaml in let c3 = read_column ~title:"TraceMonkey" ~color:"#a40000" (times ^ "/tm") js_of_ocaml in output_table 2 [o; b; c0; c1; c2; c3] *) (* let f _ = let o = read_column ~title:"ocamlopt" ~color:"#729fcf" times opt in let b = read_column ~title:"ocamlc" ~color:"#326bbe" times byte in let c1 = read_column ~title:"V8" ~color:"#d98e2d" (times ^ "/v8") js_of_ocaml in let c2 = read_column ~title:"Nitro" ~color:"#a75f0c" (times ^ "/nitro") js_of_ocaml in output_table 2 [o; b; c1; c2] *) (* let f _ = let engine = "v8" in let c1 = read_column (times ^ "/" ^ engine) js in let c2 = read_column (times ^ "/" ^ engine) js_of_ocaml in output_table 2 [c1; c2] *) (* let f _ = let c1 = read_column sizes ml in let c2 = read_column sizes byte in let c3 = read_column sizes (sub_spec js_of_ocaml "full") in let c4 = read_column sizes (sub_spec js_of_ocaml "generated") in let c5 = read_column sizes ocamljs in output_table 3 [c1; c2; c3; c4; c5] *) (* let f _ = let c1 = read_column sizes (sub_spec js_of_ocaml "generated") in let c2 = read_column sizes js_of_ocaml_compact in let c3 = read_column sizes js_of_ocaml_inline in let c4 = read_column sizes js_of_ocaml_deadcode in output_table 1 [c1; c2; c3; c4] *) (* let f _ = let c2 = read_column ~title:"bytecode" ~color:"#326bbe" sizes byte in let c3 = read_column ~title:"Javascript" ~color:"#a75f0c" sizes (sub_spec js_of_ocaml "full") in output_table 1 [c2; c3] *) (****) let read_config () = let f = !conf in if not (Sys.file_exists f) then begin Format.eprintf "Configuration file '%s' not found!@." f; exit 1 end; let fullinfo = ref [] in let info = ref [] in let i = ref 0 in let reference = ref false in let ch = open_in f in let split_at_space l = try let i = String.index l ' ' in (String.sub l 0 i, String.sub l (i + 1) (String.length l - i - 1)) with Not_found -> (l, "") in let get_info dir0 rem refe = let (dir1, rem) = split_at_space rem in let (dir2, rem) = split_at_space rem in let (color, title) = split_at_space rem in let dir1 = if dir1 = "\"\"" then dir0 else dir0^"/"^dir1 in info := Some (dir1, dir2, color, title, refe) :: !info in begin try while true do let l = input_line ch in if String.length l = 0 then (if !info <> [] then (fullinfo := (List.rev !info)::!fullinfo ; info := []; i:=0)) else if l.[0] <> '#' then begin incr i; reference := !nreference = !i; let (kind, rem) = split_at_space l in let (kind2, rem) = split_at_space rem in (match kind with | "histogram" -> () | "histogramref" -> if !nreference = -1 then reference := true | _ -> Format.eprintf "Unknown config options '%s'@." kind; exit 1); (match kind2 with | "blank" -> info := None :: !info | "times" -> get_info times rem !reference | "compiletimes" -> get_info compiletimes rem !reference | "sizes" -> get_info sizes rem !reference | _ -> Format.eprintf "Unknown config options '%s'@." kind2; exit 1); end done with End_of_file -> () end; close_in ch; if !info <> [] then fullinfo := (List.rev !info)::!fullinfo; (!reference, List.rev !fullinfo) let _ = let options = [("-ref", Arg.Set_int nreference, " use column as the baseline"); ("-max", Arg.Set_float maximum, " truncate graph at level "); ("-table", Arg.Set table, " output a text table"); ("-omit", Arg.String (fun s -> omitted := str_split s ',' @ !omitted), " omit the given benchmark"); ("-append", Arg.String (fun s -> appended := str_split s ',' @ !appended), " append the given benchmark at the end"); ("-errors", Arg.Set errors, " display error bars"); ("-config", Arg.Set_string conf, " use as a config file"); ("-script", Arg.Set script, " output gnuplot script"); ("-svg", Arg.Tuple [Arg.Set svg; Arg.Set_int svgfontsize; Arg.Set_int svgwidth; Arg.Set_int svgheight], " svg output"); ("-edgecaption", Arg.Set edgecaption, " display caption outside the diagram"); ("-ylabel", Arg.Set_string ylabel, " Y axis label"); ] in Arg.parse (Arg.align options) (fun s -> raise (Arg.Bad (Format.sprintf "unknown option `%s'" s))) (Format.sprintf "Usage: %s [options]" Sys.argv.(0)); let r, conf = read_config () in output_tables r conf (* f () *) (* http://hacks.mozilla.org/2009/07/tracemonkey-overview/ http://weblogs.mozillazine.org/bz/archives/020732.html *) (* ./report.ml -max 4 -omit hamming *) js_of_ocaml-2.5/benchmarks/run.config000066400000000000000000000003721241254034500177450ustar00rootroot00000000000000interpreter v8 /home/vincent/src/js/v8-read-only/shell interpreter tm /home/vincent/src/js/mozilla-central-7dda35eab7fc/objdir-ff-release/dist/bin/js -j -m interpreter nitro /home/vincent/src/js/WebKit/Programs/jsc #interpreter oldv8 /usr/bin/nodejs js_of_ocaml-2.5/benchmarks/run.config.sample000066400000000000000000000003521241254034500212230ustar00rootroot00000000000000interpreter v8 /home/vouillon/Js_of_ocaml_benchs/v8-read-only/d8 interpreter tm /home/vouillon/Js_of_ocaml_benchs/tracemonkey/js/src/js -j -m interpreter nitro /home/vouillon/Js_of_ocaml_benchs/WebKit/WebKitBuild/Release/Programs/jsc js_of_ocaml-2.5/benchmarks/run.ml000077500000000000000000000201321241254034500171070ustar00rootroot00000000000000#! /usr/bin/ocaml unix.cma (* Js_of_ocaml benchmarks * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2011 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let verbose = ref true;; #use "lib/common.ml" (****) let run_command cmd = if !verbose then Format.printf "+ %s@." cmd; match Unix.system cmd with Unix.WEXITED res when res <> 0 -> Format.eprintf "Command '%s' failed with exit code %d.@." cmd res; raise Exit | Unix.WSIGNALED s -> Format.eprintf "Command '%s' killed with signal %d.@." cmd s; raise Exit | _ -> () let time cmd = let t1 = (Unix.times ()).Unix.tms_cutime in run_command cmd; let t2 = (Unix.times ()).Unix.tms_cutime in t2 -. t1 (****) let compile_gen ~comptime prog src_dir src_spec dst_dir dst_spec = mkdir (dir dst_dir dst_spec); List.iter (fun nm -> let src = file src_dir src_spec nm in let dst = file dst_dir dst_spec nm in if need_update src dst then begin let cmd = prog src dst in try if comptime then write_measures compiletimes dst_spec nm [time cmd] else run_command cmd with Exit -> () end) (benchs src_dir src_spec) let compile ~comptime prog = compile_gen ~comptime (Format.sprintf "%s %s -o %s" prog) let warm_up_time = 1.0 let min_measures = ref 10 let max_confidence = ref 0.03 let max_duration = ref 1200. let fast_run () = min_measures := 5; max_confidence := 0.15; max_duration := 30. let ffast_run () = min_measures := 2; max_confidence := 42.; max_duration := 30. (****) let need_more l = let a = Array.of_list l in let (m, i) = mean_with_confidence a in let n = Array.length a in Format.eprintf "==> %f +/- %f / %f %d@." m i (i /. m) n; n < !min_measures || (i /. m > !max_confidence /. 2.) let warm_up cmd = let t = ref 0. in while !t < warm_up_time do let t' = time cmd in if t' > !max_duration then raise Exit; t := !t +. t' done let rec measure_rec cmd l = let t = time cmd in let l = t :: l in if need_more l then measure_rec cmd l else l let measure_one code meas spec nm cmd = let l = if measures_need_update code meas spec nm then [] else read_measures meas spec nm in if need_more l then begin warm_up cmd; let l = measure_rec cmd l in write_measures meas spec nm l; l end else l let measure code meas spec cmd = List.iter (fun nm -> let cmd = cmd ^ file code spec nm in try ignore (measure_one code meas spec nm cmd) with Exit -> ()) (benchs code spec) (****) let compile_no_ext ~comptime prog src_dir src_spec dst_dir dst_spec = compile_gen ~comptime prog src_dir src_spec dst_dir (no_ext dst_spec) let ml_size = compile_no_ext ~comptime:false (Format.sprintf "perl ./lib/remove_comments.pl %s | sed 's/^ *//g' | wc -c > %s") let file_size = compile_no_ext ~comptime:false (Format.sprintf "wc -c < %s > %s") let compr_file_size = compile_no_ext ~comptime:false (Format.sprintf "sed 's/^ *//g' %s | gzip -c | wc -c > %s") (* let runtime_size = *) (* compile_no_ext ~comptime:false (Format.sprintf "head -n -1 %s | wc -c > %s") *) let gen_size = compile_no_ext ~comptime:false (Format.sprintf "tail -1 %s | wc -c > %s") (****) let compile_only = ref false let full = ref false let conf = ref "run.config" let do_ocamljs = ref true let nobyteopt = ref false let has_ocamljs = Sys.command "ocamljs 2> /dev/null" = 0 let run_ocamljs () = !do_ocamljs && has_ocamljs let interpreters = ref [] let read_config () = let f = !conf in if not (Sys.file_exists f) then begin Format.eprintf "Configuration file '%s' not found!@." f; exit 1 end; let i = ref [] in let ch = open_in f in let split_at_space l = let i = String.index l ' ' in (String.sub l 0 i, String.sub l (i + 1) (String.length l - i - 1)) in begin try while true do let l = input_line ch in if l.[0] <> '#' then begin try let (kind, rem) = split_at_space l in match kind with "interpreter" -> let (nm, cmd) = split_at_space rem in i := (cmd ^ " ", nm) :: !i | _ -> Format.eprintf "Unknown config option '%s'@." kind; exit 1 with Not_found -> Format.eprintf "Bad config line '%s'@." l; exit 1 end done with End_of_file -> () end; close_in ch; interpreters := List.rev !i let _ = let options = [("-compile", Arg.Set compile_only, " only compiles"); ("-all", Arg.Set full, " run all benchmarks"); ("-config", Arg.Set_string conf, " use as a config file"); ("-fast", Arg.Unit fast_run, " perform less iterations"); ("-ffast", Arg.Unit ffast_run, " perform very few iterations"); ("-noocamljs", Arg.Clear do_ocamljs, " do not run ocamljs"); ("-nobyteopt", Arg.Set nobyteopt, " do not run benchs on bytecode and native programs")] in Arg.parse (Arg.align options) (fun s -> raise (Arg.Bad (Format.sprintf "unknown option `%s'" s))) (Format.sprintf "Usage: %s [options]" Sys.argv.(0)); read_config (); compile ~comptime:true "ocamlc" src ml code byte; compile ~comptime:true "ocamlopt" src ml code opt; compile ~comptime:true "js_of_ocaml" code byte code js_of_ocaml; compile ~comptime:true "js_of_ocaml -disable inline" code byte code js_of_ocaml_inline; compile ~comptime:true "js_of_ocaml -disable deadcode" code byte code js_of_ocaml_deadcode; compile ~comptime:true "js_of_ocaml -disable compact" code byte code js_of_ocaml_compact; compile ~comptime:true "js_of_ocaml -disable optcall" code byte code js_of_ocaml_call; if run_ocamljs () then compile ~comptime:true "ocamljs" src ml code ocamljs; compile ~comptime:true "ocamlc -unsafe" src ml code byte_unsafe; compile ~comptime:true "ocamlopt" src ml code opt_unsafe; compile ~comptime:true "js_of_ocaml" code byte_unsafe code js_of_ocaml_unsafe; if run_ocamljs () then compile ~comptime:true "ocamljs -unsafe" src ml code ocamljs_unsafe; ml_size src ml sizes ml; file_size code byte sizes byte; file_size code js_of_ocaml sizes (sub_spec js_of_ocaml "full"); compr_file_size code js_of_ocaml sizes (sub_spec js_of_ocaml "gzipped"); (* runtime_size code js_of_ocaml sizes (sub_spec js_of_ocaml "runtime"); *) gen_size code js_of_ocaml sizes (sub_spec js_of_ocaml "generated"); gen_size code js_of_ocaml_inline sizes js_of_ocaml_inline; gen_size code js_of_ocaml_deadcode sizes js_of_ocaml_deadcode; gen_size code js_of_ocaml_compact sizes js_of_ocaml_compact; gen_size code js_of_ocaml_call sizes js_of_ocaml_call; if run_ocamljs () then compr_file_size code ocamljs sizes ocamljs; if !compile_only then exit 0; if not !nobyteopt then begin measure code times opt ""; measure code times byte ""; end; let (compilers, suites) = if !full then (!interpreters, [js_of_ocaml; js_of_ocaml_unsafe; js_of_ocaml_inline; js_of_ocaml_deadcode; js_of_ocaml_compact; js_of_ocaml_call; ocamljs; ocamljs_unsafe; ]) else (begin match !interpreters with i :: r -> [i] | [] -> [] end, [js_of_ocaml]) in List.iter (fun (comp, dir) -> measure src (Filename.concat times dir) js comp; List.iter (fun suite -> measure code (Filename.concat times dir) suite comp) suites) compilers js_of_ocaml-2.5/benchmarks/sources/000077500000000000000000000000001241254034500174335ustar00rootroot00000000000000js_of_ocaml-2.5/benchmarks/sources/js/000077500000000000000000000000001241254034500200475ustar00rootroot00000000000000js_of_ocaml-2.5/benchmarks/sources/js/bdd.js000066400000000000000000000157601241254034500211470ustar00rootroot00000000000000// (***********************************************************************) // (* *) // (* Objective Caml *) // (* *) // (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) // (* *) // (* Copyright 1996 Institut National de Recherche en Informatique et *) // (* en Automatique. All rights reserved. This file is distributed *) // (* under the terms of the Q Public License version 1.0. *) // (* *) // (***********************************************************************) // Transaltion to js by VB // (* Translated to Caml by Xavier Leroy *) // (* Original code written in SML by ... *) //var sys = require('sys'); function arr(size,v) { var t = []; for (var i=0; i < size; i++) t[i] = v; return t; } function arr2(size) { var t = []; for (var i=0; i < size; i++) t[i] = []; return t; } function eval(bdd, vars) { switch (bdd.id) { case 0: return false; case 1: return true; default: return vars[bdd.v]?eval(bdd.h,vars):eval(bdd.l,vars); } } function getId(bdd) { return bdd.id; }; var initSize_1 = 8*1024 - 1; var nodeC = 1; var sz_1 = initSize_1; var htab = arr2(sz_1+1); var n_items = 0; function hashVal(x,y,v) { return ((x << 1) + y + (v << 2)); }; function resize(newSize) { var newSz_1 = newSize-1; var newArr = arr2(newSize); for (var i = 0; i <= sz_1; i++) { var b = htab[i]; for (var j = 0; j < b.length; j++) { var n = b[j]; var ind = hashVal(getId(n.l), getId(n.h), n.v) & newSz_1; newArr[ind].push(n); } } htab = newArr; sz_1 = newSz_1; } function insert(idl,idh,v,ind,bucket,newNode) { if (n_items <= sz_1) { htab[ind].push(newNode); n_items ++; } else { resize(sz_1 + sz_1 + 2); ind = hashVal(idl,idh,v) & sz_1; htab[ind].push(newNode); }; }; function mkNode(low,v,high) { var idl = getId(low); var idh = getId(high); if (idl == idh) return low; else { var ind = hashVal(idl,idh,v) & sz_1; var bucket = htab[ind]; for (i = 0; i < bucket.length; i++) { var n = bucket[i]; if ((v == n.v) && (idl == getId(n.l)) && (idh == getId(n.h))) return n; } nodeC ++; var nn = {l:low, v:v, id:nodeC, h:high}; insert(getId(low),getId(high),v,ind,bucket,nn); return nn; }; }; function cmpVar(x,y) { if (xy) { return 1; } else return 0; }; var zero = {id:0} var one = {id:1} function mkVar(xx) { return mkNode(zero,xx,one); }; var cacheSize = 1999; var andslot1 = arr(cacheSize,0); var andslot2 = arr(cacheSize,0); var andslot3 = arr(cacheSize,zero); var xorslot1 = arr(cacheSize,0); var xorslot2 = arr(cacheSize,0); var xorslot3 = arr(cacheSize,zero); var notslot1 = arr(cacheSize,0); var notslot2 = arr(cacheSize,one); function hash(x,y) { return (((x << 1)+y) % cacheSize); }; function not(n) { var id = n.id; switch (id) { case 0: return one; case 1: return zero; default: var h = id % cacheSize; if (id == notslot1[h]) { return notslot2[h]; } else { var f = mkNode(not(n.l),n.v,not(n.h)); notslot1[h] = id; notslot2[h] = f; return f; }; }; }; function and2(n1,n2) { var i1 = n1.id; switch (i1) { case 0: return zero; case 1: return n2; default: var i2 = n2.id; switch (i2) { case 0: return zero; case 1: return n1; default: var h = hash(i1,i2); if ((i1 == andslot1[h]) && (i2 == andslot2[h])) { return andslot3[h]; } else { var f; switch (cmpVar(n1.v,n2.v)) { case 0: f = mkNode(and2(n1.l,n2.l),n1.v,and2(n1.h,n2.h)); break; case -1: f = mkNode(and2(n1.l,n2),n1.v,and2(n1.h,n2)); break; default: f = mkNode(and2(n1,n2.l),n2.v,and2(n1,n2.h)); break; }; andslot1[h] = i1; andslot2[h] = i2; andslot3[h] = f; return f; } } } } function xor(n1,n2) { var i1 = n1.id; switch (i1) { case 0: return n2; case 1: return not(n2); default: var i2 = n2.id; switch (i2) { case 0: return n1; case 1: return not(n1); default: var h = hash(i1,i2); if ((i1 == andslot1[h]) && (i2 == andslot2[h])) { return andslot3[h]; } else { var f; switch (cmpVar(n1.v,n2.v)) { case 0: f = mkNode(xor(n1.l,n2.l),n1.v,xor(n1.h,n2.h)); break; case -1: f = mkNode(xor(n1.l,n2),n1.v,xor(n1.h,n2)); break; default: f = mkNode(xor(n1,n2.l),n2.v,xor(n1,n2.h)); break; }; andslot1[h] = i1; andslot2[h] = i2; andslot3[h] = f; return f; } } } } function hwb(n) { function h(i,j) { if (i==j) { return mkVar(i); } else { return xor(and2(not(mkVar(j)),h(i,j-1)), and2(mkVar(j),g(i,j-1))); }; }; function g(i,j) { if (i==j) { return mkVar(i); } else { return xor(and2(not(mkVar(i)),h(i+1,j)), and2(mkVar(i),g(i+1,j))); }; }; return h(0,n-1); }; /* Testing */ var seed = 0; function random() { seed = (seed * 25173 + 17431)|0; return (seed & 1) > 0; }; function random_vars(n) { var vars = []; for (var i = 0; i < n; i++) vars[i] = random(); return vars; }; function test_hwb(bdd,vars) { /* We should have eval bdd vars = vars.(n-1) if n > 0 eval bdd vars = false if n = 0 where n is the number of "true" elements in vars. */ var ntrue = 0; for (var i = 0; i < vars.length; i++) { if (vars[i]) ntrue++; }; return (eval(bdd,vars) == ((ntrue > 0) ? vars[ntrue-1] : false)) }; var n = 22; var ntests = 100; var bdd = hwb(n); var succeeded = true; for (var i = 1; i <= ntests; i++) { succeeded = succeeded && test_hwb(bdd,random_vars(n)); }; //print(nodeC); //if (succeeded) print("ok"); else print("failed"); js_of_ocaml-2.5/benchmarks/sources/js/bdd_lists.js000066400000000000000000000163671241254034500223710ustar00rootroot00000000000000// (***********************************************************************) // (* *) // (* Objective Caml *) // (* *) // (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) // (* *) // (* Copyright 1996 Institut National de Recherche en Informatique et *) // (* en Automatique. All rights reserved. This file is distributed *) // (* under the terms of the Q Public License version 1.0. *) // (* *) // (***********************************************************************) // Transaltion to js by VB // (* Translated to Caml by Xavier Leroy *) // (* Original code written in SML by ... *) //var sys = require('sys'); function arr(size,v) { var t = []; for (var i=0; i < size; i++) t[i] = v; return t; } function eval(bdd, vars) { switch (bdd.id) { case 0: return false; case 1: return true; default: return vars[bdd.v]?eval(bdd.h,vars):eval(bdd.l,vars); } } function getId(bdd) { return bdd.id; }; var initSize_1 = 8*1024 - 1; var nodeC = 1; var sz_1 = initSize_1; var htab = new Array(sz_1+1); var n_items = 0; function hashVal(x,y,v) { return ((x << 1) + y + (v << 2)); }; function resize(newSize) { var arr = htab; var newSz_1 = newSize-1; var newArr = []; function copyBucket(bucket) { if (bucket) { var n = bucket.head; var ind = hashVal(getId(n.l), getId(n.h), n.v) & newSz_1; newArr[ind] = {head: n, tail: newArr[ind]}; copyBucket(bucket.tail); }; }; for (var n = 0; n <= sz_1; n++) { copyBucket(arr[n]); } htab = newArr; sz_1 = newSz_1; } function insert(idl,idh,v,ind,bucket,newNode) { if (n_items <= sz_1) { htab[ind] = {head: newNode, tail: bucket}; n_items ++; } else { resize(sz_1 + sz_1 + 2); ind = hashVal(idl,idh,v) & sz_1; htab[ind] = {head: newNode, tail: htab[ind]}; }; }; function mkNode(low,v,high) { var idl = getId(low); var idh = getId(high); if (idl == idh) return low; else { var ind = hashVal(idl,idh,v) & sz_1; var bucket = htab[ind]; function lookup(b) { if (!b) { nodeC ++; var nn = {l:low, v:v, id:nodeC, h:high}; insert(getId(low),getId(high),v,ind,bucket,nn); return nn; } else { var n = b.head; if ((v == n.v) && (idl == getId(n.l)) && (idh == getId(n.h))) { return n; } else { return lookup(b.tail); }; }; }; return lookup(bucket); }; }; function cmpVar(x,y) { if (xy) { return 1; } else return 0; }; var zero = {id:0} var one = {id:1} function mkVar(xx) { return mkNode(zero,xx,one); }; var cacheSize = 1999; var andslot1 = arr(cacheSize,0); var andslot2 = arr(cacheSize,0); var andslot3 = arr(cacheSize,zero); var xorslot1 = arr(cacheSize,0); var xorslot2 = arr(cacheSize,0); var xorslot3 = arr(cacheSize,zero); var notslot1 = arr(cacheSize,0); var notslot2 = arr(cacheSize,one); function hash(x,y) { return (((x << 1)+y) % cacheSize); }; function not(n) { var id = n.id; switch (id) { case 0: return one; case 1: return zero; default: var h = id % cacheSize; if (id == notslot1[h]) { return notslot2[h]; } else { var f = mkNode(not(n.l),n.v,not(n.h)); notslot1[h] = id; notslot2[h] = f; return f; }; }; }; function and2(n1,n2) { var i1 = n1.id; switch (i1) { case 0: return zero; case 1: return n2; default: var i2 = n2.id; switch (i2) { case 0: return zero; case 1: return n1; default: var h = hash(i1,i2); if ((i1 == andslot1[h]) && (i2 == andslot2[h])) { return andslot3[h]; } else { var f; switch (cmpVar(n1.v,n2.v)) { case 0: f = mkNode(and2(n1.l,n2.l),n1.v,and2(n1.h,n2.h)); break; case -1: f = mkNode(and2(n1.l,n2),n1.v,and2(n1.h,n2)); break; default: f = mkNode(and2(n1,n2.l),n2.v,and2(n1,n2.h)); break; }; andslot1[h] = i1; andslot2[h] = i2; andslot3[h] = f; return f; } } } } function xor(n1,n2) { var i1 = n1.id; switch (i1) { case 0: return n2; case 1: return not(n2); default: var i2 = n2.id; switch (i2) { case 0: return n1; case 1: return not(n1); default: var h = hash(i1,i2); if ((i1 == andslot1[h]) && (i2 == andslot2[h])) { return andslot3[h]; } else { var f; switch (cmpVar(n1.v,n2.v)) { case 0: f = mkNode(xor(n1.l,n2.l),n1.v,xor(n1.h,n2.h)); break; case -1: f = mkNode(xor(n1.l,n2),n1.v,xor(n1.h,n2)); break; default: f = mkNode(xor(n1,n2.l),n2.v,xor(n1,n2.h)); break; }; andslot1[h] = i1; andslot2[h] = i2; andslot3[h] = f; return f; } } } } function hwb(n) { function h(i,j) { if (i==j) { return mkVar(i); } else { return xor(and2(not(mkVar(j)),h(i,j-1)), and2(mkVar(j),g(i,j-1))); }; }; function g(i,j) { if (i==j) { return mkVar(i); } else { return xor(and2(not(mkVar(i)),h(i+1,j)), and2(mkVar(i),g(i+1,j))); }; }; return h(0,n-1); }; /* Testing */ var seed = 0; function random() { seed = (seed * 25173 + 17431)|0; return (seed & 1) > 0; }; function random_vars(n) { var vars = []; for (var i = 0; i < n; i++) vars[i] = random(); return vars; }; function test_hwb(bdd,vars) { /* We should have eval bdd vars = vars.(n-1) if n > 0 eval bdd vars = false if n = 0 where n is the number of "true" elements in vars. */ var ntrue = 0; for (var i = 0; i < vars.length; i++) { if (vars[i]) ntrue++; }; return (eval(bdd,vars) == ((ntrue > 0) ? vars[ntrue-1] : false)) }; var n = 22; var ntests = 100; var bdd = hwb(n); var succeeded = true; for (var i = 1; i <= ntests; i++) { succeeded = succeeded && test_hwb(bdd,random_vars(n)); }; //print(nodeC); //if (succeeded) print("ok"); else print("failed"); js_of_ocaml-2.5/benchmarks/sources/js/binary_trees.js000066400000000000000000000025341241254034500230770ustar00rootroot00000000000000/* The Great Computer Language Shootout http://shootout.alioth.debian.org/ contributed by Isaac Gouy */ function TreeNode(left,right,item){ this.left = left; this.right = right; this.item = item; } TreeNode.prototype.itemCheck = function(){ if (this.left==null) return this.item; else return this.item + this.left.itemCheck() - this.right.itemCheck(); } function bottomUpTree(item,depth){ if (depth>0){ return new TreeNode( bottomUpTree(2*item-1, depth-1) ,bottomUpTree(2*item, depth-1) ,item ); } else { return new TreeNode(null,null,item); } } var minDepth = 4; var n = arguments[0]; var maxDepth = Math.max(minDepth + 2, n); var stretchDepth = maxDepth + 1; var check = bottomUpTree(0,stretchDepth).itemCheck(); //print("stretch tree of depth " + stretchDepth + "\t check: " + check); var longLivedTree = bottomUpTree(0,maxDepth); for (var depth=minDepth; depth<=maxDepth; depth+=2){ var iterations = 1 << (maxDepth - depth + minDepth); check = 0; for (var i=1; i<=iterations; i++){ check += bottomUpTree(i,depth).itemCheck(); check += bottomUpTree(-i,depth).itemCheck(); } // print(iterations*2 + "\t trees of depth " + depth + "\t check: " + check); } //print("long lived tree of depth " + maxDepth + "\t check: " // + longLivedTree.itemCheck()); js_of_ocaml-2.5/benchmarks/sources/js/fannkuch_redux.js000066400000000000000000000032371241254034500234160ustar00rootroot00000000000000/* The Computer Language Benchmarks Game http://shootout.alioth.debian.org/ contributed by Isaac Gouy, transliterated from Mike Pall's Lua program */ function fannkuch(n) { var p = Array(n), q = Array(n), s = Array(n); var sign = 1, maxflips = 0, sum = 0, m = n-1; for(var i=0; i maxflips) maxflips = flips; // New maximum? break; } q[q0] = q0; if (q0 >= 3){ var i = 1, j = q0 - 1, t; do { t = q[i]; q[i] = q[j]; q[j] = t; i++; j--; } while (i < j); } q0 = qq; flips++; } while (true); } // Permute. if (sign == 1){ var t = p[1]; p[1] = p[0]; p[0] = t; sign = -1; // Rotate 0<-1. } else { var t = p[1]; p[1] = p[2]; p[2] = t; sign = 1; // Rotate 0<-1 and 0<-1<-2. for(var i=2; i 0.0) ? ( (this.red > 1.0) ? 1.0 : this.red ) : 0.0; this.green = (this.green > 0.0) ? ( (this.green > 1.0) ? 1.0 : this.green ) : 0.0; this.blue = (this.blue > 0.0) ? ( (this.blue > 1.0) ? 1.0 : this.blue ) : 0.0; }, distance : function(color) { var d = Math.abs(this.red - color.red) + Math.abs(this.green - color.green) + Math.abs(this.blue - color.blue); return d; }, blend: function(c1, c2, w){ var result = new Flog.RayTracer.Color(0,0,0); result = Flog.RayTracer.Color.prototype.add( Flog.RayTracer.Color.prototype.multiplyScalar(c1, 1 - w), Flog.RayTracer.Color.prototype.multiplyScalar(c2, w) ); return result; }, brightness : function() { var r = Math.floor(this.red*255); var g = Math.floor(this.green*255); var b = Math.floor(this.blue*255); return (r * 77 + g * 150 + b * 29) >> 8; }, toString : function () { var r = Math.floor(this.red*255); var g = Math.floor(this.green*255); var b = Math.floor(this.blue*255); return "rgb("+ r +","+ g +","+ b +")"; } } /* Fake a Flog.* namespace */ if(typeof(Flog) == 'undefined') var Flog = {}; if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; Flog.RayTracer.Light = Class.create(); Flog.RayTracer.Light.prototype = { position: null, color: null, intensity: 10.0, initialize : function(pos, color, intensity) { this.position = pos; this.color = color; this.intensity = (intensity ? intensity : 10.0); }, toString : function () { return 'Light [' + this.position.x + ',' + this.position.y + ',' + this.position.z + ']'; } } /* Fake a Flog.* namespace */ if(typeof(Flog) == 'undefined') var Flog = {}; if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; Flog.RayTracer.Vector = Class.create(); Flog.RayTracer.Vector.prototype = { x : 0.0, y : 0.0, z : 0.0, initialize : function(x, y, z) { this.x = (x ? x : 0); this.y = (y ? y : 0); this.z = (z ? z : 0); }, copy: function(vector){ this.x = vector.x; this.y = vector.y; this.z = vector.z; }, normalize : function() { var m = this.magnitude(); return new Flog.RayTracer.Vector(this.x / m, this.y / m, this.z / m); }, magnitude : function() { return Math.sqrt((this.x * this.x) + (this.y * this.y) + (this.z * this.z)); }, cross : function(w) { return new Flog.RayTracer.Vector( -this.z * w.y + this.y * w.z, this.z * w.x - this.x * w.z, -this.y * w.x + this.x * w.y); }, dot : function(w) { return this.x * w.x + this.y * w.y + this.z * w.z; }, add : function(v, w) { return new Flog.RayTracer.Vector(w.x + v.x, w.y + v.y, w.z + v.z); }, subtract : function(v, w) { if(!w || !v) throw 'Vectors must be defined [' + v + ',' + w + ']'; return new Flog.RayTracer.Vector(v.x - w.x, v.y - w.y, v.z - w.z); }, multiplyVector : function(v, w) { return new Flog.RayTracer.Vector(v.x * w.x, v.y * w.y, v.z * w.z); }, multiplyScalar : function(v, w) { return new Flog.RayTracer.Vector(v.x * w, v.y * w, v.z * w); }, toString : function () { return 'Vector [' + this.x + ',' + this.y + ',' + this.z + ']'; } } /* Fake a Flog.* namespace */ if(typeof(Flog) == 'undefined') var Flog = {}; if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; Flog.RayTracer.Ray = Class.create(); Flog.RayTracer.Ray.prototype = { position : null, direction : null, initialize : function(pos, dir) { this.position = pos; this.direction = dir; }, toString : function () { return 'Ray [' + this.position + ',' + this.direction + ']'; } } /* Fake a Flog.* namespace */ if(typeof(Flog) == 'undefined') var Flog = {}; if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; Flog.RayTracer.Scene = Class.create(); Flog.RayTracer.Scene.prototype = { camera : null, shapes : [], lights : [], background : null, initialize : function() { this.camera = new Flog.RayTracer.Camera( new Flog.RayTracer.Vector(0,0,-5), new Flog.RayTracer.Vector(0,0,1), new Flog.RayTracer.Vector(0,1,0) ); this.shapes = new Array(); this.lights = new Array(); this.background = new Flog.RayTracer.Background(new Flog.RayTracer.Color(0,0,0.5), 0.2); } } /* Fake a Flog.* namespace */ if(typeof(Flog) == 'undefined') var Flog = {}; if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; if(typeof(Flog.RayTracer.Material) == 'undefined') Flog.RayTracer.Material = {}; Flog.RayTracer.Material.BaseMaterial = Class.create(); Flog.RayTracer.Material.BaseMaterial.prototype = { gloss: 2.0, // [0...infinity] 0 = matt transparency: 0.0, // 0=opaque reflection: 0.0, // [0...infinity] 0 = no reflection refraction: 0.50, hasTexture: false, initialize : function() { }, getColor: function(u, v){ }, wrapUp: function(t){ t = t % 2.0; if(t < -1) t += 2.0; if(t >= 1) t -= 2.0; return t; }, toString : function () { return 'Material [gloss=' + this.gloss + ', transparency=' + this.transparency + ', hasTexture=' + this.hasTexture +']'; } } /* Fake a Flog.* namespace */ if(typeof(Flog) == 'undefined') var Flog = {}; if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; Flog.RayTracer.Material.Solid = Class.create(); Flog.RayTracer.Material.Solid.prototype = Object.extend( new Flog.RayTracer.Material.BaseMaterial(), { initialize : function(color, reflection, refraction, transparency, gloss) { this.color = color; this.reflection = reflection; this.transparency = transparency; this.gloss = gloss; this.hasTexture = false; }, getColor: function(u, v){ return this.color; }, toString : function () { return 'SolidMaterial [gloss=' + this.gloss + ', transparency=' + this.transparency + ', hasTexture=' + this.hasTexture +']'; } } ); /* Fake a Flog.* namespace */ if(typeof(Flog) == 'undefined') var Flog = {}; if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; Flog.RayTracer.Material.Chessboard = Class.create(); Flog.RayTracer.Material.Chessboard.prototype = Object.extend( new Flog.RayTracer.Material.BaseMaterial(), { colorEven: null, colorOdd: null, density: 0.5, initialize : function(colorEven, colorOdd, reflection, transparency, gloss, density) { this.colorEven = colorEven; this.colorOdd = colorOdd; this.reflection = reflection; this.transparency = transparency; this.gloss = gloss; this.density = density; this.hasTexture = true; }, getColor: function(u, v){ var t = this.wrapUp(u * this.density) * this.wrapUp(v * this.density); if(t < 0.0) return this.colorEven; else return this.colorOdd; }, toString : function () { return 'ChessMaterial [gloss=' + this.gloss + ', transparency=' + this.transparency + ', hasTexture=' + this.hasTexture +']'; } } ); /* Fake a Flog.* namespace */ if(typeof(Flog) == 'undefined') var Flog = {}; if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; if(typeof(Flog.RayTracer.Shape) == 'undefined') Flog.RayTracer.Shape = {}; Flog.RayTracer.Shape.Sphere = Class.create(); Flog.RayTracer.Shape.Sphere.prototype = { initialize : function(pos, radius, material) { this.radius = radius; this.position = pos; this.material = material; }, intersect: function(ray){ var info = new Flog.RayTracer.IntersectionInfo(); info.shape = this; var dst = Flog.RayTracer.Vector.prototype.subtract(ray.position, this.position); var B = dst.dot(ray.direction); var C = dst.dot(dst) - (this.radius * this.radius); var D = (B * B) - C; if(D > 0){ // intersection! info.isHit = true; info.distance = (-B) - Math.sqrt(D); info.position = Flog.RayTracer.Vector.prototype.add( ray.position, Flog.RayTracer.Vector.prototype.multiplyScalar( ray.direction, info.distance ) ); info.normal = Flog.RayTracer.Vector.prototype.subtract( info.position, this.position ).normalize(); info.color = this.material.getColor(0,0); } else { info.isHit = false; } return info; }, toString : function () { return 'Sphere [position=' + this.position + ', radius=' + this.radius + ']'; } } /* Fake a Flog.* namespace */ if(typeof(Flog) == 'undefined') var Flog = {}; if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; if(typeof(Flog.RayTracer.Shape) == 'undefined') Flog.RayTracer.Shape = {}; Flog.RayTracer.Shape.Plane = Class.create(); Flog.RayTracer.Shape.Plane.prototype = { d: 0.0, initialize : function(pos, d, material) { this.position = pos; this.d = d; this.material = material; }, intersect: function(ray){ var info = new Flog.RayTracer.IntersectionInfo(); var Vd = this.position.dot(ray.direction); if(Vd == 0) return info; // no intersection var t = -(this.position.dot(ray.position) + this.d) / Vd; if(t <= 0) return info; info.shape = this; info.isHit = true; info.position = Flog.RayTracer.Vector.prototype.add( ray.position, Flog.RayTracer.Vector.prototype.multiplyScalar( ray.direction, t ) ); info.normal = this.position; info.distance = t; if(this.material.hasTexture){ var vU = new Flog.RayTracer.Vector(this.position.y, this.position.z, -this.position.x); var vV = vU.cross(this.position); var u = info.position.dot(vU); var v = info.position.dot(vV); info.color = this.material.getColor(u,v); } else { info.color = this.material.getColor(0,0); } return info; }, toString : function () { return 'Plane [' + this.position + ', d=' + this.d + ']'; } } /* Fake a Flog.* namespace */ if(typeof(Flog) == 'undefined') var Flog = {}; if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; Flog.RayTracer.IntersectionInfo = Class.create(); Flog.RayTracer.IntersectionInfo.prototype = { isHit: false, hitCount: 0, shape: null, position: null, normal: null, color: null, distance: null, initialize : function() { this.color = new Flog.RayTracer.Color(0,0,0); }, toString : function () { return 'Intersection [' + this.position + ']'; } } /* Fake a Flog.* namespace */ if(typeof(Flog) == 'undefined') var Flog = {}; if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; Flog.RayTracer.Camera = Class.create(); Flog.RayTracer.Camera.prototype = { position: null, lookAt: null, equator: null, up: null, screen: null, initialize : function(pos, lookAt, up) { this.position = pos; this.lookAt = lookAt; this.up = up; this.equator = lookAt.normalize().cross(this.up); this.screen = Flog.RayTracer.Vector.prototype.add(this.position, this.lookAt); }, getRay: function(vx, vy){ var pos = Flog.RayTracer.Vector.prototype.subtract( this.screen, Flog.RayTracer.Vector.prototype.subtract( Flog.RayTracer.Vector.prototype.multiplyScalar(this.equator, vx), Flog.RayTracer.Vector.prototype.multiplyScalar(this.up, vy) ) ); pos.y = pos.y * -1; var dir = Flog.RayTracer.Vector.prototype.subtract( pos, this.position ); var ray = new Flog.RayTracer.Ray(pos, dir.normalize()); return ray; }, toString : function () { return 'Ray []'; } } /* Fake a Flog.* namespace */ if(typeof(Flog) == 'undefined') var Flog = {}; if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; Flog.RayTracer.Background = Class.create(); Flog.RayTracer.Background.prototype = { color : null, ambience : 0.0, initialize : function(color, ambience) { this.color = color; this.ambience = ambience; } } /* Fake a Flog.* namespace */ if(typeof(Flog) == 'undefined') var Flog = {}; if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; Flog.RayTracer.Engine = Class.create(); Flog.RayTracer.Engine.prototype = { canvas: null, /* 2d context we can render to */ initialize: function(options){ this.options = Object.extend({ canvasHeight: 100, canvasWidth: 100, pixelWidth: 2, pixelHeight: 2, renderDiffuse: false, renderShadows: false, renderHighlights: false, renderReflections: false, rayDepth: 2 }, options || {}); this.options.canvasHeight /= this.options.pixelHeight; this.options.canvasWidth /= this.options.pixelWidth; /* TODO: dynamically include other scripts */ }, setPixel: function(x, y, color){ var pxW, pxH; pxW = this.options.pixelWidth; pxH = this.options.pixelHeight; if (this.canvas) { this.canvas.fillStyle = color.toString(); this.canvas.fillRect (x * pxW, y * pxH, pxW, pxH); } else { if (x === y) { checkNumber += color.brightness(); } // print(x * pxW, y * pxH, pxW, pxH); } }, renderScene: function(scene, canvas){ checkNumber = 0; /* Get canvas */ if (canvas) { this.canvas = canvas.getContext("2d"); } else { this.canvas = null; } var canvasHeight = this.options.canvasHeight; var canvasWidth = this.options.canvasWidth; for(var y=0; y < canvasHeight; y++){ for(var x=0; x < canvasWidth; x++){ var yp = y * 1.0 / canvasHeight * 2 - 1; var xp = x * 1.0 / canvasWidth * 2 - 1; var ray = scene.camera.getRay(xp, yp); var color = this.getPixelColor(ray, scene); this.setPixel(x, y, color); } } if (checkNumber !== 2321) { throw new Error("Scene rendered incorrectly"); } }, getPixelColor: function(ray, scene){ var info = this.testIntersection(ray, scene, null); if(info.isHit){ var color = this.rayTrace(info, ray, scene, 0); return color; } return scene.background.color; }, testIntersection: function(ray, scene, exclude){ var hits = 0; var best = new Flog.RayTracer.IntersectionInfo(); best.distance = 2000; for(var i=0; i= 0 && info.distance < best.distance){ best = info; hits++; } } } best.hitCount = hits; return best; }, getReflectionRay: function(P,N,V){ var c1 = -N.dot(V); var R1 = Flog.RayTracer.Vector.prototype.add( Flog.RayTracer.Vector.prototype.multiplyScalar(N, 2*c1), V ); return new Flog.RayTracer.Ray(P, R1); }, rayTrace: function(info, ray, scene, depth){ // Calc ambient var color = Flog.RayTracer.Color.prototype.multiplyScalar(info.color, scene.background.ambience); var oldColor = color; var shininess = Math.pow(10, info.shape.material.gloss + 1); for(var i=0; i 0.0){ color = Flog.RayTracer.Color.prototype.add( color, Flog.RayTracer.Color.prototype.multiply( info.color, Flog.RayTracer.Color.prototype.multiplyScalar( light.color, L ) ) ); } } // The greater the depth the more accurate the colours, but // this is exponentially (!) expensive if(depth <= this.options.rayDepth){ // calculate reflection ray if(this.options.renderReflections && info.shape.material.reflection > 0) { var reflectionRay = this.getReflectionRay(info.position, info.normal, ray.direction); var refl = this.testIntersection(reflectionRay, scene, info.shape); if (refl.isHit && refl.distance > 0){ refl.color = this.rayTrace(refl, reflectionRay, scene, depth + 1); } else { refl.color = scene.background.color; } color = Flog.RayTracer.Color.prototype.blend( color, refl.color, info.shape.material.reflection ); } // Refraction /* TODO */ } /* Render shadows and highlights */ var shadowInfo = new Flog.RayTracer.IntersectionInfo(); if(this.options.renderShadows){ var shadowRay = new Flog.RayTracer.Ray(info.position, v); shadowInfo = this.testIntersection(shadowRay, scene, info.shape); if(shadowInfo.isHit && shadowInfo.shape != info.shape /*&& shadowInfo.shape.type != 'PLANE'*/){ var vA = Flog.RayTracer.Color.prototype.multiplyScalar(color, 0.5); var dB = (0.5 * Math.pow(shadowInfo.shape.material.transparency, 0.5)); color = Flog.RayTracer.Color.prototype.addScalar(vA,dB); } } // Phong specular highlights if(this.options.renderHighlights && !shadowInfo.isHit && info.shape.material.gloss > 0){ var Lv = Flog.RayTracer.Vector.prototype.subtract( info.shape.position, light.position ).normalize(); var E = Flog.RayTracer.Vector.prototype.subtract( scene.camera.position, info.shape.position ).normalize(); var H = Flog.RayTracer.Vector.prototype.subtract( E, Lv ).normalize(); var glossWeight = Math.pow(Math.max(info.normal.dot(H), 0), shininess); color = Flog.RayTracer.Color.prototype.add( Flog.RayTracer.Color.prototype.multiplyScalar(light.color, glossWeight), color ); } } color.limit(); return color; } }; function renderScene(){ var scene = new Flog.RayTracer.Scene(); scene.camera = new Flog.RayTracer.Camera( new Flog.RayTracer.Vector(0, 0, -15), new Flog.RayTracer.Vector(-0.2, 0, 5), new Flog.RayTracer.Vector(0, 1, 0) ); scene.background = new Flog.RayTracer.Background( new Flog.RayTracer.Color(0.5, 0.5, 0.5), 0.4 ); var sphere = new Flog.RayTracer.Shape.Sphere( new Flog.RayTracer.Vector(-1.5, 1.5, 2), 1.5, new Flog.RayTracer.Material.Solid( new Flog.RayTracer.Color(0,0.5,0.5), 0.3, 0.0, 0.0, 2.0 ) ); var sphere1 = new Flog.RayTracer.Shape.Sphere( new Flog.RayTracer.Vector(1, 0.25, 1), 0.5, new Flog.RayTracer.Material.Solid( new Flog.RayTracer.Color(0.9,0.9,0.9), 0.1, 0.0, 0.0, 1.5 ) ); var plane = new Flog.RayTracer.Shape.Plane( new Flog.RayTracer.Vector(0.1, 0.9, -0.5).normalize(), 1.2, new Flog.RayTracer.Material.Chessboard( new Flog.RayTracer.Color(1,1,1), new Flog.RayTracer.Color(0,0,0), 0.2, 0.0, 1.0, 0.7 ) ); scene.shapes.push(plane); scene.shapes.push(sphere); scene.shapes.push(sphere1); var light = new Flog.RayTracer.Light( new Flog.RayTracer.Vector(5, 10, -1), new Flog.RayTracer.Color(0.8, 0.8, 0.8) ); var light1 = new Flog.RayTracer.Light( new Flog.RayTracer.Vector(-3, 5, -15), new Flog.RayTracer.Color(0.8, 0.8, 0.8), 100 ); scene.lights.push(light); scene.lights.push(light1); var imageWidth = 100; // $F('imageWidth'); var imageHeight = 100; // $F('imageHeight'); var pixelSize = "5,5".split(','); // $F('pixelSize').split(','); var renderDiffuse = true; // $F('renderDiffuse'); var renderShadows = true; // $F('renderShadows'); var renderHighlights = true; // $F('renderHighlights'); var renderReflections = true; // $F('renderReflections'); var rayDepth = 2;//$F('rayDepth'); var raytracer = new Flog.RayTracer.Engine( { canvasWidth: imageWidth, canvasHeight: imageHeight, pixelWidth: pixelSize[0], pixelHeight: pixelSize[1], "renderDiffuse": renderDiffuse, "renderHighlights": renderHighlights, "renderShadows": renderShadows, "renderReflections": renderReflections, "rayDepth": rayDepth } ); raytracer.renderScene(scene, null, 0); } var d = Date.now (); for (var i = 1; i <= 100; i++) { renderScene(); }; print(Date.now() - d); js_of_ocaml-2.5/benchmarks/sources/js/splay.js000066400000000000000000000246611241254034500215460ustar00rootroot00000000000000// Copyright 2009 the V8 project authors. All rights reserved. // Redistribution and use in source and binary forms, with or without // modification, are permitted provided that the following conditions are // met: // // * Redistributions of source code must retain the above copyright // notice, this list of conditions and the following disclaimer. // * Redistributions in binary form must reproduce the above // copyright notice, this list of conditions and the following // disclaimer in the documentation and/or other materials provided // with the distribution. // * Neither the name of Google Inc. nor the names of its // contributors may be used to endorse or promote products derived // from this software without specific prior written permission. // // THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS // "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT // LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR // A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT // OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, // SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT // LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, // DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY // THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT // (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE // OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. // This benchmark is based on a JavaScript log processing module used // by the V8 profiler to generate execution time profiles for runs of // JavaScript applications, and it effectively measures how fast the // JavaScript engine is at allocating nodes and reclaiming the memory // used for old nodes. Because of the way splay trees work, the engine // also has to deal with a lot of changes to the large tree object // graph. // Configuration. var kSplayTreeSize = 8000; var kSplayTreeModifications = 80; var kSplayTreePayloadDepth = 5; var splayTree = null; function GeneratePayloadTree(depth, tag) { if (depth == 0) { return { array : [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9 ], string : 'String for key ' + tag + ' in leaf node' }; } else { return { left: GeneratePayloadTree(depth - 1, tag), right: GeneratePayloadTree(depth - 1, tag) }; } } function GenerateKey() { // The benchmark framework guarantees that Math.random is // deterministic; see base.js. return Math.random(); } function InsertNewNode() { // Insert new node with a unique key. var key; do { key = GenerateKey(); } while (splayTree.find(key) != null); var payload = GeneratePayloadTree(kSplayTreePayloadDepth, String(key)); splayTree.insert(key, payload); return key; } function SplaySetup() { splayTree = new SplayTree(); for (var i = 0; i < kSplayTreeSize; i++) InsertNewNode(); } function SplayTearDown() { // Allow the garbage collector to reclaim the memory // used by the splay tree no matter how we exit the // tear down function. var keys = splayTree.exportKeys(); splayTree = null; // Verify that the splay tree has the right size. var length = keys.length; if (length != kSplayTreeSize) { throw new Error("Splay tree has wrong size"); } // Verify that the splay tree has sorted, unique keys. for (var i = 0; i < length - 1; i++) { if (keys[i] >= keys[i + 1]) { throw new Error("Splay tree not sorted"); } } } function SplayRun() { // Replace a few nodes in the splay tree. for (var i = 0; i < kSplayTreeModifications; i++) { var key = InsertNewNode(); var greatest = splayTree.findGreatestLessThan(key); if (greatest == null) splayTree.remove(key); else splayTree.remove(greatest.key); } } /** * Constructs a Splay tree. A splay tree is a self-balancing binary * search tree with the additional property that recently accessed * elements are quick to access again. It performs basic operations * such as insertion, look-up and removal in O(log(n)) amortized time. * * @constructor */ function SplayTree() { }; /** * Pointer to the root node of the tree. * * @type {SplayTree.Node} * @private */ SplayTree.prototype.root_ = null; /** * @return {boolean} Whether the tree is empty. */ SplayTree.prototype.isEmpty = function() { return !this.root_; }; /** * Inserts a node into the tree with the specified key and value if * the tree does not already contain a node with the specified key. If * the value is inserted, it becomes the root of the tree. * * @param {number} key Key to insert into the tree. * @param {*} value Value to insert into the tree. */ SplayTree.prototype.insert = function(key, value) { if (this.isEmpty()) { this.root_ = new SplayTree.Node(key, value); return; } // Splay on the key to move the last node on the search path for // the key to the root of the tree. this.splay_(key); if (this.root_.key == key) { return; } var node = new SplayTree.Node(key, value); if (key > this.root_.key) { node.left = this.root_; node.right = this.root_.right; this.root_.right = null; } else { node.right = this.root_; node.left = this.root_.left; this.root_.left = null; } this.root_ = node; }; /** * Removes a node with the specified key from the tree if the tree * contains a node with this key. The removed node is returned. If the * key is not found, an exception is thrown. * * @param {number} key Key to find and remove from the tree. * @return {SplayTree.Node} The removed node. */ SplayTree.prototype.remove = function(key) { if (this.isEmpty()) { throw Error('Key not found: ' + key); } this.splay_(key); if (this.root_.key != key) { throw Error('Key not found: ' + key); } var removed = this.root_; if (!this.root_.left) { this.root_ = this.root_.right; } else { var right = this.root_.right; this.root_ = this.root_.left; // Splay to make sure that the new root has an empty right child. this.splay_(key); // Insert the original right child as the right child of the new // root. this.root_.right = right; } return removed; }; /** * Returns the node having the specified key or null if the tree doesn't contain * a node with the specified key. * * @param {number} key Key to find in the tree. * @return {SplayTree.Node} Node having the specified key. */ SplayTree.prototype.find = function(key) { if (this.isEmpty()) { return null; } this.splay_(key); return this.root_.key == key ? this.root_ : null; }; /** * @return {SplayTree.Node} Node having the maximum key value. */ SplayTree.prototype.findMax = function(opt_startNode) { if (this.isEmpty()) { return null; } var current = opt_startNode || this.root_; while (current.right) { current = current.right; } return current; }; /** * @return {SplayTree.Node} Node having the maximum key value that * is less than the specified key value. */ SplayTree.prototype.findGreatestLessThan = function(key) { if (this.isEmpty()) { return null; } // Splay on the key to move the node with the given key or the last // node on the search path to the top of the tree. this.splay_(key); // Now the result is either the root node or the greatest node in // the left subtree. if (this.root_.key < key) { return this.root_; } else if (this.root_.left) { return this.findMax(this.root_.left); } else { return null; } }; /** * @return {Array<*>} An array containing all the keys of tree's nodes. */ SplayTree.prototype.exportKeys = function() { var result = []; if (!this.isEmpty()) { this.root_.traverse_(function(node) { result.push(node.key); }); } return result; }; /** * Perform the splay operation for the given key. Moves the node with * the given key to the top of the tree. If no node has the given * key, the last node on the search path is moved to the top of the * tree. This is the simplified top-down splaying algorithm from: * "Self-adjusting Binary Search Trees" by Sleator and Tarjan * * @param {number} key Key to splay the tree on. * @private */ SplayTree.prototype.splay_ = function(key) { if (this.isEmpty()) { return; } // Create a dummy node. The use of the dummy node is a bit // counter-intuitive: The right child of the dummy node will hold // the L tree of the algorithm. The left child of the dummy node // will hold the R tree of the algorithm. Using a dummy node, left // and right will always be nodes and we avoid special cases. var dummy, left, right; dummy = left = right = new SplayTree.Node(null, null); var current = this.root_; while (true) { if (key < current.key) { if (!current.left) { break; } if (key < current.left.key) { // Rotate right. var tmp = current.left; current.left = tmp.right; tmp.right = current; current = tmp; if (!current.left) { break; } } // Link right. right.left = current; right = current; current = current.left; } else if (key > current.key) { if (!current.right) { break; } if (key > current.right.key) { // Rotate left. var tmp = current.right; current.right = tmp.left; tmp.left = current; current = tmp; if (!current.right) { break; } } // Link left. left.right = current; left = current; current = current.right; } else { break; } } // Assemble. left.right = current.left; right.left = current.right; current.left = dummy.right; current.right = dummy.left; this.root_ = current; }; /** * Constructs a Splay tree node. * * @param {number} key Key. * @param {*} value Value. */ SplayTree.Node = function(key, value) { this.key = key; this.value = value; }; /** * @type {SplayTree.Node} */ SplayTree.Node.prototype.left = null; /** * @type {SplayTree.Node} */ SplayTree.Node.prototype.right = null; /** * Performs an ordered traversal of the subtree starting at * this SplayTree.Node. * * @param {function(SplayTree.Node)} f Visitor function. * @private */ SplayTree.Node.prototype.traverse_ = function(f) { var current = this; while (current) { var left = current.left; if (left) left.traverse_(f); f(current); current = current.right; } }; SplaySetup(); SplayRun(); SplayTearDown(); js_of_ocaml-2.5/benchmarks/sources/ml/000077500000000000000000000000001241254034500200435ustar00rootroot00000000000000js_of_ocaml-2.5/benchmarks/sources/ml/almabench.ml000066400000000000000000000337111241254034500223140ustar00rootroot00000000000000(* * ALMABENCH 1.0.1 * Objective Caml version * * A number-crunching benchmark designed for cross-language and vendor * comparisons. * * Written by Shawn Wagner, from Scott Robert Ladd's versions for * C++ and java. * * No rights reserved. This is public domain software, for use by anyone. * * This program calculates the daily ephemeris (at noon) for the years * 2000-2099 using an algorithm developed by J.L. Simon, P. Bretagnon, J. * Chapront, M. Chapront-Touze, G. Francou and J. Laskar of the Bureau des * Longitudes, Paris, France), as detailed in Astronomy & Astrophysics * 282, 663 (1994) * * Note that the code herein is design for the purpose of testing * computational performance; error handling and other such "niceties" * is virtually non-existent. * * Actual (and oft-updated) benchmark results can be found at: * http://www.coyotegulch.com * * Please do not use this information or algorithm in any way that might * upset the balance of the universe or otherwise cause planets to impact * upon one another. *) let pic = 3.14159265358979323846 and j2000 = 2451545.0 and jcentury = 36525.0 and jmillenia = 365250.0 let twopi = 2.0 *. pic and a2r = pic /. 648000.0 and r2h = 12.0 /. pic and r2d = 180.0 /. pic and gaussk = 0.01720209895 (* number of days to include in test *) let test_loops = 5 (* was: 20 *) and test_length = 36525 (* sin and cos of j2000 mean obliquity (iau 1976) *) and sineps = 0.3977771559319137 and coseps = 0.9174820620691818 and amas = [| 6023600.0; 408523.5; 328900.5; 3098710.0; 1047.355; 3498.5; 22869.0; 19314.0 |] (* * tables giving the mean keplerian elements, limited to t**2 terms: * a semi-major axis (au) * dlm mean longitude (degree and arcsecond) * e eccentricity * pi longitude of the perihelion (degree and arcsecond) * dinc inclination (degree and arcsecond) * omega longitude of the ascending node (degree and arcsecond) *) and a = [| [| 0.3870983098; 0.0; 0.0 |]; [| 0.7233298200; 0.0; 0.0 |]; [| 1.0000010178; 0.0; 0.0 |]; [| 1.5236793419; 3e-10; 0.0 |]; [| 5.2026032092; 19132e-10; -39e-10 |]; [| 9.5549091915; -0.0000213896; 444e-10 |]; [| 19.2184460618; -3716e-10; 979e-10 |]; [| 30.1103868694; -16635e-10; 686e-10 |] |] and dlm = [| [| 252.25090552; 5381016286.88982; -1.92789 |]; [| 181.97980085; 2106641364.33548; 0.59381 |]; [| 100.46645683; 1295977422.83429; -2.04411 |]; [| 355.43299958; 689050774.93988; 0.94264 |]; [| 34.35151874; 109256603.77991; -30.60378 |]; [| 50.07744430; 43996098.55732; 75.61614 |]; [| 314.05500511; 15424811.93933; -1.75083 |]; [| 304.34866548; 7865503.20744; 0.21103 |] |] and e = [| [| 0.2056317526; 0.0002040653; -28349e-10 |]; [| 0.0067719164; -0.0004776521; 98127e-10 |]; [| 0.0167086342; -0.0004203654; -0.0000126734 |]; [| 0.0934006477; 0.0009048438; -80641e-10 |]; [| 0.0484979255; 0.0016322542; -0.0000471366 |]; [| 0.0555481426; -0.0034664062; -0.0000643639 |]; [| 0.0463812221; -0.0002729293; 0.0000078913 |]; [| 0.0094557470; 0.0000603263; 0.0 |] |] and pi = [| [| 77.45611904; 5719.11590; -4.83016 |]; [| 131.56370300; 175.48640; -498.48184 |]; [| 102.93734808; 11612.35290; 53.27577 |]; [| 336.06023395; 15980.45908; -62.32800 |]; [| 14.33120687; 7758.75163; 259.95938 |]; [| 93.05723748; 20395.49439; 190.25952 |]; [| 173.00529106; 3215.56238; -34.09288 |]; [| 48.12027554; 1050.71912; 27.39717 |] |] and dinc = [| [| 7.00498625; -214.25629; 0.28977 |]; [| 3.39466189; -30.84437; -11.67836 |]; [| 0.0; 469.97289; -3.35053 |]; [| 1.84972648; -293.31722; -8.11830 |]; [| 1.30326698; -71.55890; 11.95297 |]; [| 2.48887878; 91.85195; -17.66225 |]; [| 0.77319689; -60.72723; 1.25759 |]; [| 1.76995259; 8.12333; 0.08135 |] |] and omega = [| [| 48.33089304; -4515.21727; -31.79892 |]; [| 76.67992019; -10008.48154; -51.32614 |]; [| 174.87317577; -8679.27034; 15.34191 |]; [| 49.55809321; -10620.90088; -230.57416 |]; [| 100.46440702; 6362.03561; 326.52178 |]; [| 113.66550252; -9240.19942; -66.23743 |]; [| 74.00595701; 2669.15033; 145.93964 |]; [| 131.78405702; -221.94322; -0.78728 |] |] (* tables for trigonometric terms to be added to the mean elements of the semi-major axes. *) and kp = [| [| 69613.0; 75645.0; 88306.0; 59899.0; 15746.0; 71087.0; 142173.0; 3086.0; 0.0 |]; [| 21863.0; 32794.0; 26934.0; 10931.0; 26250.0; 43725.0; 53867.0; 28939.0; 0.0 |]; [| 16002.0; 21863.0; 32004.0; 10931.0; 14529.0; 16368.0; 15318.0; 32794.0; 0.0 |]; [| 6345.0; 7818.0; 15636.0; 7077.0; 8184.0; 14163.0; 1107.0; 4872.0; 0.0 |]; [| 1760.0; 1454.0; 1167.0; 880.0; 287.0; 2640.0; 19.0; 2047.0; 1454.0 |]; [| 574.0; 0.0; 880.0; 287.0; 19.0; 1760.0; 1167.0; 306.0; 574.0 |]; [| 204.0; 0.0; 177.0; 1265.0; 4.0; 385.0; 200.0; 208.0; 204.0 |]; [| 0.0; 102.0; 106.0; 4.0; 98.0; 1367.0; 487.0; 204.0; 0.0 |] |] and ca = [| [| 4.0; -13.0; 11.0; -9.0; -9.0; -3.0; -1.0; 4.0; 0.0 |]; [| -156.0; 59.0; -42.0; 6.0; 19.0; -20.0; -10.0; -12.0; 0.0 |]; [| 64.0; -152.0; 62.0; -8.0; 32.0; -41.0; 19.0; -11.0; 0.0 |]; [| 124.0; 621.0; -145.0; 208.0; 54.0; -57.0; 30.0; 15.0; 0.0 |]; [| -23437.0; -2634.0; 6601.0; 6259.0; -1507.0; -1821.0; 2620.0; -2115.0;-1489.0 |]; [| 62911.0;-119919.0; 79336.0; 17814.0;-24241.0; 12068.0; 8306.0; -4893.0; 8902.0 |]; [| 389061.0;-262125.0;-44088.0; 8387.0;-22976.0; -2093.0; -615.0; -9720.0; 6633.0 |]; [| -412235.0;-157046.0;-31430.0; 37817.0; -9740.0; -13.0; -7449.0; 9644.0; 0.0 |] |] and sa = [| [| -29.0; -1.0; 9.0; 6.0; -6.0; 5.0; 4.0; 0.0; 0.0 |]; [| -48.0; -125.0; -26.0; -37.0; 18.0; -13.0; -20.0; -2.0; 0.0 |]; [| -150.0; -46.0; 68.0; 54.0; 14.0; 24.0; -28.0; 22.0; 0.0 |]; [| -621.0; 532.0; -694.0; -20.0; 192.0; -94.0; 71.0; -73.0; 0.0 |]; [| -14614.0;-19828.0; -5869.0; 1881.0; -4372.0; -2255.0; 782.0; 930.0; 913.0 |]; [| 139737.0; 0.0; 24667.0; 51123.0; -5102.0; 7429.0; -4095.0; -1976.0;-9566.0 |]; [| -138081.0; 0.0; 37205.0;-49039.0;-41901.0;-33872.0;-27037.0;-12474.0;18797.0 |]; [| 0.0; 28492.0;133236.0; 69654.0; 52322.0;-49577.0;-26430.0; -3593.0; 0.0 |] |] (* tables giving the trigonometric terms to be added to the mean elements of the mean longitudes . *) and kq = [| [| 3086.0; 15746.0; 69613.0; 59899.0; 75645.0; 88306.0; 12661.0; 2658.0; 0.0; 0.0 |]; [| 21863.0; 32794.0; 10931.0; 73.0; 4387.0; 26934.0; 1473.0; 2157.0; 0.0; 0.0 |]; [| 10.0; 16002.0; 21863.0; 10931.0; 1473.0; 32004.0; 4387.0; 73.0; 0.0; 0.0 |]; [| 10.0; 6345.0; 7818.0; 1107.0; 15636.0; 7077.0; 8184.0; 532.0; 10.0; 0.0 |]; [| 19.0; 1760.0; 1454.0; 287.0; 1167.0; 880.0; 574.0; 2640.0; 19.0;1454.0 |]; [| 19.0; 574.0; 287.0; 306.0; 1760.0; 12.0; 31.0; 38.0; 19.0; 574.0 |]; [| 4.0; 204.0; 177.0; 8.0; 31.0; 200.0; 1265.0; 102.0; 4.0; 204.0 |]; [| 4.0; 102.0; 106.0; 8.0; 98.0; 1367.0; 487.0; 204.0; 4.0; 102.0 |] |] and cl = [| [| 21.0; -95.0; -157.0; 41.0; -5.0; 42.0; 23.0; 30.0; 0.0; 0.0 |]; [| -160.0; -313.0; -235.0; 60.0; -74.0; -76.0; -27.0; 34.0; 0.0; 0.0 |]; [| -325.0; -322.0; -79.0; 232.0; -52.0; 97.0; 55.0; -41.0; 0.0; 0.0 |]; [| 2268.0; -979.0; 802.0; 602.0; -668.0; -33.0; 345.0; 201.0; -55.0; 0.0 |]; [| 7610.0; -4997.0;-7689.0;-5841.0;-2617.0; 1115.0; -748.0; -607.0; 6074.0; 354.0 |]; [| -18549.0; 30125.0;20012.0; -730.0; 824.0; 23.0; 1289.0; -352.0;-14767.0;-2062.0 |]; [| -135245.0;-14594.0; 4197.0;-4030.0;-5630.0;-2898.0; 2540.0; -306.0; 2939.0; 1986.0 |]; [| 89948.0; 2103.0; 8963.0; 2695.0; 3682.0; 1648.0; 866.0; -154.0; -1963.0; -283.0 |] |] and sl = [| [| -342.0; 136.0; -23.0; 62.0; 66.0; -52.0; -33.0; 17.0; 0.0; 0.0 |]; [| 524.0; -149.0; -35.0; 117.0; 151.0; 122.0; -71.0; -62.0; 0.0; 0.0 |]; [| -105.0; -137.0; 258.0; 35.0; -116.0; -88.0; -112.0; -80.0; 0.0; 0.0 |]; [| 854.0; -205.0; -936.0; -240.0; 140.0; -341.0; -97.0; -232.0; 536.0; 0.0 |]; [| -56980.0; 8016.0; 1012.0; 1448.0;-3024.0;-3710.0; 318.0; 503.0; 3767.0; 577.0 |]; [| 138606.0;-13478.0;-4964.0; 1441.0;-1319.0;-1482.0; 427.0; 1236.0; -9167.0;-1918.0 |]; [| 71234.0;-41116.0; 5334.0;-4935.0;-1848.0; 66.0; 434.0;-1748.0; 3780.0; -701.0 |]; [| -47645.0; 11647.0; 2166.0; 3194.0; 679.0; 0.0; -244.0; -419.0; -2531.0; 48.0 |] |] (* Normalize angle into the range -pi <= A < +pi. *) let anpm a = let w = mod_float a twopi in if abs_float w >= pic then begin if a < 0.0 then w +. twopi else w -. twopi end else w (* The reference frame is equatorial and is with respect to the * mean equator and equinox of epoch j2000. *) let planetpv epoch np pv = (* time: julian millennia since j2000. *) let t = ((epoch.(0) -. j2000) +. epoch.(1)) /. jmillenia in (* compute the mean elements. *) let da = ref (a.(np).(0) +. (a.(np).(1) +. a.(np).(2) *. t ) *. t) and dl = ref ((3600.0 *. dlm.(np).(0) +. (dlm.(np).(1) +. dlm.(np).(2) *. t ) *. t) *. a2r) and de = e.(np).(0) +. (e.(np).(1) +. e.(np).(2) *. t ) *. t and dp = anpm ((3600.0 *. pi.(np).(0) +. (pi.(np).(1) +. pi.(np).(2) *. t ) *. t ) *. a2r ) and di = (3600.0 *. dinc.(np).(0) +. (dinc.(np).(1) +. dinc.(np).(2) *. t ) *. t ) *. a2r and doh = anpm ((3600.0 *. omega.(np).(0) +. (omega.(np).(1) +. omega.(np).(2) *. t ) *. t ) *. a2r ) (* apply the trigonometric terms. *) and dmu = 0.35953620 *. t in (* loop invariant *) let kp = kp.(np) and kq = kq.(np) and ca = ca.(np) and sa = sa.(np) and cl = cl.(np) and sl = sl.(np) in for k = 0 to 7 do let arga = kp.(k) *. dmu and argl = kq.(k) *. dmu in da := !da +. (ca.(k) *. cos arga +. sa.(k) *. sin arga) *. 0.0000001; dl := !dl +. (cl.(k) *. cos argl +. sl.(k) *. sin argl) *. 0.0000001 done; begin let arga = kp.(8) *. dmu in da := !da +. t *. (ca.(8) *. cos arga +. sa.(8) *. sin arga ) *. 0.0000001; for k = 8 to 9 do let argl = kq.(k) *. dmu in dl := !dl +. t *. ( cl.(k) *. cos argl +. sl.(k) *. sin argl ) *. 0.0000001 done; end; dl := mod_float !dl twopi; (* iterative solution of kepler's equation to get eccentric anomaly. *) let am = !dl -. dp in let ae = ref (am +. de *. sin am) and k = ref 0 in let dae = ref ((am -. !ae +. de *. sin !ae) /. (1.0 -. de *. cos !ae)) in ae := !ae +. !dae; incr k; while !k < 10 || abs_float !dae >= 1e-12 do dae := (am -. !ae +. de *. sin !ae) /. (1.0 -. de *. cos !ae); ae := !ae +. !dae; incr k done; (* true anomaly. *) let ae2 = !ae /. 2.0 in let at = 2.0 *. atan2 (sqrt ((1.0 +. de) /. (1.0 -. de)) *. sin ae2) (cos ae2) (* distance (au) and speed (radians per day). *) and r = !da *. (1.0 -. de *. cos !ae) and v = gaussk *. sqrt ((1.0 +. 1.0 /. amas.(np) ) /. (!da *. !da *. !da)) and si2 = sin (di /. 2.0) in let xq = si2 *. cos doh and xp = si2 *. sin doh and tl = at +. dp in let xsw = sin tl and xcw = cos tl in let xm2 = 2.0 *. (xp *. xcw -. xq *. xsw ) and xf = !da /. sqrt (1.0 -. de *. de) and ci2 = cos (di /. 2.0) in let xms = (de *. sin dp +. xsw) *. xf and xmc = (de *. cos dp +. xcw) *. xf and xpxq2 = 2.0 *. xp *. xq in (* position (j2000 ecliptic x,y,z in au). *) let x = r *. (xcw -. xm2 *. xp) and y = r *. (xsw +. xm2 *. xq) and z = r *. (-.xm2 *. ci2) in (* rotate to equatorial. *) pv.(0).(0) <- x; pv.(0).(1) <- y *. coseps -. z *. sineps; pv.(0).(2) <- y *. sineps +. z *. coseps; (* velocity (j2000 ecliptic xdot,ydot,zdot in au/d). *) let x = v *. ((-1.0 +. 2.0 *. xp *. xp) *. xms +. xpxq2 *. xmc) and y = v *. (( 1.0 -. 2.0 *. xq *. xq ) *. xmc -. xpxq2 *. xms) and z = v *. (2.0 *. ci2 *. (xp *. xms +. xq *. xmc)) in (* rotate to equatorial *) pv.(1).(0) <- x; pv.(1).(1) <- y *. coseps -. z *. sineps; pv.(1).(2) <- y *. sineps +. z *. coseps (* Computes RA, Declination, and distance from a state vector returned by * planetpv. *) let radecdist state rdd = (* Distance *) rdd.(2) <- sqrt (state.(0).(0) *. state.(0).(0) +. state.(0).(1) *. state.(0).(1) +. state.(0).(2) *. state.(0).(2)); (* RA *) rdd.(0) <- atan2 state.(0).(1) state.(0).(0) *. r2h; if rdd.(0) < 0.0 then rdd.(0) <- rdd.(0) +. 24.0; (* Declination *) rdd.(1) <- asin (state.(0).(2) /. rdd.(2)) *. r2d (* Entry point. Calculate RA and Dec for noon on every day in 1900-2100 *) let _ = let jd = [| 0.0; 0.0 |] and pv = [| [| 0.0; 0.0; 0.0 |]; [| 0.0; 0.0; 0.0 |] |] and position = [| 0.0; 0.0; 0.0 |] in (* Test *) jd.(0) <- j2000; jd.(1) <- 1.0; for p = 0 to 7 do planetpv jd p pv; radecdist pv position; (* Printf.printf "%d %.2f %.2f\n%!" p position.(0) position.(1)*) done; (* Benchmark *) for i = 0 to test_loops - 1 do jd.(0) <- j2000; jd.(1) <- 0.0; for n = 0 to test_length - 1 do jd.(0) <- jd.(0) +. 1.0; for p = 0 to 7 do planetpv jd p pv; radecdist pv position; done done done js_of_ocaml-2.5/benchmarks/sources/ml/bdd.ml000066400000000000000000000162201241254034500211270ustar00rootroot00000000000000(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: bdd.ml 7017 2005-08-12 09:22:04Z xleroy $ *) (* Translated to Caml by Xavier Leroy *) (* Original code written in SML by ... *) type bdd = One | Zero | Node of bdd * int * int * bdd let rec eval bdd vars = match bdd with Zero -> false | One -> true | Node(l, v, _, h) -> if vars.(v) then eval h vars else eval l vars let getId bdd = match bdd with Node(_,_,id,_) -> id | Zero -> 0 | One -> 1 let initSize_1 = 8*1024 - 1 let nodeC = ref 1 let sz_1 = ref initSize_1 let htab = ref(Array.make (!sz_1+1) []) let n_items = ref 0 let hashVal x y v = x lsl 1 + y + v lsl 2 let resize newSize = let arr = !htab in let newSz_1 = newSize-1 in let newArr = Array.make newSize [] in let rec copyBucket bucket = match bucket with [] -> () | n :: ns -> match n with | Node(l,v,_,h) -> let ind = hashVal (getId l) (getId h) v land newSz_1 in newArr.(ind) <- (n :: newArr.(ind)); copyBucket ns | _ -> assert false in for n = 0 to !sz_1 do copyBucket(arr.(n)) done; htab := newArr; sz_1 := newSz_1 let rec insert idl idh v ind bucket newNode = if !n_items <= !sz_1 then ( (!htab).(ind) <- (newNode :: bucket); incr n_items ) else ( resize(!sz_1 + !sz_1 + 2); let ind = hashVal idl idh v land (!sz_1) in (!htab).(ind) <- newNode :: (!htab).(ind) ) let resetUnique () = ( sz_1 := initSize_1; htab := Array.make (!sz_1+1) []; n_items := 0; nodeC := 1 ) let mkNode low v high = let idl = getId low in let idh = getId high in if idl = idh then low else let ind = hashVal idl idh v land (!sz_1) in let bucket = (!htab).(ind) in let rec lookup b = match b with [] -> let n = Node(low, v, (incr nodeC; !nodeC), high) in insert (getId low) (getId high) v ind bucket n; n | n :: ns -> match n with | Node(l,v',id,h) -> if v = v' && idl = getId l && idh = getId h then n else lookup ns | _ -> assert false in lookup bucket type ordering = LESS | EQUAL | GREATER let cmpVar (x : int) (y : int) = if xy then GREATER else EQUAL let zero = Zero let one = One let mkVar x = mkNode zero x one let cacheSize = 1999 let andslot1 = Array.make cacheSize 0 let andslot2 = Array.make cacheSize 0 let andslot3 = Array.make cacheSize zero let xorslot1 = Array.make cacheSize 0 let xorslot2 = Array.make cacheSize 0 let xorslot3 = Array.make cacheSize zero let notslot1 = Array.make cacheSize 0 let notslot2 = Array.make cacheSize one let hash x y = ((x lsl 1)+y) mod cacheSize let rec not n = match n with Zero -> One | One -> Zero | Node(l, v, id, r) -> let h = id mod cacheSize in if id=notslot1.(h) then notslot2.(h) else let f = mkNode (not l) v (not r) in notslot1.(h) <- id; notslot2.(h) <- f; f let rec and2 n1 n2 = match n1 with Node(l1, v1, i1, r1) -> (match n2 with Node(l2, v2, i2, r2) -> let h = hash i1 i2 in if i1=andslot1.(h) && i2=andslot2.(h) then andslot3.(h) else let f = match cmpVar v1 v2 with EQUAL -> mkNode (and2 l1 l2) v1 (and2 r1 r2) | LESS -> mkNode (and2 l1 n2) v1 (and2 r1 n2) | GREATER -> mkNode (and2 n1 l2) v2 (and2 n1 r2) in andslot1.(h) <- i1; andslot2.(h) <- i2; andslot3.(h) <- f; f | Zero -> Zero | One -> n1) | Zero -> Zero | One -> n2 let rec xor n1 n2 = match n1 with Node(l1, v1, i1, r1) -> (match n2 with Node(l2, v2, i2, r2) -> let h = hash i1 i2 in if i1=andslot1.(h) && i2=andslot2.(h) then andslot3.(h) else let f = match cmpVar v1 v2 with EQUAL -> mkNode (xor l1 l2) v1 (xor r1 r2) | LESS -> mkNode (xor l1 n2) v1 (xor r1 n2) | GREATER -> mkNode (xor n1 l2) v2 (xor n1 r2) in andslot1.(h) <- i1; andslot2.(h) <- i2; andslot3.(h) <- f; f | Zero -> n1 | One -> not n1) | Zero -> n2 | One -> not n2 let hwb n = let rec h i j = if i=j then mkVar i else xor (and2 (not(mkVar j)) (h i (j-1))) (and2 (mkVar j) (g i (j-1))) and g i j = if i=j then mkVar i else xor (and2 (not(mkVar i)) (h (i+1) j)) (and2 (mkVar i) (g (i+1) j)) in h 0 (n-1) (* Testing *) let seed = ref 0 let random() = seed := !seed * 25173 + 17431; !seed land 1 > 0 let random_vars n = let vars = Array.make n false in for i = 0 to n - 1 do vars.(i) <- random() done; vars let test_hwb bdd vars = (* We should have eval bdd vars = vars.(n-1) if n > 0 eval bdd vars = false if n = 0 where n is the number of "true" elements in vars. *) let ntrue = ref 0 in for i = 0 to Array.length vars - 1 do if vars.(i) then incr ntrue done; eval bdd vars = (if !ntrue > 0 then vars.(!ntrue-1) else false) let main () = let n = if Array.length Sys.argv >= 2 then int_of_string Sys.argv.(1) else 22 in let ntests = if Array.length Sys.argv >= 3 then int_of_string Sys.argv.(2) else 100 in let bdd = hwb n in let succeeded = ref true in for i = 1 to ntests do succeeded := !succeeded && test_hwb bdd (random_vars n) done; assert !succeeded (* if !succeeded then print_string "OK\n" else print_string "FAILED\n"; Format.eprintf "%d@." !nodeC; exit 0 *) let _ = main() js_of_ocaml-2.5/benchmarks/sources/ml/binary_trees.ml000066400000000000000000000025701241254034500230670ustar00rootroot00000000000000(* The Computer Language Benchmarks Game * http://shootout.alioth.debian.org/ * * Contributed by Troestler Christophe * Modified by Fabrice Le Fessant *) type 'a tree = Empty | Node of 'a tree * 'a * 'a tree let rec make i d = (* if d = 0 then Empty *) if d = 0 then Node(Empty, i, Empty) else let i2 = 2 * i and d = d - 1 in Node(make (i2 - 1) d, i, make i2 d) let rec check = function Empty -> 0 | Node(l, i, r) -> i + check l - check r let min_depth = 4 let max_depth = (let n = try int_of_string(Array.get Sys.argv 1) with _ -> 10 in max (min_depth + 2) n) let stretch_depth = max_depth + 1 let () = (* Gc.set { (Gc.get()) with Gc.minor_heap_size = 1024 * 1024; max_overhead = -1; }; *) let _c = check (make 0 stretch_depth) in ((* Printf.printf "stretch tree of depth %i\t check: %i\n" stretch_depth c *)) let long_lived_tree = make 0 max_depth let rec loop_depths d = for i = 0 to ((max_depth - d) / 2 + 1) - 1 do let d = d + i * 2 in let niter = 1 lsl (max_depth - d + min_depth) in let c = ref 0 in for i = 1 to niter do c := !c + check(make i d) + check(make (-i) d) done; ((* Printf.printf "%i\t trees of depth %i\t check: %i\n" (2 * niter) d !c; *)) done let () = (* flush stdout; *) loop_depths min_depth; ((* Printf.printf "long lived tree of depth %i\t check: %i\n" max_depth (check long_lived_tree) *)) js_of_ocaml-2.5/benchmarks/sources/ml/boyer.ml000066400000000000000000000622421241254034500215230ustar00rootroot00000000000000(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: boyer.ml 7017 2005-08-12 09:22:04Z xleroy $ *) (* Manipulations over terms *) type term = Var of int | Prop of head * term list and head = { name: string; mutable props: (term * term) list } let rec print_term = function Var v -> print_string "v"; print_int v | Prop (head,argl) -> print_string "("; print_string head.name; List.iter (fun t -> print_string " "; print_term t) argl; print_string ")" let lemmas = ref ([] : head list) (* Replacement for property lists *) let get name = let rec get_rec = function hd1::hdl -> if hd1.name = name then hd1 else get_rec hdl | [] -> let entry = {name = name; props = []} in lemmas := entry :: !lemmas; entry in get_rec !lemmas let add_lemma = function | Prop(_, [(Prop(headl,_) as left); right]) -> headl.props <- (left, right) :: headl.props | _ -> assert false (* Substitutions *) type subst = Bind of int * term let get_binding v list = let rec get_rec = function [] -> failwith "unbound" | Bind(w,t)::rest -> if v = w then t else get_rec rest in get_rec list let apply_subst alist term = let rec as_rec = function Var v -> begin try get_binding v alist with Failure _ -> term end | Prop (head,argl) -> Prop (head, List.map as_rec argl) in as_rec term exception Unify let rec unify term1 term2 = unify1 term1 term2 [] and unify1 term1 term2 unify_subst = match term2 with Var v -> begin try if get_binding v unify_subst = term1 then unify_subst else raise Unify with Failure _ -> Bind(v,term1) :: unify_subst end | Prop (head2, argl2) -> match term1 with Var _ -> raise Unify | Prop (head1,argl1) -> if head1 == head2 then unify1_lst argl1 argl2 unify_subst else raise Unify and unify1_lst l1 l2 unify_subst = match (l1, l2) with ([], []) -> unify_subst | (h1::r1, h2::r2) -> unify1_lst r1 r2 (unify1 h1 h2 unify_subst) | _ -> raise Unify let rec rewrite = function Var _ as term -> term | Prop (head, argl) -> rewrite_with_lemmas (Prop (head, List.map rewrite argl)) head.props and rewrite_with_lemmas term lemmas = match lemmas with [] -> term | (t1,t2)::rest -> try rewrite (apply_subst (unify term t1) t2) with Unify -> rewrite_with_lemmas term rest type cterm = CVar of int | CProp of string * cterm list let rec cterm_to_term = function CVar v -> Var v | CProp(p, l) -> Prop(get p, List.map cterm_to_term l) let add t = add_lemma (cterm_to_term t) let _ = add (CProp ("equal", [CProp ("compile",[CVar 5]); CProp ("reverse", [CProp ("codegen",[CProp ("optimize",[CVar 5]); CProp ("nil",[])])])])); add (CProp ("equal", [CProp ("eqp",[CVar 23; CVar 24]); CProp ("equal",[CProp ("fix",[CVar 23]); CProp ("fix",[CVar 24])])])); add (CProp ("equal", [CProp ("gt",[CVar 23; CVar 24]); CProp ("lt",[CVar 24; CVar 23])])); add (CProp ("equal", [CProp ("le",[CVar 23; CVar 24]); CProp ("ge",[CVar 24; CVar 23])])); add (CProp ("equal", [CProp ("ge",[CVar 23; CVar 24]); CProp ("le",[CVar 24; CVar 23])])); add (CProp ("equal", [CProp ("boolean",[CVar 23]); CProp ("or", [CProp ("equal",[CVar 23; CProp ("true",[])]); CProp ("equal",[CVar 23; CProp ("false",[])])])])); add (CProp ("equal", [CProp ("iff",[CVar 23; CVar 24]); CProp ("and", [CProp ("implies",[CVar 23; CVar 24]); CProp ("implies",[CVar 24; CVar 23])])])); add (CProp ("equal", [CProp ("even1",[CVar 23]); CProp ("if", [CProp ("zerop",[CVar 23]); CProp ("true",[]); CProp ("odd",[CProp ("sub1",[CVar 23])])])])); add (CProp ("equal", [CProp ("countps_",[CVar 11; CVar 15]); CProp ("countps_loop",[CVar 11; CVar 15; CProp ("zero",[])])])); add (CProp ("equal", [CProp ("fact_",[CVar 8]); CProp ("fact_loop",[CVar 8; CProp ("one",[])])])); add (CProp ("equal", [CProp ("reverse_",[CVar 23]); CProp ("reverse_loop",[CVar 23; CProp ("nil",[])])])); add (CProp ("equal", [CProp ("divides",[CVar 23; CVar 24]); CProp ("zerop",[CProp ("remainder",[CVar 24; CVar 23])])])); add (CProp ("equal", [CProp ("assume_true",[CVar 21; CVar 0]); CProp ("cons",[CProp ("cons",[CVar 21; CProp ("true",[])]); CVar 0])])); add (CProp ("equal", [CProp ("assume_false",[CVar 21; CVar 0]); CProp ("cons",[CProp ("cons",[CVar 21; CProp ("false",[])]); CVar 0])])); add (CProp ("equal", [CProp ("tautology_checker",[CVar 23]); CProp ("tautologyp",[CProp ("normalize",[CVar 23]); CProp ("nil",[])])])); add (CProp ("equal", [CProp ("falsify",[CVar 23]); CProp ("falsify1",[CProp ("normalize",[CVar 23]); CProp ("nil",[])])])); add (CProp ("equal", [CProp ("prime",[CVar 23]); CProp ("and", [CProp ("not",[CProp ("zerop",[CVar 23])]); CProp ("not", [CProp ("equal",[CVar 23; CProp ("add1",[CProp ("zero",[])])])]); CProp ("prime1",[CVar 23; CProp ("sub1",[CVar 23])])])])); add (CProp ("equal", [CProp ("and",[CVar 15; CVar 16]); CProp ("if", [CVar 15; CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]); CProp ("false",[])])])); add (CProp ("equal", [CProp ("or",[CVar 15; CVar 16]); CProp ("if", [CVar 15; CProp ("true",[]); CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]); CProp ("false",[])])])); add (CProp ("equal", [CProp ("not",[CVar 15]); CProp ("if",[CVar 15; CProp ("false",[]); CProp ("true",[])])])); add (CProp ("equal", [CProp ("implies",[CVar 15; CVar 16]); CProp ("if", [CVar 15; CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]); CProp ("true",[])])])); add (CProp ("equal", [CProp ("fix",[CVar 23]); CProp ("if",[CProp ("numberp",[CVar 23]); CVar 23; CProp ("zero",[])])])); add (CProp ("equal", [CProp ("if",[CProp ("if",[CVar 0; CVar 1; CVar 2]); CVar 3; CVar 4]); CProp ("if", [CVar 0; CProp ("if",[CVar 1; CVar 3; CVar 4]); CProp ("if",[CVar 2; CVar 3; CVar 4])])])); add (CProp ("equal", [CProp ("zerop",[CVar 23]); CProp ("or", [CProp ("equal",[CVar 23; CProp ("zero",[])]); CProp ("not",[CProp ("numberp",[CVar 23])])])])); add (CProp ("equal", [CProp ("plus",[CProp ("plus",[CVar 23; CVar 24]); CVar 25]); CProp ("plus",[CVar 23; CProp ("plus",[CVar 24; CVar 25])])])); add (CProp ("equal", [CProp ("equal",[CProp ("plus",[CVar 0; CVar 1]); CProp ("zero",[])]); CProp ("and",[CProp ("zerop",[CVar 0]); CProp ("zerop",[CVar 1])])])); add (CProp ("equal",[CProp ("difference",[CVar 23; CVar 23]); CProp ("zero",[])])); add (CProp ("equal", [CProp ("equal", [CProp ("plus",[CVar 0; CVar 1]); CProp ("plus",[CVar 0; CVar 2])]); CProp ("equal",[CProp ("fix",[CVar 1]); CProp ("fix",[CVar 2])])])); add (CProp ("equal", [CProp ("equal",[CProp ("zero",[]); CProp ("difference",[CVar 23; CVar 24])]); CProp ("not",[CProp ("gt",[CVar 24; CVar 23])])])); add (CProp ("equal", [CProp ("equal",[CVar 23; CProp ("difference",[CVar 23; CVar 24])]); CProp ("and", [CProp ("numberp",[CVar 23]); CProp ("or", [CProp ("equal",[CVar 23; CProp ("zero",[])]); CProp ("zerop",[CVar 24])])])])); add (CProp ("equal", [CProp ("meaning", [CProp ("plus_tree",[CProp ("append",[CVar 23; CVar 24])]); CVar 0]); CProp ("plus", [CProp ("meaning",[CProp ("plus_tree",[CVar 23]); CVar 0]); CProp ("meaning",[CProp ("plus_tree",[CVar 24]); CVar 0])])])); add (CProp ("equal", [CProp ("meaning", [CProp ("plus_tree",[CProp ("plus_fringe",[CVar 23])]); CVar 0]); CProp ("fix",[CProp ("meaning",[CVar 23; CVar 0])])])); add (CProp ("equal", [CProp ("append",[CProp ("append",[CVar 23; CVar 24]); CVar 25]); CProp ("append",[CVar 23; CProp ("append",[CVar 24; CVar 25])])])); add (CProp ("equal", [CProp ("reverse",[CProp ("append",[CVar 0; CVar 1])]); CProp ("append",[CProp ("reverse",[CVar 1]); CProp ("reverse",[CVar 0])])])); add (CProp ("equal", [CProp ("times",[CVar 23; CProp ("plus",[CVar 24; CVar 25])]); CProp ("plus", [CProp ("times",[CVar 23; CVar 24]); CProp ("times",[CVar 23; CVar 25])])])); add (CProp ("equal", [CProp ("times",[CProp ("times",[CVar 23; CVar 24]); CVar 25]); CProp ("times",[CVar 23; CProp ("times",[CVar 24; CVar 25])])])); add (CProp ("equal", [CProp ("equal",[CProp ("times",[CVar 23; CVar 24]); CProp ("zero",[])]); CProp ("or",[CProp ("zerop",[CVar 23]); CProp ("zerop",[CVar 24])])])); add (CProp ("equal", [CProp ("exec",[CProp ("append",[CVar 23; CVar 24]); CVar 15; CVar 4]); CProp ("exec",[CVar 24; CProp ("exec",[CVar 23; CVar 15; CVar 4]); CVar 4])])); add (CProp ("equal", [CProp ("mc_flatten",[CVar 23; CVar 24]); CProp ("append",[CProp ("flatten",[CVar 23]); CVar 24])])); add (CProp ("equal", [CProp ("member",[CVar 23; CProp ("append",[CVar 0; CVar 1])]); CProp ("or", [CProp ("member",[CVar 23; CVar 0]); CProp ("member",[CVar 23; CVar 1])])])); add (CProp ("equal", [CProp ("member",[CVar 23; CProp ("reverse",[CVar 24])]); CProp ("member",[CVar 23; CVar 24])])); add (CProp ("equal", [CProp ("length",[CProp ("reverse",[CVar 23])]); CProp ("length",[CVar 23])])); add (CProp ("equal", [CProp ("member",[CVar 0; CProp ("intersect",[CVar 1; CVar 2])]); CProp ("and", [CProp ("member",[CVar 0; CVar 1]); CProp ("member",[CVar 0; CVar 2])])])); add (CProp ("equal",[CProp ("nth",[CProp ("zero",[]); CVar 8]); CProp ("zero",[])])); add (CProp ("equal", [CProp ("exp",[CVar 8; CProp ("plus",[CVar 9; CVar 10])]); CProp ("times", [CProp ("exp",[CVar 8; CVar 9]); CProp ("exp",[CVar 8; CVar 10])])])); add (CProp ("equal", [CProp ("exp",[CVar 8; CProp ("times",[CVar 9; CVar 10])]); CProp ("exp",[CProp ("exp",[CVar 8; CVar 9]); CVar 10])])); add (CProp ("equal", [CProp ("reverse_loop",[CVar 23; CVar 24]); CProp ("append",[CProp ("reverse",[CVar 23]); CVar 24])])); add (CProp ("equal", [CProp ("reverse_loop",[CVar 23; CProp ("nil",[])]); CProp ("reverse",[CVar 23])])); add (CProp ("equal", [CProp ("count_list",[CVar 25; CProp ("sort_lp",[CVar 23; CVar 24])]); CProp ("plus", [CProp ("count_list",[CVar 25; CVar 23]); CProp ("count_list",[CVar 25; CVar 24])])])); add (CProp ("equal", [CProp ("equal", [CProp ("append",[CVar 0; CVar 1]); CProp ("append",[CVar 0; CVar 2])]); CProp ("equal",[CVar 1; CVar 2])])); add (CProp ("equal", [CProp ("plus", [CProp ("remainder",[CVar 23; CVar 24]); CProp ("times",[CVar 24; CProp ("quotient",[CVar 23; CVar 24])])]); CProp ("fix",[CVar 23])])); add (CProp ("equal", [CProp ("power_eval",[CProp ("big_plus",[CVar 11; CVar 8; CVar 1]); CVar 1]); CProp ("plus",[CProp ("power_eval",[CVar 11; CVar 1]); CVar 8])])); add (CProp ("equal", [CProp ("power_eval", [CProp ("big_plus",[CVar 23; CVar 24; CVar 8; CVar 1]); CVar 1]); CProp ("plus", [CVar 8; CProp ("plus", [CProp ("power_eval",[CVar 23; CVar 1]); CProp ("power_eval",[CVar 24; CVar 1])])])])); add (CProp ("equal", [CProp ("remainder",[CVar 24; CProp ("one",[])]); CProp ("zero",[])])); add (CProp ("equal", [CProp ("lt",[CProp ("remainder",[CVar 23; CVar 24]); CVar 24]); CProp ("not",[CProp ("zerop",[CVar 24])])])); add (CProp ("equal",[CProp ("remainder",[CVar 23; CVar 23]); CProp ("zero",[])])); add (CProp ("equal", [CProp ("lt",[CProp ("quotient",[CVar 8; CVar 9]); CVar 8]); CProp ("and", [CProp ("not",[CProp ("zerop",[CVar 8])]); CProp ("or", [CProp ("zerop",[CVar 9]); CProp ("not",[CProp ("equal",[CVar 9; CProp ("one",[])])])])])])); add (CProp ("equal", [CProp ("lt",[CProp ("remainder",[CVar 23; CVar 24]); CVar 23]); CProp ("and", [CProp ("not",[CProp ("zerop",[CVar 24])]); CProp ("not",[CProp ("zerop",[CVar 23])]); CProp ("not",[CProp ("lt",[CVar 23; CVar 24])])])])); add (CProp ("equal", [CProp ("power_eval",[CProp ("power_rep",[CVar 8; CVar 1]); CVar 1]); CProp ("fix",[CVar 8])])); add (CProp ("equal", [CProp ("power_eval", [CProp ("big_plus", [CProp ("power_rep",[CVar 8; CVar 1]); CProp ("power_rep",[CVar 9; CVar 1]); CProp ("zero",[]); CVar 1]); CVar 1]); CProp ("plus",[CVar 8; CVar 9])])); add (CProp ("equal", [CProp ("gcd",[CVar 23; CVar 24]); CProp ("gcd",[CVar 24; CVar 23])])); add (CProp ("equal", [CProp ("nth",[CProp ("append",[CVar 0; CVar 1]); CVar 8]); CProp ("append", [CProp ("nth",[CVar 0; CVar 8]); CProp ("nth", [CVar 1; CProp ("difference",[CVar 8; CProp ("length",[CVar 0])])])])])); add (CProp ("equal", [CProp ("difference",[CProp ("plus",[CVar 23; CVar 24]); CVar 23]); CProp ("fix",[CVar 24])])); add (CProp ("equal", [CProp ("difference",[CProp ("plus",[CVar 24; CVar 23]); CVar 23]); CProp ("fix",[CVar 24])])); add (CProp ("equal", [CProp ("difference", [CProp ("plus",[CVar 23; CVar 24]); CProp ("plus",[CVar 23; CVar 25])]); CProp ("difference",[CVar 24; CVar 25])])); add (CProp ("equal", [CProp ("times",[CVar 23; CProp ("difference",[CVar 2; CVar 22])]); CProp ("difference", [CProp ("times",[CVar 2; CVar 23]); CProp ("times",[CVar 22; CVar 23])])])); add (CProp ("equal", [CProp ("remainder",[CProp ("times",[CVar 23; CVar 25]); CVar 25]); CProp ("zero",[])])); add (CProp ("equal", [CProp ("difference", [CProp ("plus",[CVar 1; CProp ("plus",[CVar 0; CVar 2])]); CVar 0]); CProp ("plus",[CVar 1; CVar 2])])); add (CProp ("equal", [CProp ("difference", [CProp ("add1",[CProp ("plus",[CVar 24; CVar 25])]); CVar 25]); CProp ("add1",[CVar 24])])); add (CProp ("equal", [CProp ("lt", [CProp ("plus",[CVar 23; CVar 24]); CProp ("plus",[CVar 23; CVar 25])]); CProp ("lt",[CVar 24; CVar 25])])); add (CProp ("equal", [CProp ("lt", [CProp ("times",[CVar 23; CVar 25]); CProp ("times",[CVar 24; CVar 25])]); CProp ("and", [CProp ("not",[CProp ("zerop",[CVar 25])]); CProp ("lt",[CVar 23; CVar 24])])])); add (CProp ("equal", [CProp ("lt",[CVar 24; CProp ("plus",[CVar 23; CVar 24])]); CProp ("not",[CProp ("zerop",[CVar 23])])])); add (CProp ("equal", [CProp ("gcd", [CProp ("times",[CVar 23; CVar 25]); CProp ("times",[CVar 24; CVar 25])]); CProp ("times",[CVar 25; CProp ("gcd",[CVar 23; CVar 24])])])); add (CProp ("equal", [CProp ("value",[CProp ("normalize",[CVar 23]); CVar 0]); CProp ("value",[CVar 23; CVar 0])])); add (CProp ("equal", [CProp ("equal", [CProp ("flatten",[CVar 23]); CProp ("cons",[CVar 24; CProp ("nil",[])])]); CProp ("and", [CProp ("nlistp",[CVar 23]); CProp ("equal",[CVar 23; CVar 24])])])); add (CProp ("equal", [CProp ("listp",[CProp ("gother",[CVar 23])]); CProp ("listp",[CVar 23])])); add (CProp ("equal", [CProp ("samefringe",[CVar 23; CVar 24]); CProp ("equal",[CProp ("flatten",[CVar 23]); CProp ("flatten",[CVar 24])])])); add (CProp ("equal", [CProp ("equal", [CProp ("greatest_factor",[CVar 23; CVar 24]); CProp ("zero",[])]); CProp ("and", [CProp ("or", [CProp ("zerop",[CVar 24]); CProp ("equal",[CVar 24; CProp ("one",[])])]); CProp ("equal",[CVar 23; CProp ("zero",[])])])])); add (CProp ("equal", [CProp ("equal", [CProp ("greatest_factor",[CVar 23; CVar 24]); CProp ("one",[])]); CProp ("equal",[CVar 23; CProp ("one",[])])])); add (CProp ("equal", [CProp ("numberp",[CProp ("greatest_factor",[CVar 23; CVar 24])]); CProp ("not", [CProp ("and", [CProp ("or", [CProp ("zerop",[CVar 24]); CProp ("equal",[CVar 24; CProp ("one",[])])]); CProp ("not",[CProp ("numberp",[CVar 23])])])])])); add (CProp ("equal", [CProp ("times_list",[CProp ("append",[CVar 23; CVar 24])]); CProp ("times", [CProp ("times_list",[CVar 23]); CProp ("times_list",[CVar 24])])])); add (CProp ("equal", [CProp ("prime_list",[CProp ("append",[CVar 23; CVar 24])]); CProp ("and", [CProp ("prime_list",[CVar 23]); CProp ("prime_list",[CVar 24])])])); add (CProp ("equal", [CProp ("equal",[CVar 25; CProp ("times",[CVar 22; CVar 25])]); CProp ("and", [CProp ("numberp",[CVar 25]); CProp ("or", [CProp ("equal",[CVar 25; CProp ("zero",[])]); CProp ("equal",[CVar 22; CProp ("one",[])])])])])); add (CProp ("equal", [CProp ("ge",[CVar 23; CVar 24]); CProp ("not",[CProp ("lt",[CVar 23; CVar 24])])])); add (CProp ("equal", [CProp ("equal",[CVar 23; CProp ("times",[CVar 23; CVar 24])]); CProp ("or", [CProp ("equal",[CVar 23; CProp ("zero",[])]); CProp ("and", [CProp ("numberp",[CVar 23]); CProp ("equal",[CVar 24; CProp ("one",[])])])])])); add (CProp ("equal", [CProp ("remainder",[CProp ("times",[CVar 24; CVar 23]); CVar 24]); CProp ("zero",[])])); add (CProp ("equal", [CProp ("equal",[CProp ("times",[CVar 0; CVar 1]); CProp ("one",[])]); CProp ("and", [CProp ("not",[CProp ("equal",[CVar 0; CProp ("zero",[])])]); CProp ("not",[CProp ("equal",[CVar 1; CProp ("zero",[])])]); CProp ("numberp",[CVar 0]); CProp ("numberp",[CVar 1]); CProp ("equal",[CProp ("sub1",[CVar 0]); CProp ("zero",[])]); CProp ("equal",[CProp ("sub1",[CVar 1]); CProp ("zero",[])])])])); add (CProp ("equal", [CProp ("lt", [CProp ("length",[CProp ("delete",[CVar 23; CVar 11])]); CProp ("length",[CVar 11])]); CProp ("member",[CVar 23; CVar 11])])); add (CProp ("equal", [CProp ("sort2",[CProp ("delete",[CVar 23; CVar 11])]); CProp ("delete",[CVar 23; CProp ("sort2",[CVar 11])])])); add (CProp ("equal",[CProp ("dsort",[CVar 23]); CProp ("sort2",[CVar 23])])); add (CProp ("equal", [CProp ("length", [CProp ("cons", [CVar 0; CProp ("cons", [CVar 1; CProp ("cons", [CVar 2; CProp ("cons", [CVar 3; CProp ("cons",[CVar 4; CProp ("cons",[CVar 5; CVar 6])])])])])])]) ; CProp ("plus",[CProp ("six",[]); CProp ("length",[CVar 6])])])); add (CProp ("equal", [CProp ("difference", [CProp ("add1",[CProp ("add1",[CVar 23])]); CProp ("two",[])]); CProp ("fix",[CVar 23])])); add (CProp ("equal", [CProp ("quotient", [CProp ("plus",[CVar 23; CProp ("plus",[CVar 23; CVar 24])]); CProp ("two",[])]); CProp ("plus",[CVar 23; CProp ("quotient",[CVar 24; CProp ("two",[])])])])); add (CProp ("equal", [CProp ("sigma",[CProp ("zero",[]); CVar 8]); CProp ("quotient", [CProp ("times",[CVar 8; CProp ("add1",[CVar 8])]); CProp ("two",[])])])); add (CProp ("equal", [CProp ("plus",[CVar 23; CProp ("add1",[CVar 24])]); CProp ("if", [CProp ("numberp",[CVar 24]); CProp ("add1",[CProp ("plus",[CVar 23; CVar 24])]); CProp ("add1",[CVar 23])])])); add (CProp ("equal", [CProp ("equal", [CProp ("difference",[CVar 23; CVar 24]); CProp ("difference",[CVar 25; CVar 24])]); CProp ("if", [CProp ("lt",[CVar 23; CVar 24]); CProp ("not",[CProp ("lt",[CVar 24; CVar 25])]); CProp ("if", [CProp ("lt",[CVar 25; CVar 24]); CProp ("not",[CProp ("lt",[CVar 24; CVar 23])]); CProp ("equal",[CProp ("fix",[CVar 23]); CProp ("fix",[CVar 25])])])])]) ); add (CProp ("equal", [CProp ("meaning", [CProp ("plus_tree",[CProp ("delete",[CVar 23; CVar 24])]); CVar 0]); CProp ("if", [CProp ("member",[CVar 23; CVar 24]); CProp ("difference", [CProp ("meaning",[CProp ("plus_tree",[CVar 24]); CVar 0]); CProp ("meaning",[CVar 23; CVar 0])]); CProp ("meaning",[CProp ("plus_tree",[CVar 24]); CVar 0])])])); add (CProp ("equal", [CProp ("times",[CVar 23; CProp ("add1",[CVar 24])]); CProp ("if", [CProp ("numberp",[CVar 24]); CProp ("plus", [CVar 23; CProp ("times",[CVar 23; CVar 24]); CProp ("fix",[CVar 23])])])])); add (CProp ("equal", [CProp ("nth",[CProp ("nil",[]); CVar 8]); CProp ("if",[CProp ("zerop",[CVar 8]); CProp ("nil",[]); CProp ("zero",[])])])); add (CProp ("equal", [CProp ("last",[CProp ("append",[CVar 0; CVar 1])]); CProp ("if", [CProp ("listp",[CVar 1]); CProp ("last",[CVar 1]); CProp ("if", [CProp ("listp",[CVar 0]); CProp ("cons",[CProp ("car",[CProp ("last",[CVar 0])]); CVar 1]); CVar 1])])])); add (CProp ("equal", [CProp ("equal",[CProp ("lt",[CVar 23; CVar 24]); CVar 25]); CProp ("if", [CProp ("lt",[CVar 23; CVar 24]); CProp ("equal",[CProp ("true",[]); CVar 25]); CProp ("equal",[CProp ("false",[]); CVar 25])])])); add (CProp ("equal", [CProp ("assignment",[CVar 23; CProp ("append",[CVar 0; CVar 1])]); CProp ("if", [CProp ("assignedp",[CVar 23; CVar 0]); CProp ("assignment",[CVar 23; CVar 0]); CProp ("assignment",[CVar 23; CVar 1])])])); add (CProp ("equal", [CProp ("car",[CProp ("gother",[CVar 23])]); CProp ("if", [CProp ("listp",[CVar 23]); CProp ("car",[CProp ("flatten",[CVar 23])]); CProp ("zero",[])])])); add (CProp ("equal", [CProp ("flatten",[CProp ("cdr",[CProp ("gother",[CVar 23])])]); CProp ("if", [CProp ("listp",[CVar 23]); CProp ("cdr",[CProp ("flatten",[CVar 23])]); CProp ("cons",[CProp ("zero",[]); CProp ("nil",[])])])])); add (CProp ("equal", [CProp ("quotient",[CProp ("times",[CVar 24; CVar 23]); CVar 24]); CProp ("if", [CProp ("zerop",[CVar 24]); CProp ("zero",[]); CProp ("fix",[CVar 23])])])); add (CProp ("equal", [CProp ("get",[CVar 9; CProp ("set",[CVar 8; CVar 21; CVar 12])]); CProp ("if", [CProp ("eqp",[CVar 9; CVar 8]); CVar 21; CProp ("get",[CVar 9; CVar 12])])])) (* Tautology checker *) let truep x lst = match x with Prop(head, _) -> head.name = "true" || List.mem x lst | _ -> List.mem x lst and falsep x lst = match x with Prop(head, _) -> head.name = "false" || List.mem x lst | _ -> List.mem x lst let rec tautologyp x true_lst false_lst = if truep x true_lst then true else if falsep x false_lst then false else begin (* print_term x; print_newline(); *) match x with Var _ -> false | Prop (head,[test; yes; no]) -> if head.name = "if" then if truep test true_lst then tautologyp yes true_lst false_lst else if falsep test false_lst then tautologyp no true_lst false_lst else tautologyp yes (test::true_lst) false_lst && tautologyp no true_lst (test::false_lst) else false | _ -> assert false end let tautp x = (* print_term x; print_string"\n"; *) let y = rewrite x in (* print_term y; print_string "\n"; *) tautologyp y [] [] (* the benchmark *) let subst = [Bind(23, cterm_to_term( CProp ("f", [CProp ("plus", [CProp ("plus",[CVar 0; CVar 1]); CProp ("plus",[CVar 2; CProp ("zero",[])])])]))); Bind(24, cterm_to_term( CProp ("f", [CProp ("times", [CProp ("times",[CVar 0; CVar 1]); CProp ("plus",[CVar 2; CVar 3])])]))); Bind(25, cterm_to_term( CProp ("f", [CProp ("reverse", [CProp ("append", [CProp ("append",[CVar 0; CVar 1]); CProp ("nil",[])])])]))); Bind(20, cterm_to_term( CProp ("equal", [CProp ("plus",[CVar 0; CVar 1]); CProp ("difference",[CVar 23; CVar 24])]))); Bind(22, cterm_to_term( CProp ("lt", [CProp ("remainder",[CVar 0; CVar 1]); CProp ("member",[CVar 0; CProp ("length",[CVar 1])])])))] let term = cterm_to_term( CProp ("implies", [CProp ("and", [CProp ("implies",[CVar 23; CVar 24]); CProp ("and", [CProp ("implies",[CVar 24; CVar 25]); CProp ("and", [CProp ("implies",[CVar 25; CVar 20]); CProp ("implies",[CVar 20; CVar 22])])])]); CProp ("implies",[CVar 23; CVar 22])])) let _ = let ok = ref true in for i = 1 to 50 do if not (tautp (apply_subst subst term)) then ok := false done; assert !ok; (* if !ok then print_string "Proved!\n" else print_string "Cannot prove!\n"; exit 0 *) (********* with failure s -> print_string "Exception failure("; print_string s; print_string ")\n" | Unify -> print_string "Exception Unify\n" | match_failure(file,start,stop) -> print_string "Exception match_failure("; print_string file; print_string ","; print_int start; print_string ","; print_int stop; print_string ")\n" | _ -> print_string "Exception ?\n" **********) js_of_ocaml-2.5/benchmarks/sources/ml/boyer_no_exc.ml000066400000000000000000000624741241254034500230650ustar00rootroot00000000000000(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: boyer.ml 7017 2005-08-12 09:22:04Z xleroy $ *) (* Manipulations over terms *) type term = Var of int | Prop of head * term list and head = { name: string; mutable props: (term * term) list } let rec print_term = function Var v -> print_string "v"; print_int v | Prop (head,argl) -> print_string "("; print_string head.name; List.iter (fun t -> print_string " "; print_term t) argl; print_string ")" let lemmas = ref ([] : head list) (* Replacement for property lists *) let get name = let rec get_rec = function hd1::hdl -> if hd1.name = name then hd1 else get_rec hdl | [] -> let entry = {name = name; props = []} in lemmas := entry :: !lemmas; entry in get_rec !lemmas let add_lemma = function | Prop(_, [(Prop(headl,_) as left); right]) -> headl.props <- (left, right) :: headl.props | _ -> assert false (* Substitutions *) type subst = Bind of int * term let get_binding v list = let rec get_rec = function [] -> None | Bind(w,t)::rest -> if v = w then Some t else get_rec rest in get_rec list let apply_subst alist term = let rec as_rec = function Var v -> begin match get_binding v alist with Some t -> t | None -> term end | Prop (head,argl) -> Prop (head, List.map as_rec argl) in as_rec term exception Unify let rec unify term1 term2 = unify1 term1 term2 [] and unify1 term1 term2 unify_subst = match term2 with Var v -> begin match get_binding v unify_subst with Some t when t = term1 -> Some unify_subst | Some _ -> None | None -> Some (Bind(v,term1) :: unify_subst) end | Prop (head2, argl2) -> match term1 with Var _ -> None | Prop (head1,argl1) -> if head1 == head2 then unify1_lst argl1 argl2 unify_subst else None and unify1_lst l1 l2 unify_subst = match (l1, l2) with ([], []) -> Some unify_subst | (h1::r1, h2::r2) -> begin match unify1 h1 h2 unify_subst with Some unify_subst -> unify1_lst r1 r2 unify_subst | None -> None end | _ -> None let rec rewrite = function Var _ as term -> term | Prop (head, argl) -> rewrite_with_lemmas (Prop (head, List.map rewrite argl)) head.props and rewrite_with_lemmas term lemmas = match lemmas with [] -> term | (t1,t2)::rest -> match unify term t1 with Some unify_subst -> rewrite (apply_subst unify_subst t2) | None -> rewrite_with_lemmas term rest type cterm = CVar of int | CProp of string * cterm list let rec cterm_to_term = function CVar v -> Var v | CProp(p, l) -> Prop(get p, List.map cterm_to_term l) let add t = add_lemma (cterm_to_term t) let _ = add (CProp ("equal", [CProp ("compile",[CVar 5]); CProp ("reverse", [CProp ("codegen",[CProp ("optimize",[CVar 5]); CProp ("nil",[])])])])); add (CProp ("equal", [CProp ("eqp",[CVar 23; CVar 24]); CProp ("equal",[CProp ("fix",[CVar 23]); CProp ("fix",[CVar 24])])])); add (CProp ("equal", [CProp ("gt",[CVar 23; CVar 24]); CProp ("lt",[CVar 24; CVar 23])])); add (CProp ("equal", [CProp ("le",[CVar 23; CVar 24]); CProp ("ge",[CVar 24; CVar 23])])); add (CProp ("equal", [CProp ("ge",[CVar 23; CVar 24]); CProp ("le",[CVar 24; CVar 23])])); add (CProp ("equal", [CProp ("boolean",[CVar 23]); CProp ("or", [CProp ("equal",[CVar 23; CProp ("true",[])]); CProp ("equal",[CVar 23; CProp ("false",[])])])])); add (CProp ("equal", [CProp ("iff",[CVar 23; CVar 24]); CProp ("and", [CProp ("implies",[CVar 23; CVar 24]); CProp ("implies",[CVar 24; CVar 23])])])); add (CProp ("equal", [CProp ("even1",[CVar 23]); CProp ("if", [CProp ("zerop",[CVar 23]); CProp ("true",[]); CProp ("odd",[CProp ("sub1",[CVar 23])])])])); add (CProp ("equal", [CProp ("countps_",[CVar 11; CVar 15]); CProp ("countps_loop",[CVar 11; CVar 15; CProp ("zero",[])])])); add (CProp ("equal", [CProp ("fact_",[CVar 8]); CProp ("fact_loop",[CVar 8; CProp ("one",[])])])); add (CProp ("equal", [CProp ("reverse_",[CVar 23]); CProp ("reverse_loop",[CVar 23; CProp ("nil",[])])])); add (CProp ("equal", [CProp ("divides",[CVar 23; CVar 24]); CProp ("zerop",[CProp ("remainder",[CVar 24; CVar 23])])])); add (CProp ("equal", [CProp ("assume_true",[CVar 21; CVar 0]); CProp ("cons",[CProp ("cons",[CVar 21; CProp ("true",[])]); CVar 0])])); add (CProp ("equal", [CProp ("assume_false",[CVar 21; CVar 0]); CProp ("cons",[CProp ("cons",[CVar 21; CProp ("false",[])]); CVar 0])])); add (CProp ("equal", [CProp ("tautology_checker",[CVar 23]); CProp ("tautologyp",[CProp ("normalize",[CVar 23]); CProp ("nil",[])])])); add (CProp ("equal", [CProp ("falsify",[CVar 23]); CProp ("falsify1",[CProp ("normalize",[CVar 23]); CProp ("nil",[])])])); add (CProp ("equal", [CProp ("prime",[CVar 23]); CProp ("and", [CProp ("not",[CProp ("zerop",[CVar 23])]); CProp ("not", [CProp ("equal",[CVar 23; CProp ("add1",[CProp ("zero",[])])])]); CProp ("prime1",[CVar 23; CProp ("sub1",[CVar 23])])])])); add (CProp ("equal", [CProp ("and",[CVar 15; CVar 16]); CProp ("if", [CVar 15; CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]); CProp ("false",[])])])); add (CProp ("equal", [CProp ("or",[CVar 15; CVar 16]); CProp ("if", [CVar 15; CProp ("true",[]); CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]); CProp ("false",[])])])); add (CProp ("equal", [CProp ("not",[CVar 15]); CProp ("if",[CVar 15; CProp ("false",[]); CProp ("true",[])])])); add (CProp ("equal", [CProp ("implies",[CVar 15; CVar 16]); CProp ("if", [CVar 15; CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]); CProp ("true",[])])])); add (CProp ("equal", [CProp ("fix",[CVar 23]); CProp ("if",[CProp ("numberp",[CVar 23]); CVar 23; CProp ("zero",[])])])); add (CProp ("equal", [CProp ("if",[CProp ("if",[CVar 0; CVar 1; CVar 2]); CVar 3; CVar 4]); CProp ("if", [CVar 0; CProp ("if",[CVar 1; CVar 3; CVar 4]); CProp ("if",[CVar 2; CVar 3; CVar 4])])])); add (CProp ("equal", [CProp ("zerop",[CVar 23]); CProp ("or", [CProp ("equal",[CVar 23; CProp ("zero",[])]); CProp ("not",[CProp ("numberp",[CVar 23])])])])); add (CProp ("equal", [CProp ("plus",[CProp ("plus",[CVar 23; CVar 24]); CVar 25]); CProp ("plus",[CVar 23; CProp ("plus",[CVar 24; CVar 25])])])); add (CProp ("equal", [CProp ("equal",[CProp ("plus",[CVar 0; CVar 1]); CProp ("zero",[])]); CProp ("and",[CProp ("zerop",[CVar 0]); CProp ("zerop",[CVar 1])])])); add (CProp ("equal",[CProp ("difference",[CVar 23; CVar 23]); CProp ("zero",[])])); add (CProp ("equal", [CProp ("equal", [CProp ("plus",[CVar 0; CVar 1]); CProp ("plus",[CVar 0; CVar 2])]); CProp ("equal",[CProp ("fix",[CVar 1]); CProp ("fix",[CVar 2])])])); add (CProp ("equal", [CProp ("equal",[CProp ("zero",[]); CProp ("difference",[CVar 23; CVar 24])]); CProp ("not",[CProp ("gt",[CVar 24; CVar 23])])])); add (CProp ("equal", [CProp ("equal",[CVar 23; CProp ("difference",[CVar 23; CVar 24])]); CProp ("and", [CProp ("numberp",[CVar 23]); CProp ("or", [CProp ("equal",[CVar 23; CProp ("zero",[])]); CProp ("zerop",[CVar 24])])])])); add (CProp ("equal", [CProp ("meaning", [CProp ("plus_tree",[CProp ("append",[CVar 23; CVar 24])]); CVar 0]); CProp ("plus", [CProp ("meaning",[CProp ("plus_tree",[CVar 23]); CVar 0]); CProp ("meaning",[CProp ("plus_tree",[CVar 24]); CVar 0])])])); add (CProp ("equal", [CProp ("meaning", [CProp ("plus_tree",[CProp ("plus_fringe",[CVar 23])]); CVar 0]); CProp ("fix",[CProp ("meaning",[CVar 23; CVar 0])])])); add (CProp ("equal", [CProp ("append",[CProp ("append",[CVar 23; CVar 24]); CVar 25]); CProp ("append",[CVar 23; CProp ("append",[CVar 24; CVar 25])])])); add (CProp ("equal", [CProp ("reverse",[CProp ("append",[CVar 0; CVar 1])]); CProp ("append",[CProp ("reverse",[CVar 1]); CProp ("reverse",[CVar 0])])])); add (CProp ("equal", [CProp ("times",[CVar 23; CProp ("plus",[CVar 24; CVar 25])]); CProp ("plus", [CProp ("times",[CVar 23; CVar 24]); CProp ("times",[CVar 23; CVar 25])])])); add (CProp ("equal", [CProp ("times",[CProp ("times",[CVar 23; CVar 24]); CVar 25]); CProp ("times",[CVar 23; CProp ("times",[CVar 24; CVar 25])])])); add (CProp ("equal", [CProp ("equal",[CProp ("times",[CVar 23; CVar 24]); CProp ("zero",[])]); CProp ("or",[CProp ("zerop",[CVar 23]); CProp ("zerop",[CVar 24])])])); add (CProp ("equal", [CProp ("exec",[CProp ("append",[CVar 23; CVar 24]); CVar 15; CVar 4]); CProp ("exec",[CVar 24; CProp ("exec",[CVar 23; CVar 15; CVar 4]); CVar 4])])); add (CProp ("equal", [CProp ("mc_flatten",[CVar 23; CVar 24]); CProp ("append",[CProp ("flatten",[CVar 23]); CVar 24])])); add (CProp ("equal", [CProp ("member",[CVar 23; CProp ("append",[CVar 0; CVar 1])]); CProp ("or", [CProp ("member",[CVar 23; CVar 0]); CProp ("member",[CVar 23; CVar 1])])])); add (CProp ("equal", [CProp ("member",[CVar 23; CProp ("reverse",[CVar 24])]); CProp ("member",[CVar 23; CVar 24])])); add (CProp ("equal", [CProp ("length",[CProp ("reverse",[CVar 23])]); CProp ("length",[CVar 23])])); add (CProp ("equal", [CProp ("member",[CVar 0; CProp ("intersect",[CVar 1; CVar 2])]); CProp ("and", [CProp ("member",[CVar 0; CVar 1]); CProp ("member",[CVar 0; CVar 2])])])); add (CProp ("equal",[CProp ("nth",[CProp ("zero",[]); CVar 8]); CProp ("zero",[])])); add (CProp ("equal", [CProp ("exp",[CVar 8; CProp ("plus",[CVar 9; CVar 10])]); CProp ("times", [CProp ("exp",[CVar 8; CVar 9]); CProp ("exp",[CVar 8; CVar 10])])])); add (CProp ("equal", [CProp ("exp",[CVar 8; CProp ("times",[CVar 9; CVar 10])]); CProp ("exp",[CProp ("exp",[CVar 8; CVar 9]); CVar 10])])); add (CProp ("equal", [CProp ("reverse_loop",[CVar 23; CVar 24]); CProp ("append",[CProp ("reverse",[CVar 23]); CVar 24])])); add (CProp ("equal", [CProp ("reverse_loop",[CVar 23; CProp ("nil",[])]); CProp ("reverse",[CVar 23])])); add (CProp ("equal", [CProp ("count_list",[CVar 25; CProp ("sort_lp",[CVar 23; CVar 24])]); CProp ("plus", [CProp ("count_list",[CVar 25; CVar 23]); CProp ("count_list",[CVar 25; CVar 24])])])); add (CProp ("equal", [CProp ("equal", [CProp ("append",[CVar 0; CVar 1]); CProp ("append",[CVar 0; CVar 2])]); CProp ("equal",[CVar 1; CVar 2])])); add (CProp ("equal", [CProp ("plus", [CProp ("remainder",[CVar 23; CVar 24]); CProp ("times",[CVar 24; CProp ("quotient",[CVar 23; CVar 24])])]); CProp ("fix",[CVar 23])])); add (CProp ("equal", [CProp ("power_eval",[CProp ("big_plus",[CVar 11; CVar 8; CVar 1]); CVar 1]); CProp ("plus",[CProp ("power_eval",[CVar 11; CVar 1]); CVar 8])])); add (CProp ("equal", [CProp ("power_eval", [CProp ("big_plus",[CVar 23; CVar 24; CVar 8; CVar 1]); CVar 1]); CProp ("plus", [CVar 8; CProp ("plus", [CProp ("power_eval",[CVar 23; CVar 1]); CProp ("power_eval",[CVar 24; CVar 1])])])])); add (CProp ("equal", [CProp ("remainder",[CVar 24; CProp ("one",[])]); CProp ("zero",[])])); add (CProp ("equal", [CProp ("lt",[CProp ("remainder",[CVar 23; CVar 24]); CVar 24]); CProp ("not",[CProp ("zerop",[CVar 24])])])); add (CProp ("equal",[CProp ("remainder",[CVar 23; CVar 23]); CProp ("zero",[])])); add (CProp ("equal", [CProp ("lt",[CProp ("quotient",[CVar 8; CVar 9]); CVar 8]); CProp ("and", [CProp ("not",[CProp ("zerop",[CVar 8])]); CProp ("or", [CProp ("zerop",[CVar 9]); CProp ("not",[CProp ("equal",[CVar 9; CProp ("one",[])])])])])])); add (CProp ("equal", [CProp ("lt",[CProp ("remainder",[CVar 23; CVar 24]); CVar 23]); CProp ("and", [CProp ("not",[CProp ("zerop",[CVar 24])]); CProp ("not",[CProp ("zerop",[CVar 23])]); CProp ("not",[CProp ("lt",[CVar 23; CVar 24])])])])); add (CProp ("equal", [CProp ("power_eval",[CProp ("power_rep",[CVar 8; CVar 1]); CVar 1]); CProp ("fix",[CVar 8])])); add (CProp ("equal", [CProp ("power_eval", [CProp ("big_plus", [CProp ("power_rep",[CVar 8; CVar 1]); CProp ("power_rep",[CVar 9; CVar 1]); CProp ("zero",[]); CVar 1]); CVar 1]); CProp ("plus",[CVar 8; CVar 9])])); add (CProp ("equal", [CProp ("gcd",[CVar 23; CVar 24]); CProp ("gcd",[CVar 24; CVar 23])])); add (CProp ("equal", [CProp ("nth",[CProp ("append",[CVar 0; CVar 1]); CVar 8]); CProp ("append", [CProp ("nth",[CVar 0; CVar 8]); CProp ("nth", [CVar 1; CProp ("difference",[CVar 8; CProp ("length",[CVar 0])])])])])); add (CProp ("equal", [CProp ("difference",[CProp ("plus",[CVar 23; CVar 24]); CVar 23]); CProp ("fix",[CVar 24])])); add (CProp ("equal", [CProp ("difference",[CProp ("plus",[CVar 24; CVar 23]); CVar 23]); CProp ("fix",[CVar 24])])); add (CProp ("equal", [CProp ("difference", [CProp ("plus",[CVar 23; CVar 24]); CProp ("plus",[CVar 23; CVar 25])]); CProp ("difference",[CVar 24; CVar 25])])); add (CProp ("equal", [CProp ("times",[CVar 23; CProp ("difference",[CVar 2; CVar 22])]); CProp ("difference", [CProp ("times",[CVar 2; CVar 23]); CProp ("times",[CVar 22; CVar 23])])])); add (CProp ("equal", [CProp ("remainder",[CProp ("times",[CVar 23; CVar 25]); CVar 25]); CProp ("zero",[])])); add (CProp ("equal", [CProp ("difference", [CProp ("plus",[CVar 1; CProp ("plus",[CVar 0; CVar 2])]); CVar 0]); CProp ("plus",[CVar 1; CVar 2])])); add (CProp ("equal", [CProp ("difference", [CProp ("add1",[CProp ("plus",[CVar 24; CVar 25])]); CVar 25]); CProp ("add1",[CVar 24])])); add (CProp ("equal", [CProp ("lt", [CProp ("plus",[CVar 23; CVar 24]); CProp ("plus",[CVar 23; CVar 25])]); CProp ("lt",[CVar 24; CVar 25])])); add (CProp ("equal", [CProp ("lt", [CProp ("times",[CVar 23; CVar 25]); CProp ("times",[CVar 24; CVar 25])]); CProp ("and", [CProp ("not",[CProp ("zerop",[CVar 25])]); CProp ("lt",[CVar 23; CVar 24])])])); add (CProp ("equal", [CProp ("lt",[CVar 24; CProp ("plus",[CVar 23; CVar 24])]); CProp ("not",[CProp ("zerop",[CVar 23])])])); add (CProp ("equal", [CProp ("gcd", [CProp ("times",[CVar 23; CVar 25]); CProp ("times",[CVar 24; CVar 25])]); CProp ("times",[CVar 25; CProp ("gcd",[CVar 23; CVar 24])])])); add (CProp ("equal", [CProp ("value",[CProp ("normalize",[CVar 23]); CVar 0]); CProp ("value",[CVar 23; CVar 0])])); add (CProp ("equal", [CProp ("equal", [CProp ("flatten",[CVar 23]); CProp ("cons",[CVar 24; CProp ("nil",[])])]); CProp ("and", [CProp ("nlistp",[CVar 23]); CProp ("equal",[CVar 23; CVar 24])])])); add (CProp ("equal", [CProp ("listp",[CProp ("gother",[CVar 23])]); CProp ("listp",[CVar 23])])); add (CProp ("equal", [CProp ("samefringe",[CVar 23; CVar 24]); CProp ("equal",[CProp ("flatten",[CVar 23]); CProp ("flatten",[CVar 24])])])); add (CProp ("equal", [CProp ("equal", [CProp ("greatest_factor",[CVar 23; CVar 24]); CProp ("zero",[])]); CProp ("and", [CProp ("or", [CProp ("zerop",[CVar 24]); CProp ("equal",[CVar 24; CProp ("one",[])])]); CProp ("equal",[CVar 23; CProp ("zero",[])])])])); add (CProp ("equal", [CProp ("equal", [CProp ("greatest_factor",[CVar 23; CVar 24]); CProp ("one",[])]); CProp ("equal",[CVar 23; CProp ("one",[])])])); add (CProp ("equal", [CProp ("numberp",[CProp ("greatest_factor",[CVar 23; CVar 24])]); CProp ("not", [CProp ("and", [CProp ("or", [CProp ("zerop",[CVar 24]); CProp ("equal",[CVar 24; CProp ("one",[])])]); CProp ("not",[CProp ("numberp",[CVar 23])])])])])); add (CProp ("equal", [CProp ("times_list",[CProp ("append",[CVar 23; CVar 24])]); CProp ("times", [CProp ("times_list",[CVar 23]); CProp ("times_list",[CVar 24])])])); add (CProp ("equal", [CProp ("prime_list",[CProp ("append",[CVar 23; CVar 24])]); CProp ("and", [CProp ("prime_list",[CVar 23]); CProp ("prime_list",[CVar 24])])])); add (CProp ("equal", [CProp ("equal",[CVar 25; CProp ("times",[CVar 22; CVar 25])]); CProp ("and", [CProp ("numberp",[CVar 25]); CProp ("or", [CProp ("equal",[CVar 25; CProp ("zero",[])]); CProp ("equal",[CVar 22; CProp ("one",[])])])])])); add (CProp ("equal", [CProp ("ge",[CVar 23; CVar 24]); CProp ("not",[CProp ("lt",[CVar 23; CVar 24])])])); add (CProp ("equal", [CProp ("equal",[CVar 23; CProp ("times",[CVar 23; CVar 24])]); CProp ("or", [CProp ("equal",[CVar 23; CProp ("zero",[])]); CProp ("and", [CProp ("numberp",[CVar 23]); CProp ("equal",[CVar 24; CProp ("one",[])])])])])); add (CProp ("equal", [CProp ("remainder",[CProp ("times",[CVar 24; CVar 23]); CVar 24]); CProp ("zero",[])])); add (CProp ("equal", [CProp ("equal",[CProp ("times",[CVar 0; CVar 1]); CProp ("one",[])]); CProp ("and", [CProp ("not",[CProp ("equal",[CVar 0; CProp ("zero",[])])]); CProp ("not",[CProp ("equal",[CVar 1; CProp ("zero",[])])]); CProp ("numberp",[CVar 0]); CProp ("numberp",[CVar 1]); CProp ("equal",[CProp ("sub1",[CVar 0]); CProp ("zero",[])]); CProp ("equal",[CProp ("sub1",[CVar 1]); CProp ("zero",[])])])])); add (CProp ("equal", [CProp ("lt", [CProp ("length",[CProp ("delete",[CVar 23; CVar 11])]); CProp ("length",[CVar 11])]); CProp ("member",[CVar 23; CVar 11])])); add (CProp ("equal", [CProp ("sort2",[CProp ("delete",[CVar 23; CVar 11])]); CProp ("delete",[CVar 23; CProp ("sort2",[CVar 11])])])); add (CProp ("equal",[CProp ("dsort",[CVar 23]); CProp ("sort2",[CVar 23])])); add (CProp ("equal", [CProp ("length", [CProp ("cons", [CVar 0; CProp ("cons", [CVar 1; CProp ("cons", [CVar 2; CProp ("cons", [CVar 3; CProp ("cons",[CVar 4; CProp ("cons",[CVar 5; CVar 6])])])])])])]) ; CProp ("plus",[CProp ("six",[]); CProp ("length",[CVar 6])])])); add (CProp ("equal", [CProp ("difference", [CProp ("add1",[CProp ("add1",[CVar 23])]); CProp ("two",[])]); CProp ("fix",[CVar 23])])); add (CProp ("equal", [CProp ("quotient", [CProp ("plus",[CVar 23; CProp ("plus",[CVar 23; CVar 24])]); CProp ("two",[])]); CProp ("plus",[CVar 23; CProp ("quotient",[CVar 24; CProp ("two",[])])])])); add (CProp ("equal", [CProp ("sigma",[CProp ("zero",[]); CVar 8]); CProp ("quotient", [CProp ("times",[CVar 8; CProp ("add1",[CVar 8])]); CProp ("two",[])])])); add (CProp ("equal", [CProp ("plus",[CVar 23; CProp ("add1",[CVar 24])]); CProp ("if", [CProp ("numberp",[CVar 24]); CProp ("add1",[CProp ("plus",[CVar 23; CVar 24])]); CProp ("add1",[CVar 23])])])); add (CProp ("equal", [CProp ("equal", [CProp ("difference",[CVar 23; CVar 24]); CProp ("difference",[CVar 25; CVar 24])]); CProp ("if", [CProp ("lt",[CVar 23; CVar 24]); CProp ("not",[CProp ("lt",[CVar 24; CVar 25])]); CProp ("if", [CProp ("lt",[CVar 25; CVar 24]); CProp ("not",[CProp ("lt",[CVar 24; CVar 23])]); CProp ("equal",[CProp ("fix",[CVar 23]); CProp ("fix",[CVar 25])])])])]) ); add (CProp ("equal", [CProp ("meaning", [CProp ("plus_tree",[CProp ("delete",[CVar 23; CVar 24])]); CVar 0]); CProp ("if", [CProp ("member",[CVar 23; CVar 24]); CProp ("difference", [CProp ("meaning",[CProp ("plus_tree",[CVar 24]); CVar 0]); CProp ("meaning",[CVar 23; CVar 0])]); CProp ("meaning",[CProp ("plus_tree",[CVar 24]); CVar 0])])])); add (CProp ("equal", [CProp ("times",[CVar 23; CProp ("add1",[CVar 24])]); CProp ("if", [CProp ("numberp",[CVar 24]); CProp ("plus", [CVar 23; CProp ("times",[CVar 23; CVar 24]); CProp ("fix",[CVar 23])])])])); add (CProp ("equal", [CProp ("nth",[CProp ("nil",[]); CVar 8]); CProp ("if",[CProp ("zerop",[CVar 8]); CProp ("nil",[]); CProp ("zero",[])])])); add (CProp ("equal", [CProp ("last",[CProp ("append",[CVar 0; CVar 1])]); CProp ("if", [CProp ("listp",[CVar 1]); CProp ("last",[CVar 1]); CProp ("if", [CProp ("listp",[CVar 0]); CProp ("cons",[CProp ("car",[CProp ("last",[CVar 0])]); CVar 1]); CVar 1])])])); add (CProp ("equal", [CProp ("equal",[CProp ("lt",[CVar 23; CVar 24]); CVar 25]); CProp ("if", [CProp ("lt",[CVar 23; CVar 24]); CProp ("equal",[CProp ("true",[]); CVar 25]); CProp ("equal",[CProp ("false",[]); CVar 25])])])); add (CProp ("equal", [CProp ("assignment",[CVar 23; CProp ("append",[CVar 0; CVar 1])]); CProp ("if", [CProp ("assignedp",[CVar 23; CVar 0]); CProp ("assignment",[CVar 23; CVar 0]); CProp ("assignment",[CVar 23; CVar 1])])])); add (CProp ("equal", [CProp ("car",[CProp ("gother",[CVar 23])]); CProp ("if", [CProp ("listp",[CVar 23]); CProp ("car",[CProp ("flatten",[CVar 23])]); CProp ("zero",[])])])); add (CProp ("equal", [CProp ("flatten",[CProp ("cdr",[CProp ("gother",[CVar 23])])]); CProp ("if", [CProp ("listp",[CVar 23]); CProp ("cdr",[CProp ("flatten",[CVar 23])]); CProp ("cons",[CProp ("zero",[]); CProp ("nil",[])])])])); add (CProp ("equal", [CProp ("quotient",[CProp ("times",[CVar 24; CVar 23]); CVar 24]); CProp ("if", [CProp ("zerop",[CVar 24]); CProp ("zero",[]); CProp ("fix",[CVar 23])])])); add (CProp ("equal", [CProp ("get",[CVar 9; CProp ("set",[CVar 8; CVar 21; CVar 12])]); CProp ("if", [CProp ("eqp",[CVar 9; CVar 8]); CVar 21; CProp ("get",[CVar 9; CVar 12])])])) (* Tautology checker *) let truep x lst = match x with Prop(head, _) -> head.name = "true" || List.mem x lst | _ -> List.mem x lst and falsep x lst = match x with Prop(head, _) -> head.name = "false" || List.mem x lst | _ -> List.mem x lst let rec tautologyp x true_lst false_lst = if truep x true_lst then true else if falsep x false_lst then false else begin (* print_term x; print_newline(); *) match x with Var _ -> false | Prop (head,[test; yes; no]) -> if head.name = "if" then if truep test true_lst then tautologyp yes true_lst false_lst else if falsep test false_lst then tautologyp no true_lst false_lst else tautologyp yes (test::true_lst) false_lst && tautologyp no true_lst (test::false_lst) else false | _ -> assert false end let tautp x = (* print_term x; print_string"\n"; *) let y = rewrite x in (* print_term y; print_string "\n"; *) tautologyp y [] [] (* the benchmark *) let subst = [Bind(23, cterm_to_term( CProp ("f", [CProp ("plus", [CProp ("plus",[CVar 0; CVar 1]); CProp ("plus",[CVar 2; CProp ("zero",[])])])]))); Bind(24, cterm_to_term( CProp ("f", [CProp ("times", [CProp ("times",[CVar 0; CVar 1]); CProp ("plus",[CVar 2; CVar 3])])]))); Bind(25, cterm_to_term( CProp ("f", [CProp ("reverse", [CProp ("append", [CProp ("append",[CVar 0; CVar 1]); CProp ("nil",[])])])]))); Bind(20, cterm_to_term( CProp ("equal", [CProp ("plus",[CVar 0; CVar 1]); CProp ("difference",[CVar 23; CVar 24])]))); Bind(22, cterm_to_term( CProp ("lt", [CProp ("remainder",[CVar 0; CVar 1]); CProp ("member",[CVar 0; CProp ("length",[CVar 1])])])))] let term = cterm_to_term( CProp ("implies", [CProp ("and", [CProp ("implies",[CVar 23; CVar 24]); CProp ("and", [CProp ("implies",[CVar 24; CVar 25]); CProp ("and", [CProp ("implies",[CVar 25; CVar 20]); CProp ("implies",[CVar 20; CVar 22])])])]); CProp ("implies",[CVar 23; CVar 22])])) let _ = let ok = ref true in for i = 1 to 50 do if not (tautp (apply_subst subst term)) then ok := false done; assert !ok; (* if !ok then print_string "Proved!\n" else print_string "Cannot prove!\n"; exit 0 *) (********* with failure s -> print_string "Exception failure("; print_string s; print_string ")\n" | Unify -> print_string "Exception Unify\n" | match_failure(file,start,stop) -> print_string "Exception match_failure("; print_string file; print_string ","; print_int start; print_string ","; print_int stop; print_string ")\n" | _ -> print_string "Exception ?\n" **********) js_of_ocaml-2.5/benchmarks/sources/ml/fannkuch_redux.ml000066400000000000000000000033701241254034500234040ustar00rootroot00000000000000(* The Computer Language Benchmarks Game http://shootout.alioth.debian.org/ from Scala version by Otto Bommer, August 2010 *) let fannkuch n = begin let perm1 = Array.make n 0 in for i = 0 to (n-1) do perm1.(i) <- i done; let perm = Array.make n 0 in let count = Array.make n 0 in let flips = ref 0 and maxflips = ref 0 and checksum = ref 0 and nperm = ref 0 and r = ref n in while !r > 0 do (* Printf.printf "perm="; i := 0; while !i < n do Printf.printf "%d " perm1.(!i); i := !i +1; done; Printf.printf "\n"; *) for i = 0 to n-1 do perm.(i) <- perm1.(i) done; while !r != 1 do count.(!r-1) <- !r; r := !r - 1; done; flips := 0; let k = ref perm.(0) in while !k != 0 do let t = ref 0 in for i = 0 to !k / 2 do t := perm.(i); perm.(i) <- perm.(!k - i); perm.(!k - i) <- !t; done; k := perm.(0); flips := !flips + 1; done; maxflips := max !maxflips !flips; checksum := !checksum + !flips * (1 - (!nperm land 1) lsl 1); let go = ref true in let t = ref 0 in while !go do if !r == n then begin go := false; r := 0; end else begin t := perm1.(0); for i = 0 to !r - 1 do perm1.(i) <- perm1.(i+1) done; perm1.(!r) <- !t; count.(!r) <- count.(!r) - 1; if count.(!r) > 0 then go := false else r := !r + 1; end done; incr nperm; done; (!maxflips, !checksum); end let _ = let n = 10 in let (_maxflips, _checksum) = fannkuch n in ((* Printf.printf "%d\nPfannkuchen(%d) = %d\n" checksum n maxflips *)) js_of_ocaml-2.5/benchmarks/sources/ml/fannkuch_redux_2.ml000066400000000000000000000035661241254034500236340ustar00rootroot00000000000000(* The Computer Language Benchmarks Game http://shootout.alioth.debian.org/ contributed by Isaac Gouy, transliterated from Mike Pall's Lua program *) let fannkuch n = let p = Array.make n 0 in let q = Array.make n 0 in let s = Array.make n 0 in let sign = ref 1 in let maxflips = ref 0 in let sum = ref 0 in for i = 0 to n - 1 do p.(i) <- i; q.(i) <- i; s.(i) <- i done; while true do let q0 = ref p.(0) in if !q0 <> 0 then begin for i = 1 to n - 1 do q.(i) <- p.(i) done; let flips = ref 1 in while let qq = q.(!q0) in if qq = 0 then begin sum := !sum + !sign * !flips; if !flips > !maxflips then maxflips := !flips; false end else true do let qq = q.(!q0) in q.(!q0) <- !q0; if !q0 >= 3 then begin let i = ref 1 in let j = ref (!q0 - 1) in while let t = q.(!i) in q.(!i) <- q.(!j); q.(!j) <- t; incr i; decr j; !i < !j do () done end; q0 := qq; incr flips done end; if !sign = 1 then begin let t = p.(1) in p.(1) <- p.(0); p.(0) <- t; sign := -1 end else begin let t = p.(1) in p.(1) <- p.(2); p.(2) <- t; sign := 1; try for i = 2 to n - 1 do let sx = s.(i) in if sx <> 0 then begin s.(i) <- sx - 1; raise Exit end; if i = n - 1 then begin Format.eprintf "%d %d@." !sum !maxflips; exit 0 end; s.(i) <- i; let t = p.(0) in for j = 0 to i do p.(j) <- p.(j + 1) done; p.(i + 1) <- t done with Exit -> () end done let n = 10 let pf = fannkuch n (* //print(pf[0] + "\n" + "Pfannkuchen(" + n + ") = " + pf[1]); *) js_of_ocaml-2.5/benchmarks/sources/ml/fft.ml000066400000000000000000000116131241254034500211560ustar00rootroot00000000000000(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: fft.ml 7017 2005-08-12 09:22:04Z xleroy $ *) let pi = 3.14159265358979323846 let tpi = 2.0 *. pi let fft px py np = let i = ref 2 in let m = ref 1 in while (!i < np) do i := !i + !i; m := !m + 1 done; let n = !i in if n <> np then begin for i = np+1 to n do px.(i) <- 0.0; py.(i) <- 0.0 done; (* print_string "Use "; print_int n; print_string " point fft"; print_newline() *) end; let n2 = ref(n+n) in for k = 1 to !m-1 do n2 := !n2 / 2; let n4 = !n2 / 4 in let e = tpi /. float !n2 in for j = 1 to n4 do let a = e *. float(j - 1) in let a3 = 3.0 *. a in let cc1 = cos(a) in let ss1 = sin(a) in let cc3 = cos(a3) in let ss3 = sin(a3) in let is = ref j in let id = ref(2 * !n2) in while !is < n do let i0r = ref !is in while !i0r < n do let i0 = !i0r in let i1 = i0 + n4 in let i2 = i1 + n4 in let i3 = i2 + n4 in let r1 = px.(i0) -. px.(i2) in px.(i0) <- px.(i0) +. px.(i2); let r2 = px.(i1) -. px.(i3) in px.(i1) <- px.(i1) +. px.(i3); let s1 = py.(i0) -. py.(i2) in py.(i0) <- py.(i0) +. py.(i2); let s2 = py.(i1) -. py.(i3) in py.(i1) <- py.(i1) +. py.(i3); let s3 = r1 -. s2 in let r1 = r1 +. s2 in let s2 = r2 -. s1 in let r2 = r2 +. s1 in px.(i2) <- r1*.cc1 -. s2*.ss1; py.(i2) <- -.s2*.cc1 -. r1*.ss1; px.(i3) <- s3*.cc3 +. r2*.ss3; py.(i3) <- r2*.cc3 -. s3*.ss3; i0r := i0 + !id done; is := 2 * !id - !n2 + j; id := 4 * !id done done done; (************************************) (* Last stage, length=2 butterfly *) (************************************) let is = ref 1 in let id = ref 4 in while !is < n do let i0r = ref !is in while !i0r <= n do let i0 = !i0r in let i1 = i0 + 1 in let r1 = px.(i0) in px.(i0) <- r1 +. px.(i1); px.(i1) <- r1 -. px.(i1); let r1 = py.(i0) in py.(i0) <- r1 +. py.(i1); py.(i1) <- r1 -. py.(i1); i0r := i0 + !id done; is := 2 * !id - 1; id := 4 * !id done; (*************************) (* Bit reverse counter *) (*************************) let j = ref 1 in for i = 1 to n - 1 do if i < !j then begin let xt = px.(!j) in px.(!j) <- px.(i); px.(i) <- xt; let xt = py.(!j) in py.(!j) <- py.(i); py.(i) <- xt end; let k = ref(n / 2) in while !k < !j do j := !j - !k; k := !k / 2 done; j := !j + !k done; n let test np = (* print_int np; print_string "... "; flush stdout;*) let enp = float np in let npm = np / 2 - 1 in let pxr = Array.make (np+2) 0.0 and pxi = Array.make (np+2) 0.0 in let t = pi /. enp in pxr.(1) <- (enp -. 1.0) *. 0.5; pxi.(1) <- 0.0; let n2 = np / 2 in pxr.(n2+1) <- -0.5; pxi.(n2+1) <- 0.0; for i = 1 to npm do let j = np - i in pxr.(i+1) <- -0.5; pxr.(j+1) <- -0.5; let z = t *. float i in let y = -0.5*.(cos(z)/.sin(z)) in pxi.(i+1) <- y; pxi.(j+1) <- -.y done; (** print_newline(); for i=0 to 15 do Printf.printf "%d %f %f\n" i pxr.(i+1) pxi.(i+1) done; **) let _ = fft pxr pxi np in (** for i=0 to 15 do Printf.printf "%d %f %f\n" i pxr.(i+1) pxi.(i+1) done; **) let zr = ref 0.0 in let zi = ref 0.0 in let kr = ref 0 in let ki = ref 0 in for i = 0 to np-1 do let a = abs_float(pxr.(i+1) -. float i) in if !zr < a then begin zr := a; kr := i end; let a = abs_float(pxi.(i+1)) in if !zi < a then begin zi := a; ki := i end done; (*print !zr; print !zi;*) if abs_float !zr <= 1e-8 && abs_float !zi <= 1e-8 then ((*print_string "ok"*)) else assert false(*print_string "ERROR"*); ((* print_newline()*)) let _ = let np = ref 16 in for i = 1 to 16 do test !np; np := !np*2 done js_of_ocaml-2.5/benchmarks/sources/ml/fib.ml000066400000000000000000000021201241254034500211300ustar00rootroot00000000000000(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: fib.ml 7017 2005-08-12 09:22:04Z xleroy $ *) let rec fib n = if n < 2 then 1 else fib(n-1) + fib(n-2) let _ = let n = 40 in (* if Array.length Sys.argv >= 2 then int_of_string Sys.argv.(1) else 40 in *) assert (fib n = 165580141) (*; print_newline(); exit 0*) js_of_ocaml-2.5/benchmarks/sources/ml/hamming.ml000066400000000000000000000057241241254034500220250ustar00rootroot00000000000000(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Damien Doligez, projet Moscova, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: hamming.ml 4303 2002-01-23 17:50:20Z doligez $ *) (* We cannot use bignums because we don't do custom runtimes, but int64 is a bit short, so we roll our own 37-digit numbers... *) let n0 = Int64.of_int 0;; let n1 = Int64.of_int 1;; let n2 = Int64.of_int 2;; let n3 = Int64.of_int 3;; let n5 = Int64.of_int 5;; let ( % ) = Int64.rem;; let ( * ) = Int64.mul;; let ( / ) = Int64.div;; let ( + ) = Int64.add;; let digit = Int64.of_string "1000000000000000000";; let mul n (pl, ph) = ((n * pl) % digit, n * ph + (n * pl) / digit);; let cmp (nl, nh) (pl, ph) = if nh < ph then -1 else if nh > ph then 1 else if nl < pl then -1 else if nl > pl then 1 else 0 ;; let x2 = fun p -> mul n2 p;; let x3 = fun p -> mul n3 p;; let x5 = fun p -> mul n5 p;; let nn1 = (n1, n0);; let pr (nl, nh) = ((* if compare nh n0 = 0 then Printf.printf "%Ld\n" nl else Printf.printf "%Ld%018Ld\n" nh nl *)) ;; (* (* bignum version *) open Num;; let nn1 = num_of_int 1;; let x2 = fun p -> (num_of_int 2) */ p;; let x3 = fun p -> (num_of_int 3) */ p;; let x5 = fun p -> (num_of_int 5) */ p;; let cmp n p = sign_num (n -/ p);; let pr n = Printf.printf "%s\n" (string_of_num n);; *) (* This is where the interesting stuff begins. *) open Lazy;; type 'a lcons = Cons of 'a * 'a lcons Lazy.t;; type 'a llist = 'a lcons Lazy.t;; let rec map f l = lazy ( match force l with | Cons (x, ll) -> Cons (f x, map f ll) ) ;; let rec merge cmp l1 l2 = lazy ( match force l1, force l2 with | Cons (x1, ll1), Cons (x2, ll2) -> let c = cmp x1 x2 in if c = 0 then Cons (x1, merge cmp ll1 ll2) else if c < 0 then Cons (x1, merge cmp ll1 l2) else Cons (x2, merge cmp l1 ll2) ) ;; let rec iter_interval f l (start, stop) = if stop = 0 then () else match force l with | Cons (x, ll) -> if start <= 0 then f x; iter_interval f ll (start-1, stop-1) ;; let rec hamming = lazy (Cons (nn1, merge cmp ham2 (merge cmp ham3 ham5))) and ham2 = lazy (force (map x2 hamming)) and ham3 = lazy (force (map x3 hamming)) and ham5 = lazy (force (map x5 hamming)) ;; iter_interval pr hamming (88000, 88100);; js_of_ocaml-2.5/benchmarks/sources/ml/kb.ml000066400000000000000000000457021241254034500210010ustar00rootroot00000000000000let print_string _ = () let print_int _ = () let print_newline _ = () (***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: terms.ml 2553 1999-11-17 18:59:06Z xleroy $ *) (****************** Term manipulations *****************) type term = Var of int | Term of string * term list let rec union l1 l2 = match l1 with [] -> l2 | a::r -> if List.mem a l2 then union r l2 else a :: union r l2 let rec vars = function Var n -> [n] | Term(_,l) -> vars_of_list l and vars_of_list = function [] -> [] | t::r -> union (vars t) (vars_of_list r) let rec substitute subst = function Term(oper,sons) -> Term(oper, List.map (substitute subst) sons) | Var(n) as t -> try List.assoc n subst with Not_found -> t (* Term replacement: replace M u N is M[u<-N]. *) let rec replace m u n = match (u, m) with [], _ -> n | i::u, Term(oper, sons) -> Term(oper, replace_nth i sons u n) | _ -> failwith "replace" and replace_nth i sons u n = match sons with s::r -> if i = 1 then replace s u n :: r else s :: replace_nth (i-1) r u n | [] -> failwith "replace_nth" (* Term matching. *) let matching term1 term2 = let rec match_rec subst t1 t2 = match (t1, t2) with Var v, _ -> if List.mem_assoc v subst then if t2 = List.assoc v subst then subst else failwith "matching" else (v, t2) :: subst | Term(op1,sons1), Term(op2,sons2) -> if op1 = op2 then List.fold_left2 match_rec subst sons1 sons2 else failwith "matching" | _ -> failwith "matching" in match_rec [] term1 term2 (* A naive unification algorithm. *) let compsubst subst1 subst2 = (List.map (fun (v,t) -> (v, substitute subst1 t)) subst2) @ subst1 let rec occurs n = function Var m -> m = n | Term(_,sons) -> List.exists (occurs n) sons let rec unify term1 term2 = match (term1, term2) with Var n1, _ -> if term1 = term2 then [] else if occurs n1 term2 then failwith "unify" else [n1, term2] | term1, Var n2 -> if occurs n2 term1 then failwith "unify" else [n2, term1] | Term(op1,sons1), Term(op2,sons2) -> if op1 = op2 then List.fold_left2 (fun s t1 t2 -> compsubst (unify (substitute s t1) (substitute s t2)) s) [] sons1 sons2 else failwith "unify" (* We need to print terms with variables independently from input terms obtained by parsing. We give arbitrary names v1,v2,... to their variables. *) let infixes = ["+";"*"] let pretty_term _ = () let pretty_close _ = () (***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: equations.ml 2553 1999-11-17 18:59:06Z xleroy $ *) (****************** Equation manipulations *************) type rule = { number: int; numvars: int; lhs: term; rhs: term } (* standardizes an equation so its variables are 1,2,... *) let mk_rule num m n = let all_vars = union (vars m) (vars n) in let counter = ref 0 in let subst = List.map (fun v -> incr counter; (v, Var !counter)) (List.rev all_vars) in { number = num; numvars = !counter; lhs = substitute subst m; rhs = substitute subst n } (* checks that rules are numbered in sequence and returns their number *) let check_rules rules = let counter = ref 0 in List.iter (fun r -> incr counter; if r.number <> !counter then failwith "Rule numbers not in sequence") rules; !counter let pretty_rule rule = print_int rule.number; print_string " : "; pretty_term rule.lhs; print_string " = "; pretty_term rule.rhs; print_newline() let pretty_rules rules = List.iter pretty_rule rules (****************** Rewriting **************************) (* Top-level rewriting. Let eq:L=R be an equation, M be a term such that L<=M. With sigma = matching L M, we define the image of M by eq as sigma(R) *) let reduce l m r = substitute (matching l m) r (* Test whether m can be reduced by l, i.e. m contains an instance of l. *) let can_match l m = try let _ = matching l m in true with Failure _ -> false let rec reducible l m = can_match l m || (match m with | Term(_,sons) -> List.exists (reducible l) sons | _ -> false) (* Top-level rewriting with multiple rules. *) let rec mreduce rules m = match rules with [] -> failwith "mreduce" | rule::rest -> try reduce rule.lhs m rule.rhs with Failure _ -> mreduce rest m (* One step of rewriting in leftmost-outermost strategy, with multiple rules. Fails if no redex is found *) let rec mrewrite1 rules m = try mreduce rules m with Failure _ -> match m with Var n -> failwith "mrewrite1" | Term(f, sons) -> Term(f, mrewrite1_sons rules sons) and mrewrite1_sons rules = function [] -> failwith "mrewrite1" | son::rest -> try mrewrite1 rules son :: rest with Failure _ -> son :: mrewrite1_sons rules rest (* Iterating rewrite1. Returns a normal form. May loop forever *) let rec mrewrite_all rules m = try mrewrite_all rules (mrewrite1 rules m) with Failure _ -> m (***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: orderings.ml 2553 1999-11-17 18:59:06Z xleroy $ *) (*********************** Recursive Path Ordering ****************************) type ordering = Greater | Equal | NotGE let ge_ord order pair = match order pair with NotGE -> false | _ -> true and gt_ord order pair = match order pair with Greater -> true | _ -> false and eq_ord order pair = match order pair with Equal -> true | _ -> false let rec rem_eq equiv x = function [] -> failwith "rem_eq" | y::l -> if equiv (x,y) then l else y :: rem_eq equiv x l let diff_eq equiv (x,y) = let rec diffrec = function ([],_) as p -> p | (h::t, y) -> try diffrec (t, rem_eq equiv h y) with Failure _ -> let (x',y') = diffrec (t,y) in (h::x',y') in if List.length x > List.length y then diffrec(y,x) else diffrec(x,y) (* Multiset extension of order *) let mult_ext order = function Term(_,sons1), Term(_,sons2) -> begin match diff_eq (eq_ord order) (sons1,sons2) with ([],[]) -> Equal | (l1,l2) -> if List.for_all (fun n -> List.exists (fun m -> gt_ord order (m,n)) l1) l2 then Greater else NotGE end | _ -> failwith "mult_ext" (* Lexicographic extension of order *) let lex_ext order = function (Term(_,sons1) as m), (Term(_,sons2) as n) -> let rec lexrec = function ([] , []) -> Equal | ([] , _ ) -> NotGE | ( _ , []) -> Greater | (x1::l1, x2::l2) -> match order (x1,x2) with Greater -> if List.for_all (fun n' -> gt_ord order (m,n')) l2 then Greater else NotGE | Equal -> lexrec (l1,l2) | NotGE -> if List.exists (fun m' -> ge_ord order (m',n)) l1 then Greater else NotGE in lexrec (sons1, sons2) | _ -> failwith "lex_ext" (* Recursive path ordering *) let rpo op_order ext = let rec rporec (m,n) = if m = n then Equal else match m with Var vm -> NotGE | Term(op1,sons1) -> match n with Var vn -> if occurs vn m then Greater else NotGE | Term(op2,sons2) -> match (op_order op1 op2) with Greater -> if List.for_all (fun n' -> gt_ord rporec (m,n')) sons2 then Greater else NotGE | Equal -> ext rporec (m,n) | NotGE -> if List.exists (fun m' -> ge_ord rporec (m',n)) sons1 then Greater else NotGE in rporec (***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: kb.ml 2553 1999-11-17 18:59:06Z xleroy $ *) (****************** Critical pairs *********************) (* All (u,subst) such that N/u (&var) unifies with M, with principal unifier subst *) let rec super m = function Term(_,sons) as n -> let rec collate n = function [] -> [] | son::rest -> List.map (fun (u, subst) -> (n::u, subst)) (super m son) @ collate (n+1) rest in let insides = collate 1 sons in begin try ([], unify m n) :: insides with Failure _ -> insides end | _ -> [] (* Ex : let (m,_) = <> and (n,_) = <> in super m n ==> [[1],[2,Term ("B",[])]; x <- B [2],[2,Term ("A",[]); 1,Term ("B",[])]] x <- A y <- B *) (* All (u,subst), u&[], such that n/u unifies with m *) let super_strict m = function Term(_,sons) -> let rec collate n = function [] -> [] | son::rest -> List.map (fun (u, subst) -> (n::u, subst)) (super m son) @ collate (n+1) rest in collate 1 sons | _ -> [] (* Critical pairs of l1=r1 with l2=r2 *) (* critical_pairs : term_pair -> term_pair -> term_pair list *) let critical_pairs (l1,r1) (l2,r2) = let mk_pair (u,subst) = substitute subst (replace l2 u r1), substitute subst r2 in List.map mk_pair (super l1 l2) (* Strict critical pairs of l1=r1 with l2=r2 *) (* strict_critical_pairs : term_pair -> term_pair -> term_pair list *) let strict_critical_pairs (l1,r1) (l2,r2) = let mk_pair (u,subst) = substitute subst (replace l2 u r1), substitute subst r2 in List.map mk_pair (super_strict l1 l2) (* All critical pairs of eq1 with eq2 *) let mutual_critical_pairs eq1 eq2 = (strict_critical_pairs eq1 eq2) @ (critical_pairs eq2 eq1) (* Renaming of variables *) let rename n (t1,t2) = let rec ren_rec = function Var k -> Var(k+n) | Term(op,sons) -> Term(op, List.map ren_rec sons) in (ren_rec t1, ren_rec t2) (************************ Completion ******************************) let deletion_message rule = print_string "Rule ";print_int rule.number; print_string " deleted"; print_newline() (* Generate failure message *) let non_orientable (m,n) = pretty_term m; print_string " = "; pretty_term n; print_newline() let rec partition p = function [] -> ([], []) | x::l -> let (l1, l2) = partition p l in if p x then (x::l1, l2) else (l1, x::l2) let rec get_rule n = function [] -> raise Not_found | r::l -> if n = r.number then r else get_rule n l (* Improved Knuth-Bendix completion procedure *) let kb_completion greater = let rec kbrec j rules = let rec process failures (k,l) eqs = (**** print_string "***kb_completion "; print_int j; print_newline(); pretty_rules rules; List.iter non_orientable failures; print_int k; print_string " "; print_int l; print_newline(); List.iter non_orientable eqs; ***) match eqs with [] -> if k rules (* successful completion *) | _ -> print_string "Non-orientable equations :"; print_newline(); List.iter non_orientable failures; failwith "kb_completion" end | (m,n)::eqs -> let m' = mrewrite_all rules m and n' = mrewrite_all rules n and enter_rule(left,right) = let new_rule = mk_rule (j+1) left right in pretty_rule new_rule; let left_reducible rule = reducible left rule.lhs in let (redl,irredl) = partition left_reducible rules in List.iter deletion_message redl; let right_reduce rule = mk_rule rule.number rule.lhs (mrewrite_all (new_rule::rules) rule.rhs) in let irreds = List.map right_reduce irredl in let eqs' = List.map (fun rule -> (rule.lhs, rule.rhs)) redl in kbrec (j+1) (new_rule::irreds) [] (k,l) (eqs @ eqs' @ failures) in (*** print_string "--- Considering "; non_orientable (m', n'); ***) if m' = n' then process failures (k,l) eqs else if greater(m',n') then enter_rule(m',n') else if greater(n',m') then enter_rule(n',m') else process ((m',n')::failures) (k,l) eqs and next_criticals failures (k,l) = (**** print_string "***next_criticals "; print_int k; print_string " "; print_int l ; print_newline(); ****) try let rl = get_rule l rules in let el = (rl.lhs, rl.rhs) in if k=l then process failures (k,l) (strict_critical_pairs el (rename rl.numvars el)) else try let rk = get_rule k rules in let ek = (rk.lhs, rk.rhs) in process failures (k,l) (mutual_critical_pairs el (rename rl.numvars ek)) with Not_found -> next_criticals failures (k+1,l) with Not_found -> next_criticals failures (1,l+1) in process in kbrec (* complete_rules is assumed locally confluent, and checked Noetherian with ordering greater, rules is any list of rules *) let kb_complete greater complete_rules rules = let n = check_rules complete_rules and eqs = List.map (fun rule -> (rule.lhs, rule.rhs)) rules in let completed_rules = kb_completion greater n complete_rules [] (n,n) eqs in print_string "Canonical set found :"; print_newline(); pretty_rules (List.rev completed_rules) (***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: kbmain.ml 7017 2005-08-12 09:22:04Z xleroy $ *) (**** let group_rules = [ { number = 1; numvars = 1; lhs = Term("*", [Term("U",[]); Var 1]); rhs = Var 1 }; { number = 2; numvars = 1; lhs = Term("*", [Term("I",[Var 1]); Var 1]); rhs = Term("U",[]) }; { number = 3; numvars = 3; lhs = Term("*", [Term("*", [Var 1; Var 2]); Var 3]); rhs = Term("*", [Var 1; Term("*", [Var 2; Var 3])]) } ] ****) let geom_rules = [ { number = 1; numvars = 1; lhs = Term ("*",[(Term ("U",[])); (Var 1)]); rhs = Var 1 }; { number = 2; numvars = 1; lhs = Term ("*",[(Term ("I",[(Var 1)])); (Var 1)]); rhs = Term ("U",[]) }; { number = 3; numvars = 3; lhs = Term ("*",[(Term ("*",[(Var 1); (Var 2)])); (Var 3)]); rhs = Term ("*",[(Var 1); (Term ("*",[(Var 2); (Var 3)]))]) }; { number = 4; numvars = 0; lhs = Term ("*",[(Term ("A",[])); (Term ("B",[]))]); rhs = Term ("*",[(Term ("B",[])); (Term ("A",[]))]) }; { number = 5; numvars = 0; lhs = Term ("*",[(Term ("C",[])); (Term ("C",[]))]); rhs = Term ("U",[]) }; { number = 6; numvars = 0; lhs = Term("*", [(Term ("C",[])); (Term ("*",[(Term ("A",[])); (Term ("I",[(Term ("C",[]))]))]))]); rhs = Term ("I",[(Term ("A",[]))]) }; { number = 7; numvars = 0; lhs = Term("*", [(Term ("C",[])); (Term ("*",[(Term ("B",[])); (Term ("I",[(Term ("C",[]))]))]))]); rhs = Term ("B",[]) } ] let group_rank = function "U" -> 0 | "*" -> 1 | "I" -> 2 | "B" -> 3 | "C" -> 4 | "A" -> 5 | _ -> assert false let group_precedence op1 op2 = let r1 = group_rank op1 and r2 = group_rank op2 in if r1 = r2 then Equal else if r1 > r2 then Greater else NotGE let group_order = rpo group_precedence lex_ext let greater pair = match group_order pair with Greater -> true | _ -> false let _ = for i = 1 to 20 do kb_complete greater [] geom_rules done js_of_ocaml-2.5/benchmarks/sources/ml/kb_no_exc.ml000066400000000000000000000477651241254034500223470ustar00rootroot00000000000000 let print_string _ = () let print_int _ = () let print_newline _ = () (***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: terms.ml 2553 1999-11-17 18:59:06Z xleroy $ *) (****************** Term manipulations *****************) type term = Var of int | Term of string * term list let rec union l1 l2 = match l1 with [] -> l2 | a::r -> if List.mem a l2 then union r l2 else a :: union r l2 let rec vars = function Var n -> [n] | Term(_,l) -> vars_of_list l and vars_of_list = function [] -> [] | t::r -> union (vars t) (vars_of_list r) let rec substitute subst = function Term(oper,sons) -> Term(oper, List.map (substitute subst) sons) | Var(n) as t -> try List.assoc n subst with Not_found -> t (* Term replacement: replace M u N is M[u<-N]. *) let rec replace m u n = match (u, m) with [], _ -> n | i::u, Term(oper, sons) -> Term(oper, replace_nth i sons u n) | _ -> failwith "replace" and replace_nth i sons u n = match sons with s::r -> if i = 1 then replace s u n :: r else s :: replace_nth (i-1) r u n | [] -> failwith "replace_nth" (* Term matching. *) let rec fold_left2_opt f accu l1 l2 = match (l1, l2) with ([], []) -> Some accu | (a1::l1, a2::l2) -> begin match f accu a1 a2 with None -> None | Some accu' -> fold_left2_opt f accu' l1 l2 end | (_, _) -> invalid_arg "List.fold_left2" let rec match_rec subst t1 t2 = match (t1, t2) with Var v, _ -> if List.mem_assoc v subst then if t2 = List.assoc v subst then Some subst else None else Some ((v, t2) :: subst) | Term(op1,sons1), Term(op2,sons2) -> if op1 = op2 then fold_left2_opt match_rec subst sons1 sons2 else None | _ -> None let matching term1 term2 = match_rec [] term1 term2 (* A naive unification algorithm. *) let compsubst subst1 subst2 = (List.map (fun (v,t) -> (v, substitute subst1 t)) subst2) @ subst1 let rec occurs n = function Var m -> m = n | Term(_,sons) -> List.exists (occurs n) sons let rec unify term1 term2 = match (term1, term2) with Var n1, _ -> if term1 = term2 then [] else if occurs n1 term2 then failwith "unify" else [n1, term2] | term1, Var n2 -> if occurs n2 term1 then failwith "unify" else [n2, term1] | Term(op1,sons1), Term(op2,sons2) -> if op1 = op2 then List.fold_left2 (fun s t1 t2 -> compsubst (unify (substitute s t1) (substitute s t2)) s) [] sons1 sons2 else failwith "unify" (* We need to print terms with variables independently from input terms obtained by parsing. We give arbitrary names v1,v2,... to their variables. *) let infixes = ["+";"*"] let rec pretty_term = function Var n -> print_string "v"; print_int n | Term (oper,sons) -> if List.mem oper infixes then begin match sons with [s1;s2] -> pretty_close s1; print_string oper; pretty_close s2 | _ -> failwith "pretty_term : infix arity <> 2" end else begin print_string oper; match sons with [] -> () | t::lt -> print_string "("; pretty_term t; List.iter (fun t -> print_string ","; pretty_term t) lt; print_string ")" end and pretty_close = function Term(oper, _) as m -> if List.mem oper infixes then begin print_string "("; pretty_term m; print_string ")" end else pretty_term m | m -> pretty_term m (***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: equations.ml 2553 1999-11-17 18:59:06Z xleroy $ *) (****************** Equation manipulations *************) type rule = { number: int; numvars: int; lhs: term; rhs: term } (* standardizes an equation so its variables are 1,2,... *) let mk_rule num m n = let all_vars = union (vars m) (vars n) in let counter = ref 0 in let subst = List.map (fun v -> incr counter; (v, Var !counter)) (List.rev all_vars) in { number = num; numvars = !counter; lhs = substitute subst m; rhs = substitute subst n } (* checks that rules are numbered in sequence and returns their number *) let check_rules rules = let counter = ref 0 in List.iter (fun r -> incr counter; if r.number <> !counter then failwith "Rule numbers not in sequence") rules; !counter let pretty_rule rule = print_int rule.number; print_string " : "; pretty_term rule.lhs; print_string " = "; pretty_term rule.rhs; print_newline() let pretty_rules rules = List.iter pretty_rule rules (****************** Rewriting **************************) (* Top-level rewriting. Let eq:L=R be an equation, M be a term such that L<=M. With sigma = matching L M, we define the image of M by eq as sigma(R) *) let reduce l m r = match matching l m with Some s -> Some (substitute s r) | None -> None (* Test whether m can be reduced by l, i.e. m contains an instance of l. *) let can_match l m = match matching l m with Some _ -> true | None -> false let rec reducible l m = can_match l m || (match m with | Term(_,sons) -> List.exists (reducible l) sons | _ -> false) (* Top-level rewriting with multiple rules. *) let rec mreduce rules m = match rules with [] -> None | rule::rest -> match reduce rule.lhs m rule.rhs with Some _ as v -> v | None -> mreduce rest m (* One step of rewriting in leftmost-outermost strategy, with multiple rules. Fails if no redex is found *) let rec mrewrite1 rules m = match mreduce rules m with Some v -> v | None -> match m with Var n -> failwith "mrewrite1" | Term(f, sons) -> Term(f, mrewrite1_sons rules sons) and mrewrite1_sons rules = function [] -> failwith "mrewrite1" | son::rest -> try mrewrite1 rules son :: rest with Failure _ -> son :: mrewrite1_sons rules rest (* Iterating rewrite1. Returns a normal form. May loop forever *) let rec mrewrite_all rules m = try mrewrite_all rules (mrewrite1 rules m) with Failure _ -> m (***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: orderings.ml 2553 1999-11-17 18:59:06Z xleroy $ *) (*********************** Recursive Path Ordering ****************************) type ordering = Greater | Equal | NotGE let ge_ord order pair = match order pair with NotGE -> false | _ -> true and gt_ord order pair = match order pair with Greater -> true | _ -> false and eq_ord order pair = match order pair with Equal -> true | _ -> false let rec rem_eq equiv x = function [] -> failwith "rem_eq" | y::l -> if equiv (x,y) then l else y :: rem_eq equiv x l let diff_eq equiv (x,y) = let rec diffrec = function ([],_) as p -> p | (h::t, y) -> try diffrec (t, rem_eq equiv h y) with Failure _ -> let (x',y') = diffrec (t,y) in (h::x',y') in if List.length x > List.length y then diffrec(y,x) else diffrec(x,y) (* Multiset extension of order *) let mult_ext order = function Term(_,sons1), Term(_,sons2) -> begin match diff_eq (eq_ord order) (sons1,sons2) with ([],[]) -> Equal | (l1,l2) -> if List.for_all (fun n -> List.exists (fun m -> gt_ord order (m,n)) l1) l2 then Greater else NotGE end | _ -> failwith "mult_ext" (* Lexicographic extension of order *) let lex_ext order = function (Term(_,sons1) as m), (Term(_,sons2) as n) -> let rec lexrec = function ([] , []) -> Equal | ([] , _ ) -> NotGE | ( _ , []) -> Greater | (x1::l1, x2::l2) -> match order (x1,x2) with Greater -> if List.for_all (fun n' -> gt_ord order (m,n')) l2 then Greater else NotGE | Equal -> lexrec (l1,l2) | NotGE -> if List.exists (fun m' -> ge_ord order (m',n)) l1 then Greater else NotGE in lexrec (sons1, sons2) | _ -> failwith "lex_ext" (* Recursive path ordering *) let rpo op_order ext = let rec rporec (m,n) = if m = n then Equal else match m with Var vm -> NotGE | Term(op1,sons1) -> match n with Var vn -> if occurs vn m then Greater else NotGE | Term(op2,sons2) -> match (op_order op1 op2) with Greater -> if List.for_all (fun n' -> gt_ord rporec (m,n')) sons2 then Greater else NotGE | Equal -> ext rporec (m,n) | NotGE -> if List.exists (fun m' -> ge_ord rporec (m',n)) sons1 then Greater else NotGE in rporec (***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: kb.ml 2553 1999-11-17 18:59:06Z xleroy $ *) (****************** Critical pairs *********************) (* All (u,subst) such that N/u (&var) unifies with M, with principal unifier subst *) let rec super m = function Term(_,sons) as n -> let rec collate n = function [] -> [] | son::rest -> List.map (fun (u, subst) -> (n::u, subst)) (super m son) @ collate (n+1) rest in let insides = collate 1 sons in begin try ([], unify m n) :: insides with Failure _ -> insides end | _ -> [] (* Ex : let (m,_) = <> and (n,_) = <> in super m n ==> [[1],[2,Term ("B",[])]; x <- B [2],[2,Term ("A",[]); 1,Term ("B",[])]] x <- A y <- B *) (* All (u,subst), u&[], such that n/u unifies with m *) let super_strict m = function Term(_,sons) -> let rec collate n = function [] -> [] | son::rest -> List.map (fun (u, subst) -> (n::u, subst)) (super m son) @ collate (n+1) rest in collate 1 sons | _ -> [] (* Critical pairs of l1=r1 with l2=r2 *) (* critical_pairs : term_pair -> term_pair -> term_pair list *) let critical_pairs (l1,r1) (l2,r2) = let mk_pair (u,subst) = substitute subst (replace l2 u r1), substitute subst r2 in List.map mk_pair (super l1 l2) (* Strict critical pairs of l1=r1 with l2=r2 *) (* strict_critical_pairs : term_pair -> term_pair -> term_pair list *) let strict_critical_pairs (l1,r1) (l2,r2) = let mk_pair (u,subst) = substitute subst (replace l2 u r1), substitute subst r2 in List.map mk_pair (super_strict l1 l2) (* All critical pairs of eq1 with eq2 *) let mutual_critical_pairs eq1 eq2 = (strict_critical_pairs eq1 eq2) @ (critical_pairs eq2 eq1) (* Renaming of variables *) let rename n (t1,t2) = let rec ren_rec = function Var k -> Var(k+n) | Term(op,sons) -> Term(op, List.map ren_rec sons) in (ren_rec t1, ren_rec t2) (************************ Completion ******************************) let deletion_message rule = print_string "Rule ";print_int rule.number; print_string " deleted"; print_newline() (* Generate failure message *) let non_orientable (m,n) = pretty_term m; print_string " = "; pretty_term n; print_newline() let rec partition p = function [] -> ([], []) | x::l -> let (l1, l2) = partition p l in if p x then (x::l1, l2) else (l1, x::l2) let rec get_rule n = function [] -> raise Not_found | r::l -> if n = r.number then r else get_rule n l (* Improved Knuth-Bendix completion procedure *) let kb_completion greater = let rec kbrec j rules = let rec process failures (k,l) eqs = (**** print_string "***kb_completion "; print_int j; print_newline(); pretty_rules rules; List.iter non_orientable failures; print_int k; print_string " "; print_int l; print_newline(); List.iter non_orientable eqs; ***) match eqs with [] -> if k rules (* successful completion *) | _ -> print_string "Non-orientable equations :"; print_newline(); List.iter non_orientable failures; failwith "kb_completion" end | (m,n)::eqs -> let m' = mrewrite_all rules m and n' = mrewrite_all rules n and enter_rule(left,right) = let new_rule = mk_rule (j+1) left right in pretty_rule new_rule; let left_reducible rule = reducible left rule.lhs in let (redl,irredl) = partition left_reducible rules in List.iter deletion_message redl; let right_reduce rule = mk_rule rule.number rule.lhs (mrewrite_all (new_rule::rules) rule.rhs) in let irreds = List.map right_reduce irredl in let eqs' = List.map (fun rule -> (rule.lhs, rule.rhs)) redl in kbrec (j+1) (new_rule::irreds) [] (k,l) (eqs @ eqs' @ failures) in (*** print_string "--- Considering "; non_orientable (m', n'); ***) if m' = n' then process failures (k,l) eqs else if greater(m',n') then enter_rule(m',n') else if greater(n',m') then enter_rule(n',m') else process ((m',n')::failures) (k,l) eqs and next_criticals failures (k,l) = (**** print_string "***next_criticals "; print_int k; print_string " "; print_int l ; print_newline(); ****) try let rl = get_rule l rules in let el = (rl.lhs, rl.rhs) in if k=l then process failures (k,l) (strict_critical_pairs el (rename rl.numvars el)) else try let rk = get_rule k rules in let ek = (rk.lhs, rk.rhs) in process failures (k,l) (mutual_critical_pairs el (rename rl.numvars ek)) with Not_found -> next_criticals failures (k+1,l) with Not_found -> next_criticals failures (1,l+1) in process in kbrec (* complete_rules is assumed locally confluent, and checked Noetherian with ordering greater, rules is any list of rules *) let kb_complete greater complete_rules rules = let n = check_rules complete_rules and eqs = List.map (fun rule -> (rule.lhs, rule.rhs)) rules in let completed_rules = kb_completion greater n complete_rules [] (n,n) eqs in print_string "Canonical set found :"; print_newline(); pretty_rules (List.rev completed_rules) (***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: kbmain.ml 7017 2005-08-12 09:22:04Z xleroy $ *) (**** let group_rules = [ { number = 1; numvars = 1; lhs = Term("*", [Term("U",[]); Var 1]); rhs = Var 1 }; { number = 2; numvars = 1; lhs = Term("*", [Term("I",[Var 1]); Var 1]); rhs = Term("U",[]) }; { number = 3; numvars = 3; lhs = Term("*", [Term("*", [Var 1; Var 2]); Var 3]); rhs = Term("*", [Var 1; Term("*", [Var 2; Var 3])]) } ] ****) let geom_rules = [ { number = 1; numvars = 1; lhs = Term ("*",[(Term ("U",[])); (Var 1)]); rhs = Var 1 }; { number = 2; numvars = 1; lhs = Term ("*",[(Term ("I",[(Var 1)])); (Var 1)]); rhs = Term ("U",[]) }; { number = 3; numvars = 3; lhs = Term ("*",[(Term ("*",[(Var 1); (Var 2)])); (Var 3)]); rhs = Term ("*",[(Var 1); (Term ("*",[(Var 2); (Var 3)]))]) }; { number = 4; numvars = 0; lhs = Term ("*",[(Term ("A",[])); (Term ("B",[]))]); rhs = Term ("*",[(Term ("B",[])); (Term ("A",[]))]) }; { number = 5; numvars = 0; lhs = Term ("*",[(Term ("C",[])); (Term ("C",[]))]); rhs = Term ("U",[]) }; { number = 6; numvars = 0; lhs = Term("*", [(Term ("C",[])); (Term ("*",[(Term ("A",[])); (Term ("I",[(Term ("C",[]))]))]))]); rhs = Term ("I",[(Term ("A",[]))]) }; { number = 7; numvars = 0; lhs = Term("*", [(Term ("C",[])); (Term ("*",[(Term ("B",[])); (Term ("I",[(Term ("C",[]))]))]))]); rhs = Term ("B",[]) } ] let group_rank = function "U" -> 0 | "*" -> 1 | "I" -> 2 | "B" -> 3 | "C" -> 4 | "A" -> 5 | _ -> assert false let group_precedence op1 op2 = let r1 = group_rank op1 and r2 = group_rank op2 in if r1 = r2 then Equal else if r1 > r2 then Greater else NotGE let group_order = rpo group_precedence lex_ext let greater pair = match group_order pair with Greater -> true | _ -> false let _ = for i = 1 to 20 do kb_complete greater [] geom_rules done js_of_ocaml-2.5/benchmarks/sources/ml/loop.ml000066400000000000000000000000431241254034500213430ustar00rootroot00000000000000for i = 1 to 1000000000 do () done js_of_ocaml-2.5/benchmarks/sources/ml/nucleic.ml000066400000000000000000004426441241254034500220350ustar00rootroot00000000000000(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: nucleic.ml 7017 2005-08-12 09:22:04Z xleroy $ *) (* Use floating-point arithmetic *) external (+) : float -> float -> float = "%addfloat" external (-) : float -> float -> float = "%subfloat" external ( * ) : float -> float -> float = "%mulfloat" external (/) : float -> float -> float = "%divfloat" (* -- MATH UTILITIES --------------------------------------------------------*) let constant_pi = 3.14159265358979323846 let constant_minus_pi = -3.14159265358979323846 let constant_pi2 = 1.57079632679489661923 let constant_minus_pi2 = -1.57079632679489661923 (* -- POINTS ----------------------------------------------------------------*) type pt = { x : float; y : float; z : float } let pt_sub p1 p2 = { x = p1.x - p2.x; y = p1.y - p2.y; z = p1.z - p2.z } let pt_dist p1 p2 = let dx = p1.x - p2.x and dy = p1.y - p2.y and dz = p1.z - p2.z in sqrt ((dx * dx) + (dy * dy) + (dz * dz)) let pt_phi p = let b = atan2 p.x p.z in atan2 ((cos b) * p.z + (sin b) * p.x) p.y let pt_theta p = atan2 p.x p.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. *) type tfo = {a: float; b: float; c: float; d: float; e: float; f: float; g: float; h: float; i: float; tx: float; ty: float; tz: float} let tfo_id = {a=1.0; b=0.0; c=0.0; d=0.0; e=1.0; f=0.0; g=0.0; h=0.0; i=1.0; tx=0.0; ty=0.0; tz=0.0} (* The function "tfo-apply" multiplies a transformation matrix, tfo, by a point vector, p. The result is a new point. *) let tfo_apply t p = { x = ((p.x * t.a) + (p.y * t.d) + (p.z * t.g) + t.tx); y = ((p.x * t.b) + (p.y * t.e) + (p.z * t.h) + t.ty); z = ((p.x * t.c) + (p.y * t.f) + (p.z * t.i) + t.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. *) let tfo_combine a b = (* *) (* Hand elimination of common subexpressions. Assumes lots of float registers (32 is perfect, 16 still OK). Loses on the I386, of course. *) let a_a = a.a and a_b = a.b and a_c = a.c and a_d = a.d and a_e = a.e and a_f = a.f and a_g = a.g and a_h = a.h and a_i = a.i and a_tx = a.tx and a_ty = a.ty and a_tz = a.tz and b_a = b.a and b_b = b.b and b_c = b.c and b_d = b.d and b_e = b.e and b_f = b.f and b_g = b.g and b_h = b.h and b_i = b.i and b_tx = b.tx and b_ty = b.ty and b_tz = b.tz in { a = ((a_a * b_a) + (a_b * b_d) + (a_c * b_g)); b = ((a_a * b_b) + (a_b * b_e) + (a_c * b_h)); c = ((a_a * b_c) + (a_b * b_f) + (a_c * b_i)); d = ((a_d * b_a) + (a_e * b_d) + (a_f * b_g)); e = ((a_d * b_b) + (a_e * b_e) + (a_f * b_h)); f = ((a_d * b_c) + (a_e * b_f) + (a_f * b_i)); g = ((a_g * b_a) + (a_h * b_d) + (a_i * b_g)); h = ((a_g * b_b) + (a_h * b_e) + (a_i * b_h)); i = ((a_g * b_c) + (a_h * b_f) + (a_i * b_i)); tx = ((a_tx * b_a) + (a_ty * b_d) + (a_tz * b_g) + b_tx); ty = ((a_tx * b_b) + (a_ty * b_e) + (a_tz * b_h) + b_ty); tz = ((a_tx * b_c) + (a_ty * b_f) + (a_tz * b_i) + b_tz) } (* *) (* Original without CSE *) (* *) (*** { a = ((a.a * b.a) + (a.b * b.d) + (a.c * b.g)); b = ((a.a * b.b) + (a.b * b.e) + (a.c * b.h)); c = ((a.a * b.c) + (a.b * b.f) + (a.c * b.i)); d = ((a.d * b.a) + (a.e * b.d) + (a.f * b.g)); e = ((a.d * b.b) + (a.e * b.e) + (a.f * b.h)); f = ((a.d * b.c) + (a.e * b.f) + (a.f * b.i)); g = ((a.g * b.a) + (a.h * b.d) + (a.i * b.g)); h = ((a.g * b.b) + (a.h * b.e) + (a.i * b.h)); i = ((a.g * b.c) + (a.h * b.f) + (a.i * b.i)); tx = ((a.tx * b.a) + (a.ty * b.d) + (a.tz * b.g) + b.tx); ty = ((a.tx * b.b) + (a.ty * b.e) + (a.tz * b.h) + b.ty); tz = ((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. *) let tfo_inv_ortho t = { a = t.a; b = t.d; c = t.g; d = t.b; e = t.e; f = t.h; g = t.c; h = t.f; i = t.i; tx = (-.((t.a * t.tx) + (t.b * t.ty) + (t.c * t.tz))); ty = (-.((t.d * t.tx) + (t.e * t.ty) + (t.f * t.tz))); tz = (-.((t.g * t.tx) + (t.h * t.ty) + (t.i * t.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. *) let tfo_align p1 p2 p3 = let x31 = p3.x - p1.x in let y31 = p3.y - p1.y in let z31 = p3.z - p1.z in let rotpy = pt_sub p2 p1 in let phi = pt_phi rotpy in let theta = pt_theta rotpy in let sinp = sin phi in let sint = sin theta in let cosp = cos phi in let cost = cos theta in let sinpsint = sinp * sint in let sinpcost = sinp * cost in let cospsint = cosp * sint in let cospcost = cosp * cost in let rotpz = { x = ((cost * x31) - (sint * z31)); y = ((sinpsint * x31) + (cosp * y31) + (sinpcost * z31)); z = ((cospsint * x31) + (-.(sinp * y31)) + (cospcost * z31)) } in let rho = pt_theta rotpz in let cosr = cos rho in let sinr = sin rho in let x = (-.(p1.x * cost)) + (p1.z * sint) in let y = ((-.(p1.x * sinpsint)) - (p1.y * cosp)) - (p1.z * sinpcost) in let z = ((-.(p1.x * cospsint) + (p1.y * sinp))) - (p1.z * cospcost) in { a = ((cost * cosr) - (cospsint * sinr)); b = sinpsint; c = ((cost * sinr) + (cospsint * cosr)); d = (sinp * sinr); e = cosp; f = (-.(sinp * cosr)); g = ((-.(sint * cosr)) - (cospcost * sinr)); h = sinpcost; i = ((-.(sint * sinr) + (cospcost * cosr))); tx = ((x * cosr) - (z * sinr)); ty = y; tz = ((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 remaining atoms for each nucleotide type. *) type nuc_specific = A of pt*pt*pt*pt*pt*pt*pt*pt | C of pt*pt*pt*pt*pt*pt | G of pt*pt*pt*pt*pt*pt*pt*pt*pt | U of pt*pt*pt*pt*pt (* 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 *) (* Define part common to all 4 nucleotide types. *) type nuc = N of 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*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 *) let is_A = function N(dgf_base_tfo,p_o3'_275_tfo,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,A(_,_,_,_,_,_,_,_)) -> true | _ -> false let is_C = function N(dgf_base_tfo,p_o3'_275_tfo,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,C(_,_,_,_,_,_)) -> true | _ -> false let is_G = function N(dgf_base_tfo,p_o3'_275_tfo,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,G(_,_,_,_,_,_,_,_,_)) -> true | _ -> false let nuc_C1' (N(dgf_base_tfo,p_o3'_275_tfo,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,_)) = c1' let nuc_C2 (N(dgf_base_tfo,p_o3'_275_tfo,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,_)) = c2 let nuc_C3' (N(dgf_base_tfo,p_o3'_275_tfo,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,_)) = c3' let nuc_C4 (N(dgf_base_tfo,p_o3'_275_tfo,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,_)) = c4 let nuc_C4' (N(dgf_base_tfo,p_o3'_275_tfo,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,_)) = c4' let nuc_N1 (N(dgf_base_tfo,p_o3'_275_tfo,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,_)) = n1 let nuc_O3' (N(dgf_base_tfo,p_o3'_275_tfo,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,_)) = o3' let nuc_P (N(dgf_base_tfo,p_o3'_275_tfo,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,_)) = p let nuc_dgf_base_tfo (N(dgf_base_tfo,p_o3'_275_tfo,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,_)) = dgf_base_tfo let nuc_p_o3'_180_tfo (N(dgf_base_tfo,p_o3'_275_tfo,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,_)) = p_o3'_180_tfo let nuc_p_o3'_275_tfo (N(dgf_base_tfo,p_o3'_275_tfo,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,_)) = p_o3'_275_tfo let nuc_p_o3'_60_tfo (N(dgf_base_tfo,p_o3'_275_tfo,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,_)) = p_o3'_60_tfo let rA_N9 = function | (N(dgf_base_tfo,p_o3'_275_tfo,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,A (n6,n7,n9,c8,h2,h61,h62,h8))) -> n9 | _ -> assert false let rG_N9 = function | (N(dgf_base_tfo,p_o3'_275_tfo,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,G (n2,n7,n9,c8,o6,h1,h21,h22,h8))) -> n9 | _ -> assert false (* Database of nucleotide conformations: *) let rA = N( { a= -0.0018; b= -0.8207; c=0.5714; (* dgf_base_tfo *) d=0.2679; e= -0.5509; f= -0.7904; g=0.9634; h=0.1517; i=0.2209; tx=0.0073; ty=8.4030; tz=0.6232 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 5.4550; y = 8.2120; z = -2.8810 }, (* C5' *) { x = 5.4546; y = 8.8508; z = -1.9978 }, (* H5' *) { x = 5.7588; y = 8.6625; z = -3.8259 }, (* H5'' *) { x = 6.4970; y = 7.1480; z = -2.5980 }, (* C4' *) { x = 7.4896; y = 7.5919; z = -2.5214 }, (* H4' *) { x = 6.1630; y = 6.4860; z = -1.3440 }, (* O4' *) { x = 6.5400; y = 5.1200; z = -1.4190 }, (* C1' *) { x = 7.2763; y = 4.9681; z = -0.6297 }, (* H1' *) { x = 7.1940; y = 4.8830; z = -2.7770 }, (* C2' *) { x = 6.8667; y = 3.9183; z = -3.1647 }, (* H2'' *) { x = 8.5860; y = 5.0910; z = -2.6140 }, (* O2' *) { x = 8.9510; y = 4.7626; z = -1.7890 }, (* H2' *) { x = 6.5720; y = 6.0040; z = -3.6090 }, (* C3' *) { x = 5.5636; y = 5.7066; z = -3.8966 }, (* H3' *) { x = 7.3801; y = 6.3562; z = -4.7350 }, (* O3' *) { x = 4.7150; y = 0.4910; z = -0.1360 }, (* N1 *) { x = 6.3490; y = 2.1730; z = -0.6020 }, (* N3 *) { x = 5.9530; y = 0.9650; z = -0.2670 }, (* C2 *) { x = 5.2900; y = 2.9790; z = -0.8260 }, (* C4 *) { x = 3.9720; y = 2.6390; z = -0.7330 }, (* C5 *) { x = 3.6770; y = 1.3160; z = -0.3660 }, (* C6 *) (A ( { x = 2.4280; y = 0.8450; z = -0.2360 }, (* N6 *) { x = 3.1660; y = 3.7290; z = -1.0360 }, (* N7 *) { x = 5.3170; y = 4.2990; z = -1.1930 }, (* N9 *) { x = 4.0100; y = 4.6780; z = -1.2990 }, (* C8 *) { x = 6.6890; y = 0.1903; z = -0.0518 }, (* H2 *) { x = 1.6470; y = 1.4460; z = -0.4040 }, (* H61 *) { x = 2.2780; y = -0.1080; z = -0.0280 }, (* H62 *) { x = 3.4421; y = 5.5744; z = -1.5482 }) (* H8 *) ) ) let rA01 = N( { a= -0.0043; b= -0.8175; c=0.5759; (* dgf_base_tfo *) d=0.2617; e= -0.5567; f= -0.7884; g=0.9651; h=0.1473; i=0.2164; tx=0.0359; ty=8.3929; tz=0.5532 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 5.4352; y = 8.2183; z = -2.7757 }, (* C5' *) { x = 5.3830; y = 8.7883; z = -1.8481 }, (* H5' *) { x = 5.7729; y = 8.7436; z = -3.6691 }, (* H5'' *) { x = 6.4830; y = 7.1518; z = -2.5252 }, (* C4' *) { x = 7.4749; y = 7.5972; z = -2.4482 }, (* H4' *) { x = 6.1626; y = 6.4620; z = -1.2827 }, (* O4' *) { x = 6.5431; y = 5.0992; z = -1.3905 }, (* C1' *) { x = 7.2871; y = 4.9328; z = -0.6114 }, (* H1' *) { x = 7.1852; y = 4.8935; z = -2.7592 }, (* C2' *) { x = 6.8573; y = 3.9363; z = -3.1645 }, (* H2'' *) { x = 8.5780; y = 5.1025; z = -2.6046 }, (* O2' *) { x = 8.9516; y = 4.7577; z = -1.7902 }, (* H2' *) { x = 6.5522; y = 6.0300; z = -3.5612 }, (* C3' *) { x = 5.5420; y = 5.7356; z = -3.8459 }, (* H3' *) { x = 7.3487; y = 6.4089; z = -4.6867 }, (* O3' *) { x = 4.7442; y = 0.4514; z = -0.1390 }, (* N1 *) { x = 6.3687; y = 2.1459; z = -0.5926 }, (* N3 *) { x = 5.9795; y = 0.9335; z = -0.2657 }, (* C2 *) { x = 5.3052; y = 2.9471; z = -0.8125 }, (* C4 *) { x = 3.9891; y = 2.5987; z = -0.7230 }, (* C5 *) { x = 3.7016; y = 1.2717; z = -0.3647 }, (* C6 *) (A ( { x = 2.4553; y = 0.7925; z = -0.2390 }, (* N6 *) { x = 3.1770; y = 3.6859; z = -1.0198 }, (* N7 *) { x = 5.3247; y = 4.2695; z = -1.1710 }, (* N9 *) { x = 4.0156; y = 4.6415; z = -1.2759 }, (* C8 *) { x = 6.7198; y = 0.1618; z = -0.0547 }, (* H2 *) { x = 1.6709; y = 1.3900; z = -0.4039 }, (* H61 *) { x = 2.3107; y = -0.1627; z = -0.0373 }, (* H62 *) { x = 3.4426; y = 5.5361; z = -1.5199 }) (* H8 *) ) ) let rA02 = N( { a=0.5566; b=0.0449; c=0.8296; (* dgf_base_tfo *) d=0.5125; e=0.7673; f= -0.3854; g= -0.6538; h=0.6397; i=0.4041; tx= -9.1161; ty= -3.7679; tz= -2.9968 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 4.5778; y = 6.6594; z = -4.0364 }, (* C5' *) { x = 4.9220; y = 7.1963; z = -4.9204 }, (* H5' *) { x = 3.7996; y = 5.9091; z = -4.1764 }, (* H5'' *) { x = 5.7873; y = 5.8869; z = -3.5482 }, (* C4' *) { x = 6.0405; y = 5.0875; z = -4.2446 }, (* H4' *) { x = 6.9135; y = 6.8036; z = -3.4310 }, (* O4' *) { x = 7.7293; y = 6.4084; z = -2.3392 }, (* C1' *) { x = 8.7078; y = 6.1815; z = -2.7624 }, (* H1' *) { x = 7.1305; y = 5.1418; z = -1.7347 }, (* C2' *) { x = 7.2040; y = 5.1982; z = -0.6486 }, (* H2'' *) { x = 7.7417; y = 4.0392; z = -2.3813 }, (* O2' *) { x = 8.6785; y = 4.1443; z = -2.5630 }, (* H2' *) { x = 5.6666; y = 5.2728; z = -2.1536 }, (* C3' *) { x = 5.1747; y = 5.9805; z = -1.4863 }, (* H3' *) { x = 4.9997; y = 4.0086; z = -2.1973 }, (* O3' *) { x = 10.3245; y = 8.5459; z = 1.5467 }, (* N1 *) { x = 9.8051; y = 6.9432; z = -0.1497 }, (* N3 *) { x = 10.5175; y = 7.4328; z = 0.8408 }, (* C2 *) { x = 8.7523; y = 7.7422; z = -0.4228 }, (* C4 *) { x = 8.4257; y = 8.9060; z = 0.2099 }, (* C5 *) { x = 9.2665; y = 9.3242; z = 1.2540 }, (* C6 *) (A ( { x = 9.0664; y = 10.4462; z = 1.9610 }, (* N6 *) { x = 7.2750; y = 9.4537; z = -0.3428 }, (* N7 *) { x = 7.7962; y = 7.5519; z = -1.3859 }, (* N9 *) { x = 6.9479; y = 8.6157; z = -1.2771 }, (* C8 *) { x = 11.4063; y = 6.9047; z = 1.1859 }, (* H2 *) { x = 8.2845; y = 11.0341; z = 1.7552 }, (* H61 *) { x = 9.6584; y = 10.6647; z = 2.7198 }, (* H62 *) { x = 6.0430; y = 8.9853; z = -1.7594 }) (* H8 *) ) ) let rA03 = N( { a= -0.5021; b=0.0731; c=0.8617; (* dgf_base_tfo *) d= -0.8112; e=0.3054; f= -0.4986; g= -0.2996; h= -0.9494; i= -0.0940; tx=6.4273; ty= -5.1944; tz= -3.7807 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 4.1214; y = 6.7116; z = -1.9049 }, (* C5' *) { x = 3.3465; y = 5.9610; z = -2.0607 }, (* H5' *) { x = 4.0789; y = 7.2928; z = -0.9837 }, (* H5'' *) { x = 5.4170; y = 5.9293; z = -1.8186 }, (* C4' *) { x = 5.4506; y = 5.3400; z = -0.9023 }, (* H4' *) { x = 5.5067; y = 5.0417; z = -2.9703 }, (* O4' *) { x = 6.8650; y = 4.9152; z = -3.3612 }, (* C1' *) { x = 7.1090; y = 3.8577; z = -3.2603 }, (* H1' *) { x = 7.7152; y = 5.7282; z = -2.3894 }, (* C2' *) { x = 8.5029; y = 6.2356; z = -2.9463 }, (* H2'' *) { x = 8.1036; y = 4.8568; z = -1.3419 }, (* O2' *) { x = 8.3270; y = 3.9651; z = -1.6184 }, (* H2' *) { x = 6.7003; y = 6.7565; z = -1.8911 }, (* C3' *) { x = 6.5898; y = 7.5329; z = -2.6482 }, (* H3' *) { x = 7.0505; y = 7.2878; z = -0.6105 }, (* O3' *) { x = 9.6740; y = 4.7656; z = -7.6614 }, (* N1 *) { x = 9.0739; y = 4.3013; z = -5.3941 }, (* N3 *) { x = 9.8416; y = 4.2192; z = -6.4581 }, (* C2 *) { x = 7.9885; y = 5.0632; z = -5.6446 }, (* C4 *) { x = 7.6822; y = 5.6856; z = -6.8194 }, (* C5 *) { x = 8.5831; y = 5.5215; z = -7.8840 }, (* C6 *) (A ( { x = 8.4084; y = 6.0747; z = -9.0933 }, (* N6 *) { x = 6.4857; y = 6.3816; z = -6.7035 }, (* N7 *) { x = 6.9740; y = 5.3703; z = -4.7760 }, (* N9 *) { x = 6.1133; y = 6.1613; z = -5.4808 }, (* C8 *) { x = 10.7627; y = 3.6375; z = -6.4220 }, (* H2 *) { x = 7.6031; y = 6.6390; z = -9.2733 }, (* H61 *) { x = 9.1004; y = 5.9708; z = -9.7893 }, (* H62 *) { x = 5.1705; y = 6.6830; z = -5.3167 }) (* H8 *) ) ) let rA04 = N( { a= -0.5426; b= -0.8175; c=0.1929; (* dgf_base_tfo *) d=0.8304; e= -0.5567; f= -0.0237; g=0.1267; h=0.1473; i=0.9809; tx= -0.5075; ty=8.3929; tz=0.2229 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 5.4352; y = 8.2183; z = -2.7757 }, (* C5' *) { x = 5.3830; y = 8.7883; z = -1.8481 }, (* H5' *) { x = 5.7729; y = 8.7436; z = -3.6691 }, (* H5'' *) { x = 6.4830; y = 7.1518; z = -2.5252 }, (* C4' *) { x = 7.4749; y = 7.5972; z = -2.4482 }, (* H4' *) { x = 6.1626; y = 6.4620; z = -1.2827 }, (* O4' *) { x = 6.5431; y = 5.0992; z = -1.3905 }, (* C1' *) { x = 7.2871; y = 4.9328; z = -0.6114 }, (* H1' *) { x = 7.1852; y = 4.8935; z = -2.7592 }, (* C2' *) { x = 6.8573; y = 3.9363; z = -3.1645 }, (* H2'' *) { x = 8.5780; y = 5.1025; z = -2.6046 }, (* O2' *) { x = 8.9516; y = 4.7577; z = -1.7902 }, (* H2' *) { x = 6.5522; y = 6.0300; z = -3.5612 }, (* C3' *) { x = 5.5420; y = 5.7356; z = -3.8459 }, (* H3' *) { x = 7.3487; y = 6.4089; z = -4.6867 }, (* O3' *) { x = 3.6343; y = 2.6680; z = 2.0783 }, (* N1 *) { x = 5.4505; y = 3.9805; z = 1.2446 }, (* N3 *) { x = 4.7540; y = 3.3816; z = 2.1851 }, (* C2 *) { x = 4.8805; y = 3.7951; z = 0.0354 }, (* C4 *) { x = 3.7416; y = 3.0925; z = -0.2305 }, (* C5 *) { x = 3.0873; y = 2.4980; z = 0.8606 }, (* C6 *) (A ( { x = 1.9600; y = 1.7805; z = 0.7462 }, (* N6 *) { x = 3.4605; y = 3.1184; z = -1.5906 }, (* N7 *) { x = 5.3247; y = 4.2695; z = -1.1710 }, (* N9 *) { x = 4.4244; y = 3.8244; z = -2.0953 }, (* C8 *) { x = 5.0814; y = 3.4352; z = 3.2234 }, (* H2 *) { x = 1.5423; y = 1.6454; z = -0.1520 }, (* H61 *) { x = 1.5716; y = 1.3398; z = 1.5392 }, (* H62 *) { x = 4.2675; y = 3.8876; z = -3.1721 }) (* H8 *) ) ) let rA05 = N( { a= -0.5891; b=0.0449; c=0.8068; (* dgf_base_tfo *) d=0.5375; e=0.7673; f=0.3498; g= -0.6034; h=0.6397; i= -0.4762; tx= -0.3019; ty= -3.7679; tz= -9.5913 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 4.5778; y = 6.6594; z = -4.0364 }, (* C5' *) { x = 4.9220; y = 7.1963; z = -4.9204 }, (* H5' *) { x = 3.7996; y = 5.9091; z = -4.1764 }, (* H5'' *) { x = 5.7873; y = 5.8869; z = -3.5482 }, (* C4' *) { x = 6.0405; y = 5.0875; z = -4.2446 }, (* H4' *) { x = 6.9135; y = 6.8036; z = -3.4310 }, (* O4' *) { x = 7.7293; y = 6.4084; z = -2.3392 }, (* C1' *) { x = 8.7078; y = 6.1815; z = -2.7624 }, (* H1' *) { x = 7.1305; y = 5.1418; z = -1.7347 }, (* C2' *) { x = 7.2040; y = 5.1982; z = -0.6486 }, (* H2'' *) { x = 7.7417; y = 4.0392; z = -2.3813 }, (* O2' *) { x = 8.6785; y = 4.1443; z = -2.5630 }, (* H2' *) { x = 5.6666; y = 5.2728; z = -2.1536 }, (* C3' *) { x = 5.1747; y = 5.9805; z = -1.4863 }, (* H3' *) { x = 4.9997; y = 4.0086; z = -2.1973 }, (* O3' *) { x = 10.2594; y = 10.6774; z = -1.0056 }, (* N1 *) { x = 9.7528; y = 8.7080; z = -2.2631 }, (* N3 *) { x = 10.4471; y = 9.7876; z = -1.9791 }, (* C2 *) { x = 8.7271; y = 8.5575; z = -1.3991 }, (* C4 *) { x = 8.4100; y = 9.3803; z = -0.3580 }, (* C5 *) { x = 9.2294; y = 10.5030; z = -0.1574 }, (* C6 *) (A ( { x = 9.0349; y = 11.3951; z = 0.8250 }, (* N6 *) { x = 7.2891; y = 8.9068; z = 0.3121 }, (* N7 *) { x = 7.7962; y = 7.5519; z = -1.3859 }, (* N9 *) { x = 6.9702; y = 7.8292; z = -0.3353 }, (* C8 *) { x = 11.3132; y = 10.0537; z = -2.5851 }, (* H2 *) { x = 8.2741; y = 11.2784; z = 1.4629 }, (* H61 *) { x = 9.6733; y = 12.1368; z = 0.9529 }, (* H62 *) { x = 6.0888; y = 7.3990; z = 0.1403 }) (* H8 *) ) ) let rA06 = N( { a= -0.9815; b=0.0731; c= -0.1772; (* dgf_base_tfo *) d=0.1912; e=0.3054; f= -0.9328; g= -0.0141; h= -0.9494; i= -0.3137; tx=5.7506; ty= -5.1944; tz=4.7470 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 4.1214; y = 6.7116; z = -1.9049 }, (* C5' *) { x = 3.3465; y = 5.9610; z = -2.0607 }, (* H5' *) { x = 4.0789; y = 7.2928; z = -0.9837 }, (* H5'' *) { x = 5.4170; y = 5.9293; z = -1.8186 }, (* C4' *) { x = 5.4506; y = 5.3400; z = -0.9023 }, (* H4' *) { x = 5.5067; y = 5.0417; z = -2.9703 }, (* O4' *) { x = 6.8650; y = 4.9152; z = -3.3612 }, (* C1' *) { x = 7.1090; y = 3.8577; z = -3.2603 }, (* H1' *) { x = 7.7152; y = 5.7282; z = -2.3894 }, (* C2' *) { x = 8.5029; y = 6.2356; z = -2.9463 }, (* H2'' *) { x = 8.1036; y = 4.8568; z = -1.3419 }, (* O2' *) { x = 8.3270; y = 3.9651; z = -1.6184 }, (* H2' *) { x = 6.7003; y = 6.7565; z = -1.8911 }, (* C3' *) { x = 6.5898; y = 7.5329; z = -2.6482 }, (* H3' *) { x = 7.0505; y = 7.2878; z = -0.6105 }, (* O3' *) { x = 6.6624; y = 3.5061; z = -8.2986 }, (* N1 *) { x = 6.5810; y = 3.2570; z = -5.9221 }, (* N3 *) { x = 6.5151; y = 2.8263; z = -7.1625 }, (* C2 *) { x = 6.8364; y = 4.5817; z = -5.8882 }, (* C4 *) { x = 7.0116; y = 5.4064; z = -6.9609 }, (* C5 *) { x = 6.9173; y = 4.8260; z = -8.2361 }, (* C6 *) (A ( { x = 7.0668; y = 5.5163; z = -9.3763 }, (* N6 *) { x = 7.2573; y = 6.7070; z = -6.5394 }, (* N7 *) { x = 6.9740; y = 5.3703; z = -4.7760 }, (* N9 *) { x = 7.2238; y = 6.6275; z = -5.2453 }, (* C8 *) { x = 6.3146; y = 1.7741; z = -7.3641 }, (* H2 *) { x = 7.2568; y = 6.4972; z = -9.3456 }, (* H61 *) { x = 7.0437; y = 5.0478; z = -10.2446 }, (* H62 *) { x = 7.4108; y = 7.6227; z = -4.8418 }) (* H8 *) ) ) let rA07 = N( { a=0.2379; b=0.1310; c= -0.9624; (* dgf_base_tfo *) d= -0.5876; e= -0.7696; f= -0.2499; g= -0.7734; h=0.6249; i= -0.1061; tx=30.9870; ty= -26.9344; tz=42.6416 }, { a=0.7529; b=0.1548; c=0.6397; (* P_O3'_275_tfo *) d=0.2952; e= -0.9481; f= -0.1180; g=0.5882; h=0.2777; i= -0.7595; tx= -58.8919; ty= -11.3095; tz=6.0866 }, { a= -0.0239; b=0.9667; c= -0.2546; (* P_O3'_180_tfo *) d=0.9731; e= -0.0359; f= -0.2275; g= -0.2290; h= -0.2532; i= -0.9399; tx=3.5401; ty= -29.7913; tz=52.2796 }, { a= -0.8912; b= -0.4531; c=0.0242; (* P_O3'_60_tfo *) d= -0.1183; e=0.1805; f= -0.9764; g=0.4380; h= -0.8730; i= -0.2145; tx=19.9023; ty=54.8054; tz=15.2799 }, { x = 41.8210; y = 8.3880; z = 43.5890 }, (* P *) { x = 42.5400; y = 8.0450; z = 44.8330 }, (* O1P *) { x = 42.2470; y = 9.6920; z = 42.9910 }, (* O2P *) { x = 40.2550; y = 8.2030; z = 43.7340 }, (* O5' *) { x = 39.3505; y = 8.4697; z = 42.6565 }, (* C5' *) { x = 39.1377; y = 7.5433; z = 42.1230 }, (* H5' *) { x = 39.7203; y = 9.3119; z = 42.0717 }, (* H5'' *) { x = 38.0405; y = 8.9195; z = 43.2869 }, (* C4' *) { x = 37.3687; y = 9.3036; z = 42.5193 }, (* H4' *) { x = 37.4319; y = 7.8146; z = 43.9387 }, (* O4' *) { x = 37.1959; y = 8.1354; z = 45.3237 }, (* C1' *) { x = 36.1788; y = 8.5202; z = 45.3970 }, (* H1' *) { x = 38.1721; y = 9.2328; z = 45.6504 }, (* C2' *) { x = 39.1555; y = 8.7939; z = 45.8188 }, (* H2'' *) { x = 37.7862; y = 10.0617; z = 46.7013 }, (* O2' *) { x = 37.3087; y = 9.6229; z = 47.4092 }, (* H2' *) { x = 38.1844; y = 10.0268; z = 44.3367 }, (* C3' *) { x = 39.1578; y = 10.5054; z = 44.2289 }, (* H3' *) { x = 37.0547; y = 10.9127; z = 44.3441 }, (* O3' *) { x = 34.8811; y = 4.2072; z = 47.5784 }, (* N1 *) { x = 35.1084; y = 6.1336; z = 46.1818 }, (* N3 *) { x = 34.4108; y = 5.1360; z = 46.7207 }, (* C2 *) { x = 36.3908; y = 6.1224; z = 46.6053 }, (* C4 *) { x = 36.9819; y = 5.2334; z = 47.4697 }, (* C5 *) { x = 36.1786; y = 4.1985; z = 48.0035 }, (* C6 *) (A ( { x = 36.6103; y = 3.2749; z = 48.8452 }, (* N6 *) { x = 38.3236; y = 5.5522; z = 47.6595 }, (* N7 *) { x = 37.3887; y = 7.0024; z = 46.2437 }, (* N9 *) { x = 38.5055; y = 6.6096; z = 46.9057 }, (* C8 *) { x = 33.3553; y = 5.0152; z = 46.4771 }, (* H2 *) { x = 37.5730; y = 3.2804; z = 49.1507 }, (* H61 *) { x = 35.9775; y = 2.5638; z = 49.1828 }, (* H62 *) { x = 39.5461; y = 6.9184; z = 47.0041 }) (* H8 *) ) ) let rA08 = N( { a=0.1084; b= -0.0895; c= -0.9901; (* dgf_base_tfo *) d=0.9789; e= -0.1638; f=0.1220; g= -0.1731; h= -0.9824; i=0.0698; tx= -2.9039; ty=47.2655; tz=33.0094 }, { a=0.7529; b=0.1548; c=0.6397; (* P_O3'_275_tfo *) d=0.2952; e= -0.9481; f= -0.1180; g=0.5882; h=0.2777; i= -0.7595; tx= -58.8919; ty= -11.3095; tz=6.0866 }, { a= -0.0239; b=0.9667; c= -0.2546; (* P_O3'_180_tfo *) d=0.9731; e= -0.0359; f= -0.2275; g= -0.2290; h= -0.2532; i= -0.9399; tx=3.5401; ty= -29.7913; tz=52.2796 }, { a= -0.8912; b= -0.4531; c=0.0242; (* P_O3'_60_tfo *) d= -0.1183; e=0.1805; f= -0.9764; g=0.4380; h= -0.8730; i= -0.2145; tx=19.9023; ty=54.8054; tz=15.2799 }, { x = 41.8210; y = 8.3880; z = 43.5890 }, (* P *) { x = 42.5400; y = 8.0450; z = 44.8330 }, (* O1P *) { x = 42.2470; y = 9.6920; z = 42.9910 }, (* O2P *) { x = 40.2550; y = 8.2030; z = 43.7340 }, (* O5' *) { x = 39.4850; y = 8.9301; z = 44.6977 }, (* C5' *) { x = 39.0638; y = 9.8199; z = 44.2296 }, (* H5' *) { x = 40.0757; y = 9.0713; z = 45.6029 }, (* H5'' *) { x = 38.3102; y = 8.0414; z = 45.0789 }, (* C4' *) { x = 37.7842; y = 8.4637; z = 45.9351 }, (* H4' *) { x = 37.4200; y = 7.9453; z = 43.9769 }, (* O4' *) { x = 37.2249; y = 6.5609; z = 43.6273 }, (* C1' *) { x = 36.3360; y = 6.2168; z = 44.1561 }, (* H1' *) { x = 38.4347; y = 5.8414; z = 44.1590 }, (* C2' *) { x = 39.2688; y = 5.9974; z = 43.4749 }, (* H2'' *) { x = 38.2344; y = 4.4907; z = 44.4348 }, (* O2' *) { x = 37.6374; y = 4.0386; z = 43.8341 }, (* H2' *) { x = 38.6926; y = 6.6079; z = 45.4637 }, (* C3' *) { x = 39.7585; y = 6.5640; z = 45.6877 }, (* H3' *) { x = 37.8238; y = 6.0705; z = 46.4723 }, (* O3' *) { x = 33.9162; y = 6.2598; z = 39.7758 }, (* N1 *) { x = 34.6709; y = 6.5759; z = 42.0215 }, (* N3 *) { x = 33.7257; y = 6.5186; z = 41.0858 }, (* C2 *) { x = 35.8935; y = 6.3324; z = 41.5018 }, (* C4 *) { x = 36.2105; y = 6.0601; z = 40.1932 }, (* C5 *) { x = 35.1538; y = 6.0151; z = 39.2537 }, (* C6 *) (A ( { x = 35.3088; y = 5.7642; z = 37.9649 }, (* N6 *) { x = 37.5818; y = 5.8677; z = 40.0507 }, (* N7 *) { x = 37.0932; y = 6.3197; z = 42.1810 }, (* N9 *) { x = 38.0509; y = 6.0354; z = 41.2635 }, (* C8 *) { x = 32.6830; y = 6.6898; z = 41.3532 }, (* H2 *) { x = 36.2305; y = 5.5855; z = 37.5925 }, (* H61 *) { x = 34.5056; y = 5.7512; z = 37.3528 }, (* H62 *) { x = 39.1318; y = 5.8993; z = 41.2285 }) (* H8 *) ) ) let rA09 = N( { a=0.8467; b=0.4166; c= -0.3311; (* dgf_base_tfo *) d= -0.3962; e=0.9089; f=0.1303; g=0.3552; h=0.0209; i=0.9346; tx= -42.7319; ty= -26.6223; tz= -29.8163 }, { a=0.7529; b=0.1548; c=0.6397; (* P_O3'_275_tfo *) d=0.2952; e= -0.9481; f= -0.1180; g=0.5882; h=0.2777; i= -0.7595; tx= -58.8919; ty= -11.3095; tz=6.0866 }, { a= -0.0239; b=0.9667; c= -0.2546; (* P_O3'_180_tfo *) d=0.9731; e= -0.0359; f= -0.2275; g= -0.2290; h= -0.2532; i= -0.9399; tx=3.5401; ty= -29.7913; tz=52.2796 }, { a= -0.8912; b= -0.4531; c=0.0242; (* P_O3'_60_tfo *) d= -0.1183; e=0.1805; f= -0.9764; g=0.4380; h= -0.8730; i= -0.2145; tx=19.9023; ty=54.8054; tz=15.2799 }, { x = 41.8210; y = 8.3880; z = 43.5890 }, (* P *) { x = 42.5400; y = 8.0450; z = 44.8330 }, (* O1P *) { x = 42.2470; y = 9.6920; z = 42.9910 }, (* O2P *) { x = 40.2550; y = 8.2030; z = 43.7340 }, (* O5' *) { x = 39.3505; y = 8.4697; z = 42.6565 }, (* C5' *) { x = 39.1377; y = 7.5433; z = 42.1230 }, (* H5' *) { x = 39.7203; y = 9.3119; z = 42.0717 }, (* H5'' *) { x = 38.0405; y = 8.9195; z = 43.2869 }, (* C4' *) { x = 37.6479; y = 8.1347; z = 43.9335 }, (* H4' *) { x = 38.2691; y = 10.0933; z = 44.0524 }, (* O4' *) { x = 37.3999; y = 11.1488; z = 43.5973 }, (* C1' *) { x = 36.5061; y = 11.1221; z = 44.2206 }, (* H1' *) { x = 37.0364; y = 10.7838; z = 42.1836 }, (* C2' *) { x = 37.8636; y = 11.0489; z = 41.5252 }, (* H2'' *) { x = 35.8275; y = 11.3133; z = 41.7379 }, (* O2' *) { x = 35.6214; y = 12.1896; z = 42.0714 }, (* H2' *) { x = 36.9316; y = 9.2556; z = 42.2837 }, (* C3' *) { x = 37.1778; y = 8.8260; z = 41.3127 }, (* H3' *) { x = 35.6285; y = 8.9334; z = 42.7926 }, (* O3' *) { x = 38.1482; y = 15.2833; z = 46.4641 }, (* N1 *) { x = 37.3641; y = 13.0968; z = 45.9007 }, (* N3 *) { x = 37.5032; y = 14.1288; z = 46.7300 }, (* C2 *) { x = 37.9570; y = 13.3377; z = 44.7113 }, (* C4 *) { x = 38.6397; y = 14.4660; z = 44.3267 }, (* C5 *) { x = 38.7473; y = 15.5229; z = 45.2609 }, (* C6 *) (A ( { x = 39.3720; y = 16.6649; z = 45.0297 }, (* N6 *) { x = 39.1079; y = 14.3351; z = 43.0223 }, (* N7 *) { x = 38.0132; y = 12.4868; z = 43.6280 }, (* N9 *) { x = 38.7058; y = 13.1402; z = 42.6620 }, (* C8 *) { x = 37.0731; y = 14.0857; z = 47.7306 }, (* H2 *) { x = 39.8113; y = 16.8281; z = 44.1350 }, (* H61 *) { x = 39.4100; y = 17.3741; z = 45.7478 }, (* H62 *) { x = 39.0412; y = 12.9660; z = 41.6397 }) (* H8 *) ) ) let rA10 = N( { a=0.7063; b=0.6317; c= -0.3196; (* dgf_base_tfo *) d= -0.0403; e= -0.4149; f= -0.9090; g= -0.7068; h=0.6549; i= -0.2676; tx=6.4402; ty= -52.1496; tz=30.8246 }, { a=0.7529; b=0.1548; c=0.6397; (* P_O3'_275_tfo *) d=0.2952; e= -0.9481; f= -0.1180; g=0.5882; h=0.2777; i= -0.7595; tx= -58.8919; ty= -11.3095; tz=6.0866 }, { a= -0.0239; b=0.9667; c= -0.2546; (* P_O3'_180_tfo *) d=0.9731; e= -0.0359; f= -0.2275; g= -0.2290; h= -0.2532; i= -0.9399; tx=3.5401; ty= -29.7913; tz=52.2796 }, { a= -0.8912; b= -0.4531; c=0.0242; (* P_O3'_60_tfo *) d= -0.1183; e=0.1805; f= -0.9764; g=0.4380; h= -0.8730; i= -0.2145; tx=19.9023; ty=54.8054; tz=15.2799 }, { x = 41.8210; y = 8.3880; z = 43.5890 }, (* P *) { x = 42.5400; y = 8.0450; z = 44.8330 }, (* O1P *) { x = 42.2470; y = 9.6920; z = 42.9910 }, (* O2P *) { x = 40.2550; y = 8.2030; z = 43.7340 }, (* O5' *) { x = 39.4850; y = 8.9301; z = 44.6977 }, (* C5' *) { x = 39.0638; y = 9.8199; z = 44.2296 }, (* H5' *) { x = 40.0757; y = 9.0713; z = 45.6029 }, (* H5'' *) { x = 38.3102; y = 8.0414; z = 45.0789 }, (* C4' *) { x = 37.7099; y = 7.8166; z = 44.1973 }, (* H4' *) { x = 38.8012; y = 6.8321; z = 45.6380 }, (* O4' *) { x = 38.2431; y = 6.6413; z = 46.9529 }, (* C1' *) { x = 37.3505; y = 6.0262; z = 46.8385 }, (* H1' *) { x = 37.8484; y = 8.0156; z = 47.4214 }, (* C2' *) { x = 38.7381; y = 8.5406; z = 47.7690 }, (* H2'' *) { x = 36.8286; y = 8.0368; z = 48.3701 }, (* O2' *) { x = 36.8392; y = 7.3063; z = 48.9929 }, (* H2' *) { x = 37.3576; y = 8.6512; z = 46.1132 }, (* C3' *) { x = 37.5207; y = 9.7275; z = 46.1671 }, (* H3' *) { x = 35.9985; y = 8.2392; z = 45.9032 }, (* O3' *) { x = 39.9117; y = 2.2278; z = 48.8527 }, (* N1 *) { x = 38.6207; y = 3.6941; z = 47.4757 }, (* N3 *) { x = 38.9872; y = 2.4888; z = 47.9057 }, (* C2 *) { x = 39.2961; y = 4.6720; z = 48.1174 }, (* C4 *) { x = 40.2546; y = 4.5307; z = 49.0912 }, (* C5 *) { x = 40.5932; y = 3.2189; z = 49.4985 }, (* C6 *) (A ( { x = 41.4938; y = 2.9317; z = 50.4229 }, (* N6 *) { x = 40.7195; y = 5.7755; z = 49.5060 }, (* N7 *) { x = 39.1730; y = 6.0305; z = 47.9170 }, (* N9 *) { x = 40.0413; y = 6.6250; z = 48.7728 }, (* C8 *) { x = 38.5257; y = 1.5960; z = 47.4838 }, (* H2 *) { x = 41.9907; y = 3.6753; z = 50.8921 }, (* H61 *) { x = 41.6848; y = 1.9687; z = 50.6599 }, (* H62 *) { x = 40.3571; y = 7.6321; z = 49.0452 }) (* H8 *) ) ) let rAs = [rA01;rA02;rA03;rA04;rA05;rA06;rA07;rA08;rA09;rA10] let rC = N( { a= -0.0359; b= -0.8071; c=0.5894; (* dgf_base_tfo *) d= -0.2669; e=0.5761; f=0.7726; g= -0.9631; h= -0.1296; i= -0.2361; tx=0.1584; ty=8.3434; tz=0.5434 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 5.2430; y = -8.2420; z = 2.8260 }, (* C5' *) { x = 5.1974; y = -8.8497; z = 1.9223 }, (* H5' *) { x = 5.5548; y = -8.7348; z = 3.7469 }, (* H5'' *) { x = 6.3140; y = -7.2060; z = 2.5510 }, (* C4' *) { x = 7.2954; y = -7.6762; z = 2.4898 }, (* H4' *) { x = 6.0140; y = -6.5420; z = 1.2890 }, (* O4' *) { x = 6.4190; y = -5.1840; z = 1.3620 }, (* C1' *) { x = 7.1608; y = -5.0495; z = 0.5747 }, (* H1' *) { x = 7.0760; y = -4.9560; z = 2.7270 }, (* C2' *) { x = 6.7770; y = -3.9803; z = 3.1099 }, (* H2'' *) { x = 8.4500; y = -5.1930; z = 2.5810 }, (* O2' *) { x = 8.8309; y = -4.8755; z = 1.7590 }, (* H2' *) { x = 6.4060; y = -6.0590; z = 3.5580 }, (* C3' *) { x = 5.4021; y = -5.7313; z = 3.8281 }, (* H3' *) { x = 7.1570; y = -6.4240; z = 4.7070 }, (* O3' *) { x = 5.2170; y = -4.3260; z = 1.1690 }, (* N1 *) { x = 4.2960; y = -2.2560; z = 0.6290 }, (* N3 *) { x = 5.4330; y = -3.0200; z = 0.7990 }, (* C2 *) { x = 2.9930; y = -2.6780; z = 0.7940 }, (* C4 *) { x = 2.8670; y = -4.0630; z = 1.1830 }, (* C5 *) { x = 3.9570; y = -4.8300; z = 1.3550 }, (* C6 *) (C ( { x = 2.0187; y = -1.8047; z = 0.5874 }, (* N4 *) { x = 6.5470; y = -2.5560; z = 0.6290 }, (* O2 *) { x = 1.0684; y = -2.1236; z = 0.7109 }, (* H41 *) { x = 2.2344; y = -0.8560; z = 0.3162 }, (* H42 *) { x = 1.8797; y = -4.4972; z = 1.3404 }, (* H5 *) { x = 3.8479; y = -5.8742; z = 1.6480 }) (* H6 *) ) ) let rC01 = N( { a= -0.0137; b= -0.8012; c=0.5983; (* dgf_base_tfo *) d= -0.2523; e=0.5817; f=0.7733; g= -0.9675; h= -0.1404; i= -0.2101; tx=0.2031; ty=8.3874; tz=0.4228 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 5.2416; y = -8.2422; z = 2.8181 }, (* C5' *) { x = 5.2050; y = -8.8128; z = 1.8901 }, (* H5' *) { x = 5.5368; y = -8.7738; z = 3.7227 }, (* H5'' *) { x = 6.3232; y = -7.2037; z = 2.6002 }, (* C4' *) { x = 7.3048; y = -7.6757; z = 2.5577 }, (* H4' *) { x = 6.0635; y = -6.5092; z = 1.3456 }, (* O4' *) { x = 6.4697; y = -5.1547; z = 1.4629 }, (* C1' *) { x = 7.2354; y = -5.0043; z = 0.7018 }, (* H1' *) { x = 7.0856; y = -4.9610; z = 2.8521 }, (* C2' *) { x = 6.7777; y = -3.9935; z = 3.2487 }, (* H2'' *) { x = 8.4627; y = -5.1992; z = 2.7423 }, (* O2' *) { x = 8.8693; y = -4.8638; z = 1.9399 }, (* H2' *) { x = 6.3877; y = -6.0809; z = 3.6362 }, (* C3' *) { x = 5.3770; y = -5.7562; z = 3.8834 }, (* H3' *) { x = 7.1024; y = -6.4754; z = 4.7985 }, (* O3' *) { x = 5.2764; y = -4.2883; z = 1.2538 }, (* N1 *) { x = 4.3777; y = -2.2062; z = 0.7229 }, (* N3 *) { x = 5.5069; y = -2.9779; z = 0.9088 }, (* C2 *) { x = 3.0693; y = -2.6246; z = 0.8500 }, (* C4 *) { x = 2.9279; y = -4.0146; z = 1.2149 }, (* C5 *) { x = 4.0101; y = -4.7892; z = 1.4017 }, (* C6 *) (C ( { x = 2.1040; y = -1.7437; z = 0.6331 }, (* N4 *) { x = 6.6267; y = -2.5166; z = 0.7728 }, (* O2 *) { x = 1.1496; y = -2.0600; z = 0.7287 }, (* H41 *) { x = 2.3303; y = -0.7921; z = 0.3815 }, (* H42 *) { x = 1.9353; y = -4.4465; z = 1.3419 }, (* H5 *) { x = 3.8895; y = -5.8371; z = 1.6762 }) (* H6 *) ) ) let rC02 = N( { a=0.5141; b=0.0246; c=0.8574; (* dgf_base_tfo *) d= -0.5547; e= -0.7529; f=0.3542; g=0.6542; h= -0.6577; i= -0.3734; tx= -9.1111; ty= -3.4598; tz= -3.2939 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 4.3825; y = -6.6585; z = 4.0489 }, (* C5' *) { x = 4.6841; y = -7.2019; z = 4.9443 }, (* H5' *) { x = 3.6189; y = -5.8889; z = 4.1625 }, (* H5'' *) { x = 5.6255; y = -5.9175; z = 3.5998 }, (* C4' *) { x = 5.8732; y = -5.1228; z = 4.3034 }, (* H4' *) { x = 6.7337; y = -6.8605; z = 3.5222 }, (* O4' *) { x = 7.5932; y = -6.4923; z = 2.4548 }, (* C1' *) { x = 8.5661; y = -6.2983; z = 2.9064 }, (* H1' *) { x = 7.0527; y = -5.2012; z = 1.8322 }, (* C2' *) { x = 7.1627; y = -5.2525; z = 0.7490 }, (* H2'' *) { x = 7.6666; y = -4.1249; z = 2.4880 }, (* O2' *) { x = 8.5944; y = -4.2543; z = 2.6981 }, (* H2' *) { x = 5.5661; y = -5.3029; z = 2.2009 }, (* C3' *) { x = 5.0841; y = -6.0018; z = 1.5172 }, (* H3' *) { x = 4.9062; y = -4.0452; z = 2.2042 }, (* O3' *) { x = 7.6298; y = -7.6136; z = 1.4752 }, (* N1 *) { x = 8.6945; y = -8.7046; z = -0.2857 }, (* N3 *) { x = 8.6943; y = -7.6514; z = 0.6066 }, (* C2 *) { x = 7.7426; y = -9.6987; z = -0.3801 }, (* C4 *) { x = 6.6642; y = -9.5742; z = 0.5722 }, (* C5 *) { x = 6.6391; y = -8.5592; z = 1.4526 }, (* C6 *) (C ( { x = 7.9033; y = -10.6371; z = -1.3010 }, (* N4 *) { x = 9.5840; y = -6.8186; z = 0.6136 }, (* O2 *) { x = 7.2009; y = -11.3604; z = -1.3619 }, (* H41 *) { x = 8.7058; y = -10.6168; z = -1.9140 }, (* H42 *) { x = 5.8585; y = -10.3083; z = 0.5822 }, (* H5 *) { x = 5.8197; y = -8.4773; z = 2.1667 }) (* H6 *) ) ) let rC03 = N( { a= -0.4993; b=0.0476; c=0.8651; (* dgf_base_tfo *) d=0.8078; e= -0.3353; f=0.4847; g=0.3132; h=0.9409; i=0.1290; tx=6.2989; ty= -5.2303; tz= -3.8577 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 3.9938; y = -6.7042; z = 1.9023 }, (* C5' *) { x = 3.2332; y = -5.9343; z = 2.0319 }, (* H5' *) { x = 3.9666; y = -7.2863; z = 0.9812 }, (* H5'' *) { x = 5.3098; y = -5.9546; z = 1.8564 }, (* C4' *) { x = 5.3863; y = -5.3702; z = 0.9395 }, (* H4' *) { x = 5.3851; y = -5.0642; z = 3.0076 }, (* O4' *) { x = 6.7315; y = -4.9724; z = 3.4462 }, (* C1' *) { x = 7.0033; y = -3.9202; z = 3.3619 }, (* H1' *) { x = 7.5997; y = -5.8018; z = 2.4948 }, (* C2' *) { x = 8.3627; y = -6.3254; z = 3.0707 }, (* H2'' *) { x = 8.0410; y = -4.9501; z = 1.4724 }, (* O2' *) { x = 8.2781; y = -4.0644; z = 1.7570 }, (* H2' *) { x = 6.5701; y = -6.8129; z = 1.9714 }, (* C3' *) { x = 6.4186; y = -7.5809; z = 2.7299 }, (* H3' *) { x = 6.9357; y = -7.3841; z = 0.7235 }, (* O3' *) { x = 6.8024; y = -5.4718; z = 4.8475 }, (* N1 *) { x = 7.9218; y = -5.5700; z = 6.8877 }, (* N3 *) { x = 7.8908; y = -5.0886; z = 5.5944 }, (* C2 *) { x = 6.9789; y = -6.3827; z = 7.4823 }, (* C4 *) { x = 5.8742; y = -6.7319; z = 6.6202 }, (* C5 *) { x = 5.8182; y = -6.2769; z = 5.3570 }, (* C6 *) (C ( { x = 7.1702; y = -6.7511; z = 8.7402 }, (* N4 *) { x = 8.7747; y = -4.3728; z = 5.1568 }, (* O2 *) { x = 6.4741; y = -7.3461; z = 9.1662 }, (* H41 *) { x = 7.9889; y = -6.4396; z = 9.2429 }, (* H42 *) { x = 5.0736; y = -7.3713; z = 6.9922 }, (* H5 *) { x = 4.9784; y = -6.5473; z = 4.7170 }) (* H6 *) ) ) let rC04 = N( { a= -0.5669; b= -0.8012; c=0.1918; (* dgf_base_tfo *) d= -0.8129; e=0.5817; f=0.0273; g= -0.1334; h= -0.1404; i= -0.9811; tx= -0.3279; ty=8.3874; tz=0.3355 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 5.2416; y = -8.2422; z = 2.8181 }, (* C5' *) { x = 5.2050; y = -8.8128; z = 1.8901 }, (* H5' *) { x = 5.5368; y = -8.7738; z = 3.7227 }, (* H5'' *) { x = 6.3232; y = -7.2037; z = 2.6002 }, (* C4' *) { x = 7.3048; y = -7.6757; z = 2.5577 }, (* H4' *) { x = 6.0635; y = -6.5092; z = 1.3456 }, (* O4' *) { x = 6.4697; y = -5.1547; z = 1.4629 }, (* C1' *) { x = 7.2354; y = -5.0043; z = 0.7018 }, (* H1' *) { x = 7.0856; y = -4.9610; z = 2.8521 }, (* C2' *) { x = 6.7777; y = -3.9935; z = 3.2487 }, (* H2'' *) { x = 8.4627; y = -5.1992; z = 2.7423 }, (* O2' *) { x = 8.8693; y = -4.8638; z = 1.9399 }, (* H2' *) { x = 6.3877; y = -6.0809; z = 3.6362 }, (* C3' *) { x = 5.3770; y = -5.7562; z = 3.8834 }, (* H3' *) { x = 7.1024; y = -6.4754; z = 4.7985 }, (* O3' *) { x = 5.2764; y = -4.2883; z = 1.2538 }, (* N1 *) { x = 3.8961; y = -3.0896; z = -0.1893 }, (* N3 *) { x = 5.0095; y = -3.8907; z = -0.0346 }, (* C2 *) { x = 3.0480; y = -2.6632; z = 0.8116 }, (* C4 *) { x = 3.4093; y = -3.1310; z = 2.1292 }, (* C5 *) { x = 4.4878; y = -3.9124; z = 2.3088 }, (* C6 *) (C ( { x = 2.0216; y = -1.8941; z = 0.4804 }, (* N4 *) { x = 5.7005; y = -4.2164; z = -0.9842 }, (* O2 *) { x = 1.4067; y = -1.5873; z = 1.2205 }, (* H41 *) { x = 1.8721; y = -1.6319; z = -0.4835 }, (* H42 *) { x = 2.8048; y = -2.8507; z = 2.9918 }, (* H5 *) { x = 4.7491; y = -4.2593; z = 3.3085 }) (* H6 *) ) ) let rC05 = N( { a= -0.6298; b=0.0246; c=0.7763; (* dgf_base_tfo *) d= -0.5226; e= -0.7529; f= -0.4001; g=0.5746; h= -0.6577; i=0.4870; tx= -0.0208; ty= -3.4598; tz= -9.6882 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 4.3825; y = -6.6585; z = 4.0489 }, (* C5' *) { x = 4.6841; y = -7.2019; z = 4.9443 }, (* H5' *) { x = 3.6189; y = -5.8889; z = 4.1625 }, (* H5'' *) { x = 5.6255; y = -5.9175; z = 3.5998 }, (* C4' *) { x = 5.8732; y = -5.1228; z = 4.3034 }, (* H4' *) { x = 6.7337; y = -6.8605; z = 3.5222 }, (* O4' *) { x = 7.5932; y = -6.4923; z = 2.4548 }, (* C1' *) { x = 8.5661; y = -6.2983; z = 2.9064 }, (* H1' *) { x = 7.0527; y = -5.2012; z = 1.8322 }, (* C2' *) { x = 7.1627; y = -5.2525; z = 0.7490 }, (* H2'' *) { x = 7.6666; y = -4.1249; z = 2.4880 }, (* O2' *) { x = 8.5944; y = -4.2543; z = 2.6981 }, (* H2' *) { x = 5.5661; y = -5.3029; z = 2.2009 }, (* C3' *) { x = 5.0841; y = -6.0018; z = 1.5172 }, (* H3' *) { x = 4.9062; y = -4.0452; z = 2.2042 }, (* O3' *) { x = 7.6298; y = -7.6136; z = 1.4752 }, (* N1 *) { x = 8.5977; y = -9.5977; z = 0.7329 }, (* N3 *) { x = 8.5951; y = -8.5745; z = 1.6594 }, (* C2 *) { x = 7.7372; y = -9.7371; z = -0.3364 }, (* C4 *) { x = 6.7596; y = -8.6801; z = -0.4476 }, (* C5 *) { x = 6.7338; y = -7.6721; z = 0.4408 }, (* C6 *) (C ( { x = 7.8849; y = -10.7881; z = -1.1289 }, (* N4 *) { x = 9.3993; y = -8.5377; z = 2.5743 }, (* O2 *) { x = 7.2499; y = -10.8809; z = -1.9088 }, (* H41 *) { x = 8.6122; y = -11.4649; z = -0.9468 }, (* H42 *) { x = 6.0317; y = -8.6941; z = -1.2588 }, (* H5 *) { x = 5.9901; y = -6.8809; z = 0.3459 }) (* H6 *) ) ) let rC06 = N( { a= -0.9837; b=0.0476; c= -0.1733; (* dgf_base_tfo *) d= -0.1792; e= -0.3353; f=0.9249; g= -0.0141; h=0.9409; i=0.3384; tx=5.7793; ty= -5.2303; tz=4.5997 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 3.9938; y = -6.7042; z = 1.9023 }, (* C5' *) { x = 3.2332; y = -5.9343; z = 2.0319 }, (* H5' *) { x = 3.9666; y = -7.2863; z = 0.9812 }, (* H5'' *) { x = 5.3098; y = -5.9546; z = 1.8564 }, (* C4' *) { x = 5.3863; y = -5.3702; z = 0.9395 }, (* H4' *) { x = 5.3851; y = -5.0642; z = 3.0076 }, (* O4' *) { x = 6.7315; y = -4.9724; z = 3.4462 }, (* C1' *) { x = 7.0033; y = -3.9202; z = 3.3619 }, (* H1' *) { x = 7.5997; y = -5.8018; z = 2.4948 }, (* C2' *) { x = 8.3627; y = -6.3254; z = 3.0707 }, (* H2'' *) { x = 8.0410; y = -4.9501; z = 1.4724 }, (* O2' *) { x = 8.2781; y = -4.0644; z = 1.7570 }, (* H2' *) { x = 6.5701; y = -6.8129; z = 1.9714 }, (* C3' *) { x = 6.4186; y = -7.5809; z = 2.7299 }, (* H3' *) { x = 6.9357; y = -7.3841; z = 0.7235 }, (* O3' *) { x = 6.8024; y = -5.4718; z = 4.8475 }, (* N1 *) { x = 6.6920; y = -5.0495; z = 7.1354 }, (* N3 *) { x = 6.6201; y = -4.5500; z = 5.8506 }, (* C2 *) { x = 6.9254; y = -6.3614; z = 7.4926 }, (* C4 *) { x = 7.1046; y = -7.2543; z = 6.3718 }, (* C5 *) { x = 7.0391; y = -6.7951; z = 5.1106 }, (* C6 *) (C ( { x = 6.9614; y = -6.6648; z = 8.7815 }, (* N4 *) { x = 6.4083; y = -3.3696; z = 5.6340 }, (* O2 *) { x = 7.1329; y = -7.6280; z = 9.0324 }, (* H41 *) { x = 6.8204; y = -5.9469; z = 9.4777 }, (* H42 *) { x = 7.2954; y = -8.3135; z = 6.5440 }, (* H5 *) { x = 7.1753; y = -7.4798; z = 4.2735 }) (* H6 *) ) ) let rC07 = N( { a=0.0033; b=0.2720; c= -0.9623; (* dgf_base_tfo *) d=0.3013; e= -0.9179; f= -0.2584; g= -0.9535; h= -0.2891; i= -0.0850; tx=43.0403; ty=13.7233; tz=34.5710 }, { a=0.9187; b=0.2887; c=0.2694; (* P_O3'_275_tfo *) d=0.0302; e= -0.7316; f=0.6811; g=0.3938; h= -0.6176; i= -0.6808; tx= -48.4330; ty=26.3254; tz=13.6383 }, { a= -0.1504; b=0.7744; c= -0.6145; (* P_O3'_180_tfo *) d=0.7581; e=0.4893; f=0.4311; g=0.6345; h= -0.4010; i= -0.6607; tx= -31.9784; ty= -13.4285; tz=44.9650 }, { a= -0.6236; b= -0.7810; c= -0.0337; (* P_O3'_60_tfo *) d= -0.6890; e=0.5694; f= -0.4484; g=0.3694; h= -0.2564; i= -0.8932; tx=12.1105; ty=30.8774; tz=46.0946 }, { x = 33.3400; y = 11.0980; z = 46.1750 }, (* P *) { x = 34.5130; y = 10.2320; z = 46.4660 }, (* O1P *) { x = 33.4130; y = 12.3960; z = 46.9340 }, (* O2P *) { x = 31.9810; y = 10.3390; z = 46.4820 }, (* O5' *) { x = 30.8152; y = 11.1619; z = 46.2003 }, (* C5' *) { x = 30.4519; y = 10.9454; z = 45.1957 }, (* H5' *) { x = 31.0379; y = 12.2016; z = 46.4400 }, (* H5'' *) { x = 29.7081; y = 10.7448; z = 47.1428 }, (* C4' *) { x = 28.8710; y = 11.4416; z = 47.0982 }, (* H4' *) { x = 29.2550; y = 9.4394; z = 46.8162 }, (* O4' *) { x = 29.3907; y = 8.5625; z = 47.9460 }, (* C1' *) { x = 28.4416; y = 8.5669; z = 48.4819 }, (* H1' *) { x = 30.4468; y = 9.2031; z = 48.7952 }, (* C2' *) { x = 31.4222; y = 8.9651; z = 48.3709 }, (* H2'' *) { x = 30.3701; y = 8.9157; z = 50.1624 }, (* O2' *) { x = 30.0652; y = 8.0304; z = 50.3740 }, (* H2' *) { x = 30.1622; y = 10.6879; z = 48.6120 }, (* C3' *) { x = 31.0952; y = 11.2399; z = 48.7254 }, (* H3' *) { x = 29.1076; y = 11.1535; z = 49.4702 }, (* O3' *) { x = 29.7883; y = 7.2209; z = 47.5235 }, (* N1 *) { x = 29.1825; y = 5.0438; z = 46.8275 }, (* N3 *) { x = 28.8008; y = 6.2912; z = 47.2263 }, (* C2 *) { x = 30.4888; y = 4.6890; z = 46.7186 }, (* C4 *) { x = 31.5034; y = 5.6405; z = 47.0249 }, (* C5 *) { x = 31.1091; y = 6.8691; z = 47.4156 }, (* C6 *) (C ( { x = 30.8109; y = 3.4584; z = 46.3336 }, (* N4 *) { x = 27.6171; y = 6.5989; z = 47.3189 }, (* O2 *) { x = 31.7923; y = 3.2301; z = 46.2638 }, (* H41 *) { x = 30.0880; y = 2.7857; z = 46.1215 }, (* H42 *) { x = 32.5542; y = 5.3634; z = 46.9395 }, (* H5 *) { x = 31.8523; y = 7.6279; z = 47.6603 }) (* H6 *) ) ) let rC08 = N( { a=0.0797; b= -0.6026; c= -0.7941; (* dgf_base_tfo *) d=0.7939; e=0.5201; f= -0.3150; g=0.6028; h= -0.6054; i=0.5198; tx= -36.8341; ty=41.5293; tz=1.6628 }, { a=0.9187; b=0.2887; c=0.2694; (* P_O3'_275_tfo *) d=0.0302; e= -0.7316; f=0.6811; g=0.3938; h= -0.6176; i= -0.6808; tx= -48.4330; ty=26.3254; tz=13.6383 }, { a= -0.1504; b=0.7744; c= -0.6145; (* P_O3'_180_tfo *) d=0.7581; e=0.4893; f=0.4311; g=0.6345; h= -0.4010; i= -0.6607; tx= -31.9784; ty= -13.4285; tz=44.9650 }, { a= -0.6236; b= -0.7810; c= -0.0337; (* P_O3'_60_tfo *) d= -0.6890; e=0.5694; f= -0.4484; g=0.3694; h= -0.2564; i= -0.8932; tx=12.1105; ty=30.8774; tz=46.0946 }, { x = 33.3400; y = 11.0980; z = 46.1750 }, (* P *) { x = 34.5130; y = 10.2320; z = 46.4660 }, (* O1P *) { x = 33.4130; y = 12.3960; z = 46.9340 }, (* O2P *) { x = 31.9810; y = 10.3390; z = 46.4820 }, (* O5' *) { x = 31.8779; y = 9.9369; z = 47.8760 }, (* C5' *) { x = 31.3239; y = 10.6931; z = 48.4322 }, (* H5' *) { x = 32.8647; y = 9.6624; z = 48.2489 }, (* H5'' *) { x = 31.0429; y = 8.6773; z = 47.9401 }, (* C4' *) { x = 31.0779; y = 8.2331; z = 48.9349 }, (* H4' *) { x = 29.6956; y = 8.9669; z = 47.5983 }, (* O4' *) { x = 29.2784; y = 8.1700; z = 46.4782 }, (* C1' *) { x = 28.8006; y = 7.2731; z = 46.8722 }, (* H1' *) { x = 30.5544; y = 7.7940; z = 45.7875 }, (* C2' *) { x = 30.8837; y = 8.6410; z = 45.1856 }, (* H2'' *) { x = 30.5100; y = 6.6007; z = 45.0582 }, (* O2' *) { x = 29.6694; y = 6.4168; z = 44.6326 }, (* H2' *) { x = 31.5146; y = 7.5954; z = 46.9527 }, (* C3' *) { x = 32.5255; y = 7.8261; z = 46.6166 }, (* H3' *) { x = 31.3876; y = 6.2951; z = 47.5516 }, (* O3' *) { x = 28.3976; y = 8.9302; z = 45.5933 }, (* N1 *) { x = 26.2155; y = 9.6135; z = 44.9910 }, (* N3 *) { x = 27.0281; y = 8.8961; z = 45.8192 }, (* C2 *) { x = 26.7044; y = 10.3489; z = 43.9595 }, (* C4 *) { x = 28.1088; y = 10.3837; z = 43.7247 }, (* C5 *) { x = 28.8978; y = 9.6708; z = 44.5535 }, (* C6 *) (C ( { x = 25.8715; y = 11.0249; z = 43.1749 }, (* N4 *) { x = 26.5733; y = 8.2371; z = 46.7484 }, (* O2 *) { x = 26.2707; y = 11.5609; z = 42.4177 }, (* H41 *) { x = 24.8760; y = 10.9939; z = 43.3427 }, (* H42 *) { x = 28.5089; y = 10.9722; z = 42.8990 }, (* H5 *) { x = 29.9782; y = 9.6687; z = 44.4097 }) (* H6 *) ) ) let rC09 = N( { a=0.8727; b=0.4760; c= -0.1091; (* dgf_base_tfo *) d= -0.4188; e=0.6148; f= -0.6682; g= -0.2510; h=0.6289; i=0.7359; tx= -8.1687; ty= -52.0761; tz= -25.0726 }, { a=0.9187; b=0.2887; c=0.2694; (* P_O3'_275_tfo *) d=0.0302; e= -0.7316; f=0.6811; g=0.3938; h= -0.6176; i= -0.6808; tx= -48.4330; ty=26.3254; tz=13.6383 }, { a= -0.1504; b=0.7744; c= -0.6145; (* P_O3'_180_tfo *) d=0.7581; e=0.4893; f=0.4311; g=0.6345; h= -0.4010; i= -0.6607; tx= -31.9784; ty= -13.4285; tz=44.9650 }, { a= -0.6236; b= -0.7810; c= -0.0337; (* P_O3'_60_tfo *) d= -0.6890; e=0.5694; f= -0.4484; g=0.3694; h= -0.2564; i= -0.8932; tx=12.1105; ty=30.8774; tz=46.0946 }, { x = 33.3400; y = 11.0980; z = 46.1750 }, (* P *) { x = 34.5130; y = 10.2320; z = 46.4660 }, (* O1P *) { x = 33.4130; y = 12.3960; z = 46.9340 }, (* O2P *) { x = 31.9810; y = 10.3390; z = 46.4820 }, (* O5' *) { x = 30.8152; y = 11.1619; z = 46.2003 }, (* C5' *) { x = 30.4519; y = 10.9454; z = 45.1957 }, (* H5' *) { x = 31.0379; y = 12.2016; z = 46.4400 }, (* H5'' *) { x = 29.7081; y = 10.7448; z = 47.1428 }, (* C4' *) { x = 29.4506; y = 9.6945; z = 47.0059 }, (* H4' *) { x = 30.1045; y = 10.9634; z = 48.4885 }, (* O4' *) { x = 29.1794; y = 11.8418; z = 49.1490 }, (* C1' *) { x = 28.4388; y = 11.2210; z = 49.6533 }, (* H1' *) { x = 28.5211; y = 12.6008; z = 48.0367 }, (* C2' *) { x = 29.1947; y = 13.3949; z = 47.7147 }, (* H2'' *) { x = 27.2316; y = 13.0683; z = 48.3134 }, (* O2' *) { x = 27.0851; y = 13.3391; z = 49.2227 }, (* H2' *) { x = 28.4131; y = 11.5507; z = 46.9391 }, (* C3' *) { x = 28.4451; y = 12.0512; z = 45.9713 }, (* H3' *) { x = 27.2707; y = 10.6955; z = 47.1097 }, (* O3' *) { x = 29.8751; y = 12.7405; z = 50.0682 }, (* N1 *) { x = 30.7172; y = 13.1841; z = 52.2328 }, (* N3 *) { x = 30.0617; y = 12.3404; z = 51.3847 }, (* C2 *) { x = 31.1834; y = 14.3941; z = 51.8297 }, (* C4 *) { x = 30.9913; y = 14.8074; z = 50.4803 }, (* C5 *) { x = 30.3434; y = 13.9610; z = 49.6548 }, (* C6 *) (C ( { x = 31.8090; y = 15.1847; z = 52.6957 }, (* N4 *) { x = 29.6470; y = 11.2494; z = 51.7616 }, (* O2 *) { x = 32.1422; y = 16.0774; z = 52.3606 }, (* H41 *) { x = 31.9392; y = 14.8893; z = 53.6527 }, (* H42 *) { x = 31.3632; y = 15.7771; z = 50.1491 }, (* H5 *) { x = 30.1742; y = 14.2374; z = 48.6141 }) (* H6 *) ) ) let rC10 = N( { a=0.1549; b=0.8710; c= -0.4663; (* dgf_base_tfo *) d=0.6768; e= -0.4374; f= -0.5921; g= -0.7197; h= -0.2239; i= -0.6572; tx=25.2447; ty= -14.1920; tz=50.3201 }, { a=0.9187; b=0.2887; c=0.2694; (* P_O3'_275_tfo *) d=0.0302; e= -0.7316; f=0.6811; g=0.3938; h= -0.6176; i= -0.6808; tx= -48.4330; ty=26.3254; tz=13.6383 }, { a= -0.1504; b=0.7744; c= -0.6145; (* P_O3'_180_tfo *) d=0.7581; e=0.4893; f=0.4311; g=0.6345; h= -0.4010; i= -0.6607; tx= -31.9784; ty= -13.4285; tz=44.9650 }, { a= -0.6236; b= -0.7810; c= -0.0337; (* P_O3'_60_tfo *) d= -0.6890; e=0.5694; f= -0.4484; g=0.3694; h= -0.2564; i= -0.8932; tx=12.1105; ty=30.8774; tz=46.0946 }, { x = 33.3400; y = 11.0980; z = 46.1750 }, (* P *) { x = 34.5130; y = 10.2320; z = 46.4660 }, (* O1P *) { x = 33.4130; y = 12.3960; z = 46.9340 }, (* O2P *) { x = 31.9810; y = 10.3390; z = 46.4820 }, (* O5' *) { x = 31.8779; y = 9.9369; z = 47.8760 }, (* C5' *) { x = 31.3239; y = 10.6931; z = 48.4322 }, (* H5' *) { x = 32.8647; y = 9.6624; z = 48.2489 }, (* H5'' *) { x = 31.0429; y = 8.6773; z = 47.9401 }, (* C4' *) { x = 30.0440; y = 8.8473; z = 47.5383 }, (* H4' *) { x = 31.6749; y = 7.6351; z = 47.2119 }, (* O4' *) { x = 31.9159; y = 6.5022; z = 48.0616 }, (* C1' *) { x = 31.0691; y = 5.8243; z = 47.9544 }, (* H1' *) { x = 31.9300; y = 7.0685; z = 49.4493 }, (* C2' *) { x = 32.9024; y = 7.5288; z = 49.6245 }, (* H2'' *) { x = 31.5672; y = 6.1750; z = 50.4632 }, (* O2' *) { x = 31.8416; y = 5.2663; z = 50.3200 }, (* H2' *) { x = 30.8618; y = 8.1514; z = 49.3749 }, (* C3' *) { x = 31.1122; y = 8.9396; z = 50.0850 }, (* H3' *) { x = 29.5351; y = 7.6245; z = 49.5409 }, (* O3' *) { x = 33.1890; y = 5.8629; z = 47.7343 }, (* N1 *) { x = 34.4004; y = 4.2636; z = 46.4828 }, (* N3 *) { x = 33.2062; y = 4.8497; z = 46.7851 }, (* C2 *) { x = 35.5600; y = 4.6374; z = 47.0822 }, (* C4 *) { x = 35.5444; y = 5.6751; z = 48.0577 }, (* C5 *) { x = 34.3565; y = 6.2450; z = 48.3432 }, (* C6 *) (C ( { x = 36.6977; y = 4.0305; z = 46.7598 }, (* N4 *) { x = 32.1661; y = 4.5034; z = 46.2348 }, (* O2 *) { x = 37.5405; y = 4.3347; z = 47.2259 }, (* H41 *) { x = 36.7033; y = 3.2923; z = 46.0706 }, (* H42 *) { x = 36.4713; y = 5.9811; z = 48.5428 }, (* H5 *) { x = 34.2986; y = 7.0426; z = 49.0839 }) (* H6 *) ) ) let rCs = [rC01;rC02;rC03;rC04;rC05;rC06;rC07;rC08;rC09;rC10] let rG = N( { a= -0.0018; b= -0.8207; c=0.5714; (* dgf_base_tfo *) d=0.2679; e= -0.5509; f= -0.7904; g=0.9634; h=0.1517; i=0.2209; tx=0.0073; ty=8.4030; tz=0.6232 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 5.4550; y = 8.2120; z = -2.8810 }, (* C5' *) { x = 5.4546; y = 8.8508; z = -1.9978 }, (* H5' *) { x = 5.7588; y = 8.6625; z = -3.8259 }, (* H5'' *) { x = 6.4970; y = 7.1480; z = -2.5980 }, (* C4' *) { x = 7.4896; y = 7.5919; z = -2.5214 }, (* H4' *) { x = 6.1630; y = 6.4860; z = -1.3440 }, (* O4' *) { x = 6.5400; y = 5.1200; z = -1.4190 }, (* C1' *) { x = 7.2763; y = 4.9681; z = -0.6297 }, (* H1' *) { x = 7.1940; y = 4.8830; z = -2.7770 }, (* C2' *) { x = 6.8667; y = 3.9183; z = -3.1647 }, (* H2'' *) { x = 8.5860; y = 5.0910; z = -2.6140 }, (* O2' *) { x = 8.9510; y = 4.7626; z = -1.7890 }, (* H2' *) { x = 6.5720; y = 6.0040; z = -3.6090 }, (* C3' *) { x = 5.5636; y = 5.7066; z = -3.8966 }, (* H3' *) { x = 7.3801; y = 6.3562; z = -4.7350 }, (* O3' *) { x = 4.7150; y = 0.4910; z = -0.1360 }, (* N1 *) { x = 6.3490; y = 2.1730; z = -0.6020 }, (* N3 *) { x = 5.9530; y = 0.9650; z = -0.2670 }, (* C2 *) { x = 5.2900; y = 2.9790; z = -0.8260 }, (* C4 *) { x = 3.9720; y = 2.6390; z = -0.7330 }, (* C5 *) { x = 3.6770; y = 1.3160; z = -0.3660 }, (* C6 *) (G ( { x = 6.8426; y = 0.0056; z = -0.0019 }, (* N2 *) { x = 3.1660; y = 3.7290; z = -1.0360 }, (* N7 *) { x = 5.3170; y = 4.2990; z = -1.1930 }, (* N9 *) { x = 4.0100; y = 4.6780; z = -1.2990 }, (* C8 *) { x = 2.4280; y = 0.8450; z = -0.2360 }, (* O6 *) { x = 4.6151; y = -0.4677; z = 0.1305 }, (* H1 *) { x = 6.6463; y = -0.9463; z = 0.2729 }, (* H21 *) { x = 7.8170; y = 0.2642; z = -0.0640 }, (* H22 *) { x = 3.4421; y = 5.5744; z = -1.5482 }) (* H8 *) ) ) let rG01 = N( { a= -0.0043; b= -0.8175; c=0.5759; (* dgf_base_tfo *) d=0.2617; e= -0.5567; f= -0.7884; g=0.9651; h=0.1473; i=0.2164; tx=0.0359; ty=8.3929; tz=0.5532 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 5.4352; y = 8.2183; z = -2.7757 }, (* C5' *) { x = 5.3830; y = 8.7883; z = -1.8481 }, (* H5' *) { x = 5.7729; y = 8.7436; z = -3.6691 }, (* H5'' *) { x = 6.4830; y = 7.1518; z = -2.5252 }, (* C4' *) { x = 7.4749; y = 7.5972; z = -2.4482 }, (* H4' *) { x = 6.1626; y = 6.4620; z = -1.2827 }, (* O4' *) { x = 6.5431; y = 5.0992; z = -1.3905 }, (* C1' *) { x = 7.2871; y = 4.9328; z = -0.6114 }, (* H1' *) { x = 7.1852; y = 4.8935; z = -2.7592 }, (* C2' *) { x = 6.8573; y = 3.9363; z = -3.1645 }, (* H2'' *) { x = 8.5780; y = 5.1025; z = -2.6046 }, (* O2' *) { x = 8.9516; y = 4.7577; z = -1.7902 }, (* H2' *) { x = 6.5522; y = 6.0300; z = -3.5612 }, (* C3' *) { x = 5.5420; y = 5.7356; z = -3.8459 }, (* H3' *) { x = 7.3487; y = 6.4089; z = -4.6867 }, (* O3' *) { x = 4.7442; y = 0.4514; z = -0.1390 }, (* N1 *) { x = 6.3687; y = 2.1459; z = -0.5926 }, (* N3 *) { x = 5.9795; y = 0.9335; z = -0.2657 }, (* C2 *) { x = 5.3052; y = 2.9471; z = -0.8125 }, (* C4 *) { x = 3.9891; y = 2.5987; z = -0.7230 }, (* C5 *) { x = 3.7016; y = 1.2717; z = -0.3647 }, (* C6 *) (G ( { x = 6.8745; y = -0.0224; z = -0.0058 }, (* N2 *) { x = 3.1770; y = 3.6859; z = -1.0198 }, (* N7 *) { x = 5.3247; y = 4.2695; z = -1.1710 }, (* N9 *) { x = 4.0156; y = 4.6415; z = -1.2759 }, (* C8 *) { x = 2.4553; y = 0.7925; z = -0.2390 }, (* O6 *) { x = 4.6497; y = -0.5095; z = 0.1212 }, (* H1 *) { x = 6.6836; y = -0.9771; z = 0.2627 }, (* H21 *) { x = 7.8474; y = 0.2424; z = -0.0653 }, (* H22 *) { x = 3.4426; y = 5.5361; z = -1.5199 }) (* H8 *) ) ) let rG02 = N( { a=0.5566; b=0.0449; c=0.8296; (* dgf_base_tfo *) d=0.5125; e=0.7673; f= -0.3854; g= -0.6538; h=0.6397; i=0.4041; tx= -9.1161; ty= -3.7679; tz= -2.9968 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 4.5778; y = 6.6594; z = -4.0364 }, (* C5' *) { x = 4.9220; y = 7.1963; z = -4.9204 }, (* H5' *) { x = 3.7996; y = 5.9091; z = -4.1764 }, (* H5'' *) { x = 5.7873; y = 5.8869; z = -3.5482 }, (* C4' *) { x = 6.0405; y = 5.0875; z = -4.2446 }, (* H4' *) { x = 6.9135; y = 6.8036; z = -3.4310 }, (* O4' *) { x = 7.7293; y = 6.4084; z = -2.3392 }, (* C1' *) { x = 8.7078; y = 6.1815; z = -2.7624 }, (* H1' *) { x = 7.1305; y = 5.1418; z = -1.7347 }, (* C2' *) { x = 7.2040; y = 5.1982; z = -0.6486 }, (* H2'' *) { x = 7.7417; y = 4.0392; z = -2.3813 }, (* O2' *) { x = 8.6785; y = 4.1443; z = -2.5630 }, (* H2' *) { x = 5.6666; y = 5.2728; z = -2.1536 }, (* C3' *) { x = 5.1747; y = 5.9805; z = -1.4863 }, (* H3' *) { x = 4.9997; y = 4.0086; z = -2.1973 }, (* O3' *) { x = 10.3245; y = 8.5459; z = 1.5467 }, (* N1 *) { x = 9.8051; y = 6.9432; z = -0.1497 }, (* N3 *) { x = 10.5175; y = 7.4328; z = 0.8408 }, (* C2 *) { x = 8.7523; y = 7.7422; z = -0.4228 }, (* C4 *) { x = 8.4257; y = 8.9060; z = 0.2099 }, (* C5 *) { x = 9.2665; y = 9.3242; z = 1.2540 }, (* C6 *) (G ( { x = 11.6077; y = 6.7966; z = 1.2752 }, (* N2 *) { x = 7.2750; y = 9.4537; z = -0.3428 }, (* N7 *) { x = 7.7962; y = 7.5519; z = -1.3859 }, (* N9 *) { x = 6.9479; y = 8.6157; z = -1.2771 }, (* C8 *) { x = 9.0664; y = 10.4462; z = 1.9610 }, (* O6 *) { x = 10.9838; y = 8.7524; z = 2.2697 }, (* H1 *) { x = 12.2274; y = 7.0896; z = 2.0170 }, (* H21 *) { x = 11.8502; y = 5.9398; z = 0.7984 }, (* H22 *) { x = 6.0430; y = 8.9853; z = -1.7594 }) (* H8 *) ) ) let rG03 = N( { a= -0.5021; b=0.0731; c=0.8617; (* dgf_base_tfo *) d= -0.8112; e=0.3054; f= -0.4986; g= -0.2996; h= -0.9494; i= -0.0940; tx=6.4273; ty= -5.1944; tz= -3.7807 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 4.1214; y = 6.7116; z = -1.9049 }, (* C5' *) { x = 3.3465; y = 5.9610; z = -2.0607 }, (* H5' *) { x = 4.0789; y = 7.2928; z = -0.9837 }, (* H5'' *) { x = 5.4170; y = 5.9293; z = -1.8186 }, (* C4' *) { x = 5.4506; y = 5.3400; z = -0.9023 }, (* H4' *) { x = 5.5067; y = 5.0417; z = -2.9703 }, (* O4' *) { x = 6.8650; y = 4.9152; z = -3.3612 }, (* C1' *) { x = 7.1090; y = 3.8577; z = -3.2603 }, (* H1' *) { x = 7.7152; y = 5.7282; z = -2.3894 }, (* C2' *) { x = 8.5029; y = 6.2356; z = -2.9463 }, (* H2'' *) { x = 8.1036; y = 4.8568; z = -1.3419 }, (* O2' *) { x = 8.3270; y = 3.9651; z = -1.6184 }, (* H2' *) { x = 6.7003; y = 6.7565; z = -1.8911 }, (* C3' *) { x = 6.5898; y = 7.5329; z = -2.6482 }, (* H3' *) { x = 7.0505; y = 7.2878; z = -0.6105 }, (* O3' *) { x = 9.6740; y = 4.7656; z = -7.6614 }, (* N1 *) { x = 9.0739; y = 4.3013; z = -5.3941 }, (* N3 *) { x = 9.8416; y = 4.2192; z = -6.4581 }, (* C2 *) { x = 7.9885; y = 5.0632; z = -5.6446 }, (* C4 *) { x = 7.6822; y = 5.6856; z = -6.8194 }, (* C5 *) { x = 8.5831; y = 5.5215; z = -7.8840 }, (* C6 *) (G ( { x = 10.9733; y = 3.5117; z = -6.4286 }, (* N2 *) { x = 6.4857; y = 6.3816; z = -6.7035 }, (* N7 *) { x = 6.9740; y = 5.3703; z = -4.7760 }, (* N9 *) { x = 6.1133; y = 6.1613; z = -5.4808 }, (* C8 *) { x = 8.4084; y = 6.0747; z = -9.0933 }, (* O6 *) { x = 10.3759; y = 4.5855; z = -8.3504 }, (* H1 *) { x = 11.6254; y = 3.3761; z = -7.1879 }, (* H21 *) { x = 11.1917; y = 3.0460; z = -5.5593 }, (* H22 *) { x = 5.1705; y = 6.6830; z = -5.3167 }) (* H8 *) ) ) let rG04 = N( { a= -0.5426; b= -0.8175; c=0.1929; (* dgf_base_tfo *) d=0.8304; e= -0.5567; f= -0.0237; g=0.1267; h=0.1473; i=0.9809; tx= -0.5075; ty=8.3929; tz=0.2229 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 5.4352; y = 8.2183; z = -2.7757 }, (* C5' *) { x = 5.3830; y = 8.7883; z = -1.8481 }, (* H5' *) { x = 5.7729; y = 8.7436; z = -3.6691 }, (* H5'' *) { x = 6.4830; y = 7.1518; z = -2.5252 }, (* C4' *) { x = 7.4749; y = 7.5972; z = -2.4482 }, (* H4' *) { x = 6.1626; y = 6.4620; z = -1.2827 }, (* O4' *) { x = 6.5431; y = 5.0992; z = -1.3905 }, (* C1' *) { x = 7.2871; y = 4.9328; z = -0.6114 }, (* H1' *) { x = 7.1852; y = 4.8935; z = -2.7592 }, (* C2' *) { x = 6.8573; y = 3.9363; z = -3.1645 }, (* H2'' *) { x = 8.5780; y = 5.1025; z = -2.6046 }, (* O2' *) { x = 8.9516; y = 4.7577; z = -1.7902 }, (* H2' *) { x = 6.5522; y = 6.0300; z = -3.5612 }, (* C3' *) { x = 5.5420; y = 5.7356; z = -3.8459 }, (* H3' *) { x = 7.3487; y = 6.4089; z = -4.6867 }, (* O3' *) { x = 3.6343; y = 2.6680; z = 2.0783 }, (* N1 *) { x = 5.4505; y = 3.9805; z = 1.2446 }, (* N3 *) { x = 4.7540; y = 3.3816; z = 2.1851 }, (* C2 *) { x = 4.8805; y = 3.7951; z = 0.0354 }, (* C4 *) { x = 3.7416; y = 3.0925; z = -0.2305 }, (* C5 *) { x = 3.0873; y = 2.4980; z = 0.8606 }, (* C6 *) (G ( { x = 5.1433; y = 3.4373; z = 3.4609 }, (* N2 *) { x = 3.4605; y = 3.1184; z = -1.5906 }, (* N7 *) { x = 5.3247; y = 4.2695; z = -1.1710 }, (* N9 *) { x = 4.4244; y = 3.8244; z = -2.0953 }, (* C8 *) { x = 1.9600; y = 1.7805; z = 0.7462 }, (* O6 *) { x = 3.2489; y = 2.2879; z = 2.9191 }, (* H1 *) { x = 4.6785; y = 3.0243; z = 4.2568 }, (* H21 *) { x = 5.9823; y = 3.9654; z = 3.6539 }, (* H22 *) { x = 4.2675; y = 3.8876; z = -3.1721 }) (* H8 *) ) ) let rG05 = N( { a= -0.5891; b=0.0449; c=0.8068; (* dgf_base_tfo *) d=0.5375; e=0.7673; f=0.3498; g= -0.6034; h=0.6397; i= -0.4762; tx= -0.3019; ty= -3.7679; tz= -9.5913 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 4.5778; y = 6.6594; z = -4.0364 }, (* C5' *) { x = 4.9220; y = 7.1963; z = -4.9204 }, (* H5' *) { x = 3.7996; y = 5.9091; z = -4.1764 }, (* H5'' *) { x = 5.7873; y = 5.8869; z = -3.5482 }, (* C4' *) { x = 6.0405; y = 5.0875; z = -4.2446 }, (* H4' *) { x = 6.9135; y = 6.8036; z = -3.4310 }, (* O4' *) { x = 7.7293; y = 6.4084; z = -2.3392 }, (* C1' *) { x = 8.7078; y = 6.1815; z = -2.7624 }, (* H1' *) { x = 7.1305; y = 5.1418; z = -1.7347 }, (* C2' *) { x = 7.2040; y = 5.1982; z = -0.6486 }, (* H2'' *) { x = 7.7417; y = 4.0392; z = -2.3813 }, (* O2' *) { x = 8.6785; y = 4.1443; z = -2.5630 }, (* H2' *) { x = 5.6666; y = 5.2728; z = -2.1536 }, (* C3' *) { x = 5.1747; y = 5.9805; z = -1.4863 }, (* H3' *) { x = 4.9997; y = 4.0086; z = -2.1973 }, (* O3' *) { x = 10.2594; y = 10.6774; z = -1.0056 }, (* N1 *) { x = 9.7528; y = 8.7080; z = -2.2631 }, (* N3 *) { x = 10.4471; y = 9.7876; z = -1.9791 }, (* C2 *) { x = 8.7271; y = 8.5575; z = -1.3991 }, (* C4 *) { x = 8.4100; y = 9.3803; z = -0.3580 }, (* C5 *) { x = 9.2294; y = 10.5030; z = -0.1574 }, (* C6 *) (G ( { x = 11.5110; y = 10.1256; z = -2.7114 }, (* N2 *) { x = 7.2891; y = 8.9068; z = 0.3121 }, (* N7 *) { x = 7.7962; y = 7.5519; z = -1.3859 }, (* N9 *) { x = 6.9702; y = 7.8292; z = -0.3353 }, (* C8 *) { x = 9.0349; y = 11.3951; z = 0.8250 }, (* O6 *) { x = 10.9013; y = 11.4422; z = -0.9512 }, (* H1 *) { x = 12.1031; y = 10.9341; z = -2.5861 }, (* H21 *) { x = 11.7369; y = 9.5180; z = -3.4859 }, (* H22 *) { x = 6.0888; y = 7.3990; z = 0.1403 }) (* H8 *) ) ) let rG06 = N( { a= -0.9815; b=0.0731; c= -0.1772; (* dgf_base_tfo *) d=0.1912; e=0.3054; f= -0.9328; g= -0.0141; h= -0.9494; i= -0.3137; tx=5.7506; ty= -5.1944; tz=4.7470 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 4.1214; y = 6.7116; z = -1.9049 }, (* C5' *) { x = 3.3465; y = 5.9610; z = -2.0607 }, (* H5' *) { x = 4.0789; y = 7.2928; z = -0.9837 }, (* H5'' *) { x = 5.4170; y = 5.9293; z = -1.8186 }, (* C4' *) { x = 5.4506; y = 5.3400; z = -0.9023 }, (* H4' *) { x = 5.5067; y = 5.0417; z = -2.9703 }, (* O4' *) { x = 6.8650; y = 4.9152; z = -3.3612 }, (* C1' *) { x = 7.1090; y = 3.8577; z = -3.2603 }, (* H1' *) { x = 7.7152; y = 5.7282; z = -2.3894 }, (* C2' *) { x = 8.5029; y = 6.2356; z = -2.9463 }, (* H2'' *) { x = 8.1036; y = 4.8568; z = -1.3419 }, (* O2' *) { x = 8.3270; y = 3.9651; z = -1.6184 }, (* H2' *) { x = 6.7003; y = 6.7565; z = -1.8911 }, (* C3' *) { x = 6.5898; y = 7.5329; z = -2.6482 }, (* H3' *) { x = 7.0505; y = 7.2878; z = -0.6105 }, (* O3' *) { x = 6.6624; y = 3.5061; z = -8.2986 }, (* N1 *) { x = 6.5810; y = 3.2570; z = -5.9221 }, (* N3 *) { x = 6.5151; y = 2.8263; z = -7.1625 }, (* C2 *) { x = 6.8364; y = 4.5817; z = -5.8882 }, (* C4 *) { x = 7.0116; y = 5.4064; z = -6.9609 }, (* C5 *) { x = 6.9173; y = 4.8260; z = -8.2361 }, (* C6 *) (G ( { x = 6.2717; y = 1.5402; z = -7.4250 }, (* N2 *) { x = 7.2573; y = 6.7070; z = -6.5394 }, (* N7 *) { x = 6.9740; y = 5.3703; z = -4.7760 }, (* N9 *) { x = 7.2238; y = 6.6275; z = -5.2453 }, (* C8 *) { x = 7.0668; y = 5.5163; z = -9.3763 }, (* O6 *) { x = 6.5754; y = 2.9964; z = -9.1545 }, (* H1 *) { x = 6.1908; y = 1.1105; z = -8.3354 }, (* H21 *) { x = 6.1346; y = 0.9352; z = -6.6280 }, (* H22 *) { x = 7.4108; y = 7.6227; z = -4.8418 }) (* H8 *) ) ) let rG07 = N( { a=0.0894; b= -0.6059; c=0.7905; (* dgf_base_tfo *) d= -0.6810; e=0.5420; f=0.4924; g= -0.7268; h= -0.5824; i= -0.3642; tx=34.1424; ty=45.9610; tz= -11.8600 }, { a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *) d= -0.0427; e=0.2409; f= -0.9696; g=0.5010; h= -0.8345; i= -0.2294; tx=4.0167; ty=54.5377; tz=12.4779 }, { a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *) d= -0.2867; e= -0.7872; f= -0.5460; g=0.8834; h=0.0032; i= -0.4686; tx= -52.9020; ty=18.6313; tz= -0.6709 }, { a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *) d=0.9040; e= -0.4236; f= -0.0582; g= -0.1007; h= -0.0786; i= -0.9918; tx= -7.6624; ty= -25.2080; tz=49.5181 }, { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P *) { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P *) { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P *) { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5' *) { x = 33.8709; y = 0.7918; z = 47.2113 }, (* C5' *) { x = 34.1386; y = 0.5870; z = 46.1747 }, (* H5' *) { x = 34.0186; y = -0.0095; z = 47.9353 }, (* H5'' *) { x = 34.7297; y = 1.9687; z = 47.6685 }, (* C4' *) { x = 35.7723; y = 1.6845; z = 47.8113 }, (* H4' *) { x = 34.6455; y = 2.9768; z = 46.6660 }, (* O4' *) { x = 34.1690; y = 4.1829; z = 47.2627 }, (* C1' *) { x = 35.0437; y = 4.7633; z = 47.5560 }, (* H1' *) { x = 33.4145; y = 3.7532; z = 48.4954 }, (* C2' *) { x = 32.4340; y = 3.3797; z = 48.2001 }, (* H2'' *) { x = 33.3209; y = 4.6953; z = 49.5217 }, (* O2' *) { x = 33.2374; y = 5.6059; z = 49.2295 }, (* H2' *) { x = 34.2724; y = 2.5970; z = 48.9773 }, (* C3' *) { x = 33.6373; y = 1.8935; z = 49.5157 }, (* H3' *) { x = 35.3453; y = 3.1884; z = 49.7285 }, (* O3' *) { x = 34.0511; y = 7.8930; z = 43.7791 }, (* N1 *) { x = 34.9937; y = 6.3369; z = 45.3199 }, (* N3 *) { x = 35.0882; y = 7.3126; z = 44.4200 }, (* C2 *) { x = 33.7190; y = 5.9650; z = 45.5374 }, (* C4 *) { x = 32.5845; y = 6.4770; z = 44.9458 }, (* C5 *) { x = 32.7430; y = 7.5179; z = 43.9914 }, (* C6 *) (G ( { x = 36.3030; y = 7.7827; z = 44.1036 }, (* N2 *) { x = 31.4499; y = 5.8335; z = 45.4368 }, (* N7 *) { x = 33.2760; y = 4.9817; z = 46.4043 }, (* N9 *) { x = 31.9235; y = 4.9639; z = 46.2934 }, (* C8 *) { x = 31.8602; y = 8.1000; z = 43.3695 }, (* O6 *) { x = 34.2623; y = 8.6223; z = 43.1283 }, (* H1 *) { x = 36.5188; y = 8.5081; z = 43.4347 }, (* H21 *) { x = 37.0888; y = 7.3524; z = 44.5699 }, (* H22 *) { x = 31.0815; y = 4.4201; z = 46.7218 }) (* H8 *) ) ) let rG08 = N( { a=0.2224; b=0.6335; c=0.7411; (* dgf_base_tfo *) d= -0.3644; e= -0.6510; f=0.6659; g=0.9043; h= -0.4181; i=0.0861; tx= -47.6824; ty= -0.5823; tz= -31.7554 }, { a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *) d= -0.0427; e=0.2409; f= -0.9696; g=0.5010; h= -0.8345; i= -0.2294; tx=4.0167; ty=54.5377; tz=12.4779 }, { a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *) d= -0.2867; e= -0.7872; f= -0.5460; g=0.8834; h=0.0032; i= -0.4686; tx= -52.9020; ty=18.6313; tz= -0.6709 }, { a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *) d=0.9040; e= -0.4236; f= -0.0582; g= -0.1007; h= -0.0786; i= -0.9918; tx= -7.6624; ty= -25.2080; tz=49.5181 }, { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P *) { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P *) { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P *) { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5' *) { x = 32.5924; y = 2.3488; z = 48.2255 }, (* C5' *) { x = 33.3674; y = 2.1246; z = 48.9584 }, (* H5' *) { x = 31.5994; y = 2.5917; z = 48.6037 }, (* H5'' *) { x = 33.0722; y = 3.5577; z = 47.4258 }, (* C4' *) { x = 33.0310; y = 4.4778; z = 48.0089 }, (* H4' *) { x = 34.4173; y = 3.3055; z = 47.0316 }, (* O4' *) { x = 34.5056; y = 3.3910; z = 45.6094 }, (* C1' *) { x = 34.7881; y = 4.4152; z = 45.3663 }, (* H1' *) { x = 33.1122; y = 3.1198; z = 45.1010 }, (* C2' *) { x = 32.9230; y = 2.0469; z = 45.1369 }, (* H2'' *) { x = 32.7946; y = 3.6590; z = 43.8529 }, (* O2' *) { x = 33.5170; y = 3.6707; z = 43.2207 }, (* H2' *) { x = 32.2730; y = 3.8173; z = 46.1566 }, (* C3' *) { x = 31.3094; y = 3.3123; z = 46.2244 }, (* H3' *) { x = 32.2391; y = 5.2039; z = 45.7807 }, (* O3' *) { x = 39.3337; y = 2.7157; z = 44.1441 }, (* N1 *) { x = 37.4430; y = 3.8242; z = 45.0824 }, (* N3 *) { x = 38.7276; y = 3.7646; z = 44.7403 }, (* C2 *) { x = 36.7791; y = 2.6963; z = 44.7704 }, (* C4 *) { x = 37.2860; y = 1.5653; z = 44.1678 }, (* C5 *) { x = 38.6647; y = 1.5552; z = 43.8235 }, (* C6 *) (G ( { x = 39.5123; y = 4.8216; z = 44.9936 }, (* N2 *) { x = 36.2829; y = 0.6110; z = 44.0078 }, (* N7 *) { x = 35.4394; y = 2.4314; z = 44.9931 }, (* N9 *) { x = 35.2180; y = 1.1815; z = 44.5128 }, (* C8 *) { x = 39.2907; y = 0.6514; z = 43.2796 }, (* O6 *) { x = 40.3076; y = 2.8048; z = 43.9352 }, (* H1 *) { x = 40.4994; y = 4.9066; z = 44.7977 }, (* H21 *) { x = 39.0738; y = 5.6108; z = 45.4464 }, (* H22 *) { x = 34.3856; y = 0.4842; z = 44.4185 }) (* H8 *) ) ) let rG09 = N( { a= -0.9699; b= -0.1688; c= -0.1753; (* dgf_base_tfo *) d= -0.1050; e= -0.3598; f=0.9271; g= -0.2196; h=0.9176; i=0.3312; tx=45.6217; ty= -38.9484; tz= -12.3208 }, { a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *) d= -0.0427; e=0.2409; f= -0.9696; g=0.5010; h= -0.8345; i= -0.2294; tx=4.0167; ty=54.5377; tz=12.4779 }, { a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *) d= -0.2867; e= -0.7872; f= -0.5460; g=0.8834; h=0.0032; i= -0.4686; tx= -52.9020; ty=18.6313; tz= -0.6709 }, { a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *) d=0.9040; e= -0.4236; f= -0.0582; g= -0.1007; h= -0.0786; i= -0.9918; tx= -7.6624; ty= -25.2080; tz=49.5181 }, { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P *) { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P *) { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P *) { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5' *) { x = 33.8709; y = 0.7918; z = 47.2113 }, (* C5' *) { x = 34.1386; y = 0.5870; z = 46.1747 }, (* H5' *) { x = 34.0186; y = -0.0095; z = 47.9353 }, (* H5'' *) { x = 34.7297; y = 1.9687; z = 47.6685 }, (* C4' *) { x = 34.5880; y = 2.8482; z = 47.0404 }, (* H4' *) { x = 34.3575; y = 2.2770; z = 49.0081 }, (* O4' *) { x = 35.5157; y = 2.1993; z = 49.8389 }, (* C1' *) { x = 35.9424; y = 3.2010; z = 49.8893 }, (* H1' *) { x = 36.4701; y = 1.2820; z = 49.1169 }, (* C2' *) { x = 36.1545; y = 0.2498; z = 49.2683 }, (* H2'' *) { x = 37.8262; y = 1.4547; z = 49.4008 }, (* O2' *) { x = 38.0227; y = 1.6945; z = 50.3094 }, (* H2' *) { x = 36.2242; y = 1.6797; z = 47.6725 }, (* C3' *) { x = 36.4297; y = 0.8197; z = 47.0351 }, (* H3' *) { x = 37.0289; y = 2.8480; z = 47.4426 }, (* O3' *) { x = 34.3005; y = 3.5042; z = 54.6070 }, (* N1 *) { x = 34.7693; y = 3.7936; z = 52.2874 }, (* N3 *) { x = 34.4484; y = 4.2541; z = 53.4939 }, (* C2 *) { x = 34.9354; y = 2.4584; z = 52.2785 }, (* C4 *) { x = 34.8092; y = 1.5915; z = 53.3422 }, (* C5 *) { x = 34.4646; y = 2.1367; z = 54.6085 }, (* C6 *) (G ( { x = 34.2514; y = 5.5708; z = 53.6503 }, (* N2 *) { x = 35.0641; y = 0.2835; z = 52.9337 }, (* N7 *) { x = 35.2669; y = 1.6690; z = 51.1915 }, (* N9 *) { x = 35.3288; y = 0.3954; z = 51.6563 }, (* C8 *) { x = 34.3151; y = 1.5317; z = 55.6650 }, (* O6 *) { x = 34.0623; y = 3.9797; z = 55.4539 }, (* H1 *) { x = 33.9950; y = 6.0502; z = 54.5016 }, (* H21 *) { x = 34.3512; y = 6.1432; z = 52.8242 }, (* H22 *) { x = 35.5414; y = -0.6006; z = 51.2679 }) (* H8 *) ) ) let rG10 = N( { a= -0.0980; b= -0.9723; c=0.2122; (* dgf_base_tfo *) d= -0.9731; e=0.1383; f=0.1841; g= -0.2083; h= -0.1885; i= -0.9597; tx=17.8469; ty=38.8265; tz=37.0475 }, { a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *) d= -0.0427; e=0.2409; f= -0.9696; g=0.5010; h= -0.8345; i= -0.2294; tx=4.0167; ty=54.5377; tz=12.4779 }, { a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *) d= -0.2867; e= -0.7872; f= -0.5460; g=0.8834; h=0.0032; i= -0.4686; tx= -52.9020; ty=18.6313; tz= -0.6709 }, { a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *) d=0.9040; e= -0.4236; f= -0.0582; g= -0.1007; h= -0.0786; i= -0.9918; tx= -7.6624; ty= -25.2080; tz=49.5181 }, { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P *) { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P *) { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P *) { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5' *) { x = 32.5924; y = 2.3488; z = 48.2255 }, (* C5' *) { x = 33.3674; y = 2.1246; z = 48.9584 }, (* H5' *) { x = 31.5994; y = 2.5917; z = 48.6037 }, (* H5'' *) { x = 33.0722; y = 3.5577; z = 47.4258 }, (* C4' *) { x = 34.0333; y = 3.3761; z = 46.9447 }, (* H4' *) { x = 32.0890; y = 3.8338; z = 46.4332 }, (* O4' *) { x = 31.6377; y = 5.1787; z = 46.5914 }, (* C1' *) { x = 32.2499; y = 5.8016; z = 45.9392 }, (* H1' *) { x = 31.9167; y = 5.5319; z = 48.0305 }, (* C2' *) { x = 31.1507; y = 5.0820; z = 48.6621 }, (* H2'' *) { x = 32.0865; y = 6.8890; z = 48.3114 }, (* O2' *) { x = 31.5363; y = 7.4819; z = 47.7942 }, (* H2' *) { x = 33.2398; y = 4.8224; z = 48.2563 }, (* C3' *) { x = 33.3166; y = 4.5570; z = 49.3108 }, (* H3' *) { x = 34.2528; y = 5.7056; z = 47.7476 }, (* O3' *) { x = 28.2782; y = 6.3049; z = 42.9364 }, (* N1 *) { x = 30.4001; y = 5.8547; z = 43.9258 }, (* N3 *) { x = 29.6195; y = 6.1568; z = 42.8913 }, (* C2 *) { x = 29.7005; y = 5.7006; z = 45.0649 }, (* C4 *) { x = 28.3383; y = 5.8221; z = 45.2343 }, (* C5 *) { x = 27.5519; y = 6.1461; z = 44.0958 }, (* C6 *) (G ( { x = 30.1838; y = 6.3385; z = 41.6890 }, (* N2 *) { x = 27.9936; y = 5.5926; z = 46.5651 }, (* N7 *) { x = 30.2046; y = 5.3825; z = 46.3136 }, (* N9 *) { x = 29.1371; y = 5.3398; z = 47.1506 }, (* C8 *) { x = 26.3361; y = 6.3024; z = 44.0495 }, (* O6 *) { x = 27.8122; y = 6.5394; z = 42.0833 }, (* H1 *) { x = 29.7125; y = 6.5595; z = 40.8235 }, (* H21 *) { x = 31.1859; y = 6.2231; z = 41.6389 }, (* H22 *) { x = 28.9406; y = 5.1504; z = 48.2059 }) (* H8 *) ) ) let rGs = [rG01;rG02;rG03;rG04;rG05;rG06;rG07;rG08;rG09;rG10] let rU = N( { a= -0.0359; b= -0.8071; c=0.5894; (* dgf_base_tfo *) d= -0.2669; e=0.5761; f=0.7726; g= -0.9631; h= -0.1296; i= -0.2361; tx=0.1584; ty=8.3434; tz=0.5434 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 5.2430; y = -8.2420; z = 2.8260 }, (* C5' *) { x = 5.1974; y = -8.8497; z = 1.9223 }, (* H5' *) { x = 5.5548; y = -8.7348; z = 3.7469 }, (* H5'' *) { x = 6.3140; y = -7.2060; z = 2.5510 }, (* C4' *) { x = 7.2954; y = -7.6762; z = 2.4898 }, (* H4' *) { x = 6.0140; y = -6.5420; z = 1.2890 }, (* O4' *) { x = 6.4190; y = -5.1840; z = 1.3620 }, (* C1' *) { x = 7.1608; y = -5.0495; z = 0.5747 }, (* H1' *) { x = 7.0760; y = -4.9560; z = 2.7270 }, (* C2' *) { x = 6.7770; y = -3.9803; z = 3.1099 }, (* H2'' *) { x = 8.4500; y = -5.1930; z = 2.5810 }, (* O2' *) { x = 8.8309; y = -4.8755; z = 1.7590 }, (* H2' *) { x = 6.4060; y = -6.0590; z = 3.5580 }, (* C3' *) { x = 5.4021; y = -5.7313; z = 3.8281 }, (* H3' *) { x = 7.1570; y = -6.4240; z = 4.7070 }, (* O3' *) { x = 5.2170; y = -4.3260; z = 1.1690 }, (* N1 *) { x = 4.2960; y = -2.2560; z = 0.6290 }, (* N3 *) { x = 5.4330; y = -3.0200; z = 0.7990 }, (* C2 *) { x = 2.9930; y = -2.6780; z = 0.7940 }, (* C4 *) { x = 2.8670; y = -4.0630; z = 1.1830 }, (* C5 *) { x = 3.9570; y = -4.8300; z = 1.3550 }, (* C6 *) (U ( { x = 6.5470; y = -2.5560; z = 0.6290 }, (* O2 *) { x = 2.0540; y = -1.9000; z = 0.6130 }, (* O4 *) { x = 4.4300; y = -1.3020; z = 0.3600 }, (* H3 *) { x = 1.9590; y = -4.4570; z = 1.3250 }, (* H5 *) { x = 3.8460; y = -5.7860; z = 1.6240 }) (* H6 *) ) ) let rU01 = N( { a= -0.0137; b= -0.8012; c=0.5983; (* dgf_base_tfo *) d= -0.2523; e=0.5817; f=0.7733; g= -0.9675; h= -0.1404; i= -0.2101; tx=0.2031; ty=8.3874; tz=0.4228 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 5.2416; y = -8.2422; z = 2.8181 }, (* C5' *) { x = 5.2050; y = -8.8128; z = 1.8901 }, (* H5' *) { x = 5.5368; y = -8.7738; z = 3.7227 }, (* H5'' *) { x = 6.3232; y = -7.2037; z = 2.6002 }, (* C4' *) { x = 7.3048; y = -7.6757; z = 2.5577 }, (* H4' *) { x = 6.0635; y = -6.5092; z = 1.3456 }, (* O4' *) { x = 6.4697; y = -5.1547; z = 1.4629 }, (* C1' *) { x = 7.2354; y = -5.0043; z = 0.7018 }, (* H1' *) { x = 7.0856; y = -4.9610; z = 2.8521 }, (* C2' *) { x = 6.7777; y = -3.9935; z = 3.2487 }, (* H2'' *) { x = 8.4627; y = -5.1992; z = 2.7423 }, (* O2' *) { x = 8.8693; y = -4.8638; z = 1.9399 }, (* H2' *) { x = 6.3877; y = -6.0809; z = 3.6362 }, (* C3' *) { x = 5.3770; y = -5.7562; z = 3.8834 }, (* H3' *) { x = 7.1024; y = -6.4754; z = 4.7985 }, (* O3' *) { x = 5.2764; y = -4.2883; z = 1.2538 }, (* N1 *) { x = 4.3777; y = -2.2062; z = 0.7229 }, (* N3 *) { x = 5.5069; y = -2.9779; z = 0.9088 }, (* C2 *) { x = 3.0693; y = -2.6246; z = 0.8500 }, (* C4 *) { x = 2.9279; y = -4.0146; z = 1.2149 }, (* C5 *) { x = 4.0101; y = -4.7892; z = 1.4017 }, (* C6 *) (U ( { x = 6.6267; y = -2.5166; z = 0.7728 }, (* O2 *) { x = 2.1383; y = -1.8396; z = 0.6581 }, (* O4 *) { x = 4.5223; y = -1.2489; z = 0.4716 }, (* H3 *) { x = 2.0151; y = -4.4065; z = 1.3290 }, (* H5 *) { x = 3.8886; y = -5.7486; z = 1.6535 }) (* H6 *) ) ) let rU02 = N( { a=0.5141; b=0.0246; c=0.8574; (* dgf_base_tfo *) d= -0.5547; e= -0.7529; f=0.3542; g=0.6542; h= -0.6577; i= -0.3734; tx= -9.1111; ty= -3.4598; tz= -3.2939 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 4.3825; y = -6.6585; z = 4.0489 }, (* C5' *) { x = 4.6841; y = -7.2019; z = 4.9443 }, (* H5' *) { x = 3.6189; y = -5.8889; z = 4.1625 }, (* H5'' *) { x = 5.6255; y = -5.9175; z = 3.5998 }, (* C4' *) { x = 5.8732; y = -5.1228; z = 4.3034 }, (* H4' *) { x = 6.7337; y = -6.8605; z = 3.5222 }, (* O4' *) { x = 7.5932; y = -6.4923; z = 2.4548 }, (* C1' *) { x = 8.5661; y = -6.2983; z = 2.9064 }, (* H1' *) { x = 7.0527; y = -5.2012; z = 1.8322 }, (* C2' *) { x = 7.1627; y = -5.2525; z = 0.7490 }, (* H2'' *) { x = 7.6666; y = -4.1249; z = 2.4880 }, (* O2' *) { x = 8.5944; y = -4.2543; z = 2.6981 }, (* H2' *) { x = 5.5661; y = -5.3029; z = 2.2009 }, (* C3' *) { x = 5.0841; y = -6.0018; z = 1.5172 }, (* H3' *) { x = 4.9062; y = -4.0452; z = 2.2042 }, (* O3' *) { x = 7.6298; y = -7.6136; z = 1.4752 }, (* N1 *) { x = 8.6945; y = -8.7046; z = -0.2857 }, (* N3 *) { x = 8.6943; y = -7.6514; z = 0.6066 }, (* C2 *) { x = 7.7426; y = -9.6987; z = -0.3801 }, (* C4 *) { x = 6.6642; y = -9.5742; z = 0.5722 }, (* C5 *) { x = 6.6391; y = -8.5592; z = 1.4526 }, (* C6 *) (U ( { x = 9.5840; y = -6.8186; z = 0.6136 }, (* O2 *) { x = 7.8505; y = -10.5925; z = -1.2223 }, (* O4 *) { x = 9.4601; y = -8.7514; z = -0.9277 }, (* H3 *) { x = 5.9281; y = -10.2509; z = 0.5782 }, (* H5 *) { x = 5.8831; y = -8.4931; z = 2.1028 }) (* H6 *) ) ) let rU03 = N( { a= -0.4993; b=0.0476; c=0.8651; (* dgf_base_tfo *) d=0.8078; e= -0.3353; f=0.4847; g=0.3132; h=0.9409; i=0.1290; tx=6.2989; ty= -5.2303; tz= -3.8577 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 3.9938; y = -6.7042; z = 1.9023 }, (* C5' *) { x = 3.2332; y = -5.9343; z = 2.0319 }, (* H5' *) { x = 3.9666; y = -7.2863; z = 0.9812 }, (* H5'' *) { x = 5.3098; y = -5.9546; z = 1.8564 }, (* C4' *) { x = 5.3863; y = -5.3702; z = 0.9395 }, (* H4' *) { x = 5.3851; y = -5.0642; z = 3.0076 }, (* O4' *) { x = 6.7315; y = -4.9724; z = 3.4462 }, (* C1' *) { x = 7.0033; y = -3.9202; z = 3.3619 }, (* H1' *) { x = 7.5997; y = -5.8018; z = 2.4948 }, (* C2' *) { x = 8.3627; y = -6.3254; z = 3.0707 }, (* H2'' *) { x = 8.0410; y = -4.9501; z = 1.4724 }, (* O2' *) { x = 8.2781; y = -4.0644; z = 1.7570 }, (* H2' *) { x = 6.5701; y = -6.8129; z = 1.9714 }, (* C3' *) { x = 6.4186; y = -7.5809; z = 2.7299 }, (* H3' *) { x = 6.9357; y = -7.3841; z = 0.7235 }, (* O3' *) { x = 6.8024; y = -5.4718; z = 4.8475 }, (* N1 *) { x = 7.9218; y = -5.5700; z = 6.8877 }, (* N3 *) { x = 7.8908; y = -5.0886; z = 5.5944 }, (* C2 *) { x = 6.9789; y = -6.3827; z = 7.4823 }, (* C4 *) { x = 5.8742; y = -6.7319; z = 6.6202 }, (* C5 *) { x = 5.8182; y = -6.2769; z = 5.3570 }, (* C6 *) (U ( { x = 8.7747; y = -4.3728; z = 5.1568 }, (* O2 *) { x = 7.1154; y = -6.7509; z = 8.6509 }, (* O4 *) { x = 8.7055; y = -5.3037; z = 7.4491 }, (* H3 *) { x = 5.1416; y = -7.3178; z = 6.9665 }, (* H5 *) { x = 5.0441; y = -6.5310; z = 4.7784 }) (* H6 *) ) ) let rU04 = N( { a= -0.5669; b= -0.8012; c=0.1918; (* dgf_base_tfo *) d= -0.8129; e=0.5817; f=0.0273; g= -0.1334; h= -0.1404; i= -0.9811; tx= -0.3279; ty=8.3874; tz=0.3355 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 5.2416; y = -8.2422; z = 2.8181 }, (* C5' *) { x = 5.2050; y = -8.8128; z = 1.8901 }, (* H5' *) { x = 5.5368; y = -8.7738; z = 3.7227 }, (* H5'' *) { x = 6.3232; y = -7.2037; z = 2.6002 }, (* C4' *) { x = 7.3048; y = -7.6757; z = 2.5577 }, (* H4' *) { x = 6.0635; y = -6.5092; z = 1.3456 }, (* O4' *) { x = 6.4697; y = -5.1547; z = 1.4629 }, (* C1' *) { x = 7.2354; y = -5.0043; z = 0.7018 }, (* H1' *) { x = 7.0856; y = -4.9610; z = 2.8521 }, (* C2' *) { x = 6.7777; y = -3.9935; z = 3.2487 }, (* H2'' *) { x = 8.4627; y = -5.1992; z = 2.7423 }, (* O2' *) { x = 8.8693; y = -4.8638; z = 1.9399 }, (* H2' *) { x = 6.3877; y = -6.0809; z = 3.6362 }, (* C3' *) { x = 5.3770; y = -5.7562; z = 3.8834 }, (* H3' *) { x = 7.1024; y = -6.4754; z = 4.7985 }, (* O3' *) { x = 5.2764; y = -4.2883; z = 1.2538 }, (* N1 *) { x = 3.8961; y = -3.0896; z = -0.1893 }, (* N3 *) { x = 5.0095; y = -3.8907; z = -0.0346 }, (* C2 *) { x = 3.0480; y = -2.6632; z = 0.8116 }, (* C4 *) { x = 3.4093; y = -3.1310; z = 2.1292 }, (* C5 *) { x = 4.4878; y = -3.9124; z = 2.3088 }, (* C6 *) (U ( { x = 5.7005; y = -4.2164; z = -0.9842 }, (* O2 *) { x = 2.0800; y = -1.9458; z = 0.5503 }, (* O4 *) { x = 3.6834; y = -2.7882; z = -1.1190 }, (* H3 *) { x = 2.8508; y = -2.8721; z = 2.9172 }, (* H5 *) { x = 4.7188; y = -4.2247; z = 3.2295 }) (* H6 *) ) ) let rU05 = N( { a= -0.6298; b=0.0246; c=0.7763; (* dgf_base_tfo *) d= -0.5226; e= -0.7529; f= -0.4001; g=0.5746; h= -0.6577; i=0.4870; tx= -0.0208; ty= -3.4598; tz= -9.6882 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 4.3825; y = -6.6585; z = 4.0489 }, (* C5' *) { x = 4.6841; y = -7.2019; z = 4.9443 }, (* H5' *) { x = 3.6189; y = -5.8889; z = 4.1625 }, (* H5'' *) { x = 5.6255; y = -5.9175; z = 3.5998 }, (* C4' *) { x = 5.8732; y = -5.1228; z = 4.3034 }, (* H4' *) { x = 6.7337; y = -6.8605; z = 3.5222 }, (* O4' *) { x = 7.5932; y = -6.4923; z = 2.4548 }, (* C1' *) { x = 8.5661; y = -6.2983; z = 2.9064 }, (* H1' *) { x = 7.0527; y = -5.2012; z = 1.8322 }, (* C2' *) { x = 7.1627; y = -5.2525; z = 0.7490 }, (* H2'' *) { x = 7.6666; y = -4.1249; z = 2.4880 }, (* O2' *) { x = 8.5944; y = -4.2543; z = 2.6981 }, (* H2' *) { x = 5.5661; y = -5.3029; z = 2.2009 }, (* C3' *) { x = 5.0841; y = -6.0018; z = 1.5172 }, (* H3' *) { x = 4.9062; y = -4.0452; z = 2.2042 }, (* O3' *) { x = 7.6298; y = -7.6136; z = 1.4752 }, (* N1 *) { x = 8.5977; y = -9.5977; z = 0.7329 }, (* N3 *) { x = 8.5951; y = -8.5745; z = 1.6594 }, (* C2 *) { x = 7.7372; y = -9.7371; z = -0.3364 }, (* C4 *) { x = 6.7596; y = -8.6801; z = -0.4476 }, (* C5 *) { x = 6.7338; y = -7.6721; z = 0.4408 }, (* C6 *) (U ( { x = 9.3993; y = -8.5377; z = 2.5743 }, (* O2 *) { x = 7.8374; y = -10.6990; z = -1.1008 }, (* O4 *) { x = 9.2924; y = -10.3081; z = 0.8477 }, (* H3 *) { x = 6.0932; y = -8.6982; z = -1.1929 }, (* H5 *) { x = 6.0481; y = -6.9515; z = 0.3446 }) (* H6 *) ) ) let rU06 = N( { a= -0.9837; b=0.0476; c= -0.1733; (* dgf_base_tfo *) d= -0.1792; e= -0.3353; f=0.9249; g= -0.0141; h=0.9409; i=0.3384; tx=5.7793; ty= -5.2303; tz=4.5997 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 3.9938; y = -6.7042; z = 1.9023 }, (* C5' *) { x = 3.2332; y = -5.9343; z = 2.0319 }, (* H5' *) { x = 3.9666; y = -7.2863; z = 0.9812 }, (* H5'' *) { x = 5.3098; y = -5.9546; z = 1.8564 }, (* C4' *) { x = 5.3863; y = -5.3702; z = 0.9395 }, (* H4' *) { x = 5.3851; y = -5.0642; z = 3.0076 }, (* O4' *) { x = 6.7315; y = -4.9724; z = 3.4462 }, (* C1' *) { x = 7.0033; y = -3.9202; z = 3.3619 }, (* H1' *) { x = 7.5997; y = -5.8018; z = 2.4948 }, (* C2' *) { x = 8.3627; y = -6.3254; z = 3.0707 }, (* H2'' *) { x = 8.0410; y = -4.9501; z = 1.4724 }, (* O2' *) { x = 8.2781; y = -4.0644; z = 1.7570 }, (* H2' *) { x = 6.5701; y = -6.8129; z = 1.9714 }, (* C3' *) { x = 6.4186; y = -7.5809; z = 2.7299 }, (* H3' *) { x = 6.9357; y = -7.3841; z = 0.7235 }, (* O3' *) { x = 6.8024; y = -5.4718; z = 4.8475 }, (* N1 *) { x = 6.6920; y = -5.0495; z = 7.1354 }, (* N3 *) { x = 6.6201; y = -4.5500; z = 5.8506 }, (* C2 *) { x = 6.9254; y = -6.3614; z = 7.4926 }, (* C4 *) { x = 7.1046; y = -7.2543; z = 6.3718 }, (* C5 *) { x = 7.0391; y = -6.7951; z = 5.1106 }, (* C6 *) (U ( { x = 6.4083; y = -3.3696; z = 5.6340 }, (* O2 *) { x = 6.9679; y = -6.6901; z = 8.6800 }, (* O4 *) { x = 6.5626; y = -4.3957; z = 7.8812 }, (* H3 *) { x = 7.2781; y = -8.2254; z = 6.5350 }, (* H5 *) { x = 7.1657; y = -7.4312; z = 4.3503 }) (* H6 *) ) ) let rU07 = N( { a= -0.9434; b=0.3172; c=0.0971; (* dgf_base_tfo *) d=0.2294; e=0.4125; f=0.8816; g=0.2396; h=0.8539; i= -0.4619; tx=8.3625; ty= -52.7147; tz=1.3745 }, { a=0.2765; b= -0.1121; c= -0.9545; (* P_O3'_275_tfo *) d= -0.8297; e=0.4733; f= -0.2959; g=0.4850; h=0.8737; i=0.0379; tx= -14.7774; ty= -45.2464; tz=21.9088 }, { a=0.1063; b= -0.6334; c= -0.7665; (* P_O3'_180_tfo *) d= -0.5932; e= -0.6591; f=0.4624; g= -0.7980; h=0.4055; i= -0.4458; tx=43.7634; ty=4.3296; tz=28.4890 }, { a=0.7136; b= -0.5032; c= -0.4873; (* P_O3'_60_tfo *) d=0.6803; e=0.3317; f=0.6536; g= -0.1673; h= -0.7979; i=0.5791; tx= -17.1858; ty=41.4390; tz= -27.0751 }, { x = 21.3880; y = 15.0780; z = 45.5770 }, (* P *) { x = 21.9980; y = 14.5500; z = 46.8210 }, (* O1P *) { x = 21.1450; y = 14.0270; z = 44.5420 }, (* O2P *) { x = 22.1250; y = 16.3600; z = 44.9460 }, (* O5' *) { x = 21.5037; y = 16.8594; z = 43.7323 }, (* C5' *) { x = 20.8147; y = 17.6663; z = 43.9823 }, (* H5' *) { x = 21.1086; y = 16.0230; z = 43.1557 }, (* H5'' *) { x = 22.5654; y = 17.4874; z = 42.8616 }, (* C4' *) { x = 22.1584; y = 17.7243; z = 41.8785 }, (* H4' *) { x = 23.0557; y = 18.6826; z = 43.4751 }, (* O4' *) { x = 24.4788; y = 18.6151; z = 43.6455 }, (* C1' *) { x = 24.9355; y = 19.0840; z = 42.7739 }, (* H1' *) { x = 24.7958; y = 17.1427; z = 43.6474 }, (* C2' *) { x = 24.5652; y = 16.7400; z = 44.6336 }, (* H2'' *) { x = 26.1041; y = 16.8773; z = 43.2455 }, (* O2' *) { x = 26.7516; y = 17.5328; z = 43.5149 }, (* H2' *) { x = 23.8109; y = 16.5979; z = 42.6377 }, (* C3' *) { x = 23.5756; y = 15.5686; z = 42.9084 }, (* H3' *) { x = 24.2890; y = 16.7447; z = 41.2729 }, (* O3' *) { x = 24.9420; y = 19.2174; z = 44.8923 }, (* N1 *) { x = 25.2655; y = 20.5636; z = 44.8883 }, (* N3 *) { x = 25.1663; y = 21.2219; z = 43.8561 }, (* C2 *) { x = 25.6911; y = 21.1219; z = 46.0494 }, (* C4 *) { x = 25.8051; y = 20.4068; z = 47.2048 }, (* C5 *) { x = 26.2093; y = 20.9962; z = 48.2534 }, (* C6 *) (U ( { x = 25.4692; y = 19.0221; z = 47.2053 }, (* O2 *) { x = 25.0502; y = 18.4827; z = 46.0370 }, (* O4 *) { x = 25.9599; y = 22.1772; z = 46.0966 }, (* H3 *) { x = 25.5545; y = 18.4409; z = 48.1234 }, (* H5 *) { x = 24.7854; y = 17.4265; z = 45.9883 }) (* H6 *) ) ) let rU08 = N( { a= -0.0080; b= -0.7928; c=0.6094; (* dgf_base_tfo *) d= -0.7512; e=0.4071; f=0.5197; g= -0.6601; h= -0.4536; i= -0.5988; tx=44.1482; ty=30.7036; tz=2.1088 }, { a=0.2765; b= -0.1121; c= -0.9545; (* P_O3'_275_tfo *) d= -0.8297; e=0.4733; f= -0.2959; g=0.4850; h=0.8737; i=0.0379; tx= -14.7774; ty= -45.2464; tz=21.9088 }, { a=0.1063; b= -0.6334; c= -0.7665; (* P_O3'_180_tfo *) d= -0.5932; e= -0.6591; f=0.4624; g= -0.7980; h=0.4055; i= -0.4458; tx=43.7634; ty=4.3296; tz=28.4890 }, { a=0.7136; b= -0.5032; c= -0.4873; (* P_O3'_60_tfo *) d=0.6803; e=0.3317; f=0.6536; g= -0.1673; h= -0.7979; i=0.5791; tx= -17.1858; ty=41.4390; tz= -27.0751 }, { x = 21.3880; y = 15.0780; z = 45.5770 }, (* P *) { x = 21.9980; y = 14.5500; z = 46.8210 }, (* O1P *) { x = 21.1450; y = 14.0270; z = 44.5420 }, (* O2P *) { x = 22.1250; y = 16.3600; z = 44.9460 }, (* O5' *) { x = 23.5096; y = 16.1227; z = 44.5783 }, (* C5' *) { x = 23.5649; y = 15.8588; z = 43.5222 }, (* H5' *) { x = 23.9621; y = 15.4341; z = 45.2919 }, (* H5'' *) { x = 24.2805; y = 17.4138; z = 44.7151 }, (* C4' *) { x = 25.3492; y = 17.2309; z = 44.6030 }, (* H4' *) { x = 23.8497; y = 18.3471; z = 43.7208 }, (* O4' *) { x = 23.4090; y = 19.5681; z = 44.3321 }, (* C1' *) { x = 24.2595; y = 20.2496; z = 44.3524 }, (* H1' *) { x = 23.0418; y = 19.1813; z = 45.7407 }, (* C2' *) { x = 22.0532; y = 18.7224; z = 45.7273 }, (* H2'' *) { x = 23.1307; y = 20.2521; z = 46.6291 }, (* O2' *) { x = 22.8888; y = 21.1051; z = 46.2611 }, (* H2' *) { x = 24.0799; y = 18.1326; z = 46.0700 }, (* C3' *) { x = 23.6490; y = 17.4370; z = 46.7900 }, (* H3' *) { x = 25.3329; y = 18.7227; z = 46.5109 }, (* O3' *) { x = 22.2515; y = 20.1624; z = 43.6698 }, (* N1 *) { x = 22.4760; y = 21.0609; z = 42.6406 }, (* N3 *) { x = 23.6229; y = 21.3462; z = 42.3061 }, (* C2 *) { x = 21.3986; y = 21.6081; z = 42.0236 }, (* C4 *) { x = 20.1189; y = 21.3012; z = 42.3804 }, (* C5 *) { x = 19.1599; y = 21.8516; z = 41.7578 }, (* C6 *) (U ( { x = 19.8919; y = 20.3745; z = 43.4387 }, (* O2 *) { x = 20.9790; y = 19.8423; z = 44.0440 }, (* O4 *) { x = 21.5235; y = 22.3222; z = 41.2097 }, (* H3 *) { x = 18.8732; y = 20.1200; z = 43.7312 }, (* H5 *) { x = 20.8545; y = 19.1313; z = 44.8608 }) (* H6 *) ) ) let rU09 = N( { a= -0.0317; b=0.1374; c=0.9900; (* dgf_base_tfo *) d= -0.3422; e= -0.9321; f=0.1184; g=0.9391; h= -0.3351; i=0.0765; tx= -32.1929; ty=25.8198; tz= -28.5088 }, { a=0.2765; b= -0.1121; c= -0.9545; (* P_O3'_275_tfo *) d= -0.8297; e=0.4733; f= -0.2959; g=0.4850; h=0.8737; i=0.0379; tx= -14.7774; ty= -45.2464; tz=21.9088 }, { a=0.1063; b= -0.6334; c= -0.7665; (* P_O3'_180_tfo *) d= -0.5932; e= -0.6591; f=0.4624; g= -0.7980; h=0.4055; i= -0.4458; tx=43.7634; ty=4.3296; tz=28.4890 }, { a=0.7136; b= -0.5032; c= -0.4873; (* P_O3'_60_tfo *) d=0.6803; e=0.3317; f=0.6536; g= -0.1673; h= -0.7979; i=0.5791; tx= -17.1858; ty=41.4390; tz= -27.0751 }, { x = 21.3880; y = 15.0780; z = 45.5770 }, (* P *) { x = 21.9980; y = 14.5500; z = 46.8210 }, (* O1P *) { x = 21.1450; y = 14.0270; z = 44.5420 }, (* O2P *) { x = 22.1250; y = 16.3600; z = 44.9460 }, (* O5' *) { x = 21.5037; y = 16.8594; z = 43.7323 }, (* C5' *) { x = 20.8147; y = 17.6663; z = 43.9823 }, (* H5' *) { x = 21.1086; y = 16.0230; z = 43.1557 }, (* H5'' *) { x = 22.5654; y = 17.4874; z = 42.8616 }, (* C4' *) { x = 23.0565; y = 18.3036; z = 43.3915 }, (* H4' *) { x = 23.5375; y = 16.5054; z = 42.4925 }, (* O4' *) { x = 23.6574; y = 16.4257; z = 41.0649 }, (* C1' *) { x = 24.4701; y = 17.0882; z = 40.7671 }, (* H1' *) { x = 22.3525; y = 16.9643; z = 40.5396 }, (* C2' *) { x = 21.5993; y = 16.1799; z = 40.6133 }, (* H2'' *) { x = 22.4693; y = 17.4849; z = 39.2515 }, (* O2' *) { x = 23.0899; y = 17.0235; z = 38.6827 }, (* H2' *) { x = 22.0341; y = 18.0633; z = 41.5279 }, (* C3' *) { x = 20.9509; y = 18.1709; z = 41.5846 }, (* H3' *) { x = 22.7249; y = 19.3020; z = 41.2100 }, (* O3' *) { x = 23.8580; y = 15.0648; z = 40.5757 }, (* N1 *) { x = 25.1556; y = 14.5982; z = 40.4523 }, (* N3 *) { x = 26.1047; y = 15.3210; z = 40.7448 }, (* C2 *) { x = 25.3391; y = 13.3315; z = 40.0020 }, (* C4 *) { x = 24.2974; y = 12.5148; z = 39.6749 }, (* C5 *) { x = 24.5450; y = 11.3410; z = 39.2610 }, (* C6 *) (U ( { x = 22.9633; y = 12.9979; z = 39.8053 }, (* O2 *) { x = 22.8009; y = 14.2648; z = 40.2524 }, (* O4 *) { x = 26.3414; y = 12.9194; z = 39.8855 }, (* H3 *) { x = 22.1227; y = 12.3533; z = 39.5486 }, (* H5 *) { x = 21.7989; y = 14.6788; z = 40.3650 }) (* H6 *) ) ) let rU10 = N( { a= -0.9674; b=0.1021; c= -0.2318; (* dgf_base_tfo *) d= -0.2514; e= -0.2766; f=0.9275; g=0.0306; h=0.9555; i=0.2933; tx=27.8571; ty= -42.1305; tz= -24.4563 }, { a=0.2765; b= -0.1121; c= -0.9545; (* P_O3'_275_tfo *) d= -0.8297; e=0.4733; f= -0.2959; g=0.4850; h=0.8737; i=0.0379; tx= -14.7774; ty= -45.2464; tz=21.9088 }, { a=0.1063; b= -0.6334; c= -0.7665; (* P_O3'_180_tfo *) d= -0.5932; e= -0.6591; f=0.4624; g= -0.7980; h=0.4055; i= -0.4458; tx=43.7634; ty=4.3296; tz=28.4890 }, { a=0.7136; b= -0.5032; c= -0.4873; (* P_O3'_60_tfo *) d=0.6803; e=0.3317; f=0.6536; g= -0.1673; h= -0.7979; i=0.5791; tx= -17.1858; ty=41.4390; tz= -27.0751 }, { x = 21.3880; y = 15.0780; z = 45.5770 }, (* P *) { x = 21.9980; y = 14.5500; z = 46.8210 }, (* O1P *) { x = 21.1450; y = 14.0270; z = 44.5420 }, (* O2P *) { x = 22.1250; y = 16.3600; z = 44.9460 }, (* O5' *) { x = 23.5096; y = 16.1227; z = 44.5783 }, (* C5' *) { x = 23.5649; y = 15.8588; z = 43.5222 }, (* H5' *) { x = 23.9621; y = 15.4341; z = 45.2919 }, (* H5'' *) { x = 24.2805; y = 17.4138; z = 44.7151 }, (* C4' *) { x = 23.8509; y = 18.1819; z = 44.0720 }, (* H4' *) { x = 24.2506; y = 17.8583; z = 46.0741 }, (* O4' *) { x = 25.5830; y = 18.0320; z = 46.5775 }, (* C1' *) { x = 25.8569; y = 19.0761; z = 46.4256 }, (* H1' *) { x = 26.4410; y = 17.1555; z = 45.7033 }, (* C2' *) { x = 26.3459; y = 16.1253; z = 46.0462 }, (* H2'' *) { x = 27.7649; y = 17.5888; z = 45.6478 }, (* O2' *) { x = 28.1004; y = 17.9719; z = 46.4616 }, (* H2' *) { x = 25.7796; y = 17.2997; z = 44.3513 }, (* C3' *) { x = 25.9478; y = 16.3824; z = 43.7871 }, (* H3' *) { x = 26.2154; y = 18.4984; z = 43.6541 }, (* O3' *) { x = 25.7321; y = 17.6281; z = 47.9726 }, (* N1 *) { x = 25.5136; y = 18.5779; z = 48.9560 }, (* N3 *) { x = 25.2079; y = 19.7276; z = 48.6503 }, (* C2 *) { x = 25.6482; y = 18.1987; z = 50.2518 }, (* C4 *) { x = 25.9847; y = 16.9266; z = 50.6092 }, (* C5 *) { x = 26.0918; y = 16.6439; z = 51.8416 }, (* C6 *) (U ( { x = 26.2067; y = 15.9515; z = 49.5943 }, (* O2 *) { x = 26.0713; y = 16.3497; z = 48.3080 }, (* O4 *) { x = 25.4890; y = 18.9105; z = 51.0618 }, (* H3 *) { x = 26.4742; y = 14.9310; z = 49.8682 }, (* H5 *) { x = 26.2346; y = 15.6394; z = 47.4975 }) (* H6 *) ) ) let rUs = [rU01;rU02;rU03;rU04;rU05;rU06;rU07;rU08;rU09;rU10] let rG' = N( { a= -0.2067; b= -0.0264; c=0.9780; (* dgf_base_tfo *) d=0.9770; e= -0.0586; f=0.2049; g=0.0519; h=0.9979; i=0.0379; tx=1.0331; ty= -46.8078; tz= -36.4742 }, { a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *) d= -0.0427; e=0.2409; f= -0.9696; g=0.5010; h= -0.8345; i= -0.2294; tx=4.0167; ty=54.5377; tz=12.4779 }, { a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *) d= -0.2867; e= -0.7872; f= -0.5460; g=0.8834; h=0.0032; i= -0.4686; tx= -52.9020; ty=18.6313; tz= -0.6709 }, { a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *) d=0.9040; e= -0.4236; f= -0.0582; g= -0.1007; h= -0.0786; i= -0.9918; tx= -7.6624; ty= -25.2080; tz=49.5181 }, { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P *) { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P *) { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P *) { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5' *) { x = 32.1610; y = 2.2370; z = 46.2560 }, (* C5' *) { x = 31.2986; y = 2.8190; z = 46.5812 }, (* H5' *) { x = 32.0980; y = 1.7468; z = 45.2845 }, (* H5'' *) { x = 33.3476; y = 3.1959; z = 46.1947 }, (* C4' *) { x = 33.2668; y = 3.8958; z = 45.3630 }, (* H4' *) { x = 33.3799; y = 3.9183; z = 47.4216 }, (* O4' *) { x = 34.6515; y = 3.7222; z = 48.0398 }, (* C1' *) { x = 35.2947; y = 4.5412; z = 47.7180 }, (* H1' *) { x = 35.1756; y = 2.4228; z = 47.4827 }, (* C2' *) { x = 34.6778; y = 1.5937; z = 47.9856 }, (* H2'' *) { x = 36.5631; y = 2.2672; z = 47.4798 }, (* O2' *) { x = 37.0163; y = 2.6579; z = 48.2305 }, (* H2' *) { x = 34.6953; y = 2.5043; z = 46.0448 }, (* C3' *) { x = 34.5444; y = 1.4917; z = 45.6706 }, (* H3' *) { x = 35.6679; y = 3.3009; z = 45.3487 }, (* O3' *) { x = 37.4804; y = 4.0914; z = 52.2559 }, (* N1 *) { x = 36.9670; y = 4.1312; z = 49.9281 }, (* N3 *) { x = 37.8045; y = 4.2519; z = 50.9550 }, (* C2 *) { x = 35.7171; y = 3.8264; z = 50.3222 }, (* C4 *) { x = 35.2668; y = 3.6420; z = 51.6115 }, (* C5 *) { x = 36.2037; y = 3.7829; z = 52.6706 }, (* C6 *) (G ( { x = 39.0869; y = 4.5552; z = 50.7092 }, (* N2 *) { x = 33.9075; y = 3.3338; z = 51.6102 }, (* N7 *) { x = 34.6126; y = 3.6358; z = 49.5108 }, (* N9 *) { x = 33.5805; y = 3.3442; z = 50.3425 }, (* C8 *) { x = 35.9958; y = 3.6512; z = 53.8724 }, (* O6 *) { x = 38.2106; y = 4.2053; z = 52.9295 }, (* H1 *) { x = 39.8218; y = 4.6863; z = 51.3896 }, (* H21 *) { x = 39.3420; y = 4.6857; z = 49.7407 }, (* H22 *) { x = 32.5194; y = 3.1070; z = 50.2664 }) (* H8 *) ) ) let rU' = N( { a= -0.0109; b=0.5907; c=0.8068; (* dgf_base_tfo *) d=0.2217; e= -0.7853; f=0.5780; g=0.9751; h=0.1852; i= -0.1224; tx= -1.4225; ty= -11.0956; tz= -2.5217 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 5.2430; y = -8.2420; z = 2.8260 }, (* C5' *) { x = 5.1974; y = -8.8497; z = 1.9223 }, (* H5' *) { x = 5.5548; y = -8.7348; z = 3.7469 }, (* H5'' *) { x = 6.3140; y = -7.2060; z = 2.5510 }, (* C4' *) { x = 5.8744; y = -6.2116; z = 2.4731 }, (* H4' *) { x = 7.2798; y = -7.2260; z = 3.6420 }, (* O4' *) { x = 8.5733; y = -6.9410; z = 3.1329 }, (* C1' *) { x = 8.9047; y = -6.0374; z = 3.6446 }, (* H1' *) { x = 8.4429; y = -6.6596; z = 1.6327 }, (* C2' *) { x = 9.2880; y = -7.1071; z = 1.1096 }, (* H2'' *) { x = 8.2502; y = -5.2799; z = 1.4754 }, (* O2' *) { x = 8.7676; y = -4.7284; z = 2.0667 }, (* H2' *) { x = 7.1642; y = -7.4416; z = 1.3021 }, (* C3' *) { x = 7.4125; y = -8.5002; z = 1.2260 }, (* H3' *) { x = 6.5160; y = -6.9772; z = 0.1267 }, (* O3' *) { x = 9.4531; y = -8.1107; z = 3.4087 }, (* N1 *) { x = 11.5931; y = -9.0015; z = 3.6357 }, (* N3 *) { x = 10.8101; y = -7.8950; z = 3.3748 }, (* C2 *) { x = 11.1439; y = -10.2744; z = 3.9206 }, (* C4 *) { x = 9.7056; y = -10.4026; z = 3.9332 }, (* C5 *) { x = 8.9192; y = -9.3419; z = 3.6833 }, (* C6 *) (U ( { x = 11.3013; y = -6.8063; z = 3.1326 }, (* O2 *) { x = 11.9431; y = -11.1876; z = 4.1375 }, (* O4 *) { x = 12.5840; y = -8.8673; z = 3.6158 }, (* H3 *) { x = 9.2891; y = -11.2898; z = 4.1313 }, (* H5 *) { x = 7.9263; y = -9.4537; z = 3.6977 }) (* H6 *) ) ) (* -- PARTIAL INSTANTIATIONS ------------------------------------------------*) type variable = { id : int; t : tfo; n : nuc } let mk_var i t n = { id = i; t = t; n = n } let absolute_pos v p = tfo_apply v.t p let atom_pos atom v = absolute_pos v (atom v.n) let rec get_var id = function | (v::lst) -> if id = v.id then v else get_var id lst | _ -> assert false (* -- SEARCH ----------------------------------------------------------------*) (* Sequential backtracking algorithm *) let rec search (partial_inst : variable list) l constr = match l with [] -> [partial_inst] | (h::t) -> let rec try_assignments = function [] -> [] | v::vs -> if constr v partial_inst then (search (v::partial_inst) t constr) @ (try_assignments vs) else try_assignments vs in try_assignments (h partial_inst) (* -- 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, "refnuc" a nucleotide which is already positioned, "nucl" the nucleotide to be placed, and "tfo" a transformation matrix which expresses the desired relationship between "refnuc" and "nucl", the function "dgf-base" computes the transformation matrix that places the nucleotide "nucl" in the given relationship to "refnuc". *) let dgf_base tfo v nucl = let x = if is_A v.n then tfo_align (atom_pos nuc_C1' v) (atom_pos rA_N9 v) (atom_pos nuc_C4 v) else if is_C v.n then tfo_align (atom_pos nuc_C1' v) (atom_pos nuc_N1 v) (atom_pos nuc_C2 v) else if is_G v.n then tfo_align (atom_pos nuc_C1' v) (atom_pos rG_N9 v) (atom_pos nuc_C4 v) else tfo_align (atom_pos nuc_C1' v) (atom_pos nuc_N1 v) (atom_pos nuc_C2 v) in tfo_combine (nuc_dgf_base_tfo nucl) (tfo_combine tfo (tfo_inv_ortho x)) (* Placement of first nucleotide. *) let reference n i partial_inst = [ mk_var i tfo_id n ] (* 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. *) let wc_tfo = ( { a= -1.0000; b=0.0028; c= -0.0019; d=0.0028; e=0.3468; f= -0.9379; g= -0.0019; h= -0.9379; i= -0.3468; tx= -0.0080; ty=6.0730; tz=8.7208 } ) let wc nucl i j partial_inst = [ mk_var i (dgf_base wc_tfo (get_var j partial_inst) nucl) nucl ] let wc_dumas_tfo = ( { a= -0.9737; b= -0.1834; c=0.1352; d= -0.1779; e=0.2417; f= -0.9539; g=0.1422; h= -0.9529; i= -0.2679; tx=0.4837; ty=6.2649; tz=8.0285 } ) let wc_dumas nucl i j partial_inst = [ mk_var i (dgf_base wc_dumas_tfo (get_var j partial_inst) nucl) nucl ] let helix5'_tfo = ( { a=0.9886; b= -0.0961; c=0.1156; d=0.1424; e=0.8452; f= -0.5152; g= -0.0482; h=0.5258; i=0.8492; tx= -3.8737; ty=0.5480; tz=3.8024 } ) let helix5' nucl i j partial_inst = [ mk_var i (dgf_base helix5'_tfo (get_var j partial_inst) nucl) nucl ] let helix3'_tfo = ( { a=0.9886; b=0.1424; c= -0.0482; d= -0.0961; e=0.8452; f=0.5258; g=0.1156; h= -0.5152; i=0.8492; tx=3.4426; ty=2.0474; tz= -3.7042 } ) let helix3' nucl i j partial_inst = [ mk_var i (dgf_base helix3'_tfo (get_var j partial_inst) nucl) nucl ] let g37_a38_tfo = ( { a=0.9991; b=0.0164; c= -0.0387; d= -0.0375; e=0.7616; f= -0.6470; g=0.0189; h=0.6478; i=0.7615; tx= -3.3018; ty=0.9975; tz=2.5585 } ) let g37_a38 nucl i j partial_inst = mk_var i (dgf_base g37_a38_tfo (get_var j partial_inst) nucl) nucl let stacked5' nucl i j partial_inst = (g37_a38 nucl i j partial_inst) :: (helix5' nucl i j partial_inst) let a38_g37_tfo = ( { a=0.9991; b= -0.0375; c=0.0189; d=0.0164; e=0.7616; f=0.6478; g= -0.0387; h= -0.6470; i=0.7615; tx=3.3819; ty=0.7718; tz= -2.5321 } ) let a38_g37 nucl i j partial_inst = mk_var i (dgf_base a38_g37_tfo (get_var j partial_inst) nucl) nucl let stacked3' nucl i j partial_inst = (a38_g37 nucl i j partial_inst) :: (helix3' nucl i j partial_inst) let p_o3' nucls i j partial_inst = let refnuc = get_var j partial_inst in let align = tfo_inv_ortho (tfo_align (atom_pos nuc_O3' refnuc) (atom_pos nuc_C3' refnuc) (atom_pos nuc_C4' refnuc)) in let rec generate domains = function [] -> domains | n::ns -> generate ((mk_var i (tfo_combine (nuc_p_o3'_60_tfo n) align) n):: (mk_var i (tfo_combine (nuc_p_o3'_180_tfo n) align) n):: (mk_var i (tfo_combine (nuc_p_o3'_275_tfo n) align) n)::domains) ns in generate [] nucls (* -- PROBLEM STATEMENT -----------------------------------------------------*) (* Define anticodon problem -- Science 253:1255 Figure 3a, 3b and 3c *) let 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 *) let anticodon_constraint v partial_inst = let rec dist j = let p = atom_pos nuc_P (get_var j partial_inst) in let o3' = atom_pos nuc_O3' v in pt_dist p o3' in if v.id = 33 then (dist 34) <= 3.0 else true let anticodon () = search [] anticodon_domains anticodon_constraint (* Define pseudoknot problem -- Science 253:1255 Figure 4a and 4b *) let 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 *) let pseudoknot_constraint v partial_inst = let rec dist j = let p = atom_pos nuc_P (get_var j partial_inst) in let o3' = atom_pos nuc_O3' v in pt_dist p o3' in if v.id = 18 then (dist 19) <= 4.0 else if v.id = 6 then (dist 7) <= 4.5 else true let pseudoknot () = search [] pseudoknot_domains pseudoknot_constraint (* -- TESTING ---------------------------------------------------------------*) let list_of_atoms = function (N(dgf_base_tfo,p_o3'_275_tfo,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, A (n6,n7,n9,c8,h2,h61,h62,h8))) -> [|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;n6;n7;n9;c8;h2;h61;h62;h8|] | (N(dgf_base_tfo,p_o3'_275_tfo,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, C (n4,o2,h41,h42,h5,h6))) -> [|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;n4;o2;h41;h42;h5;h6|] | (N(dgf_base_tfo,p_o3'_275_tfo,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, G (n2,n7,n9,c8,o6,h1,h21,h22,h8))) -> [|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;n2;n7;n9;c8;o6;h1;h21;h22;h8|] | (N(dgf_base_tfo,p_o3'_275_tfo,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, U (o2,o4,h3,h5,h6))) -> [|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;o2;o4;h3;h5;h6|] let maximum = function | x::xs -> let rec iter m = function [] -> m | (a::b) -> iter (if a > m then a else m) b in iter x xs | _ -> assert false let var_most_distant_atom v = let atoms = list_of_atoms v.n in let max_dist = ref 0.0 in for i = 0 to pred (Array.length atoms) do let p = atoms.(i) in let distance = let pos = absolute_pos v p in sqrt ((pos.x * pos.x) + (pos.y * pos.y) + (pos.z * pos.z)) in if distance > !max_dist then max_dist := distance done; !max_dist let sol_most_distant_atom s = maximum (List.map var_most_distant_atom s) let most_distant_atom sols = maximum (List.map sol_most_distant_atom sols) let check () = List.length (pseudoknot ()) let run () = most_distant_atom (pseudoknot ()) let main () = for i = 1 to 50 do ignore(run()) done; assert (abs_float (run () -. 33.7976) < 0.0002) (* Printf.printf "%.4f" (run ()); print_newline() *) let _ = main () js_of_ocaml-2.5/benchmarks/sources/ml/quicksort.ml000066400000000000000000000053471241254034500224320ustar00rootroot00000000000000(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: quicksort.ml 7017 2005-08-12 09:22:04Z xleroy $ *) (* Good test for loops. Best compiled with -unsafe. *) let rec qsort lo hi (a : int array) = if lo < hi then begin let i = ref lo in let j = ref hi in let pivot = a.(hi) in while !i < !j do while !i < hi && a.(!i) <= pivot do incr i done; while !j > lo && a.(!j) >= pivot do decr j done; if !i < !j then begin let temp = a.(!i) in a.(!i) <- a.(!j); a.(!j) <- temp end done; let temp = a.(!i) in a.(!i) <- a.(hi); a.(hi) <- temp; qsort lo (!i-1) a; qsort (!i+1) hi a end (* Same but abstract over the comparison to force spilling *) let cmp i j = i - j let rec qsort2 lo hi (a : int array) = if lo < hi then begin let i = ref lo in let j = ref hi in let pivot = a.(hi) in while !i < !j do while !i < hi && cmp a.(!i) pivot <= 0 do incr i done; while !j > lo && cmp a.(!j) pivot >= 0 do decr j done; if !i < !j then begin let temp = a.(!i) in a.(!i) <- a.(!j); a.(!j) <- temp end done; let temp = a.(!i) in a.(!i) <- a.(hi); a.(hi) <- temp; qsort2 lo (!i-1) a; qsort2 (!i+1) hi a end (* Test *) let seed = ref 0 let random() = seed := !seed * 25173 + 17431; !seed land 0xFFF exception Failed let test_sort sort_fun size = let a = Array.make size 0 in let check = Array.make 4096 0 in for i = 0 to size-1 do let n = random() in a.(i) <- n; check.(n) <- check.(n)+1 done; sort_fun 0 (size-1) a; try check.(a.(0)) <- check.(a.(0)) - 1; for i = 1 to size-1 do if a.(i-1) > a.(i) then raise Failed; check.(a.(i)) <- check.(a.(i)) - 1 done; for i = 0 to 4095 do if check.(i) <> 0 then raise Failed done; (*print_string "OK"; print_newline()*) with Failed -> assert false(*print_string "failed"; print_newline()*) let main () = test_sort qsort 500000; test_sort qsort2 500000 let _ = main(); (*exit 0*) js_of_ocaml-2.5/benchmarks/sources/ml/raytrace.ml000066400000000000000000000346531241254034500222220ustar00rootroot00000000000000module Color = struct type t = { red : float; green : float; blue : float } let make r g b = { red = r; green = g; blue = b } (* let print ch c = let r = truncate (c.red *. 255.) in let g = truncate (c.green *. 255.) in let b = truncate (c.blue *. 255.) in Format.fprintf ch "rgb(%d,%d,%d)" r g b *) let limit c = { red = (let red = c.red in if red <= 0. then 0. else if red > 1.0 then 1.0 else red); green = (let green = c.green in if green <= 0. then 0. else if green > 1.0 then 1.0 else green); blue = (let blue = c.blue in if blue <= 0. then 0. else if blue > 1.0 then 1.0 else blue) } let add c1 c2 = { red = c1.red +. c2.red; green = c1.green +. c2.green; blue = c1.blue +. c2.blue } let add_scalar c1 s = limit { red = c1.red +. s; green = c1.green +. s; blue = c1.blue +. s } let subtract c1 c2 = { red = c1.red -. c2.red; green = c1.green -. c2.green; blue = c1.blue -. c2.blue } let multiply c1 c2 = { red = c1.red *. c2.red; green = c1.green *. c2.green; blue = c1.blue *. c2.blue } let multiply_scalar c1 s = { red = c1.red *. s; green = c1.green *. s; blue = c1.blue *. s } let divide_factor c1 f = { red = c1.red /. f; green = c1.green /. f; blue = c1.blue /. f } let distance c1 c2 = abs_float (c1.red -. c2.red) +. abs_float (c1.green -. c2.green) +. abs_float (c1.blue -. c2.blue) let blend c1 c2 w = add (multiply_scalar c1 (1. -. w)) (multiply_scalar c2 w) let brightness c = let r = truncate (c.red *. 255.) in let g = truncate (c.green *. 255.) in let b = truncate (c.blue *. 255.) in (r * 77 + g * 150 + b * 29) lsr 8 end module Vector = struct type t = { x : float; mutable y : float; z : float } let make x y z = { x = x; y = y; z = z } (* let print ch v = Format.fprintf ch "%f %f %f" v.x v.y v.z *) let magnitude v = sqrt (v.x *. v.x +. v.y *. v.y +. v.z *. v.z) let normalize v = let m = magnitude v in { x = v.x /. m; y = v.y /. m; z = v.z /. m } let cross v w = { x = v.y *. w.z -. v.z *. w.y; y = v.z *. w.x -. v.x *. w.z; z = v.x *. w.y -. v.y *. w.x } let dot v w = v.x *. w.x +. v.y *. w.y +. v.z *. w.z let add v w = { x = v.x +. w.x; y = v.y +. w.y; z = v.z +. w.z } let subtract v w = { x = v.x -. w.x; y = v.y -. w.y; z = v.z -. w.z } let multiply_vector v w = { x = v.x *. w.x; y = v.y *. w.y; z = v.z *. w.z } let multiply_scalar v w = { x = v.x *. w; y = v.y *. w; z = v.z *. w } end module Light = struct type t = { position : Vector.t; color : Color.t; intensity : float } let make p c i = { position = p; color = c; intensity = i } end module Ray = struct type t = { position : Vector.t; direction : Vector.t } let make p d = { position = p; direction = d } end module Intersection_info = struct type 'a t = { shape : 'a; distance : float; position : Vector.t; normal : Vector.t; color : Color.t } end module Camera = struct type t = { position : Vector.t; look_at : Vector.t; equator : Vector.t; up : Vector.t; screen : Vector.t } let make pos look_at up = { position = pos; look_at = look_at; up = up; equator = Vector.cross (Vector.normalize look_at) up; screen = Vector.add pos look_at } let get_ray c vx vy = let pos = Vector.subtract c.screen (Vector.subtract (Vector.multiply_scalar c.equator vx) (Vector.multiply_scalar c.up vy)) in pos.Vector.y <- pos.Vector.y *. -1.; let dir = Vector.subtract pos c.position in Ray.make pos (Vector.normalize dir) end module Background = struct type t = { color : Color.t; ambience : float } let make c a = { color = c; ambience = a } end module Material = struct type t = { reflection : float; transparency : float; gloss : float; has_texture : bool; get_color : float -> float -> Color.t } let wrap_up t = let t = mod_float t 2.0 in if t < -1. then t +. 2.0 else if t >= 1. then t -. 2.0 else t let solid color reflection transparency gloss = { reflection = reflection; transparency = transparency; gloss = gloss; has_texture = false; get_color = fun _ _ -> color } let chessboard color_even color_odd reflection transparency gloss density = { reflection = reflection; transparency = transparency; gloss = gloss; has_texture = true; get_color = fun u v -> let t = wrap_up (u *. density) *. wrap_up (v *. density) in if t < 0. then color_even else color_odd } end module Shape = struct type shape = Sphere of Vector.t * float | Plane of Vector.t * float type t = { shape : shape; material : Material.t } let make shape material = { shape = shape; material = material } let dummy = make (Sphere (Vector.make 0. 0. 0., 0.)) (Material.solid (Color.make 0. 0. 0.) 0. 0. 0.) let position s = match s.shape with Sphere (p, _) -> p | Plane (p, _) -> p let intersect s ray = match s.shape with Sphere (position, radius) -> let dst = Vector.subtract ray.Ray.position position in let b = Vector.dot dst ray.Ray.direction in let c = Vector.dot dst dst -. radius *. radius in let d = b *. b -. c in if d > 0. then begin let dist = -. b -. sqrt d in let pos = Vector.add ray.Ray.position (Vector.multiply_scalar ray.Ray.direction dist) in Some { Intersection_info.shape = s; distance = dist; position = pos; normal = Vector.normalize (Vector.subtract pos position); color = s.material.Material.get_color 0. 0. } end else None | Plane (position, d) -> let vd = Vector.dot position ray.Ray.direction in if vd = 0. then None else begin let t = -. (Vector.dot position ray.Ray.position +. d) /. vd in if t <= 0. then None else begin let pos = Vector.add ray.Ray.position (Vector.multiply_scalar ray.Ray.direction t) in Some { Intersection_info.shape = s; distance = t; position = pos; normal = position; color = if s.material.Material.has_texture then begin let vu = Vector.make position.Vector.y position.Vector.z (-. position.Vector.x) in let vv = Vector.cross vu position in let u = Vector.dot pos vu in let v = Vector.dot pos vv in s.material.Material.get_color u v end else s.material.Material.get_color 0. 0. } end end end module Scene = struct type t = { camera : Camera.t; shapes : Shape.t array; lights : Light.t array; background : Background.t } let make c s l b = { camera = c; shapes = s; lights = l; background = b } end module Engine = struct type t = { pixel_width : int; pixel_height : int; canvas_width : int; canvas_height : int; render_diffuse : bool; render_shadows : bool; render_highlights : bool; render_reflections : bool; ray_depth : int; } let check_number = ref 0 let get_reflection_ray p n v = let c1 = -. Vector.dot n v in let r1 = Vector.add (Vector.multiply_scalar n (2. *. c1)) v in Ray.make p r1 let rec ray_trace options info ray scene depth = let old_color = Color.multiply_scalar info.Intersection_info.color scene.Scene.background.Background.ambience in let color = ref old_color in let shininess = 10. ** (info.Intersection_info.shape.Shape.material.Material.gloss +. 1.) in let lights = scene.Scene.lights in for i = 0 to Array.length lights - 1 do let light = lights.(i) in let v = Vector.normalize (Vector.subtract light.Light.position info.Intersection_info.position) in if options.render_diffuse then begin let l = Vector.dot v info.Intersection_info.normal in if l > 0. then color := Color.add !color (Color.multiply info.Intersection_info.color (Color.multiply_scalar light.Light.color l)) end; if depth <= options.ray_depth then begin if options.render_reflections && info.Intersection_info.shape.Shape.material.Material.reflection > 0. then begin let reflection_ray = get_reflection_ray info.Intersection_info.position info.Intersection_info.normal ray.Ray.direction in let col = match test_intersection reflection_ray scene info.Intersection_info.shape with Some ({ Intersection_info.distance = d } as info) when d > 0. -> ray_trace options info reflection_ray scene (depth + 1) | _ -> scene.Scene.background.Background.color in color := Color.blend !color col info.Intersection_info.shape.Shape.material.Material.reflection end end; let shadow_info = ref None in if options.render_shadows then begin let shadow_ray = Ray.make info.Intersection_info.position v in shadow_info := test_intersection shadow_ray scene info.Intersection_info.shape; match !shadow_info with Some info -> (*XXX This looks wrong! *) let va = Color.multiply_scalar !color 0.5 in let db = 0.5 *. info.Intersection_info.shape .Shape.material.Material.transparency ** 0.5 in color := Color.add_scalar va db | None -> () end; if options.render_highlights && !shadow_info <> None && info.Intersection_info.shape.Shape.material.Material.gloss > 0. then begin (*XXX This looks wrong! *) let shape_position = Shape.position info.Intersection_info.shape in let lv = Vector.normalize (Vector.subtract shape_position light.Light.position) in let e = Vector.normalize (Vector.subtract scene.Scene.camera.Camera.position shape_position) in let h = Vector.normalize (Vector.subtract e lv) in let gloss_weight = (max (Vector.dot info.Intersection_info.normal h) 0.) ** shininess in color := Color.add (Color.multiply_scalar light.Light.color gloss_weight) !color end done; Color.limit !color and test_intersection ray scene exclude = let best = ref None in let dist = ref 2000. in let shapes = scene.Scene.shapes in for i = 0 to Array.length shapes - 1 do let shape = shapes.(i) in if shape != exclude then begin match Shape.intersect shape ray with Some { Intersection_info.distance = d } as v when d >= 0. && d < !dist -> best := v; dist := d | _ -> () end done; !best let get_pixel_color options ray scene = match test_intersection ray scene Shape.dummy with Some info -> ray_trace options info ray scene 0 | None -> scene.Scene.background.Background.color let set_pixel options x y color = if x == y then check_number := !check_number + Color.brightness color; ((* let pxw = options.pixel_width in let pxh = options.pixel_height in Format.eprintf "%d %d %d %d %d %a@." (x * pxw) (y * pxh) pxw pxh !check_number Color.print color; *)) let render_scene options scene canvas = check_number := 0; (*XXX canvas *) let canvas_height = options.canvas_height in let canvas_width = options.canvas_width in for y = 0 to canvas_height - 1 do for x = 0 to canvas_width - 1 do let yp = float y /. float canvas_height *. 2. -. 1. in let xp = float x /. float canvas_width *. 2. -. 1. in let ray = Camera.get_ray scene.Scene.camera xp yp in let color = get_pixel_color options ray scene in set_pixel options x y color done done; assert (!check_number = 2321) let make canvas_width canvas_height pixel_width pixel_height render_diffuse render_shadows render_highlights render_reflections ray_depth = { canvas_width = canvas_width / pixel_width; canvas_height = canvas_height / pixel_height; pixel_width = pixel_width; pixel_height = pixel_height; render_diffuse = render_diffuse; render_shadows = render_shadows; render_highlights = render_highlights; render_reflections = render_reflections; ray_depth = ray_depth } end let render_scene () = let camera = Camera.make (Vector.make 0. 0. (-15.)) (Vector.make (-0.2) 0. 5.) (Vector.make 0. 1. 0.) in let background = Background.make (Color.make 0.5 0.5 0.5) 0.4 in let sphere = Shape.make (Shape.Sphere (Vector.make (-1.5) 1.5 2., 1.5)) (Material.solid (Color.make 0. 0.5 0.5) 0.3 0. 2.) in let sphere1 = Shape.make (Shape.Sphere (Vector.make 1. 0.25 1., 0.5)) (Material.solid (Color.make 0.9 0.9 0.9) 0.1 0. 1.5) in let plane = Shape.make (Shape.Plane (Vector.normalize (Vector.make 0.1 0.9 (-0.5)), 1.2)) (Material.chessboard (Color.make 1. 1. 1.) (Color.make 0. 0. 0.) 0.2 0. 1.0 0.7) in let light = Light.make (Vector.make 5. 10. (-1.)) (Color.make 0.8 0.8 0.8) 10. in let light1 = Light.make (Vector.make (-3.) 5. (-15.)) (Color.make 0.8 0.8 0.8) 100. in let scene = Scene.make camera [|plane; sphere; sphere1|] [|light; light1|] background in let image_width = 100 in let image_height = 100 in let pixel_size = (5, 5) in let render_diffuse = true in let render_shadows = true in let render_highlights = true in let render_reflections = true in let ray_depth = 2 in let engine = Engine.make image_width image_height (fst pixel_size) (snd pixel_size) render_diffuse render_shadows render_highlights render_reflections ray_depth in Engine.render_scene engine scene None let _ = for i = 0 to 99 do render_scene () done js_of_ocaml-2.5/benchmarks/sources/ml/soli.ml000066400000000000000000000066731241254034500213570ustar00rootroot00000000000000(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: soli.ml 2553 1999-11-17 18:59:06Z xleroy $ *) type peg = Out | Empty | Peg let board = [| [| Out; Out; Out; Out; Out; Out; Out; Out; Out|]; [| Out; Out; Out; Peg; Peg; Peg; Out; Out; Out|]; [| Out; Out; Out; Peg; Peg; Peg; Out; Out; Out|]; [| Out; Peg; Peg; Peg; Peg; Peg; Peg; Peg; Out|]; [| Out; Peg; Peg; Peg; Empty; Peg; Peg; Peg; Out|]; [| Out; Peg; Peg; Peg; Peg; Peg; Peg; Peg; Out|]; [| Out; Out; Out; Peg; Peg; Peg; Out; Out; Out|]; [| Out; Out; Out; Peg; Peg; Peg; Out; Out; Out|]; [| Out; Out; Out; Out; Out; Out; Out; Out; Out|] |] (* let print_peg = function Out -> print_string "." | Empty -> print_string " " | Peg -> print_string "$" let print_board board = for i=0 to 8 do for j=0 to 8 do print_peg board.(i).(j) done; print_newline() done *) type direction = { dx: int; dy: int } let dir = [| {dx = 0; dy = 1}; {dx = 1; dy = 0}; {dx = 0; dy = -1}; {dx = -1; dy = 0} |] type move = { x1: int; y1: int; x2: int; y2: int } let moves = Array.make 31 {x1=0;y1=0;x2=0;y2=0} let counter = ref 0 exception Found let rec solve m = counter := !counter + 1; if m = 31 then begin match board.(4).(4) with Peg -> true | _ -> false end else try (* if !counter mod 500 = 0 then begin print_int !counter; print_newline() end; *) for i=1 to 7 do for j=1 to 7 do match board.(i).(j) with Peg -> for k=0 to 3 do let d1 = dir.(k).dx in let d2 = dir.(k).dy in let i1 = i+d1 in let i2 = i1+d1 in let j1 = j+d2 in let j2 = j1+d2 in match board.(i1).(j1) with Peg -> begin match board.(i2).(j2) with Empty -> (* print_int i; print_string ", "; print_int j; print_string ") dir "; print_int k; print_string "\n"; *) board.(i).(j) <- Empty; board.(i1).(j1) <- Empty; board.(i2).(j2) <- Peg; if solve(m+1) then begin moves.(m) <- { x1=i; y1=j; x2=i2; y2=j2 }; raise Found end; board.(i).(j) <- Peg; board.(i1).(j1) <- Peg; board.(i2).(j2) <- Empty | _ -> () end | _ -> () done | _ -> () done done; false with Found -> true let _ = if solve 0 then ((*print_string "\n"; print_board board*)) else assert false js_of_ocaml-2.5/benchmarks/sources/ml/splay.ml000066400000000000000000000205761241254034500215370ustar00rootroot00000000000000(* // Copyright 2009 the V8 project authors. All rights reserved. // Redistribution and use in source and binary forms, with or without // modification, are permitted provided that the following conditions are // met: // // * Redistributions of source code must retain the above copyright // notice, this list of conditions and the following disclaimer. // * Redistributions in binary form must reproduce the above // copyright notice, this list of conditions and the following // disclaimer in the documentation and/or other materials provided // with the distribution. // * Neither the name of Google Inc. nor the names of its // contributors may be used to endorse or promote products derived // from this software without specific prior written permission. // // THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS // "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT // LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR // A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT // OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, // SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT // LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, // DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY // THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT // (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE // OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. // This benchmark is based on a JavaScript log processing module used // by the V8 profiler to generate execution time profiles for runs of // JavaScript applications, and it effectively measures how fast the // JavaScript engine is at allocating nodes and reclaiming the memory // used for old nodes. Because of the way splay trees work, the engine // also has to deal with a lot of changes to the large tree object // graph. *) (* Translation in ocaml by VB: This program is probably not the best splay tree implementation in OCaml, because it tries to follow exactly the steps of the Google v8 benchmark. *) let kSplayTreeSize = 8000 let kSplayTreeModifications = 80 let kSplayTreePayloadDepth = 5 type content_leaf = { array : int array ; string : string } type content = CLeaf of content_leaf | CNode of content * content type tree = | Empty | Node of (tree * float * content * tree) (** * Perform the splay operation for the given key. Moves the node with * the given key to the top of the tree. If no node has the given * key, the last node on the search path is moved to the top of the * tree. This is the simplified top-down splaying algorithm from: * "Self-adjusting Binary Search Trees" by Sleator and Tarjan *) let rec splay_ ((left, key, value, right) as a) k = if k = key then a else if k < key then (match left with | Empty -> a (* not found *) | Node (lleft, lk, lv, lright) -> if k = lk then (lleft, lk, lv, Node(lright, key, value, right)) (* zig *) else if k < lk then match lleft with | Empty -> (Empty, lk, lv, Node(lright, key, value, right)) (* not found *) | Node n -> (* zig-zig *) let (llleft, llk, llv, llright) = splay_ n k in (llleft, llk, llv, Node (llright, lk, lv, Node(lright, key, value, right))) else match lright with | Empty -> (lleft, lk, lv, Node (Empty, key, value, right)) | Node n -> (* zig-zag *) let (lrleft, lrk, lrv, lrright) = splay_ n k in (Node (lleft, lk, lv, lrleft), lrk, lrv, Node (lrright, key, value, right))) else (match right with | Empty -> a | Node (rleft, rk, rv, rright) -> if k = rk then (Node (left, key, value, rleft), rk, rv, rright) (* zag *) else if k > rk then match rright with | Empty -> (Node (left, key, value, rleft), rk, rv, rright) (* not found *) | Node n -> (* zag-zag *) let (rrleft, rrk, rrv, rrright) = splay_ n k in (Node (Node (left, key, value, rleft), rk, rv, rrleft), rrk, rrv, rrright) else match rleft with | Empty -> (Node (left, key, value, rleft), rk, rv, rright) (* not found *) | Node n -> (* zag-zig *) let (rlleft, rlk, rlv, rlright) = splay_ n k in (Node (left, key, value, rlleft), rlk, rlv, Node (rlright, rk, rv, rright))) let rec splay t key = match t with | Empty -> t | Node n -> Node (splay_ n key) let insert key value t = (* Splay on the key to move the last node on the search path for the key to the root of the tree.*) let t = splay t key in match t with | Empty -> Node (Empty, key, value, Empty) | Node (left, rk, rv, right) -> if rk = key then t else if key > rk then Node (Node (left, rk, rv, Empty), key, value, right) else Node (left, key, value, Node (Empty, rk, rv, right)) let remove key t = let t = splay t key in match t with | Empty -> t | Node (_, rk, _, _) when rk <> key -> raise Not_found | Node (Empty, _, _, right) -> right | Node (left, _, _, right) -> match splay left key with | Node (lleft, lk, lv, Empty) -> Node (lleft, lk, lv, right) | _ -> failwith "remove" let find key t = let t = splay t key in match t with | Node (_, k, v, _) when k = key -> (Some v, t) | _ -> (None, t) let rec findMax = function (* here we do not splay (but that's what the original program does) *) | Empty -> raise Not_found | Node (_, k, v, Empty) -> k | Node (_, _, _, right) -> findMax right let findGreatestLessThan key t = (* Splay on the key to move the node with the given key or the last node on the search path to the top of the tree. Now the result is either the root node or the greatest node in the left subtree. *) let t = splay t key in match t with | Empty -> (None, t) | Node (left, k, v, right) when k < key -> (Some k, t) | Node (Empty, k, v, right) -> (None, t) | Node (left, _, _, _) -> (Some (findMax left), t) let exportKeys t = let rec aux l length = function | Empty -> (l, length) | Node (left, k, _, right) -> let l, length = aux l length right in aux (k::l) (length+1) left in aux [] 0 t let rec generatePayloadTree depth tag = if depth = 0 then CLeaf { array = [| 0; 1; 2; 3; 4; 5; 6; 7; 8; 9 |]; string = "String for key " ^ tag ^ " in leaf node" } else CNode(generatePayloadTree (depth - 1) tag, generatePayloadTree (depth - 1) tag) let random = let seed = ref 49734321 in fun () -> (* // Robert Jenkins' 32 bit integer hash function. *) let s = !seed in let s = ((s + 0x7ed55d16) + (s lsl 12)) land 0xffffffff in let s = ((s lxor 0xc761c23c) lxor (s lsr 19)) in let s = ((s + 0x165667b1) + (s lsl 5)) in let s = ((s + 0xd3a2646c) lxor (s lsl 9)) in let s = ((s + 0xfd7046c5) + (s lsl 3)) land 0xffffffff in let s = ((s lxor 0xb55a4f09) lxor (s lsr 16)) in seed := s; float (s land 0xfffffff) /. float 0x10000000 let generateKey = random let insertNewNode t = let rec aux t = let key = generateKey () in let vo, t = find key t in match vo with | None -> key, t | _ -> aux t in let key, t = aux t in let payload = generatePayloadTree kSplayTreePayloadDepth (string_of_float key) in (key, insert key payload t) let splaySetup () = let rec aux i t = if i < kSplayTreeSize then aux (i+1) (snd (insertNewNode t)) else t in aux 0 Empty let splayTearDown t = let keys, length = exportKeys t in (* // Verify that the splay tree has the right size. *) if length <> kSplayTreeSize then failwith "Splay tree has wrong size"; (* // Verify that the splay tree has sorted, unique keys. *) match keys with | [] -> () | a::l -> ignore (List.fold_left (fun b e -> if b >= e then failwith "Splay tree not sorted" else e) a l) let splayRun t = (* // Replace a few nodes in the splay tree. *) let rec aux i t = if i < kSplayTreeModifications then let key, t = insertNewNode t in aux (i+1) (match findGreatestLessThan key t with | (None, t) -> remove key t | (Some k, t) -> remove k t) else t in aux 0 t let ( ++ ) a b = b a let () = splaySetup () ++ splayRun ++ splayTearDown js_of_ocaml-2.5/benchmarks/sources/ml/takc.ml000066400000000000000000000022101241254034500213120ustar00rootroot00000000000000(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: takc.ml 7017 2005-08-12 09:22:04Z xleroy $ *) let rec tak x y z = if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y) else z let rec repeat n accu = if n <= 0 then accu else repeat (n - 1) (tak 18 12 6 + accu) let _ = assert (repeat 2000 0 = 14000) (* print_int (repeat 2000); print_newline(); exit 0 *) js_of_ocaml-2.5/benchmarks/sources/ml/taku.ml000066400000000000000000000021301241254034500213350ustar00rootroot00000000000000(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: taku.ml 7017 2005-08-12 09:22:04Z xleroy $ *) let rec tak (x, y, z) = if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y)) else z let rec repeat n accu = if n <= 0 then accu else repeat (n - 1) (tak(18,12,6) + accu) let _ = assert (repeat 2000 0 = 14000) js_of_ocaml-2.5/compiler/000077500000000000000000000000001241254034500154455ustar00rootroot00000000000000js_of_ocaml-2.5/compiler/.depend000066400000000000000000000206471241254034500167160ustar00rootroot00000000000000annot_lexer.cmo : annot_parser.cmi annot_lexer.cmi annot_lexer.cmx : annot_parser.cmx annot_lexer.cmi annot_parser.cmo : primitive.cmi annot_parser.cmi annot_parser.cmx : primitive.cmx annot_parser.cmi code.cmo : varPrinter.cmi util.cmi code.cmi code.cmx : varPrinter.cmx util.cmx code.cmi commonArg.cmo : option.cmi commonArg.cmi commonArg.cmx : option.cmx commonArg.cmi compile.cmo : util.cmi pseudoFs.cmi pretty_print.cmi parse_bytecode.cmi \ option.cmi linker.cmi driver.cmi compileArg.cmi commonArg.cmi code.cmi compile.cmx : util.cmx pseudoFs.cmx pretty_print.cmx parse_bytecode.cmx \ option.cmx linker.cmx driver.cmx compileArg.cmx commonArg.cmx code.cmx compileArg.cmo : util.cmi source_map.cmi option.cmi driver.cmi \ compiler_version.cmi commonArg.cmi compileArg.cmi compileArg.cmx : util.cmx source_map.cmx option.cmx driver.cmx \ compiler_version.cmx commonArg.cmx compileArg.cmi compiler_version.cmo : compiler_version.cmi compiler_version.cmx : compiler_version.cmi control.cmo : subst.cmi code.cmi control.cmi control.cmx : subst.cmx code.cmx control.cmi deadcode.cmo : util.cmi pure_fun.cmi option.cmi code.cmi deadcode.cmi deadcode.cmx : util.cmx pure_fun.cmx option.cmx code.cmx deadcode.cmi dgraph.cmo : dgraph.cmi dgraph.cmx : dgraph.cmi driver.cmo : varPrinter.cmi util.cmi tailcall.cmi specialize_js.cmi \ specialize.cmi reserved.cmi primitive.cmi pretty_print.cmi phisimpl.cmi \ parse_bytecode.cmi option.cmi linker.cmi js_traverse.cmi js_output.cmi \ js_assign.cmi javascript.cmi inline.cmi generate.cmi flow.cmi eval.cmi \ deadcode.cmi compiler_version.cmi code.cmi driver.cmi driver.cmx : varPrinter.cmx util.cmx tailcall.cmx specialize_js.cmx \ specialize.cmx reserved.cmx primitive.cmx pretty_print.cmx phisimpl.cmx \ parse_bytecode.cmx option.cmx linker.cmx js_traverse.cmx js_output.cmx \ js_assign.cmx javascript.cmx inline.cmx generate.cmx flow.cmx eval.cmx \ deadcode.cmx compiler_version.cmx code.cmx driver.cmi eval.cmo : primitive.cmi flow.cmi code.cmi eval.cmi eval.cmx : primitive.cmx flow.cmx code.cmx eval.cmi flow.cmo : util.cmi subst.cmi primitive.cmi option.cmi dgraph.cmi code.cmi \ flow.cmi flow.cmx : util.cmx subst.cmx primitive.cmx option.cmx dgraph.cmx code.cmx \ flow.cmi freevars.cmo : util.cmi option.cmi code.cmi freevars.cmi freevars.cmx : util.cmx option.cmx code.cmx freevars.cmi generate.cmo : util.cmi subst.cmi primitive.cmi parse_js.cmi parse_info.cmi \ parse_bytecode.cmi option.cmi js_tailcall.cmi js_simpl.cmi javascript.cmi \ freevars.cmi code.cmi generate.cmi generate.cmx : util.cmx subst.cmx primitive.cmx parse_js.cmx parse_info.cmx \ parse_bytecode.cmx option.cmx js_tailcall.cmx js_simpl.cmx javascript.cmx \ freevars.cmx code.cmx generate.cmi inline.cmo : util.cmi option.cmi code.cmi inline.cmi inline.cmx : util.cmx option.cmx code.cmx inline.cmi instr.cmo : util.cmi instr.cmi instr.cmx : util.cmx instr.cmi javascript.cmo : varPrinter.cmi util.cmi parse_info.cmi code.cmi \ javascript.cmi javascript.cmx : varPrinter.cmx util.cmx parse_info.cmx code.cmx \ javascript.cmi js_assign.cmo : util.cmi option.cmi js_traverse.cmi javascript.cmi code.cmi \ js_assign.cmi js_assign.cmx : util.cmx option.cmx js_traverse.cmx javascript.cmx code.cmx \ js_assign.cmi js_lexer.cmo : parse_info.cmi js_token.cmi js_lexer.cmi js_lexer.cmx : parse_info.cmx js_token.cmx js_lexer.cmi js_output.cmo : source_map.cmi pretty_print.cmi parse_info.cmi option.cmi \ javascript.cmi js_output.cmi js_output.cmx : source_map.cmx pretty_print.cmx parse_info.cmx option.cmx \ javascript.cmx js_output.cmi js_parser.cmo : parse_info.cmi js_token.cmi javascript.cmi js_parser.cmi js_parser.cmx : parse_info.cmx js_token.cmx javascript.cmx js_parser.cmi js_simpl.cmo : javascript.cmi code.cmi js_simpl.cmi js_simpl.cmx : javascript.cmx code.cmx js_simpl.cmi js_tailcall.cmo : option.cmi js_traverse.cmi javascript.cmi code.cmi \ js_tailcall.cmi js_tailcall.cmx : option.cmx js_traverse.cmx javascript.cmx code.cmx \ js_tailcall.cmi js_token.cmo : parse_info.cmi js_token.cmi js_token.cmx : parse_info.cmx js_token.cmi js_traverse.cmo : util.cmi javascript.cmi code.cmi js_traverse.cmi js_traverse.cmx : util.cmx javascript.cmx code.cmx js_traverse.cmi linker.cmo : util.cmi reserved.cmi primitive.cmi parse_js.cmi parse_info.cmi \ option.cmi js_traverse.cmi js_token.cmi javascript.cmi annot_parser.cmi \ annot_lexer.cmi linker.cmi linker.cmx : util.cmx reserved.cmx primitive.cmx parse_js.cmx parse_info.cmx \ option.cmx js_traverse.cmx js_token.cmx javascript.cmx annot_parser.cmx \ annot_lexer.cmx linker.cmi minify.cmo : util.cmi pretty_print.cmi parse_js.cmi parse_info.cmi \ option.cmi minifyArg.cmi js_traverse.cmi js_output.cmi js_assign.cmi \ commonArg.cmi code.cmi minify.cmx : util.cmx pretty_print.cmx parse_js.cmx parse_info.cmx \ option.cmx minifyArg.cmx js_traverse.cmx js_output.cmx js_assign.cmx \ commonArg.cmx code.cmx minifyArg.cmo : compiler_version.cmi commonArg.cmi minifyArg.cmi minifyArg.cmx : compiler_version.cmx commonArg.cmx minifyArg.cmi option.cmo : option.cmi option.cmx : option.cmi parse_bytecode.cmo : util.cmi primitive.cmi parse_info.cmi option.cmi \ instr.cmi code.cmi parse_bytecode.cmi parse_bytecode.cmx : util.cmx primitive.cmx parse_info.cmx option.cmx \ instr.cmx code.cmx parse_bytecode.cmi parse_info.cmo : parse_info.cmi parse_info.cmx : parse_info.cmi parse_js.cmo : parse_info.cmi js_token.cmi js_parser.cmi js_lexer.cmi \ parse_js.cmi parse_js.cmx : parse_info.cmx js_token.cmx js_parser.cmx js_lexer.cmx \ parse_js.cmi phisimpl.cmo : util.cmi subst.cmi option.cmi dgraph.cmi code.cmi \ phisimpl.cmi phisimpl.cmx : util.cmx subst.cmx option.cmx dgraph.cmx code.cmx \ phisimpl.cmi pretty_print.cmo : pretty_print.cmi pretty_print.cmx : pretty_print.cmi primitive.cmo : util.cmi parse_info.cmi primitive.cmi primitive.cmx : util.cmx parse_info.cmx primitive.cmi pseudoFs.cmo : util.cmi code.cmi pseudoFs.cmi pseudoFs.cmx : util.cmx code.cmx pseudoFs.cmi pure_fun.cmo : primitive.cmi code.cmi pure_fun.cmi pure_fun.cmx : primitive.cmx code.cmx pure_fun.cmi reserved.cmo : util.cmi reserved.cmi reserved.cmx : util.cmx reserved.cmi source_map.cmo : vlq64.cmi javascript.cmi source_map.cmi source_map.cmx : vlq64.cmx javascript.cmx source_map.cmi specialize.cmo : util.cmi option.cmi flow.cmi code.cmi specialize.cmi specialize.cmx : util.cmx option.cmx flow.cmx code.cmx specialize.cmi specialize_js.cmo : util.cmi primitive.cmi flow.cmi code.cmi \ specialize_js.cmi specialize_js.cmx : util.cmx primitive.cmx flow.cmx code.cmx \ specialize_js.cmi subst.cmo : util.cmi code.cmi subst.cmi subst.cmx : util.cmx code.cmx subst.cmi tailcall.cmo : util.cmi subst.cmi option.cmi code.cmi tailcall.cmi tailcall.cmx : util.cmx subst.cmx option.cmx code.cmx tailcall.cmi util.cmo : util.cmi util.cmx : util.cmi varPrinter.cmo : util.cmi reserved.cmi varPrinter.cmi varPrinter.cmx : util.cmx reserved.cmx varPrinter.cmi vlq64.cmo : vlq64.cmi vlq64.cmx : vlq64.cmi annot_lexer.cmi : annot_parser.cmi annot_parser.cmi : primitive.cmi code.cmi : util.cmi commonArg.cmi : compileArg.cmi : source_map.cmi option.cmi driver.cmi commonArg.cmi compiler_version.cmi : control.cmi : code.cmi deadcode.cmi : code.cmi dgraph.cmi : driver.cmi : source_map.cmi pretty_print.cmi parse_bytecode.cmi code.cmi eval.cmi : flow.cmi code.cmi flow.cmi : code.cmi freevars.cmi : util.cmi code.cmi generate.cmi : parse_bytecode.cmi javascript.cmi code.cmi inline.cmi : code.cmi instr.cmi : javascript.cmi : parse_info.cmi code.cmi js_assign.cmi : javascript.cmi js_lexer.cmi : parse_info.cmi js_token.cmi js_output.cmi : source_map.cmi pretty_print.cmi javascript.cmi js_parser.cmi : js_token.cmi javascript.cmi js_simpl.cmi : javascript.cmi code.cmi js_tailcall.cmi : js_traverse.cmi javascript.cmi code.cmi js_token.cmi : parse_info.cmi js_traverse.cmi : util.cmi javascript.cmi code.cmi linker.cmi : util.cmi primitive.cmi parse_info.cmi javascript.cmi minifyArg.cmi : commonArg.cmi option.cmi : parse_bytecode.cmi : util.cmi parse_info.cmi code.cmi parse_info.cmi : parse_js.cmi : parse_info.cmi js_token.cmi javascript.cmi phisimpl.cmi : code.cmi pretty_print.cmi : primitive.cmi : util.cmi parse_info.cmi pseudoFs.cmi : util.cmi code.cmi pure_fun.cmi : code.cmi reserved.cmi : util.cmi source_map.cmi : javascript.cmi specialize.cmi : flow.cmi code.cmi specialize_js.cmi : flow.cmi code.cmi subst.cmi : code.cmi tailcall.cmi : code.cmi util.cmi : varPrinter.cmi : util.cmi vlq64.cmi : js_of_ocaml-2.5/compiler/Makefile000066400000000000000000000061321241254034500171070ustar00rootroot00000000000000 include ../Makefile.conf all: $(COMPILER) $(MINIFIER) man lib: compiler.cma compiler.cmxa compiler.cmxs PACKAGES=findlib,cmdliner OBJS=compiler_version.cmx \ util.cmx pretty_print.cmx option.cmx reserved.cmx varPrinter.cmx \ dgraph.cmx code.cmx javascript.cmx vlq64.cmx source_map.cmx \ js_output.cmx js_simpl.cmx parse_info.cmx js_token.cmx js_parser.cmx \ js_lexer.cmx parse_js.cmx primitive.cmx annot_parser.cmx annot_lexer.cmx \ instr.cmx subst.cmx pure_fun.cmx deadcode.cmx \ flow.cmx specialize.cmx specialize_js.cmx eval.cmx inline.cmx \ tailcall.cmx freevars.cmx phisimpl.cmx \ js_traverse.cmx js_assign.cmx js_tailcall.cmx \ linker.cmx parse_bytecode.cmx generate.cmx driver.cmx \ pseudoFs.cmx COMPOBJS=$(OBJS) commonArg.cmx compileArg.cmx compile.cmx $(COMPILER): compile.$(BEST) mv -f $< $@ $(MINIFIER): minify.$(BEST) mv -f $< $@ man: man/$(MINIFIER).1 man/$(COMPILER).1 man/$(MINIFIER).1: $(MINIFIER) mkdir -p man ./$(MINIFIER) --help=groff >$@ man/$(COMPILER).1: $(COMPILER) mkdir -p man ./$(COMPILER) --help=groff >$@ .INTERMEDIATE: compile.byte compile.opt minify.byte minify.opt compile.byte: $(COMPOBJS:cmx=cmo) ocamlfind ocamlc $(SAFESTRING) -package $(PACKAGES) -linkpkg -o $@ $^ compile.opt: $(COMPOBJS) ocamlfind ocamlopt $(SAFESTRING) -package $(PACKAGES) -linkpkg -g -o $@ $^ minify.byte: $(OBJS:cmx=cmo) commonArg.cmo minifyArg.cmo minify.cmo ocamlfind ocamlc $(SAFESTRING) -package $(PACKAGES) -linkpkg -o $@ $^ minify.opt: $(OBJS:cmx=cmx) commonArg.cmx minifyArg.cmx minify.cmx ocamlfind ocamlopt $(SAFESTRING) -package $(PACKAGES) -linkpkg -g -o $@ $^ compiler.cmo: $(OBJS:cmx=cmo) ocamlfind ocamlc -pack -o $@ $^ compiler.cma: compiler.cmo ocamlfind ocamlc -a -o $@ $^ compiler.cmx: $(OBJS) ocamlfind ocamlopt -pack -g -o $@ $^ compiler.cmxa: compiler.cmx ocamlfind ocamlopt -a -o $@ $^ compiler.cmxs: compiler.cmxa ocamlfind ocamlopt -shared -g -o $@ $^ VERSION := $(shell head -n 1 ../VERSION) compiler_version.ml: compiler_version.ml.tmp if cmp -s $^ $@; then rm $^; else mv $^ $@; fi .PHONY: compiler_version.ml.tmp compiler_version.ml.tmp: echo "let s = \"${VERSION}\"" > $@ echo "let git_version = \"${VERSION_GIT}\"" >> $@ %.cmx: %.ml ocamlfind ocamlopt $(SAFESTRING) -package $(PACKAGES) -for-pack Compiler -g -c $< %.cmo: %.ml ocamlfind ocamlc $(SAFESTRING) -package $(PACKAGES) -c $< %.cmi: %.mli ocamlfind ocamlc $(SAFESTRING) -package $(PACKAGES) -c $< annot_parser.ml: annot_parser.mli annot_parser.mli: annot_parser.mly menhir --infer --explain $< js_parser.ml: js_parser.mli js_parser.mli: js_parser.mly menhir --infer --external-tokens Js_token --explain $< %.ml: %.mll ocamllex $< clean: rm -f *.cm[aiox] *.cmxa *.cmxs *.o *.a *.conflicts rm -f compile.opt compile.byte minify.opt minify.byte rm -f $(MINIFIER) $(COMPILER) rm -f compiler_version.ml rm -f annot_lexer.ml annot_parser.ml annot_parser.mli rm -f js_lexer.ml js_parser.ml js_parser.mli rm -Rf man .PHONY: depend depend: compiler_version.ml annot_lexer.ml js_lexer.ml js_parser.ml annot_parser.ml ocamldep *.ml *.mli > .depend include .depend js_of_ocaml-2.5/compiler/annot_lexer.mli000066400000000000000000000016251241254034500204720ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val initial : Lexing.lexbuf -> Annot_parser.token js_of_ocaml-2.5/compiler/annot_lexer.mll000066400000000000000000000031061241254034500204710ustar00rootroot00000000000000{ (* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Annot_parser } let identifier = ['a'-'z''A'-'Z''_']+ rule initial = parse | "Provides" {TProvides} | "Requires" {TRequires} | "pure" {TA_Pure } | "const" {TA_Const } | "mutable" {TA_Mutable } | "mutator" {TA_Mutator } | "shallow" {TA_Shallow} | "Version" {TVersion} | ['a'-'z''A'-'Z''$''_']['a'-'z''A'-'Z''$''_''0'-'9']* { let x = Lexing.lexeme lexbuf in TIdent x} | ['0'-'9']+ ('.' (['0'-'9']+)) * { let x = Lexing.lexeme lexbuf in TVNum x} | "(" {LPARENT} | ")" {RPARENT} | "," {TComma} | ":" {TSemi} | "<=" {LE} | "<" {LT} | ">" {GT} | ">=" {GE} | "=" {EQ} | [' ''\t']+ { initial lexbuf } | eof { EOF } | ['\n'] {EOL} | _ { TOTHER(Lexing.lexeme lexbuf) } js_of_ocaml-2.5/compiler/annot_parser.mly000066400000000000000000000035711241254034500206710ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) %token TProvides TRequires TVersion %token TA_Pure TA_Const TA_Mutable TA_Mutator TA_Shallow %token TIdent TVNum %token TComma TSemi EOF EOL LE LT GE GT EQ LPARENT RPARENT %token TOTHER %start annot %type annot %% annot: | TProvides TSemi id=TIdent opt=option(prim_annot) args=option(delimited(LPARENT, separated_list(TComma,arg_annot),RPARENT)) endline { `Provides (None,id,(match opt with None -> `Mutator | Some k -> k),args) } | TRequires TSemi l=separated_nonempty_list(TComma,TIdent) endline { `Requires (None,l) } | TVersion TSemi l=separated_nonempty_list(TComma,version) endline { `Version (None,l) } prim_annot: | TA_Pure {`Pure} | TA_Const {`Pure} | TA_Mutable {`Mutable} | TA_Mutator {`Mutator} arg_annot: | TA_Const { `Const } | TA_Shallow { `Shallow_const} | TA_Mutable { `Mutable} op: | LE {(<=)} | LT {(<)} | GT {(>)} | GE {(>=)} | EQ {(=)} version: | op TVNum { $1,$2 } endline: | EOL { () } | EOF { () } | TOTHER { failwith $1 } js_of_ocaml-2.5/compiler/code.ml000066400000000000000000000301351241254034500167130ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type addr = int module DebugAddr : sig type dbg = private addr val of_addr : addr -> dbg val to_addr : dbg -> addr val no : dbg end = struct type dbg = int let of_addr (x : addr) = (x : dbg) let no = 0 let to_addr (x : dbg) = (x : addr) end module Var : sig type t val print : Format.formatter -> t -> unit val idx : t -> int val of_idx : int -> t val to_string : ?origin:t -> t -> string val fresh : unit -> t val fork : t -> t val count : unit -> int val compare : t -> t -> int val name : t -> string -> unit val propagate_name : t -> t -> unit val reset : unit -> unit val set_pretty : bool -> unit val dummy : t end = struct open Util type t = int let printer = VarPrinter.create () let last_var = ref 0 let reset () = last_var := 0; VarPrinter.reset printer let to_string ?origin i = VarPrinter.to_string printer ?origin i let print f x = Format.fprintf f "v%d" x (* Format.fprintf f "%s" (to_string x) *) let fresh () = incr last_var; !last_var let count () = !last_var + 1 let idx v = v let of_idx v = v let compare v1 v2 = v1 - v2 let name i nm = VarPrinter.name printer i nm let propagate_name i j = VarPrinter.propagate_name printer i j let set_pretty b = VarPrinter.set_pretty printer b let fork o = let n = fresh () in propagate_name o n; n let dummy = -1 end module VarSet = Set.Make (Var) module VarMap = Map.Make (Var) module VarTbl = struct type 'a t = 'a array type key = Var.t type size = unit let get t x = t.(Var.idx x) let set t x v = t.(Var.idx x) <- v let make () v = Array.make (Var.count ()) v end module VarISet = struct type t = Var.t array type elt = Var.t let iter f t = for i = 0 to Array.length t - 1 do let x = t.(i) in if Var.compare x Var.dummy <> 0 then f x done let mem t x = Var.compare t.(Var.idx x) Var.dummy <> 0 let add t x = t.(Var.idx x) <- x let remove t x = t.(Var.idx x) <- Var.dummy let copy = Array.copy let empty v = Array.make (Var.count ()) Var.dummy end module AddrSet = Util.IntSet module AddrMap = Util.IntMap type cont = addr * Var.t list type prim = Vectlength | Array_get | Extern of string | Not | IsInt | Eq | Neq | Lt | Le | Ult type constant = String of string | IString of string | Float of float | Float_array of float array | Int64 of int64 | Tuple of int * constant array | Int of int32 type prim_arg = Pv of Var.t | Pc of constant type expr = Const of int32 | Apply of Var.t * Var.t list * bool | Block of int * Var.t array | Field of Var.t * int | Closure of Var.t list * cont | Constant of constant | Prim of prim * prim_arg list type instr = Let of Var.t * expr | Set_field of Var.t * int * Var.t | Offset_ref of Var.t * int | Array_set of Var.t * Var.t * Var.t type cond = IsTrue | CEq of int32 | CLt of int32 | CLe of int32 | CUlt of int32 type last = Return of Var.t | Raise of Var.t | Stop | Branch of cont | Cond of cond * Var.t * cont * cont | Switch of Var.t * cont array * cont array | Pushtrap of cont * Var.t * cont * addr | Poptrap of cont type block = { params : Var.t list; handler : (Var.t * cont) option; body : instr list; branch : last } type program = addr * block AddrMap.t * addr (****) let rec print_list pr f l = match l with [] -> () | [x] -> pr f x | x :: r -> Format.fprintf f "%a, %a" pr x (print_list pr) r let print_var_list = print_list Var.print let print_cont f (pc, args) = Format.fprintf f "%d (%a)" pc print_var_list args let rec print_constant f x = match x with String s -> Format.fprintf f "%S" s | IString s -> Format.fprintf f "%S" s | Float fl -> Format.fprintf f "%.12g" fl | Float_array a -> Format.fprintf f "[|"; for i = 0 to Array.length a - 1 do if i > 0 then Format.fprintf f ", "; Format.fprintf f "%.12g" a.(i) done; Format.fprintf f "|]" | Int64 i -> Format.fprintf f "%LdL" i | Tuple (tag, a) -> Format.fprintf f "<%d>" tag; begin match Array.length a with 0 -> () | 1 -> Format.fprintf f "("; print_constant f a.(0); Format.fprintf f ")" | n -> Format.fprintf f "("; print_constant f a.(0); for i = 1 to n - 1 do Format.fprintf f ", "; print_constant f a.(i) done; Format.fprintf f ")" end | Int i -> Format.fprintf f "%ld" i let print_arg f a = match a with Pv x -> Var.print f x | Pc c -> print_constant f c let binop s = match s with "%int_add" -> "+" | "%int_sub" -> "-" | "%int_mul" -> "*" | "%int_div" -> "/" | "%int_mod" -> "%" | "%int_and" -> "&" | "%int_or" -> "|" | "%int_xor" -> "^" | "%int_lsl" -> "<<" | "%int_lsr" -> ">>>" | "%int_asr" -> ">>" | _ -> raise Not_found let unop s = match s with "%int_neg" -> "-" | _ -> raise Not_found let print_prim f p l = match p, l with Vectlength, [x] -> Format.fprintf f "%a.length" print_arg x | Array_get, [x; y] -> Format.fprintf f "%a[%a]" print_arg x print_arg y | Extern s, [x; y] -> begin try Format.fprintf f "%a %s %a" print_arg x (binop s) print_arg y with Not_found -> Format.fprintf f "\"%s\"(%a)" s (print_list print_arg) l end | Extern s, [x] -> begin try Format.fprintf f "%s %a" (unop s) print_arg x with Not_found -> Format.fprintf f "\"%s\"(%a)" s (print_list print_arg) l end | Extern s, _ -> Format.fprintf f "\"%s\"(%a)" s (print_list print_arg) l | Not, [x] -> Format.fprintf f "!%a" print_arg x | IsInt, [x] -> Format.fprintf f "is_int(%a)" print_arg x | Eq, [x; y] -> Format.fprintf f "%a === %a" print_arg x print_arg y | Neq, [x; y] -> Format.fprintf f "!(%a === %a)" print_arg x print_arg y | Lt, [x; y] -> Format.fprintf f "%a < %a" print_arg x print_arg y | Le, [x; y] -> Format.fprintf f "%a <= %a" print_arg x print_arg y | Ult, [x; y] -> Format.fprintf f "%a <= %a" print_arg x print_arg y | _ -> assert false let print_expr f e = match e with Const i -> Format.fprintf f "%ld" i | Apply (g, l, exact) -> if exact then Format.fprintf f "%a!(%a)" Var.print g print_var_list l else Format.fprintf f "%a(%a)" Var.print g print_var_list l | Block (t, a) -> Format.fprintf f "{tag=%d" t; for i = 0 to Array.length a - 1 do Format.fprintf f "; %d = %a" i Var.print a.(i) done; Format.fprintf f "}" | Field (x, i) -> Format.fprintf f "%a[%d]" Var.print x i | Closure (l, cont) -> Format.fprintf f "fun(%a){%a}" print_var_list l print_cont cont | Constant c -> Format.fprintf f "CONST{%a}" print_constant c | Prim (p, l) -> print_prim f p l let print_instr f i = match i with Let (x, e) -> Format.fprintf f "%a = %a" Var.print x print_expr e | Set_field (x, i, y) -> Format.fprintf f "%a[%d] = %a" Var.print x i Var.print y | Offset_ref (x, i) -> Format.fprintf f "%a[0] += %d" Var.print x i | Array_set (x, y, z) -> Format.fprintf f "%a[%a] = %a" Var.print x Var.print y Var.print z let print_cond f (c, x) = match c with IsTrue -> Var.print f x | CEq n -> Format.fprintf f "%ld = %a" n Var.print x | CLt n -> Format.fprintf f "%ld < %a" n Var.print x | CLe n -> Format.fprintf f "%ld <= %a" n Var.print x | CUlt n -> Format.fprintf f "%ld < %a" n Var.print x let print_last f l = match l with Return x -> Format.fprintf f "return %a" Var.print x | Raise x -> Format.fprintf f "raise %a" Var.print x | Stop -> Format.fprintf f "stop" | Branch cont -> Format.fprintf f "branch %a" print_cont cont | Cond (cond, x, cont1, cont2) -> Format.fprintf f "if %a then %a else %a" print_cond (cond, x) print_cont cont1 print_cont cont2 | Switch (x, a1, a2) -> Format.fprintf f "switch %a {" Var.print x; Array.iteri (fun i cont -> Format.fprintf f "int %d -> %a; " i print_cont cont) a1; Array.iteri (fun i cont -> Format.fprintf f "tag %d -> %a; " i print_cont cont) a2; Format.fprintf f "}" | Pushtrap (cont1, x, cont2, pc) -> Format.fprintf f "pushtrap %a handler %a => %a continuation %d" print_cont cont1 Var.print x print_cont cont2 pc | Poptrap cont -> Format.fprintf f "poptrap %a" print_cont cont type xinstr = Instr of instr | Last of last let print_block annot pc block = Format.eprintf "==== %d (%a) ====@." pc print_var_list block.params; begin match block.handler with Some (x, cont) -> Format.eprintf " handler %a => %a@." Var.print x print_cont cont | None -> () end; List.iter (fun i -> Format.eprintf " %s %a@." (annot pc (Instr i)) print_instr i) block.body; Format.eprintf " %s %a@." (annot pc (Last block.branch)) print_last block.branch; Format.eprintf "@." let print_program annot (pc, blocks, _) = Format.eprintf "Entry point: %d@.@." pc; AddrMap.iter (print_block annot) blocks (****) let fold_closures (pc, blocks, _) f accu = AddrMap.fold (fun _ block accu -> List.fold_left (fun accu i -> match i with Let (x, Closure (params, cont)) -> f (Some x) params cont accu | _ -> accu) accu block.body) blocks (f None [] (pc, []) accu) (****) let prepend (start, blocks, free_pc) body = let new_start = free_pc in let blocks = AddrMap.add new_start { params = []; handler = None; body = body; branch = Branch (start, []) } blocks in let free_pc = free_pc + 1 in (new_start, blocks, free_pc) let (>>) x f = f x let fold_children blocks pc f accu = let block = AddrMap.find pc blocks in let accu = match block.handler with Some (_, (pc, _)) -> f pc accu | None -> accu in match block.branch with Return _ | Raise _ | Stop -> accu | Branch (pc', _) | Poptrap (pc', _) | Pushtrap ((pc', _), _, _, _) -> f pc' accu | Cond (_, _, (pc1, _), (pc2, _)) -> f pc1 accu >> f pc1 >> f pc2 | Switch (_, a1, a2) -> accu >> Array.fold_right (fun (pc, _) accu -> f pc accu) a1 >> Array.fold_right (fun (pc, _) accu -> f pc accu) a2 let rec traverse' fold f pc visited blocks acc = if not (AddrSet.mem pc visited) then begin let visited = AddrSet.add pc visited in let (visited, acc) = fold blocks pc (fun pc (visited, acc) -> let (visited, acc) = traverse' fold f pc visited blocks acc in (visited, acc)) (visited, acc) in let acc = f pc acc in (visited, acc) end else (visited, acc) let traverse fold f pc blocks acc = snd (traverse' fold f pc AddrSet.empty blocks acc) let eq (pc1, blocks1, _) (pc2, blocks2, _) = pc1 = pc2 && AddrMap.cardinal blocks1 = AddrMap.cardinal blocks2 && AddrMap.fold (fun pc block1 b -> b && try let block2 = AddrMap.find pc blocks2 in block1.params = block2.params && block1.branch = block2.branch && block1.body = block2.body with Not_found -> false ) blocks1 true js_of_ocaml-2.5/compiler/code.mli000066400000000000000000000102251241254034500170620ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type addr = int module DebugAddr : sig type dbg = private int val of_addr : addr -> dbg val to_addr : dbg -> addr val no : dbg end module Var : sig type t val print : Format.formatter -> t -> unit val idx : t -> int val of_idx : int -> t val to_string : ?origin:t -> t -> string val fresh : unit -> t val fork : t -> t val count : unit -> int val compare : t -> t -> int val name : t -> string -> unit val propagate_name : t -> t -> unit val reset : unit -> unit val set_pretty : bool -> unit end module VarSet : Set.S with type elt = Var.t module VarMap : Map.S with type key = Var.t module VarTbl : sig type 'a t type key = Var.t type size = unit val get : 'a t -> key -> 'a val set : 'a t -> key -> 'a -> unit val make : size -> 'a -> 'a t end module VarISet : sig type t type elt = Var.t val empty : unit -> t val iter : (elt -> unit) -> t -> unit val mem : t -> elt -> bool val add : t -> elt -> unit val remove : t -> elt -> unit val copy : t -> t end module AddrSet : Set.S with type elt = addr and type t = Util.IntSet.t module AddrMap : Map.S with type key = addr and type 'a t = 'a Util.IntMap.t type cont = addr * Var.t list type prim = Vectlength | Array_get | Extern of string | Not | IsInt | Eq | Neq | Lt | Le | Ult type constant = String of string | IString of string | Float of float | Float_array of float array | Int64 of int64 | Tuple of int * constant array | Int of int32 type prim_arg = Pv of Var.t | Pc of constant type expr = Const of int32 | Apply of Var.t * Var.t list * bool (* if true, then # of arguments = # of parameters *) | Block of int * Var.t array | Field of Var.t * int | Closure of Var.t list * cont | Constant of constant (*XXX REMOVE *) | Prim of prim * prim_arg list (*XXX prim * Var.t list * constant list *) type instr = Let of Var.t * expr | Set_field of Var.t * int * Var.t | Offset_ref of Var.t * int | Array_set of Var.t * Var.t * Var.t (*XXX REMOVE *) type cond = IsTrue | CEq of int32 | CLt of int32 | CLe of int32 | CUlt of int32 type last = Return of Var.t | Raise of Var.t | Stop | Branch of cont | Cond of cond * Var.t * cont * cont | Switch of Var.t * cont array * cont array | Pushtrap of cont * Var.t * cont * addr | Poptrap of cont type block = { params : Var.t list; handler : (Var.t * cont) option; body : instr list; branch : last } type program = addr * block AddrMap.t * addr type xinstr = Instr of instr | Last of last val print_var_list : Format.formatter -> Var.t list -> unit val print_instr : Format.formatter -> instr -> unit val print_block : (AddrMap.key -> xinstr -> string) -> int -> block -> unit val print_program : (AddrMap.key -> xinstr -> string) -> program -> unit val fold_closures : program -> (Var.t option -> Var.t list -> cont -> 'd -> 'd) -> 'd -> 'd val fold_children : block AddrMap.t -> addr -> (addr -> 'c -> 'c) -> 'c -> 'c val traverse : (block AddrMap.t -> addr -> (addr -> (AddrSet.t * 'c) -> (AddrSet.t * 'c)) -> (AddrSet.t * 'c) -> (AddrSet.t * 'c)) -> (addr -> 'c -> 'c) -> addr -> block AddrMap.t -> 'c -> 'c val prepend : program -> instr list -> program val eq : program -> program -> bool js_of_ocaml-2.5/compiler/commonArg.ml000066400000000000000000000054441241254034500177300ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2014 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Cmdliner type 'a on_off = { enable : 'a; disable : 'a; } type t = { debug : string list on_off; optim : string list on_off; } let debug = let doc = "enable debug [$(docv)]." in let all = List.map (fun s -> s,s) (Option.Debug.available ()) in let arg = Arg.(value & opt_all (list (enum all)) [] & info ["debug"] ~docv:"SECTION" ~doc) in Term.(pure List.flatten $ arg) let enable = let doc = "Enable optimization [$(docv)]." in let all = List.map (fun s -> s,s) (Option.Optim.available ()) in let arg = Arg.(value & opt_all (list (enum all)) [] & info ["enable"] ~docv:"OPT" ~doc) in Term.(pure List.flatten $ arg) let disable = let doc = "Disable optimization [$(docv)]." in let all = List.map (fun s -> s,s) (Option.Optim.available ()) in let arg = Arg.(value & opt_all (list (enum all)) [] & info ["disable"] ~docv:"OPT" ~doc) in Term.(pure List.flatten $ arg) let pretty = let doc = "Pretty print the output." in Arg.(value & flag & info ["pretty"] ~doc) let debuginfo = let doc = "Output debug information." in Arg.(value & flag & info ["debuginfo";"debug-info"] ~doc) let noinline = let doc = "Disable inlining." in Arg.(value & flag & info ["noinline";"no-inline"] ~doc) let t = Term.( pure (fun debug enable disable pretty debuginfo noinline -> let enable = if pretty then "pretty"::enable else enable in let enable = if debuginfo then "debuginfo"::enable else enable in let disable = if noinline then "inline"::disable else disable in { debug = { enable = debug; disable = [] }; optim = { enable; disable } } ) $ debug $ enable $ disable $ pretty $ debuginfo $ noinline ) let on_off on off t = List.iter on t.enable; List.iter off t.disable let eval t = Option.Optim.(on_off enable disable t.optim); Option.Debug.(on_off enable disable t.debug) js_of_ocaml-2.5/compiler/commonArg.mli000066400000000000000000000020201241254034500200640ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2014 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type 'a on_off = { enable : 'a; disable : 'a; } type t = { debug : string list on_off; optim : string list on_off; } val t : t Cmdliner.Term.t val eval : t -> unit js_of_ocaml-2.5/compiler/compile.ml000066400000000000000000000132041241254034500174270ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let times = Option.Debug.find "times" let _ = Sys.catch_break true let temp_file_name = (* Inlined unavailable Filename.temp_file_name. Filename.temp_file gives us incorrect permissions. https://github.com/ocsigen/js_of_ocaml/issues/182 *) let prng = lazy(Random.State.make_self_init ()) in fun ~temp_dir prefix suffix -> let rnd = (Random.State.bits (Lazy.force prng)) land 0xFFFFFF in Filename.concat temp_dir (Printf.sprintf "%s%06x%s" prefix rnd suffix) let gen_file file f = let f_tmp = temp_file_name ~temp_dir:(Filename.dirname file) (Filename.basename file) ".tmp" in try let ch = open_out_bin f_tmp in (try f ch with e -> close_out ch; raise e); close_out ch; (try Sys.remove file with Sys_error _ -> ()); Sys.rename f_tmp file; with exc -> Sys.remove f_tmp; raise exc let f { CompileArg.common; profile; source_map; runtime_files; input_file; output_file; params ; linkall; toplevel; nocmis; include_dir; fs_files; fs_output; fs_external } = CommonArg.eval common; List.iter (fun (s,v) -> Option.Param.set s v) params; let t = Util.Timer.make () in Linker.load_files runtime_files; let paths = List.rev_append include_dir [Util.find_pkg_dir "stdlib"] in let t1 = Util.Timer.make () in if times () then Format.eprintf "Start parsing...@."; let need_debug = if source_map <> None || Option.Optim.debuginfo () then `Full else if Option.Optim.pretty () then `Names else `No in let p, cmis, d = match input_file with None -> Parse_bytecode.from_channel ~toplevel ~debug:need_debug stdin | Some f -> let ch = open_in_bin f in let p,cmis,d = Parse_bytecode.from_channel ~toplevel ~debug:need_debug ch in close_in ch; p, cmis, d in let cmis = if nocmis then Util.StringSet.empty else cmis in let p = if fs_external then let instrs = [ Code.(Let(Var.fresh (), Prim (Extern "caml_fs_init", []))) ] in Code.prepend p instrs else p in if times () then Format.eprintf " parsing: %a@." Util.Timer.print t1; begin match output_file with | None -> let p = PseudoFs.f p cmis fs_files paths in let fmt = Pretty_print.to_out_channel stdout in Driver.f ?profile ~toplevel ~linkall ?source_map fmt d p | Some file -> gen_file file (fun chan -> let p = if fs_output = None then PseudoFs.f p cmis fs_files paths else p in let fmt = Pretty_print.to_out_channel chan in Driver.f ?profile ~toplevel ~linkall ?source_map fmt d p; ); Util.opt_iter (fun file -> gen_file file (fun chan -> let pfs = PseudoFs.f_empty cmis fs_files paths in let pfs_fmt = Pretty_print.to_out_channel chan in Driver.f ?profile pfs_fmt d pfs ) ) fs_output end; if times () then Format.eprintf "compilation: %a@." Util.Timer.print t let main = Cmdliner.Term.(pure f $ CompileArg.options), CompileArg.info let _ = Util.Timer.init Sys.time; try Cmdliner.Term.eval ~catch:false ~argv:(Util.normalize_argv ~warn:true Sys.argv) main with | (Match_failure _ | Assert_failure _ | Not_found) as exc -> let backtrace = Printexc.get_backtrace () in Format.eprintf "%s: You found a bug. \ Please report it at https://github.com/ocsigen/js_of_ocaml/issues :@." Sys.argv.(0); Format.eprintf "Error: %s@." (Printexc.to_string exc); prerr_string backtrace; exit 1 | Util.MagicNumber.Bad_magic_number s -> Format.eprintf "%s: Error: Not an ocaml executable bytecode@." Sys.argv.(0); Format.eprintf "%s: Error: Invalid magic number %S, expecting %S@." Sys.argv.(0) s Util.MagicNumber.(to_string current); exit 1 | Util.MagicNumber.Bad_magic_version h -> Format.eprintf "%s: Error: Bytecode version missmatch. Got version %S, expecting %S.@." Sys.argv.(0) Util.MagicNumber.(to_string h) Util.MagicNumber.(to_string current); let comp = if Util.MagicNumber.(compare h current) < 0 then "an older" else "a newer" in Format.eprintf "%s: Error: Your program and the js_of_ocaml compiler have to be compiled with the same version of ocaml.@." Sys.argv.(0); Format.eprintf "%s: Error: The Js_of_ocaml compiler has been compiled with ocaml version %s.@." Sys.argv.(0) Sys.ocaml_version; Format.eprintf "%s: Error: Its seems that your program has been compiled with %s version of ocaml.@." Sys.argv.(0) comp; exit 1 | Failure s -> Format.eprintf "%s: Error: %s@." Sys.argv.(0) s; exit 1 | exc -> let backtrace = Printexc.get_backtrace () in Format.eprintf "%s: Error: %s@." Sys.argv.(0) (Printexc.to_string exc); prerr_string backtrace; exit 1 js_of_ocaml-2.5/compiler/compileArg.ml000066400000000000000000000162101241254034500200610ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2014 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Cmdliner type t = { common : CommonArg.t; (* compile option *) profile : Driver.profile option; source_map : (string * Source_map.t) option; runtime_files : string list; output_file : string option; input_file : string option; params : (string * string) list; (* toplevel *) linkall : bool; toplevel : bool; nocmis : bool; (* filesystem *) include_dir : string list; fs_files : string list; fs_output : string option; fs_external : bool; } exception Error of (bool * string) let options = let toplevel_section = "OPTIONS (TOPLEVEL)" in let filesystem_section = "OPTIONS (FILESYSTEM)" in let js_files = let doc = "Link JavaScript files [$(docv)]. " ^ "One can refer to path relative to Findlib packages with " ^ "the syntax '+pkg_name/file.js'" in Arg.(value & pos_left ~rev:true 0 string [] & info [] ~docv:"JS_FILES" ~doc) in let output_file = let doc = "Set output file name to [$(docv)]." in Arg.(value & opt (some string) None & info ["o"] ~docv:"FILE" ~doc) in let input_file = let doc = "Compile the bytecode program [$(docv)]. " ^ "Use '-' to read from the standard input instead." in Arg.(required & pos ~rev:true 0 (some string) None & info [] ~docv:"PROGRAM" ~doc) in let profile = let doc = "Set optimization profile : [$(docv)]." in let profile = List.map (fun (i,p) -> string_of_int i, p) Driver.profiles in Arg.(value & opt (some (enum profile)) None & info ["opt"] ~docv:"NUM" ~doc) in let noruntime = let doc = "Do not include the standard runtime." in Arg.(value & flag & info ["noruntime";"no-runtime"] ~doc) in let sourcemap = let doc = "Generate source map." in Arg.(value & flag & info ["sourcemap";"source-map"] ~doc) in let set_param = let doc = "Set compiler options." in let all = List.map (fun (x,_) -> x, x) (Option.Param.all ()) in Arg.(value & opt_all (list (pair ~sep:'=' (enum all) string)) [] & info ["set"] ~docv:"PARAM=VALUE"~doc) in let toplevel = let doc = "Compile a toplevel." in Arg.(value & flag & info ["toplevel"] ~docs:toplevel_section ~doc) in let linkall = let doc = "Link all primitives." in Arg.(value & flag & info ["linkall"] ~docs:toplevel_section ~doc) in let nocmis = let doc = "Do not include cmis when compiling toplevel." in Arg.(value & flag & info ["nocmis";"no-cmis"] ~docs:toplevel_section ~doc) in let include_dir = let doc = "Add [$(docv)] to the list of include directories." in Arg.(value & opt_all string [] & info ["I"] ~docs:filesystem_section ~docv:"DIR" ~doc) in let fs_files = let doc = "Register [$(docv)] to the pseudo filesystem." in Arg.(value & opt_all string [] & info ["file"] ~docs:filesystem_section ~docv:"FILE" ~doc) in let fs_external = let doc = "Configure pseudo-filesystem to allow registering files from outside." in Arg.(value & flag & info ["extern-fs"] ~docs:filesystem_section ~doc) in let fs_output = let doc = "Output the filesystem to [$(docv)]." in Arg.(value & opt (some string) None & info ["ofs"] ~docs:filesystem_section ~docv:"FILE" ~doc) in let build_t common set_param linkall toplevel include_dir fs_files fs_output fs_external nocmis profile noruntime sourcemap output_file input_file js_files = let chop_extension s = try Filename.chop_extension s with Invalid_argument _ -> s in try let runtime_files = js_files in let runtime_files = if noruntime then runtime_files else "+runtime.js"::runtime_files in let linkall = linkall || toplevel in let fs_external = fs_external || (toplevel && nocmis) in let input_file = match input_file with | "-" -> None | x -> Some x in let output_file = match output_file with | Some _ -> output_file | None -> Util.opt_map (fun s -> chop_extension s ^ ".js") input_file in let source_map = if sourcemap then match output_file with | Some file -> Some ( chop_extension file ^ ".map", { Source_map.version = 3; file; sourceroot = None; sources = []; sources_content = []; names = []; mappings = [] }) | None -> raise (Error (false, "Don't know where to output the Source-map file.")) else None in let params : (string * string) list = List.flatten set_param in `Ok { common; params; profile; linkall; toplevel; include_dir; runtime_files; fs_files; fs_output; fs_external; nocmis; output_file; input_file; source_map } with Error (b,str) -> `Error (b,str) in let t = Term.(pure build_t $ CommonArg.t $ set_param $ linkall $ toplevel $ include_dir $ fs_files $ fs_output $ fs_external $ nocmis $ profile $ noruntime $ sourcemap $ output_file $ input_file $ js_files) in Term.ret t let info = let doc = "Js_of_ocaml compiler" in let man = [ `S "DESCRIPTION"; `P "Js_of_ocaml is a compiler from OCaml bytecode to Javascript. \ It makes OCaml programs run on Web browsers."; `S "BUGS"; `P "Bugs are tracked on github at \ $(i,https://github.com/ocsigen/js_of_ocaml/issues)."; `S "SEE ALSO"; `P "ocaml(1)"; `S "AUTHORS"; `P "Jerome Vouillon, Hugo Heuzard."; `S "LICENSE"; `P "Copyright (C) 2010-2014."; `P "js_of_ocaml is free software, you can redistribute it and/or modify \ it under the terms of the GNU Lesser General Public License as published \ by the Free Software Foundation, with linking exception; \ either version 2.1 of the License, or (at your option) any later version." ] in let version = match Compiler_version.git_version with | "" -> Compiler_version.s | v -> Printf.sprintf "%s+git-%s"Compiler_version.s v in Term.info "js_of_ocaml" ~version ~doc ~man js_of_ocaml-2.5/compiler/compileArg.mli000066400000000000000000000025631241254034500202400ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2014 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t = { common : CommonArg.t; (* compile option *) profile : Driver.profile option; source_map : (string * Source_map.t) option; runtime_files : string list; output_file : string option; input_file : string option; params : (string * string) list; (* toplevel *) linkall : bool; toplevel : bool; nocmis : bool; (* filesystem *) include_dir : string list; fs_files : string list; fs_output : string option; fs_external : bool; } val options : t Cmdliner.Term.t val info : Cmdliner.Term.info js_of_ocaml-2.5/compiler/compiler_version.mli000066400000000000000000000017041241254034500215310ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2014 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val s : string val git_version : string js_of_ocaml-2.5/compiler/control.ml000066400000000000000000000204671241254034500174700ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) (* FIX: is there a way to merge this with dead code elimination? *) open Code (****) (* Postorder traversal of the whole program. *) let traverse blocks pc f accu = let rec traverse_rec visited pc accu = if AddrSet.mem pc visited then (visited, accu) else begin let visited = AddrSet.add pc visited in let block = AddrMap.find pc blocks in let (visited, accu) = List.fold_left (fun ((visited, accu) as p) i -> match i with Let (_, Closure (_, (pc, _))) -> traverse_rec visited pc accu | _ -> p) (visited, accu) block.body in let (visited, accu) = match block.branch with Return _ | Raise _ | Stop -> (visited, accu) | Branch (pc, _) | Poptrap (pc, _) -> traverse_rec visited pc accu | Cond (_, _, (pc1, _), (pc2, _)) -> let (visited, accu) = traverse_rec visited pc1 accu in traverse_rec visited pc2 accu | Switch (_, a1, a2) -> let (visited, accu) = Array.fold_left (fun (visited, accu) (pc, _) -> traverse_rec visited pc accu) (visited, accu) a1 in let (visited, accu) = Array.fold_left (fun (visited, accu) (pc, _) -> traverse_rec visited pc accu) (visited, accu) a2 in (visited, accu) | Pushtrap ((pc1, _), _, (pc2, _), _) -> let (visited, accu) = traverse_rec visited pc1 accu in traverse_rec visited pc2 accu in (visited, f pc accu) end in snd (traverse_rec AddrSet.empty pc accu) (****) let is_trivial instr last = instr = [] && begin match last with Return _ | Raise _ | Stop | Branch _ -> true | Cond _ | Poptrap _ | Switch _ | Pushtrap _ -> false end let resolve_branch blocks (pc, args) = match AddrMap.find pc blocks with {params = []; body = []; branch = Branch (pc', args')} -> Some (pc', args') | _ -> None let concat_blocks pc instr params handler args params' instr' last' = (* This is only valid because we know that the params only occur in the block *) let m = Subst.build_mapping params' args in let s = Subst.from_map m in { params = params; handler = handler; body = instr @ Subst.instrs s instr'; branch = Subst.last s last' } let rec block_simpl pc (preds, entries, blocks) = Format.eprintf "VV %d@." pc; (* Format.eprintf "RRRRRRRRRRRRRRR %d@." (AddrSet.cardinal (AddrMap.find 12644 preds)); *) let block = AddrMap.find pc blocks in match block.branch with Return _ | Raise _ | Stop | Poptrap _ -> (preds, entries, blocks) | Branch (pc', args) -> let block' = AddrMap.find pc' blocks in if false (*XXX FIX! not (AddrSet.mem pc' entries) && AddrSet.cardinal (AddrMap.find pc' preds) = 1 && block'.params = [] && block'.handler = block.handler *) then begin Format.eprintf "UU %d ==> %d@." pc pc'; (preds, entries, AddrMap.add pc (concat_blocks pc block.body block.params block.handler args block'.params block'.body block'.branch) (AddrMap.remove pc' blocks)) end else if false(*XXX args = [] && is_trivial block'.body block'.branch *)then begin (AddrMap.add pc' (AddrSet.remove pc (AddrMap.find pc' preds)) preds, entries, AddrMap.add pc (concat_blocks pc block.body block.params block.handler args block'.params block'.body block'.branch) blocks) end else (preds, entries, blocks) | Cond (c, x, cont1, cont2) -> if cont1 = cont2 then begin let blocks = AddrMap.add pc {block with branch = Branch cont1 } blocks in block_simpl pc (preds, entries, blocks) end else begin match resolve_branch blocks cont1 with Some cont1' -> let pc1 = fst cont1 in let pc1' = fst cont1' in let preds = AddrMap.add pc1' (AddrSet.add pc (AddrSet.remove pc1 (AddrMap.find pc1' preds))) preds in let blocks = AddrMap.add pc { block with branch = Cond (c, x, cont1', cont2) } blocks in block_simpl pc (preds, entries, blocks) | None -> match resolve_branch blocks cont2 with Some cont2' -> let pc2 = fst cont2 in let pc2' = fst cont2' in let preds = AddrMap.add pc2' (AddrSet.add pc (AddrSet.remove pc2 (AddrMap.find pc2' preds))) preds in let blocks = AddrMap.add pc { block with branch = Cond (c, x, cont1, cont2') } blocks in block_simpl pc (preds, entries, blocks) | None -> (preds, entries, blocks) end | Switch (x, a1, a2) -> let a1 = Array.map (fun pc -> match resolve_branch blocks pc with Some pc -> pc | None -> pc) a1 in let a2 = Array.map (fun pc -> match resolve_branch blocks pc with Some pc -> pc | None -> pc) a2 in (preds, entries, AddrMap.add pc { block with branch = Switch (x, a1, a2) } blocks) | Pushtrap _ -> (preds, entries, blocks) let simpl (pc, blocks, free_pc) = let preds = AddrMap.map (fun _ -> AddrSet.empty) blocks in let entries = AddrSet.empty in let add_pred pc (pc', _) preds = Format.eprintf "%d ==> %d@." pc pc'; AddrMap.add pc' (AddrSet.add pc (AddrMap.find pc' preds)) preds in let (preds, entries) = AddrMap.fold (fun pc block (preds, entries) -> let entries = List.fold_left (fun entries i -> match i with Let (_, Closure (_, (pc, _))) -> AddrSet.add pc entries | _ -> entries) entries block.body in let preds = match block.branch with Return _ | Raise _ | Stop -> preds | Branch cont | Poptrap cont -> add_pred pc cont preds | Cond (_, _, cont1, cont2) | Pushtrap (cont1, _, cont2, _) -> add_pred pc cont1 (add_pred pc cont2 preds) | Switch (_, a1, a2) -> let preds = Array.fold_left (fun preds cont -> add_pred pc cont preds) preds a1 in let preds = Array.fold_left (fun preds cont -> add_pred pc cont preds) preds a2 in preds in (preds, entries)) blocks (preds, entries) in (* Format.eprintf "RRRRRRRRRRRRRRR %d@." (AddrSet.cardinal (AddrMap.find 12644 preds));*) let (_, _, blocks) = traverse blocks pc block_simpl (preds, entries, blocks) in (pc, blocks, free_pc) js_of_ocaml-2.5/compiler/control.mli000066400000000000000000000017051241254034500176330ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val simpl : Code.program -> Code.program js_of_ocaml-2.5/compiler/deadcode.ml000066400000000000000000000171331241254034500175340ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let debug = Option.Debug.find "deadcode" let times = Option.Debug.find "times" open Code type def = Expr of expr | Var of Var.t type t = { blocks : block AddrMap.t; live : int array; defs : def list array; mutable reachable_blocks : AddrSet.t; pure_funs : VarSet.t } (****) let pure_expr pure_funs e = Pure_fun.pure_expr pure_funs e && Option.Optim.deadcode () (****) let rec mark_var st x = let x = Var.idx x in st.live.(x) <- st.live.(x) + 1; if st.live.(x) = 1 then List.iter (fun e -> mark_def st e) st.defs.(x) and mark_def st d = match d with Var x -> mark_var st x | Expr e -> if pure_expr st.pure_funs e then mark_expr st e and mark_expr st e = match e with Const _ | Constant _ -> () | Apply (f, l, _) -> mark_var st f; List.iter (fun x -> mark_var st x) l | Block (_, a) -> Array.iter (fun x -> mark_var st x) a | Field (x, _) -> mark_var st x | Closure (_, (pc, _)) -> mark_reachable st pc | Prim (_, l) -> List.iter (fun x -> match x with Pv x -> mark_var st x | _ -> ()) l and mark_cont_reachable st (pc, param) = mark_reachable st pc and mark_reachable st pc = if not (AddrSet.mem pc st.reachable_blocks) then begin st.reachable_blocks <- AddrSet.add pc st.reachable_blocks; let block = AddrMap.find pc st.blocks in List.iter (fun i -> match i with Let (_, e) -> if not (pure_expr st.pure_funs e) then mark_expr st e | Set_field (x, _, y) -> mark_var st x; mark_var st y | Array_set (x, y, z) -> mark_var st x; mark_var st y; mark_var st z | Offset_ref (x, _) -> mark_var st x) block.body; match block.branch with Return x | Raise x -> mark_var st x | Stop -> () | Branch cont | Poptrap cont -> mark_cont_reachable st cont | Cond (_, x, cont1, cont2) -> mark_var st x; mark_cont_reachable st cont1; mark_cont_reachable st cont2 | Switch (x, a1, a2) -> mark_var st x; Array.iter (fun cont -> mark_cont_reachable st cont) a1; Array.iter (fun cont -> mark_cont_reachable st cont) a2 | Pushtrap (cont1, _, cont2, _) -> mark_cont_reachable st cont1; mark_cont_reachable st cont2 end (****) let live_instr st i = match i with Let (x, e) -> st.live.(Var.idx x) > 0 || not (pure_expr st.pure_funs e) | Set_field _ | Offset_ref _ | Array_set _ -> true let rec filter_args st pl al = match pl, al with x :: pl, y :: al -> if st.live.(Var.idx x) > 0 then y :: filter_args st pl al else filter_args st pl al | [], _ -> [] | _ -> assert false let filter_cont blocks st (pc, args) = let params = (AddrMap.find pc blocks).params in (pc, filter_args st params args) let filter_closure blocks st i = match i with Let (x, Closure (l, cont)) -> Let (x, Closure (l, filter_cont blocks st cont)) | _ -> i let filter_live_last blocks st l = match l with Return _ | Raise _ | Stop -> l | Branch cont -> Branch (filter_cont blocks st cont) | Cond (c, x, cont1, cont2) -> Cond (c, x, filter_cont blocks st cont1, filter_cont blocks st cont2) | Switch (x, a1, a2) -> Switch (x, Array.map (fun cont -> filter_cont blocks st cont) a1, Array.map (fun cont -> filter_cont blocks st cont) a2) | Pushtrap (cont1, x, cont2, pc) -> Pushtrap (filter_cont blocks st cont1, x, filter_cont blocks st cont2, if AddrSet.mem pc st.reachable_blocks then pc else -1) | Poptrap cont -> Poptrap (filter_cont blocks st cont) (****) let ref_count st i = match i with Let (x, _) -> st.live.(Var.idx x) | _ -> 0 let annot st pc xi = if not (AddrSet.mem pc st.reachable_blocks) then "x" else match xi with Last _ -> " " | Instr i -> let c = ref_count st i in if c > 0 then Format.sprintf "%d" c else if live_instr st i then " " else "x" (****) let add_def defs x i = let idx = Var.idx x in defs.(idx) <- i :: defs.(idx) let rec add_arg_dep defs params args = match params, args with x :: params, y :: args -> add_def defs x (Var y); add_arg_dep defs params args | _ -> () let add_cont_dep blocks defs (pc, args) = match try Some (AddrMap.find pc blocks) with Not_found -> None with Some block -> add_arg_dep defs block.params args | None -> () (* Dead continuation *) let f ((pc, blocks, free_pc) as program) = let t = Util.Timer.make () in let nv = Var.count () in let defs = Array.make nv [] in let live = Array.make nv 0 in let pure_funs = Pure_fun.f program in AddrMap.iter (fun _ block -> List.iter (fun i -> match i with Let (x, e) -> add_def defs x (Expr e) | Set_field (x, _, _) | Array_set (x, _, _) | Offset_ref (x, _) -> ()) block.body; Util.opt_iter (fun (_, cont) -> add_cont_dep blocks defs cont) block.handler; match block.branch with Return _ | Raise _ | Stop -> () | Branch cont -> add_cont_dep blocks defs cont | Cond (_, _, cont1, cont2) -> add_cont_dep blocks defs cont1; add_cont_dep blocks defs cont2 | Switch (_, a1, a2) -> Array.iter (fun cont -> add_cont_dep blocks defs cont) a1; Array.iter (fun cont -> add_cont_dep blocks defs cont) a2 | Pushtrap (cont, _, _, _) -> add_cont_dep blocks defs cont | Poptrap cont -> add_cont_dep blocks defs cont) blocks; let st = { live = live; defs = defs; blocks = blocks; reachable_blocks = AddrSet.empty; pure_funs = pure_funs } in mark_reachable st pc; if debug () then print_program (fun pc xi -> annot st pc xi) (pc, blocks, free_pc); let all_blocks = blocks in let blocks = AddrMap.fold (fun pc block blocks -> if not (AddrSet.mem pc st.reachable_blocks) then blocks else AddrMap.add pc { params = List.filter (fun x -> st.live.(Var.idx x) > 0) block.params; handler = Util.opt_map (fun (x, cont) -> (x, filter_cont all_blocks st cont)) block.handler; body = List.map (fun i -> filter_closure all_blocks st i) (List.filter (fun i -> live_instr st i) block.body); branch = filter_live_last all_blocks st block.branch } blocks) blocks AddrMap.empty in if times () then Format.eprintf " dead code elim.: %a@." Util.Timer.print t; (pc, blocks, free_pc), st.live js_of_ocaml-2.5/compiler/deadcode.mli000066400000000000000000000017151241254034500177040ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val f : Code.program -> Code.program * int array js_of_ocaml-2.5/compiler/dgraph.ml000066400000000000000000000141601241254034500172460ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) module Make (N : sig type t end) (NSet : Set.S with type elt = N.t) (NMap : Map.S with type key = N.t) = struct type t = { domain : NSet.t; fold_children : 'a . (N.t -> 'a -> 'a) -> N.t -> 'a -> 'a } let successors g x = try NMap.find x g with Not_found -> NSet.empty let add_edge g x y = let l = successors g x in NMap.add x (NSet.add y l) g let invert g = let h = NSet.fold (fun x h -> g.fold_children (fun y h -> add_edge h y x) x h) g.domain NMap.empty in { domain = g.domain; fold_children = fun f x a -> NSet.fold f (successors h x) a } module type DOMAIN = sig type t val equal : t -> t -> bool val bot : t end module Solver (D : DOMAIN) = struct let n = ref 0 let m = ref 0 type stack = { stack : N.t Stack.t; mutable set : NSet.t } let is_empty st = Stack.is_empty st.stack let pop st = let x = Stack.pop st.stack in st.set <- NSet.remove x st.set; x let push x st = if not (NSet.mem x st.set) then begin Stack.push x st.stack; st.set <- NSet.add x st.set end let rec iterate g f v w = if is_empty w then v else begin let x = pop w in let a = NMap.find x v in incr m; let b = f v x in let v = NMap.add x b v in if not (D.equal a b) then begin g.fold_children (fun y () -> push y w) x (); iterate g f v w end else iterate g f v w end let rec traverse g visited stack x = if not (NSet.mem x visited) then begin let visited = NSet.add x visited in let visited = g.fold_children (fun y visited -> traverse g visited stack y) x visited in Stack.push x stack; visited end else visited let traverse_all g = let stack = Stack.create () in let visited = NSet.fold (fun x visited -> traverse g visited stack x) g.domain NSet.empty in assert (NSet.equal g.domain visited); stack let f g f = n := 0; m := 0; (* let t1 = Util.Timer.make () in *) let v = NSet.fold (fun x v -> incr n; NMap.add x D.bot v) g.domain NMap.empty in (* let t1 = Util.Timer.get t1 in let t2 = Util.Timer.make () in *) let w = { set = g.domain; stack = traverse_all g } in (* let t2 = Util.Timer.get t2 in let t3 = Util.Timer.make () in *) let res = iterate g f v w in (* let t3 = Util.Timer.get t3 in Format.eprintf "YYY %.2f %.2f %.2f@." t1 t2 t3; Format.eprintf "YYY %d %d (%f)@." !m !n (float !m /. float !n); *) res end end module type ISet = sig type t type elt val iter : (elt -> unit) -> t -> unit val mem : t -> elt -> bool val add : t -> elt -> unit val remove : t -> elt -> unit val copy : t -> t end module type Tbl = sig type 'a t type key type size val get : 'a t -> key -> 'a val set : 'a t -> key -> 'a -> unit val make : size -> 'a -> 'a t end module Make_Imperative (N : sig type t end) (NSet : ISet with type elt = N.t) (NTbl : Tbl with type key = N.t) = struct type t = { domain : NSet.t; iter_children : (N.t -> unit) -> N.t -> unit } let successors g x = NTbl.get g x let add_edge g x y = NTbl.set g x (y :: successors g x) let invert size g = let h = NTbl.make size [] in NSet.iter (fun x -> g.iter_children (fun y -> add_edge h y x) x) g.domain; { domain = g.domain; iter_children = fun f x -> List.iter f (successors h x) } module type DOMAIN = sig type t val equal : t -> t -> bool val bot : t end module Solver (D : DOMAIN) = struct let n = ref 0 let m = ref 0 type stack = { stack : N.t Stack.t; mutable set : NSet.t } let is_empty st = Stack.is_empty st.stack let pop st = let x = Stack.pop st.stack in NSet.add st.set x; x let push x st = if NSet.mem st.set x then begin Stack.push x st.stack; NSet.remove st.set x end let rec iterate g f v w = if is_empty w then v else begin let x = pop w in let a = NTbl.get v x in incr m; let b = f v x in NTbl.set v x b; if not (D.equal a b) then begin g.iter_children (fun y -> push y w) x; iterate g f v w end else iterate g f v w end let rec traverse g to_visit stack x = if NSet.mem to_visit x then begin NSet.remove to_visit x; incr n; g.iter_children (fun y -> traverse g to_visit stack y) x; Stack.push x stack end let traverse_all g = let stack = Stack.create () in let to_visit = NSet.copy g.domain in NSet.iter (fun x -> traverse g to_visit stack x) g.domain; { stack = stack; set = to_visit } let f size g f = n := 0; m := 0; (* let t1 = Util.Timer.make () in *) let v = NTbl.make size D.bot in (* let t1 = Util.Timer.get t1 in let t2 = Util.Timer.make () in *) let w = traverse_all g in (* let t2 = Util.Timer.get t2 in let t3 = Util.Timer.make () in *) let res = iterate g f v w in (* let t3 = Util.Timer.get t3 in Format.eprintf "YYY %.2f %.2f %.2f@." t1 t2 t3; Format.eprintf "YYY %d %d (%f)@." !m !n (float !m /. float !n); *) res end end js_of_ocaml-2.5/compiler/dgraph.mli000066400000000000000000000041711241254034500174200ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) module Make (N : sig type t end) (NSet : Set.S with type elt = N.t) (NMap : Map.S with type key = N.t) : sig type t = { domain : NSet.t; fold_children : 'a . (N.t -> 'a -> 'a) -> N.t -> 'a -> 'a } val invert : t -> t module type DOMAIN = sig type t val equal : t -> t -> bool val bot : t end module Solver (D : DOMAIN) : sig val f : t -> (D.t NMap.t -> N.t -> D.t) -> D.t NMap.t end end module type ISet = sig type t type elt val iter : (elt -> unit) -> t -> unit val mem : t -> elt -> bool val add : t -> elt -> unit val remove : t -> elt -> unit val copy : t -> t end module type Tbl = sig type 'a t type key type size val get : 'a t -> key -> 'a val set : 'a t -> key -> 'a -> unit val make : size -> 'a -> 'a t end module Make_Imperative (N : sig type t end) (NSet : ISet with type elt = N.t) (NTbl : Tbl with type key = N.t) : sig type t = { domain : NSet.t; iter_children : (N.t -> unit) -> N.t -> unit } val invert : NTbl.size -> t -> t module type DOMAIN = sig type t val equal : t -> t -> bool val bot : t end module Solver (D : DOMAIN) : sig val f : NTbl.size -> t -> (D.t NTbl.t -> N.t -> D.t) -> D.t NTbl.t end end js_of_ocaml-2.5/compiler/driver.ml000066400000000000000000000311501241254034500172720ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let debug = Option.Debug.find "main" let times = Option.Debug.find "times" open Util let tailcall p = if debug () then Format.eprintf "Tail-call optimization...@."; Tailcall.f p let deadcode' p = if debug () then Format.eprintf "Dead-code...@."; Deadcode.f p let deadcode p = let r,_ = deadcode' p in r let inline p = if Option.Optim.inline () && Option.Optim.deadcode () then let (p,live_vars) = deadcode' p in if debug () then Format.eprintf "Inlining...@."; Inline.f p live_vars else p let specialize_1 (p,info) = if debug () then Format.eprintf "Specialize...@."; Specialize.f info p let specialize_js (p,info) = if debug () then Format.eprintf "Specialize js...@."; Specialize_js.f info p let specialize' (p,info) = let p = specialize_1 (p,info)in let p = specialize_js (p,info) in p,info let specialize p = fst (specialize' p) let eval (p,info) = if Option.Optim.staticeval() then Eval.f info p else p let flow p = if debug () then Format.eprintf "Data flow...@."; Flow.f p let flow_simple p = if debug () then Format.eprintf "Data flow...@."; Flow.f ~skip_param:true p let phi p = if debug () then Format.eprintf "Variable passing simplification...@."; Phisimpl.f p let print p = if debug () then Code.print_program (fun _ _ -> "") p; p let (>>>) x f = f x let (>>) f g = fun x -> g (f x) let rec loop max name round i (p : 'a) : 'a = let p' = round p in if i >= max || Code.eq p' p then p' else begin if times () then Format.eprintf "Start Iteration (%s) %d...@." name i; loop max name round (i+1) p' end let identity x = x (* o1 *) let o1 : 'a -> 'a= print >> tailcall >> flow_simple >> (* flow simple to keep information for furture tailcall opt *) specialize' >> eval >> inline >> (* inlining may reveal new tailcall opt *) deadcode >> tailcall >> phi >> flow >> specialize >> inline >> deadcode >> print >> flow >> specialize >> inline >> deadcode >> phi >> flow >> specialize >> identity (* o2 *) let o2 : 'a -> 'a = loop 10 "o1" o1 1 >> print (* o3 *) let round1 : 'a -> 'a = print >> tailcall >> inline >> (* inlining may reveal new tailcall opt *) deadcode >> (* deadcode required before flow simple -> provided by constant *) flow_simple >> (* flow simple to keep information for furture tailcall opt *) specialize' >> eval >> identity let round2 = flow >> specialize' >> eval >> deadcode >> o1 let o3 = loop 10 "tailcall+inline" round1 1 >> loop 10 "flow" round2 1 >> print let generate d ?toplevel (p,live_vars) = if times () then Format.eprintf "Start Generation...@."; Generate.f p ?toplevel live_vars d let header formatter ~standalone js = if standalone then begin let version = match Compiler_version.git_version with | "" -> Compiler_version.s | v -> Printf.sprintf "%s+git-%s"Compiler_version.s v in Pretty_print.string formatter ("// Generated by js_of_ocaml " ^ version); Pretty_print.newline formatter; end; js let debug_linker = Option.Debug.find "linker" let global_object = Option.global_object let extra_js_files = lazy ( List.fold_left (fun acc file -> try let ss = List.fold_left (fun ss (prov,_,_,_) -> match prov with | Some (_,name,_,_) -> StringSet.add name ss | _ -> ss ) StringSet.empty (Linker.parse_file file) in (file,ss)::acc with _ -> acc ) [] Option.extra_js_files ) let report_missing_primitives missing = let missing = List.fold_left (fun missing (file,pro) -> let d = StringSet.inter missing pro in if not (StringSet.is_empty d) then begin Format.eprintf "Missing primitives provided by %s:@." file; StringSet.iter (fun nm -> Format.eprintf " %s@." nm) d; StringSet.diff missing pro end else missing ) missing (Lazy.force extra_js_files) in Format.eprintf "Missing primitives:@."; StringSet.iter (fun nm -> Format.eprintf " %s@." nm) missing let gen_missing js missing = let open Javascript in let miss = StringSet.fold (fun prim acc -> let p = S {name=prim;var=None} in (p, Some ( ECond(EBin(NotEqEq, EDot(EVar (S {name=global_object;var=None}),prim), EVar(S {name="undefined";var=None})), EDot(EVar (S {name=global_object;var=None}),prim), EFun(None,[],[ Statement( Expression_statement ( ECall(EVar (S {name="caml_failwith";var=None}), [EBin(Plus,EStr(prim,`Utf8), EStr(" not implemented",`Utf8))], N))), N],N) ), N )) :: acc ) missing [] in if not (StringSet.is_empty missing) then begin Format.eprintf "There are some missing primitives@."; Format.eprintf "Dummy implementations (raising 'Failure' exception) "; Format.eprintf "will be used if they are not available at runtime.@."; Format.eprintf "You can prevent the generation of dummy implementations with "; Format.eprintf "the commandline option '-disable genprim'@."; report_missing_primitives missing; end; (Statement (Variable_statement miss), N) :: js let link formatter ~standalone ?linkall js = if standalone then begin let t = Util.Timer.make () in if times () then Format.eprintf "Start Linking...@."; let traverse = new Js_traverse.free in let js = traverse#program js in let free = traverse#get_free_name in let prim = Primitive.get_external () in let prov = Linker.get_provided () in let all_external = StringSet.union prim prov in let used = StringSet.inter free all_external in let linkinfos = Linker.init () in let linkinfos,missing = Linker.resolve_deps ?linkall linkinfos used in (* gen_missing may use caml_failwith *) let linkinfos,missing = if not (StringSet.is_empty missing) && Option.Optim.genprim () then let linkinfos,missing2 = Linker.resolve_deps linkinfos (StringSet.singleton "caml_failwith") in linkinfos, StringSet.union missing missing2 else linkinfos, missing in let js = if Option.Optim.genprim () then gen_missing js missing else js in if times () then Format.eprintf " linking: %a@." Util.Timer.print t; Linker.link js linkinfos end else js let check_js ~standalone js = if standalone then begin let t = Util.Timer.make () in if times () then Format.eprintf "Start Checks...@."; let traverse = new Js_traverse.free in let js = traverse#program js in let free = traverse#get_free_name in let prim = Primitive.get_external () in let prov = Linker.get_provided () in let all_external = StringSet.union prim prov in let missing = StringSet.inter free all_external in let other = StringSet.diff free missing in let res = VarPrinter.get_reserved() in let other = StringSet.diff other res in if not (StringSet.is_empty missing) then begin report_missing_primitives missing end; let probably_prov = StringSet.inter other Reserved.provided in let other = StringSet.diff other probably_prov in if not (StringSet.is_empty other) && debug_linker () then begin Format.eprintf "Missing variables:@."; StringSet.iter (fun nm -> Format.eprintf " %s@." nm) other end; if not (StringSet.is_empty probably_prov) && debug_linker () then begin Format.eprintf "Variables provided by the browser:@."; StringSet.iter (fun nm -> Format.eprintf " %s@." nm) probably_prov end; if times () then Format.eprintf " checks: %a@." Util.Timer.print t; js end else js let coloring js = let t = Util.Timer.make () in if times () then Format.eprintf "Start Coloring...@."; let traverse = new Js_traverse.free in let js = traverse#program js in let free = traverse#get_free_name in VarPrinter.add_reserved (StringSet.elements free); let js = Js_assign.program js in if times () then Format.eprintf " coloring: %a@." Util.Timer.print t; js let output formatter ?source_map js = let t = Util.Timer.make () in if times () then Format.eprintf "Start Writing file...@."; Js_output.program formatter ?source_map js; if times () then Format.eprintf " write: %a@." Util.Timer.print t let pack ~standalone ?(toplevel=false)?(linkall=false) js = let module J = Javascript in let t = Util.Timer.make () in if times () then Format.eprintf "Start Optimizing js...@."; (* pre pack optim *) let js = if Option.Optim.share_constant () then let t1 = Util.Timer.make () in let js = (new Js_traverse.share_constant)#program js in if times () then Format.eprintf " share constant: %a@." Util.Timer.print t1; js else js in let js = if Option.Optim.compact_vardecl () then let t2 = Util.Timer.make () in let js = (new Js_traverse.compact_vardecl)#program js in if times () then Format.eprintf " compact var decl: %a@." Util.Timer.print t2; js else js in (* pack *) let use_strict js = if Option.Optim.strictmode () then (J.Statement (J.Expression_statement (J.EStr ("use strict", `Utf8))), J.N) :: js else js in let global = J.ECall ( J.EFun (None, [], [ J.Statement ( J.Return_statement( Some (J.EVar (J.S {J.name="this";var=None})))), J.N ], J.N), [], J.N) in let js = if standalone then let f = J.EFun (None, [J.S {J.name = global_object; var=None }], use_strict js, J.U) in [J.Statement ( J.Expression_statement ((J.ECall (f, [global], J.N)))), J.N] else let f = J.EFun (None, [J.V (Code.Var.fresh ())], js, J.N) in [J.Statement (J.Expression_statement f), J.N] in (* post pack optim *) let t3 = Util.Timer.make () in let js = (new Js_traverse.simpl)#program js in if times () then Format.eprintf " simpl: %a@." Util.Timer.print t3; let t4 = Util.Timer.make () in let js = (new Js_traverse.clean)#program js in if times () then Format.eprintf " clean: %a@." Util.Timer.print t4; let js = if (Option.Optim.shortvar ()) then let t5 = Util.Timer.make () in let keeps = if toplevel then StringSet.add global_object (Primitive.get_external ()) else StringSet.empty in let keeps = StringSet.add "caml_get_global_data" keeps in let js = (new Js_traverse.rename_variable keeps)#program js in if times () then Format.eprintf " shortten vars: %a@." Util.Timer.print t5; js else js in if times () then Format.eprintf " optimizing: %a@." Util.Timer.print t; js let configure formatter p = let pretty = Option.Optim.pretty () in Pretty_print.set_compact formatter (not pretty); Code.Var.set_pretty pretty; p type profile = Code.program -> Code.program let f ?(standalone=true) ?(profile=o1) ?toplevel ?linkall ?source_map formatter d = configure formatter >> profile >> deadcode' >> generate d ?toplevel >> link formatter ~standalone ?linkall >> pack ~standalone ?linkall ?toplevel >> coloring >> check_js ~standalone >> header formatter ~standalone >> output formatter ?source_map let from_string prims s formatter = let (p,d) = Parse_bytecode.from_string prims s in f ~standalone:false formatter d p let profiles = [1,o1; 2,o2; 3,o3] let profile i = try Some (List.assoc i profiles) with Not_found -> None js_of_ocaml-2.5/compiler/driver.mli000066400000000000000000000024011241254034500174400ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type profile val f : ?standalone:bool -> ?profile:profile -> ?toplevel:bool -> ?linkall:bool -> ?source_map:(string * Source_map.t) -> Pretty_print.t -> Parse_bytecode.Debug.data -> Code.program -> unit val from_string : string array -> string -> Pretty_print.t -> unit val profiles : (int * profile) list val profile : int -> profile option js_of_ocaml-2.5/compiler/eval.ml000066400000000000000000000201771241254034500167350ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Code open Flow module Int = Int32 let int_binop l f = match l with | [Int i; Int j] -> Some (Int (f i j)) | _ -> None let shift l f = match l with | [Int i; Int j] -> Some (Int (f i ((Int32.to_int j) land 0x1f))) | _ -> None let float_binop_aux l f = let args = match l with | [Float i; Float j]-> Some (i,j) | [Int i ; Int j] -> Some (Int32.to_float i,Int32.to_float j) | [Int i ; Float j] -> Some(Int32.to_float i,j) | [Float i ; Int j] -> Some(i,Int32.to_float j) | _ -> None in match args with | None -> None | Some (i,j) -> Some (f i j) let float_binop l f = match float_binop_aux l f with | Some x -> Some (Float x) | None -> None let float_unop l f = match l with | [Float i] -> Some (Float (f i)) | [Int i] -> Some (Float (f (Int32.to_float i))) | _ -> None let float_binop_bool l f = match float_binop_aux l f with | Some true -> Some (Int 1l) | Some false -> Some (Int 0l) | None -> None let bool b = Some (Int (if b then 1l else 0l)) let eval_prim x = match x with | Not, [Int i] -> bool (i=0l) | Lt, [Int i; Int j ] -> bool (i < j) | Le, [Int i; Int j ] -> bool (i <= j) | Eq, [Int i; Int j ] -> bool (i = j) | Neq, [Int i; Int j ] -> bool (i <> j) | IsInt, [Int _] -> bool true | Ult, [Int i; Int j ] -> bool (j < 0l || i < j) | Extern name, l -> let name = Primitive.resolve name in (match name, l with (* int *) | "%int_add", _ -> int_binop l (Int.add) | "%int_sub", _ -> int_binop l (Int.sub) | "%direct_int_mul", _ -> int_binop l (Int.mul ) | "%direct_int_div", [_; Int 0l] -> None | "%direct_int_div", _ -> int_binop l (Int.div) | "%direct_int_mod", _ -> int_binop l (Int.rem) | "%int_and", _ -> int_binop l (Int.logand) | "%int_or", _ -> int_binop l (Int.logor) | "%int_xor", _ -> int_binop l (Int.logxor) | "%int_lsl", _ -> shift l (Int.shift_left) | "%int_lsr", _ -> shift l (Int.shift_right_logical) | "%int_asr", _ -> shift l (Int.shift_right) | "%int_neg", [Int i] -> Some (Int (Int.neg i )) (* float *) | "caml_eq_float", _ -> float_binop_bool l (=) | "caml_neq_float", _ -> float_binop_bool l (<>) | "caml_ge_float", _ -> float_binop_bool l (>=) | "caml_le_float", _ -> float_binop_bool l (<=) | "caml_gt_float", _ -> float_binop_bool l (>) | "caml_lt_float", _ -> float_binop_bool l (<) | "caml_add_float",_ -> float_binop l (+.) | "caml_sub_float",_ -> float_binop l (-.) | "caml_mul_float",_ -> float_binop l ( *. ) | "caml_div_float",_ -> float_binop l ( /. ) | "caml_fmod_float",_ -> float_binop l mod_float | "caml_int_of_float",[Float f] -> Some (Int (Int32.of_float f)) | "to_int",[Float f] -> Some (Int (Int32.of_float f)) | "to_int",[Int i] -> Some (Int i) (* Math *) | "caml_abs_float",_ -> float_unop l abs_float | "caml_acos_float",_ -> float_unop l acos | "caml_asin_float",_ -> float_unop l asin | "caml_atan_float",_ -> float_unop l atan | "caml_atan2_float",_ -> float_binop l atan2 | "caml_ceil_float",_ -> float_unop l ceil | "caml_cos_float",_ -> float_unop l cos | "caml_exp_float",_ -> float_unop l exp | "caml_floor_float",_ -> float_unop l floor | "caml_log_float",_ -> float_unop l log | "caml_power_float",_ -> float_binop l ( ** ) | "caml_sin_float",_ -> float_unop l sin | "caml_sqrt_float",_ -> float_unop l sqrt | "caml_tan_float",_ -> float_unop l tan | _ -> None) | _ -> None exception Not_constant let the_length_of info x = get_approx info (fun x -> match info.info_defs.(Var.idx x) with | Expr (Constant (String s)) | Expr (Constant (IString s)) -> Some (Int32.of_int (String.length s)) | Expr (Prim (Extern "caml_create_string",[arg])) -> the_int info arg | _ -> None) None (fun u v -> match u,v with | Some l, Some l' when l = l' -> Some l | _ -> None) x let eval_instr info i = match i with | Let (x, Prim (Extern ("caml_js_equals"|"caml_equal"), [y;z])) -> begin match the_const_of info y, the_const_of info z with | Some e1, Some e2 -> let c = if e1 = e2 then 1l else 0l in Let (x , Constant (Int c)) | _ -> i end | Let (x,Prim (Extern "caml_ml_string_length", [s])) -> let c = match s with | Pc (String s) | Pc (IString s) -> Some (Int32.of_int (String.length s)) | Pv v -> the_length_of info v | _ -> None in (match c with | None -> i | Some c -> Let(x,Constant (Int c))) | Let (x, Prim (Extern ("caml_array_unsafe_get"|"caml_array_unsafe_set"), _)) -> (* Fresh parameters can be introduced for these primitives in Specialize_js, which would make the call to [the_const_of] below fail. *) i | Let (x,Prim (prim, prim_args)) -> begin let prim_args' = List.map (fun x -> the_const_of info x) prim_args in let res = if List.for_all (function Some _ -> true | _ -> false) prim_args' then eval_prim (prim,List.map (function Some c -> c | None -> assert false) prim_args') else None in match res with | Some c -> Let (x,Constant c) | _ -> Let(x, Prim(prim, (List.map2 (fun arg c -> match c with | Some ((Int _ | Float _) as c) -> Pc c | Some _ (* do not be duplicated other constant as they're not represented with constant in javascript. *) | None -> arg) prim_args prim_args'))) end | _ -> i type case_of = CConst of int | CTag of int | N let the_case_of info x = match x with | Pv x -> get_approx info (fun x -> match info.info_defs.(Var.idx x) with | Expr (Const i) | Expr (Constant (Int i)) -> CConst (Int32.to_int i) | Expr (Block (j,_)) | Expr (Constant (Tuple (j,_))) -> CTag j | _ -> N) N (fun u v -> match u, v with | CTag i, CTag j when i = j -> u | CConst i, CConst j when i = j -> u | _ -> N) x | Pc (Int i) -> CConst (Int32.to_int i) | Pc (Tuple (j,_)) -> CTag j | _ -> N let eval_branch info = function | Cond (cond,x,ftrue,ffalse) as b-> begin match the_int info (Pv x) with | Some j -> let res = match cond with | IsTrue -> (match j with 0l -> false | 1l -> true | _ -> assert false) | CEq i -> i = j | CLt i -> i < j | CLe i -> i<= j | CUlt i -> j < 0l || i < j in (match res with | true -> Branch ftrue | false -> Branch ffalse) | _ -> b end | Switch (x,const,tags) as b -> begin match the_case_of info (Pv x) with | CConst j -> Branch const.(j) | CTag j -> Branch tags.(j) | N -> b end | _ as b -> b let f info (pc, blocks, free_pc) = let blocks = AddrMap.map (fun block -> { block with Code.body = List.map (eval_instr info) block.body; Code.branch = eval_branch info block.branch }) blocks in (pc, blocks, free_pc) js_of_ocaml-2.5/compiler/eval.mli000066400000000000000000000016251241254034500171030ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val f : Flow.info -> Code.program -> Code.program js_of_ocaml-2.5/compiler/flow.ml000066400000000000000000000313731241254034500167550ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let debug = Option.Debug.find "flow" let times = Option.Debug.find "times" open Code (****) let add_var = VarISet.add type def = Phi of VarSet.t | Expr of Code.expr | Param type info = { info_defs:def array; info_known_origins : Code.VarSet.t Code.VarTbl.t; info_maybe_unknown : bool Code.VarTbl.t; info_possibly_mutable : bool array } let undefined = Phi VarSet.empty let is_undefined d = match d with Phi s -> VarSet.is_empty s | _ -> false let add_expr_def defs x e = let idx = Var.idx x in assert (is_undefined defs.(idx)); defs.(idx) <- Expr e let add_assign_def vars defs x y = add_var vars x; let idx = Var.idx x in match defs.(idx) with Expr _ | Param -> assert false | Phi s -> defs.(idx) <- Phi (VarSet.add y s) let add_param_def vars defs x = add_var vars x; let idx = Var.idx x in assert (is_undefined defs.(idx) || defs.(idx) = Param); defs.(idx) <- Param (* x depends on y *) let add_dep deps x y = let idx = Var.idx y in deps.(idx) <- VarSet.add x deps.(idx) let rec arg_deps vars deps defs params args = match params, args with x :: params, y :: args -> add_dep deps x y; add_assign_def vars defs x y; arg_deps vars deps defs params args | _ -> () let cont_deps blocks vars deps defs (pc, args) = let block = AddrMap.find pc blocks in arg_deps vars deps defs block.params args let expr_deps blocks vars deps defs x e = match e with Const _ | Constant _ | Apply _ | Prim _ -> () | Closure (l, cont) -> List.iter (fun x -> add_param_def vars defs x) l; cont_deps blocks vars deps defs cont | Block (_, a) -> Array.iter (fun y -> add_dep deps x y) a | Field (y, _) -> add_dep deps x y let program_deps (_, blocks, _) = let nv = Var.count () in let vars = VarISet.empty () in let deps = Array.make nv VarSet.empty in let defs = Array.make nv undefined in AddrMap.iter (fun pc block -> List.iter (fun i -> match i with Let (x, e) -> add_var vars x; add_expr_def defs x e; expr_deps blocks vars deps defs x e | Set_field _ | Array_set _ | Offset_ref _ -> ()) block.body; Util.opt_iter (fun (x, cont) -> add_param_def vars defs x; cont_deps blocks vars deps defs cont) block.handler; match block.branch with Return _ | Raise _ | Stop -> () | Branch cont | Poptrap cont -> cont_deps blocks vars deps defs cont | Cond (_, _, cont1, cont2) -> cont_deps blocks vars deps defs cont1; cont_deps blocks vars deps defs cont2 | Switch (_, a1, a2) -> Array.iter (fun cont -> cont_deps blocks vars deps defs cont) a1; Array.iter (fun cont -> cont_deps blocks vars deps defs cont) a2 | Pushtrap (cont, _, _, _) -> cont_deps blocks vars deps defs cont) blocks; (vars, deps, defs) let var_set_lift f s = VarSet.fold (fun y s -> VarSet.union (f y) s) s VarSet.empty let propagate1 deps defs st x = match defs.(Var.idx x) with Param -> VarSet.singleton x | Phi s -> var_set_lift (fun y -> VarTbl.get st y) s | Expr e -> match e with Const _ | Constant _ | Apply _ | Prim _ | Closure _ | Block _ -> VarSet.singleton x | Field (y, n) -> var_set_lift (fun z -> match defs.(Var.idx z) with Expr (Block (_, a)) when n < Array.length a -> let t = a.(n) in add_dep deps x t; VarTbl.get st t | Phi _ | Param | Expr _ -> VarSet.empty) (VarTbl.get st y) module G = Dgraph.Make_Imperative (Var) (VarISet) (VarTbl) module Domain1 = struct type t = VarSet.t let equal = VarSet.equal let bot = VarSet.empty end module Solver1 = G.Solver (Domain1) let solver1 vars deps defs = let g = { G.domain = vars; G.iter_children = fun f x -> VarSet.iter f deps.(Var.idx x) } in Solver1.f () g (propagate1 deps defs) (****) type mutability_state = { defs : def array; known_origins : Code.VarSet.t Code.VarTbl.t; may_escape : bool array; possibly_mutable : bool array } let rec block_escape st x = VarSet.iter (fun y -> let idx = Var.idx y in if not st.may_escape.(idx) then begin st.may_escape.(idx) <- true; st.possibly_mutable.(idx) <- true; match st.defs.(Var.idx y) with Expr (Block (_, l)) -> Array.iter (fun z -> block_escape st z) l | _ -> () end) (VarTbl.get st.known_origins x) let expr_escape st x e = match e with Const _ | Constant _ | Closure _ | Block _ | Field _ -> () | Apply (_, l, _) -> List.iter (fun x -> block_escape st x) l | Prim (prim, l) -> let ka = match prim with | Extern name -> Primitive.kind_args name | _ -> None in let ka = match ka with | None -> [] | Some l -> l in let rec loop args ka = match args,ka with | [], _ -> () | Pc _::ax, [] -> loop ax [] | Pv a::ax, [] -> block_escape st a; loop ax [] | a::ax, k::kx -> begin match a,k with | _,`Const | Pc _, _ -> () | Pv v,`Shallow_const -> begin match st.defs.(Var.idx v) with | Expr (Block (_, a)) -> Array.iter (fun x -> block_escape st x) a | _ -> block_escape st v end; | Pv v, _ -> block_escape st v end; loop ax kx in loop l ka let program_escape defs known_origins (_, blocks, _) = let nv = Var.count () in let may_escape = Array.make nv false in let possibly_mutable = Array.make nv false in let st = { defs = defs; known_origins = known_origins; may_escape = may_escape; possibly_mutable = possibly_mutable } in AddrMap.iter (fun pc block -> List.iter (fun i -> match i with Let (x, e) -> expr_escape st x e | Set_field (x, _, y) | Array_set (x, _, y) -> VarSet.iter (fun y -> possibly_mutable.(Var.idx y) <- true) (VarTbl.get known_origins x); block_escape st y | Offset_ref (x, _) -> VarSet.iter (fun y -> possibly_mutable.(Var.idx y) <- true) (VarTbl.get known_origins x)) block.body; match block.branch with Return x | Raise x -> block_escape st x | Stop | Branch _ | Cond _ | Switch _ | Pushtrap _ | Poptrap _ -> ()) blocks; possibly_mutable (****) type approx = Known | Maybe_unknown let a_max u v = match u, v with Known, Known -> Known | _ -> Maybe_unknown let approx_lift f s = VarSet.fold (fun y u -> a_max (f y) u) s Known let propagate2 ?(skip_param=false) defs known_origins possibly_mutable st x = match defs.(Var.idx x) with Param -> skip_param | Phi s -> VarSet.exists (fun y -> VarTbl.get st y) s | Expr e -> match e with Const _ | Constant _ | Closure _ | Apply _ | Prim _ | Block _ -> false | Field (y, n) -> VarTbl.get st y || VarSet.exists (fun z -> match defs.(Var.idx z) with Expr (Block (_, a)) -> n >= Array.length a || possibly_mutable.(Var.idx z) || VarTbl.get st a.(n) | Phi _ | Param | Expr _ -> true) (VarTbl.get known_origins y) module Domain2 = struct type t = bool let equal (u : bool) v = u = v let bot = false end module Solver2 = G.Solver (Domain2) let solver2 ?skip_param vars deps defs known_origins possibly_mutable = let g = { G.domain = vars; G.iter_children = fun f x -> VarSet.iter f deps.(Var.idx x) } in Solver2.f () g (propagate2 ?skip_param defs known_origins possibly_mutable) let get_approx {info_defs; info_known_origins;info_maybe_unknown} f top join x = let s = VarTbl.get info_known_origins x in if VarTbl.get info_maybe_unknown x then top else match VarSet.cardinal s with 0 -> top | 1 -> f (VarSet.choose s) | _ -> VarSet.fold (fun x u -> join (f x) u) s (f (VarSet.choose s)) let the_def_of info x = match x with | Pv x -> get_approx info (fun x -> match info.info_defs.(Var.idx x) with Expr e -> Some e | _ -> None) None (fun u v -> None) x | Pc c -> Some (Constant c) let rec the_const_of info x = match x with | Pv x -> get_approx info (fun x -> match info.info_defs.(Var.idx x) with | Expr (Const i) -> Some (Int i) | Expr (Constant c) -> Some c | _ -> None) None (fun u v -> match u, v with Some i, Some j when i = j -> u | _ -> None) x | Pc c -> Some c let the_int info x = match the_const_of info x with | Some (Int i) -> Some i | _ -> None let the_string_of info x = match the_const_of info x with | Some (String i) -> Some i | _ -> None (*XXX Maybe we could iterate? *) let direct_approx info x = match info.info_defs.(Var.idx x) with Expr (Field (y, n)) -> get_approx info (fun z -> if info.info_possibly_mutable.(Var.idx z) then None else match info.info_defs.(Var.idx z) with Expr (Block (_, a)) when n < Array.length a -> Some a.(n) | _ -> None) None (fun u v -> match u, v with Some n, Some m when Var.compare n m = 0 -> u | _ -> None) y | _ -> None let build_subst info vars = let nv = Var.count () in let subst = Array.make nv None in VarISet.iter (fun x -> let u = VarTbl.get info.info_maybe_unknown x in if not u then begin let s = VarTbl.get info.info_known_origins x in if VarSet.cardinal s = 1 then subst.(Var.idx x) <- Some (VarSet.choose s) end; if subst.(Var.idx x) = None then subst.(Var.idx x) <- direct_approx info x; match subst.(Var.idx x) with | None -> () | Some y -> Var.propagate_name x y ) vars; subst (****) let f ?skip_param ((pc, blocks, free_pc) as p) = let t = Util.Timer.make () in let t1 = Util.Timer.make () in let (vars, deps, defs) = program_deps p in if times () then Format.eprintf " flow analysis 1: %a@." Util.Timer.print t1; let t2 = Util.Timer.make () in let known_origins = solver1 vars deps defs in if times () then Format.eprintf " flow analysis 2: %a@." Util.Timer.print t2; let t3 = Util.Timer.make () in let possibly_mutable = program_escape defs known_origins p in if times () then Format.eprintf " flow analysis 3: %a@." Util.Timer.print t3; let t4 = Util.Timer.make () in let maybe_unknown = solver2 ?skip_param vars deps defs known_origins possibly_mutable in if times () then Format.eprintf " flow analysis 4: %a@." Util.Timer.print t4; if debug () then begin VarISet.iter (fun x -> let s = VarTbl.get known_origins x in if not (VarSet.is_empty s) (*&& VarSet.choose s <> x*) then begin Format.eprintf "%a: {%a} / %s@." Var.print x Code.print_var_list (VarSet.elements s) (if VarTbl.get maybe_unknown x then "any" else "known") end) vars end; let t5 = Util.Timer.make () in let info = { info_defs = defs; info_known_origins = known_origins; info_maybe_unknown = maybe_unknown; info_possibly_mutable = possibly_mutable; } in let s = build_subst info vars in let p = Subst.program (Subst.from_array s) p in if times () then Format.eprintf " flow analysis 5: %a@." Util.Timer.print t5; if times () then Format.eprintf " flow analysis: %a@." Util.Timer.print t; p, info js_of_ocaml-2.5/compiler/flow.mli000066400000000000000000000034621241254034500171240ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) (* type 'a flat = Void | Known of 'a | Unknown type v = | Blk of t list | Cst of int and t = Code.Var.t flat * v flat val approx_to_string : t -> string val get_field : t -> int -> t val get_const : t -> int option val get_label : t -> Code.Var.t option *) type def = Phi of Code.VarSet.t | Expr of Code.expr | Param type info = { info_defs:def array; info_known_origins : Code.VarSet.t Code.VarTbl.t; info_maybe_unknown : bool Code.VarTbl.t; info_possibly_mutable : bool array; } val get_approx : info -> (Code.VarSet.elt -> 'b) -> 'b -> ('b -> 'b -> 'b) -> Code.VarTbl.key -> 'b val the_def_of : info -> Code.prim_arg -> Code.expr option val the_const_of : info -> Code.prim_arg -> Code.constant option val the_string_of : info -> Code.prim_arg -> string option val the_int : info -> Code.prim_arg -> int32 option val f : ?skip_param:bool -> Code.program -> Code.program * info js_of_ocaml-2.5/compiler/freevars.ml000066400000000000000000000147651241254034500176310ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let times = Option.Debug.find "times" open Code (****) let iter_cont_free_vars f (_, l) = List.iter f l let iter_expr_free_vars f e = match e with Const _ | Constant _ -> () | Apply (x, l, _) -> f x; List.iter f l | Block (_, a) -> Array.iter f a | Field (x, _) -> f x | Closure _ -> () | Prim (_, l) -> List.iter (fun x -> match x with Pv x -> f x | Pc _ -> ()) l let iter_instr_free_vars f i = match i with Let (x, e) -> iter_expr_free_vars f e | Set_field (x, _, y) -> f x; f y | Offset_ref (x, _) -> f x | Array_set (x, y, z) -> f x; f y; f z let iter_last_free_var f l = match l with Return x | Raise x -> f x | Stop -> () | Branch cont | Poptrap cont -> iter_cont_free_vars f cont | Cond (_, x, cont1, cont2) -> f x; iter_cont_free_vars f cont1; iter_cont_free_vars f cont2 | Switch (x, a1, a2) -> f x; Array.iter (fun c -> iter_cont_free_vars f c) a1; Array.iter (fun c -> iter_cont_free_vars f c) a2 | Pushtrap (cont1, _, cont2, _) -> iter_cont_free_vars f cont1; iter_cont_free_vars f cont2 let iter_block_free_vars f block = List.iter (fun i -> iter_instr_free_vars f i) block.body; iter_last_free_var f block.branch let iter_instr_bound_vars f i = match i with Let (x, _) -> f x | Set_field _ | Offset_ref _ | Array_set _ -> () let iter_last_bound_vars f l = match l with Return _ | Raise _ | Stop | Branch _ | Cond _ | Switch _ | Poptrap _ -> () | Pushtrap (_, x, _, _) -> f x let iter_block_bound_vars f block = List.iter f block.params; List.iter (fun i -> iter_instr_bound_vars f i) block.body; iter_last_bound_vars f block.branch (****) type st = { index : int; mutable lowlink : int; mutable in_stack : bool } let find_loops ((_, blocks, _) as prog) = let in_loop = ref AddrMap.empty in let index = ref 0 in let state = ref AddrMap.empty in let stack = Stack.create () in let rec traverse pc = let st = {index = !index; lowlink = !index; in_stack = true } in state := AddrMap.add pc st !state; incr index; Stack.push pc stack; Code.fold_children blocks pc (fun pc' () -> try let st' = AddrMap.find pc' !state in if st'.in_stack then st.lowlink <- min st.lowlink st'.index with Not_found -> traverse pc'; let st' = AddrMap.find pc' !state in st.lowlink <- min st.lowlink st'.lowlink) (); if st.index = st.lowlink then begin let l = ref [] in while let pc' = Stack.pop stack in l := pc' :: !l; (AddrMap.find pc' !state).in_stack <- false; pc' <> pc do () done; if List.length !l > 1 then List.iter (fun pc' -> in_loop := AddrMap.add pc' pc !in_loop) !l end in Code.fold_closures prog (fun _ _ (pc, _) () -> traverse pc) (); !in_loop let mark_variables in_loop (pc, blocks, free_pc) = let vars = VarTbl.make () (-1) in let visited = Array.make free_pc false in let rec traverse pc = if not visited.(pc) then begin visited.(pc) <- true; let block = AddrMap.find pc blocks in begin try let pc' = AddrMap.find pc in_loop in iter_block_bound_vars (fun x -> (* Format.eprintf "!%a: %d@." Var.print x pc'; *) VarTbl.set vars x pc') block with Not_found -> () end; List.iter (fun i -> match i with Let (_, Closure (_, (pc', _))) -> traverse pc' | _ -> ()) block.body; Code.fold_children blocks pc (fun pc' () -> traverse pc') () end in traverse pc; vars let free_variables vars in_loop (pc, blocks, free_pc) = let all_freevars = ref AddrMap.empty in let freevars = ref AddrMap.empty in let visited = Array.make free_pc false in let rec traverse pc = if not visited.(pc) then begin visited.(pc) <- true; let block = AddrMap.find pc blocks in iter_block_free_vars (fun x -> let pc' = VarTbl.get vars x in (* Format.eprintf "%a: %d@." Var.print x pc'; *) if pc' <> -1 then begin let fv = try AddrMap.find pc' !all_freevars with Not_found -> VarSet.empty in let s = VarSet.add x fv in all_freevars := AddrMap.add pc' s !all_freevars end) block; begin try let pc'' = AddrMap.find pc in_loop in all_freevars := AddrMap.remove pc'' !all_freevars with Not_found -> () end; List.iter (fun i -> match i with Let (_, Closure (_, (pc', _))) -> traverse pc'; begin try let pc'' = AddrMap.find pc in_loop in let fv = try AddrMap.find pc'' !all_freevars with Not_found -> VarSet.empty in freevars := AddrMap.add pc' fv !freevars; all_freevars := AddrMap.remove pc'' !all_freevars with Not_found -> freevars := AddrMap.add pc' VarSet.empty !freevars; end | _ -> ()) block.body; Code.fold_children blocks pc (fun pc' () -> traverse pc') () end in traverse pc; (* AddrMap.iter (fun pc fv -> if VarSet.cardinal fv > 0 then Format.eprintf ">> %d: %d@." pc (VarSet.cardinal fv)) !freevars; *) !freevars let f ((pc, blocks, free_pc) as p) = let t = Util.Timer.make () in let in_loop = find_loops p in let vars = mark_variables in_loop p in let free_vars = free_variables vars in_loop p in if times () then Format.eprintf " free vars: %a@." Util.Timer.print t; free_vars js_of_ocaml-2.5/compiler/freevars.mli000066400000000000000000000017201241254034500177650ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val f : Code.program -> Code.VarSet.t Util.IntMap.t js_of_ocaml-2.5/compiler/generate.ml000066400000000000000000002012051241254034500175710ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) (*XXX Patterns: => loops should avoid absorbing the whole continuation... (detect when the continuation does not loop anymore and close the loop at this point) => should have special code for switches that include the preceding if statement when possible => if e1 then {if e2 then P else Q} else {if e3 then P else Q} => if e then return e1; return e2 => if e then var x = e1; else var x = e2; => while (true) {.... if (e) continue; break; } - CLEAN UP!!! *) let debug = Option.Debug.find "gen" let times = Option.Debug.find "times" open Code open Util module J = Javascript (****) let rec list_group_rec f g l b m n = match l with [] -> List.rev ((b, List.rev m) :: n) | a :: r -> let fa = f a in if fa = b then list_group_rec f g r b (g a :: m) n else list_group_rec f g r fa [g a] ((b, List.rev m) :: n) let list_group f g l = match l with [] -> [] | a :: r -> list_group_rec f g r (f a) [g a] [] (* like [List.map] except that it calls the function with an additional argument to indicate wether we're mapping over the last element of the list *) let rec map_last f l = match l with | [] -> assert false | [x] -> [f true x] | x::xs -> f false x :: map_last f xs (****) module Share = struct type 'a aux = { strings : 'a StringMap.t; applies : 'a IntMap.t; prims : 'a StringMap.t; } let empty_aux = { prims = StringMap.empty; strings = StringMap.empty; applies = IntMap.empty } type t = { mutable count : int aux; mutable vars : J.ident aux; alias_prims : bool; alias_strings : bool; alias_apply : bool; } let add_string s t = let n = try StringMap.find s t.strings with Not_found -> 0 in {t with strings = StringMap.add s (n+1) t.strings} let add_prim s t = let n = try StringMap.find s t.prims with Not_found -> 0 in {t with prims = StringMap.add s (n+1) t.prims} let add_special_prim_if_exists s t = if Primitive.exists s then {t with prims = StringMap.add s (-1) t.prims} else t let add_apply i t = let n = try IntMap.find i t.applies with Not_found -> 0 in {t with applies = IntMap.add i (n+1) t.applies } let add_code_string s share = let share = add_string s share in add_prim "caml_new_string" share let add_code_istring s share = add_string s share let rec get_constant c t = match c with | String s -> add_code_string s t | IString s -> add_code_istring s t | Tuple (_,args) -> Array.fold_left (fun t c -> get_constant c t) t args | _ -> t let add_args args t = List.fold_left(fun t a -> match a with | Pc c -> get_constant c t | _ -> t) t args let get ?(alias_strings=false) ?(alias_prims=false) ?(alias_apply=true) (_, blocks, _) : t = let count = AddrMap.fold (fun _ block share -> List.fold_left (fun share i -> match i with | Let (_, Constant c) -> get_constant c share | Let (_, Apply (_,args,false)) -> add_apply (List.length args) share | Let (_, Prim (Extern name, args)) -> let name = Primitive.resolve name in let share = if Primitive.exists name then add_prim name share else share in add_args args share | Let (_, Prim (_, args)) -> add_args args share | _ -> share ) share block.body) blocks empty_aux in let count = List.fold_left (fun acc x -> add_special_prim_if_exists x acc) count ["caml_trampoline";"caml_trampoline_return";"caml_wrap_exception"] in {count; vars = empty_aux; alias_strings; alias_prims; alias_apply} let get_string gen s t = if not t.alias_strings then gen s else try let c = StringMap.find s t.count.strings in if c > 1 then try J.EVar (StringMap.find s t.vars.strings) with Not_found -> let x = Var.fresh() in Var.name x "str"; let v = J.V x in t.vars <- { t.vars with strings = StringMap.add s v t.vars.strings }; J.EVar v else gen s with Not_found-> gen s let get_prim gen s t = let s = Primitive.resolve s in if not t.alias_prims then gen s else try let c = StringMap.find s t.count.prims in if c > 1 || c = -1 then try J.EVar (StringMap.find s t.vars.prims) with Not_found -> let x = Var.fresh() in Code.Var.name x s; let v = J.V x in t.vars <- { t.vars with prims = StringMap.add s v t.vars.prims }; J.EVar v else gen s with Not_found -> gen s let get_apply gen n t = if not t.alias_apply then gen n else try J.EVar (IntMap.find n t.vars.applies) with Not_found -> let x = Var.fresh() in Code.Var.name x (Printf.sprintf "caml_call_gen%d" n); let v = J.V x in t.vars <- { t.vars with applies = IntMap.add n v t.vars.applies }; J.EVar v end module Ctx = struct type t = { mutable blocks : block AddrMap.t; live : int array; mutated_vars : VarSet.t AddrMap.t; share: Share.t; debug : Parse_bytecode.Debug.data } let initial blocks live mutated_vars share debug = { blocks; live; mutated_vars; share; debug } end let var x = J.EVar (J.V x) let int n = J.ENum (float n) let int32 n = J.ENum (Int32.to_float n) let unsigned x = J.EBin (J.Lsr,x,int 0) let one = int 1 let zero = int 0 let bool e = J.ECond (e, one, zero) let boolnot e = J.ECond (e, zero, one) let val_float f = f (*J.EArr [Some (J.ENum 253.); Some f]*) let float_val e = e (*J.EAccess (e, one)*) (****) let source_location ctx ?after pc = match Parse_bytecode.Debug.find_loc ctx.Ctx.debug ?after pc with Some pi -> J.Pi pi | None -> J.N (****) let float_const f = val_float (J.ENum f) let s_var name = J.EVar (J.S {J.name=name; J.var = None}) let str_js s = J.EStr (s,`Bytes) (****) (* Some variables are constant: x = 1 Some may change after effectful operations : x = y[z] There can be at most one effectful operations in the queue at once let (e, expr_queue) = ... in flush_queue expr_queue e *) let const_p = 0 let mutable_p = 1 let mutator_p = 2 let flush_p = 3 let or_p p q = max p q let is_mutable p = p >= mutable_p let is_mutator p = p >= mutator_p let kind k = match k with `Pure -> const_p | `Mutable -> mutable_p | `Mutator -> mutator_p let rec constant_rec ~ctx x level instrs = match x with String s -> let e = Share.get_string str_js s ctx.Ctx.share in let p = Share.get_prim s_var "caml_new_string" ctx.Ctx.share in J.ECall (p,[e],J.N), instrs | IString s -> Share.get_string str_js s ctx.Ctx.share, instrs | Float f -> float_const f, instrs | Float_array a -> J.EArr (Some (int Obj.double_array_tag) :: Array.to_list (Array.map (fun f -> Some (float_const f)) a)), instrs | Int64 i -> J.EArr [Some (int 255); Some (int (Int64.to_int i land 0xffffff)); Some (int (Int64.to_int (Int64.shift_right i 24) land 0xffffff)); Some (int (Int64.to_int (Int64.shift_right i 48) land 0xffff))], instrs | Tuple (tag, a) -> let split = level = Option.Param.constant_max_depth () in let level = if split then 0 else level + 1 in let (l, instrs) = List.fold_left (fun (l, instrs) cc -> let (js, instrs) = constant_rec ~ctx cc level instrs in js::l, instrs) ([], instrs) (Array.to_list a) in let (l, instrs) = if split then List.fold_left (fun (acc,instrs) js -> match js with | J.EArr _ -> let v = Code.Var.fresh () in Var.name v "partial"; let instrs = (J.Variable_statement [J.V v, Some (js,J.N)],J.N) :: instrs in Some (J.EVar (J.V v))::acc,instrs | _ -> Some js :: acc,instrs) ([],instrs) l else List.rev_map (fun x -> Some x) l, instrs in J.EArr (Some (int tag) :: l), instrs | Int i-> int32 i, instrs let constant ~ctx x level = let (expr, instr) = constant_rec ~ctx x level [] in (expr, List.rev instr) type queue_elt = { prop : int; cardinal : int; ce : J.expression; loc : J.location; deps : Code.VarSet.t } let access_queue queue x = try let elt = List.assoc x queue in if elt.cardinal = 1 then (elt.prop,elt.ce), List.remove_assoc x queue else ((elt.prop,elt.ce), List.map (function (x',elt) when x = x' -> x',{elt with cardinal=pred elt.cardinal} | x -> x) queue) with Not_found -> ((const_p, var x), queue) let access_queue' ~ctx queue x = match x with | Pc c -> let js,instrs = constant ~ctx c (Option.Param.constant_max_depth ()) in assert (instrs = []); (* We only have simple constants here *) (const_p, js), queue | Pv x -> access_queue queue x let access_queue_may_flush queue v x = let tx,queue = access_queue queue x in let _,instrs,queue = List.fold_left (fun (deps,instrs,queue) ((y,elt) as eq) -> if Code.VarSet.exists (fun p -> Code.VarSet.mem p deps) elt.deps then (Code.VarSet.add y deps, (J.Variable_statement [J.V y, Some (elt.ce, elt.loc)], elt.loc) :: instrs, queue) else (deps, instrs, eq::queue)) (Code.VarSet.singleton ( v),[],[]) queue in instrs,(tx,List.rev queue) let should_flush cond prop = cond <> const_p && cond + prop >= flush_p let flush_queue expr_queue prop (l:J.statement_list) = let (instrs, expr_queue) = if prop >= flush_p then (expr_queue, []) else List.partition (fun (y, elt) -> should_flush prop elt.prop) expr_queue in let instrs = List.map (fun (x, elt) -> (J.Variable_statement [J.V x, Some (elt.ce, elt.loc)], elt.loc)) instrs in (List.rev_append instrs l, expr_queue) let flush_all expr_queue l = fst (flush_queue expr_queue flush_p l) let enqueue expr_queue prop x ce loc cardinal acc = let (instrs, expr_queue) = if Option.Optim.compact () then if is_mutable prop then flush_queue expr_queue prop [] else [], expr_queue else flush_queue expr_queue flush_p [] in let deps = Js_simpl.get_variable Code.VarSet.empty ce in let deps = List.fold_left (fun deps (x',elt) -> if Code.VarSet.mem ( x') deps then Code.VarSet.union elt.deps deps else deps) deps expr_queue in (instrs @ acc , (x, {prop; ce; loc; cardinal; deps}) :: expr_queue) (****) type state = { all_succs : (int, AddrSet.t) Hashtbl.t; (* not used *) succs : (int, int list) Hashtbl.t; backs : (int, AddrSet.t) Hashtbl.t; preds : (int, int) Hashtbl.t; mutable loops : AddrSet.t; mutable loop_stack : (addr * (J.Label.t * bool ref)) list; mutable visited_blocks : AddrSet.t; mutable interm_idx : int; ctx : Ctx.t; mutable blocks : Code.block AddrMap.t; at_toplevel : bool } let get_preds st pc = try Hashtbl.find st.preds pc with Not_found -> 0 let incr_preds st pc = Hashtbl.replace st.preds pc (get_preds st pc + 1) let decr_preds st pc = Hashtbl.replace st.preds pc (get_preds st pc - 1) let protect_preds st pc = Hashtbl.replace st.preds pc (get_preds st pc + 1000000) let unprotect_preds st pc = Hashtbl.replace st.preds pc (get_preds st pc - 1000000) let (>>) x f = f x (* This as to be kept in sync with the way we build conditionals and switches! *) module DTree = struct;; type 'a t = | If of Code.cond * 'a t * 'a t | Switch of (int list * 'a t) array | Branch of ('a) | Empty let normalize a = a >> Array.to_list >> List.stable_sort (fun (cont1,_) (cont2,_) -> compare cont1 cont2) >> list_group fst snd >> List.map (fun (cont1, l1) -> cont1, List.flatten l1 ) >> List.stable_sort (fun (_,l1) (_,l2) -> compare (List.length l1) (List.length l2)) >> Array.of_list let build_if cond b1 b2 = If(cond,Branch b1,Branch b2) let build_switch (a : cont array) : 'a t = let m = Option.Param.switch_max_case () in let ai = Array.mapi (fun i x -> x, i) a in (* group the contiguous cases with the same continuation *) let ai : (Code.cont * int list) array = Array.of_list (list_group fst snd (Array.to_list ai)) in let rec loop low up = let array_norm : (Code.cont * int list) array = normalize (Array.sub ai low (up - low + 1)) in let array_len = Array.length array_norm in if array_len = 1 (* remaining cases all jump to the same branch *) then Branch (fst array_norm.(0)) else try (* try to optimize when there are only 2 branch *) match array_norm with | [| b1,[i1]; b2,l2 |] -> If (CEq (Int32.of_int i1), Branch b1,Branch b2) | [| b1,l1; b2,[i2] |] -> If (CEq (Int32.of_int i2), Branch b2,Branch b1) | [|b1,l1;b2,l2|] -> let bound l1 = match l1,List.rev l1 with | min::_, max::_ -> min,max | _ -> assert false in let min1,max1 = bound l1 in let min2,max2 = bound l2 in if max1 < min2 then If (CLt (Int32.of_int max1),Branch b2,Branch b1) else if max2 < min1 then If (CLt (Int32.of_int max2),Branch b1,Branch b2) else raise Not_found | _ -> raise Not_found with Not_found -> (* do we have to split again ? *) (* we count the number of cases, default/last case count for one *) let nbcases = ref 1 (* default case *) in for i = 0 to array_len - 2 do nbcases:= !nbcases + List.length (snd array_norm.(i)) done; if !nbcases <= m then Switch (Array.map (fun (x,l) -> l,Branch x) array_norm) else let h = (up + low) / 2 in let b1 = loop low h and b2 = loop (succ h) up in let range1 = snd ai.(h) and range2 = snd ai.(succ h) in match range1, range2 with | [] , _ | _ , [] -> assert false | _ , lower_bound2::_ -> If(Code.CLe (Int32.of_int lower_bound2),b2,b1) in let len = Array.length ai in if len = 0 then Empty else loop 0 (len - 1);; let rec fold_cont f b acc = match b with | If (i,b1,b2) -> acc >> fold_cont f b1 >> fold_cont f b2 | Switch a -> Array.fold_left (fun acc (_,b) -> fold_cont f b acc) acc a | Branch (pc,_) -> f pc acc | Empty -> acc let nbcomp a = let rec loop c = function | Empty -> c | Branch _ -> c | If(_,a,b) -> let c = succ c in let c = loop c a in let c = loop c b in c | Switch a -> let c = succ c in Array.fold_left (fun acc (_,b) -> loop acc b) c a in loop 0 a end let fold_children blocks pc f accu = let block = AddrMap.find pc blocks in match block.branch with Return _ | Raise _ | Stop -> accu | Branch (pc', _) | Poptrap (pc', _) -> f pc' accu | Pushtrap ((pc1, _), _, (pc2, _), _) -> accu >> f pc1 >> f pc2 | Cond (cond, _, cont1, cont2) -> DTree.fold_cont f (DTree.build_if cond cont1 cont2) accu | Switch (_, a1, a2) -> let a1 = DTree.build_switch a1 and a2 = DTree.build_switch a2 in accu >> DTree.fold_cont f a1 >> DTree.fold_cont f a2 let rec build_graph st pc anc = if not (AddrSet.mem pc st.visited_blocks) then begin st.visited_blocks <- AddrSet.add pc st.visited_blocks; let anc = AddrSet.add pc anc in let s = Code.fold_children st.blocks pc AddrSet.add AddrSet.empty in Hashtbl.add st.all_succs pc s; let backs = AddrSet.inter s anc in Hashtbl.add st.backs pc backs; let s = fold_children st.blocks pc (fun x l -> x :: l) [] in let succs = List.filter (fun pc -> not (AddrSet.mem pc anc)) s in Hashtbl.add st.succs pc succs; AddrSet.iter (fun pc' -> st.loops <- AddrSet.add pc' st.loops) backs; List.iter (fun pc' -> build_graph st pc' anc) succs; List.iter (fun pc' -> incr_preds st pc') succs end let rec dominance_frontier_rec st pc visited grey = let n = get_preds st pc in let v = try AddrMap.find pc visited with Not_found -> 0 in if v < n then begin let v = v + 1 in let visited = AddrMap.add pc v visited in if v = n then begin let grey = AddrSet.remove pc grey in let s = Hashtbl.find st.succs pc in List.fold_right (fun pc' (visited, grey) -> dominance_frontier_rec st pc' visited grey) s (visited, grey) end else begin (visited, if v = 1 then AddrSet.add pc grey else grey) end end else (visited, grey) let dominance_frontier st pc = snd (dominance_frontier_rec st pc AddrMap.empty AddrSet.empty) let rec resolve_node interm pc = try resolve_node interm (fst (AddrMap.find pc interm)) with Not_found -> pc let resolve_nodes interm s = AddrSet.fold (fun pc s' -> AddrSet.add (resolve_node interm pc) s') s AddrSet.empty (****) let rec visit visited prev s m x l = if not (VarSet.mem x visited) then begin let visited = VarSet.add x visited in let y = VarMap.find x m in if Code.Var.compare x y = 0 then (visited, None, l) else if VarSet.mem y prev then begin let t = Code.Var.fresh () in (visited, Some (y, t), (x, t) :: l) end else if VarSet.mem y s then begin let (visited, aliases, l) = visit visited (VarSet.add x prev) s m y l in match aliases with Some (a, b) when Code.Var.compare a x = 0 -> (visited, None, (b, a) :: (x, y) :: l) | _ -> (visited, aliases, (x, y) :: l) end else (visited, None, (x, y) :: l) end else (visited, None, l) let visit_all params args = let m = Subst.build_mapping params args in let s = List.fold_left (fun s x -> VarSet.add x s) VarSet.empty params in let (_, l) = VarSet.fold (fun x (visited, l) -> let (visited, _, l) = visit visited VarSet.empty s m x l in (visited, l)) s (VarSet.empty, []) in l let parallel_renaming params args continuation queue = let l = List.rev (visit_all params args) in List.fold_left (fun continuation (y, x) -> fun queue -> let instrs,((px, cx), queue) = access_queue_may_flush queue y x in let (st, queue) = flush_queue queue px (instrs@[J.Variable_statement [J.V y, Some (cx, J.N)], J.N]) in st @ continuation queue) continuation l queue (****) let apply_fun_raw f params = let n = List.length params in J.ECond (J.EBin (J.EqEq, J.EDot (f, "length"), J.ENum (float n)), J.ECall (f, params, J.N), J.ECall (s_var "caml_call_gen", [f; J.EArr (List.map (fun x -> Some x) params)], J.N)) let generate_apply_fun n = let f' = Var.fresh () in let f = J.V f' in Code.Var.name f' "fun"; let params = Array.to_list (Array.init n (fun i -> let a = Var.fresh () in Var.name a ("var"^(string_of_int i)); J.V a)) in let f' = J.EVar f in let params' = List.map (fun x -> J.EVar x) params in J.EFun (None, f :: params, [J.Statement (J.Return_statement (Some (apply_fun_raw f' params'))), J.N], J.N) let apply_fun ctx f params loc = if Option.Optim.inline_callgen () then apply_fun_raw f params else let y = Share.get_apply generate_apply_fun (List.length params) ctx.Ctx.share in J.ECall (y, f::params, loc) (****) let to_int cx = J.EBin(J.Bor, cx, J.ENum 0.) (* 32 bit ints *) let _ = List.iter (fun (nm, nm') -> Primitive.alias nm nm') ["%int_mul", "caml_mul"; "%int_div", "caml_div"; "%int_mod", "caml_mod"; "caml_int32_neg", "%int_neg"; "caml_int32_add", "%int_add"; "caml_int32_sub", "%int_sub"; "caml_int32_mul", "%int_mul"; "caml_int32_div", "%int_div"; "caml_int32_mod", "%int_mod"; "caml_int32_and", "%int_and"; "caml_int32_or", "%int_or"; "caml_int32_xor", "%int_xor"; "caml_int32_shift_left", "%int_lsl"; "caml_int32_shift_right", "%int_asr"; "caml_int32_shift_right_unsigned", "%int_lsr"; "caml_int32_of_int", "%identity"; "caml_int32_to_int", "%identity"; "caml_int32_of_float", "caml_int_of_float"; "caml_int32_to_float", "%identity"; "caml_int32_format", "caml_format_int"; "caml_int32_of_string", "caml_int_of_string"; "caml_int32_compare", "caml_int_compare"; "caml_nativeint_neg", "%int_neg"; "caml_nativeint_add", "%int_add"; "caml_nativeint_sub", "%int_sub"; "caml_nativeint_mul", "%int_mul"; "caml_nativeint_div", "%int_div"; "caml_nativeint_mod", "%int_mod"; "caml_nativeint_and", "%int_and"; "caml_nativeint_or", "%int_or"; "caml_nativeint_xor", "%int_xor"; "caml_nativeint_shift_left", "%int_lsl"; "caml_nativeint_shift_right", "%int_asr"; "caml_nativeint_shift_right_unsigned", "%int_lsr"; "caml_nativeint_of_int", "%identity"; "caml_nativeint_to_int", "%identity"; "caml_nativeint_of_float", "caml_int_of_float"; "caml_nativeint_to_float", "%identity"; "caml_nativeint_of_int32", "%identity"; "caml_nativeint_to_int32", "%identity"; "caml_nativeint_format", "caml_format_int"; "caml_nativeint_of_string", "caml_int_of_string"; "caml_nativeint_compare", "caml_int_compare"; "caml_int64_of_int", "caml_int64_of_int32"; "caml_int64_to_int", "caml_int64_to_int32"; "caml_int64_of_nativeint", "caml_int64_of_int32"; "caml_int64_to_nativeint", "caml_int64_to_int32"; "caml_float_of_int", "%identity"; "caml_array_get_float", "caml_array_get"; "caml_array_get_addr", "caml_array_get"; "caml_array_set_float", "caml_array_set"; "caml_array_set_addr", "caml_array_set"; "caml_array_unsafe_get_float", "caml_array_unsafe_get"; "caml_array_unsafe_set_float", "caml_array_unsafe_set"; "caml_alloc_dummy_float", "caml_alloc_dummy"; "caml_make_array", "%identity"; "caml_ensure_stack_capacity", "%identity"; "caml_js_from_float", "%identity"; "caml_js_to_float", "%identity"] let internal_primitives = Hashtbl.create 31 let internal_prim name = try Hashtbl.find internal_primitives name with Not_found -> None let register_prim name k f = Primitive.register name k None None; Hashtbl.add internal_primitives name (Some f) let register_un_prim name k f = register_prim name k (fun l queue ctx loc -> match l with [x] -> let ((px, cx), queue) = access_queue' ~ctx queue x in (f cx loc, or_p (kind k) px, queue) | _ -> assert false) let register_un_prim_ctx name k f = register_prim name k (fun l queue ctx loc -> match l with [x] -> let ((px, cx), queue) = access_queue' ~ctx queue x in (f ctx cx loc, or_p (kind k) px, queue) | _ -> assert false) let register_bin_prim name k f = register_prim name k (fun l queue ctx loc -> match l with [x;y] -> let ((px, cx), queue) = access_queue' ~ctx queue x in let ((py, cy), queue) = access_queue' ~ctx queue y in (f cx cy loc, or_p (kind k) (or_p px py), queue) | _ -> assert false) let register_tern_prim name f = register_prim name `Mutator (fun l queue ctx loc -> match l with [x;y;z] -> let ((px, cx), queue) = access_queue' ~ctx queue x in let ((py, cy), queue) = access_queue' ~ctx queue y in let ((pz, cz), queue) = access_queue' ~ctx queue z in (f cx cy cz loc, or_p mutator_p (or_p px (or_p py pz)), queue) | _ -> assert false) let register_un_math_prim name prim = register_un_prim name `Pure (fun cx loc -> J.ECall (J.EDot (s_var "Math", prim), [cx], loc)) let register_bin_math_prim name prim = register_bin_prim name `Pure (fun cx cy loc -> J.ECall (J.EDot (s_var "Math", prim), [cx; cy], loc)) let _ = register_un_prim_ctx "%caml_format_int_special" `Pure (fun ctx cx loc -> let p = Share.get_prim s_var "caml_new_string" ctx.Ctx.share in J.ECall (p, [J.EBin (J.Plus,str_js "",cx)], loc)); register_bin_prim "caml_array_unsafe_get" `Mutable (fun cx cy _ -> J.EAccess (cx, J.EBin (J.Plus, cy, one))); register_bin_prim "%int_add" `Pure (fun cx cy _ -> to_int (J.EBin (J.Plus,cx,cy))); register_bin_prim "%int_sub" `Pure (fun cx cy _ -> to_int (J.EBin (J.Minus,cx,cy))); register_bin_prim "%direct_int_mul" `Pure (fun cx cy _ -> to_int (J.EBin (J.Mul, cx, cy))); register_bin_prim "%direct_int_div" `Pure (fun cx cy _ -> to_int (J.EBin (J.Div, cx, cy))); register_bin_prim "%direct_int_mod" `Pure (fun cx cy _ -> to_int (J.EBin (J.Mod, cx, cy))); register_bin_prim "%int_and" `Pure (fun cx cy _ -> J.EBin (J.Band, cx, cy)); register_bin_prim "%int_or" `Pure (fun cx cy _ -> J.EBin (J.Bor, cx, cy)); register_bin_prim "%int_xor" `Pure (fun cx cy _ -> J.EBin (J.Bxor, cx, cy)); register_bin_prim "%int_lsl" `Pure (fun cx cy _ -> J.EBin (J.Lsl, cx, cy)); register_bin_prim "%int_lsr" `Pure (fun cx cy _ -> to_int (J.EBin (J.Lsr, cx, cy))); register_bin_prim "%int_asr" `Pure (fun cx cy _ -> J.EBin (J.Asr, cx, cy)); register_un_prim "%int_neg" `Pure (fun cx _ -> to_int (J.EUn (J.Neg, cx))); register_bin_prim "caml_eq_float" `Pure (fun cx cy _ -> bool (J.EBin (J.EqEq, float_val cx, float_val cy))); register_bin_prim "caml_neq_float" `Pure (fun cx cy _ -> bool (J.EBin (J.NotEq, float_val cx, float_val cy))); register_bin_prim "caml_ge_float" `Pure (fun cx cy _ -> bool (J.EBin (J.Le, float_val cy, float_val cx))); register_bin_prim "caml_le_float" `Pure (fun cx cy _ -> bool (J.EBin (J.Le, float_val cx, float_val cy))); register_bin_prim "caml_gt_float" `Pure (fun cx cy _ -> bool (J.EBin (J.Lt, float_val cy, float_val cx))); register_bin_prim "caml_lt_float" `Pure (fun cx cy _ -> bool (J.EBin (J.Lt, float_val cx, float_val cy))); register_bin_prim "caml_add_float" `Pure (fun cx cy _ -> val_float (J.EBin (J.Plus, float_val cx, float_val cy))); register_bin_prim "caml_sub_float" `Pure (fun cx cy _ -> val_float (J.EBin (J.Minus, float_val cx, float_val cy))); register_bin_prim "caml_mul_float" `Pure (fun cx cy _ -> val_float (J.EBin (J.Mul, float_val cx, float_val cy))); register_bin_prim "caml_div_float" `Pure (fun cx cy _ -> val_float (J.EBin (J.Div, float_val cx, float_val cy))); register_un_prim "caml_neg_float" `Pure (fun cx _ -> val_float (J.EUn (J.Neg, float_val cx))); register_bin_prim "caml_fmod_float" `Pure (fun cx cy _ -> val_float (J.EBin (J.Mod, float_val cx, float_val cy))); register_tern_prim "caml_array_unsafe_set" (fun cx cy cz _ -> J.EBin (J.Eq, J.EAccess (cx, J.EBin (J.Plus, cy, one)), cz)); register_un_prim "caml_alloc_dummy" `Pure (fun cx _ -> J.EArr []); register_un_prim "caml_obj_dup" `Mutable (fun cx loc -> J.ECall (J.EDot (cx, "slice"), [], loc)); register_un_prim "caml_int_of_float" `Pure (fun cx loc -> to_int cx); register_un_math_prim "caml_abs_float" "abs"; register_un_math_prim "caml_acos_float" "acos"; register_un_math_prim "caml_asin_float" "asin"; register_un_math_prim "caml_atan_float" "atan"; register_bin_math_prim "caml_atan2_float" "atan2"; register_un_math_prim "caml_ceil_float" "ceil"; register_un_math_prim "caml_cos_float" "cos"; register_un_math_prim "caml_exp_float" "exp"; register_un_math_prim "caml_floor_float" "floor"; register_un_math_prim "caml_log_float" "log"; register_bin_math_prim "caml_power_float" "pow"; register_un_math_prim "caml_sin_float" "sin"; register_un_math_prim "caml_sqrt_float" "sqrt"; register_un_math_prim "caml_tan_float" "tan"; register_un_prim "caml_js_from_bool" `Pure (fun cx _ -> J.EUn (J.Not, J.EUn (J.Not, cx))); register_un_prim "caml_js_to_bool" `Pure (fun cx _ -> to_int cx); register_un_prim "caml_js_from_string" `Mutable (fun cx loc -> J.ECall (J.EDot (cx, "toString"), [], loc)); register_tern_prim "caml_js_set" (fun cx cy cz _ -> J.EBin (J.Eq, J.EAccess (cx, cy), cz)); register_bin_prim "caml_js_get" `Mutable (fun cx cy _ -> J.EAccess (cx, cy)); register_bin_prim "caml_js_delete" `Mutable (fun cx cy _ -> J.EUn(J.Delete, J.EAccess (cx, cy))); register_bin_prim "caml_js_equals" `Mutable (fun cx cy _ -> bool (J.EBin (J.EqEq, cx, cy))); register_bin_prim "caml_js_instanceof" `Pure (fun cx cy _ -> bool (J.EBin(J.InstanceOf, cx, cy))); register_un_prim "caml_js_typeof" `Pure (fun cx _ -> J.EUn(J.Typeof, cx)) (****) let varset_disjoint s s' = not (VarSet.exists (fun x -> VarSet.mem x s') s) let is_ident = let l = Array.init 256 (fun i -> let c = Char.chr i in if (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c = '_' || c = '$' then 1 else if (c >= '0' && c <='9') then 2 else 0 ) in fun s -> try for i = 0 to String.length s - 1 do let code = l.(Char.code(s.[i])) in if i = 0 then assert (code = 1) else assert (code >= 1) done; true with _ -> false let ident_from_string s = match Util.split_char '.' s with | [] -> assert false | [x] -> if not (is_ident x) then Format.eprintf "Warning: %S is not a valid identifier; the generated code might be incorrect.@." x; s_var x | (x::xs) as l -> Format.eprintf "Warning: %S should be written (Js.Unsafe.variable %S)##%s@." s x (String.concat "##" xs); if not (List.for_all is_ident l) then Format.eprintf "Warning: %S is not a valid identifier; the generated code might be incorrect.@." s; List.fold_left (fun e i -> J.EDot(e,i)) (s_var x) xs let rec group_closures_rec closures req = match closures with [] -> ([], VarSet.empty) | ((var, vars, req_tc, clo) as elt) :: rem -> let req = VarSet.union vars req in let req = VarSet.union req req_tc in let (closures', prov) = group_closures_rec rem req in match closures' with | [] -> ([elt] :: closures', VarSet.singleton var) | _ when varset_disjoint prov req -> ([elt] :: closures', VarSet.singleton var) | l :: r -> ((elt :: l) :: r, VarSet.add var prov) let group_closures l = fst (group_closures_rec l VarSet.empty) let rec collect_closures ctx l = match l with Let (x, Closure (args, ((pc, _) as cont))) :: rem -> let clo = compile_closure ctx false cont in let all_vars = AddrMap.find pc ctx.Ctx.mutated_vars in let tc = (new Js_tailcall.tailcall) in ignore(tc#sources clo); let req_tc = (tc#get) in let vars = VarSet.remove x all_vars in let loc = source_location ctx ~after:true pc in let clo = match clo with (st, J.N) :: rem -> (st, J.U) :: rem | _ -> clo in let cl = J.EFun (None, List.map (fun v -> J.V v) args, clo, loc) in let (l', rem') = collect_closures ctx rem in ((x, vars, req_tc, cl) :: l', rem') | _ -> ([], l) (****) and translate_expr ctx queue loc x e level : _ * J.statement_list = match e with Const i -> (int32 i, const_p, queue),[] | Apply (x, l, true) -> let ((px, cx), queue) = access_queue queue x in let (args, prop, queue) = List.fold_right (fun x (args, prop, queue) -> let ((prop', cx), queue) = access_queue queue x in (cx :: args, or_p prop prop', queue)) l ([], or_p px mutator_p, queue) in (J.ECall (cx, args, loc), prop, queue),[] | Apply (x, l, false) -> let (args, prop, queue) = List.fold_right (fun x (args, prop, queue) -> let ((prop', cx), queue) = access_queue queue x in (cx :: args, or_p prop prop', queue)) l ([], mutator_p, queue) in let ((prop', f), queue) = access_queue queue x in let prop = or_p prop prop' in let e = apply_fun ctx f args loc in (e, prop, queue),[] | Block (tag, a) -> let (contents, prop, queue) = List.fold_right (fun x (args, prop, queue) -> let ((prop', cx), queue) = access_queue queue x in (Some cx :: args, or_p prop prop', queue)) (Array.to_list a) ([], const_p, queue) in (J.EArr (Some (int tag) :: contents), prop, queue),[] | Field (x, n) -> let ((px, cx), queue) = access_queue queue x in (J.EAccess (cx, int (n + 1)), or_p px mutable_p, queue),[] | Closure _ -> (* this is done by translate_instr *) assert false | Constant c -> let js, instrs = constant ~ctx c level in (js, const_p, queue), instrs | Prim (Extern "debugger",_) -> let ins = if Option.Optim.debugger () then J.Debugger_statement else J.Empty_statement in (J.ENum 0., const_p,queue), [ins, loc] | Prim (p, l) -> let res = match p, l with Vectlength, [x] -> let ((px, cx), queue) = access_queue' ~ctx queue x in (J.EBin (J.Minus, J.EDot (cx, "length"), one), px, queue) | Array_get, [x; y] -> let ((px, cx), queue) = access_queue' ~ctx queue x in let ((py, cy), queue) = access_queue' ~ctx queue y in (J.EAccess (cx, J.EBin (J.Plus, cy, one)), or_p mutable_p (or_p px py), queue) | Extern "caml_js_var", [Pc (String nm)] -> (ident_from_string nm, const_p, queue) | Extern ("caml_js_expr"|"caml_pure_js_expr"), [Pc (String nm)] -> begin try let lex = Parse_js.lexer_from_string nm in let e = Parse_js.parse_expr lex in (e, const_p, queue) with Parse_js.Parsing_error pi -> failwith (Printf.sprintf "Parsing error %S at l:%d col:%d" nm (pi.Parse_info.line + 1) pi.Parse_info.col) end | Extern "%caml_js_opt_call", Pv f :: Pv o :: l -> let ((pf, cf), queue) = access_queue queue f in let ((po, co), queue) = access_queue queue o in let (args, prop, queue) = List.fold_right (fun x (args, prop, queue) -> let ((prop', cx), queue) = access_queue' ~ctx queue x in (cx :: args, or_p prop prop', queue) ) l ([], mutator_p, queue) in (J.ECall (J.EDot (cf, "call"), co :: args, loc), or_p (or_p pf po) prop, queue) | Extern "%caml_js_opt_fun_call", Pv f :: l -> let ((pf, cf), queue) = access_queue queue f in let (args, prop, queue) = List.fold_right (fun x (args, prop, queue) -> let ((prop', cx), queue) = access_queue' ~ctx queue x in (cx :: args, or_p prop prop', queue)) l ([], mutator_p, queue) in (J.ECall (cf, args, loc), or_p pf prop, queue) | Extern "%caml_js_opt_meth_call", Pv o :: Pc (String m) :: l -> let ((po, co), queue) = access_queue queue o in let (args, prop, queue) = List.fold_right (fun x (args, prop, queue) -> let ((prop', cx), queue) = access_queue' ~ctx queue x in (cx :: args, or_p prop prop', queue)) l ([], mutator_p, queue) in (J.ECall (J.EDot (co, m), args, loc), or_p po prop, queue) | Extern "%caml_js_opt_new", Pv c :: l -> let ((pc, cc), queue) = access_queue queue c in let (args, prop, queue) = List.fold_right (fun x (args, prop, queue) -> let ((prop', cx), queue) = access_queue' ~ctx queue x in (cx :: args, or_p prop prop', queue)) l ([], mutator_p, queue) in (J.ENew (cc, if args = [] then None else Some args), or_p pc prop, queue) | Extern "caml_js_get", [Pv o; Pc (String f)] -> let ((po, co), queue) = access_queue queue o in (J.EDot (co, f), or_p po mutable_p, queue) | Extern "caml_js_set", [Pv o; Pc (String f); Pv v] -> let ((po, co), queue) = access_queue queue o in let ((pv, cv), queue) = access_queue queue v in (J.EBin (J.Eq, J.EDot (co, f), cv), or_p (or_p po pv) mutator_p, queue) | Extern "caml_js_delete", [Pv o; Pc (String f)] -> let ((po, co), queue) = access_queue queue o in (J.EUn(J.Delete, J.EDot (co, f)), or_p po mutator_p, queue) | Extern "%overrideMod", [Pc (String m);Pc (String f)] -> s_var (Printf.sprintf "caml_%s_%s" m f), const_p,queue | Extern "%overrideMod", _ -> assert false | Extern "%caml_js_opt_object", fields -> let rec build_fields queue l = match l with [] -> (const_p, [], queue) | Pc (String nm) :: x :: r -> let ((prop, cx), queue) = access_queue' ~ctx queue x in let (prop', r', queue') = build_fields queue r in (or_p prop prop', (J.PNS nm, cx) :: r', queue) | _ -> assert false in let (prop, fields, queue) = build_fields queue fields in (J.EObj fields, prop, queue) | Extern name, l -> begin let name = Primitive.resolve name in match internal_prim name with | Some f -> f l queue ctx loc | None -> if name.[0] = '%' then failwith (Printf.sprintf "Unresolved interal primitive: %s" name); let prim = Share.get_prim s_var name ctx.Ctx.share in let prim_kind = kind (Primitive.kind name) in let (args, prop, queue) = List.fold_right (fun x (args, prop, queue) -> let ((prop', cx), queue) = access_queue' ~ctx queue x in (cx :: args, or_p prop prop', queue)) l ([], prim_kind, queue) in (J.ECall (prim, args, loc), prop, queue) end | Not, [x] -> let ((px, cx), queue) = access_queue' ~ctx queue x in (J.EBin (J.Minus, one, cx), px, queue) | Lt, [x; y] -> let ((px, cx), queue) = access_queue' ~ctx queue x in let ((py, cy), queue) = access_queue' ~ctx queue y in (bool (J.EBin (J.Lt, cx, cy)), or_p px py, queue) | Le, [x; y] -> let ((px, cx), queue) = access_queue' ~ctx queue x in let ((py, cy), queue) = access_queue' ~ctx queue y in (bool (J.EBin (J.Le, cx, cy)), or_p px py, queue) | Eq, [x; y] -> let ((px, cx), queue) = access_queue' ~ctx queue x in let ((py, cy), queue) = access_queue' ~ctx queue y in (bool (J.EBin (J.EqEqEq, cx, cy)), or_p px py, queue) | Neq, [x; y] -> let ((px, cx), queue) = access_queue' ~ctx queue x in let ((py, cy), queue) = access_queue' ~ctx queue y in (bool (J.EBin (J.NotEqEq, cx, cy)), or_p px py, queue) | IsInt, [x] -> (* JavaScript engines recognize the pattern 'typeof x==="number"'; if the string is shared, less efficient code is generated. *) let ((px, cx), queue) = access_queue' ~ctx queue x in (J.EBin(J.EqEqEq, J.EUn (J.Typeof, cx), str_js "number"), px, queue) | Ult, [x; y] -> let ((px, cx), queue) = access_queue' ~ctx queue x in let ((py, cy), queue) = access_queue' ~ctx queue y in (bool (J.EBin (J.Lt, unsigned cx, unsigned cy)), or_p px py, queue) | (Vectlength | Array_get | Not | IsInt | Eq | Neq | Lt | Le | Ult), _ -> assert false in res,[] and translate_closures ctx expr_queue l loc = match l with [] -> ([], expr_queue) | [(x, vars, req_tc, cl)] :: rem -> let vars = vars >> VarSet.elements >> List.map (fun v -> J.V v) in let prim name = Share.get_prim s_var name ctx.Ctx.share in let defs = Js_tailcall.rewrite [x,cl,loc,req_tc] prim in let rec return_last x = function | [] -> [J.Statement (J.Return_statement (Some (J.EVar (J.V x)))),J.N] | [(J.Variable_statement l as sts, loc)] -> let l' = List.rev l in begin match l' with | (J.V x',Some (e,pc)) :: rem when x = x' -> [J.Statement (J.Variable_statement (List.rev rem)), J.N; J.Statement (J.Return_statement (Some e)), pc] | _ -> [J.Statement sts, loc] end | (y,loc)::xs -> (J.Statement y, loc) :: return_last x xs in let statements = if vars = [] then defs else [J.Variable_statement [ J.V x, Some ( J.ECall (J.EFun (None, vars, return_last x defs, J.N), List.map (fun x -> J.EVar x) vars, J.N), J.N)], J.N] in let (st, expr_queue) = match ctx.Ctx.live.(Var.idx x),statements with | 1, [J.Variable_statement [(J.V x',Some (e', _))],_] when x == x' -> enqueue expr_queue flush_p x e' loc 1 [] | 0, _ -> (* deadcode is off *) flush_queue expr_queue flush_p statements | _ -> flush_queue expr_queue flush_p statements in let (st', expr_queue) = translate_closures ctx expr_queue rem loc in (st @ st', expr_queue) | l :: rem -> let names = List.fold_left (fun s (x, _, _, _) -> VarSet.add x s) VarSet.empty l in let vars = List.fold_left (fun s (_, s', _, _) -> VarSet.union s s') VarSet.empty l in let vars = VarSet.diff vars names >> VarSet.elements >> List.map (fun v -> J.V v) in let defs' = List.map (fun (x, _, req_tc, cl) -> (x, cl, loc, req_tc)) l in let prim name = Share.get_prim s_var name ctx.Ctx.share in let defs = Js_tailcall.rewrite defs' prim in let statements = if vars = [] then defs else begin let tbl = Var.fresh () in Var.name tbl "funenv"; let arr = J.EArr (List.map (fun (x, _, _, _) -> Some (J.EVar (J.V x))) l) in let assgn = List.fold_left (fun (l, n) (x, _, _, _) -> ((J.V x, Some (J.EAccess (J.EVar (J.V tbl), int n), loc)) :: l, n + 1)) ([], 0) l in [J.Variable_statement ((J.V tbl, Some (J.ECall (J.EFun (None, vars, List.map (fun (s, loc) -> (J.Statement s, loc)) defs @ [J.Statement (J.Return_statement (Some arr)),J.N], J.N), List.map (fun x -> J.EVar x) vars, J.N), J.N)) :: List.rev (fst assgn)), J.N] end in let (st, expr_queue) = flush_queue expr_queue flush_p statements in let (st', expr_queue) = translate_closures ctx expr_queue rem loc in (st @ st', expr_queue) and translate_instr ctx expr_queue loc instr = match instr with [] -> ([], expr_queue) | Let (_, Closure _) :: _ -> let (l, rem) = collect_closures ctx instr in let l = group_closures l in let (st, expr_queue) = translate_closures ctx expr_queue l loc in let (instrs, expr_queue) = translate_instr ctx expr_queue loc rem in (st @ instrs, expr_queue) | i :: rem -> let (st, expr_queue) = match i with Let (x, e) -> let (ce, prop, expr_queue),instrs = translate_expr ctx expr_queue loc x e 0 in begin match ctx.Ctx.live.(Var.idx x),e with | 0,_ -> flush_queue expr_queue prop (instrs @ [J.Expression_statement ce, loc]) | 1,_ -> enqueue expr_queue prop x ce loc 1 instrs (* We could inline more. size_v : length of the variable after serialization size_c : length of the constant after serialization num : number of occurence size_c * n < size_v * n + size_v + 1 + size_c *) | n,(Const _| Constant (Int _|Float _)) -> enqueue expr_queue prop x ce loc n instrs | _ -> flush_queue expr_queue prop (instrs@ [J.Variable_statement [J.V x, Some (ce, loc)], loc]) end | Set_field (x, n, y) -> let ((px, cx), expr_queue) = access_queue expr_queue x in let ((py, cy), expr_queue) = access_queue expr_queue y in flush_queue expr_queue mutator_p [J.Expression_statement ((J.EBin (J.Eq, J.EAccess (cx, int (n + 1)), cy))), loc] | Offset_ref (x, 1) -> (* FIX: may overflow.. *) let ((px, cx), expr_queue) = access_queue expr_queue x in flush_queue expr_queue mutator_p [J.Expression_statement ((J.EUn (J.IncrA, (J.EAccess (cx, J.ENum 1.))))), loc] | Offset_ref (x, n) -> (* FIX: may overflow.. *) let ((px, cx), expr_queue) = access_queue expr_queue x in flush_queue expr_queue mutator_p [J.Expression_statement ((J.EBin (J.PlusEq, (J.EAccess (cx, J.ENum 1.)), int n))), loc] | Array_set (x, y, z) -> let ((px, cx), expr_queue) = access_queue expr_queue x in let ((py, cy), expr_queue) = access_queue expr_queue y in let ((pz, cz), expr_queue) = access_queue expr_queue z in flush_queue expr_queue mutator_p [J.Expression_statement ((J.EBin (J.Eq, J.EAccess (cx, J.EBin(J.Plus, cy, one)), cz))), loc] in let (instrs, expr_queue) = translate_instr ctx expr_queue loc rem in (st @ instrs, expr_queue) and compile_block st queue (pc : addr) frontier interm = if queue <> [] && AddrSet.mem pc st.loops then flush_all queue (compile_block st [] pc frontier interm) else begin if pc >= 0 then begin if AddrSet.mem pc st.visited_blocks then begin Format.eprintf "!!!! %d@." pc; assert false end; st.visited_blocks <- AddrSet.add pc st.visited_blocks end; if debug () then begin if AddrSet.mem pc st.loops then Format.eprintf "@[<2>for(;;){@,"; Format.eprintf "block %d;@ @?" pc end; if AddrSet.mem pc st.loops then begin let lab = match st.loop_stack with (_, (l, _)) :: _ -> J.Label.succ l | [] -> J.Label.zero in st.loop_stack <- (pc, (lab, ref false)) :: st.loop_stack end; let succs = Hashtbl.find st.succs pc in let backs = Hashtbl.find st.backs pc in (* Remove limit *) if pc < 0 then List.iter (fun pc -> unprotect_preds st pc) succs; let succs = List.map (fun pc -> (pc, dominance_frontier st pc)) succs in let grey = List.fold_right (fun (_, frontier) grey -> AddrSet.union frontier grey) succs AddrSet.empty in let new_frontier = resolve_nodes interm grey in let block = AddrMap.find pc st.blocks in let (seq, queue) = translate_instr st.ctx queue (source_location st.ctx pc) block.body in let body = seq @ match block.branch with Code.Pushtrap ((pc1, args1), x, (pc2, args2), pc3) -> (* FIX: document this *) let grey = dominance_frontier st pc2 in let grey' = resolve_nodes interm grey in let limit_body = (* We need to make sure that pc3 is live (indeed, the continuation may have been optimized away by inlining) *) AddrSet.is_empty grey' && pc3 >= 0 && Hashtbl.mem st.succs pc3 in let inner_frontier = if limit_body then AddrSet.add pc3 grey' else grey' in if limit_body then incr_preds st pc3; assert (AddrSet.cardinal inner_frontier <= 1); if debug () then Format.eprintf "@[<2>try {@,"; let body = compile_branch st [] (pc1, args1) None AddrSet.empty inner_frontier interm in if debug () then Format.eprintf "} catch {@,"; let handler = compile_block st [] pc2 inner_frontier interm in let handler = if st.ctx.Ctx.live.(Var.idx x) > 0 && Option.Optim.excwrap () then (J.Expression_statement ( J.EBin( J.Eq, J.EVar (J.V x), J.ECall (Share.get_prim s_var "caml_wrap_exception" st.ctx.Ctx.share, [J.EVar (J.V x)], J.N))),J.N) ::handler else handler in let x = let block2 = AddrMap.find pc2 st.blocks in let m = Subst.build_mapping args2 block2.params in try VarMap.find x m with Not_found -> x in if debug () then Format.eprintf "}@]@ "; if limit_body then decr_preds st pc3; let wrap s = (* We wrap [try ... catch ...] statements at toplevel inside an anonymous function, as V8 does not optimize functions that contain these statements *) if st.at_toplevel && false (* DISABLED -> FIXME https://github.com/ocsigen/js_of_ocaml/issues/226*) then try let pc = AddrSet.choose inner_frontier in let block = AddrMap.find pc st.blocks in let x = match block.params with [x] -> x | [] -> raise Not_found | _ -> assert false in J.Variable_statement [J.V x, Some (J.ECall (J.EFun (None, [], [J.Statement s, J.N; J.Statement (J.Return_statement (Some (J.EVar (J.V x)))), J.N], J.N), [], J.N), J.N)] with Not_found -> J.Expression_statement (J.ECall (J.EFun (None, [], [J.Statement s, J.N], J.N), [], J.N)) else s in flush_all queue ((wrap (J.Try_statement (body, Some (J.V x, handler), None)), source_location st.ctx pc) :: if AddrSet.is_empty inner_frontier then [] else begin let pc = AddrSet.choose inner_frontier in if AddrSet.mem pc frontier then [] else compile_block st [] pc frontier interm end) | _ -> let (new_frontier, new_interm) = if AddrSet.cardinal new_frontier > 1 then begin let x = Code.Var.fresh () in let a = Array.of_list (AddrSet.elements new_frontier) in if debug () then Format.eprintf "@ var %a;" Code.Var.print x; let idx = st.interm_idx in st.interm_idx <- idx - 1; let cases = Array.map (fun pc -> (pc, [])) a in let switch = if Array.length cases > 2 then Code.Switch (x, cases, [||]) else Code.Cond (IsTrue, x, cases.(1), cases.(0)) in st.blocks <- AddrMap.add idx { params = []; handler = None; body = []; branch = switch } st.blocks; (* There is a branch from this switch to the members of the frontier. *) AddrSet.iter (fun pc -> incr_preds st pc) new_frontier; (* Put a limit: we are going to remove other branches to the members of the frontier (in compile_conditional), but they should remain in the frontier. *) AddrSet.iter (fun pc -> protect_preds st pc) new_frontier; Hashtbl.add st.succs idx (AddrSet.elements new_frontier); Hashtbl.add st.all_succs idx new_frontier; Hashtbl.add st.backs idx AddrSet.empty; (AddrSet.singleton idx, Array.fold_right (fun (pc, i) interm -> (AddrMap.add pc (idx, (x, i)) interm)) (Array.mapi (fun i pc -> (pc, i)) a) interm) end else (new_frontier, interm) in assert (AddrSet.cardinal new_frontier <= 1); (* Beware evaluation order! *) let cond = compile_conditional st queue pc block.branch block.handler backs new_frontier new_interm succs in cond @ if AddrSet.cardinal new_frontier = 0 then [] else begin let pc = AddrSet.choose new_frontier in if AddrSet.mem pc frontier then [] else compile_block st [] pc frontier interm end in if AddrSet.mem pc st.loops then begin let label = match st.loop_stack with (_, (l, used)) :: r -> st.loop_stack <- r; if !used then Some l else None | [] -> assert false in let st = (J.For_statement (J.Left None, None, None, (J.Block( (if AddrSet.cardinal frontier > 0 then begin if debug () then Format.eprintf "@ break (%d); }@]" (AddrSet.choose new_frontier); body @ [J.Break_statement None, J.N] end else begin if debug () then Format.eprintf "}@]"; body end)), J.N))), source_location st.ctx pc in match label with | None -> [st] | Some label -> [J.Labelled_statement (label, st), J.N] end else body end and compile_decision_tree st queue handler backs frontier interm succs loc cx dtree = (* Some changes here may require corresponding changes in function [DTree.fold_cont] above. *) let rec loop cx = function | DTree.Empty -> assert false | DTree.Branch ((pc,_) as cont) -> (* Block of code that never continues (either returns, throws an exception or loops back) *) (* If not found in successors, this is a backward edge *) let never = let d = try List.assoc pc succs with Not_found -> AddrSet.empty in not (AddrSet.mem pc frontier || AddrMap.mem pc interm) && AddrSet.is_empty d in never, compile_branch st [] cont handler backs frontier interm | DTree.If (cond,cont1,cont2) -> let never1, iftrue = loop cx cont1 in let never2, iffalse = loop cx cont2 in let e' = match cond with IsTrue -> cx | CEq n -> J.EBin (J.EqEqEq, int32 n, cx) | CLt n -> J.EBin (J.Lt, int32 n, cx) | CUlt n -> let n' = if n < 0l then unsigned (int32 n) else int32 n in J.EBin (J.Lt, n', unsigned cx) | CLe n -> J.EBin (J.Le, int32 n, cx) in never1&&never2, Js_simpl.if_statement e' loc (J.Block iftrue, J.N) never1 (J.Block iffalse, J.N) never2 | DTree.Switch a -> let all_never = ref true in let len = Array.length a in let last_index = len - 1 in let arr = Array.mapi (fun i (ints,cont) -> let never,cont = loop cx cont in if not never then all_never := false; let cont = if never || (* default case *) i = last_index then cont else cont @ [J.Break_statement None, J.N] in ints, cont) a in let (_,last) = arr.(last_index) in let l = Array.to_list (Array.sub arr 0 (len - 1)) in let l = List.flatten (List.map (fun (ints,br) -> map_last (fun last i -> J.ENum (float i), if last then br else [] ) ints ) l) in !all_never, [J.Switch_statement (cx, l, Some last, []), loc] in let cx, binds = match cx with | J.EVar _ | _ when DTree.nbcomp dtree <= 1 -> cx,[] | _ -> let v = J.V (Code.Var.fresh ()) in J.EVar v, [J.Variable_statement [v,Some (cx,J.N)],J.N] in (binds @ snd(loop cx dtree)) and compile_conditional st queue pc last handler backs frontier interm succs = List.iter (fun (pc, _) -> if AddrMap.mem pc interm then decr_preds st pc) succs; if debug () then begin match last with Branch _ | Poptrap _ | Pushtrap _ -> () | Return _ -> Format.eprintf "ret" | Raise _ -> Format.eprintf "raise" | Stop -> Format.eprintf "stop" | Cond _ -> Format.eprintf "@[cond{@," | Switch _ -> Format.eprintf "@[switch{@," end; let loc = source_location st.ctx pc in let res = match last with Return x -> let ((px, cx), queue) = access_queue queue x in flush_all queue [J.Return_statement (Some cx), loc] | Raise x -> let ((px, cx), queue) = access_queue queue x in flush_all queue [J.Throw_statement cx, loc] | Stop -> flush_all queue [J.Return_statement None, loc] | Branch cont -> compile_branch st queue cont handler backs frontier interm | Pushtrap _ -> assert false | Poptrap cont -> flush_all queue (compile_branch st [] cont None backs frontier interm) | Cond (cond,x,c1,c2) -> let ((px, cx), queue) = access_queue queue x in let b = compile_decision_tree st queue handler backs frontier interm succs loc cx (DTree.build_if cond c1 c2) in flush_all queue b | Switch (x,[||],a2) -> let ((px, cx), queue) = access_queue queue x in let code = compile_decision_tree st queue handler backs frontier interm succs loc (J.EAccess(cx, J.ENum 0.)) (DTree.build_switch a2) in flush_all queue code | Switch (x,a1,[||]) -> let ((px, cx), queue) = access_queue queue x in let code = compile_decision_tree st queue handler backs frontier interm succs loc cx (DTree.build_switch a1) in flush_all queue code | Switch (x,a1,a2) -> (* The variable x is accessed several times, so we can directly refer to it *) (* We do not want to share the string "number". See comment for IsInt *) let b1 = compile_decision_tree st queue handler backs frontier interm succs loc (var x) (DTree.build_switch a1) in let b2 = compile_decision_tree st queue handler backs frontier interm succs loc (J.EAccess(var x, J.ENum 0.)) (DTree.build_switch a2) in let code = Js_simpl.if_statement (J.EBin(J.EqEqEq, J.EUn (J.Typeof, var x), str_js "number")) loc (Js_simpl.block b1) false (Js_simpl.block b2) false in flush_all queue code in if debug () then begin match last with Branch _ | Poptrap _ | Pushtrap _ | Return _ | Raise _ | Stop -> () | Switch _ | Cond _ -> Format.eprintf "}@]@ " end; res and compile_argument_passing ctx queue (pc, args) backs continuation = if args = [] then continuation queue else let block = AddrMap.find pc ctx.Ctx.blocks in parallel_renaming block.params args continuation queue and compile_exn_handling ctx queue (pc, args) handler continuation = if pc < 0 then continuation queue else let block = AddrMap.find pc ctx.Ctx.blocks in match block.handler with None -> continuation queue | Some (x0, (h_pc, h_args)) -> let old_args = match handler with Some (y, (old_pc, old_args)) -> assert (Var.compare x0 y = 0 && old_pc = h_pc && List.length old_args = List.length h_args); old_args | None -> [] in (* When an extra block is inserted during code generation, args is [] *) let m = Subst.build_mapping (if args = [] then [] else block.params) args in let h_block = AddrMap.find h_pc ctx.Ctx.blocks in let rec loop continuation old args params queue = match args, params with [], [] -> continuation queue | x :: args, y :: params -> let (z, old) = match old with [] -> (None, []) | z :: old -> (Some z, old) in let x' = try Some (VarMap.find x m) with Not_found -> Some x in if Var.compare x x0 = 0 || x' = z then loop continuation old args params queue else begin let ((px, cx), queue) = access_queue queue x in let (st, queue) = (*FIX: we should flush only the variables we need rather than doing this; do the same for closure free variables *) match 2 (*ctx.Ctx.live.(Var.idx y)*) with 0 -> assert false | 1 -> enqueue queue px y cx (source_location ctx pc) 1 [] | _ -> flush_queue queue px [let loc = source_location ctx pc in J.Variable_statement [J.V y, Some (cx, loc)], loc] in st @ loop continuation old args params queue end | _ -> assert false in loop continuation old_args h_args h_block.params queue and compile_branch st queue ((pc, _) as cont) handler backs frontier interm = compile_argument_passing st.ctx queue cont backs (fun queue -> compile_exn_handling st.ctx queue cont handler (fun queue -> if AddrSet.mem pc backs then begin let label = match st.loop_stack with [] -> assert false | (pc', _) :: rem -> if pc = pc' then None else begin let (lab, used) = List.assoc pc rem in used := true; Some lab end in if debug () then begin if label = None then Format.eprintf "continue;@ " else Format.eprintf "continue (%d);@ " pc end; flush_all queue [J.Continue_statement label, J.N] end else if AddrSet.mem pc frontier || AddrMap.mem pc interm then begin if debug () then Format.eprintf "(br %d)@ " pc; flush_all queue (compile_branch_selection pc interm) end else compile_block st queue pc frontier interm)) and compile_branch_selection pc interm = try let (pc, (x, i)) = AddrMap.find pc interm in if debug () then Format.eprintf "@ %a=%d;" Code.Var.print x i; (J.Variable_statement [J.V x, Some (int i, J.N)], J.N) :: compile_branch_selection pc interm with Not_found -> [] and compile_closure ctx at_toplevel (pc, args) = let st = { visited_blocks = AddrSet.empty; loops = AddrSet.empty; loop_stack = []; all_succs = Hashtbl.create 17; succs = Hashtbl.create 17; backs = Hashtbl.create 17; preds = Hashtbl.create 17; interm_idx = -1; ctx = ctx; blocks = ctx.Ctx.blocks; at_toplevel } in build_graph st pc AddrSet.empty; let current_blocks = st.visited_blocks in st.visited_blocks <- AddrSet.empty; if debug () then Format.eprintf "@[closure{@,"; let res = compile_branch st [] (pc, args) None AddrSet.empty AddrSet.empty AddrMap.empty in if AddrSet.cardinal st.visited_blocks <> AddrSet.cardinal current_blocks then begin Format.eprintf "Some blocks not compiled!@."; assert false end; if debug () then Format.eprintf "}@]@ "; List.map (fun (st, loc) -> (J.Statement st, loc)) res let generate_shared_value ctx = let strings = J.Statement ( J.Variable_statement ( List.map (fun (s,v) -> v, Some (str_js s,J.N)) (StringMap.bindings ctx.Ctx.share.Share.vars.Share.strings) @ List.map (fun (s,v) -> v, Some (s_var s,J.N)) (StringMap.bindings ctx.Ctx.share.Share.vars.Share.prims))), J.U in if not (Option.Optim.inline_callgen ()) then let applies = List.map (fun (n,v) -> match generate_apply_fun n with | J.EFun (_,param,body,nid) -> J.Function_declaration (v,param,body,nid), J.U | _ -> assert false) (IntMap.bindings ctx.Ctx.share.Share.vars.Share.applies) in strings::applies else [strings] let compile_program ctx pc = let res = compile_closure ctx true (pc, []) in let res = generate_shared_value ctx @ res in if debug () then Format.eprintf "@.@."; res let f ((pc, blocks, _) as p) ?toplevel live_vars debug = let mutated_vars = Freevars.f p in let t' = Util.Timer.make () in let share = Share.get ?alias_prims:toplevel p in let ctx = Ctx.initial blocks live_vars mutated_vars share debug in let p = compile_program ctx pc in if times () then Format.eprintf " code gen.: %a@." Util.Timer.print t'; p js_of_ocaml-2.5/compiler/generate.mli000066400000000000000000000020071241254034500177410ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val f : Code.program -> ?toplevel:bool -> int array -> Parse_bytecode.Debug.data -> Javascript.program js_of_ocaml-2.5/compiler/inline.ml000066400000000000000000000146661241254034500172720ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Code let optimizable blocks pc acc = Code.traverse Code.fold_children (fun pc acc -> if not acc then acc else let b = AddrMap.find pc blocks in match b with | {handler = Some _} | {branch = Pushtrap _ } | {branch = Poptrap _ } -> false | _ -> List.for_all (function | Let (_, Prim (Extern "caml_js_eval_string",_)) -> false | Let (_, Prim (Extern "debugger",_)) -> false | Let (x, Prim(Extern ("caml_js_var" |"caml_js_expr" |"caml_pure_js_expr"),_)) -> (* TODO: we should smarter here and look the generated js *) (* let's consider it this opmiziable *) true | _ -> true ) b.body ) pc blocks true let get_closures (_, blocks, _) = AddrMap.fold (fun _ block closures -> List.fold_left (fun closures i -> match i with Let (x, Closure (l, cont)) -> (* we can compute this once during the pass as the property won't change with inlining *) let f_optimizable = optimizable blocks (fst cont) true in VarMap.add x (l, cont, f_optimizable) closures | _ -> closures) closures block.body) blocks VarMap.empty (****) let rewrite_block (pc', handler) pc blocks = let block = AddrMap.find pc blocks in assert (block.handler = None); let block = { block with handler = handler } in let block = match block.branch, pc' with Return y, Some pc' -> { block with branch = Branch (pc', [y]) } | _ -> block in AddrMap.add pc block blocks let (>>) x f = f x (* Skip try body *) let fold_children blocks pc f accu = let block = AddrMap.find pc blocks in match block.branch with Return _ | Raise _ | Stop -> accu | Branch (pc', _) | Poptrap (pc', _) -> f pc' accu | Pushtrap (_, _, (pc1, _), pc2) -> f pc1 (if pc2 >= 0 then f pc2 accu else accu) | Cond (_, _, (pc1, _), (pc2, _)) -> accu >> f pc1 >> f pc2 | Switch (_, a1, a2) -> accu >> Array.fold_right (fun (pc, _) accu -> f pc accu) a1 >> Array.fold_right (fun (pc, _) accu -> f pc accu) a2 let rewrite_closure blocks cont_pc clos_pc handler = Code.traverse fold_children (rewrite_block (cont_pc, handler)) clos_pc blocks blocks (****) (* get new location put continuation at new location update closure body to return to this location make current block continuation jump to closure body *) let inline closures live_vars outer_optimizable pc (blocks,free_pc)= let block = AddrMap.find pc blocks in let (body, (branch, blocks, free_pc)) = List.fold_right (fun i (rem, state) -> match i with Let (x, Apply (f, args, true)) when live_vars.(Var.idx f) = 1 && VarMap.mem f closures -> let (params, (clos_pc, clos_args),f_optimizable) = VarMap.find f closures in (* inlining the code of an optimizable function could make this code unoptimized. (wrt to Jit compilers) At the moment, V8 doesn't optimize function containing try..catch. We disable inlining if the inner and outer funcitons don't have the same "contain_try_catch" property *) if outer_optimizable = f_optimizable then let (branch, blocks, free_pc) = state in let (blocks, cont_pc) = match rem, branch with [], Return y when Var.compare x y = 0 -> (* We do not need a continuation block for tail calls *) (blocks, None) | _ -> (AddrMap.add free_pc { params = [x]; handler = block.handler; body = rem; branch = branch } blocks, Some free_pc) in let blocks = rewrite_closure blocks cont_pc clos_pc block.handler in (* We do not really need this intermediate block. It just avoid the need to find which function parameters are used in the function body. *) let blocks = AddrMap.add (free_pc + 1) { params = params; handler = block.handler; body = []; branch = Branch (clos_pc, clos_args) } blocks in ([], (Branch (free_pc + 1, args), blocks, free_pc + 2)) else begin (* Format.eprintf "Do not inline because inner:%b outer:%b@." f_has_handler outer_has_handler; *) (i :: rem, state) end | _ -> (i :: rem, state)) block.body ([], (block.branch, blocks, free_pc)) in (AddrMap.add pc {block with body = body; branch = branch} blocks, free_pc) (****) let times = Option.Debug.find "times" let f ((pc, blocks, free_pc) as p) live_vars = let t = Util.Timer.make () in let closures = get_closures p in let (blocks, free_pc) = Code.fold_closures p (fun name _ (pc,_) (blocks,free_pc) -> let outer_optimizable = match name with | None -> optimizable blocks pc true | Some x -> let _,_,b = VarMap.find x closures in b in Code.traverse Code.fold_children (inline closures live_vars outer_optimizable) pc blocks (blocks,free_pc) ) (blocks, free_pc) in if times () then Format.eprintf " inlining: %a@." Util.Timer.print t; (pc, blocks, free_pc) js_of_ocaml-2.5/compiler/inline.mli000066400000000000000000000017161241254034500174330ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val f : Code.program -> int array -> Code.program js_of_ocaml-2.5/compiler/instr.ml000066400000000000000000000301051241254034500171350ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t = | ACC0 | ACC1 | ACC2 | ACC3 | ACC4 | ACC5 | ACC6 | ACC7 | ACC | PUSH | PUSHACC0 | PUSHACC1 | PUSHACC2 | PUSHACC3 | PUSHACC4 | PUSHACC5 | PUSHACC6 | PUSHACC7 | PUSHACC | POP | ASSIGN | ENVACC1 | ENVACC2 | ENVACC3 | ENVACC4 | ENVACC | PUSHENVACC1 | PUSHENVACC2 | PUSHENVACC3 | PUSHENVACC4 | PUSHENVACC | PUSH_RETADDR | APPLY | APPLY1 | APPLY2 | APPLY3 | APPTERM | APPTERM1 | APPTERM2 | APPTERM3 | RETURN | RESTART | GRAB | CLOSURE | CLOSUREREC | OFFSETCLOSUREM2 | OFFSETCLOSURE0 | OFFSETCLOSURE2 | OFFSETCLOSURE | PUSHOFFSETCLOSUREM2 | PUSHOFFSETCLOSURE0 | PUSHOFFSETCLOSURE2 | PUSHOFFSETCLOSURE | GETGLOBAL | PUSHGETGLOBAL | GETGLOBALFIELD | PUSHGETGLOBALFIELD | SETGLOBAL | ATOM0 | ATOM | PUSHATOM0 | PUSHATOM | MAKEBLOCK | MAKEBLOCK1 | MAKEBLOCK2 | MAKEBLOCK3 | MAKEFLOATBLOCK | GETFIELD0 | GETFIELD1 | GETFIELD2 | GETFIELD3 | GETFIELD | GETFLOATFIELD | SETFIELD0 | SETFIELD1 | SETFIELD2 | SETFIELD3 | SETFIELD | SETFLOATFIELD | VECTLENGTH | GETVECTITEM | SETVECTITEM | GETSTRINGCHAR | SETSTRINGCHAR | BRANCH | BRANCHIF | BRANCHIFNOT | SWITCH | BOOLNOT | PUSHTRAP | POPTRAP | RAISE | CHECK_SIGNALS | C_CALL1 | C_CALL2 | C_CALL3 | C_CALL4 | C_CALL5 | C_CALLN | CONST0 | CONST1 | CONST2 | CONST3 | CONSTINT | PUSHCONST0 | PUSHCONST1 | PUSHCONST2 | PUSHCONST3 | PUSHCONSTINT | NEGINT | ADDINT | SUBINT | MULINT | DIVINT | MODINT | ANDINT | ORINT | XORINT | LSLINT | LSRINT | ASRINT | EQ | NEQ | LTINT | LEINT | GTINT | GEINT | OFFSETINT | OFFSETREF | ISINT | GETMETHOD | BEQ | BNEQ | BLTINT | BLEINT | BGTINT | BGEINT | ULTINT | UGEINT | BULTINT | BUGEINT | GETPUBMET | GETDYNMET | STOP | EVENT | BREAK | RERAISE | RAISE_NOTRACE | FIRST_UNIMPLEMENTED_OP type kind = | KNullary | KUnary | KBinary | KJump | KCond_jump | KCmp_jump | KSwitch | KClosurerec | KClosure | KNullaryCall | KUnaryCall | KBinaryCall | KStop of int | K_will_not_happen type desc = { code : t; kind : kind; name : string; opcode : int } let ops,ops_rev = let ops_rev = Hashtbl.create 17 in let if_v4 = match Util.Version.v with `V3 -> (fun _ default -> default) | `V4_02 -> (fun k _ -> k) in let instrs = [| ACC0, KNullary, "ACC0"; ACC1, KNullary, "ACC1"; ACC2, KNullary, "ACC2"; ACC3, KNullary, "ACC3"; ACC4, KNullary, "ACC4"; ACC5, KNullary, "ACC5"; ACC6, KNullary, "ACC6"; ACC7, KNullary, "ACC7"; ACC, KUnary, "ACC"; PUSH, KNullary, "PUSH"; PUSHACC0, KNullary, "PUSHACC0"; PUSHACC1, KNullary, "PUSHACC1"; PUSHACC2, KNullary, "PUSHACC2"; PUSHACC3, KNullary, "PUSHACC3"; PUSHACC4, KNullary, "PUSHACC4"; PUSHACC5, KNullary, "PUSHACC5"; PUSHACC6, KNullary, "PUSHACC6"; PUSHACC7, KNullary, "PUSHACC7"; PUSHACC, KUnary, "PUSHACC"; POP, KUnary, "POP"; ASSIGN, KUnary, "ASSIGN"; ENVACC1, KNullary, "ENVACC1"; ENVACC2, KNullary, "ENVACC2"; ENVACC3, KNullary, "ENVACC3"; ENVACC4, KNullary, "ENVACC4"; ENVACC, KUnary, "ENVACC"; PUSHENVACC1, KNullary, "PUSHENVACC1"; PUSHENVACC2, KNullary, "PUSHENVACC2"; PUSHENVACC3, KNullary, "PUSHENVACC3"; PUSHENVACC4, KNullary, "PUSHENVACC4"; PUSHENVACC, KUnary, "PUSHENVACC"; PUSH_RETADDR, KUnary, "PUSH_RETADDR"; APPLY, KUnaryCall, "APPLY"; APPLY1, KNullaryCall, "APPLY1"; APPLY2, KNullaryCall, "APPLY2"; APPLY3, KNullaryCall, "APPLY3"; APPTERM, KStop 2, "APPTERM"; APPTERM1, KStop 1, "APPTERM1"; APPTERM2, KStop 1, "APPTERM2"; APPTERM3, KStop 1, "APPTERM3"; RETURN, KStop 1, "RETURN"; RESTART, KNullary, "RESTART"; GRAB, KUnary, "GRAB"; CLOSURE, KClosure, "CLOSURE"; CLOSUREREC, KClosurerec, "CLOSUREREC"; OFFSETCLOSUREM2, KNullary, "OFFSETCLOSUREM2"; OFFSETCLOSURE0, KNullary, "OFFSETCLOSURE0"; OFFSETCLOSURE2, KNullary, "OFFSETCLOSURE2"; OFFSETCLOSURE, KUnary, "OFFSETCLOSURE"; PUSHOFFSETCLOSUREM2, KNullary, "PUSHOFFSETCLOSUREM2"; PUSHOFFSETCLOSURE0, KNullary, "PUSHOFFSETCLOSURE0"; PUSHOFFSETCLOSURE2, KNullary, "PUSHOFFSETCLOSURE2"; PUSHOFFSETCLOSURE, KUnary, "PUSHOFFSETCLOSURE"; GETGLOBAL, KUnary, "GETGLOBAL"; PUSHGETGLOBAL, KUnary, "PUSHGETGLOBAL"; GETGLOBALFIELD, KBinary, "GETGLOBALFIELD"; PUSHGETGLOBALFIELD, KBinary, "PUSHGETGLOBALFIELD"; SETGLOBAL, KUnary, "SETGLOBAL"; ATOM0, KNullary, "ATOM0"; ATOM, KUnary, "ATOM"; PUSHATOM0, KNullary, "PUSHATOM0"; PUSHATOM, KUnary, "PUSHATOM"; MAKEBLOCK, KBinary, "MAKEBLOCK"; MAKEBLOCK1, KUnary, "MAKEBLOCK1"; MAKEBLOCK2, KUnary, "MAKEBLOCK2"; MAKEBLOCK3, KUnary, "MAKEBLOCK3"; MAKEFLOATBLOCK, KUnary, "MAKEFLOATBLOCK"; GETFIELD0, KNullary, "GETFIELD0"; GETFIELD1, KNullary, "GETFIELD1"; GETFIELD2, KNullary, "GETFIELD2"; GETFIELD3, KNullary, "GETFIELD3"; GETFIELD, KUnary, "GETFIELD"; GETFLOATFIELD, KUnary, "GETFLOATFIELD"; SETFIELD0, KNullary, "SETFIELD0"; SETFIELD1, KNullary, "SETFIELD1"; SETFIELD2, KNullary, "SETFIELD2"; SETFIELD3, KNullary, "SETFIELD3"; SETFIELD, KUnary, "SETFIELD"; SETFLOATFIELD, KUnary, "SETFLOATFIELD"; VECTLENGTH, KNullary, "VECTLENGTH"; GETVECTITEM, KNullary, "GETVECTITEM"; SETVECTITEM, KNullary, "SETVECTITEM"; GETSTRINGCHAR, KNullary, "GETSTRINGCHAR"; SETSTRINGCHAR, KNullary, "SETSTRINGCHAR"; BRANCH, KJump, "BRANCH"; BRANCHIF, KCond_jump, "BRANCHIF"; BRANCHIFNOT, KCond_jump, "BRANCHIFNOT"; SWITCH, KSwitch, "SWITCH"; BOOLNOT, KNullary, "BOOLNOT"; PUSHTRAP, KCond_jump, "PUSHTRAP"; POPTRAP, KNullary, "POPTRAP"; RAISE, KStop 0, "RAISE"; CHECK_SIGNALS, KNullary, "CHECK_SIGNALS"; C_CALL1, KUnaryCall, "C_CALL1"; C_CALL2, KUnaryCall, "C_CALL2"; C_CALL3, KUnaryCall, "C_CALL3"; C_CALL4, KUnaryCall, "C_CALL4"; C_CALL5, KUnaryCall, "C_CALL5"; C_CALLN, KBinaryCall, "C_CALLN"; CONST0, KNullary, "CONST0"; CONST1, KNullary, "CONST1"; CONST2, KNullary, "CONST2"; CONST3, KNullary, "CONST3"; CONSTINT, KUnary, "CONSTINT"; PUSHCONST0, KNullary, "PUSHCONST0"; PUSHCONST1, KNullary, "PUSHCONST1"; PUSHCONST2, KNullary, "PUSHCONST2"; PUSHCONST3, KNullary, "PUSHCONST3"; PUSHCONSTINT, KUnary, "PUSHCONSTINT"; NEGINT, KNullary, "NEGINT"; ADDINT, KNullary, "ADDINT"; SUBINT, KNullary, "SUBINT"; MULINT, KNullary, "MULINT"; DIVINT, KNullary, "DIVINT"; MODINT, KNullary, "MODINT"; ANDINT, KNullary, "ANDINT"; ORINT, KNullary, "ORINT"; XORINT, KNullary, "XORINT"; LSLINT, KNullary, "LSLINT"; LSRINT, KNullary, "LSRINT"; ASRINT, KNullary, "ASRINT"; EQ, KNullary, "EQ"; NEQ, KNullary, "NEQ"; LTINT, KNullary, "LTINT"; LEINT, KNullary, "LEINT"; GTINT, KNullary, "GTINT"; GEINT, KNullary, "GEINT"; OFFSETINT, KUnary, "OFFSETINT"; OFFSETREF, KUnary, "OFFSETREF"; ISINT, KNullary, "ISINT"; GETMETHOD, KNullary, "GETMETHOD"; BEQ, KCmp_jump, "BEQ"; BNEQ, KCmp_jump, "BNEQ"; BLTINT, KCmp_jump, "BLTINT"; BLEINT, KCmp_jump, "BLEINT"; BGTINT, KCmp_jump, "BGTINT"; BGEINT, KCmp_jump, "BGEINT"; ULTINT, KNullary, "ULTINT"; UGEINT, KNullary, "UGEINT"; BULTINT, KCmp_jump, "BULTINT"; BUGEINT, KCmp_jump, "BUGEINT"; GETPUBMET, KBinary, "GETPUBMET"; GETDYNMET, KNullary, "GETDYNMET"; STOP, KStop 0, "STOP"; EVENT, K_will_not_happen, "EVENT"; BREAK, K_will_not_happen, "BREAK"; RERAISE, if_v4 (KStop 0) K_will_not_happen, "RERAISE"; RAISE_NOTRACE, if_v4 (KStop 0) K_will_not_happen, "RAISE_NOTRACE"; FIRST_UNIMPLEMENTED_OP, K_will_not_happen, "FIRST_UNIMPLEMENTED_OP"|] in let ops = Array.mapi (fun i (c, k, n) -> Hashtbl.add ops_rev c i; {code = c; kind = k; name = n; opcode = i} ) instrs in ops,ops_rev let to_int c = Hashtbl.find ops_rev c let int_to_buf buf i = Buffer.add_char buf (Char.chr (i land 0xFF)); Buffer.add_char buf (Char.chr ((i lsr 8) land 0xFF)); Buffer.add_char buf (Char.chr ((i lsr 16) land 0xFF)); Buffer.add_char buf (Char.chr ((i lsr 24) land 0xFF)) let compile b l = List.iter (fun i -> let i = match i with | `C i -> i | `I i -> to_int i in int_to_buf b i) l let compile_to_string l = let b = Buffer.create 50 in compile b l; Buffer.contents b let get code i = Char.code (code.[i]) let getu code pc = let i = pc * 4 in let b1 = get code i in let b2 = get code (i + 1) in let b3 = get code (i + 2) in let b4 = get code (i + 3) in (b4 lsl 24) + (b3 lsl 16) + (b2 lsl 8) + b1 let getu32 code pc = Int32.of_int (getu code pc) let gets code pc = let i = pc * 4 in let b1 = get code i in let b2 = get code (i + 1) in let b3 = get code (i + 2) in let b4 = get code (i + 3) in let b4' = if b4 >= 128 then b4-256 else b4 in (b4' lsl 24) + (b3 lsl 16) + (b2 lsl 8) + b1 let gets32 code pc = Int32.of_int (gets code pc) exception Bad_instruction of int let get_instr code pc = let i = getu code pc in if i < 0 || i >= Array.length ops then raise (Bad_instruction i); let ins = ops.(i) in if ins.kind = K_will_not_happen then raise (Bad_instruction i); ins (****) let same_custom x y = Obj.field x 0 == Obj.field (Obj.repr y) 0 let rec print_obj f x = if Obj.is_block x then begin let tag = Obj.tag x in if tag = Obj.string_tag then Format.fprintf f "%S" (Obj.magic x : string) else if tag = Obj.double_tag then Format.fprintf f "%.12g" (Obj.magic x : float) else if tag = Obj.double_array_tag then begin let a = (Obj.magic x : float array) in Format.fprintf f "[|"; for i = 0 to Array.length a - 1 do if i > 0 then Format.fprintf f ", "; Format.fprintf f "%.12g" a.(i) done; Format.fprintf f "|]" end else if tag = Obj.custom_tag && same_custom x 0l then Format.fprintf f "%ldl" (Obj.magic x : int32) else if tag = Obj.custom_tag && same_custom x 0n then Format.fprintf f "%ndn" (Obj.magic x : nativeint) else if tag = Obj.custom_tag && same_custom x 0L then Format.fprintf f "%LdL" (Obj.magic x : int64) else if tag < Obj.no_scan_tag then begin Format.fprintf f "<%d>" (Obj.tag x); match Obj.size x with 0 -> () | 1 -> Format.fprintf f "("; print_obj f (Obj.field x 0); Format.fprintf f ")" | n -> Format.fprintf f "("; print_obj f (Obj.field x 0); for i = 1 to n - 1 do Format.fprintf f ", "; print_obj f (Obj.field x i) done; Format.fprintf f ")" end else Format.fprintf f "" tag end else Format.fprintf f "%d" (Obj.magic x : int) js_of_ocaml-2.5/compiler/instr.mli000066400000000000000000000066421241254034500173170ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t = | ACC0 | ACC1 | ACC2 | ACC3 | ACC4 | ACC5 | ACC6 | ACC7 | ACC | PUSH | PUSHACC0 | PUSHACC1 | PUSHACC2 | PUSHACC3 | PUSHACC4 | PUSHACC5 | PUSHACC6 | PUSHACC7 | PUSHACC | POP | ASSIGN | ENVACC1 | ENVACC2 | ENVACC3 | ENVACC4 | ENVACC | PUSHENVACC1 | PUSHENVACC2 | PUSHENVACC3 | PUSHENVACC4 | PUSHENVACC | PUSH_RETADDR | APPLY | APPLY1 | APPLY2 | APPLY3 | APPTERM | APPTERM1 | APPTERM2 | APPTERM3 | RETURN | RESTART | GRAB | CLOSURE | CLOSUREREC | OFFSETCLOSUREM2 | OFFSETCLOSURE0 | OFFSETCLOSURE2 | OFFSETCLOSURE | PUSHOFFSETCLOSUREM2 | PUSHOFFSETCLOSURE0 | PUSHOFFSETCLOSURE2 | PUSHOFFSETCLOSURE | GETGLOBAL | PUSHGETGLOBAL | GETGLOBALFIELD | PUSHGETGLOBALFIELD | SETGLOBAL | ATOM0 | ATOM | PUSHATOM0 | PUSHATOM | MAKEBLOCK | MAKEBLOCK1 | MAKEBLOCK2 | MAKEBLOCK3 | MAKEFLOATBLOCK | GETFIELD0 | GETFIELD1 | GETFIELD2 | GETFIELD3 | GETFIELD | GETFLOATFIELD | SETFIELD0 | SETFIELD1 | SETFIELD2 | SETFIELD3 | SETFIELD | SETFLOATFIELD | VECTLENGTH | GETVECTITEM | SETVECTITEM | GETSTRINGCHAR | SETSTRINGCHAR | BRANCH | BRANCHIF | BRANCHIFNOT | SWITCH | BOOLNOT | PUSHTRAP | POPTRAP | RAISE | CHECK_SIGNALS | C_CALL1 | C_CALL2 | C_CALL3 | C_CALL4 | C_CALL5 | C_CALLN | CONST0 | CONST1 | CONST2 | CONST3 | CONSTINT | PUSHCONST0 | PUSHCONST1 | PUSHCONST2 | PUSHCONST3 | PUSHCONSTINT | NEGINT | ADDINT | SUBINT | MULINT | DIVINT | MODINT | ANDINT | ORINT | XORINT | LSLINT | LSRINT | ASRINT | EQ | NEQ | LTINT | LEINT | GTINT | GEINT | OFFSETINT | OFFSETREF | ISINT | GETMETHOD | BEQ | BNEQ | BLTINT | BLEINT | BGTINT | BGEINT | ULTINT | UGEINT | BULTINT | BUGEINT | GETPUBMET | GETDYNMET | STOP | EVENT | BREAK | RERAISE | RAISE_NOTRACE | FIRST_UNIMPLEMENTED_OP type kind = | KNullary | KUnary | KBinary | KJump | KCond_jump | KCmp_jump | KSwitch | KClosurerec | KClosure | KNullaryCall | KUnaryCall | KBinaryCall | KStop of int | K_will_not_happen type desc = { code : t; kind : kind; name : string; opcode : int } exception Bad_instruction of int val get_instr : string -> int -> desc val gets : string -> int -> int val getu : string -> int -> int val gets32 : string -> int -> int32 val getu32 : string -> int -> int32 val compile_to_string : [`C of int | `I of t] list -> string val print_obj : Format.formatter -> Obj.t -> unit js_of_ocaml-2.5/compiler/javascript.ml000066400000000000000000000133641241254034500201540ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) module Label = struct open Util type t = | L of int | S of string let printer = VarPrinter.create () let zero = L 0 let succ = function | L t -> L (succ t) | S _ -> assert false let to_string = function | L t -> VarPrinter.to_string printer t | S s -> s let of_string s = S s end type location = | Pi of Parse_info.t | N | U type identifier = string type ident_string = { name : identifier; var : Code.Var.t option } type ident = | S of ident_string | V of Code.Var.t (* A.3 Expressions *) and array_litteral = element_list and element_list = expression option list and binop = Eq | StarEq | SlashEq | ModEq | PlusEq | MinusEq | LslEq | AsrEq | LsrEq | BandEq | BxorEq | BorEq | Or | And | Bor | Bxor | Band | EqEq | NotEq | EqEqEq | NotEqEq | Lt | Le | Gt | Ge | InstanceOf | In | Lsl | Lsr | Asr | Plus | Minus | Mul | Div | Mod and unop = Not | Neg | Pl | Typeof | Void | Delete | Bnot | IncrA | DecrA | IncrB | DecrB and arguments = expression list and property_name_and_value_list = (property_name * expression) list and property_name = PNI of identifier | PNS of string | PNN of float and expression = ESeq of expression * expression | ECond of expression * expression * expression | EBin of binop * expression * expression | EUn of unop * expression | ECall of expression * arguments * location | EAccess of expression * expression | EDot of expression * identifier | ENew of expression * arguments option | EVar of ident | EFun of function_expression | EStr of string * [`Bytes | `Utf8] | EArr of array_litteral | EBool of bool | ENum of float | EObj of property_name_and_value_list | EQuote of string | ERegexp of string * string option (****) (* A.4 Statements *) and statement = Block of block | Variable_statement of variable_declaration list | Empty_statement | Expression_statement of expression | If_statement of expression * (statement * location) * (statement * location) option | Do_while_statement of (statement * location) * expression | While_statement of expression * (statement * location) | For_statement of (expression option,variable_declaration list) either * expression option * expression option * (statement * location) | ForIn_statement of (expression,variable_declaration) either * expression * (statement * location) | Continue_statement of Label.t option | Break_statement of Label.t option | Return_statement of expression option (* | With_statement of expression * statement *) | Labelled_statement of Label.t * (statement * location) | Switch_statement of expression * case_clause list * statement_list option * case_clause list | Throw_statement of expression | Try_statement of block * (ident * block) option * block option | Debugger_statement and ('left,'right) either = | Left of 'left | Right of 'right and block = statement_list and statement_list = (statement * location) list and variable_declaration = ident * initialiser option and case_clause = expression * statement_list and initialiser = expression * location (****) (* A.5 Functions and programs *) and function_declaration = ident * formal_parameter_list * function_body * location and function_expression = ident option * formal_parameter_list * function_body * location and formal_parameter_list = ident list and function_body = source_elements and program = source_elements and source_elements = (source_element * location) list and source_element = Statement of statement | Function_declaration of function_declaration let compare_ident t1 t2 = match t1, t2 with | V v1, V v2 -> Code.Var.compare v1 v2 | S {name=s1;var=v1}, S{name=s2;var=v2} -> begin match String.compare s1 s2 with | 0 -> begin match v1,v2 with | None,None -> 0 | None, _ -> -1 | _, None -> 1 | Some v1, Some v2 -> Code.Var.compare v1 v2 end | n -> n end | S _, V _ -> -1 | V _, S _ -> 1 let string_of_number v = if v = infinity then "Infinity" else if v = neg_infinity then "-Infinity" else if v <> v then "NaN" else let vint = int_of_float v in (* compiler 1000 into 1e3 *) if float_of_int vint = v then let rec div n i = if n <> 0 && n mod 10 = 0 then div (n/10) (succ i) else if i > 2 then Printf.sprintf "%de%d" n i else string_of_int vint in div vint 0 else let s1 = Printf.sprintf "%.12g" v in if v = float_of_string s1 then s1 else let s2 = Printf.sprintf "%.15g" v in if v = float_of_string s2 then s2 else Printf.sprintf "%.18g" v module IdentSet = Set.Make(struct type t = ident let compare = compare_ident end) module IdentMap = Map.Make(struct type t = ident let compare = compare_ident end) js_of_ocaml-2.5/compiler/javascript.mli000066400000000000000000000112061241254034500203160ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) module Label : sig type t val zero : t val succ : t -> t val to_string : t -> string val of_string : string -> t end type location = | Pi of Parse_info.t | N (* No location; use the one above *) | U (* Unknown location *) (* A.3 Expressions *) type identifier = string type ident_string = { name : identifier; var : Code.Var.t option } type ident = | S of ident_string | V of Code.Var.t and array_litteral = element_list and element_list = expression option list and binop = Eq | StarEq | SlashEq | ModEq | PlusEq | MinusEq | LslEq | AsrEq | LsrEq | BandEq | BxorEq | BorEq | Or | And | Bor | Bxor | Band | EqEq | NotEq | EqEqEq | NotEqEq | Lt | Le | Gt | Ge | InstanceOf | In | Lsl | Lsr | Asr | Plus | Minus | Mul | Div | Mod and unop = Not | Neg | Pl | Typeof | Void | Delete | Bnot | IncrA | DecrA | IncrB | DecrB and arguments = expression list and property_name_and_value_list = (property_name * expression) list and property_name = PNI of identifier | PNS of string | PNN of float and expression = ESeq of expression * expression | ECond of expression * expression * expression | EBin of binop * expression * expression | EUn of unop * expression | ECall of expression * arguments * location | EAccess of expression * expression | EDot of expression * identifier | ENew of expression * arguments option | EVar of ident | EFun of function_expression | EStr of string * [`Bytes | `Utf8] (* A string can either be composed of a sequence of bytes, or be UTF-8 encoded. In the second case, the string may contain escape sequences. *) | EArr of array_litteral | EBool of bool | ENum of float | EObj of property_name_and_value_list | EQuote of string | ERegexp of string * string option (****) (* A.4 Statements *) and statement = Block of block | Variable_statement of variable_declaration list | Empty_statement | Expression_statement of expression | If_statement of expression * (statement * location) * (statement * location) option | Do_while_statement of (statement * location) * expression | While_statement of expression * (statement * location) | For_statement of (expression option,variable_declaration list) either * expression option * expression option * (statement * location) | ForIn_statement of (expression,variable_declaration) either * expression * (statement * location) | Continue_statement of Label.t option | Break_statement of Label.t option | Return_statement of expression option (* | With_statement *) | Labelled_statement of Label.t * (statement * location) | Switch_statement of expression * case_clause list * statement_list option * case_clause list | Throw_statement of expression | Try_statement of block * (ident * block) option * block option | Debugger_statement and ('left,'right) either = | Left of 'left | Right of 'right and block = statement_list and statement_list = (statement * location) list and variable_declaration = ident * initialiser option and case_clause = expression * statement_list and initialiser = expression * location (****) (* A.5 Functions and programs *) and function_declaration = ident * formal_parameter_list * function_body * location and function_expression = ident option * formal_parameter_list * function_body * location and formal_parameter_list = ident list and function_body = source_elements and program = source_elements and source_elements = (source_element * location) list and source_element = Statement of statement | Function_declaration of function_declaration val compare_ident : ident -> ident -> int val string_of_number : float -> string module IdentSet : Set.S with type elt = ident module IdentMap : Map.S with type key = ident js_of_ocaml-2.5/compiler/js_assign.ml000066400000000000000000000231661241254034500177670ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Jérôme Vouillon * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) (* We are trying to achieve the following goals: (1) variable names should be as short as possible (2) one should reuse as much as possible a small subsets of variable names (3) function parameters should be: function(a,b,...){...} (4) for longer variable names, variable which are closed from one another should share a same prefix Point (1) minimizes the size of uncompressed files, while point (2) to (4) improve compression. We use the following strategy. We maintain the constraint that variables occurring in a function should keep different names. We first assign names a, b, ... (in order) to function parameters, starting from inner functions, skipping variables which have a conflict with a previously names variable (goal 3). Then, we order the remaining variables by their number of occurrences, then by their index (goal 4), and greedily assigned name to them. For that, we use for each variable the smallest possible name still available (goal 1/2). This algorithm seems effective. Here are some statistics gathered while compiling the OCaml toplevel: (1) We get 132025 occurrences of one-char variables out of 169728 occurrences while the optimal number (determined using a mixed integer linear programming solver) is 132105 occurrences (80 more occurrences). (2) Variable names are heavily biased toward character a: among variables, we have about 34000 occurrences of character a, less than 5000 occurrences of character i (9th character, out of the 54 characters that can start an identifier), and about 1500 occurrences of character A. (3) About 6% of the function parameters are not assigned as wanted; it is not clear we can do any better: there are a lot of nested functions. (4) We save 8181 bytes on the compressed file (1.8%) by sorting variables using their index as a secondary key rather that just based on their weights (the size of the uncompressed file remains unchanged) *) open Util open Javascript let debug = Option.Debug.find "shortvar" module S = Code.VarSet module VM = Code.VarMap module Var = Code.Var type alloc = { mutable first_free : int; mutable used : bool array } let make_alloc_table () = { first_free = 0; used = Array.make 32 false } let next_available a i = let i = ref (max i a.first_free) in let len = Array.length a.used in while !i < len && a.used.(!i) do incr i done; !i let allocate a i = let len = Array.length a.used in if i >= len then begin let l = ref len in while l := 2 * !l; i >= !l do () done; let u = Array.make !l false in Array.blit a.used 0 u 0 len; a.used <- u end; assert (not a.used.(i)); a.used.(i) <- true; if a.first_free = i then begin let i = ref a.first_free in let len = Array.length a.used in while !i < len && a.used.(!i) do incr i done; a.first_free <- !i end let is_available l i = List.for_all (fun a -> Array.length a.used <= i || not a.used.(i)) l let first_available l = let rec find_rec n = let n' = List.fold_left (fun n a -> next_available a n) n l in if n = n' then n else find_rec n' in find_rec 0 let mark_allocated l i = List.iter (fun a -> allocate a i) l type g = { constr : alloc list array; (* Constraints on variables *) mutable parameters : Var.t list array; (* Function parameters *) mutable constraints : S.t list } (* For debugging *) let create nv = { constr = Array.make nv []; parameters = [|[]|]; constraints = [] } let output_debug_information t count = let weight v = (IdentMap.find (V v) count) in let usage = List.fold_left (fun u s -> S.fold (fun v u -> VM.add v (try 1 + VM.find v u with Not_found -> 1) u) s u) VM.empty t.constraints in let l = List.map fst (VM.bindings usage) in let ch = open_out "/tmp/weights.txt" in List.iter (fun v -> Printf.fprintf ch "%d / %d / %d\n" (weight v) (VM.find v usage) (Code.Var.idx v)) l; close_out ch; let ch = open_out "/tmp/problem.txt" in Printf.fprintf ch "Maximize\n"; let a = Array.of_list l in Printf.fprintf ch " "; for i = 0 to Array.length a - 1 do let v = a.(i) in let w = weight v in if i > 0 then Printf.fprintf ch " + "; Printf.fprintf ch "%d x%d" w (Code.Var.idx v) done; Printf.fprintf ch "\n"; Printf.fprintf ch "Subject To\n"; List.iter (fun s -> if S.cardinal s > 0 then begin Printf.fprintf ch " "; let a = Array.of_list (S.elements s) in for i = 0 to Array.length a - 1 do if i > 0 then Printf.fprintf ch " + "; Printf.fprintf ch "x%d" (Code.Var.idx a.(i)) done; Printf.fprintf ch "<= 54\n" end) t.constraints; Printf.fprintf ch "Binary\n "; List.iter (fun v -> Printf.fprintf ch " x%d" (Code.Var.idx v)) l; Printf.fprintf ch "\nEnd\n"; close_out ch; let ch = open_out "/tmp/problem2" in let var x = string_of_int (Code.Var.idx x) in let a = List.map (fun v -> (var v, weight v)) l in let b = List.map (fun s -> List.map var (S.elements s)) t.constraints in let c = List.map var l in output_value ch ((a, b, c) : (string * int) list * string list list * string list); close_out ch let allocate_variables t nv count = let weight v = try IdentMap.find (V (Code.Var.of_idx v)) count with Not_found -> 0 in let constr = t.constr in let len = nv in let idx = Array.make len 0 in for i = 0 to len - 1 do idx.(i) <- i done; Array.stable_sort (fun i j -> compare (weight j) (weight i)) idx; let name = Array.make len "" in let n0 = ref 0 in let n1 = ref 0 in let n2 = ref 0 in let n3 = ref 0 in let stats i n = incr n0; if n < 54 then begin incr n1; n2 := !n2 + (weight i) end; n3 := !n3 + (weight i) in let nm ~origin n = name.(origin) <- Var.to_string ~origin:(Var.of_idx origin) (Var.of_idx n) in let total = ref 0 in let bad = ref 0 in for i = 0 to Array.length t.parameters - 1 do List.iter (fun x -> incr total; let idx = Var.idx x in let l = constr.(idx) in if is_available l i then begin nm ~origin:idx i; mark_allocated l i; stats idx i end else incr bad) (List.rev t.parameters.(i)) done; if debug () then Format.eprintf "Function parameter properly assigned: %d/%d@." (!total - !bad) !total; for i = 0 to len - 1 do let l = constr.(idx.(i)) in if l <> [] && String.length name.(idx.(i)) = 0 then begin let n = first_available l in let idx = idx.(i) in nm ~origin:idx n; mark_allocated l n; stats idx n end; if l = [] then assert (weight (idx.(i)) = 0); done; if debug () then begin Format.eprintf "short variable count: %d/%d@." !n1 !n0; Format.eprintf "short variable occurrences: %d/%d@." !n2 !n3 end; name let add_constraints global u ?(offset=0) params = if Option.Optim.shortvar () then begin let constr = global.constr in let c = make_alloc_table () in S.iter (fun v -> let i = Code.Var.idx v in constr.(i) <- c :: constr.(i)) u; let params = Array.of_list params in let len = Array.length params in let len_max = len + offset in if Array.length global.parameters < len_max then begin let a = Array.make (2 * len_max) [] in Array.blit global.parameters 0 a 0 (Array.length global.parameters); global.parameters <- a end; for i = 0 to len - 1 do match params.(i) with | V x -> global.parameters.(i + offset) <- x :: global.parameters.(i + offset) | _ -> () done; global.constraints <- u :: global.constraints end class ['state] color (state : 'state) = object(m) inherit Js_traverse.free as super method block ?(catch =false) params = let offset = if catch then 5 else 0 in let all = S.union m#state.Js_traverse.def m#state.Js_traverse.use in add_constraints state all ~offset params; super#block params end let program p = let color,p = if Option.Optim.shortvar () then let nv = Code.Var.count () in let state = create nv in let coloring = new color state in let p = coloring#program p in coloring#block []; if S.cardinal (coloring#get_free) <> 0 then begin Util.failwith_ "Some variables escaped (#%d)" (S.cardinal (coloring#get_free)) (* S.iter(fun s -> (Format.eprintf "%s@." (Code.Var.to_string s))) coloring#get_free *) end; let name = allocate_variables state nv coloring#state.Js_traverse.count in if debug () then output_debug_information state coloring#state.Js_traverse.count; (function V v -> S {name=name.(Code.Var.idx v);var=Some v} | x -> x),p else (function V v -> S {name=Var.to_string v;var=Some v} | x -> x),p in (new Js_traverse.subst color)#program p js_of_ocaml-2.5/compiler/js_assign.mli000066400000000000000000000015671241254034500201410ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val program : Javascript.program -> Javascript.program js_of_ocaml-2.5/compiler/js_lexer.mli000066400000000000000000000014171241254034500177660ustar00rootroot00000000000000(* Js_of_ocaml compiler * Copyright (C) 2013 Hugo Heuzard *) (* Yoann Padioleau * * Copyright (C) 2010 Facebook * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License * version 2.1 as published by the Free Software Foundation, with the * special exception on linking described in file license.txt. * * This library is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file * license.txt for more details. *) val initial : (Lexing.lexbuf -> Parse_info.t) -> Js_token.token option -> Lexing.lexbuf -> Js_token.token val pos : Lexing.lexbuf -> string * int js_of_ocaml-2.5/compiler/js_lexer.mll000066400000000000000000000275251241254034500200010ustar00rootroot00000000000000{ (* Js_of_ocaml compiler * Copyright (C) 2013 Hugo Heuzard *) (* Yoann Padioleau * * Copyright (C) 2010 Facebook * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License * version 2.1 as published by the Free Software Foundation, with the * special exception on linking described in file license.txt. * * This library is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file * license.txt for more details. *) open Js_token let tok lexbuf = Lexing.lexeme lexbuf let keyword_table = let h = Hashtbl.create 17 in List.iter (fun (s,f) -> Hashtbl.add h s f ) [ "catch", (fun ii -> T_CATCH ii); "finally", (fun ii -> T_FINALLY ii); "in", (fun ii -> T_IN ii); "instanceof", (fun ii -> T_INSTANCEOF ii); "else", (fun ii -> T_ELSE ii); "while", (fun ii -> T_WHILE ii); "break", (fun ii -> T_BREAK ii); "case", (fun ii -> T_CASE ii); "continue", (fun ii -> T_CONTINUE ii); "default", (fun ii -> T_DEFAULT ii); "delete", (fun ii -> T_DELETE ii); "do", (fun ii -> T_DO ii); "else", (fun ii -> T_ELSE ii); "for", (fun ii -> T_FOR ii); "function", (fun ii -> T_FUNCTION ii); "if", (fun ii -> T_IF ii); "new", (fun ii -> T_NEW ii); "return", (fun ii -> T_RETURN ii); "switch", (fun ii -> T_SWITCH ii); "this", (fun ii -> T_THIS ii); "throw", (fun ii -> T_THROW ii); "try", (fun ii -> T_TRY ii); "typeof", (fun ii -> T_TYPEOF ii); "var", (fun ii -> T_VAR ii); "void", (fun ii -> T_VOID ii); "while", (fun ii -> T_WHILE ii); "with", (fun ii -> T_WITH ii); "null", (fun ii -> T_NULL ii); "false", (fun ii -> T_FALSE ii); "true", (fun ii -> T_TRUE ii); "debugger", (fun ii -> T_DEBUGGER ii); ]; h let hexa_to_int = function | '0'..'9' as x -> Char.code x - Char.code '0' | 'a'..'f' as x -> Char.code x - Char.code 'a' + 10 | 'A'..'F' as x -> Char.code x - Char.code 'A' + 10 | _ -> assert false;; } (*****************************************************************************) let NEWLINE = ("\r"|"\n"|"\r\n") let hexa = ['0'-'9''a'-'f''A'-'F'] let inputCharacter = [^ '\r' '\n' ] (*****************************************************************************) rule initial tokinfo prev = parse (* ----------------------------------------------------------------------- *) (* spacing/comments *) (* ----------------------------------------------------------------------- *) | "/*" { let info = tokinfo lexbuf in let buf = Buffer.create 127 in let nl = ref false in st_comment buf nl lexbuf; let content = Buffer.contents buf in if !nl then TCommentML(info,content) else TComment(info,content) } (* don't keep the trailing \n; it will be in another token *) | "//" (inputCharacter* as cmt) { TComment(tokinfo lexbuf,cmt) } | ([' ' '\t' ]+ as cmt) { TCommentSpace(tokinfo lexbuf,cmt) } | NEWLINE { lexbuf.Lexing.lex_curr_p <- { lexbuf.Lexing.lex_curr_p with Lexing.pos_lnum = lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum + 1 }; TCommentNewline(tokinfo lexbuf,"") } (* ----------------------------------------------------------------------- *) (* symbols *) (* ----------------------------------------------------------------------- *) | "{" { T_LCURLY (tokinfo lexbuf); } | "}" { T_RCURLY (tokinfo lexbuf); } | "(" { T_LPAREN (tokinfo lexbuf); } | ")" { T_RPAREN (tokinfo lexbuf); } | "[" { T_LBRACKET (tokinfo lexbuf); } | "]" { T_RBRACKET (tokinfo lexbuf); } | "." { T_PERIOD (tokinfo lexbuf); } | ";" { T_SEMICOLON (tokinfo lexbuf); } | "," { T_COMMA (tokinfo lexbuf); } | ":" { T_COLON (tokinfo lexbuf); } | "?" { T_PLING (tokinfo lexbuf); } | "&&" { T_AND (tokinfo lexbuf); } | "||" { T_OR (tokinfo lexbuf); } | "===" { T_STRICT_EQUAL (tokinfo lexbuf); } | "!==" { T_STRICT_NOT_EQUAL (tokinfo lexbuf); } | "<=" { T_LESS_THAN_EQUAL (tokinfo lexbuf); } | ">=" { T_GREATER_THAN_EQUAL (tokinfo lexbuf); } | "==" { T_EQUAL (tokinfo lexbuf); } | "!=" { T_NOT_EQUAL (tokinfo lexbuf); } | "++" { let cpi = tokinfo lexbuf in match prev with | Some p when (Js_token.info_of_tok p).Parse_info.line = cpi.Parse_info.line -> T_INCR_NB(cpi) | _ -> T_INCR(cpi) } | "--" { let cpi = tokinfo lexbuf in match prev with | Some p when (Js_token.info_of_tok p).Parse_info.line = cpi.Parse_info.line -> T_DECR_NB(cpi) | _ -> T_DECR(cpi) } | "<<=" { T_LSHIFT_ASSIGN (tokinfo lexbuf); } | "<<" { T_LSHIFT (tokinfo lexbuf); } | ">>=" { T_RSHIFT_ASSIGN (tokinfo lexbuf); } | ">>>=" { T_RSHIFT3_ASSIGN (tokinfo lexbuf); } | ">>>" { T_RSHIFT3 (tokinfo lexbuf); } | ">>" { T_RSHIFT (tokinfo lexbuf); } | "+=" { T_PLUS_ASSIGN (tokinfo lexbuf); } | "-=" { T_MINUS_ASSIGN (tokinfo lexbuf); } | "*=" { T_MULT_ASSIGN (tokinfo lexbuf); } | "%=" { T_MOD_ASSIGN (tokinfo lexbuf); } | "&=" { T_BIT_AND_ASSIGN (tokinfo lexbuf); } | "|=" { T_BIT_OR_ASSIGN (tokinfo lexbuf); } | "^=" { T_BIT_XOR_ASSIGN (tokinfo lexbuf); } | "<" { T_LESS_THAN (tokinfo lexbuf); } | ">" { T_GREATER_THAN (tokinfo lexbuf); } | "+" { T_PLUS (tokinfo lexbuf); } | "-" { T_MINUS (tokinfo lexbuf); } | "*" { T_MULT (tokinfo lexbuf); } (* for '/' see below the regexp handling *) | "%" { T_MOD (tokinfo lexbuf); } | "|" { T_BIT_OR (tokinfo lexbuf); } | "&" { T_BIT_AND (tokinfo lexbuf); } | "^" { T_BIT_XOR (tokinfo lexbuf); } | "!" { T_NOT (tokinfo lexbuf); } | "~" { T_BIT_NOT (tokinfo lexbuf); } | "=" { T_ASSIGN (tokinfo lexbuf); } (* ----------------------------------------------------------------------- *) (* Keywords and ident *) (* ----------------------------------------------------------------------- *) | ['a'-'z''A'-'Z''$''_']['a'-'z''A'-'Z''$''_''0'-'9']* { let s = tok lexbuf in let info = tokinfo lexbuf in try let f = Hashtbl.find keyword_table s in f info (* need case insensitive ? *) with | Not_found -> T_IDENTIFIER (s, info) } (* ----------------------------------------------------------------------- *) (* Constant *) (* ----------------------------------------------------------------------- *) | "0" ['X''x'] hexa+ { let s = tok lexbuf in let info = tokinfo lexbuf in T_NUMBER (s, float_of_string s, info) } | '0'['0'-'7']+ { let s = tok lexbuf in let s' = String.sub s 1 (String.length s - 1 ) in let info = tokinfo lexbuf in T_NUMBER (s, Int64.(to_float (of_string ("0o"^s'))), info) } | ['0'-'9']*'.'?['0'-'9']+['e''E']['-''+']?['0'-'9']+ (* {1,3} *) { let s = tok lexbuf in let info = tokinfo lexbuf in T_NUMBER (s, float_of_string s,info) } | ['0'-'9']+'.'? | ['0'-'9']*'.'['0'-'9']+ { let s = tok lexbuf in let info = tokinfo lexbuf in T_NUMBER (s, float_of_string s, info) } (* ----------------------------------------------------------------------- *) (* Strings *) (* ----------------------------------------------------------------------- *) | ("'"|'"') as quote { let info = tokinfo lexbuf in let buf = Buffer.create 127 in string_quote quote buf lexbuf; let s = Buffer.contents buf in (* s does not contain the enclosing "'" but the info does *) T_STRING (s, info) } (* ----------------------------------------------------------------------- *) (* Regexp *) (* ----------------------------------------------------------------------- *) (* take care of ambiguity with start of comment //, and with * '/' as a divisor operator * * it can not be '/' [^ '/']* '/' because then * comments will not be recognized as lex tries * to find the longest match. * * It can not be * '/' [^'*''/'] ([^'/''\n'])* '/' ['A'-'Z''a'-'z']* * because a / (b/c) will be recognized as a regexp. * *) | "/" | "/=" { let s = tok lexbuf in let info = tokinfo lexbuf in match prev with | Some ( T_IDENTIFIER _ | T_NUMBER _ | T_STRING _ | T_REGEX _ | T_FALSE _ | T_TRUE _ | T_NULL _ | T_THIS _ | T_INCR _ | T_DECR _ | T_RBRACKET _ | T_RPAREN _ ) -> begin match s with | "/" -> T_DIV (info); | "/=" -> T_DIV_ASSIGN info | _ -> assert false end | _ -> (* raise (Token t); *) let buf = Buffer.create 127 in Buffer.add_string buf s; regexp buf lexbuf; T_REGEX (Buffer.contents buf, info) } (* ----------------------------------------------------------------------- *) (* eof *) (* ----------------------------------------------------------------------- *) | eof { EOF (tokinfo lexbuf) } | _ { (* Format.eprintf "LEXER:unrecognised symbol, in token rule: %s@." (tok lexbuf); *) TUnknown (tokinfo lexbuf, tok lexbuf) } (*****************************************************************************) and string_escape quote buf = parse | '\\'{ Buffer.add_string buf "\\\\" } | 'x' hexa hexa | 'u' hexa hexa hexa hexa { Buffer.add_char buf '\\'; Buffer.add_string buf (Lexing.lexeme lexbuf) } | (_ as c) { if c <> '\'' && c <> '\"' then Buffer.add_char buf '\\'; Buffer.add_char buf c } | eof { Format.eprintf "LEXER: WIERD end of file in string_escape@."; ()} and string_quote q buf = parse | ("'"|'"') as q' { if q = q' then () else (Buffer.add_char buf q'; string_quote q buf lexbuf) } | '\\' { string_escape q buf lexbuf; string_quote q buf lexbuf } | (_ as x) { Buffer.add_char buf x; string_quote q buf lexbuf } | eof { Format.eprintf "LEXER: WIERD end of file in quoted string@."; ()} (*****************************************************************************) and regexp buf = parse | '\\' (_ as x) { Buffer.add_char buf '\\'; Buffer.add_char buf x; regexp buf lexbuf } | '/' { Buffer.add_char buf '/'; regexp_maybe_ident buf lexbuf } | '[' { Buffer.add_char buf '['; regexp_class buf lexbuf } | (_ as x) { Buffer.add_char buf x; regexp buf lexbuf } | eof { Format.eprintf "LEXER: WIERD end of file in regexp@."; ()} and regexp_class buf = parse | ']' { Buffer.add_char buf ']'; regexp buf lexbuf } | '\\' (_ as x) { Buffer.add_char buf '\\'; Buffer.add_char buf x; regexp_class buf lexbuf } | (_ as x) { Buffer.add_char buf x; regexp_class buf lexbuf } | eof { Format.eprintf "LEXER: WIERD end of file in regexp_class@."; ()} and regexp_maybe_ident buf = parse | ['A'-'Z''a'-'z']* { Buffer.add_string buf (tok lexbuf) } (*****************************************************************************) and st_comment buf nl = parse | "*/" { Buffer.add_string buf (tok lexbuf) } (* noteopti: *) | NEWLINE { Buffer.add_string buf (tok lexbuf); nl := true; st_comment buf nl lexbuf } | [^'*' '\n' '\r' ]+ { Buffer.add_string buf (tok lexbuf);st_comment buf nl lexbuf } | '*' { Buffer.add_char buf '*';st_comment buf nl lexbuf } | eof { Format.eprintf "LEXER: end of file in comment@."; Buffer.add_string buf "*/"} | _ { let s = tok lexbuf in Format.eprintf "LEXER: unrecognised symbol in comment: %s@." s; Buffer.add_string buf s; st_comment buf nl lexbuf } and pos = parse | '#' [' ' '\t' ]+ (['0'-'9']+ as line) [' ' '\t' ]+ (("'"|'"') as quote) { let buf = Buffer.create 127 in string_quote quote buf lexbuf; Buffer.contents buf, int_of_string line } js_of_ocaml-2.5/compiler/js_output.ml000066400000000000000000000752431241254034500200460ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) (* XXX Beware automatic semi-colon insertion... a=b ++c is not the same as a=b ++c ===> see so-called "restricted productions": the space cannot be replaced by a newline in the following expressions: e ++, e --, continue e, break e, return e, throw e *) let stats = Option.Debug.find "output" open Javascript module PP = Pretty_print module Make(D : sig val source_map : Source_map.t option end) = struct let temp_mappings = ref [] let push_mapping,get_file_index,source_map_enabled = let idx = ref 0 in let files = Hashtbl.create 17 in match D.source_map with | None -> (fun _ _ -> ()),(fun _ -> -1),false | Some sm -> List.iter (fun f -> Hashtbl.add files f !idx; incr idx) sm.Source_map.sources; (fun pos m -> temp_mappings := (pos,m)::!temp_mappings), (fun file -> try Hashtbl.find files file with | Not_found -> let pos = !idx in Hashtbl.add files file pos; incr idx; sm.Source_map.sources <- sm.Source_map.sources @ [file]; pos), true let debug_enabled = Option.Optim.debuginfo () let output_debug_info f loc = if debug_enabled then begin match loc with Pi {Parse_info.name = file; line; col} -> PP.non_breaking_space f; PP.string f (Format.sprintf "/*<<%s %d %d>>*/" file (line + 1) col); PP.non_breaking_space f | N -> () | U -> PP.non_breaking_space f; PP.string f "/*<>*/"; PP.non_breaking_space f end; if source_map_enabled then match loc with N -> () | U -> push_mapping (PP.pos f) { Source_map.gen_line = -1; gen_col = -1; ori_source = -1; ori_line = -1; ori_col = -1; ori_name = None } | Pi { Parse_info.name=file; line; col } -> push_mapping (PP.pos f) { Source_map.gen_line = -1; gen_col = -1; ori_source = get_file_index file; ori_line = line; ori_col = col; ori_name = None } let ident f = function | S {name;var=None} -> PP.string f name | S {name;var=Some v} -> PP.string f name | V v -> assert false let opt_identifier f i = match i with None -> () | Some i -> PP.space f; ident f i let rec formal_parameter_list f l = match l with [] -> () | [i] -> ident f i | i :: r -> ident f i; PP.string f ","; PP.break f; formal_parameter_list f r (* 0 Expression 1 AssignementExpression 2 ConditionalExpression 3 LogicalORExpression 4 LogicalANDExpression 5 BitwiseORExpression 6 BitwiseXORExpression 7 BitwiseANDExpression 8 EqualityExpression 9 RelationalExpression 10 ShiftExpression 11 AdditiveExpression 12 MultiplicativeExpression 13 UnaryExpression 14 PostfixExpression 15 LeftHandsideExpression NewExpression CallExpression 16 MemberExpression FunctionExpression PrimaryExpression *) let op_prec op = match op with Eq | StarEq | SlashEq | ModEq | PlusEq | MinusEq | LslEq | AsrEq | LsrEq | BandEq | BxorEq | BorEq -> 1, 13, 1 (* | Or -> 3, 3, 4 | And -> 4, 4, 5 | Bor -> 5, 5, 6 | Bxor -> 6, 6, 7 | Band -> 7, 7, 8 *) | Or -> 3, 3, 3 | And -> 4, 4, 4 | Bor -> 5, 5, 5 | Bxor -> 6, 6, 6 | Band -> 7, 7, 7 | EqEq | NotEq | EqEqEq | NotEqEq -> 8, 8, 9 | Gt | Ge | Lt | Le | InstanceOf | In -> 9, 9, 10 | Lsl | Lsr | Asr -> 10, 10, 11 | Plus | Minus -> 11, 11, 12 | Mul | Div | Mod -> 12, 12, 13 let op_str op = match op with Eq -> "=" | StarEq -> "*=" | SlashEq -> "/=" | ModEq -> "%=" | PlusEq -> "+=" | MinusEq -> "-=" | Or -> "||" | And -> "&&" | Bor -> "|" | Bxor -> "^" | Band -> "&" | EqEq -> "==" | NotEq -> "!=" | EqEqEq -> "===" | NotEqEq -> "!==" | LslEq -> "<<=" | AsrEq -> ">>=" | LsrEq -> ">>>=" | BandEq -> "&=" | BxorEq -> "^=" | BorEq -> "|=" | Lt -> "<" | Le -> "<=" | Gt -> ">" | Ge -> ">=" | Lsl -> "<<" | Lsr -> ">>>" | Asr -> ">>" | Plus -> "+" | Minus -> "-" | Mul -> "*" | Div -> "/" | Mod -> "%" | InstanceOf | In -> assert false let unop_str op = match op with Not -> "!" | Neg -> "-" | Pl -> "+" | Bnot -> "~" | IncrA | IncrB | DecrA | DecrB | Typeof | Void | Delete -> assert false (*XXX May need to be updated... *) let rec ends_with_if_without_else st = match fst st with | If_statement (_, _, Some st) | While_statement (_, st) | For_statement (_, _, _, st) | ForIn_statement (_, _, st) -> ends_with_if_without_else st | If_statement (_, _, None) -> true | _ -> false let rec need_paren l e = match e with ESeq (e, _) -> l <= 0 && need_paren 0 e | ECond (e, _, _) -> l <= 2 && need_paren 3 e | EBin (op, e, _) -> let (out, lft, rght) = op_prec op in l <= out && need_paren lft e | ECall (e, _, _) | EAccess (e, _) | EDot (e, _) -> l <= 15 && need_paren 15 e | EVar _ | EStr _ | EArr _ | EBool _ | ENum _ | EQuote _ | ERegexp _| EUn _ | ENew _ -> false | EFun _ | EObj _ -> true let best_string_quote s = let simple = ref 0 and double = ref 0 in for i = 0 to String.length s - 1 do match s.[i] with | '\'' -> incr simple | '"' -> incr double | _ -> () done; if !simple < !double then '\'' else '"' let array_str1 = Array.init 256 (fun i -> String.make 1 (Char.chr i)) let array_conv = Array.init 16 (fun i -> String.make 1 (("0123456789abcdef").[i])) let string_escape f quote ?(utf=false) s = let l = String.length s in for i = 0 to l - 1 do let c = s.[i] in match c with | '\000' when i = l - 1 || s.[i + 1] < '0' || s.[i + 1] > '9' -> PP.string f "\\0" | '\b' -> PP.string f "\\b" | '\t' -> PP.string f "\\t" | '\n' -> PP.string f "\\n" (* This escape sequence is not supported by IE < 9 | '\011' -> "\\v" *) | '\012' -> PP.string f "\\f" | '\\' when not utf -> PP.string f "\\\\" | '\r' -> PP.string f "\\r" | '\000' .. '\031' | '\127'-> let c = Char.code c in PP.string f "\\x"; PP.string f (Array.unsafe_get array_conv (c lsr 4)); PP.string f (Array.unsafe_get array_conv (c land 0xf)) | '\128' .. '\255' when not utf -> let c = Char.code c in PP.string f "\\x"; PP.string f (Array.unsafe_get array_conv (c lsr 4)); PP.string f (Array.unsafe_get array_conv (c land 0xf)) | _ -> if c = quote then (PP.string f "\\"; PP.string f (Array.unsafe_get array_str1 (Char.code c))) else PP.string f (Array.unsafe_get array_str1 (Char.code c)) done let rec expression l f e = match e with EVar v -> ident f v | ESeq (e1, e2) -> if l > 0 then begin PP.start_group f 1; PP.string f "(" end; expression 0 f e1; PP.string f ","; PP.break f; expression 0 f e2; if l > 0 then begin PP.string f ")"; PP.end_group f end | EFun (i, l, b, pc) -> PP.start_group f 1; PP.start_group f 0; PP.start_group f 0; PP.string f "function"; opt_identifier f i; PP.end_group f; PP.break f; PP.start_group f 1; PP.string f "("; formal_parameter_list f l; PP.string f ")"; PP.end_group f; PP.end_group f; PP.break f; PP.start_group f 1; PP.string f "{"; function_body f b; output_debug_info f pc; PP.string f "}"; PP.end_group f; PP.end_group f | ECall (e, el,loc) -> if l > 15 then begin PP.start_group f 1; PP.string f "(" end; output_debug_info f loc; PP.start_group f 1; expression 15 f e; PP.break f; PP.start_group f 1; PP.string f "("; arguments f el; PP.string f ")"; PP.end_group f; PP.end_group f; if l > 15 then begin PP.string f ")"; PP.end_group f end | EStr (s, kind) -> let quote = best_string_quote s in let quote_s = String.make 1 quote in PP.string f quote_s; string_escape f ~utf:(kind = `Utf8) quote s; PP.string f quote_s | EBool b -> PP.string f (if b then "true" else "false") | ENum v -> let s = Javascript.string_of_number v in let need_parent = if s.[0] = '-' then l > 13 (* Negative numbers may need to be parenthesized. *) else l = 15 (* Parenthesize as well when followed by a dot. *) && s.[0] <> 'I' (* Infinity *) && s.[0] <> 'N' (* NaN *) in if need_parent then PP.string f "("; PP.string f s; if need_parent then PP.string f ")"; | EUn (Typeof, e) -> if l > 13 then begin PP.start_group f 1; PP.string f "(" end; PP.start_group f 0; PP.string f "typeof"; PP.space f; expression 13 f e; PP.end_group f; if l > 13 then begin PP.string f ")"; PP.end_group f end | EUn (Void, e) -> if l > 13 then begin PP.start_group f 1; PP.string f "(" end; PP.start_group f 0; PP.string f "void"; PP.space f; expression 13 f e; PP.end_group f; if l > 13 then begin PP.string f ")"; PP.end_group f end | EUn (Delete, e) -> if l > 13 then begin PP.start_group f 1; PP.string f "(" end; PP.start_group f 0; PP.string f "delete"; PP.space f; expression 13 f e; PP.end_group f; if l > 13 then begin PP.string f ")"; PP.end_group f end | EUn ((IncrA | DecrA | IncrB | DecrB) as op,e) -> if l > 13 then begin PP.start_group f 1; PP.string f "(" end; if op = IncrA || op = DecrA then expression 13 f e; if op = IncrA || op = IncrB then PP.string f "++" else PP.string f "--"; if op = IncrB || op = DecrB then expression 13 f e; if l > 13 then begin PP.string f ")"; PP.end_group f end | EUn (op, e) -> if l > 13 then begin PP.start_group f 1; PP.string f "(" end; PP.string f (unop_str op); expression 13 f e; if l > 13 then begin PP.string f ")"; PP.end_group f end | EBin (InstanceOf, e1, e2) -> let (out, lft, rght) = op_prec InstanceOf in if l > out then begin PP.start_group f 1; PP.string f "(" end; PP.start_group f 0; expression lft f e1; PP.space f; PP.string f "instanceof"; PP.space f; expression rght f e2; PP.end_group f; if l > out then begin PP.string f ")"; PP.end_group f end | EBin (In, e1, e2) -> let (out, lft, rght) = op_prec InstanceOf in if l > out then begin PP.start_group f 1; PP.string f "(" end; PP.start_group f 0; expression lft f e1; PP.space f; PP.string f "in"; PP.space f; expression rght f e2; PP.end_group f; if l > out then begin PP.string f ")"; PP.end_group f end | EBin (op, e1, e2) -> let (out, lft, rght) = op_prec op in if l > out then begin PP.start_group f 1; PP.string f "(" end; expression lft f e1; PP.string f (op_str op); PP.break f; expression rght f e2; if l > out then begin PP.string f ")"; PP.end_group f end | EArr el -> PP.start_group f 1; PP.string f "["; element_list f el; PP.string f "]"; PP.end_group f | EAccess (e, e') -> if l > 15 then begin PP.start_group f 1; PP.string f "(" end; PP.start_group f 1; expression 15 f e; PP.break f; PP.start_group f 1; PP.string f "["; expression 0 f e'; PP.string f "]"; PP.end_group f; PP.end_group f; if l > 15 then begin PP.string f ")"; PP.end_group f end | EDot (e, nm) -> if l > 15 then begin PP.start_group f 1; PP.string f "(" end; expression 15 f e; PP.string f "."; PP.string f nm; if l > 15 then begin PP.string f ")"; PP.end_group f end | ENew (e, None) -> (*FIX: should omit parentheses when possible*) if l > 15 then begin PP.start_group f 1; PP.string f "(" end; PP.start_group f 1; PP.string f "new"; PP.space f; expression 16 f e; PP.break f; PP.string f "()"; PP.end_group f; if l > 15 then begin PP.string f ")"; PP.end_group f end | ENew (e, Some el) -> if l > 15 then begin PP.start_group f 1; PP.string f "(" end; PP.start_group f 1; PP.string f "new"; PP.space f; expression 16 f e; PP.break f; PP.start_group f 1; PP.string f "("; arguments f el; PP.string f ")"; PP.end_group f; PP.end_group f; if l > 15 then begin PP.string f ")"; PP.end_group f end | ECond (e, e1, e2) -> if l > 2 then begin PP.start_group f 1; PP.string f "(" end; PP.start_group f 1; PP.start_group f 0; expression 3 f e; PP.end_group f; PP.break f; PP.start_group f 1; PP.string f "?"; expression 1 f e1; PP.end_group f; PP.break f; PP.start_group f 1; PP.string f ":"; expression 1 f e2; PP.end_group f; PP.end_group f; if l > 2 then begin PP.string f ")"; PP.end_group f end | EObj lst -> PP.start_group f 1; PP.string f "{"; property_name_and_value_list f lst; PP.string f "}"; PP.end_group f | ERegexp (s,opt) -> begin PP.string f "/";PP.string f s;PP.string f "/"; match opt with | None -> () | Some o -> PP.string f o end | EQuote s -> PP.string f "("; PP.string f s; PP.string f ")" and property_name f n = match n with PNI s -> PP.string f s | PNS s -> let quote = best_string_quote s in let quote_s = String.make 1 quote in PP.string f quote_s; string_escape f ~utf:true quote s; PP.string f quote_s | PNN v -> expression 0 f (ENum v) and property_name_and_value_list f l = match l with [] -> () | [(pn, e)] -> PP.start_group f 0; property_name f pn; PP.string f ":"; PP.break f; expression 1 f e; PP.end_group f | (pn, e) :: r -> PP.start_group f 0; property_name f pn; PP.string f ":"; PP.break f; expression 1 f e; PP.end_group f; PP.string f ","; PP.break f; property_name_and_value_list f r and element_list f el = match el with [] -> () | [e] -> begin match e with None -> PP.string f "," | Some e -> PP.start_group f 0; expression 1 f e; PP.end_group f end | e :: r -> begin match e with None -> () | Some e -> PP.start_group f 0; expression 1 f e; PP.end_group f end; PP.string f ","; PP.break f; element_list f r and function_body f b = source_elements f ~skip_last_semi:true b and arguments f l = match l with [] -> () | [e] -> PP.start_group f 0; expression 1 f e; PP.end_group f | e :: r -> PP.start_group f 0; expression 1 f e; PP.end_group f; PP.string f ","; PP.break f; arguments f r and variable_declaration f (i, init) = match init with None -> ident f i | Some (e,pc) -> PP.start_group f 1; output_debug_info f pc; ident f i; PP.string f "="; PP.break f; expression 1 f e; PP.end_group f and variable_declaration_list_aux f l = match l with [] -> assert false | [d] -> variable_declaration f d | d :: r -> variable_declaration f d; PP.string f ","; PP.break f; variable_declaration_list_aux f r and variable_declaration_list close f = function | [] -> () | [(i, None)] -> PP.start_group f 1; PP.string f "var"; PP.space f; ident f i; if close then PP.string f ";"; PP.end_group f | [(i, Some (e,pc))] -> PP.start_group f 1; output_debug_info f pc; PP.string f "var"; PP.space f; ident f i; PP.string f "="; PP.break1 f; PP.start_group f 0; expression 1 f e; if close then PP.string f ";"; PP.end_group f; PP.end_group f | l -> PP.start_group f 1; PP.string f "var"; PP.space f; variable_declaration_list_aux f l; if close then PP.string f ";"; PP.end_group f and opt_expression l f e = match e with None -> () | Some e -> expression l f e and statement ?(last=false) f (s, loc) = let last_semi () = if last then () else PP.string f ";" in output_debug_info f loc; match s with | Block b -> block f b | Variable_statement l -> variable_declaration_list (not last) f l | Empty_statement -> PP.string f ";" | Debugger_statement -> PP.string f "debugger"; last_semi () | Expression_statement (EVar _)-> last_semi () | Expression_statement e -> (* Parentheses are required when the expression starts syntactically with "{" or "function" *) if need_paren 0 e then begin PP.start_group f 1; PP.string f "("; expression 0 f e; PP.string f ")"; last_semi(); PP.end_group f end else begin PP.start_group f 0; expression 0 f e; last_semi(); PP.end_group f end | If_statement (e, s1, (Some _ as s2)) when ends_with_if_without_else s1 -> (* Dangling else issue... *) statement ~last f (If_statement (e, (Block ([s1]), N), s2), N) | If_statement (e, s1, Some ((Block _, _) as s2)) -> PP.start_group f 0; PP.start_group f 1; PP.string f "if"; PP.break f; PP.start_group f 1; PP.string f "("; expression 0 f e; PP.string f ")"; PP.end_group f; PP.end_group f; PP.break1 f; PP.start_group f 0; statement f s1; PP.end_group f; PP.break f; PP.string f "else"; PP.break1 f; PP.start_group f 0; statement ~last f s2; PP.end_group f; PP.end_group f | If_statement (e, s1, Some s2) -> PP.start_group f 0; PP.start_group f 1; PP.string f "if"; PP.break f; PP.start_group f 1; PP.string f "("; expression 0 f e; PP.string f ")"; PP.end_group f; PP.end_group f; PP.break1 f; PP.start_group f 0; statement f s1; PP.end_group f; PP.break f; PP.string f "else"; PP.space ~indent:1 f; PP.start_group f 0; statement ~last f s2; PP.end_group f; PP.end_group f | If_statement (e, s1, None) -> PP.start_group f 1; PP.start_group f 0; PP.string f "if"; PP.break f; PP.start_group f 1; PP.string f "("; expression 0 f e; PP.string f ")"; PP.end_group f; PP.end_group f; PP.break f; PP.start_group f 0; statement ~last f s1; PP.end_group f; PP.end_group f | While_statement (e, s) -> PP.start_group f 1; PP.start_group f 0; PP.string f "while"; PP.break f; PP.start_group f 1; PP.string f "("; expression 0 f e; PP.string f ")"; PP.end_group f; PP.end_group f; PP.break f; PP.start_group f 0; statement ~last f s; PP.end_group f; PP.end_group f | Do_while_statement ((Block _, _) as s, e) -> PP.start_group f 0; PP.string f "do"; PP.break1 f; PP.start_group f 0; statement f s; PP.end_group f; PP.break f; PP.string f "while"; PP.break1 f; PP.start_group f 1; PP.string f "("; expression 0 f e; PP.string f ")"; last_semi(); PP.end_group f; PP.end_group f | Do_while_statement (s, e) -> PP.start_group f 0; PP.string f "do"; PP.space ~indent:1 f; PP.start_group f 0; statement f s; PP.end_group f; PP.break f; PP.string f "while"; PP.break f; PP.start_group f 1; PP.string f "("; expression 0 f e; PP.string f ")"; last_semi(); PP.end_group f; PP.end_group f | For_statement (e1, e2, e3, s) -> PP.start_group f 1; PP.start_group f 0; PP.string f "for"; PP.break f; PP.start_group f 1; PP.string f "("; (match e1 with | Left e -> opt_expression 0 f e | Right l -> variable_declaration_list false f l); PP.string f ";"; PP.break f; opt_expression 0 f e2; PP.string f ";"; PP.break f; opt_expression 0 f e3; PP.string f ")"; PP.end_group f; PP.end_group f; PP.break f; PP.start_group f 0; statement ~last f s; PP.end_group f; PP.end_group f | ForIn_statement (e1, e2, s) -> PP.start_group f 1; PP.start_group f 0; PP.string f "for"; PP.break f; PP.start_group f 1; PP.string f "("; (match e1 with | Left e -> expression 0 f e | Right v -> variable_declaration_list false f [v]); PP.space f; PP.string f "in"; PP.break f; PP.space f; expression 0 f e2; PP.string f ")"; PP.end_group f; PP.end_group f; PP.break f; PP.start_group f 0; statement ~last f s; PP.end_group f; PP.end_group f | Continue_statement None -> PP.string f "continue"; last_semi() | Continue_statement (Some s) -> PP.string f "continue "; PP.string f (Javascript.Label.to_string s); last_semi() | Break_statement None -> PP.string f "break"; last_semi() | Break_statement (Some s) -> PP.string f "break "; PP.string f (Javascript.Label.to_string s); last_semi() | Return_statement e -> begin match e with None -> PP.string f "return"; last_semi() | Some (EFun (i, l, b, pc)) -> PP.start_group f 1; PP.start_group f 0; PP.start_group f 0; PP.string f "return function"; opt_identifier f i; PP.end_group f; PP.break f; PP.start_group f 1; PP.string f "("; formal_parameter_list f l; PP.string f ")"; PP.end_group f; PP.end_group f; PP.break f; PP.start_group f 1; PP.string f "{"; function_body f b; output_debug_info f pc; PP.string f "}"; last_semi(); PP.end_group f; PP.end_group f | Some e -> PP.start_group f 7; PP.string f "return"; PP.non_breaking_space f; PP.start_group f 0; expression 0 f e; last_semi(); PP.end_group f; PP.end_group f (* There MUST be a space between the return and its argument. A line return will not work *) end | Labelled_statement (i, s) -> PP.string f (Javascript.Label.to_string i); PP.string f ":"; PP.break f; statement ~last f s | Switch_statement (e, cc, def, cc') -> PP.start_group f 1; PP.start_group f 0; PP.string f "switch"; PP.break f; PP.start_group f 1; PP.string f "("; expression 0 f e; PP.string f ")"; PP.end_group f; PP.end_group f; PP.break f; PP.start_group f 1; PP.string f "{"; let output_one last (e,sl) = PP.start_group f 1; PP.start_group f 1; PP.string f "case"; PP.space f; expression 0 f e; PP.string f ":"; PP.end_group f; PP.break f; PP.start_group f 0; statement_list ~skip_last_semi:last f sl; PP.end_group f; PP.end_group f; PP.break f in let rec loop last = function | [] -> () | [x] -> output_one last x | x::xs -> output_one false x; loop last xs in loop (def = None && cc' = []) cc; begin match def with None -> () | Some def -> PP.start_group f 1; PP.string f "default:"; PP.break f; PP.start_group f 0; statement_list ~skip_last_semi:(cc' = []) f def; PP.end_group f; PP.end_group f end; loop true cc'; PP.string f "}"; PP.end_group f; PP.end_group f | Throw_statement e -> PP.start_group f 6; PP.string f "throw"; PP.non_breaking_space f; PP.start_group f 0; expression 0 f e; last_semi(); PP.end_group f; PP.end_group f (* There must be a space between the return and its argument. A line return would not work *) | Try_statement (b, ctch, fin) -> PP.start_group f 0; PP.string f "try"; PP.space ~indent:1 f; block f b; begin match ctch with None -> () | Some (i, b) -> PP.break f; PP.start_group f 1; PP.string f "catch("; ident f i; PP.string f ")"; PP.break f; block f b; PP.end_group f end; begin match fin with None -> () | Some b -> PP.break f; PP.start_group f 1; PP.string f "finally"; PP.space f; block f b; PP.end_group f end; PP.end_group f and statement_list f ?skip_last_semi b = match b with [] -> () | [s] -> statement f ?last:skip_last_semi s | s :: r -> statement f s; PP.break f; statement_list f ?skip_last_semi r and block f b = PP.start_group f 1; PP.string f "{"; statement_list ~skip_last_semi:true f b; PP.string f "}"; PP.end_group f and source_element f ?skip_last_semi se = match se with (Statement s, loc) -> statement f ?last:skip_last_semi (s, loc) | (Function_declaration (i, l, b, loc'), loc) -> output_debug_info f loc; PP.start_group f 1; PP.start_group f 0; PP.start_group f 0; PP.string f "function"; PP.space f; ident f i; PP.end_group f; PP.break f; PP.start_group f 1; PP.string f "("; formal_parameter_list f l; PP.string f ")"; PP.end_group f; PP.end_group f; PP.break f; PP.start_group f 1; PP.string f "{"; function_body f b; output_debug_info f loc'; PP.string f "}"; PP.end_group f; PP.end_group f and source_elements f ?skip_last_semi se = match se with [] -> () | [s] -> source_element f ?skip_last_semi s | s :: r -> source_element f s; PP.break f; source_elements f ?skip_last_semi r and program f s = source_elements f s end let part_of_ident = let a = Array.init 256 (fun i -> let c = Char.chr i in (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || (c >= '0' && c <= '9') || c = '_' || c = '$' ) in (fun c -> Array.unsafe_get a (Char.code c)) let need_space a b = (* do not concat 2 differant identifier *) (part_of_ident a && part_of_ident b) || (* do not generate end_of_line_comment. handle the case of "num / /* coment */ b " *) (a = '/' && b = '/') let chop_extension s = try Filename.chop_extension s with Invalid_argument _ -> s let program f ?source_map p = let smo = match source_map with | None -> None | Some (_,sm) -> Some sm in let module O = Make(struct let source_map = smo end) in PP.set_needed_space_function f need_space; PP.start_group f 0; O.program f p; PP.end_group f; PP.newline f; (match source_map with | None -> () | Some (out_file,sm) -> let oc = open_out out_file in let pp = Pretty_print.to_out_channel oc in Pretty_print.set_compact pp false; let sm = { sm with Source_map.mappings = List.map (fun (pos,m) -> {m with Source_map.gen_line = pos.PP.p_line; Source_map.gen_col = pos.PP.p_col}) !O.temp_mappings} in let e = Source_map.expression sm in O.expression 0 pp e; close_out oc; PP.newline f; PP.string f (Printf.sprintf "//# sourceMappingURL=%s" out_file)); if stats () then begin let size i = Printf.sprintf "%.2fKo" (float_of_int i /. 1024.) in let _percent n d = Printf.sprintf "%.1f%%" (float_of_int n *. 100. /. (float_of_int d)) in let total_s = PP.total f in Format.eprintf "total size : %s@." (size total_s); end js_of_ocaml-2.5/compiler/js_output.mli000066400000000000000000000020021241254034500201760ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val program : Pretty_print.t -> ?source_map:(string * Source_map.t) -> Javascript.program -> unit js_of_ocaml-2.5/compiler/js_parser.mly000066400000000000000000000622701241254034500201670ustar00rootroot00000000000000(* Js_of_ocaml compiler *) (* Copyright (C) 2013 Hugo Heuzard *) (* Yoann Padioleau *) (* Copyright (C) 2010 Facebook *) (* This library is free software; you can redistribute it and/or *) (* modify it under the terms of the GNU Lesser General Public License *) (* version 2.1 as published by the Free Software Foundation, with the *) (* special exception on linking described in file license.txt. *) (* This library is distributed in the hope that it will be useful, but *) (* WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file *) (* license.txt for more details. *) %{ (* * src: ocamlyaccified from Marcel Laverdet 'fbjs2' via emacs macros, itself * extracted from the official ECMAscript specification at: * http://www.ecma-international.org/publications/standards/ecma-262.htm * * see also http://en.wikipedia.org/wiki/ECMAScript_syntax * * related work: * - http://marijnhaverbeke.nl/parse-js/, js parser in common lisp * (which has been since ported to javascript by nodejs people) * - jslint *) module J = Javascript open Js_token let bop op a b= J.EBin(op,a,b) let uop op a = J.EUn(op,a) let var name = J.S {J.name;J.var=None} (* this is need to fake menhir while using --infer *) let _tok = EOF Parse_info.zero %} /*(*************************************************************************)*/ /*(*1 Tokens *)*/ /*(*************************************************************************)*/ /*(*-----------------------------------------*)*/ /*(*2 the normal tokens *)*/ /*(*-----------------------------------------*)*/ /*(* tokens with a value *)*/ %token T_NUMBER %token T_IDENTIFIER %token T_STRING %token T_REGEX /*(* keywords tokens *)*/ %token T_FUNCTION T_IF T_RETURN T_SWITCH T_THIS T_THROW T_TRY T_VAR T_WHILE T_WITH T_NULL T_FALSE T_TRUE T_BREAK T_CASE T_CATCH T_CONTINUE T_DEFAULT T_DO T_FINALLY T_FOR T_DEBUGGER %token T_ELSE %token T_NEW /*(* syntax *)*/ %token T_LCURLY T_RCURLY T_LPAREN T_RPAREN T_LBRACKET T_RBRACKET T_SEMICOLON T_COMMA T_PERIOD /*(* operators *)*/ %token T_RSHIFT3_ASSIGN T_RSHIFT_ASSIGN T_LSHIFT_ASSIGN T_BIT_XOR_ASSIGN T_BIT_OR_ASSIGN T_BIT_AND_ASSIGN T_MOD_ASSIGN T_DIV_ASSIGN T_MULT_ASSIGN T_MINUS_ASSIGN T_PLUS_ASSIGN T_ASSIGN %token T_PLING T_COLON T_OR T_AND T_BIT_OR T_BIT_XOR T_BIT_AND T_EQUAL T_NOT_EQUAL T_STRICT_EQUAL T_STRICT_NOT_EQUAL T_LESS_THAN_EQUAL T_GREATER_THAN_EQUAL T_LESS_THAN T_GREATER_THAN T_IN T_INSTANCEOF T_LSHIFT T_RSHIFT T_RSHIFT3 T_PLUS T_MINUS T_DIV T_MULT T_MOD T_NOT T_BIT_NOT T_INCR T_DECR T_INCR_NB T_DECR_NB T_DELETE T_TYPEOF T_VOID /*(*-----------------------------------------*)*/ /*(*2 extra tokens: *)*/ /*(*-----------------------------------------*)*/ %token T_VIRTUAL_SEMICOLON /*(* classic *)*/ %token EOF /*(*-----------------------------------------*)*/ /*(*2 priorities *)*/ /*(*-----------------------------------------*)*/ /*(* Special if / else associativity*)*/ %nonassoc p_IF %nonassoc T_ELSE %left T_OR %left T_AND %left T_BIT_OR %left T_BIT_XOR %left T_BIT_AND %left T_EQUAL T_NOT_EQUAL T_STRICT_EQUAL T_STRICT_NOT_EQUAL %left T_LESS_THAN_EQUAL T_GREATER_THAN_EQUAL T_LESS_THAN T_GREATER_THAN T_IN T_INSTANCEOF %left T_LSHIFT T_RSHIFT T_RSHIFT3 %left T_PLUS T_MINUS %left T_DIV T_MULT T_MOD %right T_NOT T_BIT_NOT T_INCR T_DECR T_INCR_NB T_DECR_NB T_DELETE T_TYPEOF T_VOID /*(*************************************************************************)*/ /*(*1 Rules type declaration *)*/ /*(*************************************************************************)*/ %start program %start standalone_expression %% /*(*************************************************************************)*/ /*(*1 Toplevel *)*/ /*(*************************************************************************)*/ program: | l=source_elements EOF { l } standalone_expression: | e=expression EOF {e} source_element: | s=statement { let (s, loc) = s in (J.Statement s, loc) } | f=function_declaration { let (f, loc) = f in (J.Function_declaration f, loc) } source_elements: | l=list(source_element) { l } /*(*************************************************************************)*/ /*(*1 statement *)*/ /*(*************************************************************************)*/ statement_no_semi: | b=block_with_pi { (J.Block (fst b), J.Pi (snd b)) } (* this is not allowed but some browsers accept it *) (* | function_declaration { *) (* let var,params,body,_ = $1 in *) (* J.Variable_statement [var,Some (J.EFun((None,params,body),None))]} *) | s=if_statement { s } | s=iteration_statement { s } | s=with_statement { s } | s=switch_statement { s } | s=try_statement { s } | s=labeled_statement { s } | s=empty_statement { s } statement_need_semi: | variable_statement { $1 } | expression_statement { $1 } | do_while_statement { $1 } | continue_statement { $1 } | break_statement { $1 } | return_statement { $1 } | throw_statement { $1 } | debugger_statement { $1 } statement: | s=statement_no_semi {s} | s=statement_need_semi semicolon {s} | s=statement_need_semi { (* 7.9.1 - 1 *) (* When, as the program is parsed from left to right, a token (called the offending token) is encountered that is not allowed by any production of the grammar, then a semicolon is automatically inserted before the offending token if one or more of the following conditions is true: - The offending token is }. - The offending token is separated from the previous token by at least one LineTerminator. *) (* 7.9.1 - 2 *) (* When, as the program is parsed from left to right, the end of the input stream of tokens *) (* is encountered and the parser is unable to parse the input token stream as a single *) (* complete ECMAScript Program, then a semicolon is automatically inserted at the end *) (* of the input stream. *) (* @@@@@@@@@ HACK @@@@@@@@@@ *) (* menhir internal's *) (* look the current token: *) (* - if it is on another line (linebreak inbetween), accept the statement *) (* - fail otherwise *) (* @@@@@@@@@ HACK @@@@@@@@@@ *) match _tok with | EOF _ -> s | T_RCURLY _ -> s | t -> let info = Js_token.info_of_tok t in match info.Parse_info.fol with | Some true -> s | _ -> $syntaxerror } semicolon: | T_SEMICOLON {} | T_VIRTUAL_SEMICOLON {} labeled_statement: | l=label T_COLON s=statement { (J.Labelled_statement (l, s), J.N) } statement_list: | l=list(statement) {l} block_with_pi: | l=curly_block(statement_list) { (fst l, fst (snd l)) } block: | block_with_pi { fst $1 } variable_statement: | pi=T_VAR separated_nonempty_list(T_COMMA,variable_declaration) { (J.Variable_statement $2, J.Pi pi) } variable_declaration: | variable option(initializeur) { $1, $2 } initializeur: | T_ASSIGN assignment_expression { $2, J.Pi $1 } empty_statement: | pi=T_SEMICOLON { (J.Empty_statement, J.Pi pi) } debugger_statement: | pi=T_DEBUGGER { (J.Debugger_statement, J.Pi pi) } expression_statement: | expression_no_statement { (J.Expression_statement $1, J.N) } if_statement: | pi=T_IF T_LPAREN i=expression T_RPAREN t=statement T_ELSE e=statement { (J.If_statement (i, t, Some e), J.Pi pi) } | pi=T_IF T_LPAREN i=expression T_RPAREN t=statement %prec p_IF { (J.If_statement (i, t, None), J.Pi pi) } do_while_statement: | pi=T_DO statement T_WHILE T_LPAREN expression T_RPAREN { (J.Do_while_statement ($2, $5), J.Pi pi) } iteration_statement: | pi=T_WHILE T_LPAREN expression T_RPAREN statement { (J.While_statement ($3, $5), J.Pi pi) } | pi=T_FOR T_LPAREN option(expression_no_in) T_SEMICOLON option(expression) T_SEMICOLON option(expression) T_RPAREN statement { (J.For_statement (J.Left $3, $5, $7, $9), J.Pi pi) } | pi=T_FOR T_LPAREN T_VAR separated_nonempty_list(T_COMMA,variable_declaration_no_in) T_SEMICOLON option(expression) T_SEMICOLON option(expression) T_RPAREN statement { (J.For_statement (J.Right($4), $6, $8, $10), J.Pi pi) } | pi=T_FOR T_LPAREN left_hand_side_expression T_IN expression T_RPAREN statement { (J.ForIn_statement (J.Left $3,$5,$7),J.Pi pi) } | pi=T_FOR T_LPAREN T_VAR variable_declaration_no_in T_IN expression T_RPAREN statement { (J.ForIn_statement ( J.Right $4, $6, $8), J.Pi pi) } variable_declaration_no_in: | variable option(initializer_no_in) { $1, $2 } initializer_no_in: | T_ASSIGN assignment_expression_no_in { $2, J.Pi $1 } continue_statement: | pi=T_CONTINUE option(label) { (J.Continue_statement $2,J.Pi pi) } break_statement: | pi=T_BREAK option(label) { (J.Break_statement $2, J.Pi pi) } return_statement: | pi=T_RETURN option(expression) { (J.Return_statement $2, J.Pi pi) } with_statement: | T_WITH T_LPAREN expression T_RPAREN statement { assert false } switch_statement: | pi=T_SWITCH T_LPAREN e=expression T_RPAREN b=curly_block( pair(list(case_clause),option(pair(default_clause,list(case_clause))))) { let (l, d, l') = match fst b with (l, None) -> (l, None, []) | (l, Some (d, l')) -> (l, Some d, l') in (J.Switch_statement (e, l, d, l'), J.Pi pi) } throw_statement: | pi=T_THROW expression { (J.Throw_statement $2, J.Pi pi) } try_statement: | pi=T_TRY block catch option(finally) { (J.Try_statement ($2, Some $3, $4), J.Pi pi) } | pi=T_TRY block finally { (J.Try_statement ($2, None, Some $3), J.Pi pi) } catch: | T_CATCH T_LPAREN variable T_RPAREN block { $3, $5 } finally: | T_FINALLY block { $2 } /*(*----------------------------*)*/ /*(*2 auxillary statements *)*/ /*(*----------------------------*)*/ case_clause: | T_CASE e=expression T_COLON l=statement_list { e,l } default_clause: | T_DEFAULT T_COLON l=statement_list { l } /*(*************************************************************************)*/ /*(*1 function declaration *)*/ /*(*************************************************************************)*/ function_declaration: | pi=T_FUNCTION v=variable T_LPAREN args=separated_list(T_COMMA,variable) T_RPAREN b=curly_block(function_body) { ((v, args, fst b, J.Pi (snd (snd b))), J.Pi pi) } function_expression: | pi=T_FUNCTION v=option(variable) T_LPAREN args=separated_list(T_COMMA,variable) T_RPAREN b=curly_block(function_body) { (pi, J.EFun (v, args, fst b, J.Pi pi)) } function_body: | l=source_elements { l } /*(*************************************************************************)*/ /*(*1 expression *)*/ /*(*************************************************************************)*/ expression: | assignment_expression { $1 } | expression T_COMMA assignment_expression { J.ESeq ($1, $3) } assignment_expression: | conditional_expression { $1 } | left_hand_side_expression assignment_operator assignment_expression { J.EBin ($2, $1, $3) } assignment_operator: | T_ASSIGN { J.Eq } | T_MULT_ASSIGN { J.StarEq } | T_DIV_ASSIGN { J.SlashEq } | T_MOD_ASSIGN { J.ModEq } | T_PLUS_ASSIGN { J.PlusEq } | T_MINUS_ASSIGN { J.MinusEq } | T_LSHIFT_ASSIGN { J.LslEq } | T_RSHIFT_ASSIGN { J.AsrEq } | T_RSHIFT3_ASSIGN { J.LsrEq } | T_BIT_AND_ASSIGN { J.BandEq } | T_BIT_XOR_ASSIGN { J.BxorEq } | T_BIT_OR_ASSIGN { J.BorEq } left_hand_side_expression: | new_expression { snd $1 } | call_expression { snd $1 } conditional_expression: | post_in_expression { $1 } | post_in_expression T_PLING assignment_expression T_COLON assignment_expression { J.ECond ($1, $3, $5) } post_in_expression: | pre_in_expression { $1 } | post_in_expression T_LESS_THAN post_in_expression { bop J.Lt $1 $3 } | post_in_expression T_GREATER_THAN post_in_expression { bop J.Gt $1 $3 } | post_in_expression T_LESS_THAN_EQUAL post_in_expression { bop J.Le $1 $3 } | post_in_expression T_GREATER_THAN_EQUAL post_in_expression { bop J.Ge $1 $3 } | post_in_expression T_INSTANCEOF post_in_expression { bop J.InstanceOf $1 $3 } | post_in_expression T_IN post_in_expression { bop J.In $1 $3 } | post_in_expression T_EQUAL post_in_expression { bop J.EqEq $1 $3 } | post_in_expression T_NOT_EQUAL post_in_expression { bop J.NotEq $1 $3 } | post_in_expression T_STRICT_EQUAL post_in_expression { bop J.EqEqEq $1 $3 } | post_in_expression T_STRICT_NOT_EQUAL post_in_expression { bop J.NotEqEq $1 $3 } | post_in_expression T_BIT_AND post_in_expression { bop J.Band $1 $3 } | post_in_expression T_BIT_XOR post_in_expression { bop J.Bxor $1 $3 } | post_in_expression T_BIT_OR post_in_expression { bop J.Bor $1 $3 } | post_in_expression T_AND post_in_expression { bop J.And $1 $3 } | post_in_expression T_OR post_in_expression { bop J.Or $1 $3 } pre_in_expression: | left_hand_side_expression { $1 } | pre_in_expression T_INCR_NB { uop J.IncrA $1 } | pre_in_expression T_DECR_NB { uop J.DecrA $1 } | T_DELETE pre_in_expression { uop J.Delete $2 } | T_VOID pre_in_expression { uop J.Void $2 } | T_TYPEOF pre_in_expression { uop J.Typeof $2 } | T_INCR pre_in_expression { uop J.IncrB $2 } | T_INCR_NB pre_in_expression { uop J.IncrB $2 } | T_DECR pre_in_expression { uop J.DecrB $2 } | T_DECR_NB pre_in_expression { uop J.DecrB $2 } | T_PLUS pre_in_expression { uop J.Pl $2 } | T_MINUS pre_in_expression { uop J.Neg $2} | T_BIT_NOT pre_in_expression { uop J.Bnot $2 } | T_NOT pre_in_expression { uop J.Not $2 } | pre_in_expression T_MULT pre_in_expression { bop J.Mul $1 $3 } | pre_in_expression T_DIV pre_in_expression { bop J.Div $1 $3 } | pre_in_expression T_MOD pre_in_expression { bop J.Mod $1 $3 } | pre_in_expression T_PLUS pre_in_expression { bop J.Plus $1 $3 } | pre_in_expression T_MINUS pre_in_expression { bop J.Minus $1 $3 } | pre_in_expression T_LSHIFT pre_in_expression { bop J.Lsl $1 $3 } | pre_in_expression T_RSHIFT pre_in_expression { bop J.Asr $1 $3 } | pre_in_expression T_RSHIFT3 pre_in_expression { bop J.Lsr $1 $3 } call_expression: | member_expression arguments { let (start, e) = $1 in (start, J.ECall(e, $2, J.Pi start)) } | call_expression arguments { let (start, e) = $1 in (start, J.ECall(e, $2, J.Pi start)) } | call_expression T_LBRACKET expression T_RBRACKET { let (start, e) = $1 in (start, J.EAccess (e, $3)) } | call_expression T_PERIOD method_name { let (start, e) = $1 in (start, J.EDot (e, $3)) } new_expression: | member_expression { $1 } | pi=T_NEW new_expression { (pi, J.ENew (snd $2,None)) } member_expression: | e=primary_expression { e } | member_expression T_LBRACKET e2=expression T_RBRACKET { let (start, e1) = $1 in (start, J.EAccess (e1,e2)) } | member_expression T_PERIOD i=field_name { let (start, e1) = $1 in (start, J.EDot(e1,i)) } | pi=T_NEW e1=member_expression a=arguments { (pi, J.ENew(snd e1, Some a)) } primary_expression: | p=primary_expression_no_statement { p } | o=object_literal { o } | f=function_expression { f } primary_expression_no_statement: | pi=T_THIS { (pi, J.EVar (var "this")) } | variable_with_loc { let (i, pi) = $1 in (pi, J.EVar (var i)) } | n=null_literal { n } | b=boolean_literal { b } | numeric_literal { let (start, n) = $1 in (start, J.ENum n) } | string_literal { let (s, start) = $1 in (start, J.EStr (s, `Utf8)) } /*(* marcel: this isn't an expansion of literal in ECMA-262... mistake? *)*/ | r=regex_literal { r } | a=array_literal { a } | pi=T_LPAREN e=expression T_RPAREN { (pi, e) } /*(*----------------------------*)*/ /*(*2 no in *)*/ /*(*----------------------------*)*/ expression_no_in: | assignment_expression_no_in { $1 } | expression_no_in T_COMMA assignment_expression_no_in { J.ESeq ($1, $3) } assignment_expression_no_in: | conditional_expression_no_in { $1 } | left_hand_side_expression assignment_operator assignment_expression_no_in { J.EBin($2,$1,$3) } conditional_expression_no_in: | post_in_expression_no_in { $1 } | post_in_expression_no_in T_PLING assignment_expression_no_in T_COLON assignment_expression_no_in { J.ECond ($1, $3, $5) } post_in_expression_no_in: | pre_in_expression { $1 } | post_in_expression_no_in T_LESS_THAN post_in_expression { bop J.Lt $1 $3 } | post_in_expression_no_in T_GREATER_THAN post_in_expression { bop J.Gt $1 $3 } | post_in_expression_no_in T_LESS_THAN_EQUAL post_in_expression { bop J.Le $1 $3 } | post_in_expression_no_in T_GREATER_THAN_EQUAL post_in_expression { bop J.Ge $1 $3 } | post_in_expression_no_in T_INSTANCEOF post_in_expression { bop J.InstanceOf $1 $3 } | post_in_expression_no_in T_EQUAL post_in_expression { bop J.EqEq $1 $3 } | post_in_expression_no_in T_NOT_EQUAL post_in_expression { bop J.NotEq $1 $3 } | post_in_expression_no_in T_STRICT_EQUAL post_in_expression { bop J.EqEqEq $1 $3 } | post_in_expression_no_in T_STRICT_NOT_EQUAL post_in_expression { bop J.NotEqEq $1 $3 } | post_in_expression_no_in T_BIT_AND post_in_expression { bop J.Band $1 $3 } | post_in_expression_no_in T_BIT_XOR post_in_expression { bop J.Bxor $1 $3 } | post_in_expression_no_in T_BIT_OR post_in_expression { bop J.Bor $1 $3 } | post_in_expression_no_in T_AND post_in_expression { bop J.And $1 $3 } | post_in_expression_no_in T_OR post_in_expression { bop J.Or $1 $3 } /*(*----------------------------*)*/ /*(*2 (no statement)*)*/ /*(*----------------------------*)*/ expression_no_statement: | assignment_expression_no_statement { $1 } | expression_no_statement T_COMMA assignment_expression { J.ESeq($1,$3) } assignment_expression_no_statement: | conditional_expression_no_statement { $1 } | left_hand_side_expression_no_statement assignment_operator assignment_expression { J.EBin ($2,$1,$3) } conditional_expression_no_statement: | post_in_expression_no_statement { $1 } | post_in_expression_no_statement T_PLING assignment_expression T_COLON assignment_expression { J.ECond ($1, $3, $5) } post_in_expression_no_statement: | pre_in_expression_no_statement { $1 } | post_in_expression_no_statement T_LESS_THAN post_in_expression { bop J.Lt $1 $3 } | post_in_expression_no_statement T_GREATER_THAN post_in_expression { bop J.Gt $1 $3 } | post_in_expression_no_statement T_LESS_THAN_EQUAL post_in_expression { bop J.Le $1 $3 } | post_in_expression_no_statement T_GREATER_THAN_EQUAL post_in_expression { bop J.Ge $1 $3 } | post_in_expression_no_statement T_INSTANCEOF post_in_expression { bop J.InstanceOf $1 $3 } | post_in_expression_no_statement T_IN post_in_expression { bop J.In $1 $3 } | post_in_expression_no_statement T_EQUAL post_in_expression { bop J.EqEq $1 $3 } | post_in_expression_no_statement T_NOT_EQUAL post_in_expression { bop J.NotEq $1 $3 } | post_in_expression_no_statement T_STRICT_EQUAL post_in_expression { bop J.EqEqEq $1 $3 } | post_in_expression_no_statement T_STRICT_NOT_EQUAL post_in_expression { bop J.NotEqEq $1 $3 } | post_in_expression_no_statement T_BIT_AND post_in_expression { bop J.Band $1 $3 } | post_in_expression_no_statement T_BIT_XOR post_in_expression { bop J.Bxor $1 $3 } | post_in_expression_no_statement T_BIT_OR post_in_expression { bop J.Bor $1 $3 } | post_in_expression_no_statement T_AND post_in_expression { bop J.And $1 $3 } | post_in_expression_no_statement T_OR post_in_expression { bop J.Or $1 $3 } pre_in_expression_no_statement: | left_hand_side_expression_no_statement { $1 } | pre_in_expression_no_statement T_INCR_NB { uop J.IncrA $1 } | pre_in_expression_no_statement T_DECR_NB { uop J.DecrA $1 } | T_DELETE pre_in_expression { uop J.Delete $2 } | T_VOID pre_in_expression { uop J.Void $2 } | T_TYPEOF pre_in_expression { uop J.Typeof $2 } | T_INCR pre_in_expression { uop J.IncrB $2 } | T_INCR_NB pre_in_expression { uop J.IncrB $2 } | T_DECR pre_in_expression { uop J.DecrB $2 } | T_DECR_NB pre_in_expression { uop J.DecrB $2 } | T_PLUS pre_in_expression { uop J.Pl $2 } | T_MINUS pre_in_expression { uop J.Neg $2} | T_BIT_NOT pre_in_expression { uop J.Bnot $2 } | T_NOT pre_in_expression { uop J.Not $2 } | pre_in_expression_no_statement T_MULT pre_in_expression { bop J.Mul $1 $3 } | pre_in_expression_no_statement T_DIV pre_in_expression { bop J.Div $1 $3 } | pre_in_expression_no_statement T_MOD pre_in_expression { bop J.Mod $1 $3 } | pre_in_expression_no_statement T_PLUS pre_in_expression { bop J.Plus $1 $3 } | pre_in_expression_no_statement T_MINUS pre_in_expression { bop J.Minus $1 $3 } | pre_in_expression_no_statement T_LSHIFT pre_in_expression { bop J.Lsl $1 $3 } | pre_in_expression_no_statement T_RSHIFT pre_in_expression { bop J.Asr $1 $3 } | pre_in_expression_no_statement T_RSHIFT3 pre_in_expression { bop J.Lsr $1 $3 } left_hand_side_expression_no_statement: | new_expression_no_statement { snd $1 } | call_expression_no_statement { snd $1 } new_expression_no_statement: | member_expression_no_statement { $1 } | pi=T_NEW new_expression { (pi, J.ENew (snd $2,None)) } call_expression_no_statement: | member_expression_no_statement arguments { let (start, e) = $1 in (start, J.ECall(e, $2, J.Pi start)) } | call_expression_no_statement arguments { let (start, e) = $1 in (start, J.ECall(e, $2, J.Pi start)) } | call_expression_no_statement T_LBRACKET expression T_RBRACKET { let (start, e) = $1 in (start, J.EAccess(e, $3)) } | call_expression_no_statement T_PERIOD method_name { let (start, e) = $1 in (start, J.EDot(e,$3)) } member_expression_no_statement: | e=primary_expression_no_statement { e } | member_expression_no_statement T_LBRACKET e2=expression T_RBRACKET { let (start, e1) = $1 in (start, J.EAccess(e1, e2)) } | member_expression_no_statement T_PERIOD i=field_name { let (start, e1) = $1 in (start, J.EDot(e1,i)) } | pi=T_NEW e=member_expression a=arguments { (pi, J.ENew(snd e,Some a)) } /*(*----------------------------*)*/ /*(*2 scalar *)*/ /*(*----------------------------*)*/ null_literal: | pi=T_NULL { (pi, J.EVar (var "null")) } boolean_literal: | pi=T_TRUE { (pi, J.EBool true) } | pi=T_FALSE { (pi, J.EBool false) } numeric_literal: | T_NUMBER { let (_, f, pi) = $1 in (pi, f) } regex_literal: | T_REGEX { let (s, pi) = $1 in let len = String.length s in let regexp,option = if s.[len - 1] = '/' then String.sub s 1 (len - 2),None else let i = String.rindex s '/' in String.sub s 1 (i - 1),Some (String.sub s (i+1) (len - i - 1)) in (pi, J.ERegexp (regexp,option)) } (* J.ENew(J.EVar (var "RegExp"), Some (List.map (fun s -> J.EStr (s,`Bytes)) args)) } *) string_literal: | str=T_STRING { str } /*(*----------------------------*)*/ /*(*2 array *)*/ /*(*----------------------------*)*/ array_literal: | pi=T_LBRACKET elison T_RBRACKET { (pi, J.EArr $2) } | pi=T_LBRACKET T_RBRACKET { (pi, J.EArr []) } | pi=T_LBRACKET element_list T_RBRACKET { (pi, J.EArr $2) } | pi=T_LBRACKET element_list_rev elison_rev T_RBRACKET { (pi, J.EArr (List.rev_append $2 (List.rev $3))) } element_list: | element_list_rev { List.rev $1 } element_list_rev: | elison_rev assignment_expression { (Some $2)::$1 } | assignment_expression { [Some $1] } | element_list_rev elison assignment_expression { (Some $3) :: (List.rev_append $2 $1) } separated_nonempty_list2(sep,X): | x = X { [ x ] } | x = X; sep { [ x ] } | x = X; sep; xs = separated_nonempty_list2(sep, X) { x :: xs } object_literal: | res=curly_block(empty) { (fst (snd res), J.EObj []) } | res=curly_block( separated_nonempty_list2( T_COMMA, separated_pair(property_name,T_COLON,assignment_expression) )) { (fst (snd res), J.EObj (fst res)) } empty: | {} /*(*----------------------------*)*/ /*(*2 variable *)*/ /*(*----------------------------*)*/ /*(*----------------------------*)*/ /*(*2 function call *)*/ /*(*----------------------------*)*/ arguments: | T_LPAREN l=separated_list(T_COMMA,assignment_expression) T_RPAREN { l } /*(*----------------------------*)*/ /*(*2 auxillary bis *)*/ /*(*----------------------------*)*/ /*(*************************************************************************)*/ /*(*1 Entities, names *)*/ /*(*************************************************************************)*/ identifier: | T_IDENTIFIER { fst $1 } /*(* should some keywork be allowed for field_name and method_name ??*)*/ field_name: | T_IDENTIFIER { fst $1 } method_name: | T_IDENTIFIER { fst $1 } variable: | i=identifier { var i } variable_with_loc: | T_IDENTIFIER { $1 } label: | identifier { J.Label.of_string $1 } property_name: | i=T_IDENTIFIER { J.PNI (fst i) } | s=string_literal { J.PNS (fst s) } | n=numeric_literal { J.PNN (snd n) } /*(*************************************************************************)*/ /*(*1 xxx_opt, xxx_list *)*/ /*(*************************************************************************)*/ elison_rev: | T_COMMA { [] } | elison T_COMMA { None :: $1 } elison: elison_rev {$1} (* | elison_rev { List.rev $1} *) curly_block(X): | pi1=T_LCURLY x=X pi2=T_RCURLY { (x, (pi1, pi2)) } js_of_ocaml-2.5/compiler/js_simpl.ml000066400000000000000000000165701241254034500176300ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) module J = Javascript let rec enot_rec e = let (_, cost) as res = match e with J.ESeq (e1, e2) -> let (e2', cost) = enot_rec e2 in (J.ESeq (e1, e2'), cost) | J.ECond (e1, e2, e3) -> let (e2', cost2) = enot_rec e2 in let (e3', cost3) = enot_rec e3 in (J.ECond (e1, e2', e3'), cost2 + cost3) | J.EBin (op, e1, e2) -> begin match op with J.Or -> let (e1', cost1) = enot_rec e1 in let (e2', cost2) = enot_rec e2 in (J.EBin (J.And, e1', e2'), cost1 + cost2) | J.And -> let (e1', cost1) = enot_rec e1 in let (e2', cost2) = enot_rec e2 in (J.EBin (J.Or, e1', e2'), cost1 + cost2) | J.EqEq -> (J.EBin (J.NotEq, e1, e2), 0) | J.NotEq -> (J.EBin (J.EqEq, e1, e2), 0) | J.EqEqEq -> (J.EBin (J.NotEqEq, e1, e2), 0) | J.NotEqEq -> (J.EBin (J.EqEqEq, e1, e2), 0) (*Disabled: this is not correct! var x = 0/0; !(x < 0) and x >= 0 give different result | J.Lt -> (J.EBin (J.Le, e2, e1), 0) | J.Le -> (J.EBin (J.Lt, e2, e1), 0) *) | _ -> (J.EUn (J.Not, e), 1) end | J.EUn (J.Not, e) -> (e, 0) | J.EUn ((J.Neg | J.Pl | J.Typeof | J.Void | J.Delete | J.Bnot ), _) -> (J.EUn (J.Not, e), 0) | J.EBool b -> (J.EBool (not b), 0) | J.ECall _ | J.EAccess _ | J.EDot _ | J.ENew _ | J.EVar _ | J.EFun _ | J.EStr _ | J.EArr _ | J.ENum _ | J.EObj _ | J.EQuote _ | J.ERegexp _ | J.EUn (( J.IncrA | J.IncrB | J.DecrA | J.DecrB ),_) -> (J.EUn (J.Not, e), 1) in if cost <= 1 then res else (J.EUn (J.Not, e), 1) let enot e = fst (enot_rec e) let unblock st = match st with J.Block l, _ -> l | _ -> [st] let block l = match l with | [x] -> x | l -> J.Block l,J.N exception Not_expression let rec expression_of_statement_list l = match l with (J.Return_statement (Some e), _) :: _ -> e | (J.Expression_statement e, _) :: rem -> J.ESeq (e, expression_of_statement_list rem) | _ -> raise Not_expression let expression_of_statement st = match fst st with J.Return_statement (Some e) -> e | J.Block l -> expression_of_statement_list l | _ -> raise Not_expression exception Not_assignment let rec assignment_of_statement_list l = match l with [(J.Variable_statement [x, Some e], _)] -> (x, e) | (J.Expression_statement e, _) :: rem -> let (x, (e',nid)) = assignment_of_statement_list rem in (x, (J.ESeq (e, e'),nid)) | _ -> raise Not_assignment let assignment_of_statement st = match fst st with J.Variable_statement [x, Some e] -> (x, e) | J.Block l -> assignment_of_statement_list l | _ -> raise Not_assignment let simplify_condition = function (* | J.ECond _ -> J.ENum 1. *) | J.ECond (e, J.ENum 1., J.ENum 0.) -> e | J.ECond (e, J.ENum 0., J.ENum 1.) -> J.EUn (J.Not, e) | J.ECond (J.EBin((J.NotEqEq | J.NotEq), J.ENum n, y ),e1,e2) | J.ECond (J.EBin((J.NotEqEq | J.NotEq), y, J.ENum n),e1,e2) -> J.ECond (J.EBin(J.Band,y,J.ENum n),e1,e2) | cond -> cond let rec if_statement_2 e loc iftrue truestop iffalse falsestop = let e = simplify_condition e in match fst iftrue, fst iffalse with (* Empty blocks *) J.Block [], J.Block [] -> [(J.Expression_statement e, loc)] | J.Block [], _ -> if_statement_2 (enot e) loc iffalse falsestop iftrue truestop | _, J.Block [] -> [(J.If_statement (e, iftrue, None), loc)] | _ -> (* Generates conditional *) begin try let (x1, (e1,_)) = assignment_of_statement iftrue in let (x2, (e2,_)) = assignment_of_statement iffalse in if x1 <> x2 then raise Not_assignment; let exp = if e1 = e then J.EBin(J.Or,e,e2) else J.ECond (e, e1, e2) in [J.Variable_statement [x1, Some (exp, loc)], loc] with Not_assignment -> try let e1 = expression_of_statement iftrue in let e2 = expression_of_statement iffalse in [J.Return_statement (Some (J.ECond (e, e1, e2))), loc] with Not_expression -> if truestop then (J.If_statement (e, iftrue, None), loc) :: unblock iffalse else if falsestop then (J.If_statement (enot e, iffalse, None), loc) :: unblock iftrue else [(J.If_statement (e, iftrue, Some iffalse), loc)] end let unopt b = match b with Some b -> b | None -> (J.Block [], J.N) let rec if_statement e loc iftrue truestop iffalse falsestop = (*FIX: should be done at an earlier stage*) let e = simplify_condition e in match iftrue, iffalse with (* Shared statements *) | (J.If_statement (e', iftrue', iffalse'), loc), _ when iffalse = unopt iffalse' -> if_statement_2 (J.EBin (J.And, e, e')) loc iftrue' truestop iffalse falsestop | (J.If_statement (e', iftrue', iffalse'), loc), _ when iffalse = iftrue' -> if_statement_2 (J.EBin (J.And, e, J.EUn (J.Not, e'))) loc (unopt iffalse') truestop iffalse falsestop | _, (J.If_statement (e', iftrue', iffalse'), loc) when iftrue = iftrue' -> if_statement_2 (J.EBin (J.Or, e, e')) loc iftrue truestop (unopt iffalse') falsestop | _, (J.If_statement (e', iftrue', iffalse'), loc) when iftrue = unopt iffalse' -> if_statement_2 (J.EBin (J.Or, e, (J.EUn (J.Not, e')))) loc iftrue truestop iftrue' falsestop | _ -> if_statement_2 e loc iftrue truestop iffalse falsestop let rec get_variable acc = function | J.ESeq (e1,e2) | J.EBin (_,e1,e2) | J.EAccess (e1,e2) -> get_variable (get_variable acc e1) e2 | J.ECond (e1,e2,e3) -> get_variable ( get_variable ( get_variable acc e1) e2) e2 | J.EUn (_,e1) | J.EDot (e1,_) | J.ENew (e1,None) -> get_variable acc e1 | J.ECall (e1,el,_) | J.ENew (e1,Some el) -> List.fold_left get_variable acc (e1::el) | J.EVar (J.V v) -> Code.VarSet.add v acc | J.EVar (J.S _) -> acc | J.EFun _ | J.EStr _ | J.EBool _ | J.ENum _ | J.EQuote _ | J.ERegexp _ -> acc | J.EArr a -> List.fold_left (fun acc i -> match i with | None -> acc | Some e1 -> get_variable acc e1) acc a | J.EObj l -> List.fold_left (fun acc (_,e1) -> get_variable acc e1) acc l js_of_ocaml-2.5/compiler/js_simpl.mli000066400000000000000000000024641241254034500177760ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Javascript val if_statement : expression -> location -> statement * location -> bool -> statement * location -> bool -> (statement * location) list val get_variable : Code.VarSet.t -> expression -> Code.VarSet.t val block : (Javascript.statement * location) list -> Javascript.statement * location val unblock : Javascript.statement * location -> (Javascript.statement * location) list js_of_ocaml-2.5/compiler/js_tailcall.ml000066400000000000000000000126671241254034500202740ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2014 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Code module J = Javascript open Js_traverse open Javascript class tailcall = object(m) inherit map as super val mutable tc = VarSet.empty method expression e = match e with | EFun _ -> e | _ -> super#expression e method statement s = let s = super#statement s in match s with | Return_statement (Some e) -> ignore(m#last_e e); s | _ -> s method source s = match s with | Function_declaration _ -> s | Statement s -> Statement (m#statement s) method get = tc method clear = tc <- VarSet.empty method private last_e e = match e with | ECall (EVar (V var), args, _) -> tc <- VarSet.add var tc | ESeq (_,e) -> m#last_e e | ECond (_,e1,e2) -> m#last_e e1;m#last_e e2 | _ -> () end class tailcall_rewrite f = object(m) inherit map as super method expression e = match e with | EFun _ -> e | _ -> super#expression e method statement s = let s = super#statement s in match s with | Return_statement(Some e) -> begin match m#last_e e with | None -> s | Some s -> s end | _ -> s method private last_e e = match e with | ECall (EVar var,args, _) -> f var args | ECond (cond,e1,e2) -> let e1' = m#last_e e1 in let e2' = m#last_e e2 in begin match e1',e2' with | None,None -> None | Some s,None -> Some (If_statement(cond,(s, N),Some (Return_statement (Some e2),N))) | None,Some s -> Some (If_statement(cond,(Return_statement (Some e1),N),Some (s, N))) | Some s1,Some s2 -> Some (If_statement(cond,(s1, N),Some (s2, N))) end | ESeq (e1,e2) -> begin match m#last_e e2 with | None -> None | Some s2 -> Some (Block ([(Expression_statement e1, N);(s2, N)])) end | _ -> None method source s = match s with | Statement st -> Statement (m#statement st) | Function_declaration _ -> s end module type TC = sig val rewrite : (Code.Var.t * Javascript.expression * J.location * VarSet.t) list -> (string -> Javascript.expression) -> Javascript.statement_list end module Ident : TC = struct let rewrite closures get_prim = [J.Variable_statement (List.map (fun (name, cl, loc, _) -> J.V name, Some (cl, loc)) closures), J.N] end module While : TC = struct let rewrite closures get_prim = failwith "todo" end module Tramp : TC = struct let rewrite cls get_prim = match cls with | [x,cl,_,req_tc] when not (VarSet.mem x req_tc) -> Ident.rewrite cls get_prim | _ -> let counter = Var.fresh () in Var.name counter "counter"; let m2old,m2new = List.fold_right (fun (v,_,_,_) (m2old,m2new) -> let v' = Var.fork v in VarMap.add v' v m2old, VarMap.add v v' m2new ) cls (VarMap.empty,VarMap.empty)in let rewrite v args = try match v with | J.S _ -> None | J.V v -> let n = J.V (VarMap.find v m2new) in let st = J.Return_statement ( Some ( J.ECond ( J.EBin (J.Lt, J.EVar (J.V counter), J.ENum (float_of_int (Option.Param.tailcall_max_depth ()))), J.ECall(J.EVar n, J.EBin (J.Plus,J.ENum 1.,J.EVar (J.V counter)) :: args,J.N), J.ECall ( get_prim "caml_trampoline_return", [J.EVar n ; J.EArr (List.map (fun x -> Some x) (J.ENum 0. :: args))], J.N )))) in Some st with Not_found -> None in let rw = new tailcall_rewrite rewrite in let wrappers = List.map (fun (v,clo,_,_) -> match clo with | J.EFun (_, args, _, nid) -> let b = J.ECall( get_prim "caml_trampoline", [J.ECall(J.EVar (J.V (VarMap.find v m2new)), J.ENum 0. :: List.map (fun i -> J.EVar i) args, J.N)], J.N) in let b = (J.Statement (J.Return_statement (Some b)), J.N) in v,J.EFun (None, args,[b],nid ) | _ -> assert false) cls in let reals = List.map (fun (v,clo,_,_) -> VarMap.find v m2new, match clo with | J.EFun (nm,args,body,nid) -> J.EFun (nm,(J.V counter)::args,rw#sources body, nid) | _ -> assert false ) cls in let make binds = [J.Variable_statement (List.map (fun (name, ex) -> J.V (name), Some (ex, J.N)) binds), J.N] in make (reals@wrappers) end let rewrite l = let open Option.Param in match tailcall_optim () with | TcNone -> Ident.rewrite l | TcTrampoline -> Tramp.rewrite l | TcWhile -> While.rewrite l js_of_ocaml-2.5/compiler/js_tailcall.mli000066400000000000000000000021661241254034500204360ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2014 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) class tailcall : object inherit Js_traverse.mapper method clear : unit method get : Code.VarSet.t end val rewrite : (Code.Var.t * Javascript.expression * Javascript.location * Code.VarSet.t) list -> (string -> Javascript.expression) -> Javascript.statement_list js_of_ocaml-2.5/compiler/js_token.ml000066400000000000000000000172771241254034500176310ustar00rootroot00000000000000 type token = | T_WITH of Parse_info.t | T_WHILE of Parse_info.t | T_VOID of Parse_info.t | T_VIRTUAL_SEMICOLON of Parse_info.t | T_VAR of Parse_info.t | T_TYPEOF of Parse_info.t | T_TRY of Parse_info.t | T_TRUE of Parse_info.t | T_THROW of Parse_info.t | T_THIS of Parse_info.t | T_SWITCH of Parse_info.t | T_STRING of (string * Parse_info.t) | T_STRICT_NOT_EQUAL of Parse_info.t | T_STRICT_EQUAL of Parse_info.t | T_SEMICOLON of Parse_info.t | T_RSHIFT_ASSIGN of Parse_info.t | T_RSHIFT3_ASSIGN of Parse_info.t | T_RSHIFT3 of Parse_info.t | T_RSHIFT of Parse_info.t | T_RPAREN of Parse_info.t | T_RETURN of Parse_info.t | T_REGEX of (string * Parse_info.t) | T_RCURLY of Parse_info.t | T_RBRACKET of Parse_info.t | T_PLUS_ASSIGN of Parse_info.t | T_PLUS of Parse_info.t | T_PLING of Parse_info.t | T_PERIOD of Parse_info.t | T_OR of Parse_info.t | T_NUMBER of (string * float * Parse_info.t) | T_NULL of Parse_info.t | T_NOT_EQUAL of Parse_info.t | T_NOT of Parse_info.t | T_NEW of Parse_info.t | T_MULT_ASSIGN of Parse_info.t | T_MULT of Parse_info.t | T_MOD_ASSIGN of Parse_info.t | T_MOD of Parse_info.t | T_MINUS_ASSIGN of Parse_info.t | T_MINUS of Parse_info.t | T_LSHIFT_ASSIGN of Parse_info.t | T_LSHIFT of Parse_info.t | T_LPAREN of Parse_info.t | T_LESS_THAN_EQUAL of Parse_info.t | T_LESS_THAN of Parse_info.t | T_LCURLY of Parse_info.t | T_LBRACKET of Parse_info.t | T_INSTANCEOF of Parse_info.t | T_INCR_NB of Parse_info.t | T_INCR of Parse_info.t | T_IN of Parse_info.t | T_IF of Parse_info.t | T_IDENTIFIER of (string * Parse_info.t) | T_GREATER_THAN_EQUAL of Parse_info.t | T_GREATER_THAN of Parse_info.t | T_FUNCTION of Parse_info.t | T_FOR of Parse_info.t | T_FINALLY of Parse_info.t | T_FALSE of Parse_info.t | T_EQUAL of Parse_info.t | T_ELSE of Parse_info.t | T_DO of Parse_info.t | T_DIV_ASSIGN of Parse_info.t | T_DIV of Parse_info.t | T_DELETE of Parse_info.t | T_DEFAULT of Parse_info.t | T_DECR_NB of Parse_info.t | T_DECR of Parse_info.t | T_CONTINUE of Parse_info.t | T_COMMA of Parse_info.t | T_COLON of Parse_info.t | T_CATCH of Parse_info.t | T_CASE of Parse_info.t | T_BREAK of Parse_info.t | T_BIT_XOR_ASSIGN of Parse_info.t | T_BIT_XOR of Parse_info.t | T_BIT_OR_ASSIGN of Parse_info.t | T_BIT_OR of Parse_info.t | T_BIT_NOT of Parse_info.t | T_BIT_AND_ASSIGN of Parse_info.t | T_BIT_AND of Parse_info.t | T_ASSIGN of Parse_info.t | T_AND of Parse_info.t | T_DEBUGGER of Parse_info.t | TUnknown of (Parse_info.t * string) | TCommentSpace of (Parse_info.t * string) | TCommentNewline of (Parse_info.t * string) | TCommentML of (Parse_info.t * string) | TComment of (Parse_info.t * string) | EOF of Parse_info.t let info_of_tok = function | TUnknown (ii,_) -> ii | TCommentSpace (ii,_) -> ii | TCommentNewline (ii,_) -> ii | TComment (ii,_) -> ii | TCommentML (ii,_) -> ii | EOF ii -> ii | T_DEBUGGER ii -> ii | T_NUMBER (s, _,ii) -> ii | T_IDENTIFIER (s, ii) -> ii | T_STRING (s, ii) -> ii | T_REGEX (s, ii) -> ii | T_FUNCTION ii -> ii | T_IF ii -> ii | T_IN ii -> ii | T_INSTANCEOF ii -> ii | T_RETURN ii -> ii | T_SWITCH ii -> ii | T_THIS ii -> ii | T_THROW ii -> ii | T_TRY ii -> ii | T_VAR ii -> ii | T_WHILE ii -> ii | T_WITH ii -> ii | T_NULL ii -> ii | T_FALSE ii -> ii | T_TRUE ii -> ii | T_BREAK ii -> ii | T_CASE ii -> ii | T_CATCH ii -> ii | T_CONTINUE ii -> ii | T_DEFAULT ii -> ii | T_DO ii -> ii | T_FINALLY ii -> ii | T_FOR ii -> ii | T_ELSE ii -> ii | T_NEW ii -> ii | T_LCURLY ii -> ii | T_RCURLY ii -> ii | T_LPAREN ii -> ii | T_RPAREN ii -> ii | T_LBRACKET ii -> ii | T_RBRACKET ii -> ii | T_SEMICOLON ii -> ii | T_COMMA ii -> ii | T_PERIOD ii -> ii | T_RSHIFT3_ASSIGN ii -> ii | T_RSHIFT_ASSIGN ii -> ii | T_LSHIFT_ASSIGN ii -> ii | T_BIT_XOR_ASSIGN ii -> ii | T_BIT_OR_ASSIGN ii -> ii | T_BIT_AND_ASSIGN ii -> ii | T_MOD_ASSIGN ii -> ii | T_DIV_ASSIGN ii -> ii | T_MULT_ASSIGN ii -> ii | T_MINUS_ASSIGN ii -> ii | T_PLUS_ASSIGN ii -> ii | T_ASSIGN ii -> ii | T_PLING ii -> ii | T_COLON ii -> ii | T_OR ii -> ii | T_AND ii -> ii | T_BIT_OR ii -> ii | T_BIT_XOR ii -> ii | T_BIT_AND ii -> ii | T_EQUAL ii -> ii | T_NOT_EQUAL ii -> ii | T_STRICT_EQUAL ii -> ii | T_STRICT_NOT_EQUAL ii -> ii | T_LESS_THAN_EQUAL ii -> ii | T_GREATER_THAN_EQUAL ii -> ii | T_LESS_THAN ii -> ii | T_GREATER_THAN ii -> ii | T_LSHIFT ii -> ii | T_RSHIFT ii -> ii | T_RSHIFT3 ii -> ii | T_PLUS ii -> ii | T_MINUS ii -> ii | T_DIV ii -> ii | T_MULT ii -> ii | T_MOD ii -> ii | T_NOT ii -> ii | T_BIT_NOT ii -> ii | T_INCR ii -> ii | T_DECR ii -> ii | T_INCR_NB ii -> ii | T_DECR_NB ii -> ii | T_DELETE ii -> ii | T_TYPEOF ii -> ii | T_VOID ii -> ii | T_VIRTUAL_SEMICOLON ii -> ii let string_of_tok = function | TUnknown (ii,_) -> "COMMENT" | TCommentSpace (ii,_) -> "COMMENT" | TCommentNewline (ii,_) -> "COMMENT" | TComment (ii,_) -> "COMMENT" | TCommentML (ii,_) -> "COMMENT" | EOF ii -> "EOF" | T_DEBUGGER ii -> "DEBUGGER" | T_NUMBER (s, _,ii) -> "T_NUMBER" | T_IDENTIFIER (s, ii) -> "T_IDENTIFIER" | T_STRING (s, ii) -> "T_STRING" | T_REGEX (s, ii) -> "T_REGEX" | T_FUNCTION ii -> " T_FUNCTION" | T_IF ii -> "T_IF" | T_IN ii -> "T_IN" | T_INSTANCEOF ii -> "T_INSTANCEOF" | T_RETURN ii -> "T_RETURN" | T_SWITCH ii -> "T_SWITCH" | T_THIS ii -> "T_THIS" | T_THROW ii -> "T_THROW" | T_TRY ii -> "T_TRY" | T_VAR ii -> "T_VAR" | T_WHILE ii -> "T_WHILE" | T_WITH ii -> "T_WITH" | T_NULL ii -> "T_NULL" | T_FALSE ii -> "T_FALSE" | T_TRUE ii -> "T_TRUE" | T_BREAK ii -> "T_BREAK" | T_CASE ii -> "T_CASE" | T_CATCH ii -> "T_CATCH" | T_CONTINUE ii -> "T_CONTINUE" | T_DEFAULT ii -> "T_DEFAULT" | T_DO ii -> "T_DO" | T_FINALLY ii -> "T_FINALLY" | T_FOR ii -> "T_FOR" | T_ELSE ii -> "T_ELSE" | T_NEW ii -> "T_NEW" | T_LCURLY ii -> "T_LCURLY" | T_RCURLY ii -> "T_RCURLY" | T_LPAREN ii -> "T_LPAREN" | T_RPAREN ii -> "T_RPAREN" | T_LBRACKET ii -> "T_LBRACKET" | T_RBRACKET ii -> "T_RBRACKET" | T_SEMICOLON ii -> "T_SEMICOLON" | T_COMMA ii -> "T_COMMA" | T_PERIOD ii -> "T_PERIOD" | T_RSHIFT3_ASSIGN ii -> "T_RSHIFT3" | T_RSHIFT_ASSIGN ii -> "T_RSHIFT" | T_LSHIFT_ASSIGN ii -> "T_LSHIFT" | T_BIT_XOR_ASSIGN ii -> "T_BIT" | T_BIT_OR_ASSIGN ii -> "T_BIT" | T_BIT_AND_ASSIGN ii -> "T_BIT" | T_MOD_ASSIGN ii -> "T_MOD" | T_DIV_ASSIGN ii -> "T_DIV" | T_MULT_ASSIGN ii -> "T_MULT" | T_MINUS_ASSIGN ii -> "T_MINUS" | T_PLUS_ASSIGN ii -> "T_PLUS" | T_ASSIGN ii -> "T_ASSIGN" | T_PLING ii -> "T_PLING" | T_COLON ii -> "T_COLON" | T_OR ii -> "T_OR" | T_AND ii -> "T_AND" | T_BIT_OR ii -> "T_BIT" | T_BIT_XOR ii -> "T_BIT" | T_BIT_AND ii -> "T_BIT" | T_EQUAL ii -> "T_EQUAL" | T_NOT_EQUAL ii -> "T_NOT" | T_STRICT_EQUAL ii -> "T_STRICT" | T_STRICT_NOT_EQUAL ii -> "T_STRICT" | T_LESS_THAN_EQUAL ii -> "T_LESS" | T_GREATER_THAN_EQUAL ii -> "T_GREATER" | T_LESS_THAN ii -> "T_LESS" | T_GREATER_THAN ii -> "T_GREATER" | T_LSHIFT ii -> "T_LSHIFT" | T_RSHIFT ii -> "T_RSHIFT" | T_RSHIFT3 ii -> "T_RSHIFT3" | T_PLUS ii -> "T_PLUS" | T_MINUS ii -> "T_MINUS" | T_DIV ii -> "T_DIV" | T_MULT ii -> "T_MULT" | T_MOD ii -> "T_MOD" | T_NOT ii -> "T_NOT" | T_BIT_NOT ii -> "T_BIT" | T_INCR ii -> "T_INCR" | T_DECR ii -> "T_DECR" | T_INCR_NB ii -> "T_INCR" | T_DECR_NB ii -> "T_DECR" | T_DELETE ii -> "T_DELETE" | T_TYPEOF ii -> "T_TYPEOF" | T_VOID ii -> "T_VOID" | T_VIRTUAL_SEMICOLON ii -> "T_VIRTUAL" let is_comment = function | TCommentSpace _ | TCommentNewline _ | TComment _ | TCommentML _ -> true | _ -> false js_of_ocaml-2.5/compiler/js_token.mli000066400000000000000000000060271241254034500177710ustar00rootroot00000000000000 type token = | T_WITH of (Parse_info.t) | T_WHILE of (Parse_info.t) | T_VOID of (Parse_info.t) | T_VIRTUAL_SEMICOLON of (Parse_info.t) | T_VAR of (Parse_info.t) | T_TYPEOF of (Parse_info.t) | T_TRY of (Parse_info.t) | T_TRUE of (Parse_info.t) | T_THROW of (Parse_info.t) | T_THIS of (Parse_info.t) | T_SWITCH of (Parse_info.t) | T_STRING of (string * Parse_info.t) | T_STRICT_NOT_EQUAL of (Parse_info.t) | T_STRICT_EQUAL of (Parse_info.t) | T_SEMICOLON of (Parse_info.t) | T_RSHIFT_ASSIGN of (Parse_info.t) | T_RSHIFT3_ASSIGN of (Parse_info.t) | T_RSHIFT3 of (Parse_info.t) | T_RSHIFT of (Parse_info.t) | T_RPAREN of (Parse_info.t) | T_RETURN of (Parse_info.t) | T_REGEX of (string * Parse_info.t) | T_RCURLY of (Parse_info.t) | T_RBRACKET of (Parse_info.t) | T_PLUS_ASSIGN of (Parse_info.t) | T_PLUS of (Parse_info.t) | T_PLING of (Parse_info.t) | T_PERIOD of (Parse_info.t) | T_OR of (Parse_info.t) | T_NUMBER of (string * float * Parse_info.t) | T_NULL of (Parse_info.t) | T_NOT_EQUAL of (Parse_info.t) | T_NOT of (Parse_info.t) | T_NEW of (Parse_info.t) | T_MULT_ASSIGN of (Parse_info.t) | T_MULT of (Parse_info.t) | T_MOD_ASSIGN of (Parse_info.t) | T_MOD of (Parse_info.t) | T_MINUS_ASSIGN of (Parse_info.t) | T_MINUS of (Parse_info.t) | T_LSHIFT_ASSIGN of (Parse_info.t) | T_LSHIFT of (Parse_info.t) | T_LPAREN of (Parse_info.t) | T_LESS_THAN_EQUAL of (Parse_info.t) | T_LESS_THAN of (Parse_info.t) | T_LCURLY of (Parse_info.t) | T_LBRACKET of (Parse_info.t) | T_INSTANCEOF of (Parse_info.t) | T_INCR_NB of (Parse_info.t) | T_INCR of (Parse_info.t) | T_IN of (Parse_info.t) | T_IF of (Parse_info.t) | T_IDENTIFIER of (string * Parse_info.t) | T_GREATER_THAN_EQUAL of (Parse_info.t) | T_GREATER_THAN of (Parse_info.t) | T_FUNCTION of (Parse_info.t) | T_FOR of (Parse_info.t) | T_FINALLY of (Parse_info.t) | T_FALSE of (Parse_info.t) | T_EQUAL of (Parse_info.t) | T_ELSE of (Parse_info.t) | T_DO of (Parse_info.t) | T_DIV_ASSIGN of (Parse_info.t) | T_DIV of (Parse_info.t) | T_DELETE of (Parse_info.t) | T_DEFAULT of (Parse_info.t) | T_DECR_NB of (Parse_info.t) | T_DECR of (Parse_info.t) | T_CONTINUE of (Parse_info.t) | T_COMMA of (Parse_info.t) | T_COLON of (Parse_info.t) | T_CATCH of (Parse_info.t) | T_CASE of (Parse_info.t) | T_BREAK of (Parse_info.t) | T_BIT_XOR_ASSIGN of (Parse_info.t) | T_BIT_XOR of (Parse_info.t) | T_BIT_OR_ASSIGN of (Parse_info.t) | T_BIT_OR of (Parse_info.t) | T_BIT_NOT of (Parse_info.t) | T_BIT_AND_ASSIGN of (Parse_info.t) | T_BIT_AND of (Parse_info.t) | T_ASSIGN of (Parse_info.t) | T_AND of (Parse_info.t) | T_DEBUGGER of (Parse_info.t) | TUnknown of (Parse_info.t * string) | TCommentSpace of (Parse_info.t * string) | TCommentNewline of (Parse_info.t * string) | TCommentML of (Parse_info.t * string) | TComment of (Parse_info.t * string) | EOF of (Parse_info.t) val info_of_tok : token -> Parse_info.t val string_of_tok : token -> string val is_comment : token -> bool js_of_ocaml-2.5/compiler/js_traverse.ml000066400000000000000000000645221241254034500203370ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Javascript class type mapper = object method expression : Javascript.expression -> Javascript.expression method expression_o : Javascript.expression option -> Javascript.expression option method switch_case : Javascript.expression -> Javascript.expression method initialiser : (Javascript.expression * Javascript.location) -> (Javascript.expression * Javascript.location) method initialiser_o : (Javascript.expression * Javascript.location) option -> (Javascript.expression * Javascript.location) option method statement : Javascript.statement -> Javascript.statement method statement_o : (Javascript.statement * Javascript.location) option -> (Javascript.statement * Javascript.location) option method statements : Javascript.statement_list -> Javascript.statement_list method source : Javascript.source_element -> Javascript.source_element method sources : Javascript.source_elements -> Javascript.source_elements method ident : Javascript.ident -> Javascript.ident method program : Javascript.program -> Javascript.program end (* generic js ast walk/map *) class map : mapper = object(m) method ident i = i method statements l = List.map (fun (s, pc) -> (m#statement s, pc)) l method statement s = match s with | Block b -> Block (m#statements b) | Variable_statement l -> Variable_statement (List.map (fun (id, eo) -> m#ident id, m#initialiser_o eo) l) | Empty_statement -> Empty_statement | Debugger_statement -> Debugger_statement | Expression_statement e -> Expression_statement (m#expression e) | If_statement (e, (s, loc), sopt) -> If_statement (m#expression e, (m#statement s, loc), m#statement_o sopt) | Do_while_statement ((s, loc), e) -> Do_while_statement ((m#statement s, loc), m#expression e) | While_statement(e, (s, loc)) -> While_statement(m#expression e, (m#statement s, loc)) | For_statement(e1, e2, e3, (s, loc)) -> let e1 = match e1 with | Left o -> Left(m#expression_o o) | Right l -> Right(List.map (fun (id, eo) -> m#ident id,m#initialiser_o eo) l) in For_statement (e1, m#expression_o e2, m#expression_o e3, (m#statement s, loc)) | ForIn_statement (e1, e2, (s, loc)) -> let e1 = match e1 with | Left e -> Left(m#expression e) | Right ((id,e)) -> Right ((m#ident id,m#initialiser_o e)) in ForIn_statement (e1, m#expression e2, (m#statement s, loc)) | Continue_statement s -> Continue_statement s | Break_statement s -> Break_statement s | Return_statement e -> Return_statement (m#expression_o e) | Labelled_statement (l, (s, loc)) -> Labelled_statement (l, (m#statement s, loc)) | Throw_statement e -> Throw_statement (m#expression e) | Switch_statement (e, l, def, l') -> Switch_statement (m#expression e, List.map (fun (e,s) -> m#switch_case e, m#statements s) l, begin match def with | None -> None | Some l -> Some (m#statements l) end, List.map (fun (e,s) -> m#switch_case e, m#statements s) l') | Try_statement (b, catch, final) -> Try_statement (m#statements b, (match catch with | None -> None | Some (id,b) -> Some (m#ident id, m#statements b)), (match final with | None -> None | Some s -> Some (m#statements s))) method statement_o x = match x with | None -> None | Some (s, loc) -> Some (m#statement s, loc) method switch_case e = m#expression e method expression x = match x with | ESeq(e1,e2) -> ESeq(m#expression e1, m#expression e2) | ECond(e1,e2,e3) -> ECond(m#expression e1,m#expression e2,m#expression e3) | EBin(b,e1,e2) -> EBin(b,m#expression e1,m#expression e2) | EUn(b,e1) -> EUn(b,m#expression e1) | ECall(e1,e2,loc) -> ECall(m#expression e1,List.map m#expression e2,loc) | EAccess(e1,e2) -> EAccess(m#expression e1,m#expression e2) | EDot(e1,id) -> EDot(m#expression e1, id) | ENew(e1,Some args) -> ENew(m#expression e1,Some (List.map m#expression args)) | ENew(e1,None) -> ENew(m#expression e1,None) | EVar v -> EVar (m#ident v) | EFun (idopt, params, body ,nid) -> let idopt = match idopt with | None -> None | Some i -> Some (m#ident i) in EFun (idopt, List.map m#ident params, m#sources body ,nid) | EArr l -> EArr (List.map (fun x -> m#expression_o x) l) | EObj l -> EObj (List.map (fun (i,e) -> i, m#expression e) l) | (EStr _ as x) | (EBool _ as x) | (ENum _ as x) | (EQuote _ as x) | (ERegexp _ as x) -> x method expression_o x = match x with | None -> None | Some s -> Some (m#expression s) method initialiser (e,pc) = (m#expression e,pc) method initialiser_o x = match x with | None -> None | Some i -> Some (m#initialiser i) method source x = match x with | Statement s -> Statement (m#statement s) | Function_declaration(id,params,body,nid) -> Function_declaration(m#ident id, List.map m#ident params, m#sources body,nid) method sources x = List.map (fun (s, loc) -> (m#source s, loc)) x method program x = m#sources x end (* var substitution *) class subst sub = object inherit map method ident x = sub x end let string_replace v f s = let v' = f s in if v = v' then raise Not_found else EVar v' class replace_expr f = object(m) inherit map as super method expression e = try EVar (f e) with Not_found -> super#expression e (* do not replace constant in switch case *) method switch_case e = match e with | ENum _ | EStr _ -> e | _ -> m#expression e end open Util (* this optimisation should be done at the lowest common scope *) class share_constant = object(m) inherit map as super val count = Hashtbl.create 17 method expression e = let e = match e with | EStr (s,`Utf8) when not(Util.has_backslash s) && Util.is_ascii s -> let e = EStr (s,`Bytes) in let n = try Hashtbl.find count e with Not_found -> 0 in Hashtbl.replace count e (n+1); e | EStr (_,_) | ENum _ -> let n = try Hashtbl.find count e with Not_found -> 0 in Hashtbl.replace count e (n+1); e | _ -> e in super#expression e (* do not replace constant in switch case *) method switch_case e = match e with | ENum _ | EStr _ -> e | _ -> m#expression e method sources l = let (revl, _) = List.fold_left (fun (l,prolog) (x, loc) -> match x with | Statement (Expression_statement (EStr _)) when prolog -> (x, loc) :: l, prolog | x -> (m#source x, loc)::l, false) ([],true) l in List.rev revl method program p = let p = super#program p in let all = Hashtbl.create 17 in Hashtbl.iter (fun x n -> let shareit = match x with (* JavaScript engines recognize the pattern 'typeof x==="number"'; if the string is shared, less efficient code is generated. *) | EStr ("number", _) -> None | EStr(s,_) when n > 1 -> if String.length s < 20 then Some ("str_"^s) else Some ("str_"^(String.sub s 0 16)^"_abr") | ENum f when n > 1 -> let s = Javascript.string_of_number f in let l = String.length s in if l > 2 then Some ("num_"^s) else None | _ -> None in match shareit with | Some name -> let v = Code.Var.fresh () in Code.Var.name v name; Hashtbl.add all x (V v) | _ -> () ) count ; if Hashtbl.length all = 0 then p else let f = Hashtbl.find all in let p = (new replace_expr f)#program p in let all = Hashtbl.fold (fun e v acc -> (v, Some (e,N)) :: acc) all [] in (Statement (Variable_statement all), N) :: p end module S = Code.VarSet type t = { use_name : StringSet.t; def_name : StringSet.t; def : S.t; use : S.t; count : int Javascript.IdentMap.t ; } let empty = { def = S.empty; use = S.empty; use_name = StringSet.empty; def_name = StringSet.empty; count = Javascript.IdentMap.empty; } (* def/used/free variable *) class type freevar = object('a) inherit mapper method merge_info : 'a -> unit method block : ?catch:bool -> Javascript.ident list -> unit method def_var : Javascript.ident -> unit method use_var : Javascript.ident -> unit method state : t method get_free_name : Util.StringSet.t method get_free : Code.VarSet.t method get_def_name : Util.StringSet.t method get_def : Code.VarSet.t method get_use_name : Util.StringSet.t method get_use : Code.VarSet.t end class free = object(m : 'test) inherit map as super val level : int = 0 val mutable state_ : t = empty method state = state_ method get_free = S.diff m#state.use m#state.def method get_def = m#state.def method get_free_name = StringSet.diff m#state.use_name m#state.def_name method get_def_name = m#state.def_name method get_use_name = m#state.use_name method get_use = m#state.use method merge_info from = let free_name = from#get_free_name in let free = from#get_free in let count = IdentMap.fold (fun v k acc -> let n = try IdentMap.find v acc with Not_found -> 0 in IdentMap.add v (k + n) acc ) from#state.count m#state.count in state_ <- { state_ with use_name = StringSet.union state_.use_name free_name; use = S.union state_.use free; count } method use_var x = let n = try IdentMap.find x state_.count with Not_found -> 0 in let count = IdentMap.add x (succ n) state_.count in match x with | S {name} -> state_ <- { state_ with use_name = StringSet.add name state_.use_name;count } | V v -> state_ <- { state_ with use = S.add v state_.use;count } method def_var x = let n = try IdentMap.find x state_.count with Not_found -> 0 in let count = IdentMap.add x (succ n) state_.count in match x with | S {name} -> state_ <- { state_ with def_name = StringSet.add name state_.def_name;count } | V v -> state_ <- { state_ with def = S.add v state_.def;count } method expression x = match x with | EVar v -> m#use_var v; x | EFun (ident,params,body,nid) -> let tbody = ({< state_ = empty; level = succ level >} :> 'test) in let () = List.iter tbody#def_var params in let body = tbody#sources body in let ident = match ident with | Some (V v) when not(S.mem v tbody#state.use) -> None | Some (S {name})when not(StringSet.mem name tbody#state.use_name) -> None | Some id -> tbody#def_var id;ident | None -> None in tbody#block params; m#merge_info tbody; EFun (ident,params,body,nid) | _ -> super#expression x method source x = match x with | Function_declaration (id,params, body, nid) -> let tbody = {< state_ = empty; level = succ level >} in let () = List.iter tbody#def_var params in let body = tbody#sources body in tbody#block params; m#def_var id; m#merge_info tbody; Function_declaration (id,params, body, nid) | _ -> super#source x method block ?catch params = () method statement x = match x with | Variable_statement l -> let l = List.map (fun (id,eopt) -> m#def_var id; match eopt with | None -> (id,None) | Some (e,pc) -> let e = m#expression e in (id,Some (e,pc))) l in Variable_statement l | For_statement (Right l, e2, e3, (s, loc)) -> let l = List.map (fun (id,eopt) -> m#def_var id; match eopt with | None -> (id,None) | Some (e,pc) -> let e = m#expression e in (id,Some (e,pc))) l in For_statement (Right l, m#expression_o e2, m#expression_o e3, (m#statement s, loc)) | ForIn_statement (Right (id,eopt), e2, (s, loc)) -> m#def_var id; let r = match eopt with | None -> (id,None) | Some (e,pc) -> let e = m#expression e in (id,Some (e,pc)) in ForIn_statement (Right r,m#expression e2, (m#statement s, loc)) | Try_statement (b,w,f) -> let b = m#statements b in let tbody = {< state_ = empty; level = level >} in let w = match w with | None -> None | Some (id,block) -> let block = tbody#statements block in let () = tbody#def_var id in tbody#block ~catch:true [id]; (* special merge here *) (* we need to propagate both def and use .. *) (* .. except 'id' because its scope is limitied to 'block' *) let clean set sets = match id with | S {name} -> set,StringSet.remove name sets | V i -> S.remove i set, sets in let def,def_name = clean tbody#state.def tbody#state.def_name in let use,use_name = clean tbody#state.use tbody#state.use_name in let count = IdentMap.fold (fun v k acc -> let n = try IdentMap.find v acc with Not_found -> 0 in IdentMap.add v (k + n) acc ) tbody#state.count m#state.count in state_ <- { use = S.union state_.use use; use_name = StringSet.union state_.use_name use_name; def = S.union state_.def def; def_name = StringSet.union state_.def_name def_name; count}; Some (id,block) in let f = match f with | None -> None | Some block -> Some (m#statements block) in Try_statement (b,w,f) | _ -> super#statement x end class rename_variable keeps = object(m : 'test) inherit free as super val mutable sub_ = new subst (fun x -> x) method merge_info from = let h = Hashtbl.create 17 in let _ = StringSet.iter (fun name -> if StringSet.mem name keeps then () else let v = Code.Var.fresh () in Code.Var.name v name; Hashtbl.add h name v) from#state.def_name in let f = function | (S {name}) when Hashtbl.mem h name -> V (Hashtbl.find h name) | s -> s in sub_ <- new subst f (* method block params *) method expression x = let x = super#expression x in match x with | EFun _ -> sub_#expression x | _ -> x method statement x = let x = super#statement x in match x with | Try_statement (b,w,f) -> let w = match w with | Some(S {name},block) -> let v = Code.Var.fresh () in Code.Var.name v name; let sub = function | S {name=name'} when name' = name -> V v | x -> x in let s = new subst sub in Some(V v ,s#statements block) | x -> x in Try_statement (b,w,f) | _ -> x method source x = let x = super#source x in match x with | Function_declaration (id,params,body,nid) -> Function_declaration (id,List.map sub_#ident params,sub_#sources body,nid) | _ -> x end class compact_vardecl = object(m) inherit free as super val mutable exc_ = IdentSet.empty val mutable insert_ = IdentSet.empty method exc = exc_ method private translate l = Util.filter_map (fun (id,eopt) -> match eopt with | None -> None | Some (e,_) -> Some (EBin (Eq,EVar id,e))) l method private translate_st l = let l = m#translate l in match l with | [] -> Empty_statement | x::l -> Expression_statement (List.fold_left (fun acc e -> ESeq(acc,e)) x l) method private translate_ex l = let l = m#translate l in match l with | [] -> None | x::l -> Some (List.fold_left (fun acc e -> ESeq(acc,e)) x l) method private except e = exc_ <- IdentSet.add e exc_ method statement s = let s = super#statement s in match s with | Variable_statement l -> m#translate_st l | For_statement (Right l,e2,e3,s) -> For_statement (Left (m#translate_ex l), e2, e3, s) | ForIn_statement(Right (id,op),e2,s) -> (match op with | Some _ -> assert false | None -> ()); ForIn_statement(Left (EVar id),e2,s) | Try_statement (b,w,f) -> (match w with | None -> () | Some (id,_) -> m#except id); Try_statement (b,w,f) | s -> s method block ?(catch=false) params = List.iter m#except params; super#block params; method merge_info from = super#merge_info from; let all = S.fold (fun e acc -> IdentSet.add (V e) acc) from#state.def IdentSet.empty in let all = StringSet.fold (fun e acc -> IdentSet.add (S {name=e;var=None}) acc) from#state.def_name all in insert_ <- IdentSet.diff all from#exc method private split x = let rec loop = function | ESeq(e1,e2) -> loop e1 @ loop e2 | e -> [e] in loop x method private pack all sources = let may_flush rem vars s instr = if vars = [] then rem,[],s::instr else rem,[],s::(Statement (Variable_statement (List.rev vars)), N)::instr in let rem,vars,instr = List.fold_left (fun (rem,vars,instr) (s, loc) -> match s with | Statement (Expression_statement e) -> begin let l = m#split e in List.fold_left (fun (rem,vars,instr) e -> match e with | EBin(Eq,EVar id,exp) when IdentSet.mem id rem -> (IdentSet.remove id rem,(id,Some (exp,N))::vars,instr) | x -> may_flush rem vars (Statement(Expression_statement x), N) instr) (rem,vars,instr) l end | Statement _ as s -> may_flush rem vars (s, loc) instr | Function_declaration _ as x -> (rem,vars,(x, loc)::instr) ) (all,[],[]) sources in let instr = match vars with | [] -> (List.rev instr) | d -> let d = Statement (Variable_statement (List.rev d)) in List.rev ((d, N)::instr) in let l = IdentSet.fold (fun x acc -> (x,None)::acc) rem [] in match l,instr with | [],_ -> instr | l, (Statement (Variable_statement l'), loc)::rest -> (Statement (Variable_statement (List.rev_append l l')), loc) :: rest | l,_ -> (Statement (Variable_statement l), N)::instr method source x = let x = super#source x in match x with | Function_declaration (id,params, body, nid) -> let all = IdentSet.diff insert_ exc_ in let body = m#pack all body in m#except id; Function_declaration (id,params, body, nid) | _ -> x method expression x = let x = super#expression x in match x with | EFun (ident,params,body,nid) -> let all = IdentSet.diff insert_ exc_ in let body = m#pack all body in (match ident with | Some id -> m#except id; | None -> ()); EFun (ident,params,body,nid) | _ -> x method statements l = let l = super#statements l in let l = List.fold_left (fun acc (x, loc) -> match x with | Expression_statement e -> let l = m#split e in let l = List.fold_left (fun acc e -> (Expression_statement e, N)::acc) acc l in l | _ -> (x, loc)::acc) [] l in List.rev l end class clean = object(m) inherit map as super method statements l = let rev_append_st x l = match x with | (Block b, _) -> List.rev_append b l | x -> x::l in let l = super#statements l in let vars_rev,instr_rev = List.fold_left (fun (vars_rev,instr_rev) (x, loc) -> match x with | Variable_statement l -> (List.rev_append l vars_rev,instr_rev) | Empty_statement | Expression_statement (EVar _) -> vars_rev,instr_rev | _ when vars_rev = [] -> ([],rev_append_st (x, loc) instr_rev) | _ -> ([],rev_append_st (x, loc) ((Variable_statement (List.rev vars_rev), N)::instr_rev)) ) ([],[]) l in let instr_rev = match vars_rev with | [] -> instr_rev | vars_rev -> (Variable_statement (List.rev vars_rev), N) :: instr_rev in List.rev instr_rev method statement s = let s = super#statement s in let b = function | Block [], loc -> (Empty_statement, loc) | Block [x], _ -> x | b -> b in let bopt = function | Some (Block [], _) -> None | Some (Block [x], _) -> Some x | Some b -> Some b | None -> None in match s with | If_statement (if',then',else') -> If_statement (if',b then',bopt else') | Do_while_statement (do',while') -> Do_while_statement (b do',while') | While_statement (cond,st) -> While_statement (cond,b st) | For_statement (p1,p2,p3,st) -> For_statement (p1,p2,p3,b st) | ForIn_statement (param,e,st) -> ForIn_statement (param,e,b st) | Switch_statement(e,l,Some [],[]) -> Switch_statement(e,l,None,[]) | s -> s method sources l = let l = super#sources l in let append_st st_rev sources_rev = let st = m#statements (List.rev st_rev) in let st = List.map (fun (s, loc) -> (Statement s, loc)) st in List.rev_append st sources_rev in let (st_rev,sources_rev) = List.fold_left (fun (st_rev,sources_rev) (x, loc) -> match x with | Statement s -> (s, loc)::st_rev,sources_rev | x when st_rev = [] -> [],(x, loc)::sources_rev | x -> [],((x, loc)::(append_st st_rev sources_rev)) ) ([],[]) l in let sources_rev = match st_rev with | [] -> sources_rev | st_rev -> append_st st_rev sources_rev in List.rev sources_rev end let translate_assign_op = function | Div -> SlashEq | Mod -> ModEq | Lsl -> LslEq | Asr -> AsrEq | Lsr -> LsrEq | Band -> BandEq | Bor -> BorEq | Bxor -> BxorEq | Mul -> StarEq | Plus -> PlusEq | Minus -> MinusEq | _ -> assert false let assign_op = function | (exp,EBin (Plus, exp',exp'')) -> begin match exp=exp',exp=exp'' with | false,false -> None | true, false -> if exp'' = ENum 1. then Some (EUn (IncrB,exp)) else Some (EBin (PlusEq,exp,exp'')) | false, true -> if exp' = ENum 1. then Some (EUn (IncrB,exp)) else Some (EBin (PlusEq,exp,exp')) | true, true -> Some(EBin(StarEq,exp,ENum 2.)) end | (exp,EBin (Minus, exp',y)) when exp = exp' -> if y = ENum 1. then Some (EUn (DecrB, exp)) else Some (EBin (MinusEq, exp,y)) | (exp,EBin (Mul, exp',exp'')) -> begin match exp=exp',exp=exp'' with | false,false -> None | true,_ -> Some (EBin (StarEq, exp,exp'')) | _,true -> Some (EBin (StarEq, exp,exp')) end | (exp,EBin (Div | Mod | Lsl | Asr | Lsr | Band | Bxor | Bor as unop, exp',y)) when exp = exp' -> Some (EBin (translate_assign_op unop, exp,y)) | _ -> None class simpl = object(m) inherit map as super method expression e = let e = super#expression e in match e with | EBin (Plus,e1,e2) -> begin match e2,e1 with | ENum n, _ when n < 0. -> EBin (Minus, e1, ENum (-. n)) | _,ENum n when n < 0. -> EBin (Minus, e2, ENum (-. n)) | _ -> e end | EBin (Minus,e1,e2) -> begin match e2,e1 with | ENum n,_ when n < 0. -> EBin (Plus, e1, ENum (-. n)) | _ -> e end | _ -> e method statement s = let s = super#statement s in match s with | Block [x] -> fst x | _ -> s method statements s = let s = super#statements s in List.fold_right (fun (st, loc) rem -> match st with | If_statement( cond, (Return_statement (Some e1), _), Some (Return_statement (Some e2), _)) -> (Return_statement (Some (ECond(cond,e1,e2))), loc)::rem | If_statement( cond, (Expression_statement (EBin(Eq,v1,e1)), _), Some (Expression_statement (EBin(Eq,v2,e2)),_)) when v1 = v2 -> (Expression_statement (EBin(Eq,v1,ECond(cond,e1,e2))),loc)::rem | Variable_statement l1 -> let x = List.map (function | (ident,None) -> (Variable_statement [(ident,None)], N) | (ident,Some (exp,pc)) -> match assign_op (EVar ident,exp) with | Some e -> (Expression_statement e, N) | None -> (Variable_statement [(ident,Some (exp,pc))],N)) l1 in x@rem | _ -> (st, loc)::rem ) s [] method sources l = let l = super#sources l in let append_st st_rev sources_rev = let st = m#statements (List.rev st_rev) in let st = List.map (function | (Variable_statement [addr, Some (EFun (None, params, body, loc'), loc)], _) -> (Function_declaration (addr, params, body, loc'), loc) | (s, loc) -> (Statement s, loc)) st in List.rev_append st sources_rev in let (st_rev,sources_rev) = List.fold_left (fun (st_rev,sources_rev) x -> match x with | (Statement s, loc) -> (s, loc)::st_rev,sources_rev | x when st_rev = [] -> [],x::sources_rev | x -> [],(x::(append_st st_rev sources_rev)) ) ([],[]) l in let sources_rev = match st_rev with | [] -> sources_rev | st_rev -> append_st st_rev sources_rev in List.rev sources_rev end js_of_ocaml-2.5/compiler/js_traverse.mli000066400000000000000000000047561241254034500205130ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Javascript class type mapper = object method expression : expression -> expression method expression_o : expression option -> expression option method switch_case : expression -> expression method initialiser : (expression * location) -> (expression * location) method initialiser_o : (expression * location) option -> (expression * location) option method statement : statement -> statement method statements : statement_list -> statement_list method statement_o : (statement * location) option -> (statement * location) option method source : source_element -> source_element method sources : source_elements -> source_elements method ident : ident -> ident method program : program -> program end class map : mapper class subst : (ident -> ident) -> object inherit mapper end open Util type t = { use_name : StringSet.t; def_name : StringSet.t; def : Code.VarSet.t; use : Code.VarSet.t; count : int IdentMap.t; } class type freevar = object('a) inherit mapper method merge_info : 'a -> unit method block : ?catch:bool -> ident list -> unit method def_var : ident -> unit method use_var : ident -> unit method state : t method get_free_name : Util.StringSet.t method get_free : Code.VarSet.t method get_def_name : Util.StringSet.t method get_def : Code.VarSet.t method get_use_name : Util.StringSet.t method get_use : Code.VarSet.t end class free : freevar class rename_variable : Util.StringSet.t -> freevar class share_constant : mapper class compact_vardecl : object('a) inherit free method exc : IdentSet.t end class clean : mapper class simpl : mapper js_of_ocaml-2.5/compiler/linker.ml000066400000000000000000000271711241254034500172730ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Util let loc pi = match pi with | None -> "unknown location" | Some pi -> Printf.sprintf "%s:%d" pi.Parse_info.name pi.Parse_info.line let parse_annot loc s = let buf = Lexing.from_string s in try match Annot_parser.annot Annot_lexer.initial buf with | `Requires (_,l) -> Some (`Requires (Some loc,l)) | `Provides (_,n,k,ka) -> Some (`Provides (Some loc,n,k,ka)) | `Version (_,l) -> Some (`Version (Some loc, l)) with | Not_found -> None | exc -> (* Format.eprintf "Not found for %s : %s @." (Printexc.to_string exc) s; *) None let error s = Format.ksprintf (fun s -> failwith s) s let parse_file f = let file = try match Util.path_require_findlib f with | Some f -> let pkg,f' = match Util.split Filename.dir_sep f with | [] -> assert false | [f] -> "js_of_ocaml",f | pkg::l -> pkg, List.fold_left Filename.concat "" l in Filename.concat (Util.find_pkg_dir pkg) f' | None -> f with | Not_found -> error "cannot find file '%s'. @." f | Sys_error s -> error "%s@." s in let lex = Parse_js.lexer_from_file ~rm_comment:false file in let status,lexs = Parse_js.lexer_fold (fun (status,lexs) t -> match t with | Js_token.TComment (info,str) -> begin match parse_annot info str with | None -> (status,lexs) | Some a -> match status with | `Annot annot -> `Annot (a::annot),lexs | `Code (an,co) -> `Annot [a], ((List.rev an,List.rev co)::lexs) end | _ when Js_token.is_comment t -> (status,lexs) | Js_token.TUnknown (info,_) -> Format.eprintf "Unknown token while parsing JavaScript at %s@." (loc (Some info)); if not (Filename.check_suffix file ".js") then Format.eprintf "%S doesn't look like a JavaScript file@." file; failwith "Error while parsing JavaScript" | c -> match status with | `Code (annot,code) -> `Code (annot,c::code),lexs | `Annot (annot) -> `Code(annot,[c]),lexs ) (`Annot [],[]) lex in let lexs = match status with | `Annot _ -> lexs | `Code(annot,code) -> (List.rev annot,List.rev code)::lexs in let res = List.rev_map (fun (annot,code) -> let lex = Parse_js.lexer_from_list code in try let code = Parse_js.parse lex in let req,has_provide,versions = List.fold_left (fun (req,has_provide,versions) a -> match a with | `Provides (pi,name,kind,ka) -> req,Some (pi,name,kind,ka),versions | `Requires (_,mn) -> (mn@req),has_provide,versions | `Version (_,l) -> req,has_provide,l::versions ) ([],None,[]) annot in has_provide,req,versions,code with Parse_js.Parsing_error pi -> error "cannot parse file %S (orig:%S from l:%d, c:%d)@." f pi.Parse_info.name pi.Parse_info.line pi.Parse_info.col) lexs in res class check_and_warn name pi = object(m) inherit Js_traverse.free as super method merge_info from = let def = from#get_def_name in let use = from#get_use_name in let diff = StringSet.diff def use in let diff = StringSet.remove name diff in let diff = StringSet.filter (fun s -> String.length s <> 0 && s.[0] <> '_') diff in if not (StringSet.is_empty diff) then Format.eprintf "WARN unused for primitive %s at %s:@. %s@." name (loc pi) (String.concat ", " (StringSet.elements diff)); super#merge_info from end exception May_not_return (* let all_return p = let open Javascript in let rec loop_st = function | [] -> raise May_not_return | [Return_statement (Some _), _] -> () | [Return_statement None, _] -> raise May_not_return | [If_statement(_,th,el), _] -> loop_st [th]; (match el with | None -> raise May_not_return | Some x -> loop_st [x]) | [Do_while_statement(st,_), _] -> loop_st [st] | [While_statement(_,st), _] -> loop_st [st] | [For_statement (_,_,_,st), _] -> loop_st [st] | [Switch_statement (_,l,def), _] -> List.iter (fun (_,sts) -> loop_st sts) l | [Try_statement(b,_,_),_] -> loop_st b | [Throw_statement _, _] -> () | x::xs -> loop_st xs in let rec loop_sources = function | [] -> raise May_not_return | [(Statement x, loc)] -> loop_st [(x, loc)] | [_] -> raise May_not_return | x::xs -> loop_sources xs in let rec loop_all_sources = function | [] -> () | Statement x :: xs -> loop_all_sources xs | Function_declaration(_,_,b,_) :: xs -> loop_sources b; loop_all_sources xs in try loop_all_sources p; true with May_not_return -> false *) let check_primitive name pi code req = let free = if Option.Optim.warn_unused () then new check_and_warn name pi else new Js_traverse.free in let _code = free#program code in let freename = free#get_free_name in let freename = List.fold_left (fun freename x -> StringSet.remove x freename) freename req in let freename = StringSet.diff freename Reserved.keyword in let freename = StringSet.diff freename Reserved.provided in let freename = StringSet.remove Option.global_object freename in if not(StringSet.mem name free#get_def_name) then begin Format.eprintf "warning: primitive code does not define value with the expected name: %s (%s)@." name (loc pi) end; if not(StringSet.is_empty freename) then begin Format.eprintf "warning: free variables in primitive code %S (%s)@." name (loc pi); Format.eprintf "vars: %s@." (String.concat ", " (StringSet.elements freename)) end (* ; *) (* return checks disabled *) (* if false && not (all_return code) *) (* then Format.eprintf "warning: returns may be missing for primitive code %S (%s)@." name (loc pi) *) let version_match = List.for_all (fun (op,str) -> op (Util.Version.(compare current (split str))) 0 ) type state = { ids : IntSet.t; codes : Javascript.program list ; } let last_code_id = ref 0 let provided = Hashtbl.create 31 let provided_rev = Hashtbl.create 31 let code_pieces = Hashtbl.create 31 let always_included = ref [] class traverse_and_find_named_values all = object inherit Js_traverse.map as self method expression x = let open Javascript in (match x with | ECall(EVar (S {name="caml_named_value"}),[EStr (v,_)],_) -> all:=StringSet.add v !all | _ -> () ); self#expression x end let find_named_value code = let all = ref StringSet.empty in let p = new traverse_and_find_named_values all in ignore(p#program code); !all let add_file f = List.iter (fun (provide,req,versions,(code:Javascript.program)) -> incr last_code_id; let id = !last_code_id in let vmatch = match versions with | [] -> true | l -> List.exists version_match l in if vmatch then begin (match provide with | None -> always_included := id :: !always_included | Some (pi,name,kind,ka) -> let module J = Javascript in let rec find = function | [] -> None | (J.Function_declaration (J.S{J.name=n},l,_,_), _)::_ when name=n -> Some(List.length l) | _::rem -> find rem in let arity = find code in let named_values = find_named_value code in Primitive.register name kind ka arity; StringSet.iter Primitive.register_named_value named_values; if Hashtbl.mem provided name then begin let ploc = snd(Hashtbl.find provided name) in Format.eprintf "warning: overriding primitive %S\n old: %s\n new: %s@." name (loc ploc) (loc pi) end; Hashtbl.add provided name (id,pi); Hashtbl.add provided_rev id (name,pi); check_primitive name pi code req ); Hashtbl.add code_pieces id (code, req) end ) (parse_file f) let get_provided () = Hashtbl.fold (fun k _ acc -> StringSet.add k acc) provided StringSet.empty let check_deps () = let provided = get_provided () in Hashtbl.iter (fun id (code,requires) -> let traverse = new Js_traverse.free in let _js = traverse#program code in let free = traverse#get_free_name in let requires = List.fold_right StringSet.add requires StringSet.empty in let real = StringSet.inter free provided in let missing = StringSet.diff real requires in if not (StringSet.is_empty missing) then begin try let (name,ploc) = Hashtbl.find provided_rev id in Format.eprintf "code providing %s (%s) may miss dependencies: %s\n" name (loc ploc) (String.concat ", " (StringSet.elements missing)) with Not_found -> (* there is no //Provides for this piece of code *) (* FIXME handle missing deps in this case *) () end ) code_pieces let load_files l = List.iter add_file l; check_deps () (* resolve *) let rec resolve_dep_name_rev visited path nm = let id = try fst(Hashtbl.find provided nm) with Not_found -> error "missing dependency '%s'@." nm in resolve_dep_id_rev visited path id and resolve_dep_id_rev visited path id = if IntSet.mem id visited.ids then begin if List.memq id path then error "circular dependency: %s" (String.concat ", " (List.map (fun id -> fst(Hashtbl.find provided_rev id)) path)); visited end else begin let path = id :: path in let (code, req) = Hashtbl.find code_pieces id in let visited = {visited with ids = IntSet.add id visited.ids} in let visited = List.fold_left (fun visited nm -> resolve_dep_name_rev visited path nm) visited req in let visited = {visited with codes = code::visited.codes} in visited end let init () = List.fold_left (fun visited id -> resolve_dep_id_rev visited [] id) {ids=IntSet.empty; codes=[]} !always_included let resolve_deps ?(linkall = false) visited_rev used = (* link the special files *) let missing,visited_rev = if linkall then begin (* link all primitives *) let prog,set = Hashtbl.fold (fun nm (id,_) (visited,set) -> resolve_dep_name_rev visited [] nm, StringSet.add nm set ) provided (visited_rev,StringSet.empty) in let missing = StringSet.diff used set in missing,prog end else (* link used primitives *) StringSet.fold (fun nm (missing, visited)-> if Hashtbl.mem provided nm then (missing, resolve_dep_name_rev visited [] nm) else (StringSet.add nm missing, visited)) used (StringSet.empty, visited_rev) in visited_rev, missing let link program state = List.flatten (List.rev (program::state.codes)) js_of_ocaml-2.5/compiler/linker.mli000066400000000000000000000026621241254034500174420ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val parse_file : string -> ((Parse_info.t option * string * Primitive.kind * Primitive.kind_arg list option) option * (* provide *) string list * (* require *) ((int -> int -> bool) * string) list list * (* version constraint *) Javascript.program) list val load_files : string list -> unit type state val init : unit -> state val resolve_deps : ?linkall:bool -> state -> Util.StringSet.t -> state * Util.StringSet.t val link : Javascript.program -> state -> Javascript.program val get_provided : unit -> Util.StringSet.t js_of_ocaml-2.5/compiler/minify.ml000066400000000000000000000072721241254034500173020ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let error k = Format.ksprintf (fun s -> failwith s) k let _ = Sys.catch_break true let f { MinifyArg.common; output_file; stdin; files } = CommonArg.eval common; let chop_extension s = try Filename.chop_extension s with Invalid_argument _ -> s in let pp,finalize = match output_file with | Some "-" -> Pretty_print.to_out_channel stdout,(fun _ -> ()) | Some file -> let oc = open_out file in Pretty_print.to_out_channel oc, (fun _ -> close_out oc) | None when not stdin -> let file = if List.length files = 1 then chop_extension (List.hd files) ^ ".min.js" else "a.min.js" in let oc = open_out file in Pretty_print.to_out_channel oc, (fun _ -> close_out oc) | None (* when stdin *) -> Pretty_print.to_out_channel stdout,(fun _ -> ()) in let pretty = Option.Optim.pretty () in Pretty_print.set_compact pp (not pretty); Code.Var.set_pretty pretty; let error_of_pi pi = if pi.Parse_info.name = "" then error "error at l:%d col:%d" pi.Parse_info.line pi.Parse_info.col else error "error at file:%S l:%d col:%d" pi.Parse_info.name pi.Parse_info.line pi.Parse_info.col in let p = List.flatten (List.map (fun file -> let lex = Parse_js.lexer_from_file file in try Parse_js.parse lex with Parse_js.Parsing_error pi -> error_of_pi pi) files) in let p = if stdin then let lex = Parse_js.lexer_from_channel Pervasives.stdin in try p@(Parse_js.parse lex) with Parse_js.Parsing_error pi -> error_of_pi pi; else p in let true_ = (fun () -> true) in let open Option in let passes : ((unit -> bool) * (unit -> Js_traverse.mapper)) list = [ Optim.shortvar, (fun () -> ((new Js_traverse.rename_variable Util.StringSet.empty) :> Js_traverse.mapper) ); Optim.share_constant, (fun () -> new Js_traverse.share_constant); true_, (fun () -> new Js_traverse.simpl); true_, (fun () -> new Js_traverse.clean); ] in let p = List.fold_left (fun p (t,m) -> if t() then (m())#program p else p) p passes in let p = Js_assign.program p in Js_output.program pp p; finalize() let main = Cmdliner.Term.(pure f $ MinifyArg.options), MinifyArg.info let _ = Util.Timer.init Sys.time; try Cmdliner.Term.eval ~catch:false ~argv:(Util.normalize_argv ~warn:true Sys.argv) main with | (Match_failure _ | Assert_failure _ | Not_found) as exc -> let backtrace = Printexc.get_backtrace () in Format.eprintf "%s: You found a bug. \ Please report it at https://github.com/ocsigen/js_of_ocaml/issues :@." Sys.argv.(0); Format.eprintf "Error: %s@." (Printexc.to_string exc); prerr_string backtrace; exit 1 | Failure s -> Format.eprintf "%s: Error: %s@." Sys.argv.(0) s; exit 1 | exc -> Format.eprintf "%s: Error: %s@." Sys.argv.(0) (Printexc.to_string exc); exit 1 js_of_ocaml-2.5/compiler/minifyArg.ml000066400000000000000000000047711241254034500177350ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2014 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Cmdliner type t = { common : CommonArg.t; (* minify option *) stdin : bool; output_file : string option; files : string list } let options = let files = Arg.(value & pos_all file [] & info [] ~docv:"JS_FILES") in let output_file = let doc = "Set output file name to [$(docv)]." in Arg.(value & opt (some string) None & info ["o"] ~docv:"FILE" ~doc) in let stdin = let doc = "Read from standard input." in Arg.(value & flag & info ["stdin"] ~doc) in let build_t common files output_file stdin = `Ok { common; stdin; output_file; files } in let t = Term.(pure build_t $ CommonArg.t $ files $ output_file $ stdin) in Term.ret t let info = let doc = "JavaScript minifier" in let man = [ `S "DESCRIPTION"; `P "jsoo_minify is a JavaScript minifier."; `S "BUGS"; `P "Bugs are tracked on github at \ $(i,https://github.com/ocsigen/js_of_ocaml/issues)."; `S "SEE ALSO"; `P "js_of_ocaml(1)"; `S "AUTHORS"; `P "Jerome Vouillon, Hugo Heuzard."; `S "LICENSE"; `P "Copyright (C) 2010-2014."; `P "jsoo_minify is free software, you can redistribute it and/or modify \ it under the terms of the GNU Lesser General Public License as published \ by the Free Software Foundation, with linking exception; \ either version 2.1 of the License, or (at your option) any later version." ] in let version = match Compiler_version.git_version with | "" -> Compiler_version.s | v -> Printf.sprintf "%s+git-%s"Compiler_version.s v in Term.info "jsoo_minify" ~version ~doc ~man js_of_ocaml-2.5/compiler/minifyArg.mli000066400000000000000000000020421241254034500200730ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2014 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t = { common : CommonArg.t; (* minify option *) stdin : bool; output_file : string option; files : string list } val options : t Cmdliner.Term.t val info : Cmdliner.Term.info js_of_ocaml-2.5/compiler/option.ml000066400000000000000000000113501241254034500173070ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let global_object = "joo_global_object" let extra_js_files = ["+weak.js" ; "+graphics.js"; "+toplevel.js"; "+nat.js"] (* Optimisation *) module Debug = struct let debugs : (string * bool ref) list ref = ref [] let available () = List.map fst !debugs let find s = let state = try List.assoc s !debugs with Not_found -> let state = ref false in debugs := (s, state) :: !debugs; state in fun () -> !state let enable s = try List.assoc s !debugs := true with Not_found -> failwith (Printf.sprintf "The debug named %S doesn't exist" s) let disable s = try List.assoc s !debugs := false with Not_found -> failwith (Printf.sprintf "The debug named %S doesn't exist" s) end module Optim = struct let optims = ref [] let available () = List.map fst !optims let o ~name ~default = let state = try List.assoc name !optims with Not_found -> let state = ref default in optims := (name, state) :: !optims; state in fun () -> !state let disable s = try List.assoc s !optims := false with Not_found -> failwith (Printf.sprintf "The option named %S doesn't exist" s) let enable s = try List.assoc s !optims := true with Not_found -> failwith (Printf.sprintf "The option named %S doesn't exist" s) let pretty = o ~name:"pretty" ~default:false let debuginfo = o ~name:"debuginfo" ~default:false let deadcode = o ~name:"deadcode" ~default:true let shortvar = o ~name:"shortvar" ~default:true let compact = o ~name:"compact" ~default:true let optcall = o ~name:"optcall" ~default:true let inline = o ~name:"inline" ~default:true let staticeval = o ~name:"staticeval" ~default:true let share_constant = o ~name:"share" ~default:true let strictmode = o ~name:"strict" ~default:true let debugger = o ~name:"debugger" ~default:true let genprim = o ~name:"genprim" ~default:true let excwrap = o ~name:"excwrap" ~default:true let include_cmis = o ~name:"withcmi" ~default: true let warn_unused = o ~name:"warn-unused" ~default: false let inline_callgen = o ~name:"callgen" ~default:false (* this does not optimize properly *) let compact_vardecl = o ~name:"vardecl" ~default:false end module Param = struct let int default = default, int_of_string let enum : (string * 'a) list -> _ = function | ((d,v) :: _) as l -> v, (fun x -> List.assoc x l) | _ -> assert false let params : (string * _) list ref = ref [] let p ~name ~desc (default,convert) = assert(not (List.mem_assoc name !params)); let state = ref default in let set : string -> unit = fun v -> try state := convert v with | _ -> Format.eprintf "Warning: malformed option %s=%s. IGNORE@." name v in params := (name, (set,desc)) :: !params; fun () -> !state let set s v = try fst (List.assoc s !params) v with Not_found -> failwith (Printf.sprintf "The option named %S doesn't exist" s) let all () = List.map (fun (n,(_,d)) -> n,d) !params (* V8 "optimize" switches with less than 128 case. 60 seams to perform well. *) let switch_max_case = p ~name:"switch_size" ~desc:"set the maximum number of case in a switch" (int 60) let tailcall_max_depth = p ~name:"tc_depth" ~desc:"set the maximum number of recursive tailcalls defore returning a trampoline" (int 50) let constant_max_depth = p ~name:"cst_depth" ~desc:"set the maximum depth of generated litteral JavaScript values" (int 10) type tc = | TcNone | TcTrampoline | TcWhile let tc_default = TcTrampoline let tc_all = tc_default :: List.filter ((<>) tc_default) [TcNone;TcTrampoline(* ;TcWhile *)] let tailcall_optim = p ~name:"tc" ~desc:"Set tailcall optimisation" (enum ["trampoline",TcTrampoline;(* default *) "none",TcNone]) end js_of_ocaml-2.5/compiler/option.mli000066400000000000000000000040101241254034500174530ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) module Debug : sig val available : unit -> string list val find : string -> unit -> bool val enable : string -> unit val disable : string -> unit end module Optim : sig val available : unit -> string list val deadcode : unit -> bool val optcall : unit -> bool val shortvar : unit -> bool val compact : unit -> bool val inline : unit -> bool val share_constant : unit -> bool val staticeval : unit -> bool val genprim : unit -> bool val strictmode : unit -> bool val compact_vardecl : unit -> bool val debugger : unit -> bool val pretty : unit -> bool val debuginfo : unit -> bool val excwrap : unit -> bool val include_cmis: unit -> bool val warn_unused : unit -> bool val inline_callgen : unit -> bool val enable : string -> unit val disable : string -> unit end module Param : sig val set : string -> string -> unit val all : unit -> (string * string) list val switch_max_case : unit -> int val tailcall_max_depth : unit -> int val constant_max_depth : unit -> int type tc = | TcNone | TcTrampoline | TcWhile val tailcall_optim : unit -> tc end val global_object : string val extra_js_files : string list js_of_ocaml-2.5/compiler/parse_bytecode.ml000066400000000000000000002136651241254034500210040ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Code open Instr let debug_parser = Option.Debug.find "parser" type code = string (* Copied from ocaml/typing/ident.ml *) module Ident = struct type t = { stamp: int; name: string; mutable flags: int } type 'a tbl = | Empty | Node of 'a tbl * 'a data * 'a tbl * int and 'a data = { ident: t; data: 'a; previous: 'a data option } let rec table_contents_rec sz t rem = match t with Empty -> rem | Node (l, v, r, _) -> table_contents_rec sz l ((sz - v.data, v.ident.name) :: table_contents_rec sz r rem) let table_contents sz t = List.sort (fun (i, _) (j, _) -> compare i j) (table_contents_rec sz t []) end (* Copied from ocaml/utils/tbl.ml *) module Tbl = struct type ('a, 'b) t = | Empty | Node of ('a, 'b) t * 'a * 'b * ('a, 'b) t * int let rec iter f = function Empty -> () | Node(l, v, d, r, _) -> iter f l; f v d; iter f r let rec find compare x = function Empty -> raise Not_found | Node(l, v, d, r, _) -> let c = compare x v in if c = 0 then d else find compare x (if c < 0 then l else r) let rec fold f m accu = match m with | Empty -> accu | Node(l, v, d, r, _) -> fold f r (f v d (fold f l accu)) end (* Copied from ocaml/bytecomp/symtable.ml *) type 'a numtable = { num_cnt: int; num_tbl: ('a, int) Tbl.t } (* Read and manipulate debug section *) module Debug : sig type compilation_env = { ce_stack: int Ident.tbl; (* Positions of variables in the stack *) ce_heap: int Ident.tbl; (* Structure of the heap-allocated env *) ce_rec: int Ident.tbl } (* Functions bound by the same let rec *) type pos = { pos_fname: string; pos_lnum: int; pos_bol: int; pos_cnum: int } type loc_info = { li_start: pos; li_end: pos; li_ghost: unit } type debug_event = { mutable ev_pos: int; (* Position in bytecode *) ev_module: string; (* Name of defining module *) ev_loc: loc_info; (* Location in source file *) ev_kind: debug_event_kind; (* Before/after event *) ev_info: debug_event_info; (* Extra information *) ev_typenv: unit; (* Typing environment *) ev_typsubst: unit; (* Substitution over types *) ev_compenv: compilation_env; (* Compilation environment *) ev_stacksize: int; (* Size of stack frame *) ev_repr: unit } (* Position of the representative *) and debug_event_kind = Event_before | Event_after of unit | Event_pseudo and debug_event_info = unit (* Event_function *) (* | Event_return of int *) (* | Event_other *) type data val propagate : Code.Var.t list -> Code.Var.t list -> unit val find : data -> Code.addr -> (int * string) list val find_loc : data -> ?after:bool -> int -> Parse_info.t option val mem : data -> Code.addr -> bool val read : in_channel -> data val no_data : unit -> data val fold : data -> (Code.addr -> debug_event -> 'a -> 'a) -> 'a -> 'a end = struct type compilation_env = { ce_stack: int Ident.tbl; (* Positions of variables in the stack *) ce_heap: int Ident.tbl; (* Structure of the heap-allocated env *) ce_rec: int Ident.tbl } (* Functions bound by the same let rec *) type pos = { pos_fname: string; pos_lnum: int; pos_bol: int; pos_cnum: int } type loc_info = { li_start: pos; li_end: pos; li_ghost: unit } type debug_event = { mutable ev_pos: int; (* Position in bytecode *) ev_module: string; (* Name of defining module *) ev_loc: loc_info; (* Location in source file *) ev_kind: debug_event_kind; (* Before/after event *) ev_info: debug_event_info; (* Extra information *) ev_typenv: unit; (* Typing environment *) ev_typsubst: unit; (* Substitution over types *) ev_compenv: compilation_env; (* Compilation environment *) ev_stacksize: int; (* Size of stack frame *) ev_repr: unit } (* Position of the representative *) and debug_event_kind = Event_before | Event_after of unit | Event_pseudo and debug_event_info = unit (* Event_function *) (* | Event_return of int *) (* | Event_other *) type data = (int, debug_event) Hashtbl.t let relocate_event orig ev = ev.ev_pos <- (orig + ev.ev_pos) / 4 let no_data () = Hashtbl.create 17 let read ic = let events_by_pc = Hashtbl.create 257 in let read_paths : unit -> string list = match Util.Version.v with | `V3 -> (fun () -> []) | `V4_02 -> (fun () -> (input_value ic : string list)) in let len = input_binary_int ic in for i = 0 to len - 1 do let orig = input_binary_int ic in let evl : debug_event list = input_value ic in (* Work arround a bug in ocaml 4.02 *) (* debug section in pack module may be wrong *) (* containing no debug_info. *) (* In this case, evl in not a debug_info list but a *) (* string list (see read_paths) *) (* save the current position *) let pos = pos_in ic in let evl_is_valid = try ignore(read_paths ());true with Failure _ -> (* restore position *) seek_in ic pos; false in if evl_is_valid then List.iter (fun ev -> relocate_event orig ev; Hashtbl.add events_by_pc ev.ev_pos ev) evl done; events_by_pc let find events_by_pc pc = try let ev = Hashtbl.find events_by_pc pc in Ident.table_contents ev.ev_stacksize ev.ev_compenv.ce_stack with Not_found -> [] let mem = Hashtbl.mem let find_loc events_by_pc ?(after = false) pc = try let (before, ev) = try false, Hashtbl.find events_by_pc pc with Not_found -> true, try Hashtbl.find events_by_pc (pc + 1) with Not_found -> try Hashtbl.find events_by_pc (pc + 2) with Not_found -> Hashtbl.find events_by_pc (pc + 3) in let loc = ev.ev_loc in let pos = if after then loc.li_end else if before then loc.li_start else match ev.ev_kind with Event_after _ -> loc.li_end | _ -> loc.li_start in Some {Parse_info.name = pos.pos_fname; line=pos.pos_lnum - 1; col=pos.pos_cnum - pos.pos_bol; (* loc.li_end.pos_cnum - loc.li_end.pos_bol *) idx=0; fol=None} with Not_found -> None let rec propagate l1 l2 = match l1, l2 with v1 :: r1, v2 :: r2 -> Var.propagate_name v1 v2; propagate r1 r2 | _ -> () let iter events_by_pc f = Hashtbl.iter f events_by_pc let fold events_by_pc f acc = Hashtbl.fold f events_by_pc acc end (* Block analysis *) (* Detect each block *) module Blocks : sig type t val add : t -> int -> t val next : t -> int -> int val analyse : Debug.data -> code -> t end = struct type t = AddrSet.t * int let add (blocks,len) pc = AddrSet.add pc blocks,len let rec scan debug blocks code pc len = if pc < len then begin match (get_instr code pc).kind with KNullary -> scan debug blocks code (pc + 1) len | KUnary -> scan debug blocks code (pc + 2) len | KBinary -> scan debug blocks code (pc + 3) len | KNullaryCall -> let blocks = if Debug.mem debug (pc + 1) then AddrSet.add pc blocks else blocks in scan debug blocks code (pc + 1) len | KUnaryCall -> let blocks = if Debug.mem debug (pc + 2) then AddrSet.add pc blocks else blocks in scan debug blocks code (pc + 2) len | KBinaryCall -> let blocks = if Debug.mem debug (pc + 3) then AddrSet.add pc blocks else blocks in scan debug blocks code (pc + 3) len | KJump -> let offset = gets code (pc + 1) in let blocks = AddrSet.add (pc + offset + 1) blocks in scan debug blocks code (pc + 2) len | KCond_jump -> let offset = gets code (pc + 1) in let blocks = AddrSet.add (pc + offset + 1) blocks in scan debug blocks code (pc + 2) len | KCmp_jump -> let offset = gets code (pc + 2) in let blocks = AddrSet.add (pc + offset + 2) blocks in scan debug blocks code (pc + 3) len | KSwitch -> let sz = getu code (pc + 1) in let blocks = ref blocks in for i = 0 to sz land 0xffff + sz lsr 16 - 1 do let offset = gets code (pc + 2 + i) in blocks := AddrSet.add (pc + offset + 2) !blocks done; scan debug !blocks code (pc + 2 + sz land 0xffff + sz lsr 16) len | KClosurerec -> let nfuncs = getu code (pc + 1) in scan debug blocks code (pc + nfuncs + 3) len | KClosure -> scan debug blocks code (pc + 3) len | KStop n -> scan debug blocks code (pc + n + 1) len | K_will_not_happen -> assert false end else blocks let rec next ((blocks,len) as info) pc = let pc = pc + 1 in if pc = len || AddrSet.mem pc blocks then pc else next info pc let analyse debug_data code = let blocks = AddrSet.empty in let len = String.length code / 4 in (scan debug_data blocks code 0 len,len) end (* Parse constants *) module Constants : sig val parse : Obj.t -> Code.constant val inlined : Obj.t -> bool end = struct let same_custom x y = Obj.field x 0 == Obj.field (Obj.repr y) 0 let warn_overflow i i32 = Format.eprintf "Warning: integer overflow: integer 0x%s truncated to 0x%lx; \ the generated code might be incorrect.@." i i32 let rec parse x = if Obj.is_block x then begin let tag = Obj.tag x in if tag = Obj.string_tag then String (Obj.magic x : string) else if tag = Obj.double_tag then Float (Obj.magic x : float) else if tag = Obj.double_array_tag then Float_array (Obj.magic x : float array) else if tag = Obj.custom_tag && same_custom x 0l then Int (Obj.magic x : int32) else if tag = Obj.custom_tag && same_custom x 0n then let i : nativeint = Obj.magic x in let i32 = Nativeint.to_int32 i in let i' = Nativeint.of_int32 i32 in if i' <> i then warn_overflow (Printf.sprintf "%nx" i) i32; Int i32 else if tag = Obj.custom_tag && same_custom x 0L then Int64 (Obj.magic x : int64) else if tag < Obj.no_scan_tag then Tuple (tag, Array.init (Obj.size x) (fun i -> parse (Obj.field x i))) else assert false end else let i : int = Obj.magic x in let i32 = Int32.of_int i in let i' = Int32.to_int i32 in if i' <> i then warn_overflow (Printf.sprintf "%x" i) i32; Int i32 let inlined x = not (Obj.is_block x) || (let tag = Obj.tag x in (tag = Obj.double_tag) || (tag = Obj.custom_tag && (same_custom x 0l || same_custom x 0n))) end (* Globals *) type globals = { mutable vars : Var.t option array; mutable is_const : bool array; mutable is_exported : bool array; mutable override : (Var.t -> Code.instr list -> (Var.t * Code.instr list)) option array; constants : Obj.t array; primitives : string array } let make_globals size constants primitives = { vars = Array.make size None; is_const = Array.make size false; is_exported = Array.make size false; override = Array.make size None; constants = constants; primitives = primitives } let resize_array a len def = let b = Array.make len def in Array.blit a 0 b 0 (Array.length a); b let resize_globals g size = g.vars <- resize_array g.vars size None; g.is_const <- resize_array g.is_const size false; g.is_exported <- resize_array g.is_exported size true; g.override <- resize_array g.override size None (* State of the VM *) module State = struct type elt = Var of Var.t | Dummy let elt_to_var e = match e with Var x -> x | _ -> assert false let opt_elt_to_var e = match e with Var x -> Some x | _ -> None let print_elt f v = match v with | Var x -> Format.fprintf f "%a" Var.print x (* | Addr x -> Format.fprintf f "[%d]" x*) | Dummy -> Format.fprintf f "???" type t = { accu : elt; stack : elt list; env : elt array; env_offset : int; handlers : (Var.t * addr * int) list; globals : globals } let fresh_var state = let x = Var.fresh () in (x, {state with accu = Var x}) let globals st = st.globals let size_globals st size = if size > Array.length st.globals.vars then resize_globals st.globals size let rec list_start n l = if n = 0 then [] else match l with [] -> assert false | v :: r -> v :: list_start (n - 1) r let rec st_pop n st = if n = 0 then st else match st with [] -> assert false | v :: r -> st_pop (n - 1) r let push st = {st with stack = st.accu :: st.stack} let pop n st = {st with stack = st_pop n st.stack} let acc n st = {st with accu = List.nth st.stack n} let env_acc n st = {st with accu = st.env.(st.env_offset + n)} let has_accu st = st.accu <> Dummy let accu st = elt_to_var st.accu let opt_accu st = opt_elt_to_var st.accu let stack_vars st = List.fold_left (fun l e -> match e with Var x -> x :: l | Dummy -> l) [] (st.accu :: st.stack) let set_accu st x = {st with accu = Var x} let clear_accu st = {st with accu = Dummy} let peek n st = elt_to_var (List.nth st.stack n) let grab n st = (List.map elt_to_var (list_start n st.stack), pop n st) let rec st_assign s n x = match s with [] -> assert false | y :: rem -> if n = 0 then x :: rem else y :: st_assign rem (n - 1) x let assign st n = {st with stack = st_assign st.stack n st.accu } let start_function state env offset = {state with accu = Dummy; stack = []; env = env; env_offset = offset; handlers = []} let start_block state = let stack = List.fold_right (fun e stack -> match e with Dummy -> Dummy :: stack | Var x -> let y = Var.fresh () in Var.propagate_name x y; Var y :: stack) state.stack [] in let state = { state with stack = stack } in match state.accu with Dummy -> state | Var x -> let y,state = fresh_var state in Var.propagate_name x y; state let push_handler state x addr = { state with handlers = (x, addr, List.length state.stack) :: state.handlers } let pop_handler state = { state with handlers = List.tl state.handlers } let current_handler state = match state.handlers with [] -> None | (x, addr, len) :: _ -> let state = { state with accu = Var x; stack = st_pop (List.length state.stack - len) state.stack} in Some (x, (addr, stack_vars state)) let initial g = { accu = Dummy; stack = []; env = [||]; env_offset = 0; handlers = []; globals = g } let rec print_stack f l = match l with [] -> () | v :: r -> Format.fprintf f "%a %a" print_elt v print_stack r let print_env f e = Array.iteri (fun i v -> if i > 0 then Format.fprintf f " "; Format.fprintf f "%a" print_elt v) e let print st = Format.eprintf "{ %a | %a | (%d) %a }@." print_elt st.accu print_stack st.stack st.env_offset print_env st.env let rec name_rec i l s = match l, s with [], _ -> () | (j, nm) :: lrem, Var v :: srem when i = j -> Var.name v nm; name_rec (i + 1) lrem srem | (j, _) :: _, _ :: srem when i < j -> name_rec (i + 1) l srem | _ -> assert false let name_vars st l = name_rec 0 l st.stack let rec make_stack i state = if i = 0 then ([], state) else let (x, state) = fresh_var state in let (params, state) = make_stack (pred i) (push state) in if debug_parser () then if i > 1 then Format.printf ", "; if debug_parser () then Format.printf "%a" Var.print x; (x :: params, state) end let primitive_name state i = let g = State.globals state in assert (i >= 0 && i <= Array.length g.primitives); let prim = g.primitives.(i) in Primitive.add_external prim; prim let access_global g i = match g.vars.(i) with Some x -> x | None -> g.is_const.(i) <- true; let x = Var.fresh () in g.vars.(i) <- Some x; x let register_global ?(force=false) g i rem = if force || g.is_exported.(i) then Let (Var.fresh (), Prim (Extern "caml_register_global", [Pc (Int (Int32.of_int i)) ; Pv (access_global g i)])) :: rem else rem let get_global state instrs i = State.size_globals state (i + 1); let g = State.globals state in match g.vars.(i) with Some x -> if debug_parser () then Format.printf "(global access %a)@." Var.print x; (x, State.set_accu state x, instrs) | None -> if i < Array.length g.constants && Constants.inlined g.constants.(i) then begin let (x, state) = State.fresh_var state in (x, state, Let (x, Constant (Constants.parse g.constants.(i))) :: instrs) end else begin g.is_const.(i) <- true; let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = CONST(%d)@." Var.print x i; g.vars.(i) <- Some x; (x, state, instrs) end let tagged_blocks = ref AddrSet.empty let compiled_blocks = ref AddrMap.empty let method_cache_id = ref 1 type compile_info = { blocks : Blocks.t; code : string; limit : int; debug : Debug.data } let rec compile_block blocks debug code pc state = if not (AddrSet.mem pc !tagged_blocks) then begin let limit = Blocks.next blocks pc in if debug_parser () then Format.eprintf "Compiling from %d to %d@." pc (limit - 1); let state = State.start_block state in tagged_blocks := AddrSet.add pc !tagged_blocks; let (instr, last, state') = compile {blocks; code; limit; debug} pc state [] in compiled_blocks := AddrMap.add pc (state, List.rev instr, last) !compiled_blocks; begin match last with Branch (pc', _) | Poptrap (pc', _) -> compile_block blocks debug code pc' state' | Cond (_, _, (pc1, _), (pc2, _)) -> compile_block blocks debug code pc1 state'; compile_block blocks debug code pc2 state' | Switch (_, l1, l2) -> Array.iter (fun (pc', _) -> compile_block blocks debug code pc' state') l1; Array.iter (fun (pc', _) -> compile_block blocks debug code pc' state') l2 | Pushtrap _ | Raise _ | Return _ | Stop -> () end end and compile infos pc state instrs = if debug_parser () then State.print state; if pc = infos.limit then (instrs, Branch (pc, State.stack_vars state), state) else begin if debug_parser () then Format.eprintf "%4d " pc; State.name_vars state (Debug.find infos.debug pc); let code = infos.code in let instr = try get_instr code pc with Bad_instruction op -> if debug_parser () then Format.eprintf "%08x@." op; assert false in if debug_parser () then Format.eprintf "%08x %s@." instr.opcode instr.name; match instr.Instr.code with | ACC0 -> compile infos (pc + 1) (State.acc 0 state) instrs | ACC1 -> compile infos (pc + 1) (State.acc 1 state) instrs | ACC2 -> compile infos (pc + 1) (State.acc 2 state) instrs | ACC3 -> compile infos (pc + 1) (State.acc 3 state) instrs | ACC4 -> compile infos (pc + 1) (State.acc 4 state) instrs | ACC5 -> compile infos (pc + 1) (State.acc 5 state) instrs | ACC6 -> compile infos (pc + 1) (State.acc 6 state) instrs | ACC7 -> compile infos (pc + 1) (State.acc 7 state) instrs | ACC -> let n = getu code (pc + 1) in compile infos (pc + 2) (State.acc n state) instrs | PUSH -> compile infos (pc + 1) (State.push state) instrs | PUSHACC0 -> compile infos (pc + 1) (State.acc 0 (State.push state)) instrs | PUSHACC1 -> compile infos (pc + 1) (State.acc 1 (State.push state)) instrs | PUSHACC2 -> compile infos (pc + 1) (State.acc 2 (State.push state)) instrs | PUSHACC3 -> compile infos (pc + 1) (State.acc 3 (State.push state)) instrs | PUSHACC4 -> compile infos (pc + 1) (State.acc 4 (State.push state)) instrs | PUSHACC5 -> compile infos (pc + 1) (State.acc 5 (State.push state)) instrs | PUSHACC6 -> compile infos (pc + 1) (State.acc 6 (State.push state)) instrs | PUSHACC7 -> compile infos (pc + 1) (State.acc 7 (State.push state)) instrs | PUSHACC -> let n = getu code (pc + 1) in compile infos (pc + 2) (State.acc n (State.push state)) instrs | POP -> let n = getu code (pc + 1) in compile infos (pc + 2) (State.pop n state) instrs | ASSIGN -> let n = getu code (pc + 1) in let state = State.assign state n in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = 0@." Var.print x; (* We switch to a different block as this may have changed the exception handler continuation *) compile_block infos.blocks infos.debug code (pc + 2) state; (Let (x, Const 0l) :: instrs, Branch (pc + 2, State.stack_vars state), state) | ENVACC1 -> compile infos (pc + 1) (State.env_acc 1 state) instrs | ENVACC2 -> compile infos (pc + 1) (State.env_acc 2 state) instrs | ENVACC3 -> compile infos (pc + 1) (State.env_acc 3 state) instrs | ENVACC4 -> compile infos (pc + 1) (State.env_acc 4 state) instrs | ENVACC -> let n = getu code (pc + 1) in compile infos (pc + 2) (State.env_acc n state) instrs | PUSHENVACC1 -> compile infos (pc + 1) (State.env_acc 1 (State.push state)) instrs | PUSHENVACC2 -> compile infos (pc + 1) (State.env_acc 2 (State.push state)) instrs | PUSHENVACC3 -> compile infos (pc + 1) (State.env_acc 3 (State.push state)) instrs | PUSHENVACC4 -> compile infos (pc + 1) (State.env_acc 4 (State.push state)) instrs | PUSHENVACC -> let n = getu code (pc + 1) in compile infos (pc + 2) (State.env_acc n (State.push state)) instrs | PUSH_RETADDR -> compile infos (pc + 2) {state with State.stack = State.Dummy :: State.Dummy :: State.Dummy :: state.State.stack} instrs | APPLY -> let n = getu code (pc + 1) in let f = State.accu state in let (x, state) = State.fresh_var state in let (args, state) = State.grab n state in if debug_parser () then begin Format.printf "%a = %a(" Var.print x Var.print f; for i = 0 to n - 1 do if i > 0 then Format.printf ", "; Format.printf "%a" Var.print (List.nth args i) done; Format.printf ")@." end; compile infos (pc + 2) (State.pop 3 state) (Let (x, Apply (f, args, false)) :: instrs) | APPLY1 -> let f = State.accu state in let (x, state) = State.fresh_var state in let y = State.peek 0 state in if debug_parser () then Format.printf "%a = %a(%a)@." Var.print x Var.print f Var.print y; compile infos (pc + 1) (State.pop 1 state) (Let (x, Apply (f, [y], false)) :: instrs) | APPLY2 -> let f = State.accu state in let (x, state) = State.fresh_var state in let y = State.peek 0 state in let z = State.peek 1 state in if debug_parser () then Format.printf "%a = %a(%a, %a)@." Var.print x Var.print f Var.print y Var.print z; compile infos (pc + 1) (State.pop 2 state) (Let (x, Apply (f, [y; z], false)) :: instrs) | APPLY3 -> let f = State.accu state in let (x, state) = State.fresh_var state in let y = State.peek 0 state in let z = State.peek 1 state in let t = State.peek 2 state in if debug_parser () then Format.printf "%a = %a(%a, %a, %a)@." Var.print x Var.print f Var.print y Var.print z Var.print t; compile infos (pc + 1) (State.pop 3 state) (Let (x, Apply (f, [y; z; t], false)) :: instrs) | APPTERM -> let n = getu code (pc + 1) in let f = State.accu state in let (l, state) = State.grab n state in if debug_parser () then begin Format.printf "return %a(" Var.print f; for i = 0 to n - 1 do if i > 0 then Format.printf ", "; Format.printf "%a" Var.print (List.nth l i) done; Format.printf ")@." end; let (x, state) = State.fresh_var state in (Let (x, Apply (f, l, false)) :: instrs, Return x, state) | APPTERM1 -> let f = State.accu state in let x = State.peek 0 state in if debug_parser () then Format.printf "return %a(%a)@." Var.print f Var.print x; let (y, state) = State.fresh_var state in (Let (y, Apply (f, [x], false)) :: instrs, Return y, state) | APPTERM2 -> let f = State.accu state in let x = State.peek 0 state in let y = State.peek 1 state in if debug_parser () then Format.printf "return %a(%a, %a)@." Var.print f Var.print x Var.print y; let (z, state) = State.fresh_var state in (Let (z, Apply (f, [x; y], false)) :: instrs, Return z, state) | APPTERM3 -> let f = State.accu state in let x = State.peek 0 state in let y = State.peek 1 state in let z = State.peek 2 state in if debug_parser () then Format.printf "return %a(%a, %a, %a)@." Var.print f Var.print x Var.print y Var.print z; let (t, state) = State.fresh_var state in (Let (t, Apply (f, [x; y; z], false)) :: instrs, Return t, state) | RETURN -> let x = State.accu state in if debug_parser () then Format.printf "return %a@." Var.print x; (instrs, Return x, state) | RESTART -> assert false | GRAB -> compile infos (pc + 2) state instrs | CLOSURE -> let nvars = getu code (pc + 1) in let addr = pc + gets code (pc + 2) + 2 in let state = if nvars > 0 then State.push state else state in let (vals, state) = State.grab nvars state in let (x, state) = State.fresh_var state in let env = Array.of_list (State.Dummy :: List.map (fun x -> State.Var x) vals) in if debug_parser () then Format.printf "fun %a (" Var.print x; let nparams = match (get_instr code addr).Instr.code with GRAB -> getu code (addr + 1) + 1 | _ -> 1 in let state' = State.start_function state env 0 in let (params, state') = State.make_stack nparams state' in if debug_parser () then Format.printf ") {@."; let state' = State.clear_accu state' in compile_block infos.blocks infos.debug code addr state'; if debug_parser () then Format.printf "}@."; let args = State.stack_vars state' in let (state'', _, _) = AddrMap.find addr !compiled_blocks in Debug.propagate (State.stack_vars state'') args; compile infos (pc + 3) state (Let (x, Closure (List.rev params, (addr, args))) :: instrs) | CLOSUREREC -> let nfuncs = getu code (pc + 1) in let nvars = getu code (pc + 2) in let state = if nvars > 0 then (State.push state) else state in let (vals, state) = State.grab nvars state in let state = ref state in let vars = ref [] in for i = 0 to nfuncs - 1 do let (x, st) = State.fresh_var !state in vars := (i, x) :: !vars; state := State.push st done; let env = ref (List.map (fun x -> State.Var x) vals) in List.iter (fun (i, x) -> env := State.Var x :: !env; if i > 0 then env := State.Dummy :: !env) !vars; let env = Array.of_list !env in let state = !state in let instrs = List.fold_left (fun instr (i, x) -> let addr = pc + 3 + gets code (pc + 3 + i) in if debug_parser () then Format.printf "fun %a (" Var.print x; let nparams = match (get_instr code addr).Instr.code with GRAB -> getu code (addr + 1) + 1 | _ -> 1 in let state' = State.start_function state env (i * 2) in let (params, state') = State.make_stack nparams state' in if debug_parser () then Format.printf ") {@."; let state' = State.clear_accu state' in compile_block infos.blocks infos.debug code addr state'; if debug_parser () then Format.printf "}@."; let args = State.stack_vars state' in let (state'', _, _) = AddrMap.find addr !compiled_blocks in Debug.propagate (State.stack_vars state'') args; Let (x, Closure (List.rev params, (addr, args))) :: instr) instrs (List.rev !vars) in compile infos (pc + 3 + nfuncs) (State.acc (nfuncs - 1) state) instrs | OFFSETCLOSUREM2 -> compile infos (pc + 1) (State.env_acc (-2) state) instrs | OFFSETCLOSURE0 -> compile infos (pc + 1) (State.env_acc 0 state) instrs | OFFSETCLOSURE2 -> compile infos (pc + 1) (State.env_acc 2 state) instrs | OFFSETCLOSURE -> let n = gets code (pc + 1) in compile infos (pc + 2) (State.env_acc n state) instrs | PUSHOFFSETCLOSUREM2 -> let state = State.push state in compile infos (pc + 1) (State.env_acc (-2) state) instrs | PUSHOFFSETCLOSURE0 -> let state = State.push state in compile infos (pc + 1) (State.env_acc 0 state) instrs | PUSHOFFSETCLOSURE2 -> let state = State.push state in compile infos (pc + 1) (State.env_acc 2 state) instrs | PUSHOFFSETCLOSURE -> let state = State.push state in let n = gets code (pc + 1) in compile infos (pc + 2) (State.env_acc n state) instrs | GETGLOBAL -> let i = getu code (pc + 1) in let (_, state, instrs) = get_global state instrs i in compile infos (pc + 2) state instrs | PUSHGETGLOBAL -> let state = State.push state in let i = getu code (pc + 1) in let (_, state, instrs) = get_global state instrs i in compile infos (pc + 2) state instrs | GETGLOBALFIELD -> let i = getu code (pc + 1) in let (x, state, instrs) = get_global state instrs i in let j = getu code (pc + 2) in let (y, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a[%d]@." Var.print y Var.print x j; compile infos (pc + 3) state (Let (y, Field (x, j)) :: instrs) | PUSHGETGLOBALFIELD -> let state = State.push state in let i = getu code (pc + 1) in let (x, state, instrs) = get_global state instrs i in let j = getu code (pc + 2) in let (y, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a[%d]@." Var.print y Var.print x j; compile infos (pc + 3) state (Let (y, Field (x, j)) :: instrs) | SETGLOBAL -> let i = getu code (pc + 1) in State.size_globals state (i + 1); let y = State.accu state in let g = State.globals state in assert (g.vars.(i) = None); if debug_parser () then Format.printf "(global %d) = %a@." i Var.print y; let instrs = match g.override.(i) with | Some f -> let v,instrs = f y instrs in g.vars.(i) <- Some v; instrs | None -> g.vars.(i) <- Some y; instrs in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = 0@." Var.print x; let instrs = register_global g i instrs in compile infos (pc + 2) state (Let (x, Const 0l) :: instrs) | ATOM0 -> let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = ATOM(0)@." Var.print x; compile infos (pc + 1) state (Let (x, Block (0, [||])) :: instrs) | ATOM -> let i = getu code (pc + 1) in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = ATOM(%d)@." Var.print x i; compile infos (pc + 2) state (Let (x, Block (i, [||])) :: instrs) | PUSHATOM0 -> let state = State.push state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = ATOM(0)@." Var.print x; compile infos (pc + 1) state (Let (x, Block (0, [||])) :: instrs) | PUSHATOM -> let state = State.push state in let i = getu code (pc + 1) in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = ATOM(%d)@." Var.print x i; compile infos (pc + 2) state (Let (x, Block (i, [||])) :: instrs) | MAKEBLOCK -> let size = getu code (pc + 1) in let tag = getu code (pc + 2) in let state = State.push state in let (x, state) = State.fresh_var state in let (contents, state) = State.grab size state in if debug_parser () then begin Format.printf "%a = { " Var.print x; for i = 0 to size - 1 do Format.printf "%d = %a; " i Var.print (List.nth contents i); done; Format.printf "}@." end; compile infos (pc + 3) state (Let (x, Block (tag, Array.of_list contents)) :: instrs) | MAKEBLOCK1 -> let tag = getu code (pc + 1) in let y = State.accu state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = { 0 = %a; }@." Var.print x Var.print y; compile infos (pc + 2) state (Let (x, Block (tag, [|y|])) :: instrs) | MAKEBLOCK2 -> let tag = getu code (pc + 1) in let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = { 0 = %a; 1 = %a; }@." Var.print x Var.print y Var.print z; compile infos (pc + 2) (State.pop 1 state) (Let (x, Block (tag, [|y; z|])) :: instrs) | MAKEBLOCK3 -> let tag = getu code (pc + 1) in let y = State.accu state in let z = State.peek 0 state in let t = State.peek 1 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = { 0 = %a; 1 = %a; 2 = %a }@." Var.print x Var.print y Var.print z Var.print t; compile infos (pc + 2) (State.pop 2 state) (Let (x, Block (tag, [|y; z; t|])) :: instrs) | MAKEFLOATBLOCK -> let size = getu code (pc + 1) in let state = State.push state in let (x, state) = State.fresh_var state in let (contents, state) = State.grab size state in if debug_parser () then begin Format.printf "%a = { " Var.print x; for i = 0 to size - 1 do Format.printf "%d = %a; " i Var.print (List.nth contents i); done; Format.printf "}@." end; compile infos (pc + 2) state (Let (x, Block (254, Array.of_list contents)) :: instrs) | GETFIELD0 -> let y = State.accu state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a[0]@." Var.print x Var.print y; compile infos (pc + 1) state (Let (x, Field (y, 0)) :: instrs) | GETFIELD1 -> let y = State.accu state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a[1]@." Var.print x Var.print y; compile infos (pc + 1) state (Let (x, Field (y, 1)) :: instrs) | GETFIELD2 -> let y = State.accu state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a[2]@." Var.print x Var.print y; compile infos (pc + 1) state (Let (x, Field (y, 2)) :: instrs) | GETFIELD3 -> let y = State.accu state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a[3]@." Var.print x Var.print y; compile infos (pc + 1) state (Let (x, Field (y, 3)) :: instrs) | GETFIELD -> let y = State.accu state in let n = getu code (pc + 1) in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a[%d]@." Var.print x Var.print y n; compile infos (pc + 2) state (Let (x, Field (y, n)) :: instrs) | GETFLOATFIELD -> let y = State.accu state in let n = getu code (pc + 1) in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a[%d]@." Var.print x Var.print y n; compile infos (pc + 2) state (Let (x, Field (y, n)) :: instrs) | SETFIELD0 -> let y = State.accu state in let z = State.peek 0 state in if debug_parser () then Format.printf "%a[0] = %a@." Var.print y Var.print z; let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = 0@." Var.print x; compile infos (pc + 1) (State.pop 1 state) (Let (x, Const 0l) :: Set_field (y, 0, z) :: instrs) | SETFIELD1 -> let y = State.accu state in let z = State.peek 0 state in if debug_parser () then Format.printf "%a[1] = %a@." Var.print y Var.print z; let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = 0@." Var.print x; compile infos (pc + 1) (State.pop 1 state) (Let (x, Const 0l) :: Set_field (y, 1, z) :: instrs) | SETFIELD2 -> let y = State.accu state in let z = State.peek 0 state in if debug_parser () then Format.printf "%a[2] = %a@." Var.print y Var.print z; let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = 0@." Var.print x; compile infos (pc + 1) (State.pop 1 state) (Let (x, Const 0l) :: Set_field (y, 2, z) :: instrs) | SETFIELD3 -> let y = State.accu state in let z = State.peek 0 state in if debug_parser () then Format.printf "%a[3] = %a@." Var.print y Var.print z; let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = 0@." Var.print x; compile infos (pc + 1) (State.pop 1 state) (Let (x, Const 0l) :: Set_field (y, 3, z) :: instrs) | SETFIELD -> let y = State.accu state in let z = State.peek 0 state in let n = getu code (pc + 1) in if debug_parser () then Format.printf "%a[%d] = %a@." Var.print y n Var.print z; let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = 0@." Var.print x; compile infos (pc + 2) (State.pop 1 state) (Let (x, Const 0l) :: Set_field (y, n, z) :: instrs) | SETFLOATFIELD -> let y = State.accu state in let z = State.peek 0 state in let n = getu code (pc + 1) in if debug_parser () then Format.printf "%a[%d] = %a@." Var.print y n Var.print z; let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = 0@." Var.print x; compile infos (pc + 2) (State.pop 1 state) (Let (x, Const 0l) :: Set_field (y, n, z) :: instrs) | VECTLENGTH -> let y = State.accu state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a.length@." Var.print x Var.print y; compile infos (pc + 1) state (Let (x, Prim (Vectlength, [Pv y])) :: instrs) | GETVECTITEM -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a[%a]@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Array_get, [Pv y; Pv z])) :: instrs) | SETVECTITEM -> if debug_parser () then Format.printf "%a[%a] = %a@." Var.print (State.accu state) Var.print (State.peek 0 state) Var.print (State.peek 1 state); let instrs = Array_set (State.accu state, State.peek 0 state, State.peek 1 state) :: instrs in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = 0@." Var.print x; compile infos (pc + 1) (State.pop 2 state) (Let (x, Const 0l) :: instrs) | GETSTRINGCHAR -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a[%a]@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Extern "caml_string_unsafe_get", [Pv y; Pv z])) :: instrs) | SETSTRINGCHAR -> if debug_parser () then Format.printf "%a[%a] = %a@." Var.print (State.accu state) Var.print (State.peek 0 state) Var.print (State.peek 1 state); let x = State.accu state in let y = State.peek 0 state in let z = State.peek 1 state in let (t, state) = State.fresh_var state in let instrs = Let (t, Prim (Extern "caml_string_unsafe_set", [Pv x; Pv y; Pv z])) :: instrs in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = 0@." Var.print x; compile infos (pc + 1) (State.pop 2 state) (Let (x, Const 0l) :: instrs) | BRANCH -> let offset = gets code (pc + 1) in if debug_parser () then Format.printf "... (branch)@."; (instrs, Branch (pc + offset + 1, State.stack_vars state), state) | BRANCHIF -> let offset = gets code (pc + 1) in let x = State.accu state in let args = State.stack_vars state in (instrs, Cond (IsTrue, x, (pc + offset + 1, args), (pc + 2, args)), state) | BRANCHIFNOT -> let offset = gets code (pc + 1) in let x = State.accu state in let args = State.stack_vars state in (instrs, Cond (IsTrue, x, (pc + 2, args), (pc + offset + 1, args)), state) | SWITCH -> if debug_parser () then Format.printf "switch ...@."; let sz = getu code (pc + 1) in let x = State.accu state in let args = State.stack_vars state in let l = sz land 0xFFFF in let it = Array.init (sz land 0XFFFF) (fun i -> (pc + 2 + gets code (pc + 2 + i), args)) in let bt = Array.init (sz lsr 16) (fun i -> (pc + 2 + gets code (pc + 2 + l + i), args)) in (instrs, Switch (x, it, bt), state) | BOOLNOT -> let y = State.accu state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = !%a@." Var.print x Var.print y; compile infos (pc + 1) state (Let (x, Prim (Not, [Pv y])) :: instrs) | PUSHTRAP -> let addr = pc + 1 + gets code (pc + 1) in let (x, state') = State.fresh_var state in compile_block infos.blocks infos.debug code addr state'; compile_block infos.blocks infos.debug code (pc + 2) {(State.push_handler state x addr) with State.stack = State.Dummy :: State.Dummy :: State.Dummy :: State.Dummy :: state.State.stack}; (instrs, Pushtrap ((pc + 2, State.stack_vars state), x, (addr, State.stack_vars state'), -1), state) | POPTRAP -> compile_block infos.blocks infos.debug code (pc + 1) (State.pop 4 (State.pop_handler state)); (instrs, Poptrap (pc + 1, State.stack_vars state), state) | RERAISE | RAISE_NOTRACE | RAISE -> if debug_parser () then Format.printf "throw(%a)@." Var.print (State.accu state); (instrs, Raise (State.accu state), state) | CHECK_SIGNALS -> compile infos (pc + 1) state instrs | C_CALL1 -> let prim = primitive_name state (getu code (pc + 1)) in if Primitive.resolve prim = "%identity" then (* This is a no-op *) compile infos (pc + 2) state instrs else begin let y = State.accu state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = ccall \"%s\" (%a)@." Var.print x prim Var.print y; compile infos (pc + 2) state (Let (x, Prim (Extern prim, [Pv y])) :: instrs) end | C_CALL2 -> let prim = primitive_name state (getu code (pc + 1)) in let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = ccall \"%s\" (%a, %a)@." Var.print x prim Var.print y Var.print z; compile infos (pc + 2) (State.pop 1 state) (Let (x, Prim (Extern prim, [Pv y; Pv z])) :: instrs) | C_CALL3 -> let prim = primitive_name state (getu code (pc + 1)) in let y = State.accu state in let z = State.peek 0 state in let t = State.peek 1 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = ccall \"%s\" (%a, %a, %a)@." Var.print x prim Var.print y Var.print z Var.print t; compile infos (pc + 2) (State.pop 2 state) (Let (x, Prim (Extern prim, [Pv y; Pv z; Pv t])) :: instrs) | C_CALL4 -> let nargs = 4 in let prim = primitive_name state (getu code (pc + 1)) in let state = State.push state in let (x, state) = State.fresh_var state in let (args, state) = State.grab nargs state in if debug_parser () then begin Format.printf "%a = ccal \"%s\" (" Var.print x prim; for i = 0 to nargs - 1 do if i > 0 then Format.printf ", "; Format.printf "%a" Var.print (List.nth args i); done; Format.printf ")@." end; compile infos (pc + 2) state (Let (x, Prim (Extern prim, List.map (fun x -> Pv x) args)) :: instrs) | C_CALL5 -> let nargs = 5 in let prim = primitive_name state (getu code (pc + 1)) in let state = State.push state in let (x, state) = State.fresh_var state in let (args, state) = State.grab nargs state in if debug_parser () then begin Format.printf "%a = ccal \"%s\" (" Var.print x prim; for i = 0 to nargs - 1 do if i > 0 then Format.printf ", "; Format.printf "%a" Var.print (List.nth args i); done; Format.printf ")@." end; compile infos (pc + 2) state (Let (x, Prim (Extern prim, List.map (fun x -> Pv x) args)) :: instrs) | C_CALLN -> let nargs = getu code (pc + 1) in let prim = primitive_name state (getu code (pc + 2)) in let state = State.push state in let (x, state) = State.fresh_var state in let (args, state) = State.grab nargs state in if debug_parser () then begin Format.printf "%a = ccal \"%s\" (" Var.print x prim; for i = 0 to nargs - 1 do if i > 0 then Format.printf ", "; Format.printf "%a" Var.print (List.nth args i); done; Format.printf ")@." end; compile infos (pc + 3) state (Let (x, Prim (Extern prim, List.map (fun x -> Pv x) args)) :: instrs) | ( CONST0 | CONST1 | CONST2 | CONST3 ) as cc -> let (x, state) = State.fresh_var state in let n = match cc with | CONST0 -> 0l | CONST1 -> 1l | CONST2 -> 2l | CONST3 -> 3l | _ -> assert false in if debug_parser () then Format.printf "%a = %ld@." Var.print x n; compile infos (pc + 1) state (Let (x, Const n) :: instrs) | CONSTINT -> let n = gets32 code (pc + 1) in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %ld@." Var.print x n; compile infos (pc + 2) state (Let (x, Const n) :: instrs) | ( PUSHCONST0 | PUSHCONST1 | PUSHCONST2 | PUSHCONST3 ) as cc -> let state = State.push state in let (x, state) = State.fresh_var state in let n = match cc with | PUSHCONST0 -> 0l | PUSHCONST1 -> 1l | PUSHCONST2 -> 2l | PUSHCONST3 -> 3l | _ -> assert false in if debug_parser () then Format.printf "%a = %ld@." Var.print x n; compile infos (pc + 1) state (Let (x, Const n) :: instrs) | PUSHCONSTINT -> let state = State.push state in let n = gets32 code (pc + 1) in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %ld@." Var.print x n; compile infos (pc + 2) state (Let (x, Const n) :: instrs) | NEGINT -> let y = State.accu state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = -%a@." Var.print x Var.print y; compile infos (pc + 1) state (Let (x, Prim (Extern "%int_neg", [Pv y])) :: instrs) | ADDINT -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a + %a@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Extern "%int_add", [Pv y; Pv z])) :: instrs) | SUBINT -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a - %a@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Extern "%int_sub", [Pv y; Pv z])) :: instrs) | MULINT -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a * %a@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Extern "%int_mul", [Pv y; Pv z])) :: instrs) | DIVINT -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a / %a@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Extern "%int_div", [Pv y; Pv z])) :: instrs) | MODINT -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a %% %a@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Extern "%int_mod", [Pv y; Pv z])) :: instrs) | ANDINT -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a & %a@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Extern "%int_and", [Pv y; Pv z])) :: instrs) | ORINT -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a | %a@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Extern "%int_or", [Pv y; Pv z])) :: instrs) | XORINT -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a ^ %a@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Extern "%int_xor", [Pv y; Pv z])) :: instrs) | LSLINT -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a << %a@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Extern "%int_lsl", [Pv y; Pv z])) :: instrs) | LSRINT -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a >>> %a@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Extern "%int_lsr", [Pv y; Pv z])) :: instrs) | ASRINT -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a >> %a@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Extern "%int_asr", [Pv y; Pv z])) :: instrs) | EQ -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = mk_bool(%a == %a)@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Eq, [Pv y; Pv z])) :: instrs) | NEQ -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = mk_bool(%a != %a)@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Neq, [Pv y; Pv z])) :: instrs) | LTINT -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = mk_bool(%a < %a)@." Var.print x Var.print y Var.print (State.peek 0 state); compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Lt, [Pv y; Pv z])) :: instrs) | LEINT -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = mk_bool(%a <= %a)@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Le, [Pv y; Pv z])) :: instrs) | GTINT -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = mk_bool(%a > %a)@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Lt, [Pv z; Pv y])) :: instrs) | GEINT -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = mk_bool(%a >= %a)@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Le, [Pv z; Pv y])) :: instrs) | OFFSETINT -> let n = gets32 code (pc + 1) in let y = State.accu state in let (z, state) = State.fresh_var state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %a + %ld@." Var.print x Var.print y n; compile infos (pc + 2) state (Let (x, Prim (Extern "%int_add", [Pv y; Pv z])) :: Let (z, Const n) :: instrs) | OFFSETREF -> let n = gets code (pc + 1) in let x = State.accu state in if debug_parser () then Format.printf "%a += %d@." Var.print x n; let instrs = Offset_ref (x, n) :: instrs in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "x = 0@."; compile infos (pc + 2) state (Let (x, Const 0l) :: instrs) | ISINT -> let y = State.accu state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = !%a@." Var.print x Var.print y; compile infos (pc + 1) state (Let (x, Prim (IsInt, [Pv y])) :: instrs) | BEQ -> let n = gets32 code (pc + 1) in let offset = gets code (pc + 2) in let x = State.accu state in let args = State.stack_vars state in (instrs, Cond (CEq n, x, (pc + offset + 2, args), (pc + 3, args)), state) | BNEQ -> let n = gets32 code (pc + 1) in let offset = gets code (pc + 2) in let x = State.accu state in let args = State.stack_vars state in (instrs, Cond (CEq n, x, (pc + 3, args), (pc + offset + 2, args)), state) | BLTINT -> let n = gets32 code (pc + 1) in let offset = gets code (pc + 2) in let x = State.accu state in let args = State.stack_vars state in (instrs, Cond (CLt n, x, (pc + offset + 2, args), (pc + 3, args)), state) | BLEINT -> let n = gets32 code (pc + 1) in let offset = gets code (pc + 2) in let x = State.accu state in let args = State.stack_vars state in (instrs, Cond (CLe n, x, (pc + offset + 2, args), (pc + 3, args)), state) | BGTINT -> let n = gets32 code (pc + 1) in let offset = gets code (pc + 2) in let x = State.accu state in let args = State.stack_vars state in (instrs, Cond (CLe n, x, (pc + 3, args), (pc + offset + 2, args)), state) | BGEINT -> let n = gets32 code (pc + 1) in let offset = gets code (pc + 2) in let x = State.accu state in let args = State.stack_vars state in (instrs, Cond (CLt n, x, (pc + 3, args), (pc + offset + 2, args)), state) | BULTINT -> let n = getu32 code (pc + 1) in let offset = gets code (pc + 2) in let x = State.accu state in let args = State.stack_vars state in (instrs, Cond (CUlt n, x, (pc + offset + 2, args), (pc + 3, args)), state) | BUGEINT -> let n = getu32 code (pc + 1) in let offset = gets code (pc + 2) in let x = State.accu state in let args = State.stack_vars state in (instrs, Cond (CUlt n, x, (pc + 3, args), (pc + offset + 2, args)), state) | ULTINT -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = mk_bool(%a <= %a) (unsigned)@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Ult, [Pv y; Pv z])) :: instrs) | UGEINT -> let y = State.accu state in let z = State.peek 0 state in let (x, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = mk_bool(%a >= %a)@." Var.print x Var.print y Var.print z; compile infos (pc + 1) (State.pop 1 state) (Let (x, Prim (Ult, [Pv z; Pv y])) :: instrs) | GETPUBMET -> let n = gets32 code (pc + 1) in let cache = !method_cache_id in incr method_cache_id; let obj = State.accu state in let state = State.push state in let (tag, state) = State.fresh_var state in let (m, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = %ld@." Var.print tag n; if debug_parser () then Format.printf "%a = caml_get_public_method(%a, %a)@." Var.print m Var.print obj Var.print tag; compile infos (pc + 3) state (Let (m, Prim (Extern "caml_get_public_method", [Pv obj; Pv tag; Pc (Int (Int32.of_int cache))])) :: Let (tag, Const n) :: instrs) | GETDYNMET -> let tag = State.accu state in let obj = State.peek 0 state in let (m, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = caml_get_public_method(%a, %a)@." Var.print m Var.print obj Var.print tag; compile infos (pc + 1) state (Let (m, Prim (Extern "caml_get_public_method", [Pv obj; Pv tag; Pc (Int 0l)])) :: instrs) | GETMETHOD -> let lab = State.accu state in let obj = State.peek 0 state in let (meths, state) = State.fresh_var state in let (m, state) = State.fresh_var state in if debug_parser () then Format.printf "%a = lookup(%a, %a)@." Var.print m Var.print obj Var.print lab; compile infos (pc + 1) state (Let (m, Prim (Array_get, [Pv meths; Pv lab])) :: Let (meths, Field (obj, 0)) :: instrs) | STOP -> (instrs, Stop, state) | EVENT | BREAK | FIRST_UNIMPLEMENTED_OP -> assert false end (****) let merge_path p1 p2 = match p1, p2 with [], _ -> p2 | _, [] -> p1 | _ -> assert (p1 = p2); p1 let (>>) x f = f x let fold_children blocks pc f accu = let block = AddrMap.find pc blocks in match block.branch with Return _ | Raise _ | Stop -> accu | Branch (pc', _) | Poptrap (pc', _) -> f pc' accu | Cond (_, _, (pc1, _), (pc2, _)) | Pushtrap ((pc1, _), _, (pc2, _), _) -> f pc1 accu >> f pc1 >> f pc2 | Switch (_, a1, a2) -> accu >> Array.fold_right (fun (pc, _) accu -> f pc accu) a1 >> Array.fold_right (fun (pc, _) accu -> f pc accu) a2 let rec traverse blocks pc visited blocks' = if not (AddrSet.mem pc visited) then begin let visited = AddrSet.add pc visited in let (visited, blocks', path) = fold_children blocks pc (fun pc (visited, blocks', path) -> let (visited, blocks', path') = traverse blocks pc visited blocks' in (visited, blocks', merge_path path path')) (visited, blocks', []) in let block = AddrMap.find pc blocks in let (blocks', path) = (* Note that there is no matching poptrap when an exception is always raised in the [try ... with ...] body. *) match block.branch, path with Pushtrap (cont1, x, cont2, _), pc3 :: rem -> (AddrMap.add pc { block with branch = Pushtrap (cont1, x, cont2, pc3) } blocks', rem) | Poptrap (pc, _), _ -> (blocks', pc :: path) | _ -> (blocks', path) in (visited, blocks', path) end else (visited, blocks', []) let match_exn_traps ((_, blocks, _) as p) = fold_closures p (fun _ _ (pc, _) blocks' -> let (_, blocks', path) = traverse blocks pc AddrSet.empty blocks' in assert (path = []); blocks') blocks (****) let parse_bytecode ?(debug=`No) code globals debug_data = let state = State.initial globals in Code.Var.reset (); let blocks = Blocks.analyse (if debug = `Full then debug_data else Debug.no_data ()) code in let blocks = if debug = `Full then Debug.fold debug_data (fun pc _ blocks -> Blocks.add blocks pc) blocks else blocks in compile_block blocks debug_data code 0 state; let blocks = AddrMap.mapi (fun pc (state, instr, last) -> { params = State.stack_vars state; handler = State.current_handler state; body = instr; branch = last }) !compiled_blocks in compiled_blocks := AddrMap.empty; tagged_blocks := AddrSet.empty; let free_pc = String.length code / 4 in let blocks = match_exn_traps (0, blocks, free_pc) in (0, blocks, free_pc) (* HACK 1 - fix bytecode *) let orig_code_bytes = [`I PUSHCONSTINT; `C 31; `I PUSHCONST1; `I LSLINT; `I BNEQ; `C 0; `C 5; (* overwrite from here *) `I CONSTINT; `C 30; `I BRANCH; `C 3; `I CONSTINT; `C 62; `I PUSHCONST1; `I LSLINT ] let fixed_code_bytes = [`I CONSTINT; `C 31; `I BRANCH; `C 6; `I PUSHCONST1] let orig_code = lazy (Instr.compile_to_string orig_code_bytes) let fixed_code = lazy (Instr.compile_to_string fixed_code_bytes) let fix_min_max_int code = begin try let i = Util.find (Lazy.force orig_code) code in String.blit (Lazy.force fixed_code) 0 code (i + 16) (String.length (Lazy.force fixed_code)) with Not_found -> Format.eprintf "Warning: could not fix min_int/max_int definition \ (bytecode not found).@." end (* HACK 2 - override module *) let override_global = let jsmodule name func = Prim(Extern "%overrideMod",[Pc (String name);Pc (String func)]) in [ "CamlinternalMod",(fun orig instrs -> let x = Var.fresh () in Var.name x "internalMod"; let init_mod = Var.fresh () in let update_mod = Var.fresh () in x, Let(x,Block(0,[| init_mod; update_mod |])):: Let(init_mod,jsmodule "CamlinternalMod" "init_mod"):: Let(update_mod,jsmodule "CamlinternalMod" "update_mod"):: instrs) ] (* HACK 3 - really input string *) let really_input_string ic size = let b = Bytes.create size in really_input ic b 0 size; Bytes.unsafe_to_string b let really_input_string = (* the one above or the one in Pervasives *) let open Pervasives in really_input_string (* HACK END *) let seek_section toc ic name = let rec seek_sec curr_ofs = function [] -> raise Not_found | (n, len) :: rem -> if n = name then begin seek_in ic (curr_ofs - len); len end else seek_sec (curr_ofs - len) rem in seek_sec (in_channel_length ic - 16 - 8 * List.length toc) toc let read_toc ic = let pos_trailer = in_channel_length ic - 16 in seek_in ic pos_trailer; let num_sections = input_binary_int ic in let header = really_input_string ic Util.MagicNumber.size in Util.MagicNumber.assert_current header; seek_in ic (pos_trailer - 8 * num_sections); let section_table = ref [] in for i = 1 to num_sections do let name = really_input_string ic 4 in let len = input_binary_int ic in section_table := (name, len) :: !section_table done; !section_table let from_channel ?(toplevel=false) ?(debug=`No) ic = let toc = read_toc ic in let prim_size = seek_section toc ic "PRIM" in let prim = really_input_string ic prim_size in let primitive_table = Array.of_list(Util.split_char '\000' prim) in let code_size = seek_section toc ic "CODE" in let code = match Util.Version.v with | `V3 -> let code = Bytes.create code_size in really_input ic code 0 code_size; (* We fix the bytecode to replace max_int/min_int *) fix_min_max_int code; Bytes.to_string code | `V4_02 -> really_input_string ic code_size in ignore(seek_section toc ic "DATA"); let init_data = (input_value ic : Obj.t array) in ignore(seek_section toc ic "SYMB"); let symbols = (input_value ic : Ident.t numtable) in ignore(seek_section toc ic "CRCS"); let crcs = (input_value ic : Obj.t) in let debug_data = if debug = `No then Debug.no_data () else try ignore(seek_section toc ic "DBUG"); Debug.read ic with Not_found -> Debug.no_data () in let globals = make_globals (Array.length init_data) init_data primitive_table in (* Initialize module override mechanism *) List.iter (fun (name, v) -> try let nn = { Ident.stamp= 0; name; flags= 0 } in let i = Tbl.find (fun x1 x2 -> String.compare x1.Ident.name x2.Ident.name) nn symbols.num_tbl in globals.override.(i) <- Some v; if debug_parser () then Format.eprintf "overriding global %s@." name with Not_found -> () ) override_global; if toplevel then begin (* export globals *) Tbl.iter (fun _ n -> globals.is_exported.(n) <- true) symbols.num_tbl; (* @vouillon: *) (* we should then use the -linkall option to build the toplevel. *) (* The OCaml compiler can generate code using this primitive but *) (* does not use it itself. This is the only primitive in this case. *) (* Ideally, Js_of_ocaml should parse the .mli files for primitives as *) (* well as marking this primitive as potentially used. But *) (* the -linkall option is probably good enough. *) (* Primitive.mark_used "caml_string_greaterthan" *) end; let p = parse_bytecode ~debug code globals debug_data in (* register predefined exception *) let body = ref [] in for i = 0 to 11 do (* see ocaml/byterun/fail.h *) body := register_global ~force:true globals i !body; globals.is_exported.(i) <- false; done; let body = Util.array_fold_right_i (fun i c l -> match globals.vars.(i) with Some x when globals.is_const.(i) -> let l = register_global globals i l in Let (x, Constant (Constants.parse globals.constants.(i))) :: l | _ -> l) globals.constants !body in let body = if toplevel then begin (* Include linking information *) let toc = [ ("SYMB", Obj.repr symbols); ("CRCS", crcs); ("PRIM", Obj.repr prim) ] in let gdata = Var.fresh () in let infos = [ "toc",(Constants.parse (Obj.repr toc)); "prim_count",(Int (Int32.of_int (Array.length globals.primitives)))] in let body = List.fold_left (fun rem (name,const) -> let c = Var.fresh () in Let (c, Constant const) :: Let (Var.fresh (), Prim (Extern "caml_js_set", [Pv gdata; Pc (String name); Pv c])) :: rem) body infos in Let (gdata, Prim (Extern "caml_get_global_data", [])) :: body end else body in (* List interface files *) let cmis = if toplevel && Option.Optim.include_cmis () then Tbl.fold (fun id _num acc -> if id.Ident.flags = 1 then Util.StringSet.add id.Ident.name acc else acc) symbols.num_tbl Util.StringSet.empty else Util.StringSet.empty in prepend p body, cmis, debug_data (* As input: list of primitives + size of global table *) let from_bytes primitives (code : code) = let globals = make_globals 0 [||] primitives in let debug_data = Debug.no_data () in let p = parse_bytecode code globals debug_data in let gdata = Var.fresh () in let body = Util.array_fold_right_i (fun i var l -> match var with | Some x when globals.is_const.(i) -> Let (x, Field (gdata, i)) :: l | _ -> l) globals.vars [] in let body = Let (gdata, Prim (Extern "caml_get_global_data", [])) :: body in prepend p body, debug_data let from_string primitives (code : string) = from_bytes primitives code js_of_ocaml-2.5/compiler/parse_bytecode.mli000066400000000000000000000023541241254034500211440ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) module Debug : sig type data val no_data : unit -> data val find_loc : data -> ?after:bool -> int -> Parse_info.t option end val from_channel : ?toplevel:bool -> ?debug:[`Full | `Names | `No] -> in_channel -> Code.program * Util.StringSet.t * Debug.data val from_string : string array -> string -> Code.program * Debug.data js_of_ocaml-2.5/compiler/parse_info.ml000066400000000000000000000065221241254034500201310ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t = { name : string; col : int; line : int; idx : int; fol : bool option; } let zero = { name = ""; col = 0; line = 0; idx = 0; fol = None } module Line_info = struct type t = { mutable acc_pos : int; mutable acc_line : int; lines : int array; name : string; } let rec compute lines acc line pos = if line >= Array.length lines then if pos = 0 then acc, line,0 else assert false else if lines.(line) >= pos then acc, line, pos else compute lines (acc + lines.(line) + 1) (succ line) (pos - lines.(line) - 1) let get t pos = let acc,line,pos = if t.acc_pos <= pos then compute t.lines t.acc_pos t.acc_line (pos - t.acc_pos) else compute t.lines 0 0 pos in t.acc_pos <- acc; t.acc_line <- line; line,pos let from_file file = let ic = open_in file in let lines = ref [] in (try while true do lines:=String.length (input_line ic) :: !lines done with End_of_file -> ()); let lines = Array.of_list (List.rev !lines) in let t = { acc_pos = 0; acc_line = 0; lines; name=file; } in close_in ic; t let from_string str = let pos = ref 0 and lines = ref [] in (try while true do let idx = String.index_from str !pos '\n' in lines:=(idx - !pos)::!lines; pos:=idx+1; done with Not_found -> lines:= (String.length str - !pos) :: !lines); let lines = Array.of_list (List.rev !lines) in { acc_pos = 0; acc_line = 0; lines; name=""} let from_channel ic = let buf = Buffer.create 1024 in let lines = ref [] in (try while true do let l = input_line ic in Buffer.add_string buf l; Buffer.add_char buf '\n'; lines:=String.length l :: !lines done with End_of_file -> ()); let lines = Array.of_list (List.rev !lines) in let t = { acc_pos = 0; acc_line = 0; lines; name=""; } in t,Buffer.contents buf end type lineinfo = Line_info.t let make_lineinfo_from_file file = Line_info.from_file file let make_lineinfo_from_string str = Line_info.from_string str let make_lineinfo_from_channel c = Line_info.from_channel c let t_of_lexbuf line_info lexbuf : t = let idx = lexbuf.Lexing.lex_start_p.Lexing.pos_cnum in let line,col = Line_info.get line_info idx in { fol = None; idx; line; col; name = line_info.Line_info.name; } js_of_ocaml-2.5/compiler/parse_info.mli000066400000000000000000000022631241254034500203000ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t = { name : string; col : int; line : int; idx : int; fol : bool option; } val zero : t type lineinfo val make_lineinfo_from_file : string -> lineinfo val make_lineinfo_from_string : string -> lineinfo val make_lineinfo_from_channel : in_channel -> lineinfo * string val t_of_lexbuf : lineinfo -> Lexing.lexbuf -> t js_of_ocaml-2.5/compiler/parse_js.ml000066400000000000000000000137711241254034500176160ustar00rootroot00000000000000(* Js_of_ocaml compiler * Copyright (C) 2013 Hugo Heuzard *) (* Yoann Padioleau * * Copyright (C) 2010 Facebook * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License * version 2.1 as published by the Free Software Foundation, with the * special exception on linking described in file license.txt. * * This library is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file * license.txt for more details. *) let strip_comment l= List.filter (fun x -> not (Js_token.is_comment x)) l let rec until_non_comment acc = function | [] -> acc,None | x::xs -> if Js_token.is_comment x then until_non_comment (x::acc) xs else (acc, Some (x,xs)) let rec adjust_tokens ?(keep_comment=true) l = match until_non_comment [] l with | acc,None when keep_comment -> List.rev acc | _,None -> [] | past,Some (first,rest) -> let open Js_token in let f prev x acc = match prev, x with (* restricted productions *) (* 7.9.1 - 3 *) (* When, as the program is parsed from left to right, a token is encountered *) (* that is allowed by some production of the grammar, but the production *) (* is a restricted production and the token would be the first token for a *) (* terminal or nonterminal immediately following the annotation [no LineTerminator here] *) (* within the restricted production (and therefore such a token is called a restricted token), *) (* and the restricted token is separated from the previous token by at least *) (* one LineTerminator, then a semicolon is automatically inserted before the *) (* restricted token. *) | (T_RETURN _ | T_CONTINUE _ | T_BREAK _ | T_THROW _),(T_SEMICOLON _ | T_VIRTUAL_SEMICOLON _) -> x::acc | (T_RETURN _ | T_CONTINUE _ | T_BREAK _ | T_THROW _),_ -> let x' = Js_token.info_of_tok x in let prev' = Js_token.info_of_tok prev in if prev'.Parse_info.line <> x'.Parse_info.line then x::(Js_token.T_VIRTUAL_SEMICOLON x')::acc else x::acc | _, _ -> x::acc in let rec aux prev acc = function | [] -> List.rev acc | e::l -> let nprev,nacc = if Js_token.is_comment e then if keep_comment then prev,(e::acc) else prev,acc else e,(f prev e acc) in aux nprev nacc l in let past = if keep_comment then past else [] in aux first (first::past) rest type lexer = Js_token.token list let lexer_aux ?(rm_comment=true) lines_info lexbuf = let rec loop lexbuf extra lines_info prev acc = let tokinfo lexbuf = let pi = Parse_info.t_of_lexbuf lines_info lexbuf in let pi = match prev with | None -> { pi with Parse_info.fol=Some true} | Some prev -> let prev_pi = Js_token.info_of_tok prev in if prev_pi.Parse_info.line <> pi.Parse_info.line then {pi with Parse_info.fol=Some true} else pi in match extra with | None -> pi | Some (file,offset) -> { pi with Parse_info.name = file; line = pi.Parse_info.line - offset } in let t = Js_lexer.initial tokinfo prev lexbuf in match t with | Js_token.EOF _ -> List.rev acc | _ -> let extra = match t with | Js_token.TComment (ii,cmt) when String.length cmt > 1 && cmt.[0] = '#' -> let lexbuf = Lexing.from_string cmt in begin try let file,line = Js_lexer.pos lexbuf in match extra with | None -> Some (file, ii.Parse_info.line - ( line - 2)) | Some (_,offset) -> Some (file, ii.Parse_info.line - (line - 2) + offset) with _ -> extra end | _ -> extra in let prev = if Js_token.is_comment t then prev else Some t in loop lexbuf extra lines_info prev (t::acc) in let toks = loop lexbuf None lines_info None [] in (* hack: adjust tokens *) adjust_tokens ~keep_comment:(not rm_comment) toks let lexer_from_file ?rm_comment file : lexer = let lines_info = Parse_info.make_lineinfo_from_file file in let ic = open_in file in let lexbuf = Lexing.from_channel ic in lexer_aux ?rm_comment lines_info lexbuf let lexer_from_channel ?rm_comment ci : lexer = let lines_info,str = Parse_info.make_lineinfo_from_channel ci in let lexbuf = Lexing.from_string str in lexer_aux ?rm_comment lines_info lexbuf let lexer_from_string ?rm_comment str : lexer = let lines_info = Parse_info.make_lineinfo_from_string str in let lexbuf = Lexing.from_string str in lexer_aux ?rm_comment lines_info lexbuf let lexer_map = List.map let lexer_fold f acc l = List.fold_left f acc l let lexer_filter f l = List.filter f l let lexer_from_list l = adjust_tokens l exception Parsing_error of Parse_info.t type st = { mutable rest : Js_token.token list; mutable current : Js_token.token ; mutable passed : Js_token.token list; mutable eof : bool } let parse_aux the_parser toks = let state = match toks with | [] -> { rest = []; passed = []; current = Js_token.EOF Parse_info.zero; eof = false } | hd :: _ -> { rest = toks; passed = []; current = hd ; eof = false } in let lexer_fun lb = match state.rest with | [] when not state.eof -> state.eof <- true; let info = Js_token.info_of_tok state.current in Js_token.EOF info | [] -> assert false | x::tl -> state.rest <- tl; state.current <- x; state.passed <- x::state.passed; x in let lexbuf = Lexing.from_string "" in try the_parser lexer_fun lexbuf with | Js_parser.Error | Parsing.Parse_error -> let pi = Js_token.info_of_tok state.current in raise (Parsing_error pi) let parse lex = parse_aux Js_parser.program lex let parse_expr lex = parse_aux Js_parser.standalone_expression lex js_of_ocaml-2.5/compiler/parse_js.mli000066400000000000000000000027101241254034500177560ustar00rootroot00000000000000 (* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type lexer exception Parsing_error of Parse_info.t val strip_comment : lexer -> lexer val lexer_from_file : ?rm_comment:bool -> string -> lexer val lexer_from_string : ?rm_comment:bool -> string -> lexer val lexer_from_channel : ?rm_comment:bool -> in_channel -> lexer val lexer_map : (Js_token.token -> Js_token.token) -> lexer -> lexer val lexer_fold : ('a -> Js_token.token -> 'a) -> 'a -> lexer -> 'a val lexer_filter : (Js_token.token -> bool) -> lexer -> lexer val lexer_from_list : Js_token.token list -> lexer val parse : lexer -> Javascript.program val parse_expr : lexer -> Javascript.expression js_of_ocaml-2.5/compiler/phisimpl.ml000066400000000000000000000123151241254034500176260ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let times = Option.Debug.find "times" open Code (****) let add_var = VarISet.add let add_def vars defs x y = add_var vars x; let idx = Var.idx x in defs.(idx) <- VarSet.add y defs.(idx) let add_dep deps x y = let idx = Var.idx y in deps.(idx) <- VarSet.add x deps.(idx) let rec arg_deps vars deps defs params args = match params, args with x :: params, y :: args -> add_dep deps x y; add_def vars defs x y; arg_deps vars deps defs params args | _ -> () let cont_deps blocks vars deps defs (pc, args) = let block = AddrMap.find pc blocks in arg_deps vars deps defs block.params args let expr_deps blocks vars deps defs x e = match e with Const _ | Constant _ | Apply _ | Prim _ -> () | Closure (l, cont) -> cont_deps blocks vars deps defs cont | Block (_, a) -> Array.iter (fun y -> add_dep deps x y) a | Field (y, _) -> add_dep deps x y let program_deps (_, blocks, _) = let nv = Var.count () in let vars = VarISet.empty () in let deps = Array.make nv VarSet.empty in let defs = Array.make nv VarSet.empty in AddrMap.iter (fun pc block -> List.iter (fun i -> match i with Let (x, e) -> add_var vars x; expr_deps blocks vars deps defs x e | Set_field _ | Array_set _ | Offset_ref _ -> ()) block.body; Util.opt_iter (fun (x, cont) -> cont_deps blocks vars deps defs cont) block.handler; match block.branch with Return _ | Raise _ | Stop -> () | Branch cont -> cont_deps blocks vars deps defs cont | Cond (_, _, cont1, cont2) -> cont_deps blocks vars deps defs cont1; cont_deps blocks vars deps defs cont2 | Switch (_, a1, a2) -> Array.iter (fun cont -> cont_deps blocks vars deps defs cont) a1; Array.iter (fun cont -> cont_deps blocks vars deps defs cont) a2 | Pushtrap (cont, _, _, _) -> cont_deps blocks vars deps defs cont | Poptrap cont -> cont_deps blocks vars deps defs cont) blocks; (vars, deps, defs) let rec repr' reprs x acc = let idx = Var.idx x in match reprs.(idx) with | None -> (x, acc) | Some y -> repr' reprs y (x :: acc) let repr reprs x = let (last, l) = repr' reprs x [] in List.iter (fun v -> reprs.(Var.idx v) <- Some last) l; last let replace deps reprs x y = let yidx = Var.idx y in let xidx = Var.idx x in deps.(yidx) <- VarSet.union deps.(yidx) deps.(xidx); reprs.(xidx) <- Some y; true let propagate1 deps defs reprs st x = let prev = VarTbl.get st x in if prev then prev else begin let idx = Var.idx x in let s = VarSet.fold (fun x s -> VarSet.add (repr reprs x) s) defs.(idx) VarSet.empty in defs.(idx) <- s; match VarSet.cardinal s with 1 -> replace deps reprs x (VarSet.choose s) | 2 -> begin match VarSet.elements s with [y; z] when Var.compare x y = 0 -> replace deps reprs x z | [z; y] when Var.compare x y = 0 -> replace deps reprs x z | _ -> false end | _ -> false end module G = Dgraph.Make_Imperative (Var) (VarISet) (VarTbl) module Domain1 = struct type t = bool let equal x y = x = y let bot = false end module Solver1 = G.Solver (Domain1) let solver1 vars deps defs = let nv = Var.count () in let reprs = Array.make nv None in let g = { G.domain = vars; G.iter_children = fun f x -> VarSet.iter f deps.(Var.idx x) } in ignore (Solver1.f () g (propagate1 deps defs reprs)); Array.mapi (fun idx y -> match y with Some y -> let y = repr reprs y in if Var.idx y = idx then None else Some y | None -> None) reprs let f p = let t = Util.Timer.make () in let t' = Util.Timer.make () in let (vars, deps, defs) = program_deps p in if times () then Format.eprintf " phi-simpl. 1: %a@." Util.Timer.print t'; let t' = Util.Timer.make () in let subst = solver1 vars deps defs in if times () then Format.eprintf " phi-simpl. 2: %a@." Util.Timer.print t'; let p = Subst.program (Subst.from_array subst) p in if times () then Format.eprintf " phi-simpl.: %a@." Util.Timer.print t; p js_of_ocaml-2.5/compiler/phisimpl.mli000066400000000000000000000017011241254034500177740ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val f : Code.program -> Code.program js_of_ocaml-2.5/compiler/pretty_print.ml000066400000000000000000000157661241254034500205610ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type pos = { mutable p_line : int; mutable p_col : int } type elt = Text of string | Break of string * int | Start_group of int | End_group | Set_pos of pos type t = { mutable indent : int; mutable box_indent : int; mutable prev_indents : (int * int) list; mutable limit : int; mutable cur : int; mutable l : elt list; mutable n : int; mutable w : int; mutable compact : bool; mutable needed_space : (char -> char -> bool) option; mutable pending_space : string option; mutable last_char : char option; mutable line : int; mutable col : int; mutable total : int; output : string -> int -> int -> unit } let spaces = String.make 80 ' ' let output st (s : string) l = (try let last = String.rindex_from s (l-1) '\n' + 1 in let line = ref 0 in for i = 0 to l-1 do if String.get s i = '\n' then incr line; done; st.line <- st.line + !line; st.col <- l - last with Not_found -> st.col <- l + st.col); st.total <- st.total + String.length s; st.output s 0 l let rec output_spaces st n = output st spaces (min n 80); if n > 80 then output_spaces st (n - 80) let output_newline st = output st "\n" 1 let rec flat_render st l = match l with Text s :: r | Break (s, _) :: r -> output st s (String.length s); flat_render st r | Set_pos p :: r -> p.p_line <- st.line; p.p_col <- st.col; flat_render st r | _ :: r -> flat_render st r | [] -> () let rec push st e = if st.n = 0 then begin (* Vertical rendering *) match e with Text s -> output st s (String.length s); st.cur <- st.cur + String.length s | Set_pos p -> p.p_line <- st.line; p.p_col <- st.col | Break (_, offs) -> output_newline st; let indent = st.box_indent + offs in st.indent <- indent; output_spaces st indent; st.limit <- max (indent + 60) 78; st.cur <- st.indent | Start_group n -> st.n <- 1; st.w <- st.limit - st.cur; st.prev_indents <- (st.box_indent, st.indent) :: st.prev_indents; st.indent <- st.indent + n; st.box_indent <- st.indent | End_group -> st.box_indent <- fst (List.hd st.prev_indents); st.indent <- snd (List.hd st.prev_indents); st.prev_indents <- List.tl st.prev_indents end else begin (* Fits? *) st.l <- e :: st.l; match e with Text s | Break (s, _) -> let w = st.w - String.length s in st.w <- w; if w < 0 then begin let l = List.rev st.l in st.l <- []; st.n <- 0; List.iter (fun e -> push st e) l end | Set_pos _ -> () | Start_group _ -> st.n <- st.n + 1 | End_group -> st.n <- st.n - 1; if st.n = 0 then begin flat_render st (List.rev st.l); st.box_indent <- fst (List.hd st.prev_indents); st.indent <- snd (List.hd st.prev_indents); st.prev_indents <- List.tl st.prev_indents; st.cur <- st.cur + st.w; st.l <- [] end end (****) let string st (s : string) = if st.compact then ( let len = (String.length s) in if len <> 0 then begin (match st.pending_space with | None -> () | Some sp -> begin st.pending_space <- None; match st.last_char,st.needed_space with | Some last,Some f -> if f last s.[0] then output st sp 1 | _, None -> output st sp 1 | _ ->() end); output st s len; st.last_char <- Some (s.[len-1]) end ) else push st (Text s) let genbreak st s n = if not st.compact then push st (Break (s, n)) let break_token = Break ("", 0) let break st = if not st.compact then push st break_token let break1 st = if not st.compact then push st (Break ("", 1)) let non_breaking_space_token = Text " " let non_breaking_space st = if st.compact then st.pending_space <- Some " " else push st non_breaking_space_token let space ?(indent=0) st = if st.compact then st.pending_space <- Some "\n" else push st (Break (" ", indent)) let start_group st n = if not st.compact then push st (Start_group n) let end_group st = if not st.compact then push st End_group (* let render l = let st = { indent = 0; box_indent = 0; prev_indents = []; limit = 78; cur = 0; l = []; n = 0; w = 0; output = fun s i l -> output stdout s i l } in push st (Start_group 0); List.iter (fun e -> push st e) l; push st End_group; output_newline st let rec tree n = if n = 0 then [Text "Leaf"] else [Start_group 10; Text "Node.... ("] @ tree (n - 1) @ [Text ","; Break (" ", 0)] @ tree (n - 1) @ [Text ")"; End_group] let _ = for i = 1 to 10 do render (tree i) done *) let total t = t.total let pos t = if t.compact then { p_line = t.line; p_col = t.col } else let p = { p_line = -1 ; p_col = -1 } in push t (Set_pos p); p let newline st = output_newline st; st.indent <- 0; st.box_indent <- 0; st.prev_indents <- []; st.cur <- 0; st.l <- []; st.n <- 0; st.w <- 0 (* hack on*) let output_substring = Pervasives.output (* for ocaml < 4.02, output_substring will be Pervasives.ouput (above) for ocaml >= 4.02, output_substring will be taken from the locally open Pervasives module *) let output_substring = let open Pervasives in output_substring (* hack off*) let to_out_channel ch = { indent = 0; box_indent = 0; prev_indents = []; limit = 78; cur = 0; l = []; n = 0; w = 0; col = 0; line = 0; total = 0; compact = false; pending_space = None; last_char = None; needed_space = None; output = output_substring ch } let to_buffer b = { indent = 0; box_indent = 0; prev_indents = []; limit = 78; cur = 0; l = []; n = 0; w = 0; col = 0; line = 0; total = 0; compact = false; pending_space = None; last_char = None; needed_space = None; output = fun s i l -> Buffer.add_substring b s i l } let set_compact st v = st.compact <- v let set_needed_space_function st f = st.needed_space <- Some f js_of_ocaml-2.5/compiler/pretty_print.mli000066400000000000000000000027201241254034500207140ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t type pos = { mutable p_line : int; mutable p_col : int } val string : t -> string -> unit val genbreak : t -> string -> int -> unit val break : t -> unit val break1 : t -> unit val non_breaking_space : t -> unit val space : ?indent:int -> t -> unit val start_group : t -> int -> unit val end_group : t -> unit val newline : t -> unit val to_out_channel : out_channel -> t val to_buffer : Buffer.t -> t val pos : t -> pos val total : t -> int val set_compact : t -> bool -> unit val set_needed_space_function : t -> (char -> char -> bool) -> unit js_of_ocaml-2.5/compiler/primitive.ml000066400000000000000000000046011241254034500200100ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let aliases = Hashtbl.create 17 let rec resolve nm = try resolve (Hashtbl.find aliases nm) with Not_found -> nm (****) type kind = [ `Pure | `Mutable | `Mutator ] type kind_arg = [`Shallow_const | `Const | `Mutable] type t = [ | `Requires of Parse_info.t option * string list | `Provides of Parse_info.t option * string * kind * kind_arg list option | `Version of Parse_info.t option * ((int -> int -> bool) * string) list ] let kinds = Hashtbl.create 37 let kind_args_tbl = Hashtbl.create 37 let arities = Hashtbl.create 37 let kind nm = try Hashtbl.find kinds (resolve nm) with Not_found -> `Mutator let kind_args nm = try Some (Hashtbl.find kind_args_tbl (resolve nm)) with Not_found -> None let arity nm = Hashtbl.find arities (resolve nm) let is_pure nm = kind nm <> `Mutator let exists p = Hashtbl.mem kinds p open Util let externals = ref StringSet.empty let add_external name = externals := StringSet.add name !externals let is_external name = StringSet.mem name !externals let get_external () = !externals let register p k kargs arity = add_external p; (match arity with Some a -> Hashtbl.add arities p a | _ -> ()); (match kargs with Some k -> Hashtbl.add kind_args_tbl p k | _ -> ()); Hashtbl.add kinds p k let alias nm nm' = add_external nm'; add_external nm; Hashtbl.add aliases nm nm' let named_values = ref StringSet.empty let need_named_value s = StringSet.mem s !named_values let register_named_value s = named_values := StringSet.add s !named_values js_of_ocaml-2.5/compiler/primitive.mli000066400000000000000000000033031241254034500201570ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val is_pure : string -> bool val exists : string -> bool type kind = [ `Pure | `Mutable | `Mutator ] type kind_arg = [`Shallow_const | `Const | `Mutable] type t = [ `Requires of Parse_info.t option * string list | `Provides of Parse_info.t option * string * kind * kind_arg list option | `Version of Parse_info.t option * ((int -> int -> bool) * string) list ] val kind : string -> kind val kind_args : string -> kind_arg list option val register : string -> kind -> kind_arg list option -> int option -> unit val arity : string -> int val alias : string -> string -> unit val resolve : string -> string val add_external : string -> unit val is_external : string -> bool val get_external : unit -> Util.StringSet.t val need_named_value : string -> bool val register_named_value : string -> unit js_of_ocaml-2.5/compiler/pseudoFs.ml000066400000000000000000000110221241254034500175630ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2014 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let expand_path exts real virt = let rec loop realfile virtfile acc = if try Sys.is_directory realfile with _ -> false then Array.fold_left (fun acc s -> loop (Filename.concat realfile s) (Filename.concat virtfile s) acc) acc (Sys.readdir realfile) else try let exmatch = try let b = Filename.basename realfile in let i = String.rindex b '.' in let e = String.sub b (i+1) (String.length b - i - 1) in List.mem e exts with Not_found -> List.mem "" exts in if exts = [] || exmatch then (virtfile, realfile) :: acc else acc with exc -> Format.eprintf "ignoring %s: %s@." realfile (Printexc.to_string exc); acc in loop real virt [] let list_files name paths = let name,dir = try let i = String.index name ':' in let d = String.sub name (i + 1) (String.length name - i - 1) in let n = String.sub name 0 i in if String.length d > 0 && d.[0] <> '/' then failwith (Printf.sprintf "path '%s' for file '%s' must be absolute" d n); let d = if d.[String.length d - 1] <> '/' then d^Filename.dir_sep else d in n,d with Not_found -> (* by default, files are store in /static/ directory *) name,"/static/" in let name, exts (* extensions filter *) = try let i = String.index name '=' in let exts = String.sub name (i + 1) (String.length name - i - 1) in let n = String.sub name 0 i in let exts = Util.split_char ',' exts in n,exts with Not_found -> name,[] in let file = try Util.find_in_paths paths name with Not_found -> failwith (Printf.sprintf "file '%s' not found" name) in expand_path exts file (Filename.concat dir name) let cmi_dir = "/cmis" let find_cmi paths base = try let name = String.uncapitalize base ^ ".cmi" in Filename.concat cmi_dir name, Util.find_in_paths paths name with Not_found -> let name = String.capitalize base ^ ".cmi" in Filename.concat cmi_dir name, Util.find_in_paths paths name open Util open Code let read name filename = let content = Util.read_file filename in (Pc (IString name),Pc (IString content)) let program_of_files l = let fs = List.map (fun (name,filename) -> read name filename) l in let body = List.map (fun (n, c) -> Let(Var.fresh (), Prim(Extern "caml_fs_register_extern", [n;c]))) fs in let pc = 0 in let blocks = AddrMap.add pc {params=[]; handler=None; body=[]; branch=Stop} AddrMap.empty in let p = pc, blocks, pc+1 in Code.prepend p body let make_body prim cmis files paths = let fs = StringSet.fold (fun s acc -> try let name, filename = find_cmi paths s in read name filename :: acc with Not_found -> failwith (Printf.sprintf "interface file '%s' not found" s) ) cmis [] in let fs = List.fold_left (fun acc f -> let l = list_files f paths in List.fold_left (fun acc (n,fn) -> read n fn :: acc) acc l ) fs files in let body = List.map (fun (n, c) -> Let(Var.fresh (), Prim(Extern prim, [n;c]))) fs in body let f p cmis files paths = let body = make_body "caml_fs_register" cmis files paths in Code.prepend p body let f_empty cmis files paths = let body = make_body "caml_fs_register_extern" cmis files paths in let pc = 0 in let blocks = AddrMap.add pc {params=[]; handler=None; body=[]; branch=Stop} AddrMap.empty in let p = pc, blocks, pc+1 in Code.prepend p body js_of_ocaml-2.5/compiler/pseudoFs.mli000066400000000000000000000021061241254034500177370ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2014 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Util val f : Code.program -> StringSet.t -> string list -> string list -> Code.program val f_empty : StringSet.t -> string list -> string list -> Code.program val program_of_files : (string * string) list -> Code.program js_of_ocaml-2.5/compiler/pure_fun.ml000066400000000000000000000050421241254034500176230ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Code (****) let pure_expr pure_funs e = match e with Const _ | Block _ | Field _ | Closure _ | Constant _ -> true | Apply (f, l, exact) -> exact && VarSet.mem f pure_funs | Prim (p, l) -> match p with Extern f -> Primitive.is_pure f | _ -> true let pure_instr pure_funs i = match i with Let (_, e) -> pure_expr pure_funs e | Set_field _ | Offset_ref _ | Array_set _ -> false (****) let rec traverse blocks pc visited funs = try (AddrMap.find pc visited, visited, funs) with Not_found -> let visited = AddrMap.add pc false visited in let (pure, visited, funs) = fold_children blocks pc (fun pc (pure, visited, funs) -> let (pure', visited, funs) = traverse blocks pc visited funs in (pure && pure', visited, funs)) (true, visited, funs) in let (pure, visited, funs) = block blocks pc pure visited funs in (pure, AddrMap.add pc pure visited, funs) and block blocks pc pure visited funs = let b = AddrMap.find pc blocks in let pure = match b.branch with Raise _ -> false | _ -> pure in List.fold_left (fun (pure, visited, funs) i -> let (visited, funs) = match i with Let (x, Closure (_, (pc, _))) -> let (pure, visited, funs) = traverse blocks pc visited funs in (visited, if pure then VarSet.add x funs else funs) | _ -> (visited, funs) in (pure && pure_instr funs i, visited, funs)) (pure, visited, funs) b.body let f (pc, blocks, _) = let (_, _, funs) = traverse blocks pc AddrMap.empty VarSet.empty in funs js_of_ocaml-2.5/compiler/pure_fun.mli000066400000000000000000000020531241254034500177730ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val pure_expr : Code.VarSet.t -> Code.expr -> bool val pure_instr : Code.VarSet.t -> Code.instr -> bool val f : Code.program -> Code.VarSet.t js_of_ocaml-2.5/compiler/reserved.ml000066400000000000000000000041341241254034500176200ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Util let keyword = List.fold_left (fun acc x -> StringSet.add x acc) StringSet.empty [ (* keywork *) "break"; "case"; "catch"; "continue"; "debugger";"default";"delete";"do"; "else"; "finally";"for";"function"; "if"; "in";"instanceof"; "new"; "return"; "switch"; "this"; "throw"; "try"; "typeof"; "var"; "void"; "while"; "with"; (* reserved for future use *) "class"; "enum"; "export"; "extends"; "import"; "super"; "implements";"interface"; "let"; "package";"private";"protected";"public"; "static"; "yield"; (* other *) "null"; "true"; "false"; "NaN"; "undefined"; "this"; ] let provided = List.fold_left (fun acc x -> StringSet.add x acc) StringSet.empty [ "event"; "location"; "window"; "document"; "eval"; "navigator"; "self"; "Array"; "Date"; "Math"; "JSON"; "Object"; "RegExp"; "String"; "Boolean"; "Number"; "Infinity"; "isFinite"; "ActiveXObject"; "XMLHttpRequest"; "XDomainRequest"; "DOMException"; "Error"; "SyntaxError"; "arguments"; "decodeURI"; "decodeURIComponent"; "encodeURI"; "encodeURIComponent"; "escape"; "unescape"; "isNaN"; "parseFloat"; "parseInt"; ] js_of_ocaml-2.5/compiler/reserved.mli000066400000000000000000000016421241254034500177720ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val keyword : Util.StringSet.t val provided : Util.StringSet.t js_of_ocaml-2.5/compiler/source_map.ml000066400000000000000000000074061241254034500201430ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type map = { gen_line : int; gen_col : int; ori_source : int; ori_line : int; ori_col : int; ori_name : int option } type mapping = map list type t = { version : int; file : string; sourceroot : string option; mutable sources : string list; mutable sources_content : string option list; mutable names : string list; mutable mappings : mapping ; } let string_of_mapping mapping = let a = Array.of_list mapping in let len = Array.length a in Array.stable_sort (fun t1 t2 -> match compare t1.gen_line t2.gen_line with | 0 -> compare t1.gen_col t2.gen_col | n -> n) a; let buf = Buffer.create 1024 in let gen_line = ref 0 in let gen_col = ref 0 in let ori_source = ref 0 in let ori_line = ref 0 in let ori_col = ref 0 in let ori_name = ref 0 in let rec loop prev i = if i < len then let c = a.(i) in if prev >= 0 && c.ori_source = a.(prev).ori_source && c.ori_line = a.(prev).ori_line && c.ori_col = a.(prev).ori_col then (* We already are at this location *) loop prev (i + 1) else if i + 1 < len && c.gen_line = a.(i+1).gen_line && c.gen_col = a.(i+1).gen_col then (* Only keep one source location per generated location *) loop prev (i + 1) else begin if !gen_line <> c.gen_line then begin assert (!gen_line < c.gen_line); for j = !gen_line to c.gen_line - 1 do Buffer.add_char buf ';'; done; gen_col := 0; gen_line := c.gen_line end else if i > 0 then Buffer.add_char buf ','; let l = c.gen_col - !gen_col :: if c.ori_source = -1 then [] else c.ori_source - !ori_source :: c.ori_line - !ori_line :: c.ori_col - !ori_col :: match c.ori_name with | None -> [] | Some n -> let n' = !ori_name in ori_name := n; [n - n'] in gen_col := c.gen_col; if c.ori_source <> -1 then begin ori_source := c.ori_source; ori_line := c.ori_line; ori_col := c.ori_col end; Vlq64.encode_l buf l; loop i (i + 1) end in loop (-1) 0; Buffer.contents buf let expression t = let open Javascript in EObj [ PNS "version", ENum (float_of_int t.version); PNS "file", EStr (t.file,`Bytes); PNS "sourceRoot", EStr ((match t.sourceroot with None -> "" | Some s -> s),`Bytes); PNS "sources", EArr (List.map (fun s -> Some (EStr (s,`Bytes))) t.sources); PNS "sources_content", EArr (List.map (function | None -> Some (EVar (S {name="null";var=None})) | Some s -> Some (EStr (s,`Bytes))) t. sources_content); PNS "names", EArr (List.map (fun s -> Some (EStr (s,`Bytes))) t.names); PNS "mappings", EStr (string_of_mapping t.mappings,`Bytes) ] js_of_ocaml-2.5/compiler/source_map.mli000066400000000000000000000024071241254034500203100ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type map = { gen_line : int; gen_col : int; ori_source : int; ori_line : int; ori_col : int; ori_name : int option } type mapping = map list type t = { version : int; file : string; sourceroot : string option; mutable sources : string list; mutable sources_content : string option list; mutable names : string list; mutable mappings : mapping ; } val expression : t -> Javascript.expression js_of_ocaml-2.5/compiler/specialize.ml000066400000000000000000000064631241254034500201400ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Code open Flow let rec function_cardinality info x acc = get_approx info (fun x -> match info.info_defs.(Var.idx x) with | Expr (Closure (l, _)) -> Some (List.length l) | Expr (Apply (f, l, _)) -> if List.mem f acc then None else begin match function_cardinality info f (f::acc) with Some n -> let diff = n - List.length l in if diff > 0 then Some diff else None | None -> None end | _ -> None) None (fun u v -> match u, v with Some n, Some m when n = m -> u | _ -> None) x let specialize_instr info (acc,free_pc,extra) i = match i with | Let (x, Apply (f, l, _)) when Option.Optim.optcall () -> begin let n' = List.length l in match function_cardinality info f [] with | None -> i::acc,free_pc,extra | Some n when n = n' -> Let (x, Apply (f, l, true))::acc,free_pc,extra | Some n when n < n' -> let v = Code.Var.fresh () in let args,rest = Util.take n l in (Let(v, Apply(f,args,true))) ::(Let(x,Apply(v,rest,false))) ::acc,free_pc,extra | Some n when n > n' -> let missing = Array.init (n - n') (fun _ -> Code.Var.fresh ()) in let missing = Array.to_list missing in let block = let params' = Array.init (n - n') (fun _ -> Code.Var.fresh ()) in let params' = Array.to_list params' in let return' = Code.Var.fresh () in { params=params'; body = [Let(return',Apply(f,l@params',true))]; branch = Return return'; handler = None; } in Let(x, Closure(missing,(free_pc,missing)))::acc,(free_pc + 1),(free_pc,block)::extra | _ -> i::acc, free_pc,extra end | _ -> i::acc,free_pc,extra let specialize_instrs info (pc, blocks, free_pc) = let blocks,free_pc = AddrMap.fold (fun pc block (blocks,free_pc) -> let body,free_pc,extra = List.fold_right (fun i acc -> specialize_instr info acc i) block.body ([],free_pc,[]) in let blocks = List.fold_left (fun blocks (pc,b) -> AddrMap.add pc b blocks) blocks extra in (AddrMap.add pc { block with Code.body = body } blocks),free_pc) blocks (AddrMap.empty,free_pc) in (pc, blocks, free_pc) let f info p = specialize_instrs info p js_of_ocaml-2.5/compiler/specialize.mli000066400000000000000000000017161241254034500203050ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val f : Flow.info -> Code.program -> Code.program js_of_ocaml-2.5/compiler/specialize_js.ml000066400000000000000000000200641241254034500206250ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Code open Flow let specialize_instr info i rem = match i with | Let (x, Prim (Extern "caml_format_int", [y;z])) -> begin match the_string_of info y with | Some "%d" -> begin match the_int info z with | Some i -> Let(x,Constant(String (Int32.to_string i))) | None -> Let (x, Prim (Extern "%caml_format_int_special", [z])) end | _ -> i end :: rem | Let (x, Prim (Extern "%caml_format_int_special", [z])) -> begin match the_int info z with | Some i -> Let(x,Constant(String (Int32.to_string i))) | None -> i end :: rem | Let (x, Prim (Extern ("caml_js_var"|"caml_js_expr"|"caml_pure_js_expr" as prim), [y])) -> begin match the_string_of info y with Some s -> Let (x, Prim (Extern prim, [Pc (String s)])) | _ -> i end :: rem | Let (x, Prim (Extern ("caml_register_named_value" as prim), [y;z])) -> begin match the_string_of info y with | Some s when Primitive.need_named_value s -> Let (x, Prim (Extern prim, [Pc (String s);z])) | Some s -> (* Format.eprintf "Do not register named value %S@." s; *) Let(x, Constant (Int 0l)) | None -> i end :: rem | Let (x, Prim (Extern "caml_js_call", [f; o; a])) -> begin match the_def_of info a with Some (Block (_, a)) -> let a = Array.map (fun x -> Pv x) a in Let (x, Prim (Extern "%caml_js_opt_call", f :: o :: Array.to_list a)) | _ -> i end :: rem | Let (x, Prim (Extern "caml_js_fun_call", [f; a])) -> begin match the_def_of info a with Some (Block (_, a)) -> let a = Array.map (fun x -> Pv x) a in Let (x, Prim (Extern "%caml_js_opt_fun_call", f :: Array.to_list a)) | _ -> i end :: rem | Let (x, Prim (Extern "caml_js_meth_call", [o; m; a])) -> begin match the_string_of info m with Some m -> begin match the_def_of info a with Some (Block (_, a)) -> let a = Array.map (fun x -> Pv x) a in Let (x, Prim (Extern "%caml_js_opt_meth_call", o :: Pc (String m) :: Array.to_list a)) | _ -> i end | _ -> i end :: rem | Let (x, Prim (Extern "caml_js_new", [c; a])) -> begin match the_def_of info a with Some (Block (_, a)) -> let a = Array.map (fun x -> Pv x) a in Let (x, Prim (Extern "%caml_js_opt_new", c :: Array.to_list a)) | _ -> i end :: rem | Let (x, Prim (Extern "caml_js_object", [a])) -> begin try let a = match the_def_of info a with Some (Block (_, a)) -> a | _ -> raise Exit in let a = Array.map (fun x -> match the_def_of info (Pv x) with Some (Block (_, [|k; v|])) -> let k = match the_string_of info (Pv k) with | Some s -> Pc (String s) | _ -> raise Exit in [k; Pv v] | _ -> raise Exit) a in Let (x, Prim (Extern "%caml_js_opt_object", List.flatten (Array.to_list a))) with Exit -> i end :: rem | Let (x, Prim (Extern "caml_js_get", [o; f])) -> begin match the_string_of info f with Some s -> Let (x, Prim (Extern "caml_js_get", [o; Pc (String s)])) | _ -> i end :: rem | Let (x, Prim (Extern "caml_js_set", [o; f; v])) -> begin match the_string_of info f with Some s -> Let (x, Prim (Extern "caml_js_set", [o; Pc (String s); v])) | _ -> i end :: rem | Let (x, Prim (Extern "caml_js_delete", [o; f])) -> begin match the_string_of info f with Some s -> Let (x, Prim (Extern "caml_js_delete", [o; Pc (String s)])) | _ -> i end :: rem | Let (x, Prim (Extern "caml_js_from_string", [y])) -> begin match the_string_of info y with Some s when Util.is_ascii s -> Let (x, Constant (IString s)) | _ -> i end :: rem | Let (x, Prim (Extern "%int_mul", [y; z])) -> begin match the_int info y, the_int info z with Some j, _ | _, Some j when Int32.abs j < 0x200000l -> Let (x, Prim (Extern "%direct_int_mul", [y; z])) | _ -> i end :: rem | Let (x, Prim (Extern "%int_div", [y; z])) -> begin match the_int info z with Some j when j <> 0l -> Let (x, Prim (Extern "%direct_int_div", [y; z])) | _ -> i end :: rem | Let (x, Prim (Extern "%int_mod", [y; z])) -> begin match the_int info z with Some j when j <> 0l -> Let (x, Prim (Extern "%direct_int_mod", [y; z])) | _ -> i end :: rem | _ -> i :: rem let rec specialize_instrs info checks l = match l with [] -> [] | i :: r -> (* We make bound checking explicit. Then, we can remove duplicated bound checks. Also, it appears to be more efficient to inline the array access. The bound checking function returns the array, which allows to produce more compact code. *) match i with | Let (x, Prim (Extern "caml_array_get", [y;z])) | Let (x, Prim (Extern "caml_array_get_float", [y;z])) | Let (x, Prim (Extern "caml_array_get_addr", [y;z])) -> let idx = match the_int info z with Some idx -> `Cst idx | None -> `Var z in if List.mem (y, idx) checks then Let (x, Prim (Extern "caml_array_unsafe_get", [y;z])) :: specialize_instrs info checks r else let y' = Code.Var.fresh () in Let (y', Prim (Extern "caml_check_bound", [y;z])) :: Let (x, Prim (Extern "caml_array_unsafe_get", [Pv y';z])) :: specialize_instrs info ((y, idx) :: checks) r | Let (x, Prim (Extern "caml_array_set", [y;z;t])) | Let (x, Prim (Extern "caml_array_set_float", [y;z;t])) | Let (x, Prim (Extern "caml_array_set_addr", [y;z;t])) -> let idx = match the_int info z with Some idx -> `Cst idx | None -> `Var z in if List.mem (y, idx) checks then Let (x, Prim (Extern "caml_array_unsafe_set", [y;z;t])) :: specialize_instrs info checks r else let y' = Code.Var.fresh () in Let (y', Prim (Extern "caml_check_bound", [y;z])) :: Let (x, Prim (Extern "caml_array_unsafe_set", [Pv y';z;t])) :: specialize_instrs info ((y, idx) :: checks) r | _ -> specialize_instr info i (specialize_instrs info checks r) let specialize_all_instrs info (pc, blocks, free_pc) = let blocks = AddrMap.map (fun block -> { block with Code.body = specialize_instrs info [] block.body }) blocks in (pc, blocks, free_pc) (****) let f info p = specialize_all_instrs info p js_of_ocaml-2.5/compiler/specialize_js.mli000066400000000000000000000017161241254034500210010ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val f : Flow.info -> Code.program -> Code.program js_of_ocaml-2.5/compiler/subst.ml000066400000000000000000000056471241254034500171530ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Code let expr s e = match e with Const _ | Constant _ -> e | Apply (f, l, n) -> Apply (s f, List.map (fun x -> s x) l, n) | Block (n, a) -> Block (n, Array.map (fun x -> s x) a) | Field (x, n) -> Field (s x, n) | Closure (l, pc) -> Closure (l, pc) | Prim (p, l) -> Prim (p, List.map (fun x -> match x with Pv x -> Pv (s x) | Pc _ -> x) l) let instr s i = match i with Let (x, e) -> Let (x, expr s e) | Set_field (x, n, y) -> Set_field (s x, n, s y) | Offset_ref (x, n) -> Offset_ref (s x, n) | Array_set (x, y, z) -> Array_set (s x, s y, s z) let instrs s l = List.map (fun i -> instr s i) l let subst_cont s (pc, arg) = (pc, List.map (fun x -> s x) arg) let last s l = match l with Stop -> l | Branch cont -> Branch (subst_cont s cont) | Pushtrap (cont1, x, cont2, pc) -> Pushtrap (subst_cont s cont1, x, subst_cont s cont2, pc) | Return x -> Return (s x) | Raise x -> Raise (s x) | Cond (c, x, cont1, cont2) -> Cond (c, s x, subst_cont s cont1, subst_cont s cont2) | Switch (x, a1, a2) -> Switch (s x, Array.map (fun cont -> subst_cont s cont) a1, Array.map (fun cont -> subst_cont s cont) a2) | Poptrap cont -> Poptrap (subst_cont s cont) let program s (pc, blocks, free_pc) = let blocks = AddrMap.map (fun block -> { params = block.params; handler = Util.opt_map (fun (x, cont) -> (x, subst_cont s cont)) block.handler; body = instrs s block.body; branch = last s block.branch }) blocks in (pc, blocks, free_pc) (****) let from_array s = fun x -> match s.(Var.idx x) with Some y -> y | None -> x (****) let rec build_mapping params args = match params, args with x :: params, y :: args -> VarMap.add x y (build_mapping params args) | [], _ -> VarMap.empty | _ -> assert false let from_map m = fun x -> try VarMap.find x m with Not_found -> x js_of_ocaml-2.5/compiler/subst.mli000066400000000000000000000025051241254034500173120ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Code val program : (Var.t -> Var.t) -> program -> program val expr : (Var.t -> Var.t) -> expr -> expr val instr : (Var.t -> Var.t) -> instr -> instr val instrs : (Var.t -> Var.t) -> instr list -> instr list val last : (Var.t -> Var.t) -> last -> last val from_array : Var.t option array -> Var.t -> Var.t val build_mapping : Var.t list -> Var.t list -> Var.t VarMap.t val from_map : Var.t VarMap.t -> Var.t -> Var.t js_of_ocaml-2.5/compiler/tailcall.ml000066400000000000000000000071421241254034500175700ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let times = Option.Debug.find "times" open Code (* FIX: it should be possible to deal with tail-recursion in exception handlers, but we have to adapt the code generator for that *) let rec remove_last l = match l with [] -> assert false | [_] -> [] | x :: r -> x :: remove_last r let rec tail_call x f l = match l with [] -> None | [Let (y, Apply (g, args, _))] when Var.compare x y = 0 && Var.compare f g = 0 -> Some args | i :: rem -> tail_call x f rem let rewrite_block (f, f_params, f_pc, args) pc blocks = (*Format.eprintf "%d@." pc;*) let block = AddrMap.find pc blocks in match block.branch with | Return x -> begin match tail_call x f block.body with Some f_args when List.length f_params = List.length f_args -> let m = Subst.build_mapping f_params f_args in AddrMap.add pc { params = block.params; handler = block.handler; body = remove_last block.body; branch = Branch (f_pc, List.map (fun x -> VarMap.find x m) args) } blocks | _ -> blocks end | _ -> blocks let (>>) x f = f x (* Skip try body *) let fold_children blocks pc f accu = let block = AddrMap.find pc blocks in match block.branch with Return _ | Raise _ | Stop -> accu | Branch (pc', _) | Poptrap (pc', _) -> f pc' accu | Pushtrap (_, _, (pc1, _), pc2) -> f pc1 (if pc2 >= 0 then f pc2 accu else accu) | Cond (_, _, (pc1, _), (pc2, _)) -> accu >> f pc1 >> f pc2 | Switch (_, a1, a2) -> accu >> Array.fold_right (fun (pc, _) accu -> f pc accu) a1 >> Array.fold_right (fun (pc, _) accu -> f pc accu) a2 let rec traverse f pc visited blocks = if not (AddrSet.mem pc visited) then begin let visited = AddrSet.add pc visited in let blocks = rewrite_block f pc blocks in let (visited, blocks) = fold_children blocks pc (fun pc (visited, blocks) -> let (visited, blocks) = traverse f pc visited blocks in (visited, blocks)) (visited, blocks) in (visited, blocks) end else (visited, blocks) let f ((pc, blocks, free_pc) as p) = let t = Util.Timer.make () in let blocks = fold_closures p (fun f params (pc, args) blocks -> match f with Some f when List.length params = List.length args -> let (_, blocks) = traverse (f, params, pc, args) pc AddrSet.empty blocks in blocks | _ -> blocks) blocks in if times () then Format.eprintf " tail calls: %a@." Util.Timer.print t; (pc, blocks, free_pc) js_of_ocaml-2.5/compiler/tailcall.mli000066400000000000000000000017011241254034500177340ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val f : Code.program -> Code.program js_of_ocaml-2.5/compiler/util.ml000066400000000000000000000215331241254034500167600ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) module Int = struct type t = int let compare (x : int) y = compare x y end module IntSet = Set.Make (Int) module IntMap = Map.Make (Int) module StringSet = Set.Make (String) module StringMap = Map.Make (String) let opt_map f x = match x with None -> None | Some v -> Some (f v) let opt_iter f x = match x with None -> () | Some v -> f v let opt_bind x f = match x with None -> None | Some v -> f v let opt_filter p x = match x with None -> None | Some v -> if p v then Some v else None (****) let findlib_init = lazy (Findlib.init ()) let find_pkg_dir pkg = let () = Lazy.force findlib_init in try Findlib.package_directory pkg with _ -> raise Not_found let path_require_findlib path = if path <> "" && path.[0] = '+' then Some (String.sub path 1 (String.length path - 1)) else None let rec find_in_paths ?(pkg="stdlib") paths name = match paths with | [] -> raise Not_found | path :: rem -> try let file = match path_require_findlib path with | Some path -> let () = Lazy.force findlib_init in Filename.concat (Filename.concat (find_pkg_dir pkg) path) name | None -> Filename.concat path name in if Sys.file_exists file then file else find_in_paths rem name with Not_found -> find_in_paths rem name let read_file f = let ic = open_in f in let n = in_channel_length ic in let s = Bytes.create n in really_input ic s 0 n; close_in ic; Bytes.unsafe_to_string s let filter_map f l = let l = List.fold_left (fun acc x -> match f x with | Some x -> x::acc | None -> acc) [] l in List.rev l let array_fold_right_i f a x = let r = ref x in for i = Array.length a - 1 downto 0 do r := f i (Array.unsafe_get a i) !r done; !r let rec take' acc n l = if n = 0 then acc,l else match l with | [] -> acc,[] | x::xs -> take' (x::acc) (pred n) xs let take n l = let x,xs = take' [] n l in List.rev x, xs module Timer = struct type t = float let timer = ref (fun _ -> 0.) let init f = timer := f let make () = !timer () let get t = !timer () -. t let print f t = Format.fprintf f "%.2f" (get t) end let is_ascii s = let res = ref true in for i = 0 to String.length s - 1 do if s.[i] > '\127' then res := false done; !res let has_backslash s = let res = ref false in for i = 0 to String.length s - 1 do if s.[i] = '\\' then res := true done; !res let fail = ref true let failwith_ fmt = Printf.ksprintf (fun s -> if !fail then failwith s else Format.eprintf "%s@." s) fmt let raise_ exn = if !fail then raise exn else begin Format.eprintf "%s@." (Printexc.to_string exn) end let split_char sep p = let len = String.length p in let rec split beg cur = if cur >= len then if cur - beg > 0 then [String.sub p beg (cur - beg)] else [] else if p.[cur] = sep then String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1) else split beg (cur + 1) in split 0 0 (* copied from https://github.com/ocaml/ocaml/pull/10 *) let split sep s = let sep_len = String.length sep in if sep_len = 1 then split_char sep.[0] s else let sep_max = sep_len - 1 in if sep_max < 0 then invalid_arg "String.split: empty separator" else let s_max = String.length s - 1 in if s_max < 0 then [""] else let acc = ref [] in let sub_start = ref 0 in let k = ref 0 in let i = ref 0 in (* We build the substrings by running from the start of [s] to the end with [i] trying to match the first character of [sep] in [s]. If this matches, we verify that the whole [sep] is matched using [k]. If this matches we extract a substring from the start of the current substring [sub_start] to [!i - 1] (the position before the [sep] we found). We then continue to try to match with [i] by starting after the [sep] we just found, this is also becomes the start position of the next substring. If [i] is such that no separator can be found we exit the loop and make a substring from [sub_start] until the end of the string. *) while (!i + sep_max <= s_max) do if String.unsafe_get s !i <> String.unsafe_get sep 0 then incr i else begin (* Check remaining [sep] chars match, access to unsafe s (!i + !k) is guaranteed by loop invariant. *) k := 1; while (!k <= sep_max && String.unsafe_get s (!i + !k) = String.unsafe_get sep !k) do incr k done; if !k <= sep_max then (* no match *) incr i else begin let new_sub_start = !i + sep_max + 1 in let sub_end = !i - 1 in let sub_len = sub_end - !sub_start + 1 in acc := String.sub s !sub_start sub_len :: !acc; sub_start := new_sub_start; i := new_sub_start; end end done; List.rev (String.sub s !sub_start (s_max - !sub_start + 1) :: !acc) exception Found of int let find sep s = let sep_max = String.length sep - 1 in let s_max = Bytes.length s - 1 in if sep_max < 0 then invalid_arg "find: empty string"; let k = ref 0 in let i = ref 0 in try while (!i + sep_max <= s_max) do if Bytes.unsafe_get s !i <> String.unsafe_get sep 0 then incr i else begin (* Check remaining [sep] chars match, access to unsafe s (!i + !k) is guaranteed by loop invariant. *) k := 1; while (!k <= sep_max && Bytes.unsafe_get s (!i + !k) = String.unsafe_get sep !k) do incr k done; if !k <= sep_max then (* no match *) incr i else raise (Found !i) end done; raise Not_found with Found i -> i module Version = struct type t = int list let split v = match split_char '+' v with | [] -> assert false | x::_ -> List.map int_of_string (split_char '.' x) let current = split Sys.ocaml_version let compint (a : int) b = compare a b let rec compare v v' = match v,v' with | [x],[y] -> compint x y | [],[] -> 0 | [],y::_ -> compint 0 y | x::_,[] -> compint x 0 | x::xs,y::ys -> match compint x y with | 0 -> compare xs ys | n -> n let v = if compare current [4;2] < 0 then `V3 else `V4_02 end module MagicNumber = struct type t = string * int exception Bad_magic_number of string exception Bad_magic_version of t let size = 12 let kind_of_string = function | "Caml1999X" -> "exe" | "Caml1999I" -> "cmi" | "Caml1999O" -> "cmo" | "Caml1999A" -> "cma" | "Caml1999Y" -> "cmx" | "Caml1999Z" -> "cmxa" | "Caml2007D" -> "cmxs" | "Caml2012T" -> "cmt" | "Caml1999M" -> "impl" | "Caml1999N" -> "intf" | s -> raise Not_found let of_string s = try if String.length s <> size then raise Not_found; let kind = String.sub s 0 9 in let v = String.sub s 9 3 in kind, int_of_string v with _ -> raise (Bad_magic_number s) let to_string (k,v) = Printf.sprintf "%s%03d" k v let compare (p1,n1) (p2,n2) = if p1 <> p2 then raise Not_found; compare n1 n2 let current = let v = match Version.v with | `V3 -> 8 | `V4_02 -> 11 in ("Caml1999X",v) let assert_current h': unit = let (t',v') as h = of_string h' in let t,v = current in if t <> t' then raise_ (Bad_magic_number h') else if v <> v' then raise_ (Bad_magic_version h) else () end let normalize_argv ?(warn=false) a = let bad = ref [] in let a = Array.map (fun s -> let size = String.length s in if size <= 2 then s else if s.[0] = '-' && s.[1] <> '-' && s.[2] <> '=' then begin bad:=s::!bad; (* long option with one dash lets double the dash *) "-"^s end else s ) a in if (warn && !bad <> []) then Format.eprintf "[Warning] long options with a single '-' are now deprecated.\ Please use '--' for the following options: %s@." (String.concat ", " !bad); a js_of_ocaml-2.5/compiler/util.mli000066400000000000000000000053131241254034500171270ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2010 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) module IntSet : Set.S with type elt = int module IntMap : Map.S with type key = int module StringSet : Set.S with type elt = string module StringMap : Map.S with type key = string val opt_filter : ('a -> bool) -> 'a option -> 'a option val opt_map : ('a -> 'b) -> 'a option -> 'b option val opt_iter : ('a -> unit) -> 'a option -> unit val filter_map : ('a -> 'b option) -> 'a list -> 'b list val array_fold_right_i : (int -> 'a -> 'b -> 'b) -> 'a array -> 'b -> 'b val path_require_findlib : string -> string option val find_pkg_dir : string -> string val find_in_paths : ?pkg:string -> string list -> string -> string val read_file : string -> string val take : int -> 'a list -> 'a list * 'a list val is_ascii : string -> bool val has_backslash : string -> bool module Timer : sig type t val init : (unit -> float) -> unit val make : unit -> t val get : t -> float val print : Format.formatter -> t -> unit end val fail : bool ref val failwith_ : ('a,unit,string,unit) format4 -> 'a val raise_ : exn -> unit val split_char : char -> string -> string list val split : string -> string -> string list val find : string -> Bytes.t -> int (* [normalize_argv argv] returns a new array of arguments where '-long-option' are replaced by '--long-option' *) val normalize_argv : ?warn:bool -> string array -> string array module Version : sig type t = int list val current : t val compare : t -> t -> int val split : string -> t val v : [ `V3 (* OCaml 3.12 to 4.01 *) | `V4_02 ] (* OCaml 4.02 *) end module MagicNumber : sig type t = private string * int exception Bad_magic_number of string exception Bad_magic_version of t val size : int val compare : t -> t -> int val of_string : string -> t val to_string : t -> string val current : t val assert_current : string -> unit end js_of_ocaml-2.5/compiler/varPrinter.ml000066400000000000000000000073251241254034500201420ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Util type t = { names : (int,string) Hashtbl.t; known : (int,string) Hashtbl.t; cache : (int*int,string) Hashtbl.t; mutable last : int; mutable pretty : bool; } let c1 = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_$" let c2 = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$" let name_raw t v nm = Hashtbl.add t.names v nm let propagate_name t v v' = try name_raw t v' (Hashtbl.find t.names v) with Not_found -> () let is_alpha c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') let is_num c = (c >= '0' && c <= '9') let name t v nm_orig = let len = String.length nm_orig in if len > 0 then begin let buf = Buffer.create (String.length nm_orig) in let idx = ref 0 in while (!idx < len && not (is_alpha nm_orig.[!idx])) do incr idx done; let pending = ref false in if(!idx >= len) then begin pending := true; idx := 0 end; for i = !idx to len - 1 do if is_alpha nm_orig.[i] || is_num nm_orig.[i] then begin if !pending then Buffer.add_char buf '_'; Buffer.add_char buf nm_orig.[i]; pending:=false end else pending := true done; let str = Buffer.contents buf in if String.length str > 0 then name_raw t v str end let rec format_ident x = assert (x >= 0); let char c x = String.make 1 (c.[x]) in if x < 54 then char c1 x else format_ident ((x - 54) / 64) ^ char c2 ((x - 54) mod 64) let format_var t i x = let s = format_ident x in if t.pretty then Format.sprintf "_%s_" s else s let reserved = ref StringSet.empty let add_reserved s = reserved := List.fold_left (fun acc x -> StringSet.add x acc) !reserved s let _ = reserved := StringSet.union !reserved Reserved.keyword(* ; *) (* add_reserved Reserved.provided *) let get_reserved () = !reserved let is_reserved s = StringSet.mem s !reserved let rec to_string t ?origin i = let origin = match origin with | Some i when t.pretty -> i | _ -> i in try Hashtbl.find t.cache (i,origin) with Not_found -> let name = try Hashtbl.find t.known i with Not_found -> t.last <- t.last + 1; let j = t.last in let s = format_var t i j in if is_reserved s then to_string t i else begin Hashtbl.add t.known i s; s end in let name = if t.pretty then try let nm = Hashtbl.find t.names origin in nm ^ name with Not_found -> name else name in Hashtbl.add t.cache (i,origin) name; name let set_pretty t b = t.pretty <- b let reset t = Hashtbl.clear t.names; Hashtbl.clear t.known; Hashtbl.clear t.cache; t.last <- -1 let create ?(pretty=false) () = let t = { names = Hashtbl.create 107; known = Hashtbl.create 1001; cache = Hashtbl.create 1001; last = -1; pretty; } in t js_of_ocaml-2.5/compiler/varPrinter.mli000066400000000000000000000022431241254034500203050ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t val add_reserved : string list -> unit val get_reserved : unit -> Util.StringSet.t val create : ?pretty:bool -> unit -> t val reset : t -> unit val to_string : t -> ?origin:int -> int -> string val name : t -> int -> string -> unit val propagate_name : t -> int -> int -> unit val set_pretty : t -> bool -> unit js_of_ocaml-2.5/compiler/vlq64.ml000066400000000000000000000054631241254034500167630ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let code = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=" let code_rev = let a = Array.make 127 (-1) in for i = 0 to String.length code - 1 do a.(Char.code code.[i]) <- i; done; a let vlq_base_shift = 5 (* binary: 100000 *) let vlq_base = 1 lsl vlq_base_shift (* binary: 011111 *) let vlq_base_mask = vlq_base - 1 (* binary: 100000 *) let vlq_continuation_bit = vlq_base let toVLQSigned v = if v < 0 then ((-v) lsl 1) + 1 else (v lsl 1);; (* assert (toVLQSigned 1 = 2); *) (* assert (toVLQSigned 2 = 4); *) (* assert (toVLQSigned (-1) = 3); *) (* assert (toVLQSigned (-2) = 5);; *) let fromVLQSigned v = let is_neg = (v land 1) = 1 in let shift = v lsr 1 in if is_neg then - shift else shift (* assert (fromVLQSigned 2 = 1); *) (* assert (fromVLQSigned 4 = 2); *) (* assert (fromVLQSigned 3 = -1); *) (* assert (fromVLQSigned 5 = -2);; *) let add_char buf x = Buffer.add_char buf code.[x] let rec encode' buf x = let digit = x land vlq_base_mask in let rest = x lsr vlq_base_shift in if rest = 0 then add_char buf digit else begin add_char buf (digit lor vlq_continuation_bit); encode' buf rest; end let encode b x = let vql = toVLQSigned x in encode' b vql let encode_l b l = List.iter (encode b) l let rec decode' acc s start pos = let digit = code_rev.(Char.code s.[pos]) in let cont = digit land vlq_continuation_bit = vlq_continuation_bit in let digit = digit land vlq_base_mask in let acc = acc + (digit lsl ((pos - start) * vlq_base_shift)) in if cont then decode' acc s start (succ pos) else acc,succ pos let decode s p = let d,i = decode' 0 s p p in fromVLQSigned d,i let decode_pos s = let sl = String.length s in let rec aux pos acc = if List.length acc > 10 then assert false; let d,i = decode s pos in if i = sl then List.rev (d::acc) else aux i (d::acc) in aux 0 [] (* let _ = assert ( *) (* let l = [0;0;16;1] in *) (* decode_pos (encode_pos l) = l); *) js_of_ocaml-2.5/compiler/vlq64.mli000066400000000000000000000016171241254034500171310ustar00rootroot00000000000000(* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ * Copyright (C) 2013 Hugo Heuzard * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exception; * either version 2.1 of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val encode_l : Buffer.t -> int list -> unit js_of_ocaml-2.5/doc/000077500000000000000000000000001241254034500144005ustar00rootroot00000000000000js_of_ocaml-2.5/doc/Makefile000066400000000000000000000047011241254034500160420ustar00rootroot00000000000000 include ../Makefile.conf -include ../Makefile.local include ../Makefile.filelist MLIS := ${addprefix ../, ${DOC}} ifeq "${WITH_GRAPHICS}" "YES" OTHER=-package graphics -I ../lib/graphics endif ifeq "${WITH_DERIVING}" "YES" OTHER += -package deriving.syntax.common endif ifeq "${WITH_TYXML}${WITH_REACT}" "YESYES" OTHER += -package tyxml.functor,react,reactiveData -I ../lib/tyxml endif ifeq "${WITH_TOPLEVEL}" "YES" OTHER += -package compiler-libs.bytecomp,compiler-libs.common,compiler-libs.toplevel -I ../lib/toplevel endif .PHONY: doc wikidoc doc: api/html/index.html api/html/index.html: ${MLIS} api/index mkdir -p api/html ocamlfind ocamldoc ${DOCOPT} -package lwt,ocamlbuild ${OTHER} -intro api/index -html \ -d api/html -I ../lib -I ../lib/deriving_json ${MLIS} wikidoc: api/wiki/index.wiki cp-examples api/wiki/index.wiki: ${MLIS} api/index mkdir -p api/wiki ocamlfind ocamldoc ${DOCOPT} -package lwt,ocamlbuild ${OTHER} -intro api/index \ -d api/wiki -I ../lib -I ../lib/deriving_json -I ../lib/syntax \ -i $(shell ocamlfind query wikidoc) -g odoc_wiki.cma \ ${MLIS} EX_TOPLEVEL:=index.html toplevel.js *.cmis.js EX_BOULDER:=index.html boulderdash.js sprites EX_WEBGL:=index.html webgldemo.js EX_GRAPH:=index.html jsviewer.js EX_PLANET:=index.html texture.jpg planet.js EX_WIKI:=index.html wiki.js EX_WYSIWYG:=index.html wiki.js EX_HYPER:=index.html hypertree.js icons thumbnails svg_icons EX_MINE:=index.html minesweeper.js sprites EX_CUBE:=index.html cubes.js cp-examples: $(MAKE) -C .. toplevel examples mkdir -p ${addprefix manual/files/, toplevel/ boulderdash/ webgl/ graph_viewer/ planet/ wiki/ wysiwyg/ minesweeper/ cubes/ hyperbolic/} cp -R ${addprefix ../toplevel/, ${EX_TOPLEVEL}} manual/files/toplevel/ cp -R ${addprefix ../examples/boulderdash/, ${EX_BOULDER}} manual/files/boulderdash/ cp -R ${addprefix ../examples/webgl/, ${EX_WEBGL}} manual/files/webgl/ cp -R ${addprefix ../examples/graph_viewer/, ${EX_GRAPH}} manual/files/graph_viewer/ cp -R ${addprefix ../examples/planet/, ${EX_PLANET}} manual/files/planet/ cp -R ${addprefix ../examples/wiki/, ${EX_WIKI}} manual/files/wiki/ cp -R ${addprefix ../examples/wysiwyg/, ${EX_WYSIWYG}} manual/files/wysiwyg/ cp -R ${addprefix ../examples/minesweeper/, ${EX_MINE}} manual/files/minesweeper/ cp -R ${addprefix ../examples/cubes/, ${EX_CUBE}} manual/files/cubes/ cp -R ${addprefix ../examples/hyperbolic/, ${EX_HYPER}} manual/files/hyperbolic/ clean: -rm -rf api/html/* api/wiki/* js_of_ocaml-2.5/doc/api/000077500000000000000000000000001241254034500151515ustar00rootroot00000000000000js_of_ocaml-2.5/doc/api/api.odocl000066400000000000000000000006711241254034500167500ustar00rootroot00000000000000lib/Js lib/Dom lib/Typed_array lib/Dom_html lib/Dom_svg lib/File lib/Dom_events lib/Firebug lib/Lwt_js lib/Regexp lib/CSS lib/Url lib/Form lib/XmlHttpRequest lib/Lwt_js_events lib/Json lib/WebGL lib/WebSockets lib/Keycode lib/Sys_js lib/graphics/Graphics_js lib/log/Lwt_log_js lib/tyxml/Tyxml_js lib/tyxml/Tyxml_cast lib/tyxml/Tyxml_cast_sigs lib/deriving_json/Deriving_Json lib/syntax/Pa_deriving_Json ocamlbuild/Ocamlbuild_js_of_ocaml js_of_ocaml-2.5/doc/api/index000066400000000000000000000011671241254034500162100ustar00rootroot00000000000000{1 Js_of_ocaml – API Reference} {!modules: Js Dom Dom_html Dom_svg Dom_events CSS Lwt_js Lwt_js_events EventSource Firebug Regexp Url XmlHttpRequest Json Jsonp File Form Sys_js Typed_array WebGL WebSockets } {1 Deriving - API Reference} {!modules: Deriving_Json Pa_deriving_Json } {1 Logger - API Reference} {!modules: Lwt_log_js } {1 Tyxml - API Reference} {!modules: Tyxml_js Tyxml_cast Tyxml_cast_sigs } {1 Graphics - API Reference} {!modules: Graphics_js } {1 Toplevel - API Reference} {!modules: JsooTop } {1 The ocamlbuild plugin - API Reference} {!modules: Ocamlbuild_js_of_ocaml } {1 Indexes} {!indexlist} js_of_ocaml-2.5/doc/manual/000077500000000000000000000000001241254034500156555ustar00rootroot00000000000000js_of_ocaml-2.5/doc/manual/files/000077500000000000000000000000001241254034500167575ustar00rootroot00000000000000js_of_ocaml-2.5/doc/manual/files/performances/000077500000000000000000000000001241254034500214435ustar00rootroot00000000000000js_of_ocaml-2.5/doc/manual/files/performances/perf.png000066400000000000000000001242141241254034500231110ustar00rootroot00000000000000PNG  IHDR8/q sBIT|d pHYsnu>tEXtSoftwarewww.inkscape.org< IDATxw\ C"8ֺ:*VպڢhTԺ+=lu 2 A|<|<ޗ>?#̝;ʏ%%GU9sH,,,$oVu* XXXH.]Zn\^^A)]VTT$YluSSS$00P_iȑ#%̘+WJ,,,$Ǐ.ҥU&.++KUeU7 СCUJ+wl߾͛K,,,$_|EաCIfͪ8 *?V޽1y*?QUAjj*D"S\>} 6o>$&&gϞeÆ ÷~ 90w\tU7dee!55AAA~z1yyyHMMEaatӧO&hР:T9U%233UJ+wKMMˌx"]!==]Gԕz_Q$:JQ3Xh:۷! UJ&akNikiѝUgĉGDUQj7M :99]v8}4n޼&MqFB1pUرp4nرcoߎCP u7JiT ;ivEEE_MMMgΜX߽lff&RSSTIn܀$=^ UgQرcΆ;w,`. *p!!!_>,,,ʍOJJƒP^=XZZ;wŋptt1```@"%%nnnPWmC$%%&&&:B#++ 4\Lvv6455,ZZZDl DVVjժZjU(,l?4*[8phhhe_s"PWWG ʌ}`ll ʬ˃D"qM^#@FACCB#qMD"8;;C__Bۑ<<< xyyݻҸ;v'N@akk-Z@jj*Zj[[[iظqYv-lll oooԮ]:uBrrL N &&&ׯP466F||<ܹccc̜9^mɞ={c [F͡ӧ4^wcccl͚5C:ue}666h׮4iCCCL6Mg}N:a׮]011AfPn]4iؿ?LLLмys $ưa`ffwwwh666 >H!vD"~˖-5jtYV'O͚5ŒToѢES~g\zUa|vP~} Xd qy|(֭ {n|N>ǏcW^E֭aoovڡ^z燦M󰲲B ТE cժU066ܹs HyA__nnnΝ+v+++x{{NNNҥ TqƗ_~ KKK>|7n+p xzz?>f͚''':u /_СCyf777.__~݋ŋ4i\#:`hhh`ذa 믿B ``io8;;رcAHHgϞoذ?#̟?655ɓ'akk {{{>>pvvΝ;qu,_Xh/s۷ocȑ֭[ر#0|p;v ~~~E```ӧOlݺÇǵkp!4n'O.'"4hqY6m%>Fa8pƌ#G`ƌ E֭+ׯH$̏ Ez-}4d>[FFF4~C`` <==qyDEEÇ!00&Mmۆ7n`ƌXxkf͚CCCL2}􁍍t]Zлwoi7WܹvvvRRRЭ[7$$$`Æ y&|'8rL'OЫW/t֭[mmm7wD"رcn:|wXdt݄ 6m`Ϟ=~:1{lL8`dd\v #۪/22)))eH???ɓ0224ifff8p fΜC,c…prrѣG]H_aX|9.]l|wo-Z@^p?^. b׮] ٳ'n߾ 6}8x4Epp0O^q'N6jڴ)_c޼y nSXXoiii?> ={CсP(D*ŧصk|}}/H{yy!33SZ\k۶-<gٳlق;bϞ=æMpww9Gz/kCطobbb}tCʕ+eŋqI5JbYfpqqAÆ iӦ2U֬Ym۶]v.]B\\f̘!xYt~ ֭[uɮSAڵ+ƌkbΜ9?~F˖-_rR`'??W^E:uی38z(7n hܸ16l͛o)۳g&uE=pyia„ Dرcڷou`ff.]`_͚5CxxѲeKVW Μ9#kҤ RSScǢM~jhhٳ Md!<<~~~v+}Ǐsݲ]]]ggg|7st|̚5KP(9"x7|5k ((HZLL ֮] WWW˖-Crr2V^ 4n#F۱uVϼ͛7CKK  b w"%%7J 08qa :TT("** ENϞ=˗aiiϟѹsg%ō%UؒDǎ+nʔ) }^{zzɓ'%֬YgϞI.^%K^u&oMMM4o[[2rtttģG%jѢ6mݻw<.i'///};v\!РA m۶e7LLLdDFF"##CEEEYZ(akkݻw̺W[VH$?~~8b1&L Q\\ӧOx[۷ovk}ߏ> &&&,pPׯ$I)XHDhh(|||P^=m۶//?H155YhDG(o;o`Mz{彿^w2 K>mLL &O:/ׯ555AE׋mEKyCfflaa!v܉]K+V˗믿bÆ ٳ'.]ׯѣG2s> +7ۨWCaaaΐH$HHHxcBll,OΝ; vvv2d޽ D HIIƔxZu]r|wrҥ KWihhGΝ;RU~xiyX[[]2K+jÆ 󃞞ߢm۶AD_^+4ѻ/1}tlݺ9~wdff .Z055E~dשSݺuf tcƌ5kXlpo*rHT]#33Sz(zakxx8Zj cǎ7ի'''@NE9bo\N~g̘!W(C֊0`֯_ؿ?NZjlIoz,jjjX|9ٳg̚V̝;k.u...żyuVk7o2 T!%xɓWb￰@ &%%ٳN”)Sxbx]Ɉ$Xdݾ}ݨpܿ2'OFڵ1c L2vLkG¬IJJk1w\c*މ z 77[n\x9q%PXX(!ѣXxqkoouuRueD$R)I&A__2 . jjjԄn޼ sssBi7o}(i5ѰaCHsssq޽2 ر#ͱ{n"'')ڰKjSo k.,Z}A֭4kLKff&?~,888Hǖ ٳg1ei]TB۷ɓ'2mۆT|^9̰eD"i\qq1f̘uDEY2Fʊnnn@XXt k֬A~~|J={Vn˗?zzz@1..]*\"H,yĖQ̙3 ELL RSS;;;HD"J*>wڵ_!** ~~~(((;!Cȍ[ƽ{}rKӨ[.,--6IݻWa|I"ԩΝ;'7%+Wpc) e %6jb`nn.JbFtttжm[DFFuM@ӦMŌ;^zXz5ӥq2/ҥKe~7ѤI)e+J(o߾8vТE2/G,OJJ޽{$ӊmc^()u-kƍL&#GDzz: eƉc*DCCA6mc={ѣѼysH7oѹsg>>>\*..\'Owƙ3g?`h۶-f͚%X,-[ԩS7nt -ZHlmm']aԩ|||CűcpǏGPPjݿxyyaSӂ`̙3^ ܸqƐ!Cp*VY7n?O^}a)<, =ztq!!!'|ŋ#** AAAbի6QЩSR, wٳ|r["44޽;֮](Yݺu\HJZw ڵkK+tuuѲeKcƌƱc0rHoԔZt)йsg,_gΜApp0FMMM,XM˖-Cvv6<<<ٳgYfيJ*;88`ʔ)F۶mgDDD`ܸqظq#\]]K*"/^/FFhh(Ν;M6صk[͛cɸ}6~/<=OF׮]q:t#F)-o߾000͛ѪU+4lP]T*@C{:O\?sDFFb)!'`ڵ2CGG'O6ܹsiӦ!>>7n@J$-- _}O 02NWallI&I]6 5kok߾=\\\0rHD"Ü9sd&Ncٲeg}V%WGB_\-7ܱc~'JPoР.\ӧKpQL0/… |pa4m{n 2s9sS%2dPPPPʰm6ԩS+WڵklgtԩJ UgQ3@ `Ĉ3gZh77R㜜p93FO#>ݻuTA B<G"118uuu`ɒ%;w.ЫW25j+WcǎX,>#XB%@h-oxN#F@BB-Z$jР~֭[1x`#88;w͛71qD8q044Dfpecĉ7oooo~{SN!((V1[[[?zzzuA``@ _|KްFJJ Xn%_ӦMCqq1ЪU+Kg AAAػw/,Yxyyaʕ_>ϟ޽{x95l0ʍbݺuEKIlGTLYaͅSdee!99<0JOOGfffMB!:wcǎ!??>,s۷OL"]cHIIKMM!""[pB/q-XXXȬ;D~޽x9ڵkZja駟ׯ_Zj]vJϝjvQ!""*o߾;v,~W4o8wCCCѣG\t o֭[ajj3!""NM"HTW^exϟKIQQ 333i˗:VZ2IMMŹs  ++?)"""X """"""cpQA믿ݻN^3`vdc̙HOOWuDDDDDDDT 8ނ@^:DDDUI[OBPa(+!#"""b;mA8ڷoSN: ""HIU } %dDDDDՑP(|"/Qx,pQx,pQx5j@\|u?3ݕU5e<~FFFrrssU)X C oTqBDDDDTԘGVVݻqaŊNTE$8,BjPcPcxxx8"""""""njL#::G^^nݺgϞ8+"""""""jTCMM -4i###tNTƌ DXشi>#Ɩ:hy p=quỷ>LHOOWʱjLc޽;fϞZj ggg̚5 ?#-ZFt"++&""""""PcĈJ9V)p|ҤIq9%gDDDDDDDDE)pE[[FFFHKK{mw^qA(Q666o}QDŽ yɬ@ff&ZlԄeeIDDDDDDDֆRU#&ԩSgΜ… q}uK._Q5P# QTTO>k֬ٳg1a裏4HEjD8q"B!_tuuPBgHDDDDDDDRc 0~x?^iQ5S#"""""""X """"""Ǟ={0yd|g8{,?~+V //O)$7'OЧODEEI 6 "ǏGXX;ڵk+5Q"""""""ȵ5j\ɓ'ѣ9r$1k,&IDDDDDDDT 8x V\cӧu H$¶m۰vZ)=a"""""""ɴqǧ z|TmfDDDDDDDD$S\~ 222͌d PWWիQ\\,3,Y5Ғ$"""""""*fff D`` 0p@@tt4l2ܿRIDDDDDDDD&v̙DFHHয়~cٳr$"""""""*\C("((GŋPm۶{G [[[OR nR7Ƙ1c41"""""""+pL:/.w#SSS8F:X0NС ( jBŋ ӦM54446*mQMPr%PT0N hj*!# 27o6n܈6mڨ$71o<`ʕNTH P%ɼݻw#00Tu*DDDDDDDb2&MVRU>CBDDDDDDDR2]T͛uh׮LMM6 $ sss&7Jhh(˗/ 8}4Ο?#F ;;[%yQ!SHIIO?ggg5 ͚5+uuuRܸq3g-[$"""""""~d*.\?WIBe)((!CYf:""""""zG]Ǝ Fiݕd2 ULyp]DGGWZ 7n{ ^)$"""""f q9JȆBdd$/^\XDNǒ4j-[Ă jzWH,_+WD+mPghhXi$""""""P<|B+L#''_}&LwwwhvvvҒHGGӧOWJ0e8}tQTTsyWa\u)$={vbΝN8d =z4 ..qqqndjj:tttpQ幹H$8z[ͦRn7.QŸݽb̛7 ҁFS*Uڵk.wuuEvv6߿|z)phkkSUSNA(m۶˗n6m(!="""""""";v]]]"11;vT)ӕ^~7: """""""R1 @SS`aa (HGG󪐖-[:"""""""տKSXXwVu^DDDDDDDD&3 WWWܼyn0uT[ϟ?@ PJDDT=}ÑǏcܹ`mm-CCCKESѣGNU عsr!"""""""z+j<8cj<8cj<#!!Ϟ=H$[*O" 'O/UQE81h NNN֖HGGGi Q)k\ 8^T,Y&MRUNDDDDDT&"x)q>зPBFDDDDDD!ShԨ TK444$ӧt4iL( 77+1n86lؠ⌈HK[x}x!}AHHtuuƏ8H$+@^DDDDDDD*;w*SW`*I!99׮]PD"yc8\;"77 4@׮]QPPx^7oÇN~ΝD"ƍpB2sT>}(344DVVۦKDDDDDD|EEݫ8NC 'N#d߯)pD" 6 ?о}{bo0uT]V) dөSG@@GCC&&& *O""""""6,,*6Aj #S={7#!!{+Rd(,,r___ "" }N:UYQ` o},Gll,7^զM,Z033{XSNYWuJ)Qp5*2y񀽉2""""""U)p @^---W}vaÆS?K.u^v9s&o߾JˇT/ 9=/zlHd 022ĉqQ X`<==! Mйsgt}Aƍq_>|8 DDT<~yy ˈrc4 ^d ;w.&LGGG(,,Dll,!Hl2'ڮ];\~?Μ9#Gqؼy3|Ẽ$>MT׽Qw8:(!#"""Isӑ>5 EJʦz&v񰶶رczju_榴_}DDDDDDDT}8YIII&`gg555eHDDDDDDDTR  6%""""""M}Μ9̙3\RF:::>}zgGDDDDgHy0LfJȈrAWW3gDZZndjjQ kX~Qaܷ1q2"""\.\N .(HCC"R:c@a8ZZJȈ*JSD"AAAZl ]]R7q.]eHہY7 DDDDDDՌ?ѱcG$&&uÚO/#GtҥKaff&]vvPW/s""""""""Rwuu_|<°7PWGpp2r#"""""""u;;;ܾ}ǧ~~2jjj0449A#"""""""R>uXXX`hӦ LLLTQQ\⊴rVWpڴχ$31U QT\ ɥK44>"L:u믿VYRDDDDDDDDoB]v!4)"""""""7!Shذ!233͛7WZDDDDDDDD8䂌`mmvڡo߾:t($Qyx׏??^1u! PTTmmȩL"۶måK'''-ZPjDDDDDDDT8 pm XL;wVBÆ a``$ӧh۶-bccGGGٳ!!!7ofΜ|>T!S'0UBFDD8ЬYr7ĪU4Ҍ; ?Gǎ>4k׀,Ł/^ADJ#S077ٳK ҂>s+%8x 1yd/iذ!f̘!C,pD xH:""d kƜ9sEEEА{,--v"XF:u2"-3WaMQ-L =0o&X42"""eV`ҤI?q3f "" .R/aaaOOOetj"@"QY{M1dݻM6X,ѣG1j(B*;W9'v܉MbРAN^#>Wmj "w"S޽{1at?~<СC̙3GC_~Ulͷ߸qݻwWIŋW(VR)pܺu bc]o011y={`РA011ADD6mVDDD8CC÷?\=TW-*!#xa~wW V-&*æM;;;DFFegg+~c팈?o*۹{UhҤ f̘Qwj!Shݺ5tuu1|lذA.ŋXr%:.]ɓ' ;?s%eGDDDDDDDGbCBB*Cb͚5_sp]GeL4 :tzE%44baaa|:333]}UZ)S@(O?Ş={b֭:(5AqH8iPQBFDDDDDDD jڵktRڵkH$prrJ Ǔ'OSL)5_~,pT!wOq܋U QY % OOOeSnݺɓƘ+)"""""POX8ҥU )RfcϞ=B||ct˩]F 6`֬YXnғ%"""zh߹ |qjj)!#""Obʕ;v,>}*]g``0D"l۶ k׮&""",6FLq+fkj>Ǎ7>>>enУGl޼)))숈$p^9{ޤji4g""6myyyҥKEaa)^;H ?"tfa0rp( oo߾Iw!BA!!!Tn]`aaHӐZ6;D#~;̎ =),`0̛ qp<DThQj߾Z--\Fe1#=K^N!},`0 0 0 ٳgN+W: qu֍ݻaވ'nҔ͎yee3 X0 0 0L~B&WWWر#ߟ,X@NNNDDl25jsaaaNM%^kv\G)F* c7H… ӥK|ri4gڻw/)S֬YCk׶ 0 0 0pJH2;[nT,b=W`Aڲe [ B 4 "ѣGӔ)SČ];D/͎\c,aaa;En`zz:]zRSSI&ԽOZ8 ГN3aaa_28=J}[nQiմvZ1cUPfϞM  0 0 0΋;ino 0L u5lؐ߿O3gΤ#GPɒ%iʔ)t1AQVe^'ORFFMaaaI/g2}!PJ?3URE2VZE#F۷[HSDDDܹsTdIk0 0 0 XfXHtYrvv69ՕVXA}Eˎ˗ܹsj0 0 0 c[컺/G7_Ģ G M[:!!8]F;=31A/st2R$,eMR:cZu-<;OHyj~M6CifǍlAT/h a^)M{9x>`~MA9Vؿ8 fܔS<8n "A}IMڼ7&8r"{PTTŊ&}n {c<>-ޘ<N]>jq(-pY0 0 0 0 DDwޥwrIw[0 0 0 0 C'NxT<0 듳Maaaa(¬m[1l06l`aaa`Qaaaavp0 0 0 0 caaaaGimaA7u*QZq ,`0 0 Xvp0 p*Qj:]0 0 0KTaaa{0 0 0 0aaaa`H+W=deX"aaaw x2g55aaa&aaaa2մhqal4=Hdvlaa&9y)iv\Ig{^`ݧ3f}=,` `+rSqA(1 0 0L.pi2>kvܝ'y_`0 0 0 frY} 0 H8x&cv\/(0 'f72,` ?X Eݏ7;ɫ4 X0b|t:}qm\%'/N$ 9asa"<-` ?+:u*޽RSSv4d[Mcr@\RF&)-:PbtN?+^&i[fǽztxB4^q{*aaa؍#995jD/^N:?m߾>#ڶmh&2{ɣ9?0 0 0 b7-ZD.\UV/B}:uiРAm"0 0 0 0Vn28֬YC>>>ԭ[7񘯯/ 0"""hԲeK+Z0 0 cy3b4%h=U:?_iB:]I0;E0aϟӝ;wSNRI [hAtIvp06ZtqK0FSbkētN0ww :OiY:&ҡ'fݏ} -]U>{}gyBa7'C k -W9v>efldLJ<1cKqAm8zWϟ[&Htɉs?O6;.o'24:yncND!9]l~a쇳w_Ҷ͎{Ͷ]882ׂ3/t2 ü 1q)f=M5 4L0 0 m9>LM4ӧӸq$t:)JjԨ>|8GKqqo(L GwtZ-iuӣݔZrR"59f(WZ-iN$3;(N!smM ԜEgswnҐ.9}sz_SI17g&{c~ 25WkF:i2r?73H#uF)}}4}ֱ+ǫW r}ӧO'N/P(Td?c?5kЋ// ZۤRSSiҥ4`k<+eWƞٴiT*9s&uܙ֭[gm۷͞=j֬I;v ,'9 _5NzԫWu=Kx{{^9y`[ۜ<… P(mNx{{CTl2NÒ%Kʕ+cܹjVݸx" ( ^o&SըX"T*>|hE+sHd2gbccŋ#55)׮]RDJ>}%Kb׮]6E=e6%8s N< ZmmsNH9s:.]#d2q}kg2 D'NX$4i$zXrH hm6*RiϞ=4rHj׮M,\tB&M?r9-[4_QVS ̗(Oƍ@AAAv҅ݻG]tsQFF滈;5hЀVXADD=P RnH.SFFm߾Zf8Q &"XR .\Z0jݺ5mذ\]] oߞ>|H[nB… [۴ﱲ卸|2*Tyƌ(T:u@.vf7oΕ+Wh;BCC!PlYXۼ\ѣo`(]45j@\\Ul"^/J, "G}$kj D+Ve˖(_<ڶm`ٳM6!>>־=z5jԀB P~}|wHHH@BBd[UZwc3WWW4i'OB&^zx؃Pjٳg:tOMM5m^x ^8wr9P( ")So߶yAD ѥK(JL2ڦ:+VM2 ;wi?M;wcǎ " 8ڦ:=zL&ҥKyfhDoڦ:>+gl2f5hѢpwwѬY3<{fY rp<~gϞEbbMw<~X^v-d2BBBRdN,m; "|W@Cʕl]Prer|wbZ www4miii #V^-߿?ѣG+Z8pDvډߏEPn]g ""?RaȐ!ŕ+W1Drr2)LkB"##ӦM^0r?/_ѢE ӧO.]' jK3޽gb̙hܸ1%K5j"ǭhSn]ƏF4ر...(Zεw/^,: 6ƬY2 V^˗ׯ[ۼ\O>IG"‘#GhYSV-8;;ϰ^G׮]!])Rn@Dضmxbb"]7oZɲg„ "̙3Gr<557ow6+v`rhlٲO6D={DŽͤe<رD/ܬY@DeEGNVF LwZg ",Z\׮]oV4 ʖ- '''{ oooڵkHOOGRxyyI2,+CЪU+kN|W "L0\xx8d2?nr!S@#˗uVZ5jdeߎst>>> "rTR#FΝ;Źi "tV+~ѹC{n+XFIV OOOxzz" _d^5JtZeE`ڴiԩ>3ر Vk֬aÆ6Пl̘1C mӦM "޽{v1 d24h@r|(X\2V\j\z5}'RJI TR5kk.\ɹ;8̛7OR-ǎ+>Ba4ILN4Zf(Y$T*ɍ)6tZ3fBd ٳAD8}] 6ٱ`޽{i&|6l@%PX1&Nh%ߞqƁpB>HMh4(WT*nܸa S߉{d/^* O>uBD(]4P(L^NCժUP(ekߍO2 *T */_MOOG%lw(^8L~ ">|X-i;߂0}tsO>3/.F'|"E.߳gOIm۷oC.f͚I,m;ӲeK~wSRRrJq=x %M}'P(п֭[УGƍQ|yZzזi4 L&f"<<DѣGM4A۶mѧO2+6y׮ڷo_ƌ#9.8lӧOиqc^ADh߾pwqq ;8sQFIkZ?bc-l&7m$[~;;bccQ@Iod||<$3... Pxӧ@ѢEM.̭ɵkנR@Dؾ}T*T^@fQ޽EU"ƌc3/8~h .H^z:"xBEK4G' IDAT-2`֯_/9\sI 5Æ P}AXFFBBB$:"|N:vN_hҤ /̱͛DOOOL4SLPqS;dzw ӹ\P!ʕ+aÆ "9fxxxLe?zHZ* 5k0sLK%J6 V92ӳgOrB&I%]v}l(p߿Dm>))ٳdSN^kŅ Df͚ٴaDDH0~x.]$+9Rh;v,ß9r$U_OYG%m6EC([*ϟ5GסR$: EY'8Lݻ_>d/.ƍ 2ݽj ۷/۲NJ*AR|?66BL&wM&DYE}TIVHxMHH-[Vӧ "IfrM4iDR' ==P(f$&&Q U/^AAAVO:wj׮-i4ЧOhZzԪU d'26mj/^֭[5jI; ̟?D;DŽ2={MII1ݻXv-s "֝;wPF 1@ LKfddŋyn{n$:tJ7 󃇇~ ,'''?^/Ppa+V*申gbɘ;w$Bggg4oL"B޽%Dž>Y)))(Vʕ+gx^ǏoqYܹs^ }|JJ d2ZnmV#G`„ XhA%g ={|ttɲ[c D/;ju֕dMmݺDRFg:[_dzg&s4hEE:u U͚51|0ӿ.\ئ[U Q[5)>)QO2Ҧ3K.Vk׮!44x!b K+h4uR  nGAD +\~(QaU @9ZB 23#<<

>>˗L&C߾}yfL0=z4ҥKۤsG06!!%J8_^0ĖEˬ@J/ܹsAdF֯m۶ "*+W 00ݻw/<%+Je˖5zt:5jdw .4-[I')PWdItd Rj)Y9wн{w:ˮSL!2d9A@ĒVZa>|8\]]Q|yMnmJ/ /R:1,I ͛7Ѯ];899APN("2Ҟb],\YfaСر(nQbNrʡ|FA7PJҔJet_ "BjgTF#ts&$ѣXt)V\i /^ѭ[7q5\Or|<==h;w`ڴiڵ+WWW(J1.99 lURmpv_lovp0fFvo>ж0P?P(}G "q?޸~xl޽F%_nZTSuBz۷oRSSMrDDx|ܸq "#w>@mB5:e˖Eҥ%qg$6f^x!!!YGǶm۠T*;wXۜ<#55@*Uc۷OժU&oUdСbLa̘1 vwʕ+'v ݟ mtj|ضm8 vRUs$''aaaؽ{7كMШQ#-)))񁷷k 0ҩS'ٔ;vL&DY322PdI?!۔ӧObŊz^8cZPנAأGзo_)Su}m8,_*QDܾ}[Ա64l>>>w777룭[A,յÇ*U`Æ ؽ{(#:.ȿ+hrktt48 <<\5k&fvk a6J2qppn:l Yn].\/_ۣdɒh޼9ϟo٣^\.G׮]cB73!kYxMe 2rgKycL e E,[odWWWWj u#Bɓ'ADh۶322DѦf͚Y7֭[ '#G"88DzImڴc{QѦ7M@ , !C0l01 m۶EXX%ߵk憝;wZ7⯿B(;nݺ% eu;:_}:u)r\0 ;F ֡C?ڵ lRL7::+W l"o˗"^R)VO:dɒu V"##ADhܸIG;ĿϜ9*.iiik,r(QBy2%l\xǎdGyfYFW7Tw:u*2eK.bJϞ=Qn]888 ((ݳEW\ѣGZsy סRlV`7>>+&O2LR߳gO#+*UBƍd(P6)uaԩa <`LBP~%''J*pqqa.B݃812.8b7n,Y'fdd $$DG fve%Cg`I ә!ФIsqqq8vQVdÆ AD8zʼN%H࿬2õӧO'''IQpaZ! ԰wvB׳ѣG}OBB:udk&ҧ-ZdtN-Ҽj Rڵkڶ7oVX,ٺu+$ΊիH"& #FX\#zz: zVÇPjUI}uDGGGGiƤZ1cǎEzzנAhߋ ...ԩauA&z+xa˗/CTx,nIә|؋ cnQF k c`ɒ%Fm5Heс'oJ7?p޽{-x.X vp0yFBB-4Lq"Bhh(&Mׯ|C%!CtRk]Jcܸq([,Za4{⧟~kWXGGG(Q/^4{A ;w.jݺuѣGm۶6BtR@c̙P(dV IDATPɺuց_o |}}}BaJ=ЫW/K^Èq ZHgB0?H2;nݺ"E 00ϟ?'Mm mvpURRRзo_8;;k;">>bccV0J2:-*i, GGGh4(^QNd ŋlj'0g|GBٳ-m>ƍ0`6mUV NCɤ?R LL\֭[ۤtJJ jr͏]5j$ nڴ 2 Ŋ5 怜Quf5  8Pr<%%^UyFYfӓ'OPH8::ڔ ;8<˗ׯp~%T*pm@# .]Zߺr J%tR̟?o߶eeK\\\]]%J!jݺuivBs 8 Ku,[7oބի3f`Vgdd2 "è&\`ĉ ">}@fk׮d\#LdhӦ &NÇtĉ 8d ӆaƙpUgddQF "lܸ$''믿իϛLADXvѹ7n@P>>İarabK["11׮] 3gy- BL:u$櫯ٳgFΝwjǛY{qU4hbj.ɪUbԨQؽ{Me{B&!$$D,M:dA׮]qq >|JhР ,"B"E0b1K k%---d3%>|"ԩSE͛My9sL|ϳ8jwF߾}矣A q9s&ӦM3 Q}vHjkժ%.:.\"ѣl黳fFӴiSQD3g-en͛6""DYfIA&f͚&ߚ73 5j.,9WLOO/mB{ѣٮ4 ,X Cϟcԩӧ~FDDKGңGF͛EAl899lmt D]vȼGQPLQDpddd`bYPP `cǡC@D ׅXB'`:Jhc(P2L."Dfp9swF?ĉ +..^^^)Aw!-- wƚ5kD4 FKRt(]4 .Dɹ;wd, e._kf@ףlٲ.]Ν;纽yMϞ=!0b>|7oFj0|qZFҥ%-oܸ!:]]]"_|Vz󚬙:[ $''b%QEl-:w "r YlHҩ[n l3;|L0~~~w}"]f vp0V'99Y[-_ xϞ=+ ʕ+'v`lfkkD{Z^BddO>D"N)`p5pqqaQ!)) N.88Onr6XL7O.:(?ݻwǏx/UD 1tСV2vX;\uE+Q5,( Wңif~y"s PTZ=p^*a([.0|~'GƲzt\}_ב#GHJW~-ZSSSIJ| n߾ ʍ&33j=QښJ˗ǏoK);;&_(>3:88UV q?HC4(%%%?LkkZҨVj*)ƍ]vqׯmmmuҥKjwߔ}*((hwEgb831ЯYk׮mEee%[nmDFF-,,ئMVUU!III5ITRRBgggnZlSO׭[WyFIKK oǎ޽{IL@rI;;;%[G-===Bn ʽ{m۶nݺ)U"y먑5}||j}~$oqttGy4(..6wXhpXPP@///ܼy3]\\z?00,,9_N:qfZSQQQٶ{2d{5!ZHH-,,jkZshgg+ b:991((eeefk-(yyyz*l–-[RR5VxxQ _~jE "C݆|immmsNj*cTTlݺ5y n޼mڴ#~_6m ݕ8+W$~'&?~<[je4V]]Z\6E'NK/{qqq {h$!CŅ*J/ݮ];޽oZR=Њ$ΝKFwsssNh4;gfxx8%!N}jZ~km2eR={4yFԯxݹe||CǏZ6c_&++hRcMZɉzEEEtvvVˣe_{II [h (cSN5YpvDkzz:{EZMJ@BKA+++ qƍv؋/H @''' .SNLLL]v?c;v(:;F)c/25n`!D# hz+gg} >Fũߒy?}]AA]nqq{,9+K?%$$jhpܹ.믿q7o'O̮]Ɔ۶m3wxwئMvY:AqF̰vwQVTTDKKKW3K/dt<$MN:5YcƌZ3vZ z)(( .[̌+B]֑#G3g47˗Iֶ7J>BOƍ%_}Uw^wΆ*0ݻEI4_~m۶ҶvK.%\R={nݺۦRm6`6mvTUU188nnn&`7999ܹ3͍NNNJц=e׮]M>fHf:|J4VKKKK x9{\]pҥlѢ2dsssYRRBKKK011:t̙Ë/2''pBs/C7HC4jJ˗sɴ`XXR9--8bĈZF+yhRRRǖ-[r͚5xTTwݡ1x`Pt:İwO<۷uaʕ+WxAe˖WXQknII ᡴpܵk]ѣQthJjbOe0qDoB-//۱o\f Ǎlj'rΝMի FY]tQSÆ #N>7n˗9tPnKVUUœ'OuoonvUVVrŊtpp+{9G}d$8D_O>ʇv)bOKKKG VZUafDߧ3wnvzZfVVVǓ< [ އ{)S.%"iӦ7l@V!R{{{3!!+:o߾z׃K.ёC8p@y+b VVV*;nB?8/^#F]\\;v(; |8ju"\'}||8k,$oر#mmmWڲ2UV={6۶mjz=٩S'G9¨(3D&$!K.͍nnnF EhSTlٲ%U*ܸgϞZu;udggsE>޼y6+V-ZD֖rիɻAAAtwwoDHqwR .B|7ڵ+]\\nͭ[G9c̘0a <Ñ۽[}̙F\b{`Sioo޽{s˖-ݻwwejZܑ­[kS8cƌ{5"GQQٶm[ Cў={68ڵQooo9rܡ !Ip&ʕ+&LHުniiIooZۡO8A|הUV̙S M޽찈$nڴIӧ2((jZ dPPϝ; >&]V:495jrtv6lZѣ5j'Nh,>>!!!T5"ʕ+ }LJJ2fe`/ݎQӍ}aǎMT>!NkkkAii)[nVZIrLVkBJJ ۴ict7W^7xbej` ݊a'''ǎ[ !=R$hFƎD;v ///X[[̙3PFo޼_ĬYzjL4 AAAСẖL-X+WDNNqN=z5j˗jqa`ȑغu+ & ##qqq8q9s :vh򱚚;wFRN͛7CNN 440z?BAA`;u8q L:u G!jhvjjj eW_}ѣjjj`oo\p;wݻѡC_@ii)agg 6 00'Oܹs S^GNl2!)) /z=ڵk|t:J2wo(//ڵkZBxx8/_%K_7bҤIǣ>Wbӧj 899[nΖQ!D)B4-(ڵCnn^;w\`(--Eii)v؁_~č7*l!lVСCammnݺ!-- OF*++d3<|[o&\\\Rj*`֬Yx7h\,ZPRRb4?==ҥ {ܹiiiؾ};>sc w}s#&ICrrrh"t:MСC;v`߾}x' [[[T*sDFFߩ0wB4&LxbDFFuχzIDAT]*̟?Oj]<<Ԫ!D}ҥ t͛FJJ .\L<zQ GŰa0i$ 4_}о}{{QG;n޼ PTxТE |GN* =zF3ӣG%}p튋56!$8ovލqzl޼ytd"66O[n4 /_?;wFTTn޼ kkkEhh(bBf$44:u*qIlٲ~~~5jjjjBFDB܃#Fۻw/v܉ѣG|\n:̝; z{0`Nرc1|#>>W滻#11v! Fo߾ < &&MF1wB!Ipļy`eeG,XݺuCPPƏsun\v-兰0?J͉VEjj*fǣ=CBHC@RaBΝF<==oҥ ƍ&4v2ֽ{w!11Ghh򘇇7nիO!S1}tL0G!D#$]TKHH F1 33F`` ѥK!%%K./SNE۶m2xxx`̙Xp!m}B!BBf눌Ddd$֬Y=18x yW^XhSNO)dڳgO+;v$6B!HC!sz*lقG cƌaÔǏ9$%%AIII0`TWWc̄ѻwo)(B!$8Bݻw#""鰰㑓ϣhNȑ#KKK899… ѣcU!BN !۷#44ĴiO?aƍEii)̑#==SNŋQVV̙3xQUUe!BNB!駟O?ӧOc gggTWW… ܘlڴ G DDD~'޽,B!MBѰyyy3p,..?֭[Je4_8Z!B\!ulII 8~8Ǝ OOZ KgϞB!h>dB?m֬Y(//Ǖ+W]߲eK,[B!͐$8Bixw===aee\3F%B!39"osssCXX␘^NcРAR{C!B9!Xj\PN3wxB!SB4Djj*p5 0aaaJQR!B!$8B!B?.%ۉIENDB`js_of_ocaml-2.5/doc/manual/files/performances/size.png000066400000000000000000001560741241254034500231400ustar00rootroot00000000000000PNG  IHDR}7csBIT|d pHYsnu>tEXtSoftwarewww.inkscape.org< IDATx{\?uuu.F%-9klj[da99n6cdٜPP*PtP_]zon7|ADDDDDDL&ׯ_W_nWL9rϟu)oaff&_TsۅL&ǎ+5&77WtAhii mmmo … FՑ;v{{{!ҥKˌFFFBPvN:BP֭[ T1c333!6l(J~hӦu% sssѶm۪JTE_}2Lhii{O庍z WDDDDDDTkmڴ .(**߿1cƠ~صkУG<~Xm |*_fffx ڵko߾P(ؾ};ciii1b+5Ν͛ɓaggy6lëÆ ;nݺaĉ8|pK,֭[1yd 99...u___lݺs/[na8;wb͚5qAe˖111ؽ{7O;v_-_~HNNƓ'O2޽*Ç/1/кuk;v ؽ{7~G@vv6ݻ:goo_DD:Qěo)WJ+tttϹB.1c-"##ѥK!0o>>g---(Gᰰ+W޿݃p=ܻwݻwA8رcvvv%yqAlذӦMSֱcGKssO^/5|հǏ իٳg1b*u&444ĝ;wB>|XBiW[?##Chhh!;vr\l޼_|!}600vvv"++K={V !;w ! "**ڞΝ;B&I~r\ !wB! $455ŋEJJҥ BCCB8:: CCC/n߾-Je߿4~x!EFF8p 6n(x2~x)H899Tqall\jζյZ,--EzĽ{ŋS2uTa!-ؾ}Us:b!ő#GDzzRE_"""""ZB L&mmm_KF!iaÆRN*ttt\.bU0($ԩ#}>}022JJy!rK.g'9@XlBaee%L&444TwJR/K~~x7r=ztSr͛%]SE} @kkk͛ !033e`` "''G{$ܹs#BjTLDDDDDD<ɩRֻqF-"^qqqSNzp-4nܸ2{ɓ'8s \]]all8ܿ%^ZGTDGG}|YXZZh ==2`Wbb"R Qm/k䖗>066F.]T*jNf͚ʕ+P(hٲ% SSSDEEDL"""""""""zꝾ۶mÕ+W\;w==zٳgtDDDDDDDDDDRA@@J3f~J(j:`,X@m~ """""""""zŞ3?\sNŕ{ LMM+'~222Xxkkk NNNj׸;qN:Gرc(((~r?~ό311IDDDDDR8W,[9uMu1÷}encXZZtDDDDDDDDDDV;ׯnܸ'xaԩk8C"""""""""E_hժݻѣhҤ Zn]i=Z_-V~}tDDDDDDDDDD/V%"""""""""zݰKDDDDDDDDDaї5¢/kE_"""""""""DDDDDDDDDD}jP||ZhӧӣW """"""""Ml???ԩSRDFFO|W8s BBB`ddTө+E_""""""""j4}td2DDDAҸĮ]uV`~j.NH4*]M9ii^dїDEE!..T)L&̙3_Ģ{+++4i jyFݺu!_gע"$&&BOOGA333\zڰSYϟ\.Ǜo ==Rd2YMBHȮ𼗝Fߓ=}-pQ$&&]o֬>|{_~]t-v gggXZZb֭*qSN5^z8~8N6m **J믿`hhC???$%%ϝK^T>_pv;::"%%;w>>>*q666pwwɓ'QPPycїhiiO>( <xw(4j"##+B[[[/JZ||!-- d*_gΜAAAn߾\yыa{""""""""j?㯿a``r۶mCff&ۇ7oQFd28_[[[ (,,,9MbܸqzDDDDDDDDDvaȐ!%zvvvv󡩩[÷xntHq?DNTڴiӠP(0g(Jdffbjkܸq077/}Q5yw<-^tIkFiӦݻ#336lPMKKƍall:T S-[ݺulܸQe<<<ϗѣ޽`hݽTu^ǹs''NHMfͰpBL:ҥ \]]W_\.W)N2?#ƍDt 5kw^hii}]̜9}T*g=z EJzBݱzj( /_ڵk3gΝ;v`Ĉ~:<==q5Z 9997o^I!!!CZZ4ɓ'cܹxMOO+'''L<ԩS*k>ݻիWoÞ={077ǥK g`ƍ9rdދ F|R|U~8p ppp:gb޼y066ƤI\#44`ff===kի܉򂗗p}( 4mTPbF~~>bbbT*jYņ fff,'OTׯT*o>!&&Q;X<խ6gz(** A!3fʕ+1n8̙3E$NcLDDDDDDDDTԔzE&IMMr̴r%Jr̛7Oe<00 \֭[P(,kWSPPPgkkkaƍD1lذNʽE<<<ʌ;uHLL4e|g8q4W"""""""""}}];wػwoa9r$1i$ܽ{;wF|||s5kףGӧ… +eתۭ[79r8utuuˌ5jбcGtFFFHHHm0dȐ iӦrݸqE_"""""""""/+WVZAn#G@WW\]]9ӧO r9:u?*B(חI&""""""""׏a-**+._ ccc\r/wd+Sll,JeQ4uTL:\2N_GGG\|JwޭP zzz5kڵ/ڷo_Y+( VVV*_666ԩF-ՑWS/-Zw5+] Dtt4lmmq֭2OKKKCppJ˖-S kנ ??I^ iiix!5j@T"..֭Cp;tP|ᇕqHJJBJJJMAʶwի݃fqcǎa044Dzz:`ؽ{76m -- W\\.!uq""""""""$Α:r0ydӧkVVzI>QiT:}]mLP|e7n܀aMMMall Hcrn݂BCCqihiiI&رc7o^kk׮h۶-;$XXXѣG˃Zռ<|xx1Μ9֭[Kbݺu= s1tP[?DFFLLL_7~xI .@GGT4hZ_PGe8y$ J}V:KDDDDDDDDTAAApuuUaðzjn#G :}n݊#??۷o'4hP=bcc<\ah111/JZ稨(d2٩"##/_F r8\~~>PXX}}R%ޗDDDDDDDDDϩN:6mvڅknn///ݻ믿,]/MQQz_jrZV\`*1455UM6ŸqJQrŢ/ P(TGݻwc޽8z( V[=Z˗aeesjq{šC0aA7nE*q;|mmmovڅ'O@GGG+**;wФIOJ%y ܼ祪DDDDDDDDDϩW^Į]~ 8*1* Cʕ+*C-o&իm۶ɓ'RSNڵkabbݻ/_^QQ4h׮f۷#==]eG{.UƣwwrBŝDDDDDDDDD0eHp9$%%ÝBСCtR( 34h[xxx3gDq,[ :::5kϟ#FsΘ2e 駟pUL8Qj3ѳgO+WXh7o=z4~7|BN/uQ}ܹرcFׯ׮]êUyIzÇ?d2^z'|xaҥhܸ1:tv}ر8|0֮] .`РApssٳg1f7NۼyslݺÇC[[ƍ{iӧc̙Rݻ1k,Z 6l1~x)NCC;v1cxb̘1Xr%V\9.]|W={67>1U}?~ŻcJ޺uk#99Yгz aaa͛7aiiu떸7t٩<`̟?7oބ!,,,J\?3  ;;;hhh`ԨQjJC^^bbb````OC`߾}OJUKTX%""""""""D %KtJT˰KDDDDDDDDTܹEZE_ƬYp=k׮Eݺuk:5""""""""zE*cBcݺuXv-pԩ*#11pvvpAih=Өtut1p'zZ_1b6o A^^o~C޽k8C""""""""zUd2bٲe_pY.((BQB@Ϟ=ˌ),,s'??ʧ$7b©=eejnYEZ}ÇyfhiiaAFF|||PXXooN^:::hР C O8>}8{,Ν GGGhkkI&Xt)_~ݻwlڴ 8s 233舉'JÀ>}رcQXX7n{022!>#dee䙛)Sڨ_>F*yT>zʕ+=z 駟k.dffڵkprr4?/2+4M3%\5 KСCx",--aggب(o񈊊YYYB@@"##1` 8[lI 1a4n^^^Xb4iݻt;wիԩZjI&aXz5 R)S`޽abboFʿC [oKXj~w}j ECOOfR<|E_"*q?1Bs,L(""n%axbTAF/4$fWhUQɊw[JJ nݺGBKK }]-+..n݂%زe &LWWWbŊ^%}5!!Xv-;?⫯´iǏGq!b aʔ)?:t耩SbÆ juwԨQ5j  \OOȌJ 7h~~~ Df^ o~HJJz5G- G}2޸qcܿ_۴i Uk߾=}v|dϝ=Z]-Iff&yȑ#k6""""""""zeݻϝ;aРA/\R6fffRF|622,,,T vBܼyhMOOGvv6Q~΍$%%aÆϽɩ\1tPi<d2w}OF-ʵVAAA::ێICC%ɓ'Az`eevx :z+WJ4^_bb" \z)}s߃^~X|9зo_DDDHa\PWyVT:u`eecccl߾y-#3bėE_<%j֬222вeK\pٳgե/t""""""""z"$$u=z羟w Wz ŋѲeKihٲ%KPٺwre^EHl999ի8k~w%W!"""""""ix7;v1`ժU2d羗5r9N8?͛7f%>S_5<bÆ h߾=1c bҤI,V'<==ֲHUVZ!''G/)J̛7B|RQwʕ@`` Ѷm[a„ }/B={ҥKx{z ͚5î] OOOԩSNNN ñ`*/=[l!==ēO''Ȏ^ ˌ Ά6:w(:u x뭷;wW^N֭[ѣS[wj;wލ0ǣuѣGQn])fɒ%HMMU[oɒ%HOOW_rYVC.]py\~pssC&M|% *3F.SNj&&&xwT6l tܹu[j6vکw~K\q *Ԛ4Z0z5Z]]lʌիW5eCDDDDDDDDDju7 S """""""""T 7""""""""" DDDDDDDDDD}^#/.gn?w*4ZWQFD2x.~6BsOSE}8lsBs\cї^),U9TxN{fWQm/QrTKDDDDDύE_""""*ᷱx @¡UDDDDTn <*Bs45("""""* """""""""Sb733{!444вeK@ݺu1{jM^NXp!u놦MYfҥKYU'O --RLMMqJ]E_#<~AAAظq#K\+??庯Bn]%:--r"9<+(((Bsh>inB$_}/+Ӱ+\pBk׮ >>>ت͌^:wFJJ F]b &HgE{ иqchkkF£G{uz [nvлwoAWW͚5?D8::bÆ  >qO] BFccc~;v,,X6l\]]kB,[ Յ9[b-..cƌA `dd={ۥŋoׯ_???ԫWZZZhذ!Ft5O< ooonݺ裏S#""еkWCWW...˝?U-|f!!!:t[oUqjDDDDDDDDٻw/i l2R/6n܈m۶}|M[#xѢE7nZ;힕U+ >Sqt ǝ;wT*q14mTeS\.ǔ)SU=s `ڴi*Æ ) ozK*2d.\m۶aݺux"##/|*9~8n޼CJ_d5jBBBc}kZѷSN СC_,deeASSAAA믫=Q"""z]~M{WhNF,U#kkkܾ}P**׌ ɤBxz8۷At$%%B=;J\ 4P311Q兤$M6RG}Tfylmڴ6?~"KmmmhhhrIRlI9|NKK_n]xRY5UիѱcG8;;Tsb֭/7… pwwG=ʵΝ;//YYY^izj 4Hj,FFF0559o^i4j"((FVV~7 Ӳٱcܹsزe44V{S "8W:|m갎U[]ZV)nmeUU",a5HDIdwf2r'ܓx=1nf[\WFxx8-[VAq(p/v(wׯFx!"~={p?~<sl~իWǴi?åK۷c AժUCXXۇݻw#//iiiW_}k7** g̞=*U3>?/*Aa0ر-3gd2[n^|^:~g̜9~!.]K<'..˖-CfʹcZg}֭V+rssa61a-+[nG}nxx8>#hV+V\ &G ō7Pzu|xpڵCdd$}HJJBdd$`>|8,6k6..\~cAZp8x뭷?744_}}@,[ }pŻﾋYf!&&6 vCiO"!!o&׿l6#88/2͛ZZ*֮]q<*]UVř3g7"66?J;{:q7nO>vҝzV~BZZz{T~{/Ʈ]pyvƢE7Kwӧ<'OB h߾=4h7|frkߢE |wZ-_ áCp%Ԯ]zr,""}WGFΝ{nQFСBBBРA Xnoǎ#7M@bk㯟Ǐ`XѽK{y *G[.֭[kj׮qKq/܏niӻwocw/ !..ϋ@~ *T# Sttt )kf4CBB]v?zK)Q ߢشiƍhܸ1zK.a˖-ؼy3u_%*Qs~b>ٷ  g?xSA0w\?~o6K??uԩtϟGy ʚ9s*h2{gf,\P/ZV <s+^zut|z;""""""""";9syظqcuUʋxwƥKt]h֭[%4"""""""""*gz)ԯ_P}']m~Wưa\;uUV_wԨQ]vHDDDDDDDDD_zOJ[lJ*a֭HTT??c߈f3_3g|2|_ /미v^ z]K<(ގDmݺDʕXr%ի4lO>$?yyy2eJ4O^fh\S<ҩ"2U%{aP(e!"uvFصk ӧOk3~m6/^3f./tEdՖjx)˞}Y<E7 f>< tf͚Çc۶mC۶m֭9YG ݎ#Go.\A-vZ#""""""""""W$~?oҷ7julK_y7I{Z:t{K߹c{Mq]m<z)˺R/=oJH|xy-&}9ojⒿŔq/N}Qw;_!]2o*.զ[A>ܺn%{M4iwl,;Qwq&}s )j |6+ũsu}WWFlr3/N֟.l mڴlgu,۽= Ѥo֥t@CNݴxZW'I_o?jZ'w6&}Yy_rGQ]</~CWoy7xqf]m<I].ƗI ~>Sn߬jH^qyԮ]0`m!/6al/EC_믿^L>Τ/LBp}3dy)kS3ӿB{ PA%""""""""B CfKpW45fƮ`җcW@mt3FKV+*V}s3 """""""""{L_'!!!HKݚ)DDDd<ğ|"""gM}bh.&} !V0ʵڕL۵U/}fDwejB$DDDDDD LgTwY^I_2bW?#7/OW\QǤ/Q`Nܲ;t|""""""""*F@DDDDDDDDDD%3}ʱãQ! ZW^ JDXjZOW^ J;#KDDDDDDDDTƥe"+G߆7y^Ƥ/Q5pCW7 &}w(g[h1[vÎ|YW,o!""""u-CզDDD#&}ʀǻWE*u9r횗!"""_Ƥ/T5&}Ѓ6iͩ|5•+W/7nzyسg`޼yh׮caaa^zv.D_\DDDDD8x.&=+Kѽs=xѨQ#@ժUtRL8gƏ?x8~8`nDDTb'Iw'2Ag'T&r? xW\O0&MѣGIII a—JNxjt7]mRR4DDDDDDDVL&"## Dff]_znBxx86mӧOp ""oƏ>;/n'\NDDDDDDDD`6:p8Z=oڴ پgϞEtt4"##qL0A+ADDDDDDDDDTV陾"1ŋ9 A&M~~QFaŊ6mի+;v6n8k^ʟ?s-*I_l7v+1}t#G믿x[WbbbwA]KDDDDDDDDDӉ'p…y2 Bzzn޼C{Ŋڱǿom6mZ{.JhDDDDDDDDDTδm-Z(s9rt7<<׮]4jH;,ܹܵsk.\M6uy,)) ;[vںiС:thk2xm?..\A˖-~׮]ػw/|I㹹سg`̘1%1wܹsM6aɒ%ç~7x& ߿իWGNc̓d?ɓ'ի8q5jltm0/+I_ذal6fΜ łQF!///vI&%%!)) Ǐ׎f3V\*UI&=z`޽F%""""""""""+5}_~tVZ}vژ9s&ԩN:aٲe^?xꩧoÈȑ#Ѿ}|DDDDDDDDDD%'} ""s̹sV{7B#"""ҭzE T&ۥگy!"""""W[Z6Coy)nw L&5Тv ]mJxv@{?13t{:9]mnqEQA%?אa,/ECDDDDDD%H/Τ/ \&W?ؔhW0K>/MzSWIbVxzvy[t#""ۓݵ,ߝeGDDt/ lV6Ҽ  &}\.n7;1KDŖlXJJd[꫟HDDDDDT1KDӷYC%;yҴj.^ӷS:QqU 5rJT`R4DDDDD%""""iHs3즫+LDDDDC_o""""""""""iKDDDD^`;^oV,Y^cҗ*OXg[!*Y9yz]w5-/EC8yI^|DDDDDDEt>!IWk׮{)_\%}I+l "0KDDDt|-js>妗!""""¤/}+7D6I3IYڜ͚ѽv /DS2<&%hH=I_""*pBȀ?6l󟈌4:4"*BKx6-+oa+]<;v9i^dXP]mrr$dCNn6vwIߙ3gbɒ%CNpe9r5j"cC 飫/)EDDD݉4J7;!Qߊ"""".ڵkXt)l6Ξ=={ٳ0anܸɓ'".uw…C׮]QV-łFGDDDDDDDDD}=qՊzn_5"4""""""""""k^|РA*U8v,`""""rMڪOR4%CWq69[W_R4DDDD}ʺ@X"ׯ_ED~7myH~v-+'.ej|)jLڤg-}o3bMw+rDa~}H9<\˴{)Y]~g!VXt ~qKlB0?~˰BDoAh1RGu 6Y9ddz! YP!X8v5ߝ9X1*\} IDAT7o!=7~V3*~ y>U "_VnngdP9TzV.}ooAwCP?,v7n:yG~T ^ٷpnq+7vaA6| (EGr~wP?Xsu@? t߾7bU߹W7oxLJ*!%%.\@ƍ]۳TbDhelE=ϧEI疿\˓re8壝*oM7ȗo,V9<_u䗔\G;g8|f|9Q7o9|6TT<Yv\2:U=P,[-*_/:ӧO{L^~z9}V'0BCCZt, 4ibt8%Ӹy&QfM)gΜAvIp88qcDFF"227PNTPpҥKHMM?6lht8DD^s9ܸq!!!xn޼ӧOd2qưX&EǏ@ZISp8ͽ9Q~7o&Fʕ1uTI&M`Ϟ=ذayΝ;ɄBVNpQoIEXX`Æ 4hw <HNNZvO ^|Ei? >/^Ċ+'NѣGѨQ#3+Yf~Պ_U,:|0[Z 0eʔrQmƌ8z(֭_~p>QޮIGyy˅f\~]O'7o" 0Ncb6%,,Lv|͚5@ |q4kPJLxx+VJ͝;Wh?7oKOO d+ʌ3 bbb$999""beҤI@7onp$&&l$'O4:ѹsg 7:-AAA2zhC8 =zJɑw}WVZ%FS"'-ÇJeggfӮIӦM3:b4h~BCCDjráĶmfիDEEIlla.|\R222D<"۷o7:OdddH@@JI_޽{ ];2uT-9>K,??? 6M#Ǐ7:"p႘f ~ltX2{l 2|p;v;v谊nࢢd֭""Ү]; EL&7xh '00Pd8IKK쨨(3{LvSqd޼yeg9vSl6f[n1U>ҪU+ԩ$%%V;vL3,&L0:b޽@dZܹsFU, .ޏ[萊puftH֫W/ UTȔ)SŋFUdv]F%AAAbZaÆK/VlܸQjԨ!VUeРAeIDJ*@~i2d|D7)ѣG u>|aKRR9}ᔈ%KH*UfI``WRSSeȑ(6M"""d̙FU, ҹsgC)>p8O>.t???Yrѡ) 6mH͚5d2l˗{l3`ܹrӪU+;aZp۶m]f.3vMdŋ^ļdiӦX,ys$##C&Mdt2g-ݻwoٵks̛7-]v_ߑjm۶^ԬYSȟ'wKwIȸqJ3D]N> Uջktx%&&J@@J*IǎB LۃoIL+X  YfiWm۶5:"QPYdʼnl&w6:"q8,dΜ9RZ5ٴiaO?-$&&F $ڵ3:b9p9AV6^֨l( Rn]dÆ ڵRJRZ51LbXdW_}UY,oV&V.Agxl3eiܸuUH׮]套^x@HÆ $C/ԀVDFFj{5:<Ҵjujݸq2:99pO*Ν;dȡC޶m pAm\zzzizO۶m:2*ip8$..NȘ1c PzHHժUΝ0 G_6m1BDnj}bdܹF|WZb~߾}"r{ƋYڲeKk׮:ؾ,**J+,C,X]puYbʕ+KRR̝;W5k}nvZٽ{6ˉM iРHvv^ZK2bY#@}Q:uHjd/~jB rIΖˠA*W,\VlR٤ұcGJԭ[Ȋnĉ@6mr<--M6m$k֬)S7qjS}ڵk\YujؔٹsXVZenaôY{LCie˖i'f8'H }T~Gõ:dffJTTL&ٱcv.j_kz!dѢEFV4j`_,^XСCL_ݰa2Y~AZ9?dȐ2yiԨz[Jttt70KŖ(gϖ%KUU""2k֬ ԒUVw8b2$ 3RÇ~ؠfF͔UH9plڴIur}CЯ_? ݻww9fdP ~Β%K-o|Xz=Y!*)㏻=ʓ℄21Cʟׯ#FȂ p8d]={VL&ΙJ4_եKe_siOT)u С={h`_Vzu ,ۥԪ.]hɑ>_nkV=Ze,B jYѭ_^HppUj;c@t0KŲvZ&IevEkj*-[ڵ=>*Яxb?~IW$2{l֭[Yѩ%0Υ)ϔݼySʹǎӖ8w:g*=5hP %''G[b>Qsj|Æ =tS "-n6% @ʺu|v5ӧWhX1LaÆ SUl6 |s[%?sR}ٱcǖV5ospvERf޽>˹\&MTXQ%11Qz!I$AAAb|:xbsӧ{lkTMgΜ)dԩYѩ\{q5,TH{5VZڱ͛7Ƥ/ڄeРAdرY6Zy5Ź>233iv^jjL&k׮Ȋ+\IH^Z Thܹn3}SSSe̙2i$Lm,SzujlYM)߿Ovbbb.3K7o,"=rҽ{wdxϙ"fY,Kbj2x`1bϽ/jΝ;'gϞvUTʕ+K|nvߟgfggk.W2K 8PHϞ=c*竛3,[msT d\.\Rt\&&&Ǐw-00Pf̘Qgddz1 =we6ݒqjz*U={ʩS |3JqYؤƴiwݗP, Sٳ9C󪙥#ܞ-&Il6ܹC(!!AVs^Oݺu}o۶m5JDt=1bQFć< f:S7ߪCK3T]fLE_ժq^~gy6 tQ>:uʭl۵/,uf[֩SG;%opLs,={1ch7588/sJt8'.Jj,p{itfl6K``Yb6 Ly:;}Y4hرcٳ.mg\ BnԨQJbWP帚ܣGm2e!:F.Wt-δ4q8.=/m^tv]u&2w\5jP+H G%}6PsҥK4M6mZZjeIPPuG%w+WqRGW٨kJ*U<>t{ 5WWq%$$ Te*zOݦMרQ:'~'ݺusiI;vKE)SWuԍ/G}?TNmO2lb2<&:hk)';vHLLl۶M>,>|X,Zw:'M1GDd˖-^0W%:7-_[sJuIgiHXt۠dm0d2I dSݨ:c˗/'>ph现Zȝ6fpHttی6Uh58G;wԾ?γ,8 &I^[޻o"Q5OddLUjo``6T~_;vرc뚯,V %99YW:tH;+Ag#AAAn tihܸK(nZۻwl6gʪfYVQ ~w"ՃÇ:kY t+n iC؃jFR}j|B.]J* Z```6νO{ r3f6f͒͛7k3CCC}$.]m cժUvZ쟯lP{?#-Wfkڵkˈ#qwݻx LR[N֭[7Yx 2DUD<_\T:00P,Iv MHHZ*W,eqtΜ9"r#\^CR |gZqr9IJJҖX,9uꔶٛdrKرdTׯfA3e{Z>sSΝ;F7ґ#Gjԍx"wFt`Uó08eqf6%88嘪 uohl2RSGO5.'M%w*W,k֬uiIڜu2uEiѢE5kָmhlUV]sf4iDpTR)AAV\G%ׯf˪ί}n:*yھ}{sv'jI-ަMʒ%KdҤI u6hmd5R4h {n6l_8ر%;;[hB[f2d֭*͓|eߐ_(Wj0@RSSԩS5(44T233>uKnz#[~~~2o<ٽ{VW;b iѢtm5xԤI#H}qqqGɪUOVݻץ5Emxf9ܙA)IM999pBj k׮nJ<:vRIƍٳg%99Y;l6-&8Ī?kaiϴdӰadOm]>PA}ҠαOYnm۶T0@;˳gϞigӮ]$&&Fl"fgdyAvT3-=^0 wӨQ#3fLޣG Jk֬2sW%ڝxvw ###Cީ! 6,sztE;f5U\钑$ IDAT<R6nh@%66V VBBBd||6D5 Ù&}ĩO=vLjiRijO-%%EO.;wcǺ,OT*<%9?Kiƍ9>Sn#ް~2d[f̘T]--h),,̥0.pY ueF}'jY)9Orrrjde>njԩS*~:˝;wFgL Yp4o\[j[%HlM#p˸q\i@Ns7PeI6m*W6| O6t^٩\A_8p@o?q'O̙3W^nϭZ}u',=J[||̚5K6nܨYWx۲eiFdȐ!.+B5J̽}thhJ͋/jgyFe׮]iz?~\&M$}>H듥kI`O*8 UVqIFF o=tÆ 2`0a@*-\ ٟ'gϊnKTTTVM~i v]222un*q *Z*+LR۵kDFFj59)0|<: /Ebbb I-Z^2eˆo,YO`2 )6nBUFވLf}Vf͚5.<[ dggҥKE.7qj#ؾ}{NRRY"-Z$VZ>[nuǹ\M~6U7==]^ָqg^;k.RSS͌}5sNoiӦ1/m`f͛%--M^}Uyٳn=iZep8946UIOĮY-llUF9oK3ԀliӦ69ivrlҰaCwi S=]DS{8rd|͛5 SLL߻EL"r{ݾjjzuLzz<Ål۶8m4 `i޼˽c+2,X Rt;^} jڷyP$C[`mcǎ`qYtMAT5kJfʹ>ݞ-Q%R< ׳gO>BPfˤҶcXU^2\;;?ԗ71K^|1PI&]xQдhBƍZ,W6ȟȐ`Uv,C)ShK7o|̈́JΓf͚6HKKRzuj/+VZI@@I^\۱cV6C%}ש|[nnǀ۳l2f{۷XV w?~\KV{*˶o.YCusޜ!$$D,]v6l fMr\2:v66ߺvFw.MOTU^]vڱl-9*+WoQoI6U tSu{t4U~GJ۹skjuo64,N:%G~X/_n5СC2`Yԯ__dPga_>egg˼y$::Z֭pۨD[m˖-bX|f#Dnnk7|IxZ&&&bqY^MjY {ՠsY'Oj#GM6ɴiӴFR8_pAOrîxڵkرc2h l >ӵT 7ܲe̜9S3?%>RرWHFXnzU:ϥ_giK];yOp.aaaWOIJSNҳgbܰaLӽj&dYεՠs=99Y-ZLWIΝe"w>͂:wr\-g*̲ҠfCծ][`j5df&ׯ3vrrr$,,LV5E8qq5OW焜5 -oU(%%E &y:t4z䢘3gs8Ţ}r4$;gEnϺ^b} 8͏IQQ0rH!۷/[hoܸ"յFpqEFF"&&F6T,YTU&V/_nỄs|iq%0smiv;N :ڵ %bnYs1|dlFtt4'Gb|UU:Ξ=+ qUhFmPqϞ=2dnf)~Z=+ ."5WYY UU/Ev;&M^zI>W/ 8Ell, ZuuǹԩZͲ'dW&saA{bANtvtZJqjѣ۷G||H63u֨bٳ[8o&''L.f8^ZkdŊZG`֚ Yŋu獪jOF2ԈF{oszٲerQuᡓ WX,:5kրٽ8{,]_v1Bm6WR,A OOOJfDK8y;Vgzp8sXj͎DۦN(233u Q/]j+k6 v111n}Vn#!!Ν;,ћғ'Obɒ%\NYW2eeebZk(sKRUUq=qP繺:5:qFSrhn޼)nݺ!66VZ,QIW\`Ŗlضmz]9X^˅ ZN0 .Z . >>^S劲\s;9"WW\i41 @9ܡsđxL@ lAc߿ѮUw|5MsR[[+nݺ!33'NZΝ;}"22k֬i]zUAAAAJ"qppvv6u?~|Qؼy'ٌ7o ƌ#C***ľJ;Zj0aSB%^z5Ν+v(W^EDD-nG54s1"::ZdqM C o߾%,\b0`NӧE }pFii)oߎ'O^!pmbb6r$Dݻ#88XUnҧ"Ν;jQUUcĈX`E&M"jԽk׮b̀sK{sulL0ӧOw2<+UUյhrW15f tFFFBQddd):1bl6t0a۷{nQ¸2Zw؄Hv2:d GqLy󦐰00v\{Չ@ݳ>+ZL9sLߑ2( TpaG˂ `X2SLy///ƊjG:uĎQu}x]r٨Nkci\\8At#u#Z%n#m b8ѕ}YYY5-'xt.l2j2J+aRѹJ:P\ (.װjN sM~~~qU&?hM4gaEEFڵ 0"Qz%qif{)ߙ:u 0L0L߿? E~itI鼼Dqc; \%FPXXTE $)mh=زeWp+cn۷}cԱcG;33D &|?gsas㊇TCQl6s?v kmo\ǙPc;tFHkk:t6܂6o 1c}JhhϤ;cseǭļ*Z[RfXZoܸ̙3e˖-ظq᭶+XZ)--}䀹V繂С.\kw{.-- @Crlܹ֭[u?Aj*UC@@"h ;*uXWUg h#qusnǎN.6֑(jkk1m4tm8|DG ''WG2f{h+/Y>*وCOWuiڤ#'m %qՏ'ß. wԮ];"//Izv;"##LKyyw׬[C hbW^ӧEQ?w_#DuSSS-[ Mov4l0aS;w(%q,Fg6SOL}WdWb8ZǪݲ2f͛ł%K`MhNU ́vCƮ6/, 1xfOsၠ v $'/ "6B*ylsl pӧk+8n6L 5[L:<s95+Bx!g2̕ݱ1rQQQnnh o 0eeeY:Z).ضmHN4'(((pz}ԩ }k FE/Nrzmٲe jLakBUU5 zb(uuuشi"C\weqޔjaw"::8UVsW6Q9L23fw6ɭG-YDgy|l L&6ӭ0Ncg;~:&O:`ܸq#yXܕ%Knh/ !"t]tcG֭[b16 .//kE999۷Z ߩsC}%SUUaÆ`Yf=wl6(pj%#<<<`Zu^/^UMli*AAAv~~x(::,۝LN$СCunόt1x~aX\:J;[l!))IwW^Uƀ둒3 wdE:77f111;T7VQ]]e˖nc޽ jkiϢEEE"!:`s7m$ +WDff&Ѯ];[kR9 ם 7nXh._ٳg6<\LEFF.:=r䈡OP=z4(j9wao͟?_:I۱seFF&Oݻw\UUU"p];«;ȥ+@DNW^/uF-Mqq1&O3f@UU]qLRRZqYs4z6vu#Z2ڪf6c!///]^^^tD$O:U}uS/]-[`Æ w 8pD] 7='9+++ UU޽{7++K ù!CHoeֳg6 ӧOԳgn S7VԈ=;{Op;u4CP-Bqq1^ wem&Gw#VX; DU^^ѣG/qرo<-ON8bƍM,;#M>,(oooL6 #F7+7*>6$P5Zy3$1Wݻb 8Хmbe˖aƌ8pn0`RRRD?v@h۵z)DEE W@CǎuCT]]b#G\g0hI l' ӦM'Eƾ52+q[€u#Yqaٿ"[5gذaÈl'Gcwx饗`q t6ߪd2aΝbBԶm߿[e$'\=dڵNEg\(qf!>>^1h׮`ETYXV]Lh9Y$YkԱ XWypB1祥'DTUŞ={m6 3f@HH|ɇ: *-ܑtf._d`b6]nZ2eskN\7+WRqi5v;Eq٬V2 OOO{U;~k0NiݙRL:F6' R,UQRR".'N0͢hms־tUqݹsg("W^yEO7oƴiӐ"ˮ(--ɓѮ];bĉߕV6mKQ\\, m¥ ;vp7d2uʼn䁪B|NIl۶YMbΝ;#|^]v0s[nҥKEcU=k!55[naشiqիAZxգ3f 䶲R=>>>:`VmD&EY˝;rJm IDATwh" 4III"-\izzz5^KH}Z[ZV1s0a) 7o^RSSXs Auu]fIȠm>}"׭[zݻB[8mg?~<&NL7J貇f٥#2`!"Z5oȐ!T)dDEE5$0\ᘵgo޼)6DիW9w]vYV}ºEgXIDݻ[T19999ӧOF,5'N:s֖&??3JނD Dcmi6TPä9jjj\\IXL4I tŋŵJ/9sxbqSi+s-mr{etD 桎@-qZ:6BM]:|}}B6hH:tyX5ʪ\~]|=^}F6ͭu&ݙrz\2|pL8Qa0sLn:o<7jQէ_֠ImNٳgE2Rۂ\v ۷G=N:U[]An#7nTrBlX5>>qKD޽XO ȱQhkiV3M˱qF޺hVV͛},-//S5(.#""sltQ!oz ,4=.\Hf#!!Ag'iZ8FJHűڪ^^^PE/_\Gtt 9v47ovYi$֮b3鉧~qqq "1B|;v0TԩS:PdNOOGmmïQ\x:Yw %%ũ;&88%%%(,,]2},7m6 <@C!>>ްsq[g͚;^[[)S@Qx{{sQtTNN}0իWъ{3K+~ddK#sd2ErȐ! r;hmNTyΜ9r ^ug4^ramw7ywE5uwjn ݻfܹ HEQddee!55U$W8+#_V gf̘!"UEnbqjŦMe˖o(y8GŒ%KvZ]#M\jJ,сԼıgbbLvnݰqFl۶ ڵu0WeD}}(bjvId2j:L& z`§I9??_T\!<<\-iV@u$gΜ;NUTT-ingE՝4WrBMM п1)"*;dҒddd`ظqo޼)sɆQ† 0|ݺnСPEy_( N8 "l޼E0l6<==aXt-UUU(++CQQhϿuTUW1B۷OW[VV& 7n@YYYk I͛71n8=GDDOPPb,//GΝukhB,uVR$܅ 6@QQ,h<h+e@'OjbA]1$ jUڸq#VX2 _F|ueWy饗čK/IJϼ+ " 8@8;k3/bΝ;AԠW%4.4aXT[9aN<ڵ+ҥLG wd^pX`bp0K.ᥗ^K/$cv]Hn̟?_,4+++O Š+u<==j5rjjj3Ϡ _~2i-iQXb <<\C 𖔔k)4 c0 "1^\t).\(J6(]{رؕ+W;xrOOO{ZTVVbĉL>|d2!::cǎе<D$mx.в rmŕF6ׯ_jEn nmW\II rrr: *++!iZZA۷/puK.o߾&]I>&V{ "c\(d2!Gc̖&55U׹( /N}(dWl(:M'ٕ'l֊`oool߾b5<4}鎕 ;2///(ںu+2鈋s|;qF̟?BB@[⤯Ʋ RاO(AZzG{=VUU9%# ҹ}e d>j(IY䛳n:=wj$)G1h Qm7osܺu|7o "~40p g6QmlpЎb555 ( su(///](kO0};~㼿ʏSQQ!4J]I1$/^tb\YoZ &TTT~a-uuuYMMMرc 5&!00P$yjE౥ϟ6ڙ:u$Jsω-NAawi*h+9rqڽSO="B׮]uÇ&Њb۷/}Bpw؀<$$5N~,^6mz"²e˜>ڄ!!!8q 0j(5Z( y+YQ'Vb `GkVϪ,A/^g3,00Pt4|{rrrDIc=Z+Wl6CUU̟?)r0BMM v):8l2TTTC'.䆫b¤Ν;EQ퍴4\pAM0}c9 re-ylٹs'EbСC1rHтzxqY_ $I맾iii;vh@k`Cii)  CqqqC['77{ddBTTNc5UUq9q:#"{nW^"cHEqq1/^9s**y+Zu& ##CFa󭀀BDDXc1JFIƍi߾=TU,<0VUUza(Vm\tItr{FQ*++1ffΜ}܋'..v j0w>p.^(aFUZ}}=ڷo/a,YYfd25 HO>x'O,2ΕYPQQzyyСC-}-@n… ŘmmGqz;9F]$3ӧOcm& ٖy؜hXqékر "of:鰺#W\AYYl6222˗͸19s٪*1;vDΝ~a]J\ja>lȾغu+ wmNdW"ACu^^^͛g "cΝCLL "##`WWW7IH$&'==?qhD'Zf*qOnݺѣG X???$$$*q qIDATMrrr-eeexꩧPTTd$;vLjaJGc7fذa " 6(i>G,ҥ D'Ym۷c͚5FYyQ4dYCX,Nd#q,2+4pΝ [,(޼ybb4hPsD"i-5+_*UEhJ$_+@__F+MQ֊Mo>̙3V$Izjjj( aaaظqc ZҚvUhbbbDV7۷oիLZ%`iG,Djjc߿_8CZ\|m66$2+Bߗ\W^( L&0nsp#u42e \?%I- jjj ".? K$߆Eлwo7D٣S]]޽{;iI LDTTT47Dk;m"7%5"tro0qD]_~b}(4˗}0yo;/_į5"I#\|Yg@ü "D 5{~(--mޓH$MΥKбcG~lիWɷtgCv(,,Ċ++W=Dfd2SYUQF~~Wlؘ%F )mXf F-FJZ)))BK.Kٳ.0}tN}}K]toy___yсk׮tmqEEE5p+T &~Q||<ǾK""_"ǔGDDDDt}ÇS@@OjK$`ذazj ҿ/ >}P`` ѣG:-I+ Hn޼)OSUV?͘1+""~Qtt46x)<<.\(uݻw̙3*|0aܹLTU!** ڵøqPRRbHZFk׮EYYOЮ];^6VxRRoVWWc„ P>>>ػw~f "{qacw˗/7%dW"\xD`0̄jBUUUȑ#'&&0eʔD"nDDDpq .۷o4:D~~>zL"H$qwd5p@z)qlȐ! "۷`ѷo_NhX)I3.#l۫W/ז/_ EQP^^>>8q"1f]`XK^^̙o=悂Dnݺ=0nȑ "l߾]{ׄAbuu5_%6L=z4zUU[qK#I&N\mEDHHH$$$0a.ZDC%wDMMMō7ooo֮]k%D"iQjpBlڴ { ޗ_~D:PTT$Z@D8p@ХK7l6v9sDOOO]Wŋ( vCBqݻD0ڶmۜLИ)SDdd$( Eb2 "q~222"˜1cPYY۷f;w3dS@[``wo[F}%&ʕ+HHH@.]Я_?߿PXXEQ`6EJ ;:t,Hw}WiƎk$D"iӬ_;v0{lK.l(//Gxx8F!~ҥKADѣ!#i ** &M'EѵoDlѭ[7X, Պe˖h<==AD8weeeBVѣxvv6޺ܹS$ƚ ݎ yN4hXnn*}MܸqC7n'L"ŋlm H:[Oq%̚5 R["H$lFmm- Æ  "Btt +**Dqٖ?I iiӦv DpHz!2{l#F0ydTUdN9oyLT.^]4aʕS0uT >D,^gƍ'@4IM)))HUUUNoߞ>cڵkX€J$D"H$mHQz"jp}ٳ'}4|})//O, '?W^yNBҪN;w&"Sv/}ѿۿ>s}#JCv)BK.?ITTTDoߦN:hdXO>!___ڮ]G?EFFRII %%%ѱchСblhС0_}ݻjjjhʔ)ԯ_?qׯ_/R\\; /PYYP}}=}TRRBON4w\ꫯhݺud6I[ӦMs).N:02D"H$m UUufBgϞF˗E̙3u Ɉ͛71|I+eڴiz:saҤI#GI*K.Vvđcͻ~zX7otki6t4۾}Nܹ8Άo }>j ǘ% ooo:u=sߧ4"":vCH$D"H4?髯#G/~y""JLL'NИ1c??7 ޽/iӧIUU2Lo^?s effF__/GUUUO-۷oӀ :Ik 22R_TZZJek˖-{Q߾}E|bƌD;WjJLLM6яcOHUUZj:tvJӧOoRA"13gɓ')...^hp$D"H$6޽{iҥdIQ@iܹoPjj*˗iĈE7 $'x>Zp!ݼyrssgI&Й3gA^Ν;ӝ;wÃy{={rrr{Q$iETӧiʔ)L;v>ӧ9s&OL^^^t=@`Ҝ9s~_ȑ#IUU(((l6ܹV\IDD}k׎|}}SȩO>5l6Nj/QXXUUUnpNPdD"H$D"H;.\H4p@z{QHHl6z* 8РQJZ t]Ƞ9?~zEܹs)33?9͜9.^H&-ZDvZOJDD;vO>>Sns>?Q||wA?>M:~^HԫW;}D"H$D"41+WD( _>[oe0Y-Z)K&"iŊ( y^VJ$D"H$cƍ'/K/4p@RU($$ĠJ2;v젗_~MFNҽNNaaaTRRB9R}}=L& >iܸq5p]ԩM2)66.]dȾǏٳg}駤 ?_N#i7|TU_bȠD"H$D"H$G޽.]H???>׿$"":pEDDرcݻԵkWz7 ҇~H_?ҡC= Ibݻw)44|' JIIɓ''jD N_~%1ˋrssJZZн{h֬Y/jmidW"H$D"H$jhw~Ϗݻgp$m⨶ÃIQzwhzEP~~> d2ÃƎr'-D"H$D"H$'u֍¨Tz_}礪*ӇnܸAPN裏>"NK,4,Y+H$D"H$D"H vJ111G~q{ѝ;wTUzK|yߧѣGΝ; SYfѫJDD+Wj޽{ J_D"H$D"H$D"|'J_~%СC7FVJ$D"H$D"H$sї_~IǏo_"Y+H$D"H$D"H$={?O1 0A$PP];4w ~3b<;j;c:IENDB`js_of_ocaml-2.5/doc/manual/src/000077500000000000000000000000001241254034500164445ustar00rootroot00000000000000js_of_ocaml-2.5/doc/manual/src/bindings.wiki000066400000000000000000000130351241254034500211300ustar00rootroot00000000000000= How to bind a JS library for OCaml ==Accessing a JS variable, ex: {{{document}}}: Write in .ml: <> Alternatively, the global object can be used. In the browser, it refers to {{{window}}}. <> and in .mli: <> Be careful the function <> and the value <> are not typed. Verify the library documentation before writing the type. ==Binding a JS function Example from the Js module: <> Have a look at the <> module API. ==Using a JS constructor, ex: {{{F}}}: Write in .ml: <> and in .mli: < ... Js.t) Js.constr >> and if you want to use JS overloading, do, for example: < ... Js.t) Js.constr val f_fromString : (js_string t -> ... Js.t) Js.constr val f_blah : (#Dom_html.element t -> js_string t -> ... Js.t) Js.constr >> ==Accessing or modifying a JS property to an element When a property is missing in the OCaml interface of an element (for example it has been dynamically added by a library), you can access using unsafe features: <> If you want to add yourself a new property: <> Here, {{{v}}} may be a JS value or an OCaml value. If you want to do that in type safe manner, just define new types for the extended elements, or wrap the unsafe functions inside a getter and setter. == Binding a JS object == Write in .ml and in .mli: < unit meth method my_fun_string : js_string t -> unit meth (* Both will actually call the my_fun JavaScript method. *) (* To call a javascript method starting with one underscore *) method __hiddenfun : .. method __hiddenfun_ : .. method __hiddenfun_something : .. (* This will call the _hiddenfun Javascript method *) (* To call the javascript method '_' *) method __ : .. end >> ===Example binding some constants: For example if the JS class is used to define three constants {{{thelib.Theclass.VALUEA}}}, {{{thelib.Theclass.VALUEB}}}, {{{thelib.Theclass.VALUEC}}}, Since ocaml doesn't allows method name to start with capitalised letter, we can add an {{{_}}} write in .ml and .mli: <> and in .ml: <> and in .mli: <> ==Constructing JS objects manually If you want to construct a JS object manually (without calling a function or a constructor), use function {{{Js.Unsafe.obj}}} and create the corresponding object type. You can also create an empty object of this type ({{{Js.Unsafe.obj [||]}}}) and set all fields manually using {{{o##prop <- ...}}}. For example, write in .mli: < options t >> and in the .ml file of your library: <> == Set/get variables You can access every variable through the global javascript object ({{{window}}}): If the variable {{{var}}} has type {{{t Js.t}}} <> == Object property with multiple types If you want to read a property of an object which can have multiple types, you can define an intermediate type to do typesafe casting ex: Suppose the object {{{obj}}} has a property {{{prop}}} which can be either a string or a Dom node: <> == Check availability of method It is frequent that some method are not to be implemented in some browser. To check the presence of method {{{met}}}: <> js_of_ocaml-2.5/doc/manual/src/library.wiki000066400000000000000000000207651241254034500210070ustar00rootroot00000000000000= The Js_of_ocaml library == Base types == Base values are not represented the same way in OCaml and Javascript. In particular, OCaml strings are mutable arrays of bytes, while Javascript strings are constant arrays of UTF-16 code points. We list here the correspondance between base types. Conversion functions are provided. |= OCaml values |= Ocaml type of Javascript values |= Actual Javascript type | | {{{int}}} | {{{int}}} | Number | | {{{float}}} | {{{float}}} or {{{float Js.t}}} | Number | | {{{bool}}} | {{{bool Js.t}}} | Boolean | | {{{string}}} | {{{Js.js_string Js.t}}} | String | | {{{array}}} | {{{Js.js_array Js.t}}} | Array | Integers are implemented as Javascript numbers. They can thus be directly passed to and from Javascript. To allow a possible compatibility with Obrowser, where floats are boxed, we use to types for floats. Numbers of type {{{float}}} can be passed to Javascript functions. We rely in implicit coercion to perform unboxing when needed. On the other hand, Javascript will return unboxed float, of type {{{float Js.t}}}. == Typing Javascript objects == Javascript objects are given types of the shape {{{ Js.t}}}, using a phantom object type. The methods {{{m_i}}} stands for the field of the Javascript object. For instance, a Javascript object of type: {{{ < data : js_string t Js.prop; appendData : js_string t -> unit Js.meth> Js.t }}} has a property {{{data}}} containing a Javascript string, and a method {{{appendData}}} taking a Javascript string as argument and returning no value. === Method name and underscore Some overloading is possible using a syntactic trick: names {{{_foo}}}, {{{foo_abcd}}} and {{{foo}}} are all mapped to a same Javascript field name {{{foo}}}: when accessing a field of an object, the name given in the OCaml code is transformed by removing a leading underscore and then removing all characters starting from the last underscore; this yields the corresponding Javascript name. For instance, these three types correspond to the same Javascript method {{{drawImage}}}: {{{ drawImage : imageElement t -> float -> float -> unit meth drawImage_withSize : imageElement t -> float -> float -> float -> float -> unit meth drawImage_fromCanvas : canvasElement t -> float -> float -> unit meth }}} This trick can also be used to refer to Javascript fields {{{type}}} or {{{URL}}}, for instance as {{{_type}}} and {{{_URL}}}. ==== Example <> == Syntax extension == A syntax extension is available for manipulating object properties, invoking methods and creating objects. The syntax and typing rules are as follows: * Getting a property {{{ obj : Js.t ----------------------- obj##m : u }}} * Setting a property {{{ obj : Js.t e : u ----------------------- obj##m <- e : unit }}} * Invoking a method {{{ obj : ... -> t_n -> u meth; ..> Js.t e_i : t_i (1 <= i <= n) ------------------------------------------------- obj##m(e_1, ..., e_n) : u }}} * Creating an object {{{ constr : (t_1 -> ... -> t_n -> u Js.t) Js.constr e_i : t_i (1 <= i <= n) ------------------------------------------------ jsnew constr (e1, ..., en) : u }}} == OCaml and Javascript functions == OCaml and Javascript do not follow the same calling convention. In OCaml, functions can be partially applied, returning a function closure. In Javascript, when only some of the parameters are passed, the others are set to the {{{undefined}}} value. As a consequence, it is not possible to call a Javascript function from OCaml as if it was an OCaml function, and conversely. === Calling Javascript functions === At the moment, there is no syntactic sugar for calling Javascript functions. You should use either {{{Js.Unsafe.call}}} or {{{Js.Unsafe.fun_call}}}, depending whether you want {{{this}}} to be bound to some particular object in the function body or not. You can also refer to a Javascript function using an OCaml external declaration. Then, you need to write stub functions in C so that the OCaml compiler accept the external declaration: {{{ Ocaml file: external foo : t1 -> t2 = "foo" C file: #include #define D(f) void f () { exit(1); } D(foo) }}} You can call this function as if it was an OCaml function, as the Javascript function is appropriately wrapped by the system. Refer to <> to link your program with javascript stubs. === Using OCaml functions from JS === You should use function {{{Js.wrap_callback}}} or function {{{Js.wrap_meth_callback}}} to wrap an OCaml function so that it can be called from Javascript. To call an OCaml function from Javascript, follow this example: <> Or, to create a JS object with OCaml methods: <> Variant: create an empty JavaScript object (typed or not) and set its properties afterward < float -> float) callback writeonly_prop method printInt : (int -> unit) callback writeonly_prop end let exported : exported Js.t = let empty = Js.Unsafe.obj [||] in Js.Unsafe.global##exportModuleA <- empty; empty let _ = exported##printInt <- Js.wrap_callback (fun i -> print_int i ); exported##addFloat <- Js.wrap_callback (fun x y -> x +. y) >> == IO == The <> module allows to marshal and unmarshal the javascript representation of OCaml values into the corresponding JSON string. The unmarshaling is unsafe in the same way the OCaml {{{Marshal.from_string}}} function is. Type-safe unmarshaling may be achieved with the {{{deriving}}} library using either the optionnal {{{Json}}} class or the {{{Pickle}}} class. * The {{{Json}}} class use a Json as external representation and do not preserve potential sharings in the data representation. See <> for more information. * The {{{Pickle}}} class use a binary format as external representation and preserve sharings in the data representation. == Events == Besides the functions provided by {{{Dom_html}}} to register event handlers (mainly <>) using the usual Javascript way, js_of_ocaml provides another module to program event handlers very easily and concisely, in the module <>. This module defines functions you can call on a DOM element to create an Lwt thread that will return when the event occures. Example: <>= handler); >> The handler receives the JS event as parameter. Each of these functions has a version (same name with an ending "s") that loops when the handler terminates. Example: <> To remove an event handler, cancel the Lwt threads using {{{Lwt.cancel}}}. It is also possible to use {{{Lwt.pick}}}. For example the following piece of code waits for a click on one of t1 or t2: <>= handler1; Lwt_js_events.click t2 ~>>= handler2] >> Warning: If you are using {{{Lwt.pick}}} and your handlers take time, be aware that other events listeners will not be cancelled before the handler has terminated. It is probably a better idea to return immediately after having launched the long handlers. Look at the <> for more information. js_of_ocaml-2.5/doc/manual/src/linker.wiki000066400000000000000000000042301241254034500206140ustar00rootroot00000000000000= Link with JavaScript code The Js_of_ocaml compiler accepts JavaScript files provided on the command-line. The main purpose is to provide (external) primitives needed by the bytecode program. Most of the primitives from the standard library are already implemented and loaded by default (located in "runtime.js"). Additionally, some other primitives are installed but not loaded by default: * "+weak.js" : when using weak references (does no follow the weak semantic) * "+toplevel.js" : when compiling toplevel == Command-line Pass the JavaScript file (must have a ".js" extension) <> Or load it from a findlib package <> The file **jsfile.js** will be looked up inside **mypackage** lib directory. When no package is provided, the compiler will look inside js_of_ocaml lib directory. == Provide your own JavaScript You may need to provide extra JavaScript files to provide missing primitives or to override existing ones. Primitive code must be annotated with the primitive name and primitive requirements. The linker uses these information to only include the primitive actually used in the program and to perform better deadcode elimination. ===Syntax {{{ //Provides: primitive_name [const|mutable] //Requires: primitive_name[,primitive_name]* //Version: version_constraint[,version_constraint]* function primitive_name(..){ ... JavaScript code ... } }}} * **{{{//Provides}}}** is used to declare a primitive; an annotation can be used to specify the possible side-effects of the primitive: **const** means no side-effect; **mutable** indicates that the primitive has no side-effect but that other primitives might affect the returned value of the primitive; when no annotation is provided, the linker assumes that the primitive may have side-effects. * **{{{//Requires}}}** is used if other primitives need to be loaded first * **version_constraint** looks like "{{{< 4.02.1}}}" * **{{{//Version}}}** is optional and is rarely used All JavaScript code following a **{{{//Provides}}}** annotation is associated to this annotation, until the next **{{{//Provides}}}** annotation. js_of_ocaml-2.5/doc/manual/src/menu.wiki000066400000000000000000000015671241254034500203060ustar00rootroot00000000000000=Js_of_ocaml ==[[overview|Overview]] ==[[library|Library overview]] ==[[bindings|Binding a JS library]] ==[[linker|Link javascript code]] ==[[options|Command line options]] ==[[performances|Performances]] ==Examples ===<> ===<> ===<> ===<> ===<> ===<> ===<> ===<> ===<> ===<> js_of_ocaml-2.5/doc/manual/src/options.wiki000066400000000000000000000045501241254034500210300ustar00rootroot00000000000000= Main Command-Line options |= Option name |= Description | | --version | Display the version of the compiler | | -o | Set the output filename to | | --source-map | Generate sourcemap | | --opt {1,2,3} | Set the compilation profile (default 1). See **Optimization** section below. | | --pretty | Pretty print javascript output | | --no-inline | Disable code inlining | | --debug-info | Output debug information | | -I dir | Add

to the list of include directories | | --file file[:dir] | Register to the pseudo filesytem and choose the the destination directory (default /) | | --enable