diff --git a/.ghci b/.ghci
new file mode 100644
index 000000000..222adaf8d
--- /dev/null
+++ b/.ghci
@@ -0,0 +1 @@
+:set -XOverloadedStrings
diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml
new file mode 100644
index 000000000..c0f70b611
--- /dev/null
+++ b/.stylish-haskell.yaml
@@ -0,0 +1,24 @@
+---
+steps:
+ - simple_align:
+ cases: true
+ top_level_patterns: true
+ records: true
+ - imports:
+ align: global
+ list_align: after_alias
+ pad_module_names: true
+ long_list_align: inline
+ empty_list_align: inherit
+ list_padding: 4
+ separate_lists: true
+ space_surround: false
+ - language_pragmas:
+ style: vertical
+ align: true
+ remove_redundant: false
+
+ - trailing_whitespace: {}
+columns: 180
+newline: native
+language_extensions: [CPP]
diff --git a/ASM.md b/ASM.md
new file mode 100644
index 000000000..b89b6b19f
--- /dev/null
+++ b/ASM.md
@@ -0,0 +1,16 @@
+- [ ] floor function: https://stackoverflow.com/a/37573707/11296354
+ -- check parity: AND with 00010 or w/e
+- [ ] note: fused multiply-add etc. for doubles
+- [ ] https://disasm.pro/
+- [ ] sign by parity: AND with 0x1 to find parity, then use this to set sign bit? lol.
+ (-1)^n
+- [ ] avx512 has: https://www.felixcloutier.com/x86/vexp2pd
+- [ ] https://www.felixcloutier.com/x86/f2xm1
+ - [ ] thence: x^y=s^(y \* (log_2 x))
+# Min/max
+- [ ] http://web.archive.org/web/20130821015554/http://bob.allegronetwork.com/prog/tricks.html
+ - [ ] quick absolute value
+ - [ ] min/max?
+- [ ] http://graphics.stanford.edu/~seander/bithacks.html
+- [ ] https://stackoverflow.com/questions/227383/how-do-i-programmatically-return-the-max-of-two-integers-without-using-any-compa
+- [ ] https://stackoverflow.com/questions/476800/comparing-two-integers-without-any-comparison?noredirect=1&lq=1
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
index 000000000..8b4f027ea
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,5 @@
+# apple
+
+## 0.1.0.0
+
+Initial release
diff --git a/COPYING b/COPYING
new file mode 100644
index 000000000..be3f7b28e
--- /dev/null
+++ b/COPYING
@@ -0,0 +1,661 @@
+ GNU AFFERO GENERAL PUBLIC LICENSE
+ Version 3, 19 November 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The GNU Affero General Public License is a free, copyleft license for
+software and other kinds of works, specifically designed to ensure
+cooperation with the community in the case of network server software.
+
+ The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+our General Public Licenses are intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users.
+
+ 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
+them 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.
+
+ Developers that use our General Public Licenses protect your rights
+with two steps: (1) assert copyright on the software, and (2) offer
+you this License which gives you legal permission to copy, distribute
+and/or modify the software.
+
+ A secondary benefit of defending all users' freedom is that
+improvements made in alternate versions of the program, if they
+receive widespread use, become available for other developers to
+incorporate. Many developers of free software are heartened and
+encouraged by the resulting cooperation. However, in the case of
+software used on network servers, this result may fail to come about.
+The GNU General Public License permits making a modified version and
+letting the public access it on a server without ever releasing its
+source code to the public.
+
+ The GNU Affero General Public License is designed specifically to
+ensure that, in such cases, the modified source code becomes available
+to the community. It requires the operator of a network server to
+provide the source code of the modified version running there to the
+users of that server. Therefore, public use of a modified version, on
+a publicly accessible server, gives the public access to the source
+code of the modified version.
+
+ An older license, called the Affero General Public License and
+published by Affero, was designed to accomplish similar goals. This is
+a different license, not a version of the Affero GPL, but Affero has
+released a new version of the Affero GPL which permits relicensing under
+this license.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ TERMS AND CONDITIONS
+
+ 0. Definitions.
+
+ "This License" refers to version 3 of the GNU Affero General Public License.
+
+ "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+ "The Program" refers to any copyrightable work licensed under this
+License. Each licensee is addressed as "you". "Licensees" and
+"recipients" may be individuals or organizations.
+
+ To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy. The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+ A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+ To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy. Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+ To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies. Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+ An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License. If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+ 1. Source Code.
+
+ The "source code" for a work means the preferred form of the work
+for making modifications to it. "Object code" means any non-source
+form of a work.
+
+ A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+ The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form. A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+ The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities. However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work. For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+ The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+ The Corresponding Source for a work in source code form is that
+same work.
+
+ 2. Basic Permissions.
+
+ All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met. This License explicitly affirms your unlimited
+permission to run the unmodified Program. The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work. This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+ You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force. You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright. Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+ Conveying under any other circumstances is permitted solely under
+the conditions stated below. Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+ No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+ When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+ 4. Conveying Verbatim Copies.
+
+ You may convey 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;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+ You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+ 5. Conveying Modified Source Versions.
+
+ You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+ a) The work must carry prominent notices stating that you modified
+ it, and giving a relevant date.
+
+ b) The work must carry prominent notices stating that it is
+ released under this License and any conditions added under section
+ 7. This requirement modifies the requirement in section 4 to
+ "keep intact all notices".
+
+ c) You must license the entire work, as a whole, under this
+ License to anyone who comes into possession of a copy. This
+ License will therefore apply, along with any applicable section 7
+ additional terms, to the whole of the work, and all its parts,
+ regardless of how they are packaged. This License gives no
+ permission to license the work in any other way, but it does not
+ invalidate such permission if you have separately received it.
+
+ d) If the work has interactive user interfaces, each must display
+ Appropriate Legal Notices; however, if the Program has interactive
+ interfaces that do not display Appropriate Legal Notices, your
+ work need not make them do so.
+
+ A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit. Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+ 6. Conveying Non-Source Forms.
+
+ You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+ a) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by the
+ Corresponding Source fixed on a durable physical medium
+ customarily used for software interchange.
+
+ b) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by a
+ written offer, valid for at least three years and valid for as
+ long as you offer spare parts or customer support for that product
+ model, to give anyone who possesses the object code either (1) a
+ copy of the Corresponding Source for all the software in the
+ product that is covered by this License, on a durable physical
+ medium customarily used for software interchange, for a price no
+ more than your reasonable cost of physically performing this
+ conveying of source, or (2) access to copy the
+ Corresponding Source from a network server at no charge.
+
+ c) Convey individual copies of the object code with a copy of the
+ written offer to provide the Corresponding Source. This
+ alternative is allowed only occasionally and noncommercially, and
+ only if you received the object code with such an offer, in accord
+ with subsection 6b.
+
+ d) Convey the object code by offering access from a designated
+ place (gratis or for a charge), and offer equivalent access to the
+ Corresponding Source in the same way through the same place at no
+ further charge. You need not require recipients to copy the
+ Corresponding Source along with the object code. If the place to
+ copy the object code is a network server, the Corresponding Source
+ may be on a different server (operated by you or a third party)
+ that supports equivalent copying facilities, provided you maintain
+ clear directions next to the object code saying where to find the
+ Corresponding Source. Regardless of what server hosts the
+ Corresponding Source, you remain obligated to ensure that it is
+ available for as long as needed to satisfy these requirements.
+
+ e) Convey the object code using peer-to-peer transmission, provided
+ you inform other peers where the object code and Corresponding
+ Source of the work are being offered to the general public at no
+ charge under subsection 6d.
+
+ A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+ A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling. In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage. For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product. A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+ "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source. The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+ If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information. But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+ The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed. Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+ Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+ 7. Additional Terms.
+
+ "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law. If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+ When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it. (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.) You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+ Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+ a) Disclaiming warranty or limiting liability differently from the
+ terms of sections 15 and 16 of this License; or
+
+ b) Requiring preservation of specified reasonable legal notices or
+ author attributions in that material or in the Appropriate Legal
+ Notices displayed by works containing it; or
+
+ c) Prohibiting misrepresentation of the origin of that material, or
+ requiring that modified versions of such material be marked in
+ reasonable ways as different from the original version; or
+
+ d) Limiting the use for publicity purposes of names of licensors or
+ authors of the material; or
+
+ e) Declining to grant rights under trademark law for use of some
+ trade names, trademarks, or service marks; or
+
+ f) Requiring indemnification of licensors and authors of that
+ material by anyone who conveys the material (or modified versions of
+ it) with contractual assumptions of liability to the recipient, for
+ any liability that these contractual assumptions directly impose on
+ those licensors and authors.
+
+ All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10. If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term. If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+ If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+ Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+ 8. Termination.
+
+ You may not propagate or modify a covered work except as expressly
+provided under this License. Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+ However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+ Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+ Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+ 9. Acceptance Not Required for Having Copies.
+
+ You are not required to accept this License in order to receive or
+run a copy of the Program. Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance. However,
+nothing other than this License grants you permission to propagate or
+modify any covered work. These actions infringe copyright if you do
+not accept this License. Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+ 10. Automatic Licensing of Downstream Recipients.
+
+ Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License. You are not responsible
+for enforcing compliance by third parties with this License.
+
+ An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations. If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+ You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License. For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+ 11. Patents.
+
+ A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based. The
+work thus licensed is called the contributor's "contributor version".
+
+ A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version. For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+ Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+ In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement). To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+ If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients. "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+ If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+ A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License. You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+ Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+ 12. No Surrender of Others' Freedom.
+
+ If 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 convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all. For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+ 13. Remote Network Interaction; Use with the GNU General Public License.
+
+ Notwithstanding any other provision of this License, if you modify the
+Program, your modified version must prominently offer all users
+interacting with it remotely through a computer network (if your version
+supports such interaction) an opportunity to receive the Corresponding
+Source of your version by providing access to the Corresponding Source
+from a network server at no charge, through some standard or customary
+means of facilitating copying of software. This Corresponding Source
+shall include the Corresponding Source for any work covered by version 3
+of the GNU General Public License that is incorporated pursuant to the
+following paragraph.
+
+ Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU General Public License into a single
+combined work, and to convey the resulting work. The terms of this
+License will continue to apply to the part which is the covered work,
+but the work with which it is combined will remain governed by version
+3 of the GNU General Public License.
+
+ 14. Revised Versions of this License.
+
+ The Free Software Foundation may publish revised and/or new versions of
+the GNU Affero 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 that a certain numbered version of the GNU Affero General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation. If the Program does not specify a version number of the
+GNU Affero General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+ If the Program specifies that a proxy can decide which future
+versions of the GNU Affero General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+ Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+ 15. Disclaimer of Warranty.
+
+ 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.
+
+ 16. Limitation of Liability.
+
+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+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.
+
+ 17. Interpretation of Sections 15 and 16.
+
+ If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+ 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
+state 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 Affero General Public License as published by
+ the Free Software Foundation, either version 3 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 Affero General Public License for more details.
+
+ You should have received a copy of the GNU Affero General Public License
+ along with this program. If not, see .
+
+Also add information on how to contact you by electronic and paper mail.
+
+ If your software can interact with users remotely through a computer
+network, you should also make sure that it provides a way for users to
+get its source. For example, if your program is a web application, its
+interface could display a "Source" link that leads users to an archive
+of the code. There are many ways you could offer source, and different
+solutions will be better for different programs; see section 13 for the
+specific requirements.
+
+ You should also get your employer (if you work as a programmer) or school,
+if any, to sign a "copyright disclaimer" for the program, if necessary.
+For more information on this, and how to apply and follow the GNU AGPL, see
+.
diff --git a/EXISTENTIAL.md b/EXISTENTIAL.md
new file mode 100644
index 000000000..e0e35ffbf
--- /dev/null
+++ b/EXISTENTIAL.md
@@ -0,0 +1,37 @@
+Notes on existential types:
+
+1. Only introduced by filter, iota (on RHS)
+
+2. Eliminate by pulling out ∃n. int(n) as int(#n). We don't ever need ∃n. int(n)
+ to check against ∀n. int(n) (say) because we don't allow higher-rank types
+ (also it wouldn't work).
+
+3. #n unifies with any (universal) type variable as a constant; #n doesn't unify
+ with 2 (say), ∃n. int(n) shouldn't unify with int(2) (the former being, say,
+ the result of a filter...)
+
+4. DISPLAY: I think we can restrict so that all #n are on the RHS of the arrow,
+ then display as ∃n. ...
+
+
+existential vs. universal:
+
+int(4) checks against ∃n. int(n) BUT it is not an instance of ∀n. int(n)
+
+however, a term of type ∀n. int(n) could be instantiated to type int(4) if
+wanted.
+term of type ∃n. int(n) does not check against ∀n. int(n)
+term of type ∀n. int(n) checks against ∃n. int(n) (can be instantiated etc.)
+∃n. int(n) can be used as an argument to a function of type ∀n. int(n) → bool
+(instantiate with virtual #n, then #n = n..., treating #n as a constant)
+
+# Python
+
+Note that Python gets this precisely wrong! In Python, an integer can have type
+`Any`, and a value of type `Any` can be used as a string.
+
+What *should* happen is that an integer checks against the type ∃a:type. a. Now,
+a value of type ∃a:type. a should *not* check against the type string.
+
+HOWEVER, a value of type ∀a:type. a SHOULD check against integer and also
+string...
diff --git a/IDIOMS.md b/IDIOMS.md
new file mode 100644
index 000000000..5f09c8071
--- /dev/null
+++ b/IDIOMS.md
@@ -0,0 +1,4 @@
+- [ ] `+/` and `*/` have SIMD
+- [ ] fold-map-reduce and variations
+- [ ] https://stackoverflow.com/a/45786422/11296354
+ - [ ] note ln (simplified)
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 000000000..9a25a4071
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,14 @@
+Copyright (C) 2022 Vanessa McHale
+
+This program is free software: you can redistribute it and/or modify
+it under the terms of the GNU Affero General Public License as published by
+the Free Software Foundation, either version 3 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 Affero General Public License for more details.
+
+You should have received a copy of the GNU Affero General Public License
+along with this program. If not, see .
diff --git a/LITERATURE.md b/LITERATURE.md
new file mode 100644
index 000000000..231364c2a
--- /dev/null
+++ b/LITERATURE.md
@@ -0,0 +1,26 @@
+- [ ] https://www.lri.fr/~filliatr/ens/compil/x86-64.pdf
+- [ ] https://www.cs.princeton.edu/courses/archive/spr16/cos217/lectures/16_MachineLang.pdf
+- [ ] https://staffwww.fullcoll.edu/aclifton/cs241/lecture-floating-point-simd.html
+- [ ] log https://stackoverflow.com/questions/45785705/logarithm-in-c-and-assembly
+- [ ] https://cfallin.org/blog/2022/06/09/cranelift-regalloc2/
+- [ ] https://kobzol.github.io/davis/
+- [ ] http://asmdebugger.com/
+- [ ] https://twitter.com/johncarlosbaez/status/1541812092897861632
+- [ ] https://vim.fandom.com/wiki/Folding#Opening_and_closing_folds
+- [ ] https://en.wikipedia.org/wiki/Double-precision_floating-point_format
+
+# Haskal
+- [ ] https://hackage.haskell.org/package/linearscan-1.0.0/docs/LinearScan.html
+- [ ] https://hackage.haskell.org/package/reg-alloc-graph-color
+
+# JIT
+- [ ] https://stackoverflow.com/questions/19552158/call-an-absolute-pointer-in-x86-machine-code
+- [ ] https://stackoverflow.com/questions/54947302/handling-calls-to-potentially-far-away-ahead-of-time-compiled-functions-from-j
+- [ ] https://stackoverflow.com/questions/64852711/how-do-i-call-puts-in-a-jit
+
+# Python?
+- [ ] https://github.com/pola-rs/polars/
+- [ ] https://docs.python.org/3/extending/extending.html
+- [ ] https://numpy.org/doc/stable/reference/c-api/array.html#
+- [ ] https://docs.python.org/3/c-api/index.html
+- [ ] https://pythonextensionpatterns.readthedocs.io/en/latest/parsing_arguments.html#variable-number-of-arguments
diff --git a/LOOPING.md b/LOOPING.md
new file mode 100644
index 000000000..78b72ef15
--- /dev/null
+++ b/LOOPING.md
@@ -0,0 +1,3 @@
+- [ ] Loop unrolling
+- [ ] Backwards/compare to 0 instead: (`test rax, rax ...`) https://stackoverflow.com/a/13064985
+ - [ ] https://stackoverflow.com/a/14842140/11296354
diff --git a/MEM.md b/MEM.md
new file mode 100644
index 000000000..8305c4ed4
--- /dev/null
+++ b/MEM.md
@@ -0,0 +1,4 @@
+- [ ] 1: decide when we want to be able to reuse allocations, dispatch that in
+ type system...
+- [ ] liveness analysis (in stmt layer?) -> copy/free should be doable
+ - [ ] maybe special register type for arrays?
diff --git a/Makefile b/Makefile
new file mode 100644
index 000000000..38985bf23
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,21 @@
+HS_SRC := $(shell find src -type f) $(shell find lib -type f) apple.cabal
+
+libapple.so: $(HS_SRC) include/apple.h
+ cabal build flib:apple -w ghc-9.4.2
+ cp $$(fd 'libapple\.so$$' dist-newstyle) .
+
+moddeps.svg: $(HS_SRC)
+ graphmod -i src | dot -Tsvg -o $@
+
+install-lib: libapple.so
+ cp $^ /usr/local/lib
+
+install:
+ cabal install -w ghc-9.4.2
+ strip $$(readlink -f $$(which atc))
+ strip $$(readlink -f $$(which writeo))
+ strip $$(readlink -f $$(which arepl))
+
+clean:
+ make -C pyc clean
+ rm -rf dist-newstyle tags moddeps.svg *.hp *.prof *.svg *.so
diff --git a/POW.md b/POW.md
new file mode 100644
index 000000000..440d3ef27
--- /dev/null
+++ b/POW.md
@@ -0,0 +1,32 @@
+Exponentiation with integer exponent:
+ 1. To check parity, `AND` with 0x1 instead of `idiv`
+
+See:
+
+```ats
+// Fast integer exponentiation. This performs O(log n) multiplications. This
+// function is mostly useful for exponentiation in modular arithmetic, as
+// it can overflow.
+fun exp {n:nat} .. (x : int, n : int(n)) : int =
+ case+ x of
+ | 0 => 0
+ | x =>>
+ begin
+ if n > 0 then
+ let
+ var n2 = half(n)
+ var i2 = n % 2
+ in
+ if i2 = 0 then
+ exp(x * x, n2)
+ else
+ let
+ var y = x * exp(x * x, n2)
+ in
+ y
+ end
+ end
+ else
+ 1
+ end
+```
diff --git a/README.md b/README.md
new file mode 100644
index 000000000..a8c0c7e7c
--- /dev/null
+++ b/README.md
@@ -0,0 +1,52 @@
+# Apple Array System
+
+## Compiler-As-a-Library
+
+Rather than an environment-based interpreter or a compiler invoked on the
+command line and generating object files, Apple generates machine code which can
+be used by a JIT compiler or in general.
+
+Thus the same implementation can be used interpreted, compiled, or called from
+another language.
+
+## Documentation from Types
+
+Like Haskell's Haddock or Doxygen, one can generate hyperlinked type signatures,
+e.g.
+
+```
+hypergeometric : Arr (i `Cons` Nil) float -> Arr (j `Cons` Nil) float -> float -> float
+```
+
+This saves the author from writing redundant documentation.
+
+Programmatic type inference can be of aid in debugging.
+
+## Dimension As a Functor
+
+This is based on J (and APL?). Looping is replaced by functoriality (map); we
+have a family of functors `('n)`
+
+## Linear Memory Allocation
+
+Rather than calling `malloc` to create a new array, arrays
+
+
+
+
+## Special Combinations
+
+Apple takes inspiration from [J's special combinations](https://code.jsoftware.com/wiki/Vocabulary/SpecialCombinations).
+
+## Moving Code vs. Moving Data
+
+> For a computation to take place the data and the program have to be at the
+> same point in space-time - this is just physics. You can move the data to the
+> program or the program to the data, or both somewhere else. ...
+> data movement predominates.
+
+- [Joe Armstrong](https://twitter.com/joeerl/status/1087678726911987712)
+
+## Property Testing
+
+Types act as witnesses, as in [QuickCheck](https://hackage.haskell.org/package/QuickCheck).
diff --git a/TODO.md b/TODO.md
new file mode 100644
index 000000000..164e09bfd
--- /dev/null
+++ b/TODO.md
@@ -0,0 +1,115 @@
+- [ ] Figure out log/exp... eh
+- [ ] inspiration: J,Haskell,C?,Remora
+- [ ] windows lol
+- [ ] apple (array system)
+- [ ] serialize (save on disk) REPL states
+- [ ] bidirectional type inference (rank-polymorphism aka dimension functor)
+- [ ] documentation generated from types
+- [ ] "array server" architecture like J? (figure out refcounting, copy-on-write -> efficient polymorphism/(static) reuse analysis?)
+ - [ ] example `(2&*) "0`
+- [ ] idioms... deforestation
+- [ ] types... (linear? remora; integer-indexed)
+- [x] `.🍎` file extension (`.🍏`)
+ - [ ] ⍳ (apl iota)
+ - [ ] remora-like type system
+ - [ ] ⩪ for filter
+ - [ ] ℘
+ - [ ] script f https://en.wikipedia.org/wiki/Mathematical_Alphanumeric_Symbols#Latin_letters
+ - [ ] https://en.wikipedia.org/wiki/Mathematical_operators_and_symbols_in_Unicode
+ - [ ] dfns like k, APL (J)
+- [ ] big three: map, reduce, zip (dyadic map)
+ - [ ] unfold
+ - [ ] map is naturally functorial, zip then is a bifunctor (etc.) n-functor
+ over dimension
+ - [ ] our 'map' is a family of functors... arrays being functorial over
+ cells
+ - [ ] mapMaybe hm
+ - [x] problem: filter (#) (existential types... PITA?)
+ EXAMPLE: (*2)"0
+ filt. -> Vec i Bool -> Vec i Int -> ∃n. Vec n Int
+
+- [ ] numpy einstein summation
+ - [ ] https://ajcr.net/Basic-guide-to-einsum/
+- [ ] documentation from types
+ - [ ] quickcheck!
+ - [ ] automatic differentiation (pytorch eh)
+- [ ] deforestation
+- [ ] Note: !-modality is functorial, so we get some polymorphism that way?
+# Features
+- [ ] allow type signatures in lambdas?
+- [ ] mko executable - compile expression into .o file, with some name
+- [ ] random number generation
+- [ ] lift constants out of loops (precompute)
+- [ ] tuples idk.
+- [ ] reshape arrays...
+- [ ] clz? (count leading zeroes = floor(log) -> digits)
+## Syntax
+- [ ] https://en.wikipedia.org/wiki/Mathematical_operators_and_symbols_in_Unicode
+- [ ] https://www.compart.com/en/unicode/U+1D66
+## Optimization
+- [ ] `neg` instruction, not `0-`...
+- [ ] Back/forward loops (compare to 0 or whatever)
+- [ ] Break dependency chains: use e.g. four accumulators per loop cycle when
+ summing float array (see agner fog)
+# Performance
+- [ ] `-O2` perhaps (investigate with further pipeline)
+- [ ] Modify state (+1) instead of using lazy list to supply e.g. temps
+- [ ] Live intervals/linear allocator is stupid as shit
+ - [ ] need to do backwards/forwards thing and stitch it up at basic block
+ boundaries
+- [ ] entropy: vfmadd231sd could take address directly as argument!
+# Modules
+- [x] Assembler
+- [x] linear register allocator
+- [ ] deforestation
+# Bugs
+- [ ] `gammaln` generates `vaddsd rsp, xmm3, xmm1` lol
+- [ ] Pass over to ensure everything is monomorphized
+- [ ] `itof (:xs)` - would prefer w/o parens?
+- [ ] it would be nice to write `_x%y` instead of `(_x)%y` (parse precedence)
+- [ ] x+y-1 parsed as (x + (y - 1))
+## Type system
+- [ ] Check that bindings are not too polymorphic
+- [ ] `LLet` cannot contain functions (lol)
+# Checks/Passes
+- [ ] Warn if irange or frange will exceed?
+- [ ] Sanity check pass to make sure xmm0 doesn't end up target of `movtemp` etc.
+# Examples
+- [ ] median
+- [ ] https://optimized-einsum.readthedocs.io/en/stable/
+- [ ] polynomial evaluation
+- [ ] modulo
+- [ ] http://blog.vmchale.com/article/numba-why
+- [ ] https://mathworld.wolfram.com/MotzkinNumber.html
+- [ ] perceptual hash
+- [ ] elliptic fourier series
+ - [ ] http://www.sci.utah.edu/~gerig/CS7960-S2010/handouts/Kuhl-Giardina-CGIP1982.pdf
+- [ ] Pascal's triangle
+- [ ] FFT
+- [ ] generating functions
+- [ ] continued fractions
+- [ ] `+//. y` in J... maybe `/.` takes `∀n. (Arr (n `Cons` Nil)) -> ...`
+- [ ] matrix multiplication
+ - [ ] rearrange: note that I implicitly coerce
+ `Arr (i `Cons` Nil) (Arr (j `Cons` Nil) a)` into (Arr (i `Cons` j `Cons` Nil) a)
+ which I guess needs a function (annoying?)
+ - [ ] my `map` is too underpowered I think... compared to true rank (remora
+ paper?)
+ - [ ] could have a matmul builtin lol
+- [ ] https://www.labri.fr/perso/nrougier/from-python-to-numpy/
+- [ ] neural net!
+- [ ] think: inner/outer product, wedge products (?)
+ - [ ] permutations/indices (determinant...)
+- [ ] https://en.wikipedia.org/wiki/Arithmetic–geometric_mean#Complete_elliptic_integral_K(sinα)
+- [ ] https://github.com/justin2004/image-processing#image-processing-with-apl
+- [ ] http://shvbsle.in/computers-are-fast-but-you-dont-know-it-p1/
+- [ ] Python FFI: modify a numpy array or something; regression->matplotlib?
+- [ ] SciPy t-test
+- [ ] discrete cosine transformation
+- [ ] full hypergeometric (analytically extended?)
+- [ ] https://www.shamusyoung.com/twentysidedtale/?p=11874
+- [ ] ANOVA
+- [ ] convolution (image processing)
+- [ ] http://www.paulbourke.net/fractals/burnship/
+- [ ] kaplan-meier, clopper-pearson?
+- [ ] https://forem.julialang.org/inphyt/ann-juliaepi-collaborative-computational-epidemiology-in-julia-19ng
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
index 000000000..57506261b
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,33 @@
+module Main (main) where
+
+import Control.Exception (throwIO)
+import qualified Data.ByteString.Lazy as BSL
+import Data.Semigroup ((<>))
+import qualified Data.Version as V
+import Options.Applicative
+import P
+import qualified Paths_apple as P
+
+fp :: Parser FilePath
+fp = argument str
+ (metavar "SRC_FILE"
+ <> help "Source file")
+
+wrapper :: ParserInfo FilePath
+wrapper = info (helper <*> versionMod <*> fp)
+ (fullDesc
+ <> progDesc "Editor integration for the Apple language"
+ <> header "atc - apple type checker")
+
+versionMod :: Parser (a -> a)
+versionMod = infoOption (V.showVersion P.version) (short 'V' <> long "version" <> help "Show version")
+
+main :: IO ()
+main = run =<< execParser wrapper
+
+run :: FilePath -> IO ()
+run fpϵ = do
+ contents <- BSL.readFile fpϵ
+ case tyParse contents of
+ Left err -> throwIO err
+ Right{} -> pure ()
diff --git a/apple.cabal b/apple.cabal
new file mode 100644
index 000000000..f678d3cb7
--- /dev/null
+++ b/apple.cabal
@@ -0,0 +1,296 @@
+cabal-version: 1.18
+name: apple
+version: 0.1.0.0
+license: AGPL-3
+license-file: LICENSE
+copyright: Copyright: (c) 2022 Vanessa McHale
+maintainer: vamchale@gmail.com
+author: Vanessa McHale
+category: Language, Array
+build-type: Simple
+data-files:
+ ./c/apple.c
+extra-doc-files:
+ README.md
+ CHANGELOG.md
+
+source-repository head
+ type: darcs
+ location: https://hub.darcs.net/vmchale/apple
+
+library
+ exposed-modules:
+ Dbg
+ P
+ A
+ Ty
+ Name
+ U
+ L
+ IR
+ I
+ A.Eta
+ CGen
+ Hs.A
+ Hs.FFI
+ Sys.DL
+ Asm.X86.Byte
+
+ build-tool-depends: alex:alex, happy:happy, hsc2hs:hsc2hs, c2hs:c2hs
+ hs-source-dirs: src
+ other-modules:
+ CF
+ LI
+ R
+ LR
+ R.Dfn
+ R.M
+ Parser
+ Parser.Rw
+ Ty.Clone
+ A.Opt
+ IR.Alloc
+ IR.CF
+ IR.Trans
+ Prettyprinter.Ext
+ Data.Copointed
+ Asm.X86
+ Asm.X86.BB
+ Asm.X86.Opt
+ Asm.X86.Alloc
+ Asm.X86.Color
+ Asm.X86.CF
+ Asm.X86.Trans
+ Asm.G
+
+ default-language: Haskell2010
+ other-extensions:
+ OverloadedStrings RankNTypes DeriveGeneric DeriveAnyClass
+ StandaloneDeriving DeriveFunctor FlexibleContexts
+
+ ghc-options: -Wall -fno-warn-missing-signatures
+ build-depends:
+ base >=4.10 && <5,
+ prettyprinter >=1.7.0,
+ deepseq,
+ text,
+ mtl >=2.2.2,
+ containers,
+ microlens,
+ microlens-mtl >=0.1.8.0,
+ array,
+ bytestring,
+ transformers,
+ split,
+ unix,
+ extra
+
+ if !impl(ghc >=8.0)
+ build-depends: semigroups
+
+ if impl(ghc >=8.0)
+ ghc-options:
+ -Wincomplete-uni-patterns -Wincomplete-record-updates
+ -Wredundant-constraints -Widentities
+
+ if impl(ghc >=8.4)
+ ghc-options: -Wmissing-export-lists
+
+ if impl(ghc >=8.2)
+ ghc-options: -Wcpp-undef
+
+ if impl(ghc >=8.10)
+ ghc-options: -Wunused-packages
+
+ if impl(ghc >=9.2)
+ ghc-options: -Wno-operator-whitespace-ext-conflict
+
+foreign-library apple
+ type: native-shared
+ hs-source-dirs: lib
+ other-modules: E
+ build-tool-depends: c2hs:c2hs >=0.19.1
+ default-language: Haskell2010
+ include-dirs: include
+ install-includes: apple.h
+ ghc-options: -Wall
+ build-depends:
+ base,
+ apple,
+ bytestring >=0.11.0.0,
+ prettyprinter,
+ text
+
+ lib-version-info: 1:0:0
+
+ if os(windows)
+ options: standalone
+
+ if impl(ghc >=8.0)
+ ghc-options:
+ -Wincomplete-uni-patterns -Wincomplete-record-updates
+ -Wredundant-constraints
+
+ if impl(ghc >=8.4)
+ ghc-options: -Wmissing-export-lists
+
+ if impl(ghc >=8.10)
+ ghc-options: -Wunused-packages
+
+executable atc
+ main-is: Main.hs
+ hs-source-dirs: app
+ other-modules: Paths_apple
+ default-language: Haskell2010
+ ghc-options: -Wall
+ build-depends:
+ base,
+ apple,
+ optparse-applicative >=0.13.0.0,
+ bytestring
+
+ if !impl(ghc >=8.0)
+ build-depends: semigroups
+
+ if impl(ghc >=8.0)
+ ghc-options:
+ -Wincomplete-uni-patterns -Wincomplete-record-updates
+ -Wredundant-constraints -Widentities
+
+ if impl(ghc >=8.4)
+ ghc-options: -Wmissing-export-lists
+
+ if impl(ghc >=8.2)
+ ghc-options: -Wcpp-undef
+
+ if impl(ghc >=8.10)
+ ghc-options: -Wunused-packages
+
+executable writeo
+ main-is: Main.hs
+ hs-source-dirs: exe
+ other-modules:
+ Nasm
+ Paths_apple
+
+ default-language: Haskell2010
+ ghc-options: -Wall
+ build-depends:
+ base,
+ apple,
+ optparse-applicative >=0.14.0.0,
+ bytestring,
+ prettyprinter,
+ temporary,
+ process,
+ text
+
+ if !impl(ghc >=8.0)
+ build-depends: semigroups
+
+ if impl(ghc >=8.0)
+ ghc-options:
+ -Wincomplete-uni-patterns -Wincomplete-record-updates
+ -Wredundant-constraints -Widentities
+
+ if impl(ghc >=8.4)
+ ghc-options: -Wmissing-export-lists
+
+ if impl(ghc >=8.2)
+ ghc-options: -Wcpp-undef
+
+ if impl(ghc >=8.10)
+ ghc-options: -Wunused-packages
+
+executable arepl
+ main-is: Main.hs
+ hs-source-dirs: run
+
+ default-language: Haskell2010
+ ghc-options: -Wall
+ build-depends:
+ base,
+ apple,
+ bytestring,
+ libffi,
+ prettyprinter,
+ containers,
+ haskeline,
+ mtl,
+ text,
+ directory,
+ filepath
+
+ if !impl(ghc >=8.0)
+ build-depends: semigroups
+
+ if impl(ghc >=8.0)
+ ghc-options:
+ -Wincomplete-uni-patterns -Wincomplete-record-updates
+ -Wredundant-constraints -Widentities
+
+ if impl(ghc >=8.4)
+ ghc-options: -Wmissing-export-lists
+
+ if impl(ghc >=8.2)
+ ghc-options: -Wcpp-undef
+
+ if impl(ghc >=8.10)
+ ghc-options: -Wunused-packages
+
+test-suite apple-test
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ hs-source-dirs: test
+ default-language: Haskell2010
+ ghc-options: -threaded -rtsopts "-with-rtsopts=-N -K1K" -Wall -fno-warn-missing-signatures
+ build-tool-depends: cpphs:cpphs
+ build-depends:
+ base,
+ apple,
+ tasty,
+ tasty-hunit,
+ bytestring,
+ hypergeometric>=0.1.1.0
+
+ if impl(ghc >=8.0)
+ ghc-options:
+ -Wincomplete-uni-patterns -Wincomplete-record-updates
+ -Wredundant-constraints -Widentities
+
+ if impl(ghc >=8.4)
+ ghc-options: -Wmissing-export-lists
+
+ if impl(ghc >=8.2)
+ ghc-options: -Wcpp-undef
+
+ if impl(ghc >=8.10)
+ ghc-options: -Wunused-packages
+
+benchmark apple-bench
+ type: exitcode-stdio-1.0
+ main-is: Bench.hs
+ build-tool-depends: cpphs:cpphs
+ hs-source-dirs: bench
+ default-language: Haskell2010
+ ghc-options: -rtsopts -Wall
+ build-depends:
+ base,
+ apple,
+ criterion,
+ bytestring,
+ erf,hypergeometric>=0.1.1.0
+
+ if impl(ghc >=8.0)
+ ghc-options:
+ -Wincomplete-uni-patterns -Wincomplete-record-updates
+ -Wredundant-constraints -Widentities
+
+ if impl(ghc >=8.4)
+ ghc-options: -Wmissing-export-lists
+
+ if impl(ghc >=8.2)
+ ghc-options: -Wcpp-undef
+
+ if impl(ghc >=8.10)
+ ghc-options: -Wunused-packages
diff --git a/bench/Bench.cpphs b/bench/Bench.cpphs
new file mode 100644
index 000000000..93126951b
--- /dev/null
+++ b/bench/Bench.cpphs
@@ -0,0 +1,124 @@
+module Main (main) where
+
+import Asm.X86.Byte
+import Control.Exception (Exception, throw)
+import Criterion.Main
+import qualified Data.ByteString.Lazy as BSL
+import Data.Functor (($>))
+import Data.Number.Erf (erf)
+import Foreign.Marshal.Alloc (free, mallocBytes)
+import Foreign.Ptr (FunPtr, Ptr)
+import Foreign.Storable (Storable (..))
+import Hs.A
+import I
+import qualified Math.Hypergeometric as Hyper
+import qualified Math.SpecialFunction as Math
+import P
+import Ty
+
+risingFactorial :: Integral a => a -> a -> a
+risingFactorial x n = product [x..(x+n-1)]
+{-# SPECIALIZE risingFactorial :: Int -> Int -> Int #-}
+
+hsEntropy :: Floating a => [a] -> a
+hsEntropy xs = sum [ x * log x | x <- xs ]
+
+kl :: Floating a => [a] -> [a] -> a
+kl xs ys = sum [ x * log (x/y) | x <- xs, y <- ys ]
+
+aA :: Storable a => Apple a -> IO (Ptr (Apple a))
+aA x = do
+ p <- mallocBytes (sizeOf x)
+ poke p x $> p
+
+main :: IO ()
+main = do
+ -- this sucks but using env segfaults so...
+ xsPtr <- aA (AA 1 [500] xs)
+ ysPtr <- aA (AA 1 [500] ys)
+ iPtr <- aA (AA 1 [10000000] (replicate 10000000 (1::Int)))
+#ifdef x86_64_HOST_ARCH
+ fp <- fmap iii . funP =<< BSL.readFile "test/examples/risingFactorial.🍎"
+ erfFp <- fmap ff . funP =<< BSL.readFile "test/examples/erf.🍏"
+ entropyFp <- fmap af . funP =<< BSL.readFile "test/examples/entropy.🍏"
+ klFp <- fmap aaf . funP =<< BSL.readFile "test/examples/kl.🍎"
+ gammaFp <- fmap ff . funP =<< BSL.readFile "test/examples/gammaln.🍏"
+ scanFp <- fmap aa . funP =<< BSL.readFile "bench/apple/scanmax.🍏"
+#endif
+ defaultMain [ env files $ \ ~(he, e, f, 𝛾) ->
+ bgroup "pipeline"
+ [ bench "tyParse (erf)" $ nf tyParse he
+ , bench "tyParse" $ nf tyParse e
+ -- , bench "expanded" $ nf opt he
+ , bench "bytes (erf)" $ nf bytes he
+ , bench "bytes" $ nf bytes f
+ , bench "bytes (gammaln)" $ nf bytes 𝛾
+ ]
+ -- TODO: thunks after type checking?
+ , env rfx86 $ \asm ->
+ bgroup "asm"
+ [ bench "risingFactorial" $ nf assemble asm
+ ]
+ , env (fmap yeet erfParsed) $ \ast ->
+ bgroup "ty"
+ [ bench "tyClosed" $ nf (\(e, m) -> tyClosed m e) ast
+ ]
+ , env (fmap yeet erfTy) $ \e ->
+ bgroup "inline"
+ [ bench "inline" $ nf (\(ast, i) -> fst (inline i ast)) e
+ ]
+ , bgroup "erf"
+ [ bench "erf (libm)" $ nf erf (1 :: Double)
+ , bench "erf (hypergeometric)" $ nf Hyper.erf (1 :: Double)
+#ifdef x86_64_HOST_ARCH
+ , bench "erf (jit)" $ nfIO (pure $ erfFp 1)
+#endif
+ ]
+ , bgroup "risingFactorial"
+ [ bench "hs" $ nf (risingFactorial 5) (15 :: Int)
+#ifdef x86_64_HOST_ARCH
+ , bench "jit" $ nfIO (pure $ fp 5 15)
+#endif
+ ]
+ , bgroup "entropy"
+ [ bench "hs" $ nf hsEntropy xs
+#ifdef x86_64_HOST_ARCH
+ , bench "jit" $ nfIO $ (pure $ entropyFp xsPtr)
+#endif
+ ]
+ , bgroup "k-l"
+ [ bench "hs" $ nf (kl xs) ys
+#ifdef x86_64_HOST_ARCH
+ , bench "jit" $ nfIO (pure $ klFp xsPtr ysPtr)
+#endif
+ ]
+ , bgroup "Γ"
+ [ bench "hs" $ nf Math.gammaln (1.5 :: Double)
+#ifdef x86_64_HOST_ARCH
+ , bench "jit" $ nfIO (pure $ gammaFp 1.5)
+#endif
+ ]
+#ifdef x86_64_HOST_ARCH
+ , bgroup "scanmax"
+ [ bench "apple" $ nfIO (do {p<- scanFp iPtr;free p})
+ ]
+#endif
+ ]
+ where erfSrc = BSL.readFile "test/examples/erf.🍏"
+ rf = BSL.readFile "test/examples/risingFactorial.🍎"
+ expApple = BSL.readFile "test/examples/exp.🍏"
+ gamma = BSL.readFile "test/examples/gammaln.🍏"
+ rfx86 = yeet . x86 <$> rf
+ files = (,,,) <$> erfSrc <*> expApple <*> rf <*> gamma
+ erfParsed = parseRename <$> erfSrc
+ erfTy = tyParse <$> erfSrc
+ yeet :: (Exception e) => Either e a -> a
+ yeet = either throw id
+ xs = replicate 500 (0.002 :: Double)
+ ys = replicate 500 (0.002 :: Double)
+
+foreign import ccall "dynamic" iii :: FunPtr (Int -> Int -> Int) -> Int -> Int -> Int
+foreign import ccall "dynamic" ff :: FunPtr (Double -> Double) -> Double -> Double
+foreign import ccall "dynamic" aaf :: FunPtr (Ptr (Apple a) -> Ptr (Apple a) -> Double) -> Ptr (Apple a) -> Ptr (Apple a) -> Double
+foreign import ccall "dynamic" af :: FunPtr (Ptr (Apple a) -> Double) -> Ptr (Apple a) -> Double
+foreign import ccall "dynamic" aa :: FunPtr (Ptr (Apple a) -> IO (Ptr (Apple a))) -> Ptr (Apple a) -> IO (Ptr (Apple a))
diff --git "a/bench/apple/scanmax.\360\237\215\217" "b/bench/apple/scanmax.\360\237\215\217"
new file mode 100644
index 000000000..597126a90
--- /dev/null
+++ "b/bench/apple/scanmax.\360\237\215\217"
@@ -0,0 +1 @@
+[(⋉) Λ 0 (x::Arr (i `Cons` Nil) int)]
diff --git a/cabal.project b/cabal.project
new file mode 100644
index 000000000..ae69ca8d5
--- /dev/null
+++ b/cabal.project
@@ -0,0 +1,10 @@
+packages: ./
+
+haddock-internal: True
+
+program-options
+ alex-options: -g
+ happy-options: -gcsa
+
+package apple
+ ghc-options: -j +RTS -A32m
diff --git a/exe/Main.hs b/exe/Main.hs
new file mode 100644
index 000000000..1a0e04169
--- /dev/null
+++ b/exe/Main.hs
@@ -0,0 +1,38 @@
+module Main (main) where
+
+import qualified Data.ByteString.Lazy as BSL
+import Data.Semigroup ((<>))
+import qualified Data.Text as T
+import qualified Data.Version as V
+import Nasm
+import Options.Applicative
+import qualified Paths_apple as P
+
+fp :: Parser FilePath
+fp = argument str
+ (metavar "SRC_FILE"
+ <> help "Source file")
+
+fun :: Parser T.Text
+fun = strOption
+ (short 'f'
+ <> metavar "FUNCTION"
+ <> help "Function name in generated .o")
+
+wrapper :: ParserInfo (FilePath, T.Text)
+wrapper = info (helper <*> versionMod <*> p)
+ (fullDesc
+ <> header "Output object files with Apple array system"
+ <> progDesc "writeo - generate object files")
+ where p = (,) <$> fp <*> fun
+
+versionMod :: Parser (a -> a)
+versionMod = infoOption (V.showVersion P.version) (short 'V' <> long "version" <> help "Show version")
+
+main :: IO ()
+main = run =<< execParser wrapper
+
+run :: (FilePath, T.Text) -> IO ()
+run (fpϵ, n) = do
+ contents <- BSL.readFile fpϵ
+ writeO n contents True
diff --git a/exe/Nasm.hs b/exe/Nasm.hs
new file mode 100644
index 000000000..6a6abbcd4
--- /dev/null
+++ b/exe/Nasm.hs
@@ -0,0 +1,26 @@
+module Nasm ( writeO ) where
+
+import qualified Data.ByteString.Lazy as BSL
+import Data.Functor (void)
+import Data.Semigroup ((<>))
+import qualified Data.Text as T
+import qualified Data.Text.Lazy.IO as TLIO
+import Dbg
+import Prettyprinter (layoutCompact)
+import Prettyprinter.Render.Text (renderLazy)
+import System.IO (hFlush)
+import System.IO.Temp (withSystemTempFile)
+import System.Process (CreateProcess (..), StdStream (Inherit), proc, readCreateProcess)
+
+writeO :: T.Text -- ^ Function name
+ -> BSL.ByteString
+ -> Bool -- ^ Debug symbols?
+ -> IO ()
+writeO f contents dbg = withSystemTempFile "apple.S" $ \fp h -> do
+ let txt = renderLazy $ layoutCompact (nasm f contents)
+ TLIO.hPutStr h txt
+ hFlush h
+ let debugFlag = if dbg then ("-g":) else id
+ -- -O1 is signed byte optimization but no multi-passes
+ void $ readCreateProcess ((proc "nasm" (debugFlag [fp, "-f", "elf64", "-O1", "-o", fpO])) { std_err = Inherit }) ""
+ where fpO = T.unpack f <> ".o"
diff --git a/include/apple.h b/include/apple.h
new file mode 100644
index 000000000..047fcf92f
--- /dev/null
+++ b/include/apple.h
@@ -0,0 +1,11 @@
+void* apple_compile(const char*);
+// NULL on error
+char* apple_printty(const char*, char**);
+
+// FIXME: how do c-niles handle tuples??
+enum apple_t{I_t,F_t,IA,FA,Fn};
+
+// returns -1 on error
+enum apple_t apple_ty(const char*, char**);
+
+enum apple_err{TooPolymorphic,Wrong};
diff --git a/include/apple_abi.h b/include/apple_abi.h
new file mode 100644
index 000000000..31268474c
--- /dev/null
+++ b/include/apple_abi.h
@@ -0,0 +1,12 @@
+#include
+
+#define R return
+#define I int64_t
+#define F double
+#define U void*
+#define B bool
+
+#define DO(i,n,a) {I i;for(i=0;i))
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Data.Word (Word8)
+import Foreign.C.String (CString)
+import Foreign.C.Types (CInt (..), CSize (..), CChar)
+import Foreign.Marshal.Alloc (mallocBytes)
+import Foreign.Ptr (Ptr, castPtr, castFunPtrToPtr, nullPtr)
+import Foreign.Storable (poke, pokeByteOff)
+import P
+import Prettyprinter (Pretty (..), layoutCompact)
+import Prettyprinter.Render.Text (renderStrict)
+
+#include
+#include
+#include
+
+{# fun memcpy as ^ { castPtr `Ptr a', castPtr `Ptr a', coerce `CSize' } -> `Ptr a' castPtr #}
+
+-- how tf do C weenies store like... function types??
+{# enum apple_t as CT {} #}
+{# enum apple_err as IErr {} #}
+
+tcstr :: T.Text -> IO CString
+tcstr t =
+ BS.unsafeUseAsCStringLen (encodeUtf8 t) $ \(bs,sz) -> do
+ p <- mallocBytes (sz+1)
+ memcpy p bs (fromIntegral sz)
+ pokeByteOff p sz (0::CChar) $> p
+
+apple_printty :: CString -> Ptr CString -> IO CString
+apple_printty src errPtr = do
+ bSrc <- BS.unsafePackCString src
+ case tyExpr (BSL.fromStrict bSrc) of
+ Left err ->
+ (poke errPtr =<< tcstr (ptxt err)) $> nullPtr
+ Right t -> tcstr (ptxt t)
+
+ptxt :: Pretty a => a -> T.Text
+ptxt = renderStrict . layoutCompact . pretty
+
+apple_ty :: CString -> Ptr CString -> IO CInt
+apple_ty src errPtr = do
+ bSrc <- BS.unsafePackCString src
+ let b = tyExpr (BSL.fromStrict bSrc)
+ case b of
+ Left err -> do
+ poke errPtr =<< tcstr (ptxt err)
+ pure (-1)
+ Right t -> pure $ fromIntegral $ fromEnum $ case t of
+ A.I -> I_t
+ A.F -> F_t
+ (A.Arr _ A.I) -> IA
+ (A.Arr _ A.F) -> FA
+ A.Arrow{} -> Fn
+
+apple_compile :: CString -> IO (Ptr Word8)
+apple_compile src = do
+ bSrc <- BS.unsafePackCString src
+ castFunPtrToPtr <$> funP (BSL.fromStrict bSrc)
+
+foreign export ccall apple_compile :: CString -> IO (Ptr Word8)
+foreign export ccall apple_printty :: CString -> Ptr CString -> IO CString
+foreign export ccall apple_ty :: CString -> Ptr CString -> IO CInt
diff --git a/pyc/Makefile b/pyc/Makefile
new file mode 100644
index 000000000..08f0be570
--- /dev/null
+++ b/pyc/Makefile
@@ -0,0 +1,17 @@
+GHC_VER := 9.4.2
+HS_LIBDIR := $(shell ghc-pkg-$(GHC_VER) field rts dynamic-library-dirs | ja '{ix=1}{`2}')
+HS_INCLUDE_DIR := $(shell ghc-pkg-$(GHC_VER) field rts include-dirs | ja '{ix=1}{`2}')
+
+all: apple.so
+
+install: apple.so
+ cp $^ $$(python3 -m site --user-site)
+
+apple.o: applemodule.c
+ gcc -fPIC -O2 -c $< -I /usr/include/python3.10 -I ../include -I $(HS_INCLUDE_DIR) -o $@
+
+apple.so: apple.o
+ gcc -shared $^ -o $@ -lapple -L .. -lHSrts-1.0.2-ghc$(GHC_VER) -L $(HS_LIBDIR)
+
+clean:
+ rm -rf *.o *.so
diff --git a/pyc/applemodule.c b/pyc/applemodule.c
new file mode 100644
index 000000000..c2392e133
--- /dev/null
+++ b/pyc/applemodule.c
@@ -0,0 +1,84 @@
+#include
+#include
+#include
+#include
+#include
+
+#define U void*
+#define R return
+
+PyObject* npy_i(U x) {
+ I* i_p = x;
+ I t = 1;
+ I rnk = i_p[0];
+ long* dims=malloc(sizeof(long)*rnk);
+ DO(i,rnk,t*=i_p[i+1];dims[i]=(long)i_p[i+1]);
+ size_t sz=8*t;
+ U data=malloc(sz);
+ memcpy(data,i_p+rnk+1,sz);
+ PyObject* res=PyArray_SimpleNewFromData(rnk,dims,NPY_INT64,data);
+ free(x);R res;
+}
+
+PyObject* npy_f(U x) {
+ I* i_p = x;
+ I t = 1;
+ I rnk = i_p[0];
+ long* dims=malloc(sizeof(long)*rnk);
+ DO(i,rnk,t*=i_p[i+1];dims[i]=(long)i_p[i+1]);
+ size_t sz=8*t;
+ U data=malloc(sz);
+ memcpy(data,i_p+rnk+1,sz);
+ PyObject* res=PyArray_SimpleNewFromData(rnk,dims,NPY_INT64,data);
+ free(x);R res;
+}
+
+static PyObject* apple_typeof(PyObject* self, PyObject *args) {
+ const char* inp;
+ PyArg_ParseTuple(args, "s", &inp);
+ char* err;char** err_p = &err;
+ char* res = apple_printty(inp,err_p);
+ if (res == NULL) {
+ PyErr_SetString(PyExc_RuntimeError, err);
+ free(err);R NULL;
+ }
+ PyObject* pyres = PyUnicode_FromString(res);
+ free(res);
+ R pyres;
+}
+
+typedef U (*Ufp)(void);
+typedef I (*Ifp)(void);
+typedef F (*Ffp)(void);
+
+static PyObject* apple_apple(PyObject *self, PyObject *args) {
+ const char* inp;
+ PyArg_ParseTuple(args, "s", &inp);
+ char* err;char** err_p = &err;
+ enum apple_t ty=apple_ty(inp,err_p);
+ if (ty == -1) {
+ PyErr_SetString(PyExc_RuntimeError, err);
+ free(err);R NULL;
+ };
+ U fp;
+ if (ty != Fn){fp=apple_compile(inp);}
+ switch(ty){
+ case Fn: R PyUnicode_FromString("(function)");
+ case IA: R npy_i(((Ufp) fp)());
+ case FA: R npy_f(((Ufp) fp)());
+ case F_t: R PyFloat_FromDouble(((Ffp) fp)());
+ case I_t: R PyLong_FromLongLong(((Ifp) fp)());
+ }
+ // FIXME: function pointer is never freed
+ Py_RETURN_NONE;
+}
+
+static PyMethodDef AppleMethods[] = {
+ {"apple", apple_apple, METH_VARARGS, "JITed array"},
+ {"typeof", apple_typeof, METH_VARARGS, "Display type of expression"},
+ {NULL,NULL,0,NULL}
+};
+
+static struct PyModuleDef applemodule = { PyModuleDef_HEAD_INIT, "apple", NULL, -1, AppleMethods };
+
+PyMODINIT_FUNC PyInit_apple(void) { hs_init(0,0); import_array(); R PyModule_Create(&applemodule); }
diff --git a/run/Main.hs b/run/Main.hs
new file mode 100644
index 000000000..8ca64d303
--- /dev/null
+++ b/run/Main.hs
@@ -0,0 +1,184 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module Main (main) where
+
+import A
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.State (StateT, evalStateT, gets)
+import qualified Data.ByteString.Lazy as BSL
+import Data.List
+import qualified Data.Map as M
+import Data.Semigroup ((<>))
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import Data.Text.Lazy.Encoding (encodeUtf8)
+import Dbg
+import Foreign.LibFFI (callFFI, retCDouble, retInt64, retPtr)
+import Foreign.Marshal.Alloc (free)
+import Foreign.Ptr (Ptr)
+import Foreign.Storable (peek)
+import Hs.A
+import L
+import Prettyprinter (hardline, pretty, (<+>))
+import Prettyprinter.Render.Text (putDoc)
+import Sys.DL
+import System.Console.Haskeline (Completion, CompletionFunc, InputT, defaultSettings, getInputLine, historyFile, runInputT, setComplete, simpleCompletion)
+import System.Directory (getHomeDirectory)
+import System.FilePath (())
+
+main :: IO ()
+main = runRepl loop
+
+data EE = Fn (E AlexPosn) | CI !AI | CF !AF
+
+namesStr :: StateT Env IO [String]
+namesStr = gets (fmap T.unpack . M.keys . ee)
+
+data Env = Env { _lex :: AlexUserState, ee :: M.Map T.Text EE, _mf :: (Int, Int) }
+
+type Repl a = InputT (StateT Env IO)
+
+cyclicSimple :: [String] -> [Completion]
+cyclicSimple [] = []
+cyclicSimple xs = cycle $ fmap simpleCompletion xs
+
+runRepl :: Repl a x -> IO x
+runRepl x = do
+ histDir <- ( ".apple_history") <$> getHomeDirectory
+ mf <- mem'
+ let initSt = Env alexInitUserState M.empty mf
+ let myCompleter = appleCompletions
+ let settings = setComplete myCompleter $ defaultSettings { historyFile = Just histDir }
+ flip evalStateT initSt $ runInputT settings x
+
+appleCompletions :: CompletionFunc (StateT Env IO)
+appleCompletions (":","") = pure (":", cyclicSimple ["help", "h", "ty", "quit", "q", "list"])
+appleCompletions ("i:", "") = pure ("i:", cyclicSimple ["r", ""])
+appleCompletions ("ri:", "") = pure ("ri:", cyclicSimple [""])
+appleCompletions ("t:", "") = pure ("t:", cyclicSimple ["y", ""])
+appleCompletions ("yt:", "") = pure ("yt:", cyclicSimple [""])
+appleCompletions ("d:", "") = pure ("d:", [simpleCompletion "isasm"])
+appleCompletions ("id:", "") = pure ("id:", [simpleCompletion "sasm"])
+appleCompletions ("sid:", "") = pure ("sid:", [simpleCompletion "asm"])
+appleCompletions ("asid:", "") = pure ("asid:", [simpleCompletion "sm"])
+appleCompletions ("sasid:", "") = pure ("sasid:", [simpleCompletion "m"])
+appleCompletions ("msasid:", "") = pure ("msasid:", [simpleCompletion ""])
+appleCompletions ("a:", "") = pure ("a:", [simpleCompletion "ms"])
+appleCompletions ("sa:", "") = pure ("sa:", [simpleCompletion "m"])
+appleCompletions ("msa:", "") = pure ("msa:", [simpleCompletion ""])
+appleCompletions ("q:", "") = pure ("q:", cyclicSimple ["uit", ""])
+appleCompletions ("uq:", "") = pure ("uq:", [simpleCompletion "it"])
+appleCompletions ("iuq:", "") = pure ("iuq:", [simpleCompletion "t"])
+appleCompletions ("tiuq:", "") = pure ("tiuq:", [simpleCompletion ""])
+appleCompletions ("h:", "") = pure ("h:", cyclicSimple ["elp", ""])
+appleCompletions ("eh:", "") = pure ("eh:", [simpleCompletion "lp"])
+appleCompletions ("leh:", "") = pure ("leh:", [simpleCompletion "p"])
+appleCompletions ("pleh:", "") = pure ("pleh:", [simpleCompletion ""])
+appleCompletions (" yt:", "") = do { ns <- namesStr ; pure (" yt:", cyclicSimple ns) }
+appleCompletions (" t:", "") = do { ns <- namesStr ; pure (" t:", cyclicSimple ns) }
+appleCompletions ("", "") = ("",) . cyclicSimple <$> namesStr
+appleCompletions (rp, "") = do { ns <- namesStr ; pure (unwords ("" : tail (words rp)), cyclicSimple (namePrefix ns rp)) }
+appleCompletions _ = pure (undefined, [])
+
+namePrefix :: [String] -> String -> [String]
+namePrefix names prevRev = filter (last (words (reverse prevRev)) `isPrefixOf`) names
+
+loop :: Repl AlexPosn ()
+loop = do
+ inp <- getInputLine " > "
+ case words <$> inp of
+ Just [] -> loop
+ Just (":h":_) -> showHelp *> loop
+ Just (":help":_) -> showHelp *> loop
+ Just ("\\l":_) -> langHelp *> loop
+ Just (":ty":e) -> tyExprR (unwords e) *> loop
+ Just [":q"] -> pure ()
+ Just [":quit"] -> pure ()
+ Just (":asm":e) -> dumpAsm (unwords e) *> loop
+ Just (":ir":e) -> irR (unwords e) *> loop
+ Just (":disasm":e) -> disasm (unwords e) *> loop
+ Just e -> printExpr (unwords e) *> loop
+ Nothing -> pure ()
+
+showHelp :: Repl AlexPosn ()
+showHelp = liftIO $ putStr $ concat
+ [ helpOption ":help, :h" "" "Show this help"
+ , helpOption ":ty" "" "Display the type of an expression"
+ , helpOption ":list" "" "List all names that are in scope"
+ , helpOption ":quit, :q" "" "Quit REPL"
+ , helpOption "\\l" "" "Show reference"
+ -- TODO: dump debug state
+ ]
+
+langHelp :: Repl AlexPosn ()
+langHelp = liftIO $ putStr $ concat
+ [ lOption "Λ" "scan" "√" "sqrt"
+ , lOption "⋉" "max" "⋊" "min"
+ , lOption "⍳" "integer range" "⌊" "floor"
+ , lOption "ℯ" "exp" "⨳" "convolve"
+ , lOption "\\~" "successive application" "\\`n" "dyadic infix"
+ , lOption "_." "log" "'n" "map"
+ , lOption "`m n" "zip-m" "`{i,j∘[k,l]}" "rank"
+ , lOption "𝒻" "range (real)" "𝜋" "pi"
+ , lOption "_" "negate" ":" "size"
+ ]
+
+lOption op0 desc0 op1 desc1 =
+ rightPad 14 op0 ++ rightPad 25 desc0 ++ rightPad 14 op1 ++ desc1 ++ "\n"
+
+rightPad :: Int -> String -> String
+rightPad n str = take n $ str ++ repeat ' '
+
+helpOption :: String -> String -> String -> String
+helpOption cmd args desc =
+ rightPad 15 cmd ++ rightPad 14 args ++ desc ++ "\n"
+
+ubs :: String -> BSL.ByteString
+ubs = encodeUtf8 . TL.pack
+
+disasm :: String -> Repl AlexPosn ()
+disasm s = liftIO $ do
+ res <- pBIO (ubs s)
+ case res of
+ Left err -> putDoc (pretty err <> hardline)
+ Right b -> putDoc (b <> hardline)
+
+irR :: String -> Repl AlexPosn ()
+irR s = case dumpIR (ubs s) of
+ Left err -> liftIO $ putDoc (pretty err <> hardline)
+ Right d -> liftIO $ putDoc (d <> hardline)
+
+dumpAsm :: String -> Repl AlexPosn ()
+dumpAsm s = case dumpX86 (ubs s) of
+ Left err -> liftIO $ putDoc (pretty err <> hardline)
+ Right d -> liftIO $ putDoc (d <> hardline)
+
+tyExprR :: String -> Repl AlexPosn ()
+tyExprR s = case tyExpr (ubs s) of
+ Left err -> liftIO $ putDoc (pretty err <> hardline)
+ Right t -> liftIO $ putDoc (pretty t <> hardline)
+
+printExpr :: String -> Repl AlexPosn ()
+printExpr s = case tyParse bs of
+ Left err -> liftIO $ putDoc (pretty err <> hardline)
+ Right (e, _) ->
+ case eAnn e of
+ I -> liftIO $ do
+ fp <- funP bs
+ print =<< callFFI fp retInt64 []
+ F -> liftIO $ do
+ fp <- funP bs
+ print =<< callFFI fp retCDouble []
+ (Arr _ F) -> liftIO $ do
+ fp <- funP bs
+ p <- callFFI fp (retPtr undefined) []
+ putDoc.(<>hardline).pretty =<< (peek :: Ptr AF -> IO AF) p
+ free p
+ (Arr _ I) -> liftIO $ do
+ fp <- funP bs
+ p <- callFFI fp (retPtr undefined) []
+ putDoc.(<>hardline).pretty =<< (peek :: Ptr AI -> IO AI) p
+ free p
+ t -> liftIO $ putDoc (pretty e <+> ":" <+> pretty t <> hardline)
+ where bs = ubs s
diff --git a/src/A.hs b/src/A.hs
new file mode 100644
index 000000000..533b93aed
--- /dev/null
+++ b/src/A.hs
@@ -0,0 +1,239 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | AST
+module A ( T (..)
+ , I (..)
+ , Sh (..)
+ , C (..)
+ , E (..)
+ , Idiom (..)
+ , Builtin (..)
+ , ResVar (..)
+ , prettyTyped
+ ) where
+
+import Control.DeepSeq (NFData)
+import Data.Semigroup ((<>))
+import GHC.Generics (Generic)
+import Name
+import Prettyprinter (Doc, Pretty (..), braces, brackets, comma, encloseSep, flatAlt, group, lbrace, lbracket, parens, rbrace, rbracket, tupled, (<+>))
+import Prettyprinter.Ext
+
+instance Pretty (I a) where
+ pretty (Ix _ i) = pretty i
+ pretty (IVar _ n) = pretty n -- FIXME: different lexemes for index vars?
+ pretty (StaPlus _ i j) = parens (pretty i <+> "+" <+> pretty j)
+ pretty (IEVar _ n) = "#" <> pretty n
+
+data I a = Ix a !Int
+ | IVar a (Name a)
+ | IEVar a (Name a) -- existential
+ | StaPlus a (I a) (I a)
+ deriving (Functor, Generic)
+
+instance Show (I a) where
+ show = show . pretty
+
+-- remora allows us to append shapes together with the ++ shape operator (at the
+-- type level)
+
+data C = IsNum | IsOrd -- implies eq
+ | HasBits deriving (Generic) -- or, xor, etc.
+
+instance NFData C where
+
+instance Pretty C where
+ pretty IsNum = "IsNum"
+ pretty IsOrd = "IsOrd"
+ pretty HasBits = "HasBits"
+
+tupledArr = group . encloseSep (flatAlt "⟨ " "⟨") (flatAlt " ⟩" "⟩") ", "
+
+data Sh a = IxA (I a)
+ | Nil
+ | SVar (Name a)
+ | Cons (I a) (Sh a)
+ deriving (Functor, Generic)
+
+instance Show (Sh a) where
+ show = show . pretty
+
+instance Pretty (Sh a) where
+ pretty (IxA i) = pretty i
+ pretty (SVar n) = pretty n
+ pretty (Cons i sh) = pretty i <+> "`Cons`" <+> pretty sh
+ pretty Nil = "Nil"
+
+data T a = Arr (Sh a) (T a)
+ | F -- | double
+ | I -- | int
+ | B -- | bool
+ | TVar (Name a) -- | Kind \(*\), 'F' or 'I'
+ | Arrow (T a) (T a)
+ | P [T a]
+ deriving (Functor, Generic)
+
+instance Show (T a) where
+ show = show . pretty
+
+instance Pretty (T a) where
+ pretty (Arr i t) = "Arr" <+> parens (pretty i) <+> pretty t
+ pretty F = "float"
+ pretty I = "int"
+ pretty B = "bool"
+ pretty (TVar n) = pretty n
+ pretty (Arrow t0 t1) = parens (pretty t0 <+> "→" <+> pretty t1)
+ pretty (P ts) = tupledBy " * " (pretty <$> ts)
+
+prettyRank :: (Int, Maybe [Int]) -> Doc ann
+prettyRank (i, Nothing) = pretty i
+prettyRank (i, Just as) = pretty i <+> "∘" <+> encloseSep lbracket rbracket comma (pretty<$>as)
+
+instance Pretty Builtin where
+ pretty Plus = "+"
+ pretty (Fold n) = "/" <> pretty n
+ pretty Times = "*"
+ pretty FRange = "frange"
+ pretty IRange = "⍳"
+ pretty Floor = "⌊"
+ pretty Minus = "-"
+ pretty Max = "⋉"
+ pretty Min = "⋊"
+ pretty (Map n) = "\'" <> pretty n
+ pretty (MapN n a) = "`" <> pretty n <+> pretty a
+ pretty Div = "%"
+ pretty IntExp = "^"
+ pretty Exp = "**"
+ pretty ItoF = "itof"
+ pretty Neg = "_"
+ pretty Sqrt = "√"
+ pretty Log = "_."
+ pretty Re = "r:"
+ pretty Size = ":"
+ pretty (Rank as) = "`" <> encloseSep lbrace rbrace comma (prettyRank<$>as)
+ pretty IDiv = "/."
+ pretty Scan = "Λ"
+ pretty (DI i) = "\\`" <> pretty i
+ pretty (Conv ns) = "⨳" <+> encloseSep lbrace rbrace comma (pretty<$>ns)
+
+data Builtin = Plus | Minus | Times | Div | IntExp | Exp | Log | And | Or
+ | Xor | Eq | Neq | Gt | Lt | Gte | Lte | Concat | IDiv | Mod
+ | Max | Min | Neg | Sqrt
+ | Transpose -- TODO: in J, this has rank infinity... https://code.jsoftware.com/wiki/Vocabulary/barco
+ | Reverse -- also rank infinity... https://code.jsoftware.com/wiki/Vocabulary/bardot
+ | Filter -- TODO: filter by bitvector...
+ | Grade -- TODO: sort
+ | IRange | FRange
+ | Map !Int
+ | MapN !Int !Int
+ | Rank [(Int, Maybe [Int])]
+ | Fold !Int | Floor | ItoF
+ | Scan | Iter | Size | Re | Gen | Fib | Succ
+ | DI !Int -- dyadic infix
+ | Conv [Int]
+ -- sin/cos &c.
+ deriving (Generic)
+ -- TODO: window (feuilleter, stagger, ...) functions, foldAll, reshape...?
+
+ptName :: Name (T a) -> Doc ann
+ptName n@(Name _ _ t) = parens (pretty n <+> ":" <+> pretty t)
+
+prettyTyped :: E (T a) -> Doc ann
+prettyTyped (Var t n) = parens (pretty n <+> ":" <+> pretty t)
+prettyTyped (Builtin t b) = parens (pretty b <+> ":" <+> pretty t)
+prettyTyped (ILit t n) = parens (pretty n <+> ":" <+> pretty t)
+prettyTyped (FLit t x) = parens (pretty x <+> ":" <+> pretty t)
+prettyTyped (Lam _ n@(Name _ _ xt) e) = parens ("λ" <> parens (pretty n <+> ":" <+> pretty xt) <> "." <+> prettyTyped e)
+prettyTyped (EApp _ (EApp _ (EApp _ (Builtin _ (Fold n)) e0) e1) e2) = parens (prettyTyped e0 <> "/" <> pretty n <+> prettyTyped e1 <+> prettyTyped e2)
+prettyTyped (EApp _ e0 e1) = parens (prettyTyped e0 <+> prettyTyped e1)
+prettyTyped (Let t (n, e) e') = parens (braces (ptName n <+> "←" <+> prettyTyped e <> ";" <+> prettyTyped e') <+> pretty t)
+prettyTyped (LLet t (n, e) e') = parens (braces (ptName n <+> "⟜" <+> prettyTyped e <> ";" <+> prettyTyped e') <+> pretty t)
+
+isBinOp :: Builtin -> Bool
+isBinOp Plus = True
+isBinOp Minus = True
+isBinOp Times = True
+isBinOp Div = True
+isBinOp IDiv = True
+isBinOp Exp = True
+isBinOp IntExp = True
+isBinOp And = True
+isBinOp Or = True
+isBinOp Xor = True
+isBinOp DI{} = True
+isBinOp Conv{} = True
+isBinOp _ = False
+
+instance Pretty (E a) where
+ pretty (Lam _ n e) = parens ("λ" <> pretty n <> "." <+> pretty e)
+ pretty (Var _ n) = pretty n
+ pretty (Builtin _ op) | isBinOp op = parens (pretty op)
+ pretty (Builtin _ b) = pretty b
+ pretty (EApp _ (Builtin _ op) e0) | isBinOp op = parens (pretty e0 <+> pretty op)
+ pretty (EApp _ (EApp _ (Builtin _ op) e0) e1) | isBinOp op = parens (pretty e0 <+> pretty op <+> pretty e1)
+ pretty (EApp _ (EApp _ (EApp _ (Builtin _ (Fold n)) e0) e1) e2) = parens (pretty e0 <> "/" <> pretty n <+> pretty e1 <+> pretty e2)
+ pretty (EApp _ (EApp _ (Builtin _ (Map n)) e0) e1) = parens (pretty e0 <> "'" <> pretty n <+> pretty e1)
+ pretty (EApp _ (EApp _ (Builtin _ (MapN a d)) e0) e1) = parens (pretty e0 <+> "`" <+> pretty a <+> pretty d <+> pretty e1)
+ pretty (EApp _ (EApp _ (EApp _ (Builtin _ Scan) e0) e1) e2) = parens (pretty e0 <+> "Λ" <+> pretty e1 <+> pretty e2)
+ pretty (EApp _ (EApp _ (Builtin _ op@Rank{}) e0) e1) = parens (pretty e0 <+> pretty op <+> pretty e1)
+ pretty (EApp _ (EApp _ (Builtin _ op@Conv{}) e0) e1) = parens (pretty e0 <+> pretty op <+> pretty e1)
+ pretty (EApp _ (EApp _ (Builtin _ (DI i)) e0) e1) = parens (pretty e0 <+> "\\`" <> pretty i <+> pretty e1)
+ pretty (EApp _ e0 e1) = parens (pretty e0 <+> pretty e1)
+ pretty (FLit _ x) = pretty x
+ pretty (ILit _ n) = pretty n
+ pretty (Dfn _ e) = brackets (pretty e)
+ pretty (ResVar _ x) = pretty x
+ pretty (Parens _ e) = parens (pretty e)
+ pretty (Let _ (n, e) e') = braces (pretty n <+> "⇐" <+> pretty e <> ";" <+> pretty e')
+ pretty (Def _ (n, e) e') = braces (pretty n <+> "←" <+> pretty e <> ";" <+> pretty e')
+ pretty (LLet _ (n, e) e') = braces (pretty n <+> "⟜" <+> pretty e <> ";" <+> pretty e')
+ pretty (Id _ idm) = pretty idm
+ pretty (Tup _ es) = tupled (pretty <$> es)
+ pretty (ALit _ es) = tupledArr (pretty <$> es)
+ pretty (Ann _ e t) = parens (pretty e <+> "::" <+> pretty t)
+
+instance Show (E a) where
+ show = show . pretty
+
+data ResVar = X | Y deriving (Generic)
+
+instance Pretty ResVar where
+ pretty X = "x"
+ pretty Y = "y"
+
+data Idiom = FoldOfZip { seedI :: E (T ()), opI :: E (T ()), esI :: [E (T ())] } deriving (Generic)
+
+instance Pretty Idiom where
+ pretty (FoldOfZip seed op es) = parens ("fold-of-zip" <+> pretty seed <+> pretty op <+> pretty es)
+
+data E a = ALit { eAnn :: a, arrLit :: [E a] } -- TODO: include shape?
+ -- TODO: bool array
+ | Var { eAnn :: a, eVar :: Name a }
+ | Builtin { eAnn :: a, eBuiltin :: !Builtin }
+ | EApp { eAnn :: a, eF :: E a, eArg :: E a }
+ | Lam { eAnn :: a, eVar :: Name a, eIn :: E a }
+ | ILit { eAnn :: a, eILit :: !Integer }
+ | FLit { eAnn :: a, eFLit :: !Double }
+ | BLit { eAnn :: a, eBLit :: !Bool }
+ | Cond { eAnn :: a, prop :: E a, ifBranch :: E a, elseBranch :: E a }
+ | Let { eAnn :: a, eBnd :: (Name a, E a), eIn :: E a }
+ | Def { eAnn :: a, eBnd :: (Name a, E a), eIn :: E a }
+ | LLet { eAnn :: a, eBnd :: (Name a, E a), eIn :: E a }
+ | Dfn { eAnn :: a, eIn :: E a }
+ | ResVar { eAnn :: a, eXY :: ResVar }
+ | Parens { eAnn :: a, eExp :: E a }
+ | Ann { eAnn :: a, eEe :: E a, eTy :: T () }
+ | Tup { eAnn :: a, eEs :: [E a] }
+ | Id { eAnn :: a, eIdiom :: Idiom }
+ deriving (Functor, Generic)
+
+instance NFData Builtin where
+instance NFData ResVar where
+instance NFData Idiom where
+instance NFData a => NFData (E a) where
+instance NFData a => NFData (I a) where
+instance NFData a => NFData (Sh a) where
+instance NFData a => NFData (T a) where
diff --git a/src/A/Eta.hs b/src/A/Eta.hs
new file mode 100644
index 000000000..e4f292ea6
--- /dev/null
+++ b/src/A/Eta.hs
@@ -0,0 +1,73 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module A.Eta ( eta ) where
+
+import A
+import Control.Monad ((<=<))
+import R.M
+
+-- domains
+doms :: T a -> [T a]
+doms (Arrow t t') = t:doms t'
+doms _ = []
+
+-- count lambdas
+cLam :: E a -> Int
+cLam (Lam _ _ e) = 1 + cLam e
+cLam _ = 0
+
+thread = foldr (.) id
+
+unseam :: [T ()] -> RM (E (T ()) -> E (T ()), E (T ()) -> E (T ()))
+unseam ts = do
+ lApps <- traverse (\t -> do { n <- nextN t ; pure (\e' -> let t' = eAnn e' in Lam (Arrow t t') n e', \e' -> let Arrow _ cod = eAnn e' in EApp cod e' (Var t n)) }) ts
+ let (ls, eApps) = unzip lApps
+ pure (thread ls, thread (reverse eApps))
+
+mkLam :: [T ()] -> E (T ()) -> RM (E (T ()))
+mkLam ts e = do
+ (lam, app) <- unseam ts
+ pure $ lam (app e)
+
+eta :: E (T ()) -> RM (E (T ()))
+eta = etaM <=< etaAt
+
+tuck :: E a -> (E a -> E a, E a)
+tuck (Lam l n e) = let (f, e') = tuck e in (Lam l n . f, e')
+tuck e = (id, e)
+
+etaAt :: E (T ()) -> RM (E (T ()))
+etaAt (EApp t ho@(Builtin _ Scan{}) op) = EApp t ho <$> (etaM =<< etaAt op)
+etaAt (EApp t ho@(Builtin _ Fold{}) op) = EApp t ho <$> (etaM =<< etaAt op)
+etaAt (EApp t ho@(Builtin _ Filter{}) op) = EApp t ho <$> (etaM =<< etaAt op)
+etaAt (EApp t ho@(Builtin _ Map{}) op) = EApp t ho <$> (etaM =<< etaAt op)
+etaAt (EApp t ho@(Builtin _ MapN{}) op) = EApp t ho <$> (etaM =<< etaAt op)
+etaAt (EApp t ho@(Builtin _ Rank{}) op) = EApp t ho <$> (etaM =<< etaAt op)
+etaAt (EApp t ho@(Builtin _ DI{}) op) = EApp t ho <$> (etaM =<< etaAt op)
+etaAt (EApp t ho@(Builtin _ Conv{}) op) = EApp t ho <$> (etaM =<< etaAt op)
+etaAt (EApp t e0 e1) = EApp t <$> etaAt e0 <*> etaAt e1
+etaAt (Lam l n e) = Lam l n <$> etaAt e
+etaAt (Cond l p e e') = Cond l <$> etaAt p <*> etaAt e <*> etaAt e'
+etaAt (LLet l (n, e') e) = do { e'𝜂 <- etaAt e'; e𝜂 <- etaAt e; pure $ LLet l (n, e'𝜂) e𝜂 }
+etaAt (Id l idm) = Id l <$> etaIdm idm
+etaAt e = pure e
+
+etaIdm (FoldOfZip seed op es) = FoldOfZip <$> etaAt seed <*> etaAt op <*> traverse etaAt es
+
+-- outermost only
+etaM :: E (T ()) -> RM (E (T ()))
+etaM e@FLit{} = pure e
+etaM e@ILit{} = pure e
+etaM e@ALit{} = pure e
+etaM e@(Var t@Arrow{} _) = mkLam (doms t) e
+etaM e@Var{} = pure e
+etaM e@(Builtin t@Arrow{} _) = mkLam (doms t) e
+etaM e@Builtin{} = pure e
+etaM e@(EApp t@Arrow{} _ _) = mkLam (doms t) e
+etaM e@EApp{} = pure e
+etaM e@(Lam t@Arrow{} _ _) = do
+ let l = length (doms t)
+ (preL, e') = tuck e
+ (lam, app) <- unseam (take (l-cLam e) $ doms t)
+ pure (lam (preL (app e')))
+-- "\\y. (y*)" -> (λx. (λy. (y * x)))
diff --git a/src/A/Opt.hs b/src/A/Opt.hs
new file mode 100644
index 000000000..00a55f68e
--- /dev/null
+++ b/src/A/Opt.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module A.Opt ( optA
+ ) where
+
+import A
+import R.M
+
+-- FIXME: fold-of-zip-of-map... as in dotprod.
+-- TODO zip-of-map->zip
+
+optA :: E (T ()) -> RM (E (T ()))
+optA e@ILit{} = pure e
+optA e@FLit{} = pure e
+optA e@Var{} = pure e
+optA e@Builtin{} = pure e
+optA (Lam l n e) = Lam l n <$> optA e
+optA (EApp l0 (EApp l1 op@(Builtin _ Times) x) y) = do
+ xO <- optA x
+ yO <- optA y
+ pure $ case (xO, yO) of
+ (FLit _ x', ILit _ y') -> FLit F (x'*realToFrac y')
+ (ILit _ x', FLit _ y') -> FLit F (realToFrac x'*y')
+ _ -> EApp l0 (EApp l1 op xO) yO
+optA (EApp l op@(Builtin _ Sqrt) x) = do
+ xO <- optA x
+ pure $ case xO of
+ FLit _ z -> FLit F (sqrt z)
+ _ -> EApp l op xO
+optA (EApp _ (Builtin _ Floor) (EApp _ (Builtin _ ItoF) x)) = optA x
+optA (EApp ty (EApp _ (Builtin _ IntExp) x) (ILit _ 2)) = pure $ EApp ty (EApp (Arrow ty ty) (Builtin (Arrow ty (Arrow ty ty)) Times) x) x
+optA (EApp l0 (EApp _ (EApp _ (Builtin _ ho0@Fold{}) op) seed) (EApp _ (EApp _ (Builtin _ (Map 1)) f) x))
+ | Arrow dom _ <- eAnn f
+ , Arrow _ (Arrow _ cod) <- eAnn op = do
+ x' <- optA x
+ x0 <- nextU "x" cod
+ x1 <- nextU "y" dom
+ opA <- optA op
+ let vx0 = Var cod x0
+ vx1 = Var dom x1
+ opTy = Arrow cod (Arrow dom cod)
+ op' = Lam opTy x0 (Lam (Arrow dom cod) x1 (EApp cod (EApp undefined opA vx0) (EApp undefined f vx1)))
+ arrTy = eAnn x'
+ optA (EApp l0 (EApp undefined (EApp (Arrow arrTy l0) (Builtin (Arrow opTy (Arrow arrTy l0)) ho0) op') seed) x')
+optA (EApp _ (EApp _ (EApp _ (Builtin _ (MapN 2 1)) op) (EApp _ (EApp _ (Builtin _ (Map 1)) f) xs)) (EApp _ (EApp _ (Builtin _ (Map 1)) g) ys))
+ | Arrow dom0 _ <- eAnn f
+ , Arrow dom1 _ <- eAnn g
+ , Arrow _ (Arrow _ cod) <- eAnn op = do
+ f' <- optA f
+ g' <- optA g
+ opA <- optA op
+ xs' <- optA xs
+ ys' <- optA ys
+ x0 <- nextU "x" cod
+ x1 <- nextU "y" dom0
+ let vx0 = Var dom0 x0
+ vx1 = Var dom1 x1
+ opTy = Arrow dom0 (Arrow dom1 cod)
+ op' = Lam opTy x0 (Lam undefined x1 (EApp undefined (EApp undefined opA (EApp undefined f' vx0)) (EApp undefined g' vx1)))
+ pure (EApp undefined (EApp undefined (EApp undefined (Builtin undefined (MapN 2 1)) op') xs') ys')
+optA (EApp l (EApp t0 (EApp t1 (Builtin bt b@Fold{}) op) seed) arr) = do
+ arr' <- optA arr
+ seed' <- optA seed
+ opA <- optA op
+ case arr' of
+ (EApp _ (EApp _ (EApp _ (Builtin _ (MapN 2 1)) f) xs) ys)
+ | Arrow dom0 (Arrow dom1 dom2) <- eAnn f
+ , Arrow _ (Arrow _ cod) <- eAnn op -> do
+ f' <- optA f
+ xs' <- optA xs
+ ys' <- optA ys
+ x0 <- nextU "x" cod
+ x1 <- nextU "y" dom0
+ x2 <- nextU "z" dom1
+ let vx0 = Var cod x0
+ vx1 = Var dom0 x1
+ vx2 = Var dom1 x2
+ opTy = Arrow cod (Arrow dom0 (Arrow dom1 cod))
+ op' = Lam opTy x0 (Lam undefined x1 (Lam (Arrow dom1 cod) x2 (EApp cod (EApp undefined opA vx0) (EApp dom2 (EApp undefined f' vx1) vx2))))
+ pure $ Id l $ FoldOfZip seed' op' [xs',ys']
+ _ -> pure (EApp l (EApp t0 (EApp t1 (Builtin bt b) opA) seed') arr')
+optA (EApp l e0 e1) = EApp l <$> optA e0 <*> optA e1
+optA (ALit l es) = ALit l <$> traverse optA es
+optA (Tup l es) = Tup l <$> traverse optA es
+optA (Let l (n, e') e) = do
+ e'Opt <- optA e'
+ eOpt <- optA e
+ pure $ Let l (n, e'Opt) eOpt
+optA (LLet l (n, e') e) = do
+ e'Opt <- optA e'
+ eOpt <- optA e
+ pure $ LLet l (n, e'Opt) eOpt
+optA (Id l idm) = Id l <$> optI idm
+
+optI (FoldOfZip seed op es) = FoldOfZip <$> optA seed <*> optA op <*> traverse optA es
diff --git a/src/Asm/G.hs b/src/Asm/G.hs
new file mode 100644
index 000000000..5332ed1f8
--- /dev/null
+++ b/src/Asm/G.hs
@@ -0,0 +1,50 @@
+module Asm.G ( mG ) where
+
+import CF
+import Control.Monad.State.Strict (State)
+import qualified Data.Array as A
+import Data.Copointed
+import Data.Graph (Bounds, Edge, Graph, Vertex, buildG)
+import qualified Data.IntSet as IS
+
+-- same for xmm0, r15
+k = 16
+
+data St
+
+type M = State St
+
+-- make worklists (simplify, freeze, coalescedNodes,
+
+simplify :: Graph -> (Graph, [Vertex])
+simplify x = (xϵ,stack) where
+ dG = deg x
+ toPrune v = fmap (k ]
+ es = fmap (filter (not.toPrune)) x
+ xϵ = A.array (A.bounds x) [ y | y@(v,_) <- A.assocs es, not (toPrune v) ]
+
+deg :: Graph -> A.Array Vertex Int
+deg = fmap length
+
+mG :: Copointed p => [p Liveness] -> Graph
+mG asms = buildG bounds (concatMap (ls.copoint) asms)
+ where bounds = (minimum mins, maximum maxs) where (mins, maxs) = unzip (fmap (boundLiveness.copoint) asms)
+
+maxM :: IS.IntSet -> IS.Key
+maxM is | IS.null is = minBound
+ | otherwise = IS.findMax is
+
+minM :: IS.IntSet -> IS.Key
+minM is | IS.null is = maxBound
+ | otherwise = IS.findMin is
+
+ls :: Liveness -> [Edge]
+ls (Liveness is os) = cross (IS.toList is) (IS.toList os)
+
+-- FIXME: handle float vs. int registers as separate graphs
+boundLiveness :: Liveness -> Bounds
+boundLiveness (Liveness is os) = let vs = is `IS.union` os in (minM vs, maxM vs)
+
+cross :: [a] -> [b] -> [(a,b)]
+cross xs ys = (,) <$> xs <*> ys
diff --git a/src/Asm/X86.hs b/src/Asm/X86.hs
new file mode 100644
index 000000000..fa190f0e8
--- /dev/null
+++ b/src/Asm/X86.hs
@@ -0,0 +1,336 @@
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Asm.X86 ( X86 (..)
+ , AbsReg (..)
+ , X86Reg (..)
+ , Addr (..)
+ , ST (..)
+ , Scale (..)
+ , RoundMode (..)
+ , Label
+ , CFunc (..)
+ , prettyX86
+ , prettyDebugX86
+ , toInt
+ , roundMode
+ ) where
+
+import Control.DeepSeq (NFData (..))
+import Data.Copointed
+import Data.Int (Int32, Int64, Int8)
+import Data.Semigroup ((<>))
+import Data.Word (Word8)
+import GHC.Generics (Generic)
+import Prettyprinter (Doc, Pretty (..), brackets, colon, indent, (<+>))
+import Prettyprinter.Ext
+
+type Label = Word
+
+-- TODO: consider separate FX86Reg etc. type
+data X86Reg = Rcx | Rdx | Rsi | Rdi | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 | Rbx | Rax | Rsp
+ | XMM1 | XMM2 | XMM3 | XMM4 | XMM5 | XMM6 | XMM7 | XMM8 | XMM9 | XMM10 | XMM11 | XMM12 | XMM13 | XMM14 | XMM15 | XMM0
+ deriving (Eq, Ord, Enum, Generic)
+
+instance NFData X86Reg where
+
+instance Pretty X86Reg where
+ pretty Rax = "rax"
+ pretty Rbx = "rbx"
+ pretty Rcx = "rcx"
+ pretty Rdx = "rdx"
+ pretty Rsi = "rsi"
+ pretty Rdi = "rdi"
+ pretty R8 = "r8"
+ pretty R9 = "r9"
+ pretty R10 = "r10"
+ pretty R11 = "r11"
+ pretty R12 = "r12"
+ pretty R13 = "r13"
+ pretty R14 = "r14"
+ pretty R15 = "r15"
+ pretty Rsp = "rsp"
+ pretty XMM0 = "xmm0"
+ pretty XMM1 = "xmm1"
+ pretty XMM2 = "xmm2"
+ pretty XMM3 = "xmm3"
+ pretty XMM4 = "xmm4"
+ pretty XMM5 = "xmm5"
+ pretty XMM6 = "xmm6"
+ pretty XMM7 = "xmm7"
+ pretty XMM8 = "xmm8"
+ pretty XMM9 = "xmm9"
+ pretty XMM10 = "xmm10"
+ pretty XMM11 = "xmm11"
+ pretty XMM12 = "xmm12"
+ pretty XMM13 = "xmm13"
+ pretty XMM14 = "xmm14"
+ pretty XMM15 = "xmm15"
+
+instance Show X86Reg where show = show . pretty
+
+-- TODO: FAbsReg
+data AbsReg = IReg !Int
+ | FReg !Int
+ | FArg0 | FArg1 | FArg2 | FArg3 | FArg4 | FArg5 | FArg6 | FArg7
+ | FRet0 | FRet1
+ | CArg0 | CArg1 | CArg2 | CArg3 | CArg4 | CArg5
+ | CRet
+ | SP
+ | Quot | Rem
+ deriving (Eq, Ord)
+
+instance Pretty AbsReg where
+ pretty FArg0 = "xmm0"
+ pretty FArg1 = "xmm1"
+ pretty FArg2 = "xmm2"
+ pretty FArg3 = "xmm3"
+ pretty FArg4 = "xmm4"
+ pretty FArg5 = "xmm5"
+ pretty FArg6 = "xmm6"
+ pretty FArg7 = "xmm7"
+ pretty FRet0 = "xmm0"
+ pretty FRet1 = "xmm1"
+ pretty CArg0 = "rdi"
+ pretty CArg1 = "rsi"
+ pretty CArg2 = "rdx"
+ pretty CArg3 = "rcx"
+ pretty CArg4 = "r8"
+ pretty CArg5 = "r9"
+ pretty CRet = "rax"
+ pretty SP = "rsp"
+ pretty Quot = "rax"
+ pretty Rem = "rdx"
+ pretty (FReg i) = "^xmm" <> pretty i
+ pretty (IReg i) = "^r" <> pretty i
+
+toInt :: AbsReg -> Int
+toInt CArg0 = 0
+toInt CArg1 = 1
+toInt CArg2 = 2
+toInt CArg3 = 3
+toInt CArg4 = 4
+toInt CArg5 = 5
+toInt CRet = 6
+toInt FArg0 = 7
+toInt FArg1 = 8
+toInt FArg2 = 9
+toInt FArg3 = 10
+toInt FArg4 = 11
+toInt FArg5 = 12
+toInt FArg6 = 13
+toInt FArg7 = 14
+toInt FRet0 = 7 -- xmm0
+toInt FRet1 = 8 -- xmm1
+toInt SP = 15
+toInt Quot = 6 -- FIXME: I think this is wrong, graph approach would precolor both...?
+toInt Rem = 2
+toInt (IReg i) = 16+i
+toInt (FReg i) = 16+i
+
+newtype ST = ST Int8 deriving (NFData)
+
+instance Pretty ST where
+ pretty (ST i) = "ST(" <> pretty i <> ")"
+
+data RoundMode = RNearest | RDown | RUp | RZero deriving Generic
+
+instance NFData RoundMode where
+
+-- 3 bits, stored as Word8 for ease of manipulation
+roundMode :: RoundMode -> Word8
+roundMode RNearest = 0x0
+roundMode RDown = 0x1
+roundMode RUp = 0x2
+roundMode RZero = 0x3
+
+instance Pretty RoundMode where
+ pretty = pretty . roundMode
+
+data Scale = One | Two | Four | Eight deriving (Generic)
+
+instance Pretty Scale where
+ pretty One = "1"
+ pretty Two = "2"
+ pretty Four = "4"
+ pretty Eight = "8"
+
+data Addr reg = R reg | RC reg Int8 | RS reg Scale reg | RSD reg Scale reg Int8 deriving (Generic, Functor, Foldable, Traversable)
+
+instance NFData Scale where
+
+instance NFData reg => NFData (Addr reg) where
+
+instance Pretty reg => Pretty (Addr reg) where
+ pretty (R r) = brackets (pretty r)
+ pretty (RC r c) = brackets (pretty r <> "+" <> pretty c)
+ pretty (RS b One i) = brackets (pretty b <> "+" <> pretty i)
+ pretty (RS b s i) = brackets (pretty b <> "+" <> pretty s <> "*" <> pretty i)
+ pretty (RSD b One i d) = brackets (pretty b <> "+" <> pretty i <> pretty d)
+ pretty (RSD b s i d) = brackets (pretty b <> "+" <> pretty s <> "*" <> pretty i <> "+" <> pretty d)
+
+data CFunc = Malloc | Free deriving (Generic)
+
+instance NFData CFunc where
+
+instance Pretty CFunc where
+ pretty Malloc = "malloc"
+ pretty Free = "free"
+
+data X86 reg a = Label { ann :: a, label :: Label }
+ | IAddRR { ann :: a, rAdd1 :: reg, rAdd2 :: reg }
+ | IAddRI { ann :: a, rAdd1 :: reg, rAddI :: Int64 }
+ | ISubRR { ann :: a, rSub1 :: reg, rSub2 :: reg }
+ | ISubRI { ann :: a, rSub :: reg, rSubI :: Int64 }
+ | IMulRR { ann :: a, rMul1 :: reg, rMul2 :: reg }
+ | MovRR { ann :: a, rDest :: reg, rSrc :: reg }
+ | MovRA { ann :: a, rDest :: reg, aSrc :: Addr reg }
+ | MovAR { ann :: a, aDest :: Addr reg, rSrc :: reg }
+ | MovAI32 { ann :: a, aDest :: Addr reg, i32Src :: Int32 }
+ | MovRI { ann :: a, rDest :: reg, iSrc :: Int64 }
+ | MovqXR { ann :: a, rDest :: reg, rSrc :: reg }
+ | MovqXA { ann :: a, rDest :: reg, aSrc :: Addr reg }
+ | MovqAX { ann :: a, aDest :: Addr reg, rSrc :: reg }
+ | Fld { ann :: a, a87 :: Addr reg }
+ | FldS { ann :: a, stIsn :: ST }
+ | Fldl2e { ann :: a }
+ | Fldln2 { ann :: a }
+ | Fld1 { ann :: a }
+ | Fyl2x { ann :: a }
+ | Fstp { ann :: a, a87 :: Addr reg }
+ | F2xm1 { ann :: a }
+ | Fmulp { ann :: a }
+ | Fprem { ann :: a }
+ | Faddp { ann :: a }
+ | Fscale { ann :: a }
+ | Fxch { ann :: a, stIsn :: ST }
+ | J { ann :: a, label :: Label }
+ | Je { ann :: a, jLabel :: Label }
+ | Jne { ann :: a, jLabel :: Label }
+ | Jg { ann :: a, jLabel :: Label }
+ | Jge { ann :: a, jLabel :: Label }
+ | Jl { ann :: a, jLabel :: Label }
+ | Jle { ann :: a, jLabel :: Label }
+ | CmpRR { ann :: a, rCmp :: reg, rCmp' :: reg }
+ | CmpRI { ann :: a, rCmp :: reg, cmpI32 :: Int32 }
+ | Ret { ann :: a }
+ | Vdivsd { ann :: a, rDest :: reg, rSrc1 :: reg, rSrc2 :: reg }
+ | Movapd { ann :: a, rDest :: reg, rSrc :: reg }
+ | Roundsd { ann :: a, rDest :: reg, rSrc :: reg, mode :: RoundMode }
+ | Cvttsd2si { ann :: a, rDest :: reg, rSrc :: reg }
+ | Mulsd { ann :: a, rDest :: reg, rSrc :: reg }
+ | Addsd { ann :: a, rDest :: reg, rSrc :: reg }
+ | Subsd { ann :: a, rDest :: reg, rSrc :: reg }
+ | Divsd { ann :: a, rDest :: reg, rSrc :: reg }
+ | Vmulsd { ann :: a, rDest :: reg, rSrc1 :: reg, rSrc2 :: reg }
+ | Vaddsd { ann :: a, rDest :: reg, rSrc1 :: reg, rSrc2 :: reg }
+ | Vsubsd { ann :: a, rDest :: reg, rSrc1 :: reg, rSrc2 :: reg }
+ | Cvtsi2sd { ann :: a, rDest :: reg, rSrc :: reg }
+ | Vfmadd231sd { ann :: a, rDest :: reg, rSrc1 :: reg, rSrc2 :: reg }
+ | Push { ann :: a, rSrc :: reg }
+ | Pop { ann :: a, rDest :: reg }
+ | Call { ann :: a, cfunc :: CFunc }
+ | IDiv { ann :: a, rSrc :: reg }
+ | Sal { ann :: a, rSrc :: reg, iExp :: Int8 }
+ | Sar { ann :: a, rSrc :: reg, iExp :: Int8 }
+ | Sqrtsd { ann :: a, rDest :: reg, rSrc :: reg }
+ | Maxsd { ann :: a, rDest :: reg, rSrc :: reg }
+ | Vmaxsd { ann :: a, rDest :: reg, rSrc1 :: reg, rSrc2 :: reg }
+ | Minsd { ann :: a, rDest :: reg, rSrc :: reg }
+ | Vminsd { ann :: a, rDest :: reg, rSrc1 :: reg, rSrc2 :: reg }
+ | Not { ann :: a, rSrc :: reg }
+ | And { ann :: a, rDest :: reg, rSrc :: reg }
+ | Cmovnle { ann :: a, rDest :: reg, rSrc :: reg }
+ deriving (Functor, Generic)
+
+instance (NFData a, NFData reg) => NFData (X86 reg a) where
+
+instance Copointed (X86 reg) where
+ copoint = ann
+
+prettyLabel :: Label -> Doc ann
+prettyLabel l = "apple_" <> pretty l
+
+i4 :: Doc ann -> Doc ann
+i4 = indent 4
+
+instance Pretty reg => Pretty (X86 reg a) where
+ pretty (J _ l) = i4 ("jmp" <+> prettyLabel l)
+ pretty (Label _ l) = prettyLabel l <> colon
+ pretty (CmpRR _ r0 r1) = i4 ("cmp" <+> pretty r0 <> "," <+> pretty r1)
+ pretty (MovRR _ r0 r1) = i4 ("mov" <+> pretty r0 <> "," <+> pretty r1)
+ pretty (MovRI _ r i) = i4 ("mov" <+> pretty r <> "," <+> pretty i)
+ pretty (MovqXR _ r0 r1) = i4 ("movq" <+> pretty r0 <> "," <+> pretty r1)
+ pretty (IAddRR _ r0 r1) = i4 ("add" <+> pretty r0 <> "," <+> pretty r1)
+ pretty (IAddRI _ r i) = i4 ("add" <+> pretty r <> "," <+> pretty i)
+ pretty (ISubRR _ r0 r1) = i4 ("sub" <+> pretty r0 <> "," <+> pretty r1)
+ pretty (ISubRI _ r i) = i4 ("sub" <+> pretty r <> "," <+> pretty i)
+ pretty (IMulRR _ r0 r1) = i4 ("imul" <+> pretty r0 <> "," <+> pretty r1)
+ pretty (Jne _ l) = i4 ("jne" <+> prettyLabel l)
+ pretty (Jle _ l) = i4 ("jle" <+> prettyLabel l)
+ pretty (Je _ l) = i4 ("je" <+> prettyLabel l)
+ pretty (Jge _ l) = i4 ("jge" <+> prettyLabel l)
+ pretty (Jg _ l) = i4 ("jg" <+> prettyLabel l)
+ pretty (Jl _ l) = i4 ("jl" <+> prettyLabel l)
+ pretty Ret{} = i4 "ret"
+ pretty (Vdivsd _ rD r0 r1) = i4 ("vdivsd" <+> pretty rD <> "," <+> pretty r0 <> "," <+> pretty r1)
+ pretty (Movapd _ r0 r1) = i4 ("movapd" <+> pretty r0 <> "," <+> pretty r1)
+ pretty (Cvttsd2si _ r0 r1) = i4 ("cvttsd2si" <+> pretty r0 <> "," <+> pretty r1)
+ pretty (Vmulsd _ rD r0 r1) = i4 ("vmulsd" <+> pretty rD <> "," <+> pretty r0 <> "," <+> pretty r1)
+ pretty (Vaddsd _ rD r0 r1) = i4 ("vaddsd" <+> pretty rD <> "," <+> pretty r0 <> "," <+> pretty r1)
+ pretty (Vsubsd _ rD r0 r1) = i4 ("vsubsd" <+> pretty rD <> "," <+> pretty r0 <> "," <+> pretty r1)
+ pretty (Cvtsi2sd _ r0 r1) = i4 ("cvtsi2sd" <+> pretty r0 <> "," <+> pretty r1)
+ pretty (Roundsd _ r0 r1 m) = i4 ("roundsd" <+> pretty r0 <> "," <+> pretty r1 <> "," <+> pretty m)
+ pretty (CmpRI _ r i) = i4 ("cmp" <+> pretty r <> "," <+> pretty i)
+ pretty (Divsd _ r0 r1) = i4 ("divsd" <+> pretty r0 <> "," <+> pretty r1)
+ pretty (Mulsd _ r0 r1) = i4 ("mulsd" <+> pretty r0 <> "," <+> pretty r1)
+ pretty (Addsd _ r0 r1) = i4 ("addsd" <+> pretty r0 <> "," <+> pretty r1)
+ pretty (Subsd _ r0 r1) = i4 ("subsd" <+> pretty r0 <> "," <+> pretty r1)
+ pretty (MovRA _ r a) = i4 ("mov" <+> pretty r <> "," <+> pretty a)
+ pretty (MovAR _ a r) = i4 ("mov" <+> pretty a <> "," <+> pretty r)
+ pretty (MovAI32 _ a i) = i4 ("mov qword" <+> pretty a <> "," <+> pretty i)
+ pretty (MovqXA _ x a) = i4 ("movq" <+> pretty x <> "," <+> pretty a)
+ pretty (MovqAX _ a x) = i4 ("movq" <+> pretty a <> "," <+> pretty x)
+ pretty (Fld _ a) = i4 ("fld qword" <+> pretty a)
+ pretty Fyl2x{} = i4 "fyl2x"
+ pretty (Fstp _ a) = i4 ("fstp qword" <+> pretty a)
+ pretty F2xm1{} = i4 "f2xm1"
+ pretty Fldl2e{} = i4 "fldl2e"
+ pretty Fldln2{} = i4 "fldln2"
+ pretty Fld1{} = i4 "fld1"
+ pretty Fprem{} = i4 "fprem"
+ pretty Faddp{} = i4 "faddp"
+ pretty Fscale{} = i4 "fscale"
+ pretty (Fxch _ st) = i4 ("fxch" <+> pretty st)
+ pretty (FldS _ st) = i4 ("fld" <+> pretty st)
+ pretty Fmulp{} = i4 "fmulp"
+ pretty (Vfmadd231sd _ rD r0 r1) = i4 ("vfmadd231sd" <+> pretty rD <> "," <+> pretty r0 <> "," <+> pretty r1)
+ pretty (Push _ r) = i4 ("push" <+> pretty r)
+ pretty (Pop _ r) = i4 ("pop" <+> pretty r)
+ pretty (IDiv _ r) = i4 ("idiv" <+> pretty r)
+ pretty (Call _ f) = i4 ("call" <+> pretty f <+> "wrt ..plt")
+ pretty (Sal _ r i) = i4 ("sal" <+> pretty r <> "," <+> pretty i)
+ pretty (Sar _ r i) = i4 ("sar" <+> pretty r <> "," <+> pretty i)
+ pretty (Sqrtsd _ r0 r1) = i4 ("sqrtsd" <+> pretty r0 <> "," <+> pretty r1)
+ pretty (Maxsd _ r0 r1) = i4 ("maxsd" <+> pretty r0 <> "," <+> pretty r1)
+ pretty (Vmaxsd _ r0 r1 r2) = i4 ("maxsd" <+> pretty r0 <> "," <+> pretty r1 <> "," <+> pretty r2)
+ pretty (Minsd _ r0 r1) = i4 ("minsd" <+> pretty r0 <> "," <+> pretty r1)
+ pretty (Vminsd _ r0 r1 r2) = i4 ("minsd" <+> pretty r0 <> "," <+> pretty r1 <> "," <+> pretty r2)
+ pretty (Not _ r) = i4 ("not" <+> pretty r)
+ pretty (And _ r0 r1) = i4 ("and" <+> pretty r0 <> "," <+> pretty r1)
+ pretty (Cmovnle _ r0 r1) = i4 ("cmovnle" <+> pretty r0 <> "," <+> pretty r1)
+
+instance Pretty reg => Show (X86 reg a) where show = show . pretty
+
+prettyLive :: (Pretty reg, Pretty o) => X86 reg o -> Doc ann
+prettyLive r = pretty r <+> pretty (ann r)
+
+prettyX86 :: (Pretty reg) => [X86 reg a] -> Doc ann
+prettyX86 = prettyLines . fmap pretty
+
+prettyDebugX86 :: (Pretty reg, Pretty o) => [X86 reg o] -> Doc ann
+prettyDebugX86 = prettyLines . fmap prettyLive
diff --git a/src/Asm/X86/Alloc.hs b/src/Asm/X86/Alloc.hs
new file mode 100644
index 000000000..69ce55611
--- /dev/null
+++ b/src/Asm/X86/Alloc.hs
@@ -0,0 +1,286 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+-- | From [Kempe compiler](http://vmchale.com/original/compiler.pdf).
+module Asm.X86.Alloc ( allocFrame ) where
+
+import Asm.X86
+import CF
+import Control.Monad (when)
+import Control.Monad.Extra (concatMapM)
+import Control.Monad.State.Strict (State, gets, runState)
+import Data.Bifunctor (second)
+import Data.Foldable (traverse_)
+import Data.Functor (($>))
+import qualified Data.IntMap as IM
+import qualified Data.IntSet as IS
+import Data.Maybe (fromMaybe, mapMaybe)
+import qualified Data.Set as S
+import Lens.Micro (Lens')
+import Lens.Micro.Mtl (modifying, (.=))
+
+data ASt = ASt { allocs :: IM.IntMap X86Reg
+ , freeI :: S.Set X86Reg
+ , freeF :: S.Set X86Reg
+ , clobbered :: S.Set X86Reg
+ , active :: S.Set X86Reg
+ }
+
+allocsLens :: Lens' ASt (IM.IntMap X86Reg)
+allocsLens f s = fmap (\x -> s { allocs = x }) (f (allocs s))
+
+freeILens :: Lens' ASt (S.Set X86Reg)
+freeILens f s = fmap (\x -> s { freeI = x }) (f (freeI s))
+
+freeFLens :: Lens' ASt (S.Set X86Reg)
+freeFLens f s = fmap (\x -> s { freeF = x }) (f (freeF s))
+
+clobberedLens :: Lens' ASt (S.Set X86Reg)
+clobberedLens f s = fmap (\x -> s { clobbered = x }) (f (clobbered s))
+
+activeLens :: Lens' ASt (S.Set X86Reg)
+activeLens f s = fmap (\x -> s { active = x }) (f (active s))
+
+type AM = State ASt
+
+allFree :: ASt
+allFree = ASt IM.empty (S.fromList [Rcx .. Rax]) (S.fromList [XMM1 .. XMM15]) S.empty S.empty
+
+runAM = second clobbered . flip runState allFree
+
+allocFrame = uncurry frame . allocRegs
+
+frame :: [X86 X86Reg ()] -> S.Set X86Reg -> [X86 X86Reg ()]
+frame asms clob = pre++asms++post++[Ret()] where
+ pre = Push () <$> clobs
+ post = Pop () <$> reverse clobs
+ clobs = S.toList (clob `S.intersection` S.fromList [R12 .. Rbx])
+
+callerSave :: S.Set X86Reg
+callerSave = S.fromList (Rsp : [Rcx .. R11] ++ [XMM1 .. XMM0])
+
+allocRegs :: [X86 AbsReg Interval] -> ([X86 X86Reg ()], S.Set X86Reg)
+allocRegs asms@(asm:_) = runAM (do {initUsed (ann asm); concatMapM allocReg asms})
+
+findReg :: Int -> AM X86Reg
+findReg i = gets
+ (IM.findWithDefault (error ("Internal error in register allocator: unfound register " ++ show i)) i . allocs)
+
+assignReg :: Int -> X86Reg -> AM ()
+assignReg i xr =
+ modifying allocsLens (IM.insert i xr) *> modifying activeLens (S.insert xr)
+
+freeReg :: Int -> AM ()
+freeReg i = do
+ r <- findReg i
+ modifying allocsLens (IM.delete i)
+ case r of
+ Rax -> freeIϵ r
+ Rbx -> freeIϵ r
+ Rcx -> freeIϵ r
+ Rdx -> freeIϵ r
+ Rsi -> freeIϵ r
+ Rdi -> freeIϵ r
+ R8 -> freeIϵ r
+ R9 -> freeIϵ r
+ R10 -> freeIϵ r
+ R11 -> freeIϵ r
+ R12 -> freeIϵ r
+ R13 -> freeIϵ r
+ R14 -> freeIϵ r
+ R15 -> freeIϵ r
+ _ -> freeFϵ r
+
+ where freeIϵ r = modifying freeILens (S.insert r) *> modifying activeLens (S.delete r)
+ freeFϵ r = modifying freeFLens (S.insert r) *> modifying activeLens (S.delete r)
+
+fromInt :: Int -> Maybe X86Reg
+fromInt 0 = Just Rdi
+fromInt 1 = Just Rsi
+fromInt 2 = Just Rdx
+fromInt 3 = Just Rcx
+fromInt 4 = Just R8
+fromInt 5 = Just R9
+fromInt 6 = Just Rax
+fromInt 7 = Just XMM0
+fromInt 8 = Just XMM1
+fromInt 9 = Just XMM2
+fromInt 10 = Just XMM3
+fromInt 11 = Just XMM4
+fromInt 12 = Just XMM5
+fromInt 13 = Just XMM6
+fromInt 14 = Just XMM7
+fromInt 15 = Just Rsp
+fromInt _ = Nothing
+
+initUsed :: Interval -> AM ()
+initUsed l = traverse_ ini (mapMaybe fromInt (IS.toList (new l)))
+ where ini r =
+ case r of
+ Rdi -> iniI r
+ Rsi -> iniI r
+ Rdx -> iniI r
+ Rcx -> iniI r
+ R8 -> iniI r
+ R9 -> iniI r
+ Rax -> iniI r
+ XMM0 -> iniF r
+ XMM1 -> iniF r
+ XMM2 -> iniF r
+ XMM3 -> iniF r
+ XMM4 -> iniF r
+ XMM5 -> iniF r
+ XMM6 -> iniF r
+ XMM7 -> iniF r
+ Rsp -> iniI r
+ iniI r = modifying freeILens (S.delete r)
+ iniF r = modifying freeFLens (S.delete r)
+
+freeDone :: Interval -> AM ()
+freeDone l = traverse_ freeReg (IS.toList absRs)
+ where absRs = done l
+
+newI :: AM X86Reg
+newI = do
+ st <- gets freeI
+ let (res, next) = c $ S.minView st
+ freeILens .= next
+ modifying clobberedLens (S.insert res)
+ pure res
+ where c = fromMaybe (error "(internal error) Register spilling not implemented.")
+
+newF :: AM X86Reg
+newF = do
+ st <- gets freeF
+ let (res, next) = c $ S.minView st
+ freeFLens .= next
+ pure res
+ where c = fromMaybe (error "(internal error) Register spilling not implemented.")
+
+useI :: Interval -> Int -> AM X86Reg
+useI l i =
+ if i `IS.member` new l
+ then do { res <- newI ; assignReg i res $> res }
+ else findReg i
+
+useF :: Interval -> Int -> AM X86Reg
+useF l i =
+ if i `IS.member` new l
+ then do { res <- newF ; assignReg i res $> res }
+ else findReg i
+
+useCArg :: X86Reg -> AbsReg -> AM X86Reg
+useCArg rr r = do
+ modifying freeILens (S.delete rr)
+ modifying activeLens (S.insert rr)
+ assignReg (toInt r) rr $> rr
+
+useFArg :: X86Reg -> AbsReg -> AM X86Reg
+useFArg rr r = do
+ modifying freeFLens (S.delete rr)
+ modifying activeLens (S.insert rr)
+ assignReg (toInt r) rr $> rr
+
+useR :: Interval -> AbsReg -> AM X86Reg
+useR l r@IReg{} = useI l (toInt r)
+useR l r@FReg{} = useF l (toInt r)
+useR _ r@CArg0{} = useCArg Rdi r
+useR _ r@CArg1{} = useCArg Rsi r
+useR _ r@CArg2{} = useCArg Rdx r
+useR _ r@CArg3{} = useCArg Rcx r
+useR _ r@CArg4{} = useCArg R8 r
+useR _ r@CArg5{} = useCArg R9 r
+useR _ r@FArg0{} = useFArg XMM0 r
+useR _ r@FArg1{} = useFArg XMM1 r
+useR _ r@FArg2{} = useFArg XMM2 r
+useR _ r@FArg3{} = useFArg XMM3 r
+useR _ r@FArg4{} = useFArg XMM4 r
+useR _ r@FArg5{} = useFArg XMM5 r
+useR l r@CRet{} =
+ let rr = Rax in do
+ q <- gets freeI
+ when (toInt r `IS.member` new l && not (rr `S.member` q)) $ error "Sanity check failed."
+ modifying freeILens (S.delete rr)
+ modifying activeLens (S.insert rr)
+ assignReg (toInt r) rr $> rr
+useR l r@FRet0{} =
+ let rr = XMM0 in do
+ -- skip sanity check cause xmm0 is used for the first argument as well
+ q <- gets freeF
+ when (toInt r `IS.member` new l && not (rr `S.member` q)) $ error "Sanity check failed."
+ modifying freeFLens (S.delete rr)
+ modifying activeLens (S.insert rr)
+ assignReg (toInt r) rr $> rr
+useR _ r@SP =
+ let rr = Rsp
+ in assignReg (toInt r) rr $> rr
+
+uA :: Interval -> Addr AbsReg -> AM (Addr X86Reg)
+uA l = traverse (useR l)
+
+allocReg :: X86 AbsReg Interval -> AM [X86 X86Reg ()]
+allocReg Ret{} = pure [Ret ()]
+allocReg (Label _ l) = pure [Label () l]
+allocReg (J _ l) = pure [J () l]
+allocReg (Je _ l) = pure [Je () l]
+allocReg (Jne _ l) = pure [Jne () l]
+allocReg (Jg _ l) = pure [Jg () l]
+allocReg (Jl _ l) = pure [Jl () l]
+allocReg (Jge _ l) = pure [Jge () l]
+allocReg (Jle _ l) = pure [Jle () l]
+allocReg (MovRR l r0 r1) = sequence [MovRR () <$> useR l r0 <*> useR l r1] <* freeDone l
+allocReg (IAddRR l r0 r1) = sequence [IAddRR () <$> useR l r0 <*> useR l r1] <* freeDone l
+allocReg (IAddRI l r i) = sequence [IAddRI () <$> useR l r <*> pure i] <* freeDone l
+allocReg (ISubRR l r0 r1) = sequence [ISubRR () <$> useR l r0 <*> useR l r1] <* freeDone l
+allocReg (ISubRI l r i) = sequence [ISubRI () <$> useR l r <*> pure i] <* freeDone l
+allocReg (IMulRR l r0 r1) = sequence [IMulRR () <$> useR l r0 <*> useR l r1] <* freeDone l
+allocReg (And l r0 r1) = sequence [And () <$> useR l r0 <*> useR l r1] <* freeDone l
+allocReg (CmpRR l r0 r1) = sequence [CmpRR () <$> useR l r0 <*> useR l r1] <* freeDone l
+allocReg (MovRI l r i) = sequence [MovRI () <$> useR l r <*> pure i] <* freeDone l
+allocReg (MovqXR l r0 r1) = sequence [MovqXR () <$> useR l r0 <*> useR l r1] <* freeDone l
+allocReg (CmpRI l r i) = sequence [CmpRI () <$> useR l r <*> pure i] <* freeDone l
+allocReg (Vdivsd l r0 r1 r2) = sequence [Vdivsd () <$> useR l r0 <*> useR l r1 <*> useR l r2] <* freeDone l
+allocReg (Movapd l r0 r1) = sequence [Movapd () <$> useR l r0 <*> useR l r1] <* freeDone l
+allocReg (Vmulsd l r0 r1 r2) = sequence [Vmulsd () <$> useR l r0 <*> useR l r1 <*> useR l r2] <* freeDone l
+allocReg (Vaddsd l r0 r1 r2) = sequence [Vaddsd () <$> useR l r0 <*> useR l r1 <*> useR l r2] <* freeDone l
+allocReg (Vsubsd l r0 r1 r2) = sequence [Vsubsd () <$> useR l r0 <*> useR l r1 <*> useR l r2] <* freeDone l
+allocReg (Roundsd l r0 r1 m) = sequence [Roundsd () <$> useR l r0 <*> useR l r1 <*> pure m] <* freeDone l
+allocReg (Cvttsd2si l r0 r1) = sequence [Cvttsd2si () <$> useR l r0 <*> useR l r1] <* freeDone l
+allocReg (Cvtsi2sd l r0 r1) = sequence [Cvtsi2sd () <$> useR l r0 <*> useR l r1] <* freeDone l
+allocReg (Mulsd l r0 r1) = sequence [Mulsd () <$> useR l r0 <*> useR l r1] <* freeDone l
+allocReg (Addsd l r0 r1) = sequence [Addsd () <$> useR l r0 <*> useR l r1] <* freeDone l
+allocReg (Subsd l r0 r1) = sequence [Subsd () <$> useR l r0 <*> useR l r1] <* freeDone l
+allocReg (Divsd l r0 r1) = sequence [Divsd () <$> useR l r0 <*> useR l r1] <* freeDone l
+allocReg (MovRA l r a) = sequence [MovRA () <$> useR l r <*> uA l a] <* freeDone l
+allocReg (MovAR l a r) = sequence [MovAR () <$> uA l a <*> useR l r] <* freeDone l
+allocReg (MovAI32 l a i) = sequence [MovAI32 () <$> uA l a <*> pure i] <* freeDone l
+allocReg (MovqXA l x a) = sequence [MovqXA () <$> useR l x <*> uA l a] <* freeDone l
+allocReg (MovqAX l a x) = sequence [MovqAX () <$> uA l a <*> useR l x] <* freeDone l
+allocReg (Cmovnle l r0 r1) = sequence [Cmovnle () <$> useR l r0 <*> useR l r1] <* freeDone l
+allocReg Fldl2e{} = pure [Fldl2e ()]
+allocReg Fldln2{} = pure [Fldln2 ()]
+allocReg Fld1{} = pure [Fld1 ()]
+allocReg (FldS _ st) = pure [FldS () st]
+allocReg Fprem{} = pure [Fprem ()]
+allocReg Faddp{} = pure [Faddp ()]
+allocReg Fscale{} = pure [Fscale ()]
+allocReg (Fxch _ st) = pure [Fxch () st]
+allocReg (Fld l a) = sequence [Fld () <$> uA l a] <* freeDone l
+allocReg Fyl2x{} = pure [Fyl2x ()]
+allocReg F2xm1{} = pure [F2xm1 ()]
+allocReg Fmulp{} = pure [Fmulp ()]
+allocReg (Fstp l a) = sequence [Fstp () <$> uA l a] <* freeDone l
+allocReg (Vfmadd231sd l r0 r1 r2) = sequence [Vfmadd231sd () <$> useR l r0 <*> useR l r1 <*> useR l r2] <* freeDone l
+allocReg (Sal l r e) = sequence [Sal () <$> useR l r <*> pure e] <* freeDone l
+allocReg (Sar l r e) = sequence [Sar () <$> useR l r <*> pure e] <* freeDone l
+allocReg (Sqrtsd l r0 r1) = sequence [Sqrtsd () <$> useR l r0 <*> useR l r1] <* freeDone l
+allocReg (Minsd l r0 r1) = sequence [Minsd () <$> useR l r0 <*> useR l r1] <* freeDone l
+allocReg (Maxsd l r0 r1) = sequence [Maxsd () <$> useR l r0 <*> useR l r1] <* freeDone l
+allocReg (Vmaxsd l r0 r1 r2) = sequence [Vmaxsd () <$> useR l r0 <*> useR l r1 <*> useR l r2] <* freeDone l
+allocReg (Vminsd l r0 r1 r2) = sequence [Vminsd () <$> useR l r0 <*> useR l r1 <*> useR l r2] <* freeDone l
+allocReg (Not l r) = sequence [Not () <$> useR l r] <* freeDone l
+allocReg (Call l f) = do
+ a <- gets active
+ let cs = S.toList (a `S.intersection` S.delete Rdi callerSave)
+ save = fmap (Push ()) cs
+ restore = fmap (Pop ()) (reverse cs)
+ save ++ [Call () f] ++ restore <$ freeDone l
diff --git a/src/Asm/X86/BB.hs b/src/Asm/X86/BB.hs
new file mode 100644
index 000000000..cc9f02bab
--- /dev/null
+++ b/src/Asm/X86/BB.hs
@@ -0,0 +1,24 @@
+-- | Basic blocks.
+module Asm.X86.BB ( BB (..)
+ , splitI
+ ) where
+
+import Asm.X86
+import Data.List.Split (split, whenElt)
+
+data BB reg a = BB { bAnn :: a
+ , isn :: [X86 reg ()]
+ }
+
+splitI :: [X86 reg ()] -> [BB reg ()]
+splitI = fmap (BB ()) . split (whenElt p) where
+ p J{} = True
+ p Je{} = True
+ p Jg{} = True
+ p Jl{} = True
+ p Jge{} = True
+ p Jle{} = True
+ p Jne{} = True
+ p Label{} = True
+ p Ret{} = True
+ p _ = False
diff --git a/src/Asm/X86/Byte.hs b/src/Asm/X86/Byte.hs
new file mode 100644
index 000000000..49e6d4e1e
--- /dev/null
+++ b/src/Asm/X86/Byte.hs
@@ -0,0 +1,563 @@
+-- https://defuse.ca/online-x86-assembler.htm
+-- https://disasm.pro/
+--
+-- https://wiki.osdev.org/X86-64_Instruction_Encoding
+
+{-# LANGUAGE TupleSections #-}
+
+module Asm.X86.Byte ( aFp, assemble, dbgFp ) where
+
+import Asm.X86
+import Data.Bifunctor (second)
+import Data.Bits (Bits, rotateR, shiftL, (.&.), (.|.))
+import qualified Data.ByteString as BS
+import Data.Int (Int32, Int64, Int8)
+import qualified Data.Map.Strict as M
+import Data.Word
+import Foreign.Ptr (FunPtr, IntPtr (..), Ptr, castFunPtrToPtr, ptrToIntPtr)
+import Foreign.Storable (Storable, sizeOf)
+import Hs.FFI
+import Sys.DL
+
+pI :: Ptr a -> Int
+pI = (\(IntPtr i) -> i) . ptrToIntPtr
+
+hasMa :: [X86 reg a] -> Bool
+hasMa = any g where
+ g Call{} = True
+ g _ = False
+
+prepAddrs :: [X86 reg a] -> IO (Maybe (Int, Int))
+prepAddrs ss = if hasMa ss then Just <$> mem' else pure Nothing
+
+aFp = fmap snd . allFp
+dbgFp = fmap fst . allFp
+
+allFp :: [X86 X86Reg a] -> IO (BS.ByteString, FunPtr b)
+allFp instrs = do
+ let (sz, lbls) = mkIx 0 instrs
+ (fn, p) <- do
+ res <- prepAddrs instrs
+ case res of
+ Just (m, _) -> (res,) <$> allocNear m (fromIntegral sz)
+ _ -> (res,) <$> allocExec (fromIntegral sz)
+ let b = BS.pack$asm 0 (pI p, fn, lbls) instrs
+ (b,)<$>finish b p
+
+assemble :: [X86 X86Reg a] -> BS.ByteString
+assemble instrs =
+ let (_, lbls) = mkIx 0 instrs in
+ BS.pack $ asm 0 (error "Internal error: no self", Nothing, lbls) instrs
+
+data VEXM = F | F38 | F3A
+
+data PP = S6 | F3 | F2
+
+rrNoPre :: [Word8] -> X86Reg -> X86Reg -> [Word8] -> [Word8]
+rrNoPre opc r0 r1 =
+ let (_, b0) = modRM r0
+ (_, b1) = modRM r1
+ modRMB = (0x3 `shiftL` 6) .|. (b1 `shiftL` 3) .|. b0
+ in (\x -> opc++modRMB:x)
+
+mkRR opc = mkAR opc 3
+
+mkAR :: [Word8]
+ -> Word8 -- ^ mod
+ -> X86Reg -- ^ r/m
+ -> X86Reg -- ^ reg
+ -> [Word8] -> [Word8]
+mkAR opc m r0 r1 =
+ let (e0, b0) = modRM r0
+ (e1, b1) = modRM r1
+ prefix = 0x48 .|. (e1 `shiftL` 2) .|. e0
+ modRMB = (m `shiftL` 6) .|. (b1 `shiftL` 3) .|. b0
+ in (\x -> prefix:opc++modRMB:x)
+
+-- movapd xmm9, xmm5 -> 66 44 0f 28 cd
+-- movapd xmm1, xmm5 -> 66 0f 28 cd
+--
+-- addsd xmm8,xmm10 -> f2 45 0f 58 c2
+extSse :: Word8 -> Word8 -> X86Reg -> X86Reg -> [Word8] -> [Word8]
+extSse pre opc r0 r1 =
+ let (e0, b0) = modRM r0
+ (e1, b1) = modRM r1
+ b = 0x40 .|. (e1 `shiftL` 2) .|. e0
+ modRMB = (0x3 `shiftL` 6) .|. (b1 `shiftL` 3) .|. b0
+ in (\x -> pre:b:0xf:opc:modRMB:x)
+
+vexV4 :: X86Reg -> Word8
+vexV4 XMM0 = 0xf
+vexV4 XMM1 = 0xe
+vexV4 XMM2 = 0xd
+vexV4 XMM3 = 0xc
+vexV4 XMM4 = 0xb
+vexV4 XMM5 = 0xa
+vexV4 XMM6 = 0x9
+vexV4 XMM7 = 0x8
+vexV4 XMM8 = 0x7
+vexV4 XMM9 = 0x6
+vexV4 XMM10 = 0x5
+vexV4 XMM11 = 0x4
+vexV4 XMM12 = 0x3
+vexV4 XMM13 = 0x2
+vexV4 XMM14 = 0x1
+vexV4 XMM15 = 0x0
+
+bitC :: Word8 -> Word8
+bitC 0x0 = 0x1
+bitC 0x1 = 0x0
+
+bitsm :: VEXM -> Word8
+bitsm F = 0x1
+bitsm F38 = 0x2
+bitsm F3A = 0x3
+
+ppbits :: PP -> Word8
+ppbits S6 = 0x1
+ppbits F3 = 0x2
+ppbits F2 = 0x3
+
+mkVex :: Word8 -> PP -> X86Reg -> X86Reg -> X86Reg -> ([Word8] -> [Word8])
+mkVex opc pp r0 r1 r2 =
+ \x -> 0xc5:b:opc:modRMB:x
+ where b = (bitC e0 `shiftL` 7) .|. (vexV4 r1 `shiftL` 3) .|. ppbits pp
+ (e0, b0) = modRM r0
+ (_, b2) = modRM r2
+ modRMB = (0x3 `shiftL` 6) .|. b0 `shiftL` 3 .|. b2
+
+mkVex3 :: Word8 -> PP -> VEXM -> X86Reg -> X86Reg -> X86Reg -> ([Word8] -> [Word8])
+mkVex3 opc pp mm r0 r1 r2 =
+ \x -> 0xc4:by0:by1:opc:modRMB:x
+ where by0 = (bitC e0 `shiftL` 7) .|. (0x1 `shiftL` 6) .|. (bitC e2 `shiftL` 5) .|. bitsm mm
+ by1 = 1 `shiftL` 7 .|. (vexV4 r1 `shiftL` 3) .|. ppbits pp
+ (e0, b0) = modRM r0
+ (e2, b2) = modRM r2
+ modRMB = (0x3 `shiftL` 6) .|. b0 `shiftL` 3 .|. b2
+
+mkIx :: Int -> [X86 X86Reg a] -> (Int, M.Map Label Int)
+mkIx ix (Pop _ r:asms) | fits r = mkIx (ix+1) asms
+ | otherwise = mkIx (ix+2) asms
+mkIx ix (Push _ r:asms) | fits r = mkIx (ix+1) asms
+ | otherwise = mkIx (ix+2) asms
+mkIx ix (Label _ l:asms) = second (M.insert l ix) $ mkIx ix asms
+mkIx ix (MovRR{}:asms) = mkIx (ix+3) asms
+mkIx ix (Movapd _ r0 r1:asms) | fits r0 && fits r1 = mkIx (ix+4) asms
+ | otherwise = mkIx (ix+5) asms
+mkIx ix (IAddRR{}:asms) = mkIx (ix+3) asms
+mkIx ix (And{}:asms) = mkIx (ix+3) asms
+mkIx ix (ISubRR{}:asms) = mkIx (ix+3) asms
+mkIx ix (Addsd _ r0 r1:asms) | fits r0 && fits r1 = mkIx (ix+4) asms
+ | otherwise = mkIx (ix+5) asms
+mkIx ix (Mulsd _ r0 r1:asms) | fits r0 && fits r1 = mkIx (ix+4) asms
+ | otherwise = mkIx (ix+5) asms
+mkIx ix (Vsubsd _ _ _ r:asms) | fits r = mkIx (ix+4) asms
+ | otherwise = mkIx (ix+5) asms
+mkIx ix (Vaddsd _ _ _ r:asms) | fits r = mkIx (ix+4) asms
+ | otherwise = mkIx (ix+5) asms
+mkIx ix (Vdivsd _ _ _ r:asms) | fits r = mkIx (ix+4) asms
+ | otherwise = mkIx (ix+5) asms
+mkIx ix (Vmulsd _ _ _ r:asms) | fits r = mkIx (ix+4) asms
+ | otherwise = mkIx (ix+5) asms
+mkIx ix (Vfmadd231sd{}:asms) = mkIx (ix+5) asms
+mkIx ix (CmpRR{}:asms) = mkIx (ix+3) asms
+mkIx ix (IMulRR{}:asms) = mkIx (ix+4) asms
+mkIx ix (MovqXR{}:asms) = mkIx (ix+5) asms
+mkIx ix ((CmpRI _ _ i):asms) | Just{} <- mi64i8 (fromIntegral i) = mkIx (ix+4) asms
+mkIx ix ((IAddRI _ _ i):asms) | Just{} <- mi64i8 i = mkIx (ix+4) asms
+mkIx ix ((ISubRI _ _ i):asms) | Just{} <- mi64i8 i = mkIx (ix+4) asms
+ | otherwise = mkIx (ix+7) asms
+mkIx ix (MovRI _ r i:asms) | Just{} <- mi64i32 i, i >= 0 && (r < R8 || r == Rax) = mkIx (ix+5) asms
+mkIx ix (MovRI{}:asms) = mkIx (ix+10) asms
+mkIx ix (Roundsd _ r0 r1 _:asms) | fits r0 && fits r1 = mkIx (ix+6) asms
+mkIx ix (Cvttsd2si{}:asms) = mkIx (ix+5) asms
+mkIx ix (Cvtsi2sd{}:asms) = mkIx (ix+5) asms
+mkIx ix (Ret{}:asms) = mkIx (ix+1) asms
+mkIx ix (Je{}:asms) = mkIx (ix+6) asms
+mkIx ix (Jg{}:asms) = mkIx (ix+6) asms
+mkIx ix (Jge{}:asms) = mkIx (ix+6) asms
+mkIx ix (Jl{}:asms) = mkIx (ix+6) asms
+mkIx ix (J{}:asms) = mkIx (ix+5) asms
+mkIx ix (MovRA _ _ RC{}:asms) = mkIx (ix+4) asms
+mkIx ix (MovqXA _ _ (R R13):asms) = mkIx (ix+6) asms
+mkIx ix (MovqXA _ r0 (R r1):asms) | fits r0 && fits r1 = mkIx (ix+4) asms
+ | otherwise = mkIx (ix+5) asms
+mkIx ix (MovqAX _ (RC Rsp _) r1:asms) | fits r1 = mkIx (ix+6) asms
+mkIx ix (MovqXA _ r0 (RC Rsp _):asms) | fits r0 = mkIx (ix+6) asms
+mkIx ix (Fldl2e{}:asms) = mkIx (ix+2) asms
+mkIx ix (Fldln2{}:asms) = mkIx (ix+2) asms
+mkIx ix (Fld1{}:asms) = mkIx (ix+2) asms
+mkIx ix (FldS{}:asms) = mkIx (ix+2) asms
+mkIx ix (Fld _ (RC Rsp _):asms) = mkIx (ix+4) asms
+mkIx ix (Fyl2x{}:asms) = mkIx (ix+2) asms
+mkIx ix (Fmulp{}:asms) = mkIx (ix+2) asms
+mkIx ix (F2xm1{}:asms) = mkIx (ix+2) asms
+mkIx ix (Fprem{}:asms) = mkIx (ix+2) asms
+mkIx ix (Faddp{}:asms) = mkIx (ix+2) asms
+mkIx ix (Fscale{}:asms) = mkIx (ix+2) asms
+mkIx ix (Fxch{}:asms) = mkIx (ix+2) asms
+mkIx ix (Fstp _ (RC Rsp _):asms) = mkIx (ix+4) asms
+mkIx ix (Sal{}:asms) = mkIx (ix+4) asms
+mkIx ix (Sar{}:asms) = mkIx (ix+4) asms
+mkIx ix (Call{}:asms) = mkIx (ix+5) asms
+mkIx ix (MovAI32 _ R{} _:asms) = mkIx (ix+7) asms
+mkIx ix (MovAR _ RC{} _:asms) = mkIx (ix+4) asms
+mkIx ix (MovRA _ _ RS{}:asms) = mkIx (ix+4) asms
+mkIx ix (MovAR _ RSD{} _:asms) = mkIx (ix+5) asms
+mkIx ix (MovAR _ RS{} _:asms) = mkIx (ix+4) asms
+mkIx ix (MovAR _ R{} _:asms) = mkIx (ix+3) asms
+mkIx ix (MovRA _ _ R{}:asms) = mkIx (ix+3) asms
+mkIx ix (Sqrtsd{}:asms) = mkIx (ix+4) asms
+mkIx ix (Not{}:asms) = mkIx (ix+3) asms
+mkIx ix (Cmovnle{}:asms) = mkIx (ix+4) asms
+mkIx ix [] = (ix, M.empty)
+mkIx _ (instr:_) = error (show instr)
+
+fits :: X86Reg -> Bool
+fits r = let (e, _) = modRM r in e == 0
+
+asm :: Int -> (Int, Maybe (Int, Int), M.Map Label Int) -> [X86 X86Reg a] -> [Word8]
+asm _ _ [] = []
+asm ix st (Push _ r:asms) | fits r =
+ let (_, b0) = modRM r
+ isn = 0x50 .|. b0
+ in isn:asm (ix+1) st asms
+ | otherwise =
+ let (_, b0) = modRM r
+ instr = [0x41, 0x50 .|. b0]
+ in instr ++ asm (ix+2) st asms
+asm ix st (Pop _ r:asms) | fits r =
+ let (_, b0) = modRM r
+ isn = 0x58 .|. b0
+ in isn:asm (ix+1) st asms
+ | otherwise =
+ let (_, b0) = modRM r
+ instr = [0x41, 0x58 .|. b0]
+ in instr ++ asm (ix+2) st asms
+asm ix st (Label{}:asms) =
+ asm ix st asms
+asm ix st (MovRR _ r0 r1:asms) =
+ mkRR [0x89] r0 r1 $ asm (ix+3) st asms
+asm ix st (MovRA _ r0 (RC r1 i8):asms) =
+ let (e0, b0) = modRM r0
+ (e1, b1) = modRM r1
+ pref = 0x48 .|. (e0 `shiftL` 2) .|. e1
+ modB = 0x1 `shiftL` 6 .|. (b0 `shiftL` 3) .|. b1
+ opc=0x8b
+ instr = pref:opc:modB:le i8
+ in (instr++) $ asm (ix+4) st asms
+asm ix st (MovqXA _ r0 (RC r1@Rsp i8):asms) | fits r0 =
+ let (_, b0) = modRM r0
+ (_, b1) = modRM r1
+ modB = 0x1 `shiftL` 6 .|. b0 `shiftL` 3 .|. 0x4
+ sib = b1 `shiftL` 3 .|. b1
+ instr = 0xf3:0xf:0x7e:modB:sib:le i8
+ in (instr++) $ asm (ix+6) st asms
+asm ix st (MovqXA _ r0 (R r1):asms) | fits r0 && fits r1 =
+ let (_, b0) = modRM r0
+ (_, b1) = modRM r1
+ modB = b0 `shiftL` 3 .|. b1
+ instr = [0xf3, 0x0f, 0x7e, modB]
+ in instr ++ asm (ix+4) st asms
+-- https://stackoverflow.com/questions/52522544/rbp-not-allowed-as-sib-base
+asm ix st (MovqXA l r0 (R R13):asms) = asm ix st (MovqXA l r0 (RC R13 0):asms)
+asm ix st (MovqXA _ r0 (RC r1 i8):asms) =
+ let (e0, b0) = modRM r0
+ (e1, b1) = modRM r1
+ modB = 0x1 `shiftL` 6 .|. b0 `shiftL` 3 .|. b1
+ pre = 0x48 .|. e0 `shiftL` 2 .|. e1
+ instr = 0x66:pre:0xf:0x6e:modB:le i8
+ in instr ++ asm (ix+6) st asms
+asm ix st (MovqXA _ r0 (R r1):asms) =
+ let (e0, b0) = modRM r0
+ (e1, b1) = modRM r1
+ modB = b0 `shiftL` 3 .|. b1
+ pre = 0x48 .|. e0 `shiftL` 2 .|. e1
+ instr = [0x66, pre, 0xf, 0x6e, modB]
+ in instr ++ asm (ix+5) st asms
+-- https://stackoverflow.com/questions/52522544/rbp-not-allowed-as-sib-base
+asm ix st (MovqAX _ (RC r0@Rsp i8) r1:asms) | fits r1 =
+ let (_, b0) = modRM r0
+ (_, b1) = modRM r1
+ modB = 0x1 `shiftL` 6 .|. b1 `shiftL` 3 .|. 0x4
+ sib = b0 `shiftL` 3 .|. b0
+ instr = 0x66:0x0f:0xd6:modB:sib:le i8
+ in (instr++) $ asm (ix+6) st asms
+asm ix st (Movapd _ r0 r1:asms) | fits r0 && fits r1 =
+ rrNoPre [0x66,0x0f,0x28] r1 r0 $ asm (ix+4) st asms
+ | otherwise =
+ extSse 0x66 0x28 r1 r0 $ asm (ix+5) st asms
+asm ix st (IAddRR _ r0 r1:asms) =
+ mkRR [0x01] r0 r1 $ asm (ix+3) st asms
+asm ix st (And _ r0 r1:asms) =
+ mkRR [0x21] r0 r1 $ asm (ix+3) st asms
+asm ix st (ISubRR _ r0 r1:asms) =
+ mkRR [0x29] r0 r1 $ asm (ix+3) st asms
+asm ix st (Addsd _ r0 r1:asms) | fits r0 && fits r1 =
+ rrNoPre [0xf2,0x0f,0x58] r1 r0 $ asm (ix+4) st asms -- idk why swapped for mulsd &c.
+ | otherwise =
+ extSse 0xf2 0x58 r1 r0 $ asm (ix+5) st asms
+asm ix st (Mulsd _ r0 r1:asms) | fits r0 && fits r1 =
+ rrNoPre [0xf2,0x0f,0x59] r1 r0 $ asm (ix+4) st asms
+ | otherwise =
+ extSse 0xf2 0x59 r1 r0 $ asm (ix+5) st asms
+asm ix st (Vsubsd _ r0 r1 r2:asms) | fits r2 =
+ mkVex 0x5c F2 r0 r1 r2 $ asm (ix+4) st asms
+ | otherwise =
+ mkVex3 0x5c F2 F r0 r1 r2 $ asm (ix+5) st asms
+asm ix st (Vaddsd _ r0 r1 r2:asms) | fits r2 =
+ mkVex 0x58 F2 r0 r1 r2 $ asm (ix+4) st asms
+ | otherwise =
+ mkVex3 0x58 F2 F r0 r1 r2 $ asm (ix+5) st asms
+asm ix st (Vdivsd _ r0 r1 r2:asms) | fits r2 =
+ mkVex 0x5e F2 r0 r1 r2 $ asm (ix+4) st asms
+ | otherwise =
+ mkVex3 0x5e F2 F r0 r1 r2 $ asm (ix+5) st asms
+asm ix st (Vmulsd _ r0 r1 r2:asms) | fits r2 =
+ mkVex 0x59 F2 r0 r1 r2 $ asm (ix+4) st asms
+ | otherwise =
+ mkVex3 0x59 F2 F r0 r1 r2 $ asm (ix+5) st asms
+asm ix st (Vfmadd231sd _ r0 r1 r2:asms) =
+ mkVex3 0xb9 S6 F38 r0 r1 r2 $ asm (ix+5) st asms
+asm ix st (Roundsd _ r0 r1 i:asms) | fits r0 && fits r1 =
+ rrNoPre [0x66,0x0f,0x3a,0x0b] r0 r1 . (le (roundMode i) ++) $ asm (ix+6) st asms
+asm ix st (Cvttsd2si _ r0 r1:asms) =
+ (0xf2:) . mkRR [0x0f,0x2c] r1 r0 $ asm (ix+5) st asms
+asm ix st (Cvtsi2sd _ fr r:asms) =
+ (0xf2:) . mkRR [0x0f,0x2a] r fr $ asm (ix+5) st asms
+asm ix st (Sqrtsd _ r0 r1:asms) =
+ rrNoPre [0xf2,0x0f,0x51] r1 r0 $ asm (ix+4) st asms
+asm ix st (CmpRR _ r0 r1:asms) =
+ mkRR [0x39] r0 r1 $ asm (ix+3) st asms
+asm ix st (MovqXR _ fr r:asms) =
+ (0x66:) . mkRR [0x0f,0x6e] r fr $ asm (ix+5) st asms
+asm ix st (IMulRR _ r0 r1:asms) =
+ -- flip r0,r1 as instr. uses them differently from sub, etc.
+ mkRR [0x0f, 0xaf] r1 r0 $ asm (ix+4) st asms
+asm ix st (CmpRI _ r i:asms) | Just i8 <- mi64i8 (fromIntegral i) =
+ let (e, b) = modRM r
+ prefix = 0x48 .|. e
+ modRMB = (0x3 `shiftL` 6) .|. (0o7 `shiftL` 3) .|. b
+ in (prefix:0x83:modRMB:le i8) ++ asm (ix+4) st asms
+asm ix st (IAddRI _ r i:asms) | Just i8 <- mi64i8 i =
+ let (e, b) = modRM r
+ prefix = 0x48 .|. e
+ modRMB = (0x3 `shiftL` 6) .|. b -- /0
+ in (prefix:0x83:modRMB:le i8) ++ asm (ix+4) st asms
+asm ix st (ISubRI _ r i:asms) | Just i8 <- mi64i8 i =
+ let (e, b) = modRM r
+ prefix = 0x48 .|. e
+ modRMB = (0x3 `shiftL` 6) .|. (0x5 `shiftL` 3) .|. b
+ in (prefix:0x83:modRMB:le i8) ++ asm (ix+4) st asms
+asm ix st (ISubRI _ r i:asms) | Just i32 <- mi64i32 i =
+ let (e, b) = modRM r
+ prefix = 0x48 .|. e
+ modRMB = (0x3 `shiftL` 6) .|. (0x5 `shiftL` 3) .|. b
+ in (prefix:0x81:modRMB:le i32) ++ asm (ix+7) st asms
+ | otherwise = error "Not implemented yet: handling 64-bit immediates"
+-- TODO: r32<-i32 like nasm does (note r32<-i32 (zero-extended) vs.
+-- sign-extended
+-- https://stackoverflow.com/questions/40315803/difference-between-movq-and-movabsq-in-x86-64
+asm ix st (MovRI _ r i:asms) | Just i32 <- mi64i32 i, i >= 0 && fits r =
+ let (_, b) = modRM r
+ opc = 0xb8 .|. b
+ in (opc:cd i32) ++ asm (ix+5) st asms
+ -- TODO: 0xc7 for case i<0
+asm ix st (MovRI _ r i:asms) =
+ let (e, b) = modRM r
+ pre = (0x48 .|. e:) . (0xB8 .|. b:)
+ in pre (le i) ++ asm (ix+10) st asms
+asm ix st (Ret{}:asms) =
+ 0xc3:asm (ix+1) st asms
+asm ix st (Je _ l:asms) =
+ let lIx = get l st
+ instr = let offs = lIx-ix-6 in 0x0f:0x84:cd (fromIntegral offs :: Int32)
+ in (instr ++) $ asm (ix+6) st asms
+asm ix st (Jg _ l:asms) =
+ let lIx = get l st
+ instr = let offs = lIx-ix-6 in 0x0f:0x8f:cd (fromIntegral offs :: Int32)
+ in (instr ++) $ asm (ix+6) st asms
+asm ix st (Jge _ l:asms) =
+ let lIx = get l st
+ instr = let offs = lIx-ix-6 in 0x0f:0x8d:cd (fromIntegral offs :: Int32)
+ in (instr ++) $ asm (ix+6) st asms
+asm ix st (Jl _ l:asms) =
+ let lIx = get l st
+ instr = let offs = lIx-ix-6 in 0x0f:0x8e:cd (fromIntegral offs :: Int32)
+ in (instr ++) $ asm (ix+6) st asms
+asm ix st (J _ l:asms) =
+ let lIx = get l st
+ instr = let offs = lIx-ix-5 in 0xe9:cd (fromIntegral offs :: Int32)
+ in (instr ++) $ asm (ix+5) st asms
+asm ix st (Fmulp{}:asms) =
+ (0xde:) . (0xc9:) $ asm (ix+2) st asms
+asm ix st (F2xm1{}:asms) =
+ (0xd9:) . (0xf0:) $ asm (ix+2) st asms
+asm ix st (Fldl2e{}:asms) =
+ (0xd9:) . (0xea:) $ asm (ix+2) st asms
+asm ix st (Fldln2{}:asms) =
+ (0xd9:) . (0xed:) $ asm (ix+2) st asms
+asm ix st (Fld1{}:asms) =
+ (0xd9:) . (0xe8:) $ asm (ix+2) st asms
+asm ix st (FldS _ (ST i):asms) =
+ let isn = [0xd9, 0xc0+fromIntegral i] in isn ++ asm (ix+2) st asms
+asm ix st (Fprem{}:asms) =
+ (0xd9:) . (0xf8:) $ asm (ix+2) st asms
+asm ix st (Faddp{}:asms) =
+ (0xde:) . (0xc1:) $ asm (ix+2) st asms
+asm ix st (Fscale{}:asms) =
+ (0xd9:) . (0xfd:) $ asm (ix+2) st asms
+asm ix st (Fxch _ (ST i):asms) =
+ let isn = [0xd9, 0xc9+fromIntegral i] in isn ++ asm (ix+2) st asms
+asm ix st (Fyl2x{}:asms) =
+ (0xd9:) . (0xf1:) $ asm (ix+2) st asms
+asm ix st (Fld _ (RC r@Rsp i8):asms) =
+ let (_, b) = modRM r
+ modB = 0x1 `shiftL` 6 .|. 0x4
+ sib = b `shiftL` 3 .|. b
+ instr = 0xdd:modB:sib:le i8
+ in instr ++ asm (ix+4) st asms
+asm ix st (Fstp _ (RC r@Rsp i8):asms) =
+ let (_, b) = modRM r
+ modB = 0x1 `shiftL` 6 .|. 0x3 `shiftL` 3 .|. 0x4
+ sib = b `shiftL` 3 .|. b
+ instr = 0xdd:modB:sib:le i8
+ in instr ++ asm (ix+4) st asms
+asm ix st (Sal _ r i:asms) =
+ let (e, b) = modRM r
+ modRMB = (0x3 `shiftL` 6) .|. (0x4 `shiftL` 3) .|. b
+ pre = 0x48 .|. e
+ instr = pre:0xc1:modRMB:le i
+ in instr ++ asm (ix+4) st asms
+asm ix st (Sar _ r i:asms) =
+ let (e, b) = modRM r
+ modRMB = (0x3 `shiftL` 6) .|. (0x7 `shiftL` 3) .|. b
+ pre = 0x48 .|. e
+ instr = pre:0xc1:modRMB:le i
+ in instr ++ asm (ix+4) st asms
+asm ix st (MovAI32 _ (R r) i32:asms) =
+ let (e, b) = modRM r
+ modRMB = b
+ pre = 0x48 .|. e
+ instr = pre:0xc7:modRMB:le i32
+ in instr ++ asm (ix+7) st asms
+asm ix st (MovAR _ (RC ar i8) r:asms) =
+ mkAR [0x89] 1 ar r $ le i8 ++ asm (ix+4) st asms
+asm ix st (MovRA _ r (RS b s i):asms) =
+ let (e0, b0) = modRM r
+ (eb, bb) = modRM b
+ (ei, bi) = modRM i
+ pre = 0x48 .|. e0 `shiftL` 2 .|. ei `shiftL` 1 .|. eb
+ modB = b0 `shiftL` 3 .|. 4
+ sib = encS s `shiftL` 6 .|. bi `shiftL` 3 .|. bb
+ instr = [pre,0x8b,modB,sib]
+ in instr ++ asm (ix+4) st asms
+asm ix st (MovAR _ (RSD b s i i8) r:asms) =
+ let (eb, bb) = modRM b
+ (ei, bi) = modRM i
+ (e0, b0) = modRM r
+ pre = 0x48 .|. e0 `shiftL` 2 .|. ei `shiftL` 1 .|. eb
+ modRMB = 1 `shiftL` 6 .|. b0 `shiftL` 3 .|. 4
+ sib = encS s `shiftL` 6 .|. bi `shiftL` 3 .|. bb
+ instr = pre:0x89:modRMB:sib:le i8
+ in instr++asm(ix+5) st asms
+asm ix st (MovAR _ (R ar) r:asms) =
+ mkAR [0x89] 0 ar r $ asm (ix+3) st asms
+asm ix st (MovRA _ r (R ar):asms) =
+ mkAR [0x8b] 0 ar r $ asm (ix+3) st asms
+asm ix st (Cmovnle _ r0 r1:asms) =
+ mkRR [0xf,0x4f] r1 r0 $ asm (ix+4) st asms
+asm ix st (MovAR _ (RS rb s ri) r:asms) =
+ let (eb, bb) = modRM rb
+ (ei, bi) = modRM ri
+ (e, b) = modRM r
+ modRMB = b `shiftL` 3 .|. 4
+ sib = encS s `shiftL` 6 .|. bi `shiftL` 3 .|. bb
+ pre = 0x48 .|. e `shiftL` 2 .|. ei `shiftL` 1 .|. eb
+ in pre:0x89:modRMB:sib:asm (ix+4) st asms
+asm ix st (Not _ r:asms) =
+ let (e, b) = modRM r
+ pre = 0x48 .|. e
+ opc = 0xf7
+ modB = 3 `shiftL` 6 .|. 2 `shiftL` 3 .|. b
+ in (pre:).(opc:).(modB:) $ asm(ix+3) st asms
+asm ix st@(self, Just (m, _), _) (Call _ Malloc:asms) | Just i32 <- mi32 (m-(self+ix+5)) =
+ let instr = 0xe8:le i32
+ in instr ++ asm (ix+5) st asms
+asm ix st@(self, Just (_, f), _) (Call _ Free:asms) | Just i32 <- mi32 (f-(self+ix+5)) =
+ let instr = 0xe8:le i32
+ in instr ++ asm (ix+5) st asms
+asm _ (_, Nothing, _) (Call{}:_) = error "Internal error? no dynlibs"
+asm _ _ (instr:_) = error (show instr)
+
+encS :: Scale -> Word8
+encS One = 0
+encS Two = 1
+encS Four = 2
+encS Eight = 3
+
+get :: Label -> (Int, Maybe (Int, Int), M.Map Label Int) -> Int
+get l =
+ M.findWithDefault (error "Internal error: label not found") l . thd where thd (_, _, z) = z
+
+mi64i8 :: Int64 -> Maybe Int8
+mi64i8 i | i > fromIntegral (maxBound :: Int8) || i < fromIntegral (minBound :: Int8) = Nothing
+ | otherwise = Just $ fromIntegral i
+
+mi32 :: Int -> Maybe Int32
+mi32 i | i > fromIntegral (maxBound :: Int32) || i < fromIntegral (minBound :: Int32) = Nothing
+ | otherwise = Just $ fromIntegral i
+
+mi64i32 :: Int64 -> Maybe Int32
+mi64i32 i | i > fromIntegral (maxBound :: Int32) || i < fromIntegral (minBound :: Int32) = Nothing
+ | otherwise = Just $ fromIntegral i
+
+-- extra is 1 bit, ModR/M is 3 bits; I store them as bytes for ease of
+-- manipulation
+modRM :: X86Reg -> (Word8, Word8)
+modRM Rax = (0, 0o0)
+modRM Rcx = (0, 0o1)
+modRM Rdx = (0, 0o2)
+modRM Rbx = (0, 0o3)
+modRM Rsp = (0, 0o4)
+modRM Rsi = (0, 0o6)
+modRM Rdi = (0, 0o7)
+modRM R8 = (1, 0o0)
+modRM R9 = (1, 0o1)
+modRM R10 = (1, 0o2)
+modRM R11 = (1, 0o3)
+modRM R12 = (1, 0o4)
+modRM R13 = (1, 0o5)
+modRM R14 = (1, 0o6)
+modRM R15 = (1, 0o7)
+modRM XMM0 = (0, 0o0)
+modRM XMM1 = (0, 0o1)
+modRM XMM2 = (0, 0o2)
+modRM XMM3 = (0, 0o3)
+modRM XMM4 = (0, 0o4)
+modRM XMM5 = (0, 0o5)
+modRM XMM6 = (0, 0o6)
+modRM XMM7 = (0, 0o7)
+modRM XMM8 = (1, 0o0)
+modRM XMM9 = (1, 0o1)
+modRM XMM10 = (1, 0o2)
+modRM XMM11 = (1, 0o3)
+modRM XMM12 = (1, 0o4)
+modRM XMM13 = (1, 0o5)
+modRM XMM14 = (1, 0o6)
+modRM XMM15 = (1, 0o7)
+
+cb :: (Integral a) => a -> [Word8]
+cb x = le (fromIntegral x :: Int8)
+
+cd :: (Integral a) => a -> [Word8]
+cd x = le (fromIntegral x :: Word32)
+
+dlB :: FunPtr a -> IntPtr
+dlB = ptrToIntPtr . castFunPtrToPtr
+
+-- little endian
+le :: (Storable a, Integral a, Bits a) => a -> [Word8]
+le x = fromIntegral <$> zipWith (\m e -> (x .&. m) `rotateR` e) masks ee
+ where ee = [0,8..(8*(sizeOf x-1))]
+ masks = iterate (*0x100) 0xff
diff --git a/src/Asm/X86/CF.hs b/src/Asm/X86/CF.hs
new file mode 100644
index 000000000..b98c69d20
--- /dev/null
+++ b/src/Asm/X86/CF.hs
@@ -0,0 +1,246 @@
+-- | From the [Kempe compiler](http://vmchale.com/original/compiler.pdf) with
+-- improvements.
+module Asm.X86.CF ( mkControlFlow
+ ) where
+
+import Asm.X86
+import CF
+-- seems to pretty clearly be faster
+import Control.Monad.State.Strict (State, evalState, gets, modify)
+import Data.Bifunctor (first, second)
+import Data.Functor (($>))
+import qualified Data.IntSet as IS
+import qualified Data.Map as M
+import Data.Semigroup ((<>))
+
+-- map of labels by node
+type FreshM = State (Int, M.Map Label Int)
+
+runFreshM :: FreshM a -> a
+runFreshM = flip evalState (0, mempty)
+
+mkControlFlow :: [X86 AbsReg ()] -> [X86 AbsReg ControlAnn]
+mkControlFlow instrs = runFreshM (broadcasts instrs *> addControlFlow instrs)
+
+getFresh :: FreshM Int
+getFresh = gets fst <* modify (first (+1))
+
+lookupLabel :: Label -> FreshM Int
+lookupLabel l = gets (M.findWithDefault (error "Internal error in control-flow graph: node label not in map.") l . snd)
+
+broadcast :: Int -> Label -> FreshM ()
+broadcast i l = modify (second (M.insert l i))
+
+singleton :: AbsReg -> IS.IntSet
+singleton = IS.singleton . toInt
+
+fromList :: [AbsReg] -> IS.IntSet
+fromList = foldMap singleton
+
+-- | Annotate instructions with a unique node name and a list of all possible
+-- destinations.
+addControlFlow :: [X86 AbsReg ()] -> FreshM [X86 AbsReg ControlAnn]
+addControlFlow [] = pure []
+addControlFlow ((Label _ l):asms) = do
+ { i <- lookupLabel l
+ ; (f, asms') <- next asms
+ ; pure (Label (ControlAnn i (f []) IS.empty IS.empty) l : asms')
+ }
+addControlFlow ((Je _ l):asms) = do
+ { i <- getFresh
+ ; (f, asms') <- next asms
+ ; l_i <- lookupLabel l
+ ; pure (Je (ControlAnn i (f [l_i]) IS.empty IS.empty) l : asms')
+ }
+addControlFlow ((Jl _ l):asms) = do
+ { i <- getFresh
+ ; (f, asms') <- next asms
+ ; l_i <- lookupLabel l
+ ; pure (Jl (ControlAnn i (f [l_i]) IS.empty IS.empty) l : asms')
+ }
+addControlFlow ((Jle _ l):asms) = do
+ { i <- getFresh
+ ; (f, asms') <- next asms
+ ; l_i <- lookupLabel l
+ ; pure (Jle (ControlAnn i (f [l_i]) IS.empty IS.empty) l : asms')
+ }
+addControlFlow ((Jne _ l):asms) = do
+ { i <- getFresh
+ ; (f, asms') <- next asms
+ ; l_i <- lookupLabel l
+ ; pure (Jne (ControlAnn i (f [l_i]) IS.empty IS.empty) l : asms')
+ }
+addControlFlow ((Jge _ l):asms) = do
+ { i <- getFresh
+ ; (f, asms') <- next asms
+ ; l_i <- lookupLabel l
+ ; pure (Jge (ControlAnn i (f [l_i]) IS.empty IS.empty) l : asms')
+ }
+addControlFlow ((Jg _ l):asms) = do
+ { i <- getFresh
+ ; (f, asms') <- next asms
+ ; l_i <- lookupLabel l
+ ; pure (Jg (ControlAnn i (f [l_i]) IS.empty IS.empty) l : asms')
+ }
+addControlFlow ((J _ l):asms) = do
+ { i <- getFresh
+ ; nextAsms <- addControlFlow asms
+ ; l_i <- lookupLabel l
+ ; pure (J (ControlAnn i [l_i] IS.empty IS.empty) l : nextAsms)
+ }
+addControlFlow (Ret{}:asms) = do
+ { i <- getFresh
+ ; nextAsms <- addControlFlow asms
+ ; pure (Ret (ControlAnn i [] IS.empty IS.empty) : nextAsms)
+ }
+addControlFlow (asm:asms) = do
+ { i <- getFresh
+ ; (f, asms') <- next asms
+ ; pure ((asm $> ControlAnn i (f []) (uses asm) (defs asm)) : asms')
+ }
+
+isM :: X86 AbsReg ann -> Bool
+isM MovRR{} = True
+isM MovRA{} = True
+isM MovRI{} = True
+isM MovAR{} = True
+isM MovAI32{} = True
+
+isMX :: X86 AbsReg ann -> Bool
+isMX MovqXR{} = True
+isMX MovqXA{} = True
+isMX MovqAX{} = True
+
+uA :: Addr AbsReg -> IS.IntSet
+uA (R r) = singleton r
+uA (RC r _) = singleton r
+uA (RS b _ i) = fromList [b,i]
+uA (RSD b _ i _) = fromList [b,i]
+
+uses :: X86 AbsReg ann -> IS.IntSet
+uses (MovRR _ _ r) = singleton r
+uses (And _ r0 r1) = fromList [r0, r1]
+uses (IAddRR _ r0 r1) = fromList [r0, r1]
+uses (IAddRI _ r _) = singleton r
+uses (ISubRR _ r0 r1) = fromList [r0, r1]
+uses (ISubRI _ r _) = singleton r
+uses (IMulRR _ r0 r1) = fromList [r0, r1]
+uses (CmpRR _ r0 r1) = fromList [r0, r1]
+uses MovRI{} = IS.empty
+uses (Movapd _ _ r) = singleton r
+uses (Roundsd _ _ r _) = singleton r
+uses (Cvttsd2si _ _ r) = singleton r
+uses (CmpRI _ r _) = singleton r
+uses (Vmulsd _ _ r0 r1) = fromList [r0, r1]
+uses (Vaddsd _ _ r0 r1) = fromList [r0, r1]
+uses (Vsubsd _ _ r0 r1) = fromList [r0, r1]
+uses (Vdivsd _ _ r0 r1) = fromList [r0, r1]
+uses (MovqXR _ _ r) = singleton r
+uses (Cvtsi2sd _ _ r) = singleton r
+uses (Mulsd _ r0 r1) = fromList [r0, r1]
+uses (Divsd _ r0 r1) = fromList [r0, r1]
+uses (Addsd _ r0 r1) = fromList [r0, r1]
+uses (Subsd _ r0 r1) = fromList [r0, r1]
+uses (MovqXA _ _ a) = uA a
+uses (MovqAX _ a x) = uA a <> singleton x
+uses Fldl2e{} = IS.empty
+uses Fldln2{} = IS.empty
+uses (Fld _ a) = uA a
+uses Fyl2x{} = IS.empty
+uses F2xm1{} = IS.empty
+uses Fmulp{} = IS.empty
+uses (Fstp _ a) = uA a
+uses (MovRA _ _ a) = uA a
+uses (Vfmadd231sd _ r0 r1 r2) = fromList [r0, r1, r2]
+uses (IDiv _ r) = fromList [r, Quot, Rem]
+uses (MovAR _ a r) = uA a <> singleton r
+uses (Sal _ r _) = singleton r
+uses (Sar _ r _) = singleton r
+uses (Call _ Malloc) = fromList [CArg0]
+uses (MovAI32 _ a _) = uA a
+uses (Sqrtsd _ _ r) = singleton r
+uses (Vmaxsd _ _ r0 r1) = fromList [r0, r1]
+uses (Vminsd _ _ r0 r1) = fromList [r0, r1]
+uses (Maxsd _ r0 r1) = fromList [r0, r1]
+uses (Minsd _ r0 r1) = fromList [r0, r1]
+uses Fld1{} = IS.empty
+uses FldS{} = IS.empty
+uses Fprem{} = IS.empty
+uses Faddp{} = IS.empty
+uses Fscale{} = IS.empty
+uses Fxch{} = IS.empty
+uses (Not _ r) = singleton r
+uses (Cmovnle _ _ r) = singleton r
+uses r = error (show r)
+
+defs :: X86 AbsReg ann -> IS.IntSet
+defs (MovRR _ r _) = singleton r
+defs (IAddRR _ r _) = singleton r
+defs (And _ r _) = singleton r
+defs (IAddRI _ r _) = singleton r
+defs (ISubRR _ r _) = singleton r
+defs (ISubRI _ r _) = singleton r
+defs (IMulRR _ r _) = singleton r
+defs CmpRR{} = IS.empty
+defs (MovRI _ r _) = singleton r
+defs (Movapd _ r _) = singleton r
+defs (Roundsd _ r _ _) = singleton r
+defs (Cvttsd2si _ r _) = singleton r
+defs CmpRI{} = IS.empty
+defs (Vmulsd _ r _ _) = singleton r
+defs (Vaddsd _ r _ _) = singleton r
+defs (Vsubsd _ r _ _) = singleton r
+defs (Vdivsd _ r _ _) = singleton r
+defs (MovqXR _ r _) = singleton r
+defs (Cvtsi2sd _ r _) = singleton r
+defs (Addsd _ r _) = singleton r
+defs (Subsd _ r _) = singleton r
+defs (Divsd _ r _) = singleton r
+defs (Mulsd _ r _) = singleton r
+defs (MovqXA _ r _) = singleton r
+defs MovqAX{} = IS.empty
+defs Fldl2e{} = IS.empty
+defs Fldln2{} = IS.empty
+defs Fyl2x{} = IS.empty
+defs Fstp{} = IS.empty
+defs Fld{} = IS.empty
+defs F2xm1{} = IS.empty
+defs Fmulp{} = IS.empty
+defs (MovRA _ r _) = singleton r
+defs (Vfmadd231sd _ r _ _) = singleton r
+defs (IDiv _ r) = fromList [r, Quot, Rem]
+defs MovAR{} = IS.empty
+defs (Sal _ r _) = singleton r
+defs (Sar _ r _) = singleton r
+defs (Call _ Malloc) = singleton CRet
+defs MovAI32{} = IS.empty
+defs (Sqrtsd _ r _) = singleton r
+defs (Vmaxsd _ r _ _) = singleton r
+defs (Vminsd _ r _ _) = singleton r
+defs (Minsd _ r _) = singleton r
+defs (Maxsd _ r _) = singleton r
+defs Fld1{} = IS.empty
+defs FldS{} = IS.empty
+defs Fprem{} = IS.empty
+defs Faddp{} = IS.empty
+defs Fscale{} = IS.empty
+defs Fxch{} = IS.empty
+defs (Not _ r) = singleton r
+defs (Cmovnle _ r _) = singleton r
+
+next :: [X86 AbsReg ()] -> FreshM ([Int] -> [Int], [X86 AbsReg ControlAnn])
+next asms = do
+ nextAsms <- addControlFlow asms
+ case nextAsms of
+ [] -> pure (id, [])
+ (asm:_) -> pure ((node (ann asm) :), nextAsms)
+
+-- | Construct map assigning labels to their node name.
+broadcasts :: [X86 reg ()] -> FreshM [X86 reg ()]
+broadcasts [] = pure []
+broadcasts (asm@(Label _ l):asms) = do
+ { i <- getFresh
+ ; broadcast i l
+ ; (asm :) <$> broadcasts asms
+ }
+broadcasts (asm:asms) = (asm :) <$> broadcasts asms
diff --git a/src/Asm/X86/Color.hs b/src/Asm/X86/Color.hs
new file mode 100644
index 000000000..bcf133587
--- /dev/null
+++ b/src/Asm/X86/Color.hs
@@ -0,0 +1,19 @@
+module Asm.X86.Color ( x86Init
+ ) where
+
+import Asm.X86
+import qualified Data.IntMap as IM
+import qualified Data.Map as M
+
+type Count = Int
+
+-- TODO: collect information on which nodes are related to moves
+movIx :: [X86 AbsReg ()] -> IM.IntMap Count
+movIx = undefined
+
+type Coloring = M.Map AbsReg X86Reg
+
+x86Init = M.fromList [ (CArg0, Rdi), (CArg1, Rsi), (CArg2, Rdx), (CArg3, Rcx), (CArg4, R9), (CArg5, R9)
+ , (FArg0, XMM0), (FArg1, XMM1), (FArg2, XMM2), (FArg3, XMM3), (FArg4, XMM4), (FArg5, XMM5)
+ , (CRet, Rax), (FRet0, XMM0), (FRet1, XMM1), (SP, Rsp)
+ ]
diff --git a/src/Asm/X86/Opt.hs b/src/Asm/X86/Opt.hs
new file mode 100644
index 000000000..85c9f23d4
--- /dev/null
+++ b/src/Asm/X86/Opt.hs
@@ -0,0 +1,11 @@
+module Asm.X86.Opt ( optX86 ) where
+
+import Asm.X86
+
+-- remove noops
+optX86 :: Eq reg => [X86 reg a] -> [X86 reg a]
+optX86 [] = []
+optX86 ((MovRR _ r0 r1):asms) | r0 == r1 = optX86 asms
+optX86 ((Movapd _ r0 r1):asms) | r0 == r1 = optX86 asms
+optX86 (isn@(Movapd _ r0 r1):(Movapd _ r0' r1'):asms) | r0 == r1' && r1 == r0' = optX86 (isn:asms)
+optX86 (asm:asms) = asm : optX86 asms
diff --git a/src/Asm/X86/Trans.hs b/src/Asm/X86/Trans.hs
new file mode 100644
index 000000000..4c4ee6b6f
--- /dev/null
+++ b/src/Asm/X86/Trans.hs
@@ -0,0 +1,176 @@
+module Asm.X86.Trans ( irToX86 ) where
+
+import Asm.X86
+import Control.Monad.State.Strict (State, evalState, gets, modify)
+import Data.ByteString.Internal (accursedUnutterablePerformIO)
+import Data.Foldable (fold)
+import Data.Functor (($>))
+import Data.Int (Int32, Int64, Int8)
+import Foreign.Marshal.Alloc (alloca)
+import Foreign.Ptr (castPtr)
+import Foreign.Storable (peek, poke)
+import qualified IR
+
+type WM = State IR.WSt
+
+absReg :: IR.Temp -> AbsReg
+absReg (IR.ITemp i) = IReg i
+absReg (IR.ATemp i) = IReg i
+absReg (IR.FTemp i) = FReg i
+absReg IR.C0 = CArg0
+absReg IR.C1 = CArg1
+absReg IR.C2 = CArg2
+absReg IR.C3 = CArg3
+absReg IR.C4 = CArg4
+absReg IR.C5 = CArg5
+absReg IR.CRet = CRet
+absReg IR.F0 = FArg0
+absReg IR.F1 = FArg1
+absReg IR.F2 = FArg2
+absReg IR.F3 = FArg3
+absReg IR.F4 = FArg4
+absReg IR.F5 = FArg5
+absReg IR.FRet = FRet0
+absReg IR.FRet1 = FRet1
+absReg IR.StackPointer = SP
+
+foldMapA :: (Applicative f, Traversable t, Monoid m) => (a -> f m) -> t a -> f m
+foldMapA = (fmap fold .) . traverse
+
+irToX86 :: IR.WSt -> [IR.Stmt] -> [X86 AbsReg ()]
+irToX86 st = flip evalState st . foldMapA ir
+
+nextI :: WM Int
+nextI = do { i <- gets (head.IR.wtemps); modify (\(IR.WSt l (_:t)) -> IR.WSt l t) $> i }
+
+nextR :: WM AbsReg
+nextR = IReg <$> nextI
+
+mi8 :: Int64 -> Maybe Int8
+mi8 i | i <= fromIntegral (maxBound :: Int8) && i >= fromIntegral (minBound :: Int8) = Just $ fromIntegral i
+ | otherwise = Nothing
+
+mi32 :: Int64 -> Maybe Int32
+mi32 i | i <= fromIntegral (maxBound :: Int32) && i >= fromIntegral (minBound :: Int32) = Just $ fromIntegral i
+ | otherwise = Nothing
+
+fI64 :: Double -> Int64
+fI64 x = accursedUnutterablePerformIO $ alloca $ \bytes ->
+ poke (castPtr bytes) x *>
+ peek bytes
+
+ir :: IR.Stmt -> WM [X86 AbsReg ()]
+ir (IR.MT t (IR.Reg r)) = pure [MovRR () (absReg t) (absReg r)]
+ir (IR.MT t (IR.ConstI i)) = pure [MovRI () (absReg t) i]
+ir (IR.MT t (IR.EAt (IR.AP m (Just (IR.ConstI i)) _))) | Just i8 <- mi8 i = pure [MovRA () (absReg t) (RC (absReg m) i8)]
+ir (IR.MT t (IR.EAt (IR.AP m Nothing _))) = pure [MovRA () (absReg t) (R$absReg m)]
+ir (IR.MX t (IR.FAt (IR.AP m Nothing _ ))) = pure [MovqXA () (absReg t) (R (absReg m))]
+ir (IR.L l) = pure [Label () l]
+ir (IR.MT t e) = evalE e t
+ir (IR.MJ (IR.IRel IR.INeq (IR.Reg r0) (IR.Reg r1)) l) = pure [CmpRR () (absReg r0) (absReg r1), Jne () l]
+ir (IR.MJ (IR.IRel IR.IEq (IR.Reg r0) (IR.Reg r1)) l) = pure [CmpRR () (absReg r0) (absReg r1), Je () l]
+ir (IR.MJ (IR.IRel IR.IEq (IR.Reg r0) (IR.ConstI i)) l) | Just i32 <- mi32 i = pure [CmpRI () (absReg r0) i32, Je () l]
+ir (IR.MJ (IR.IRel IR.IGt (IR.Reg r0) (IR.Reg r1)) l) = pure [CmpRR () (absReg r0) (absReg r1), Jg () l]
+ir (IR.MJ (IR.IRel IR.IGeq (IR.Reg r0) (IR.Reg r1)) l) = pure [CmpRR () (absReg r0) (absReg r1), Jge () l]
+ir (IR.MJ (IR.IRel IR.IGt (IR.Reg r0) (IR.ConstI i)) l) | Just i32 <- mi32 i = pure [CmpRI () (absReg r0) i32, Jg () l]
+ir (IR.MJ (IR.IRel IR.ILt (IR.Reg r0) (IR.Reg r1)) l) = pure [CmpRR () (absReg r0) (absReg r1), Jl () l]
+ir (IR.MJ (IR.IRel IR.ILt (IR.Reg r0) (IR.ConstI i)) l) | Just i32 <- mi32 i = pure [CmpRI () (absReg r0) i32, Jl () l]
+ir (IR.J l) = pure [J () l]
+-- see https://www.agner.org/optimize/optimizing_assembly.pdf, p. 125
+ir (IR.MX t e) = feval e t
+ir (IR.Ma t e) = do
+ plE <- evalE e IR.C0
+ pure $ plE ++ [Call () Malloc, MovRR () (absReg t) CRet]
+ir (IR.Wr (IR.AP m Nothing _) (IR.ConstI i)) | Just i32 <- mi32 i = pure [MovAI32 () (R$absReg m) i32]
+ir (IR.Wr (IR.AP m Nothing _) (IR.Reg r)) = pure [MovAR () (R$absReg m) (absReg r)]
+ir (IR.Wr (IR.AP m (Just (IR.ConstI i)) _) (IR.Reg r)) | Just i8 <- mi8 i = pure [MovAR () (RC (absReg m) i8) (absReg r)]
+ir (IR.Wr (IR.AP m (Just (IR.Reg ix)) _) (IR.Reg r)) = pure [MovAR () (RS (absReg m) One (absReg ix)) (absReg r)]
+ir (IR.Wr (IR.AP m (Just (IR.IB IR.IAsl (IR.Reg i) (IR.ConstI 3))) _) (IR.Reg r)) = pure [MovAR () (RS (absReg m) Eight (absReg i)) (absReg r)]
+ir (IR.Wr (IR.AP m (Just (IR.IB IR.IPlus (IR.IB IR.IAsl (IR.Reg i) (IR.ConstI 3)) (IR.ConstI j))) _) (IR.Reg r)) | Just i8 <- mi8 j = pure [MovAR () (RSD (absReg m) Eight (absReg i) i8) (absReg r)]
+ir (IR.Cmov (IR.IRel IR.IGt (IR.Reg r0) (IR.Reg r1)) rD (IR.Reg rS)) = pure [CmpRR () (absReg r0) (absReg r1), Cmovnle () (absReg rD) (absReg rS)]
+ir s = error (show s)
+
+feval :: IR.FExp -> IR.Temp -> WM [X86 AbsReg ()]
+feval (IR.FB IR.FDiv (IR.FReg r0) (IR.FReg r1)) t | t == r0 = pure [Divsd () (absReg t) (absReg r1)]
+feval (IR.FB IR.FTimes (IR.FReg r0) (IR.FReg r1)) t | t == r0 = pure [Mulsd () (absReg t) (absReg r1)]
+feval (IR.FB IR.FMinus (IR.FReg r0) (IR.FReg r1)) t | t == r0 = pure [Subsd () (absReg t) (absReg r1)]
+feval (IR.FB IR.FPlus (IR.FReg r0) (IR.FReg r1)) t | t == r0 = pure [Addsd () (absReg t) (absReg r1)]
+feval (IR.FB IR.FDiv (IR.FReg r0) (IR.FReg r1)) t = pure [Vdivsd () (absReg t) (absReg r0) (absReg r1)]
+feval (IR.FB IR.FTimes (IR.FReg r0) (IR.FReg r1)) t = pure [Vmulsd () (absReg t) (absReg r0) (absReg r1)]
+feval (IR.FB IR.FPlus (IR.FReg r0) (IR.FReg r1)) t = pure [Vaddsd () (absReg t) (absReg r0) (absReg r1)]
+feval (IR.FB IR.FMinus (IR.FReg r0) (IR.FReg r1)) t = pure [Vsubsd () (absReg t) (absReg r0) (absReg r1)]
+feval (IR.FConv (IR.Reg r)) t = pure [Cvtsi2sd () (absReg t) (absReg r)]
+feval (IR.FReg r) t = pure [Movapd () (absReg t) (absReg r)]
+feval (IR.FB IR.FMinus (IR.FReg r0) e) t = do
+ i <- nextI
+ putR <- feval e (IR.FTemp i)
+ pure $ putR ++ [Vsubsd () (absReg t) (absReg r0) (FReg i)]
+feval (IR.FB IR.FMinus e (IR.FReg r)) t = do
+ i <- nextI
+ putR <- feval e (IR.FTemp i)
+ pure $ putR ++ [Vsubsd () (absReg t) (FReg i) (absReg r)]
+feval (IR.FB IR.FPlus (IR.FReg r0) (IR.FB IR.FTimes (IR.FReg r1) (IR.FReg r2))) t =
+ pure [Movapd () (absReg t) (absReg r0), Vfmadd231sd () (absReg t) (absReg r1) (absReg r2)]
+feval (IR.FB IR.FPlus (IR.FReg r0) e) t = do
+ i <- nextI
+ putR <- feval e (IR.FTemp i)
+ pure $ putR ++ [Vaddsd () (absReg t) (absReg r0) (FReg i)]
+feval (IR.ConstF x) t = do
+ iR <- nextR
+ pure [MovRI () iR (fI64 x), MovqXR () (absReg t) iR]
+feval (IR.FU IR.FLog (IR.FReg r0)) t =
+ let sa = RC SP 8 in
+ pure [Fldln2 (), MovqAX () sa (absReg r0), Fld () sa, Fyl2x (), Fstp () sa, MovqXA () (absReg t) sa]
+feval (IR.FB IR.FExp (IR.ConstF 2.718281828459045) e) t = do
+ i <- nextI
+ putE <- feval e (IR.FTemp i)
+ let sa = RC SP 8
+ -- https://www.madwizard.org/programming/snippets?id=36
+ pure $ putE ++ [MovqAX () sa (FReg i), Fld () sa, Fldl2e (), Fmulp (), Fld1 (), FldS () (ST 1), Fprem (), F2xm1 (), Faddp (), Fscale (), Fstp () sa, MovqXA () (absReg t) sa]
+feval (IR.FU IR.FSqrt (IR.FReg r)) t =
+ pure [Sqrtsd () (absReg t) (absReg r)]
+feval e _ = error (show e)
+
+evalE :: IR.Exp -> IR.Temp -> WM [X86 AbsReg ()]
+evalE (IR.IB IR.IMinus (IR.Reg r0) (IR.Reg r1)) rD = let rD' = absReg rD in pure [MovRR () rD' (absReg r0), ISubRR () rD' (absReg r1)]
+evalE (IR.IB IR.IPlus (IR.Reg r0) (IR.Reg r1)) rD = let rD' = absReg rD in pure [MovRR () rD' (absReg r0), IAddRR () rD' (absReg r1)]
+evalE (IR.IB IR.IPlus (IR.Reg r0) (IR.ConstI i)) rD = let rD' = absReg rD in pure [MovRR () rD' (absReg r0), IAddRI () rD' i]
+evalE (IR.IB IR.ITimes (IR.Reg r0) (IR.Reg r1)) rD = let rD' = absReg rD in pure [MovRR () rD' (absReg r0), IMulRR () rD' (absReg r1)]
+evalE (IR.IB IR.IAsl (IR.Reg r0) (IR.ConstI i)) rD | Just i8 <- mi8 i = let rD' = absReg rD in pure [MovRR () rD' (absReg r0), Sal () rD' i8]
+evalE (IR.IB IR.IAsr (IR.Reg r0) (IR.ConstI i)) rD | Just i8 <- mi8 i = let rD' = absReg rD in pure [MovRR () rD' (absReg r0), Sar () rD' i8]
+evalE (IR.IB IR.IMinus (IR.Reg r0) (IR.ConstI i)) rD = let rD' = absReg rD in pure [MovRR () rD' (absReg r0), ISubRI () rD' i]
+evalE (IR.IB IR.IMinus e (IR.ConstI i)) rD = do
+ let rD' = absReg rD
+ eR <- nextI
+ plE <- evalE e (IR.ITemp eR)
+ pure $ plE ++ [MovRR () rD' (IReg eR), ISubRI () rD' i]
+evalE (IR.IB IR.IMinus e (IR.Reg r)) rD = do
+ let rD' = absReg rD
+ eR <- nextI
+ plE <- evalE e (IR.ITemp eR)
+ pure $ plE ++ [MovRR () rD' (IReg eR), ISubRR () rD' (absReg r)]
+evalE (IR.IB IR.IDiv e (IR.Reg r)) rD = do
+ let rD' = absReg rD
+ eR <- nextI
+ plE <- evalE e (IR.ITemp eR)
+ pure $ plE ++ [MovRR () Quot (absReg r), IDiv () (IReg eR), MovRR () rD' Quot]
+evalE (IR.IB IR.IDiv e0 e1) rD = do
+ let rD' = absReg rD
+ e0R <- nextI
+ e1R <- nextI
+ plE0 <- evalE e0 (IR.ITemp e0R)
+ plE1 <- evalE e1 (IR.ITemp e1R)
+ pure $ plE0 ++ plE1 ++ [MovRR () Quot (IReg e0R), IDiv () (IReg e1R), MovRR () rD' Quot]
+evalE (IR.IB IR.IPlus e (IR.ConstI i)) rD = do
+ let rD' = absReg rD
+ eR <- nextI
+ plE <- evalE e (IR.ITemp eR)
+ pure $ plE ++ [MovRR () rD' (IReg eR), IAddRI () rD' i]
+ -- = let rD' = absReg rD in pure [MovRR () rD' (absReg r0), IAddRI () rD' i]
+evalE (IR.IRFloor (IR.FReg r)) t = let r' = absReg r in pure [Roundsd () r' r' RDown, Cvttsd2si () (absReg t) r']
+evalE (IR.EAt (IR.AP m (Just (IR.ConstI i)) _)) rD | Just i8 <- mi8 i = pure [MovRA () (absReg rD) (RC (absReg m) i8)]
+evalE (IR.EAt (IR.AP m (Just (IR.IB IR.IAsl (IR.Reg i) (IR.ConstI 3))) _)) rD = pure [MovRA () (absReg rD) (RS (absReg m) Eight (absReg i))]
+evalE (IR.IU IR.INot (IR.Reg r0)) rD | r0 == rD = pure [Not () (absReg rD)]
+ | otherwise = let rD' = absReg rD in pure [MovRR () rD' (absReg r0), Not () rD']
+evalE (IR.IB IR.IAnd (IR.Reg r0) (IR.Reg r1)) rD = let rD' = absReg rD in pure [MovRR () rD' (absReg r0), And () rD' (absReg r1)]
+evalE e _ = error (show e)
diff --git a/src/C/FP.hs b/src/C/FP.hs
new file mode 100644
index 000000000..4d22f473c
--- /dev/null
+++ b/src/C/FP.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module C.FP ( cArr ) where
+
+import qualified Data.ByteString as BS
+import qualified Data.Text as T
+import Prettyprinter (Doc)
+
+cArr :: T.Text -> BS.ByteString -> Doc ann
+cArr f = "char " <> f <> undefined
+ -- int my_array[3][3] ={10, 23, 42, 1, 654, 0, 40652, 22, 0};
diff --git a/src/CF.hs b/src/CF.hs
new file mode 100644
index 000000000..541b26fc8
--- /dev/null
+++ b/src/CF.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module CF ( ControlAnn (..)
+ , Liveness (..)
+ , NLiveness (..)
+ , GLiveness (..)
+ , Interval (..)
+ ) where
+
+import Control.DeepSeq (NFData)
+import qualified Data.IntSet as IS
+import Data.Semigroup ((<>))
+import GHC.Generics (Generic)
+import Prettyprinter (Pretty (pretty), braces, punctuate, (<+>))
+
+data GLiveness = GLiveness { isMove :: !Bool, gLiveness :: !Liveness }
+
+data Liveness = Liveness { ins :: !IS.IntSet, out :: !IS.IntSet } -- strictness annotations make it perform better
+ deriving (Eq, Generic, NFData)
+
+data NLiveness = NLiveness { nx :: Int, liveness :: !Liveness }
+ deriving (Generic, NFData)
+
+data Interval = Interval { new :: !IS.IntSet, done :: !IS.IntSet }
+ deriving (Generic, NFData)
+
+instance Pretty Liveness where
+ pretty (Liveness is os) = pretty (Interval is os)
+
+instance Pretty Interval where
+ pretty (Interval is os) = braces (pp is <+> ";" <+> pp os)
+ where pp = mconcat . punctuate "," . fmap pretty . IS.toList
+
+-- | Control-flow annotations
+data ControlAnn = ControlAnn { node :: !Int
+ , conn :: [Int]
+ , usesNode :: IS.IntSet
+ , defsNode :: IS.IntSet
+ } deriving (Generic, NFData)
diff --git a/src/CGen.hs b/src/CGen.hs
new file mode 100644
index 000000000..249fbe146
--- /dev/null
+++ b/src/CGen.hs
@@ -0,0 +1,25 @@
+module CGen ( irTy
+ ) where
+
+import A
+import Control.Exception (Exception)
+import Data.Bifunctor (first)
+import qualified Data.Text as T
+
+data CType = CDouble | CLong -- todo: int64_t?
+
+data CF = CF !T.Text [CType] CType
+
+-- type translation error
+data TTE = HigherOrder | Poly deriving Show
+
+instance Exception TTE where
+
+irTy :: T a -> Either TTE ([T a], T a)
+irTy F = pure ([], F)
+irTy I = pure ([], I)
+irTy B = pure ([], B)
+irTy t@Arr{} = pure ([], t)
+irTy (Arrow Arrow{} _) = Left HigherOrder
+irTy (Arrow t0 t1) = first (t0:) <$> irTy t1
+irTy TVar{} = Left Poly
diff --git a/src/Data/Copointed.hs b/src/Data/Copointed.hs
new file mode 100644
index 000000000..9d89bd3d7
--- /dev/null
+++ b/src/Data/Copointed.hs
@@ -0,0 +1,8 @@
+module Data.Copointed ( Copointed (..)
+ ) where
+
+class Copointed p where
+ copoint :: p a -> a
+
+instance Copointed ((,) a) where
+ copoint (_, y) = y
diff --git a/src/Dbg.hs b/src/Dbg.hs
new file mode 100644
index 000000000..580728fbf
--- /dev/null
+++ b/src/Dbg.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Dbg ( dumpX86
+ , dumpX86Abs
+ , dumpX86Liveness
+ , dumpIR
+ , dumpX86Intervals
+ , printParsed
+ , printTypes
+ , topt
+ , nasm
+ , pB
+ , pBIO
+ , module P
+ ) where
+
+import A
+import Asm.X86
+import Asm.X86.Byte
+import qualified Asm.X86.CF as X86
+import Asm.X86.Trans
+import CF
+import Control.Exception (throw)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BSL
+import Data.Semigroup ((<>))
+import qualified Data.Text as T
+import IR
+import L
+import LI
+import LR
+import Numeric (showHex)
+import P
+import Prettyprinter (Doc, pretty, prettyList)
+import Prettyprinter.Ext
+import Ty
+
+pBIO :: BSL.ByteString -> IO (Either (Err AlexPosn) (Doc ann))
+pBIO = fmap (fmap pHex) . comm . fmap dbgFp . x86
+ where comm :: Either a (IO b) -> IO (Either a b)
+ comm (Left err) = pure(Left err)
+ comm (Right x) = Right <$> x
+
+pB :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann)
+pB = fmap pHex . bytes
+
+pHex :: BS.ByteString -> Doc ann
+pHex = prettyList . fmap (($"").showHex) . BS.unpack
+
+nasm :: T.Text -> BSL.ByteString -> Doc ann
+nasm f = (prolegomena <#>) . prettyX86 . either throw id . x86
+ where prolegomena = "section .text\n\nextern malloc\n\nextern free\n\nglobal " <> pretty f <#> pretty f <> ":"
+
+dumpX86 :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann)
+dumpX86 = fmap prettyX86 . x86
+
+dumpX86Abs :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann)
+dumpX86Abs = fmap (prettyX86 . (\(x, st) -> irToX86 st x)) . ir
+
+dumpIR :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann)
+dumpIR = fmap (prettyIR.fst) . ir
+
+dumpX86Intervals :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann)
+dumpX86Intervals = fmap prettyDebugX86 . x86Iv
+
+dumpX86Liveness :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann)
+dumpX86Liveness = fmap (prettyDebugX86 . fmap (fmap liveness) . reconstruct . X86.mkControlFlow . (\(x, st) -> irToX86 st x)) . ir
+
+x86Iv :: BSL.ByteString -> Either (Err AlexPosn) [X86 AbsReg Interval]
+x86Iv = fmap (intervals . reconstruct . X86.mkControlFlow . (\(x, st) -> irToX86 st x)) . ir
+
+printParsed :: BSL.ByteString -> Doc ann
+printParsed = pretty . fst . either throw id . parseRename
+
+-- throws exception
+printTypes :: BSL.ByteString -> Doc ann
+printTypes bsl =
+ case parseRename bsl of
+ Left err -> throw err
+ Right (ast, m) -> either throw (prettyTyped.fst) $ tyClosed m ast
+
+topt :: BSL.ByteString -> Either (Err AlexPosn) (Doc ann)
+topt = fmap prettyTyped . opt
diff --git a/src/Hs/A.hs b/src/Hs/A.hs
new file mode 100644
index 000000000..1ab1dc8e2
--- /dev/null
+++ b/src/Hs/A.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Hs.A ( Apple (..)
+ , AI
+ , AF
+ ) where
+
+import Control.Monad (forM, zipWithM_)
+import Data.Int (Int64)
+import Foreign.Ptr (castPtr, plusPtr)
+import Foreign.Storable (Storable (..))
+import Prettyprinter (Pretty (..), (<+>))
+import Prettyprinter.Ext
+
+type AI = Apple Int64
+type AF = Apple Double
+
+-- TODO: Int8, Int32?
+data Apple a = AA !Int64 [Int64] [a]
+
+instance Pretty a => Pretty (Apple a) where
+ pretty (AA _ dims xs) = "Arr" <+> tupledBy "×" (pretty <$> dims) <+> pretty xs
+
+instance Storable a => Storable (Apple a) where
+ sizeOf (AA rnk dims _) = 8+8*fromIntegral rnk+(sizeOf (undefined::a)*fromIntegral (product dims))
+ poke p (AA rnk dims xs) = do
+ poke (castPtr p) rnk
+ zipWithM_ (\i o -> poke (p `plusPtr` (8+8*o)) i) dims [0..]
+ let datOffs = 8+8*fromIntegral rnk
+ zipWithM_ (\x o -> poke (p `plusPtr` (datOffs+8*o)) x) xs [0..]
+ peek p = do
+ rnk <- peek (castPtr p)
+ dims <- forM [1..fromIntegral rnk] $ \o -> peek $ p `plusPtr` (8*o)
+ let datOffs = 8+8*fromIntegral rnk
+ xs <- forM [1..fromIntegral (product dims)] $ \o -> peek $ p `plusPtr` (datOffs+8*(o-1))
+ pure $ AA rnk dims xs
diff --git a/src/Hs/FFI.hsc b/src/Hs/FFI.hsc
new file mode 100644
index 000000000..87db03a72
--- /dev/null
+++ b/src/Hs/FFI.hsc
@@ -0,0 +1,44 @@
+-- https://eli.thegreenplace.net/2013/11/05/how-to-jit-an-introduction
+module Hs.FFI ( bsFp
+ , allocNear
+ , allocExec
+ , finish
+ ) where
+
+import Data.Bits ((.|.))
+import Foreign.C.Types (CInt (..), CSize (..), CChar)
+import Foreign.Ptr (FunPtr, IntPtr (..), castPtrToFunPtr, Ptr, intPtrToPtr, nullPtr)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Unsafe as BS
+import System.Posix.Types (COff (..))
+
+#include
+
+allocNear :: Int -> CSize -> IO (Ptr a)
+allocNear i sz =
+ mmap (intPtrToPtr (IntPtr$i+6*1024*104)) sz #{const PROT_WRITE} (#{const MAP_PRIVATE} .|. #{const MAP_ANONYMOUS}) (-1) 0
+ -- libc.so is 2.1MB, libm is 918kB
+
+allocExec :: CSize -> IO (Ptr a)
+allocExec sz =
+ mmap nullPtr sz #{const PROT_WRITE} (#{const MAP_32BIT} .|. #{const MAP_PRIVATE} .|. #{const MAP_ANONYMOUS}) (-1) 0
+
+finish :: BS.ByteString -> Ptr CChar -> IO (FunPtr a)
+finish bs fAt = BS.unsafeUseAsCStringLen bs $ \(b, sz) -> do
+ let sz' = fromIntegral sz
+ _ <- memcpy fAt b sz'
+ _ <- mprotect fAt sz' #{const PROT_EXEC}
+ pure (castPtrToFunPtr fAt)
+
+bsFp :: BS.ByteString -> IO (FunPtr a, CSize)
+bsFp bs = BS.unsafeUseAsCStringLen bs $ \(bytes, sz) -> do
+ let sz' = fromIntegral sz
+ fAt <- {-# SCC "mmap" #-} allocExec sz'
+ _ <- {-# SCC "memcpy" #-} memcpy fAt bytes sz'
+ _ <- {-# SCC "mprotect" #-} mprotect fAt sz' #{const PROT_EXEC}
+ pure (castPtrToFunPtr fAt, sz')
+
+foreign import ccall mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> COff -> IO (Ptr a)
+foreign import ccall mprotect :: Ptr a -> CSize -> CInt -> IO CInt
+foreign import ccall memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)
+foreign import ccall munmap :: Ptr a -> CSize -> IO CInt
diff --git a/src/I.hs b/src/I.hs
new file mode 100644
index 000000000..acbb6f64b
--- /dev/null
+++ b/src/I.hs
@@ -0,0 +1,91 @@
+module I ( inline
+ , β
+ ) where
+
+import A
+import Control.Monad.State.Strict (State, gets, modify, runState)
+import Data.Bifunctor (second)
+import qualified Data.IntMap as IM
+import Name
+import R
+import Ty
+import U
+
+data ISt a = ISt { renames :: !Renames
+ , binds :: IM.IntMap (E a)
+ }
+
+instance HasRenames (ISt a) where
+ rename f s = fmap (\x -> s { renames = x }) (f (renames s))
+
+type M a = State (ISt a)
+
+bind :: Name a -> E a -> ISt a -> ISt a
+bind (Name _ (U u) _) e (ISt r bs) = ISt r (IM.insert u e bs)
+
+runI i = second (max_.renames) . flip runState (ISt (Renames i mempty) mempty)
+
+inline :: Int -> E (T ()) -> (E (T ()), Int)
+inline i = runI i . iM
+
+β :: Int -> E (T ()) -> (E (T ()), Int)
+β i = runI i . bM
+
+-- assumes globally renamed already
+-- | Inlining is easy because we don't have recursion
+iM :: E (T ()) -> M (T ()) (E (T ()))
+iM e@Builtin{} = pure e
+iM e@FLit{} = pure e
+iM e@ILit{} = pure e
+iM (ALit l es) = ALit l <$> traverse iM es
+iM (Tup l es) = Tup l <$> traverse iM es
+iM (Cond l p e0 e1) = Cond l <$> iM p <*> iM e0 <*> iM e1
+iM (EApp l e0 e1) = EApp l <$> iM e0 <*> iM e1
+iM (Lam l n e) = Lam l n <$> iM e
+iM (LLet l (n, e') e) = do
+ e'I <- iM e'
+ eI <- iM e
+ pure $ LLet l (n, e'I) eI
+iM (Let _ (n, e') e) = do
+ eI <- iM e'
+ modify (bind n eI) *> iM e
+iM (Def _ (n, e') e) = do
+ eI <- iM e'
+ modify (bind n eI) *> iM e
+iM e@(Var t (Name _ (U i) _)) = do
+ st <- gets binds
+ case IM.lookup i st of
+ Just e' -> do {er <- rE e'; pure $ fmap (aT (match (eAnn er) t)) er}
+ Nothing -> pure e
+
+-- beta reduction
+bM :: E (T ()) -> M (T ()) (E (T ()))
+bM e@Builtin{} = pure e
+bM e@FLit{} = pure e
+bM e@ILit{} = pure e
+bM (ALit l es) = ALit l <$> traverse bM es
+bM (Tup l es) = Tup l <$> traverse bM es
+bM (Cond l p e0 e1) = Cond l <$> bM p <*> bM e0 <*> bM e1
+bM (EApp _ (Lam _ n e') e) = do
+ eI <- bM e
+ modify (bind n eI) *> bM e'
+bM (EApp l e0 e1) = do
+ e0' <- bM e0
+ e1' <- bM e1
+ case e0' of
+ Lam{} -> bM (EApp l e0' e1')
+ _ -> pure $ EApp l e0' e1'
+bM (Lam l n e) = Lam l n <$> bM e
+bM e@(Var _ (Name _ (U i) _)) = do
+ st <- gets binds
+ case IM.lookup i st of
+ Just e' -> rE e'
+ Nothing -> pure e
+bM (LLet l (n, e') e) = do
+ e'B <- bM e'
+ eB <- bM e
+ pure $ LLet l (n, e'B) eB
+bM (Id l idm) = Id l <$> bid idm
+
+bid :: Idiom -> M (T ()) Idiom
+bid (FoldOfZip seed op es) = FoldOfZip <$> bM seed <*> bM op <*> traverse bM es
diff --git a/src/IR.hs b/src/IR.hs
new file mode 100644
index 000000000..7cb8cf23d
--- /dev/null
+++ b/src/IR.hs
@@ -0,0 +1,179 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module IR ( Exp (..)
+ , FExp (..)
+ , Stmt (..)
+ , Temp (..)
+ , FBin (..)
+ , FUn (..)
+ , AE (..)
+ , IBin (..)
+ , IUn (..)
+ , IRel (..)
+ , Label
+ , WSt (..)
+ , prettyIR
+ ) where
+
+import Data.Int (Int64)
+import Data.Semigroup ((<>))
+import Prettyprinter (Doc, Pretty (..), hardline, parens, (<+>))
+import Prettyprinter.Ext
+
+-- see https://my.eng.utah.edu/~cs4400/sse-fp.pdf
+
+type Label = Word
+
+data WSt = WSt { wlabels :: [Label], wtemps :: [Int] }
+
+prettyLabel :: Label -> Doc ann
+prettyLabel l = "apple_" <> pretty l
+
+data Temp = ITemp !Int
+ | ATemp !Int
+ | C0 | C1 | C2 | C3 | C4 | C5
+ | CRet
+ | FTemp !Int
+ -- 512-bit
+ | F8Temp !Int -- ZMM0-ZMM31
+ | F0 | F1 | F2 | F3 | F4 | F5
+ | FRet | FRet1
+ | StackPointer
+ deriving (Eq)
+
+instance Pretty Temp where
+ pretty (ITemp i) = "r_" <> pretty i
+ pretty (ATemp i) = "a_" <> pretty i
+ pretty C0 = "r_arg0"
+ pretty C1 = "r_arg1"
+ pretty C2 = "r_arg2"
+ pretty C3 = "r_arg3"
+ pretty C4 = "r_arg4"
+ pretty C5 = "r_arg5"
+ pretty CRet = "r_ret"
+ pretty (FTemp i) = "f_" <> pretty i
+ pretty F0 = "f_arg0"
+ pretty F1 = "f_arg1"
+ pretty F2 = "f_arg2"
+ pretty F3 = "f_arg3"
+ pretty F4 = "f_arg4"
+ pretty F5 = "f_arg5"
+ pretty FRet = "f_ret"
+ pretty FRet1 = "f_ret1"
+ pretty StackPointer = "stack_pointer"
+
+instance Show Temp where show = show . pretty
+
+data Stmt = L Label
+ | MJ Exp Label
+ | J Label
+ | MT Temp Exp
+ | MX Temp FExp -- move targeting xmm0, etc.
+ | Ma Temp Exp -- size
+ | Free Temp
+ | Wr AE Exp
+ | WrF AE FExp
+ | Cmov Exp Temp Exp
+ -- TODO: ccall?
+
+instance Pretty Stmt where
+ pretty (L l) = hardline <> prettyLabel l <> ":"
+ pretty (MT t e) = parens ("movtemp" <+> pretty t <+> pretty e)
+ pretty (MX t e) = parens ("movf" <+> pretty t <+> pretty e)
+ pretty (MJ e l) = parens ("mjump" <+> pretty e <+> prettyLabel l)
+ pretty (J l) = parens ("j" <+> prettyLabel l)
+ pretty (Wr p e) = parens ("write" <+> pretty p <+> pretty e)
+ pretty (WrF p e) = parens ("write" <+> pretty p <+> pretty e)
+ pretty (Ma t e) = parens ("malloc" <+> pretty t <+> ":" <+> pretty e)
+ pretty (Cmov p t e) = parens ("cmov" <+> pretty p <+> pretty t <+> pretty e)
+
+instance Show Stmt where show = show . pretty
+
+data AE = AP Temp (Maybe Exp) (Maybe Int) -- offset, label for tracking liveness
+
+instance Pretty AE where
+ pretty (AP t Nothing _) = parens ("ptr" <+> pretty t)
+ pretty (AP t (Just e) _) = parens ("ptr" <+> pretty t <> "+" <> pretty e)
+
+data FExp = ConstF Double
+ | FB FBin FExp FExp
+ | FConv Exp
+ | FReg Temp
+ | FU FUn FExp
+ | FAt AE
+
+data Exp = ConstI Int64
+ | Reg Temp
+ | IB IBin Exp Exp
+ | IRel IRel Exp Exp
+ | IU IUn Exp
+ | IRFloor FExp
+ | EAt AE
+
+instance Pretty FExp where
+ pretty (ConstF x) = parens ("double" <+> pretty x)
+ pretty (FConv e) = parens ("itof" <+> pretty e)
+ pretty (FReg t) = parens ("freg" <+> pretty t)
+ pretty (FB op e e') = parens (pretty op <+> pretty e <+> pretty e')
+ pretty (FU op e) = parens (pretty op <+> pretty e)
+ pretty (FAt p) = "f@" <> pretty p
+
+instance Show FExp where show=show.pretty
+
+instance Pretty Exp where
+ pretty (ConstI i) = parens ("int" <+> pretty i)
+ pretty (Reg t) = parens ("reg" <+> pretty t)
+ pretty (IRel op e e') = parens (pretty op <+> pretty e <+> pretty e')
+ pretty (IB op e e') = parens (pretty op <+> pretty e <+> pretty e')
+ pretty (IU op e) = parens (pretty op <+> pretty e)
+ pretty (IRFloor e) = parens ("floor" <+> pretty e)
+ pretty (EAt p) = "@" <> pretty p
+
+instance Show Exp where show = show.pretty
+
+data FUn = FSqrt | FLog
+
+data IUn = ISgn | INot
+
+data FBin = FPlus | FMinus | FTimes | FDiv | FMax | FMin | FExp
+
+data IBin = IPlus | IMinus | ITimes | IAsr | IAnd | IMax | IMin | IDiv | IAsl
+
+data IRel = IEq | INeq | IGt | ILt | ILeq | IGeq
+
+instance Pretty IRel where
+ pretty IEq = "="
+ pretty INeq = "!="
+ pretty IGt = ">"
+ pretty ILt = "<"
+ pretty ILeq = "≤"
+ pretty IGeq = "≥"
+
+instance Pretty IBin where
+ pretty IPlus = "+"
+ pretty IMinus = "-"
+ pretty ITimes = "*"
+ pretty IDiv = "div"
+ pretty IAsl = "asl"
+ pretty IAsr = "asr"
+ pretty IMax = "max"
+ pretty IMin = "min"
+ pretty IAnd = "∧"
+
+instance Pretty FBin where
+ pretty FPlus = "+"
+ pretty FMinus = "-"
+ pretty FTimes = "*"
+ pretty FDiv = "%"
+ pretty FExp = "^"
+
+instance Pretty FUn where
+ pretty FSqrt = "sqrt"
+ pretty FLog = "log"
+
+instance Pretty IUn where
+ pretty ISgn = "sgn"
+ pretty INot = "¬"
+
+prettyIR :: [Stmt] -> Doc ann
+prettyIR = prettyLines . fmap pretty
diff --git a/src/IR/Alloc.hs b/src/IR/Alloc.hs
new file mode 100644
index 000000000..b8e0a2747
--- /dev/null
+++ b/src/IR/Alloc.hs
@@ -0,0 +1,10 @@
+module IR.Alloc ( live ) where
+
+import CF
+import IR
+import qualified IR.CF as IR
+import LI
+import LR
+
+live :: [Stmt] -> [(Stmt, Interval)]
+live = intervals . reconstruct . IR.mkControlFlow
diff --git a/src/IR/CF.hs b/src/IR/CF.hs
new file mode 100644
index 000000000..281e1e284
--- /dev/null
+++ b/src/IR/CF.hs
@@ -0,0 +1,84 @@
+module IR.CF ( mkControlFlow
+ ) where
+
+import CF
+-- seems to pretty clearly be faster
+import Control.Monad.State.Strict (State, evalState, gets, modify)
+import Data.Bifunctor (first, second)
+import qualified Data.IntSet as IS
+import qualified Data.Map as M
+import Data.Semigroup ((<>))
+import IR
+
+-- map of labels by node
+type FreshM = State (Int, M.Map Label Int)
+
+runFreshM :: FreshM a -> a
+runFreshM = flip evalState (0, mempty)
+
+mkControlFlow :: [Stmt] -> [(Stmt, ControlAnn)]
+mkControlFlow instrs = runFreshM (broadcasts instrs *> addControlFlow instrs)
+
+getFresh :: FreshM Int
+getFresh = gets fst <* modify (first (+1))
+
+lookupLabel :: Label -> FreshM Int
+lookupLabel l = gets (M.findWithDefault (error "Internal error in control-flow graph: node label not in map.") l . snd)
+
+broadcast :: Int -> Label -> FreshM ()
+broadcast i l = modify (second (M.insert l i))
+
+-- | Pair 'Stmt's with a unique node name and a list of all possible
+-- destinations.
+addControlFlow :: [Stmt] -> FreshM [(Stmt, ControlAnn)]
+addControlFlow [] = pure []
+addControlFlow ((L l):stmts) = do
+ { i <- lookupLabel l
+ ; (f, stmts') <- next stmts
+ ; pure ((L l, ControlAnn i (f []) IS.empty IS.empty):stmts')
+ }
+addControlFlow (J l:stmts) = do
+ { i <- getFresh
+ ; nextStmts <- addControlFlow stmts
+ ; l_i <- lookupLabel l
+ ; pure ((J l, ControlAnn i [l_i] IS.empty IS.empty):nextStmts)
+ }
+addControlFlow (MJ e l:stmts) = do
+ { i <- getFresh
+ ; (f, stmts') <- next stmts
+ ; l_i <- lookupLabel l
+ ; pure ((MJ e l, ControlAnn i (f [l_i]) (uE e) IS.empty):stmts')
+ }
+addControlFlow (stmt:stmts) = do
+ { i <- getFresh
+ ; (f, stmts') <- next stmts
+ ; pure ((stmt, ControlAnn i (f []) (uses stmt) (defs stmt)):stmts')
+ }
+
+uE :: Exp -> IS.IntSet
+uE (EAt (AP _ _ (Just m))) = IS.singleton m
+
+uses :: Stmt -> IS.IntSet
+uses L{} = IS.empty
+uses (Ma _ e) = uE e
+
+defs :: Stmt -> IS.IntSet
+defs L{} = IS.empty
+-- defs (Ma t _) = IS.singleton t
+
+next :: [Stmt] -> FreshM ([Int] -> [Int], [(Stmt, ControlAnn)])
+next stmts = do
+ nextStmts <- addControlFlow stmts
+ case nextStmts of
+ [] -> pure (id, [])
+ (stmt:_) -> pure ((node (snd stmt) :), nextStmts)
+
+-- | Construct map assigning labels to their node name.
+broadcasts :: [Stmt] -> FreshM [Stmt]
+broadcasts [] = pure []
+broadcasts (stmt@(L l):stmts) = do
+ { i <- getFresh
+ ; broadcast i l
+ ; (stmt :) <$> broadcasts stmts
+ }
+broadcasts (asm:asms) = (asm :) <$> broadcasts asms
diff --git a/src/IR/Trans.hs b/src/IR/Trans.hs
new file mode 100644
index 000000000..35ce31a66
--- /dev/null
+++ b/src/IR/Trans.hs
@@ -0,0 +1,544 @@
+{-# LANGUAGE TupleSections #-}
+
+module IR.Trans ( writeC
+ ) where
+
+import A
+import Control.Monad.State.Strict (State, gets, modify, runState)
+import Data.Bifunctor (second)
+import Data.Foldable (fold)
+import Data.Functor (($>))
+import Data.Int (Int64)
+import qualified Data.IntMap as IM
+import IR
+import Name
+import U
+
+data IRSt = IRSt { labels :: [Label]
+ , temps :: [Int]
+ , arrs :: [Int]
+ , vars :: IM.IntMap Temp -- track vars so that (Var x) can be replaced at the site
+ , avars :: IM.IntMap (Maybe Int, Temp)
+ }
+
+getT :: IM.IntMap b -> Name a -> b
+getT st (Name _ (U i) _) = IM.findWithDefault (error "Internal error: variable not mapped to register.") i st
+
+nextI :: IRM Int
+nextI = do
+ i <- gets (head.temps)
+ modify (\(IRSt l (_:t) ar v a) -> IRSt l t ar v a) $> i
+
+nextArr :: IRM Int
+nextArr = do
+ a <- gets (head.arrs)
+ modify (\(IRSt l t (_:ar) v aϵ) -> IRSt l t ar v aϵ) $> a
+
+newITemp :: IRM Temp
+newITemp = ITemp <$> nextI
+
+newFTemp :: IRM Temp
+newFTemp = FTemp <$> nextI
+
+newLabel :: IRM Label
+newLabel = do
+ i <- gets (head.labels)
+ modify (\(IRSt l t ar v a) -> IRSt (tail l) t ar v a) $> i
+
+addVar :: Name a -> Temp -> IRSt -> IRSt
+addVar (Name _ (U i) _) r (IRSt l t ar v a) = IRSt l t ar (IM.insert i r v) a
+
+addAVar :: Name a -> (Maybe Int, Temp) -> IRSt -> IRSt
+addAVar (Name _ (U i) _) r (IRSt l t ar v a) = IRSt l t ar v (IM.insert i r a)
+
+type IRM = State IRSt
+
+isF :: T a -> Bool
+isF F = True
+isF _ = False
+
+isI :: T a -> Bool
+isI I = True
+isI _ = False
+
+isArr Arr{} = True
+isArr _ = False
+
+writeC :: E (T ()) -> ([Stmt], WSt)
+writeC = second π . flip runState (IRSt [0..] [0..] [0..] IM.empty IM.empty) . writeCM where π (IRSt l t _ _ _) = WSt l t
+
+-- %xmm0 – %xmm7
+writeCM :: E (T ()) -> IRM [Stmt]
+writeCM e' = go e' [F0,F1,F2,F3,F4,F5] [C0,C1,C2,C3,C4,C5] where
+ go (Lam _ x@(Name _ _ F) e) (fr:frs) rs = do
+ modify (addVar x fr)
+ go e frs rs
+ go (Lam _ (Name _ _ F) _) [] _ = error "Not enough floating-point registers!"
+ go (Lam _ x@(Name _ _ I) e) frs (r:rs) = do
+ modify (addVar x r)
+ go e frs rs
+ go (Lam _ x@(Name _ _ Arr{}) e) frs (r:rs) = do
+ modify (addAVar x (Nothing, r))
+ go e frs rs
+ go Lam{} _ [] = error "Not enough registers!"
+ go e _ _ | isF (eAnn e) = do { f <- newFTemp ; (++[MX FRet (FReg f)]) <$> eval e f } -- avoid clash with xmm0 (arg + ret)
+ | isI (eAnn e) = eval e CRet
+ | isArr (eAnn e) = snd <$> aeval e CRet
+ | otherwise = error ("Unsupported return type: " ++ show (eAnn e))
+
+writeRF :: E (T ()) -> [Temp] -> Temp -> IRM [Stmt]
+writeRF e rs = fmap snd . writeF e ((Nothing,) <$> rs)
+
+-- write loop body (updates global state, dependent on ast being globally renamed)
+writeF :: E (T ())
+ -> [(Maybe Int, Temp)] -- ^ Registers for arguments
+ -> Temp -- ^ Register for return value
+ -> IRM (Maybe Int, [Stmt])
+ -- TODO: handle when args are arrays
+writeF (Lam _ x e) (r:rs) ret | isArr (loc x) = do
+ modify (addAVar x r)
+ writeF e rs ret
+writeF (Lam _ x e) ((_,r):rs) ret = do
+ modify (addVar x r)
+ writeF e rs ret
+writeF Lam{} [] _ = error "Internal error: wrong number of registers to arguments."
+writeF e _ ret | isArr (eAnn e) = aeval e ret
+ | otherwise = (Nothing,) <$> eval e ret
+
+fop op e0 = EApp F (EApp (Arrow F F) (Builtin (Arrow F (Arrow F F)) op) e0)
+eMinus = fop Minus
+ePlus = fop Plus
+eDiv = fop Div
+
+aeval :: E (T ()) -> Temp -> IRM (Maybe Int, [Stmt])
+aeval (Var Arr{} x) t = do
+ st <- gets avars
+ let (i, r) = getT st x
+ pure (i, [MT t (Reg r)])
+aeval (EApp res (EApp _ (Builtin _ (Map 1)) op) e) t | f1 (eAnn e) && f1 res = do
+ a <- nextArr
+ arrP <- newITemp
+ (l, plE) <- aeval e arrP
+ -- cause f1 (skip rank)
+ let sz = EAt (AP arrP (Just (ConstI 8)) l)
+ f <- newFTemp
+ (_, ss) <- writeF op [(Nothing, f)] f
+ iR <- newITemp
+ szR <- newITemp
+ let loop = MX f (FAt (AP arrP Nothing l)):ss++[WrF (AP t (Just (IB IPlus (IB IAsl (Reg iR) (ConstI 3)) (ConstI 16))) (Just a)) (FReg f), MT arrP (IB IPlus (Reg arrP) (ConstI 8)), MT iR (IB IPlus (Reg iR) (ConstI 1))]
+ ll <- newLabel
+ endL <- newLabel
+ pure (Just a, plE ++ (MT szR sz:Ma t (IB IPlus (IB IAsl (Reg szR) (ConstI 3)) (ConstI 24)):MT iR (ConstI 0):Wr (AP t Nothing (Just a)) (ConstI 1):Wr (AP t (Just$ConstI 8) (Just a)) (Reg szR):MT arrP (IB IPlus (Reg arrP) (ConstI 16)):L ll:MJ (IRel IGt (Reg iR) (Reg szR)) endL:loop) ++ [J ll, L endL])
+aeval (EApp res (EApp _ (EApp _ (Builtin _ Scan) op) seed) e) t | i1 (eAnn e) && i1 res && isI (eAnn seed) = do
+ a <- nextArr
+ arrP <- newITemp
+ acc <- newITemp
+ plSeed <- eval seed acc
+ (l, plE) <- aeval e arrP
+ -- rank1
+ let sz = EAt (AP arrP (Just$ConstI 8) l)
+ n <- newITemp
+ (_, ss) <- writeF op [(Nothing, acc), (Nothing, n)] acc
+ iR <- newITemp
+ szR <- newITemp
+ -- TODO: why arrP and iR?
+ let loop=MT n (EAt (AP arrP (Just$IB IAsl (Reg iR) (ConstI 3)) l)):Wr (AP t (Just (IB IPlus (IB IAsl (Reg iR) (ConstI 3)) (ConstI 16))) (Just a)) (Reg acc):ss++[MT iR (IB IPlus (Reg iR) (ConstI 1))]
+ ll <- newLabel
+ endL <- newLabel
+ pure (Just a, plE ++ plSeed ++ (MT szR (IB IPlus sz (ConstI 1)):Ma t (IB IPlus (IB IAsl (Reg szR) (ConstI 3)) (ConstI 24)):MT iR (ConstI 0):Wr (AP t Nothing (Just a)) (ConstI 1):Wr (AP t (Just$ConstI 8) (Just a)) (Reg szR):MT arrP (IB IPlus (Reg arrP) (ConstI 16)):L ll:MJ (IRel IGt (Reg iR) (Reg szR)) endL:loop) ++ [J ll, L endL])
+aeval (EApp res (EApp _ (Builtin _ (Map 1)) op) e) t | i1 (eAnn e) && i1 res = do
+ a <- nextArr
+ arrP <- newITemp
+ (l, plE) <- aeval e arrP
+ -- cause f1 (skip rank)
+ let sz = EAt (AP arrP (Just (ConstI 8)) l)
+ m <- newITemp
+ (_, ss) <- writeF op [(Nothing, m)] m
+ iR <- newITemp
+ szR <- newITemp
+ -- TODO: why arrP and iR?
+ let loop = MT m (EAt (AP arrP (Just$IB IAsl (Reg iR) (ConstI 3)) l)):ss++[Wr (AP t (Just (IB IPlus (IB IAsl (Reg iR) (ConstI 3)) (ConstI 16))) (Just a)) (Reg m), MT iR (IB IPlus (Reg iR) (ConstI 1))]
+ ll <- newLabel
+ endL <- newLabel
+ pure (Just a, plE ++ (MT szR sz:Ma t (IB IPlus (IB IAsl (Reg szR) (ConstI 3)) (ConstI 24)):MT iR (ConstI 0):Wr (AP t Nothing (Just a)) (ConstI 1):Wr (AP t (Just$ConstI 8) (Just a)) (Reg szR):MT arrP (IB IPlus (Reg arrP) (ConstI 16)):L ll:MJ (IRel IGt (Reg iR) (Reg szR)) endL:loop) ++ [J ll, L endL])
+aeval (EApp _ (EApp _ (EApp _ (Builtin _ IRange) start) end) (ILit _ 1)) t = do
+ a <- nextArr
+ n <- newITemp
+ startR <- newITemp
+ endR <- newITemp
+ i <- newITemp
+ putStart <- eval start startR
+ putEnd <- eval end endR
+ l <- newLabel
+ endL <- newLabel
+ let putN = MT n (IB IMinus (Reg endR) (Reg startR))
+ let loop = [MJ (IRel IGt (Reg startR) (Reg endR)) endL, Wr (AP t (Just (Reg i)) (Just a)) (Reg startR), MT startR (IB IPlus (Reg startR) (ConstI 1)), MT i (IB IPlus (Reg i) (ConstI 8))]
+ pure (Just a, putStart++putEnd++putN:Ma t (IB IPlus (IB IAsl (Reg n) (ConstI 3)) (ConstI 24)):Wr (AP t Nothing (Just a)) (ConstI 1):Wr (AP t (Just (ConstI 8)) (Just a)) (Reg n):MT i (ConstI 16):L l:loop ++ [J l, L endL])
+aeval (EApp _ (EApp _ (EApp _ (Builtin _ IRange) start) end) incr) t = do
+ a <- nextArr
+ n <- newITemp
+ startR <- newITemp
+ endR <- newITemp
+ incrR <- newITemp
+ i <- newITemp
+ putStart <- eval start startR
+ putEnd <- eval end endR
+ putIncr <- eval incr incrR
+ l <- newLabel
+ endL <- newLabel
+ let putN = MT n (IB IR.IDiv (IB IMinus (Reg endR) (Reg startR)) (Reg incrR))
+ let loop = [MJ (IRel IGt (Reg startR) (Reg endR)) endL, Wr (AP t (Just (Reg i)) (Just a)) (Reg startR), MT startR (IB IPlus (Reg startR) (Reg incrR)), MT i (IB IPlus (Reg i) (ConstI 8))]
+ pure (Just a, putStart++putEnd++putIncr++putN:Ma t (IB IPlus (IB IAsl (Reg n) (ConstI 3)) (ConstI 24)):Wr (AP t Nothing (Just a)) (ConstI 1):Wr (AP t (Just (ConstI 8)) (Just a)) (Reg n):MT i (ConstI 16):L l:loop ++ [J l, L endL])
+aeval e _ = error (show e)
+
+eval :: E (T ()) -> Temp -> IRM [Stmt]
+eval (LLet _ (n, e') e) t | isF (eAnn e') = do
+ f <- newFTemp
+ plF <- eval e' f
+ modify (addVar n f)
+ (plF ++) <$> eval e t
+eval (LLet _ (n, e') e) t | isI (eAnn e') = do
+ t' <- newITemp
+ plT <- eval e' t'
+ modify (addVar n t')
+ (plT ++) <$> eval e t
+ -- TODO: isArr
+eval (EApp _ (EApp _ (EApp _ (Builtin _ Fold{}) op) seed) (EApp _ (EApp _ (EApp _ (Builtin _ IRange) start) end) (ILit _ j))) acc = do
+ i <- newITemp
+ endR <- newITemp
+ l <- newLabel
+ endL <- newLabel
+ putStart <- eval start i
+ putAcc <- eval seed acc
+ irEnd <- eval end endR
+ step <- writeRF op [acc, i] acc
+ pure $ putStart ++ putAcc ++ irEnd ++ (L l:MJ (IRel IGt (Reg i) (Reg endR)) endL:step) ++ [MT i (IB IPlus (Reg i) (ConstI $ asI j)), J l, L endL]
+eval (EApp _ (EApp _ (EApp _ (Builtin _ Fold{}) op) seed) (EApp _ (EApp _ (EApp _ (Builtin _ IRange) start) end) incr)) acc = do
+ i <- newITemp
+ endR <- newITemp
+ incrR <- newITemp
+ l <- newLabel
+ endL <- newLabel
+ putStart <- eval start i
+ putAcc <- eval seed acc
+ irEnd <- eval end endR
+ irIncr <- eval incr incrR
+ step <- writeRF op [acc, i] acc
+ -- TODO: is this shortest loop?
+ pure $ putStart ++ putAcc ++ irEnd ++ irIncr ++ (L l:MJ (IRel IGt (Reg i) (Reg endR)) endL:step) ++ [MT i (IB IPlus (Reg i) (Reg incrR)), J l, L endL]
+-- TODO: start, end, nSteps a literal
+eval (EApp _ (EApp _ (EApp _ (Builtin _ Fold{}) op) seed) (EApp _ (EApp _ (EApp _ (Builtin _ FRange) (ILit _ start)) (ILit _ end)) (ILit _ nSteps))) acc = do
+ i <- newITemp
+ l <- newLabel
+ endL <- newLabel
+ let incr = fromIntegral (end-start+1)/fromIntegral nSteps
+ xR <- newFTemp
+ putAcc <- eval seed acc
+ step <- writeRF op [acc, xR] acc
+ pure $ putAcc ++ (MX xR (ConstF $ fromIntegral start):MT i (ConstI 1):L l:MJ (IRel IGt (Reg i) (ConstI $ fromIntegral nSteps)) endL:step) ++ [MT i (IB IPlus (Reg i) (ConstI 1)), MX xR (FB FPlus (FReg xR) (ConstF incr)), J l, L endL]
+eval (EApp _ (EApp _ (EApp _ (Builtin _ Fold{}) op) seed) (EApp _ (EApp _ (EApp _ (Builtin _ FRange) start) end) nSteps@(EApp _ (Builtin _ Floor) nStepsF))) acc = do
+ i <- newITemp
+ startR <- newFTemp
+ incrR <- newFTemp
+ xR <- newFTemp
+ endI <- newITemp
+ l <- newLabel
+ endL <- newLabel
+ putStart <- eval start startR
+ putAcc <- eval seed acc
+ putIEnd <- eval nSteps endI
+ putIncr <- eval (((end `eMinus` start) `ePlus` FLit F 1) `eDiv` nStepsF) incrR
+ -- step the accumulating value
+ step <- writeRF op [acc, xR] acc
+ pure $ putStart ++ (MX xR (FReg startR):putIEnd) ++ putIncr ++ putAcc ++ (MT i (ConstI 1):L l:MJ (IRel IGt (Reg i) (Reg endI)) endL:step) ++ [MT i (IB IPlus (Reg i) (ConstI 1)), MX xR (FB FPlus (FReg xR) (FReg incrR)), J l, L endL]
+ -- TODO: case where nSteps is a Var ...
+eval (EApp _ (EApp _ (EApp _ (Builtin _ Fold{}) op) seed) (EApp _ (EApp _ (EApp _ (Builtin _ FRange) start) end) nSteps)) acc = do
+ i <- newITemp
+ startR <- newFTemp
+ incrR <- newFTemp
+ xR <- newFTemp
+ endI <- newITemp
+ l <- newLabel
+ endL <- newLabel
+ putStart <- eval start startR
+ putAcc <- eval seed acc
+ putIEnd <- eval nSteps endI
+ putIncr <- eval (((end `eMinus` start) `ePlus` FLit F 1) `eDiv` EApp F (Builtin (Arrow I F) ItoF) nSteps) incrR
+ -- step the accumulating value
+ step <- writeRF op [acc, xR] acc
+ pure $ putStart ++ (MX xR (FReg startR):putIEnd) ++ putIncr ++ putAcc ++ (MT i (ConstI 1):L l:MJ (IRel IGt (Reg i) (Reg endI)) endL:step) ++ [MT i (IB IPlus (Reg i) (ConstI 1)), MX xR (FB FPlus (FReg xR) (FReg incrR)), J l, L endL]
+eval (EApp _ (EApp _ (Builtin (Arrow I _) Plus) (Var _ x)) e) t = do
+ tϵ <- newITemp
+ st <- gets vars
+ pl <- eval e tϵ
+ pure $ pl ++ [MT t (IB IPlus (Reg $ getT st x) (Reg tϵ))]
+eval (EApp _ (EApp _ (Builtin (Arrow I _) Plus) e0) e1) t = do
+ t0 <- newITemp
+ t1 <- newITemp
+ pl0 <- eval e0 t0
+ pl1 <- eval e1 t1
+ pure $ pl0 ++ pl1 ++ [MT t (IB IPlus (Reg t0) (Reg t1))]
+eval (EApp _ (EApp _ (Builtin _ Plus) (Var F x)) (EApp _ (EApp _ (Builtin _ Times) (Var _ y)) e0)) t = do
+ st <- gets vars
+ t0 <- newFTemp
+ pl0 <- eval e0 t0
+ pure $ pl0 ++ [MX t (FB FPlus (FReg $ getT st x) (FB FTimes (FReg t0) (FReg $ getT st y)))]
+eval (EApp _ (EApp _ (Builtin _ Plus) (Var F x)) (EApp _ (EApp _ (Builtin _ Times) e0) e1)) t = do
+ st <- gets vars
+ t0 <- newFTemp
+ t1 <- newFTemp
+ pl0 <- eval e0 t0
+ pl1 <- eval e1 t1
+ pure $ pl0 ++ pl1 ++ [MX t (FB FPlus (FReg $ getT st x) (FB FTimes (FReg t0) (FReg t1)))]
+eval (EApp _ (EApp _ (Builtin _ Plus) (Var F x)) e) t = do
+ st <- gets vars
+ t' <- newFTemp
+ pl <- eval e t'
+ pure $ pl ++ [MX t (FB FPlus (FReg $ getT st x) (FReg t'))]
+eval (EApp _ (EApp _ (Builtin (Arrow F _) Plus) e0) e1) t = do
+ t0 <- newFTemp
+ t1 <- newFTemp
+ pl0 <- eval e0 t0
+ pl1 <- eval e1 t1
+ pure $ pl0 ++ pl1 ++ [MX t (FB FPlus (FReg t0) (FReg t1))]
+eval (EApp _ (EApp _ (Builtin (Arrow I _) Times) (Var I x)) (Var _ y)) t = do
+ st <- gets vars
+ let xT = getT st x
+ yT = getT st y
+ pure [MT t (IB ITimes (Reg xT) (Reg yT))]
+eval (EApp _ (EApp _ (Builtin (Arrow I _) Times) e0) e1) t = do
+ t0 <- newITemp
+ t1 <- newITemp
+ pl0 <- eval e0 t0
+ pl1 <- eval e1 t1
+ pure $ pl0 ++ pl1 ++ [MT t (IB ITimes (Reg t0) (Reg t1))]
+eval (EApp _ (EApp _ (Builtin _ Minus) (Var _ x)) (ILit F n)) t = do
+ st <- gets vars
+ pure [MX t (FB FMinus (FReg $ getT st x) (ConstF $ fromIntegral n))]
+eval (EApp _ (EApp _ (Builtin _ Minus) e) (ILit F i)) t = do
+ tϵ <- newFTemp
+ pl <- eval e tϵ
+ pure $ pl ++ [MX t (FB FMinus (FReg tϵ) (ConstF $ fromIntegral i))]
+eval (EApp _ (EApp _ (Builtin _ Minus) (Var _ x)) (ILit I i)) t = do
+ st <- gets vars
+ pure [MT t (IB IMinus (Reg $ getT st x) (ConstI $ asI i))]
+eval (EApp _ (EApp _ (Builtin _ Minus) e) (ILit I i)) t = do
+ tϵ <- newITemp
+ pl <- eval e tϵ
+ pure $ pl ++ [MT t (IB IMinus (Reg tϵ) (ConstI $ asI i))]
+eval (EApp _ (EApp _ (Builtin (Arrow I _) Minus) e0) e1) t = do
+ t0 <- newITemp
+ t1 <- newITemp
+ pl0 <- eval e0 t0
+ pl1 <- eval e1 t1
+ pure $ pl0 ++ pl1 ++ [MT t (IB IMinus (Reg t0) (Reg t1))]
+eval (ILit F x) t = pure [MX t (ConstF $ fromIntegral x)] -- if it overflows... you deserve it
+eval (ILit _ i) t = pure [MT t (ConstI $ asI i)]
+eval (Var F x) t = do
+ st <- gets vars
+ pure [MX t (FReg $ getT st x)]
+eval (Var I x) t = do
+ st <- gets vars
+ pure [MT t (Reg $ getT st x)]
+eval (EApp _ (Builtin _ ItoF) (ILit _ i)) t = do
+ pure [MX t (ConstF $ fromIntegral i)]
+eval (EApp _ (Builtin _ ItoF) (Var _ x)) t = do
+ st <- gets vars
+ pure [MX t (FConv $ Reg $ getT st x)]
+eval (EApp _ (Builtin _ ItoF) e) t = do
+ iR <- newITemp
+ pl<- eval e iR
+ pure $ pl ++ [MX t (FConv $ Reg iR)]
+eval (EApp _ (EApp _ (Builtin _ Div) e) (Var _ x)) t = do
+ tf <- newFTemp
+ st <- gets vars
+ pl <- eval e tf
+ pure $ pl ++ [MX t (FB FDiv (FReg tf) (FReg $ getT st x))]
+eval (EApp _ (EApp _ (Builtin _ Div) e0) e1) t = do
+ t0 <- newFTemp
+ t1 <- newFTemp
+ pl0 <- eval e0 t0
+ pl1 <- eval e1 t1
+ pure $ pl0 ++ pl1 ++ [MX t (FB FDiv (FReg t0) (FReg t1))]
+eval (EApp _ (EApp _ (Builtin _ A.IDiv) e0) e1) t = do
+ t0 <- newITemp
+ t1 <- newITemp
+ pl0 <- eval e0 t0
+ pl1 <- eval e1 t1
+ pure $ pl0 ++ pl1 ++ [MT t (IB IR.IDiv (Reg t0) (Reg t1))]
+eval (EApp F (EApp _ (Builtin _ Times) (Var F x)) (Var F y)) t = do
+ st <- gets vars
+ let xT = getT st x
+ yT = getT st y
+ pure [MX t (FB FTimes (FReg xT) (FReg yT))]
+eval (EApp F (EApp _ (Builtin _ Times) (Var F x)) e) t = do
+ st <- gets vars
+ t' <- newFTemp
+ pl <- eval e t'
+ pure $ pl ++ [MX t (FB FTimes (FReg $ getT st x) (FReg t'))]
+eval (EApp F (EApp _ (Builtin _ Times) e0) e1) t = do
+ t0 <- newFTemp
+ t1 <- newFTemp
+ pl0 <- eval e0 t0
+ pl1 <- eval e1 t1
+ pure $ pl0 ++ pl1 ++ [MX t (FB FTimes (FReg t0) (FReg t1))]
+eval (EApp F (EApp _ (Builtin _ Minus) e0) e1) t = do
+ t0 <- newFTemp
+ t1 <- newFTemp
+ pl0 <- eval e0 t0
+ pl1 <- eval e1 t1
+ pure $ pl0 ++ pl1 ++ [MX t (FB FMinus (FReg t0) (FReg t1))]
+eval (EApp F (EApp _ (Builtin _ Exp) (FLit _ x)) e) t = do
+ f <- newFTemp
+ plE <- eval e f
+ pure $ plE ++ [MX t (FB FExp (ConstF x) (FReg f))]
+eval (EApp F (EApp _ (Builtin _ IntExp) x) n) t = do
+ i <- newITemp
+ nR <- newITemp
+ plR <- eval n nR
+ xR <- newFTemp
+ plX <- eval x xR
+ l <- newLabel
+ endL <- newLabel
+ pure $ plR ++ plX ++ [MX t (ConstF 1), MT i (Reg nR), L l, MJ (IRel IEq (Reg i) (ConstI 0)) endL, MX t (FB FTimes (FReg t) (FReg xR)), MT i (IB IMinus (Reg i) (ConstI 1)), J l, L endL]
+eval (EApp _ (EApp _ (Builtin _ IntExp) x) n) t = do
+ i <- newITemp
+ nR <- newITemp
+ plR <- eval n nR
+ xR <- newITemp
+ plX <- eval x xR
+ l <- newLabel
+ endL <- newLabel
+ pure $ plR ++ plX ++ [MT t (ConstI 1), MT i (Reg nR), L l, MJ (IRel IEq (Reg i) (ConstI 0)) endL, MT t (IB ITimes (Reg t) (Reg xR)), MT i (IB IMinus (Reg i) (ConstI 1)), J l, L endL]
+eval (EApp _ (Builtin _ Floor) (Var _ x)) t = do
+ st <- gets vars
+ pure [MT t (IRFloor (FReg $ getT st x))]
+eval (EApp _ (Builtin _ Floor) x) t = do
+ fR <- newFTemp
+ plX <- eval x fR
+ pure $ plX ++ [MT t (IRFloor (FReg fR))]
+eval (EApp _ (Builtin (Arrow F _) Neg) x) t = do
+ fR <- newFTemp
+ plX <- eval x fR
+ pure $ plX ++ [MX t (FB FMinus (ConstF 0) (FReg fR))]
+eval (FLit _ x) t = pure [MX t (ConstF x)]
+eval (EApp _ (Builtin _ Sqrt) (FLit _ x)) t =
+ pure [MX t (ConstF (sqrt x))]
+ -- FIXME: check op is F->F &c.
+eval (EApp _ (Builtin _ Sqrt) (ILit F x)) t =
+ pure [MX t (ConstF (sqrt $ realToFrac x :: Double))]
+eval (EApp _ (Builtin _ Sqrt) e) t = do
+ eR <- newFTemp
+ plE <- eval e eR
+ pure $ plE ++ [MX t (FU FSqrt (FReg eR))]
+eval (EApp _ (EApp _ (EApp _ (Builtin _ Fold{}) op) seed) e) acc | f1 (eAnn e) = do
+ x <- newFTemp
+ arrR <- newITemp
+ eR <- newITemp
+ szR <- newITemp
+ i <- newITemp
+ (mI, plE) <- aeval e eR
+ putAcc <- eval seed acc
+ l <- newLabel
+ endL <- newLabel
+ stepR <- writeRF op [acc, x] acc
+ let step = MX x (FAt (AP arrR Nothing mI)):stepR ++ [MT arrR (IB IPlus (Reg arrR) (ConstI 8))]
+ -- GHC uses 'length' but our szR needs to be one less
+ pure $ plE ++ putAcc ++ MT i (ConstI 0):MT szR (EAt (AP eR (Just (ConstI 8)) mI)):MT arrR (IB IPlus (Reg eR) (ConstI 16)):MT szR (IB IMinus (Reg szR) (ConstI 1)):L l:MJ (IRel IGt (Reg i) (Reg szR)) endL:MT i (IB IPlus (Reg i) (ConstI 1)):step++[J l, L endL]
+eval (EApp _ (EApp _ (EApp _ (Builtin _ Fold{}) op) seed) e) acc | i1 (eAnn e) = do
+ x <- newITemp
+ arrR <- newITemp
+ eR <- newITemp
+ szR <- newITemp
+ i <- newITemp
+ (mI, plE) <- aeval e eR
+ putAcc <- eval seed acc
+ l <- newLabel
+ endL <- newLabel
+ stepR <- writeRF op [acc, x] acc
+ let step = MT x (EAt (AP arrR Nothing mI)):stepR ++ [MT arrR (IB IPlus (Reg arrR) (ConstI 8))]
+ -- GHC uses 'length' but our szR needs to be one less
+ pure $ plE ++ putAcc ++ MT i (ConstI 0):MT szR (EAt (AP eR (Just (ConstI 8)) mI)):MT arrR (IB IPlus (Reg eR) (ConstI 16)):MT szR (IB IMinus (Reg szR) (ConstI 1)):L l:MJ (IRel IGt (Reg i) (Reg szR)) endL:MT i (IB IPlus (Reg i) (ConstI 1)):step++[J l, L endL]
+eval (Id F (FoldOfZip seed op [p, q])) acc | f1 (eAnn p) && f1 (eAnn q) = do
+ x <- newFTemp
+ y <- newFTemp
+ pR <- newITemp
+ qR <- newITemp
+ szR <- newITemp
+ arr0R <- newITemp
+ arr1R <- newITemp
+ i <- newITemp
+ (iP, plP) <- aeval p pR
+ (iQ, plQ) <- aeval q qR
+ putAcc <- eval seed acc
+ l <- newLabel
+ endL <- newLabel
+ stepR <- writeRF op [acc, x, y] acc
+ let step = MX x (FAt (AP arr0R Nothing iP)):MX y (FAt (AP arr1R Nothing iQ)):stepR ++ [MT arr0R (IB IPlus (Reg arr0R) (ConstI 8)), MT arr1R (IB IPlus (Reg arr1R) (ConstI 8))]
+ -- FIXME: this assumes the arrays are the same size
+ pure $ plP ++ plQ ++ putAcc ++ MT i (ConstI 0):MT szR (EAt (AP pR (Just (ConstI 8)) iP)):MT arr0R (IB IPlus (Reg pR) (ConstI 16)):MT arr1R (IB IPlus (Reg qR) (ConstI 16)):MT szR (IB IMinus (Reg szR) (ConstI 1)):L l:MJ (IRel IGt (Reg i) (Reg szR)) endL:MT i (IB IPlus (Reg i) (ConstI 1)):step++[J l, L endL]
+eval (Id F (FoldOfZip seed op [EApp _ (EApp _ (EApp _ (Builtin _ IRange) start) end) incr, ALit ty qs])) acc | f1 ty = do
+ x <- newITemp
+ i <- newITemp
+ y <- newFTemp
+ plX <- eval start x
+ plI <- eval incr i
+ putAcc <- eval seed acc
+ stepR <- writeRF op [acc, x, y] acc
+ steps <- foldMapA (\q -> do { plY <- eval q y ; pure $ plY ++ stepR ++ [MT x (IB IPlus (Reg x) (Reg i))] }) qs -- FIXME: doesn't check arrays are same size
+ pure $ plX ++ plI ++ putAcc ++ steps
+eval (EApp _ (Builtin _ Log) (Var _ x)) t = do
+ st <- gets vars
+ pure [MX t (FU FLog (FReg $ getT st x))]
+eval (EApp _ (Builtin _ Log) e) t = do
+ t' <- newFTemp
+ plE <- eval e t'
+ pure $ plE ++ [MX t (FU FLog (FReg t'))]
+eval (EApp _ (Builtin _ Size) e) t | unDim (eAnn e) = do
+ r <- newITemp
+ (mI, plE) <- aeval e r
+ pure $ plE ++ [MT t (EAt (AP r (Just (ConstI 8)) mI))]
+eval (EApp _ (Builtin _ Size) e) t = do
+ r <- newITemp
+ (mI, plE) <- aeval e r
+ rnkR <- newITemp
+ l <- newLabel
+ endL <- newLabel
+ i <- newITemp
+ pure $ plE ++ [MT rnkR (EAt (AP r Nothing mI)), MT i (ConstI 8), MT t (EAt (AP r (Just (ConstI 8)) mI)), L l, MJ (IRel IGt (Reg i) (Reg rnkR)) endL, MT i (IB IPlus (Reg i) (ConstI 8)), MT t (IB ITimes (Reg t) (EAt (AP r (Just (Reg i)) mI))),J l, L endL]
+eval (EApp I (EApp _ (Builtin _ Max) e0) (Var _ y)) t = do
+ st <- gets vars
+ e0R <- newITemp
+ let e1R = getT st y
+ e1RE = Reg e1R
+ plE0 <- eval e0 e0R
+ pure $ if e1R == t
+ then plE0 ++ [MT t (Reg e0R), Cmov (IRel IGt e1RE (Reg e0R)) t e1RE]
+ else plE0 ++ [MT t e1RE, Cmov (IRel IGt (Reg e0R) e1RE) t (Reg e0R)]
+eval (EApp I (EApp _ (Builtin _ Max) e0) e1) t = do
+ e0R <- newITemp
+ e1R <- newITemp
+ plE0 <- eval e0 e0R
+ plE1 <- eval e1 e1R
+ pure $ plE0 ++ plE1 ++ [MT t (Reg e1R), Cmov (IRel IGt (Reg e0R) (Reg e1R)) t (Reg e0R)]
+eval e _ = error (show e)
+
+foldMapA :: (Applicative f, Traversable t, Monoid m) => (a -> f m) -> t a -> f m
+foldMapA = (fmap fold .) . traverse
+
+-- 1-dim'l array of floats
+f1 :: T a -> Bool
+f1 (Arr (_ `Cons` Nil) F) = True
+f1 _ = False
+
+i1 :: T a -> Bool
+i1 (Arr (_ `Cons` Nil) I) = True
+i1 _ = False
+
+unDim :: T a -> Bool
+unDim (Arr (_ `Cons` Nil) _) = True
+unDim _ = False
+
+asI :: Integer -> Int64
+asI i | i < fromIntegral (minBound :: Int64) || i > fromIntegral (maxBound :: Int64) = error "integer literal out of bounds!"
+ | otherwise = fromIntegral i
diff --git a/src/L.x b/src/L.x
new file mode 100644
index 000000000..db9f9396d
--- /dev/null
+++ b/src/L.x
@@ -0,0 +1,345 @@
+{
+ {-# LANGUAGE DeriveGeneric #-}
+ {-# LANGUAGE DeriveAnyClass #-}
+ {-# LANGUAGE OverloadedStrings #-}
+ {-# LANGUAGE StandaloneDeriving #-}
+ module L ( alexMonadScan
+ , alexInitUserState
+ , runAlex
+ , runAlexSt
+ , withAlexSt
+ , freshName
+ , AlexPosn (..)
+ , Alex (..)
+ , Token (..)
+ , Sym (..)
+ , Builtin (..)
+ , Var (..)
+ , AlexUserState
+ ) where
+
+import Control.Arrow ((&&&))
+import Control.DeepSeq (NFData)
+import Data.Bifunctor (first)
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.ByteString.Lazy.Char8 as ASCII
+import Data.Functor (($>))
+import qualified Data.IntMap as IM
+import qualified Data.Map as M
+import Data.Semigroup ((<>))
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8)
+import GHC.Generics (Generic)
+import Prettyprinter (Pretty (pretty), (<+>), colon, squotes)
+import Name
+import U
+
+}
+
+%wrapper "monadUserState-bytestring"
+
+$digit = [0-9]
+
+$latin = [a-zA-Z]
+
+$greek = [α-ωΑ-Ω]
+
+$mathgreek = [𝛼-𝜛]
+
+$letter = [$latin $greek]
+
+@follow_char = [$letter $digit \_]
+
+@name = ($letter#[Λλ] @follow_char* | $mathgreek)
+
+@exp = e\-?$digit+
+@float = $digit+\.$digit+@exp?
+
+tokens :-
+
+ <0> "[" { mkSym LSqBracket `andBegin` dfn } -- FIXME: this doesn't allow nested
+
+ {
+ x { mkRes VarX }
+ y { mkRes VarY }
+ }
+
+ {
+ "[" { mkSym LSqBracket }
+ "]" { mkSym RSqBracket }
+ -- FIXME: what if this is in a dfn?
+ "}" { mkSym RBrace `andBegin` 0 }
+ ∘ { mkSym Compose }
+ o { mkSym Compose }
+ }
+
+ <0,dfn,braces> {
+ $white+ ;
+
+ "--".* ;
+
+ "," { mkSym Comma }
+
+ $digit+ { tok (\p s -> alex $ TokInt p (read $ ASCII.unpack s)) }
+ }
+
+ <0,dfn> {
+ "{" { mkSym LBrace }
+ "}" { mkSym RBrace }
+
+ -- symbols/operators
+ "%" { mkSym Percent }
+ "*" { mkSym Times }
+ "+" { mkSym Plus }
+ "-" { mkSym Minus }
+ "^" { mkSym Caret }
+
+ "/" { mkSym Fold }
+ ' { mkSym Quot }
+ `$white*"{" { mkSym LRank `andBegin` braces }
+ ` { mkSym MapN }
+
+ "(" { mkSym LParen }
+ ")" { mkSym RParen }
+ λ { mkSym Lam }
+ \\ { mkSym Lam }
+ "\`" { mkSym DIS }
+ "\~" { mkSym Succ }
+ "." { mkSym Dot }
+ ";" { mkSym Semicolon }
+ : { mkSym Colon }
+ "←" { mkSym Bind }
+ "<-" { mkSym Bind }
+ _ { mkSym Underscore }
+ "?" { mkSym QuestionMark }
+ ",." { mkSym CondSplit }
+ ⟨ { mkSym ArrL }
+ ⟩ { mkSym ArrR }
+ "_." { mkSym SymLog }
+ ⟜ { mkSym LBind }
+ ⇐ { mkSym PolyBind }
+ → { mkSym Arrow }
+ "->" { mkSym Arrow }
+ :: { mkSym Sig }
+ ⋉ { mkSym MaxS }
+ ">." { mkSym MaxS }
+ ⋊ { mkSym MinS }
+ "<." { mkSym MinS }
+ ⨳ { mkSym Conv }
+
+ "]" { mkSym RSqBracket `andBegin` 0 }
+
+ frange { mkBuiltin BuiltinFRange }
+ 𝒻 { mkBuiltin BuiltinFRange }
+ irange { mkBuiltin BuiltinIota }
+ ⍳ { mkBuiltin BuiltinIota }
+ ⌊ { mkBuiltin BuiltinFloor }
+ "|." { mkBuiltin BuiltinFloor }
+ ℯ { mkBuiltin BuiltinE }
+ "e:" { mkBuiltin BuiltinE }
+ itof { mkBuiltin BuiltinI }
+ 𝑖 { mkBuiltin BuiltinI } -- TODO: better as ℝ?
+ 𝓕 { mkBuiltin BuiltinF }
+ "#t" { mkBuiltin BuiltinTrue }
+ "#f" { mkBuiltin BuiltinFalse }
+ √ { mkBuiltin BuiltinSqrt }
+ 𝜋 { mkBuiltin BuiltinPi }
+ "gen." { mkBuiltin BuiltinGen }
+ "r:" { mkBuiltin BuiltinRep }
+ Λ { mkBuiltin BuiltinScan }
+ "/\" { mkBuiltin BuiltinScan }
+ "`Cons`" { mkBuiltin BuiltinCons }
+ Nil { mkBuiltin BuiltinNil }
+ "%." { mkBuiltin BuiltinMMul }
+ Arr { mkBuiltin BuiltinArr }
+ float { mkBuiltin BuiltinFloat }
+ int { mkBuiltin BuiltinInt }
+
+ _$digit+ { tok (\p s -> alex $ TokInt p (negate $ read $ ASCII.unpack $ BSL.tail s)) }
+
+ @float { tok (\p s -> alex $ TokFloat p (read $ ASCII.unpack s)) }
+ _@float { tok (\p s -> alex $ TokFloat p (negate $ read $ ASCII.unpack $ BSL.tail s)) }
+
+ @name { tok (\p s -> TokName p <$> newIdentAlex p (mkText s)) }
+
+ }
+
+{
+
+alex :: a -> Alex a
+alex = pure
+
+tok f (p,_,s,_) len = f p (BSL.take len s)
+
+constructor c t = tok (\p _ -> alex $ c p t)
+
+mkRes = constructor TokResVar
+
+mkSym = constructor TokSym
+
+mkBuiltin = constructor TokBuiltin
+
+mkText :: BSL.ByteString -> T.Text
+mkText = decodeUtf8 . BSL.toStrict
+
+instance Pretty AlexPosn where
+ pretty (AlexPn _ line col) = pretty line <> colon <> pretty col
+
+deriving instance Ord AlexPosn
+
+deriving instance Generic AlexPosn
+
+deriving instance NFData AlexPosn
+
+-- functional bimap?
+type AlexUserState = (Int, M.Map T.Text Int, IM.IntMap (Name AlexPosn))
+
+alexInitUserState :: AlexUserState
+alexInitUserState = (0, mempty, mempty)
+
+gets_alex :: (AlexState -> a) -> Alex a
+gets_alex f = Alex (Right . (id &&& f))
+
+get_ust :: Alex AlexUserState
+get_ust = gets_alex alex_ust
+
+get_pos :: Alex AlexPosn
+get_pos = gets_alex alex_pos
+
+set_ust :: AlexUserState -> Alex ()
+set_ust st = Alex (Right . (go &&& (const ())))
+ where go s = s { alex_ust = st }
+
+alexEOF = EOF <$> get_pos
+
+data Sym = Plus | Minus | Fold | Percent | Times | Semicolon | Bind
+ | LSqBracket | RSqBracket | LBrace | RBrace | LParen | RParen | Lam
+ | Dot | Caret | Quot | MapN | Comma | Underscore | QuestionMark | Colon
+ | CondSplit | ArrL | ArrR | SymLog | LBind | PolyBind | LRank | Compose
+ | Arrow | Sig | MaxS | MinS | DIS | Succ | Conv
+ deriving (Generic, NFData)
+
+instance Pretty Sym where
+ pretty Plus = "+"
+ pretty Minus = "-"
+ pretty Percent = "%"
+ pretty Fold = "/"
+ pretty Times = "*"
+ pretty Semicolon = ";"
+ pretty Colon = ":"
+ pretty Bind = "←"
+ pretty LSqBracket = "["
+ pretty RSqBracket = "]"
+ pretty LBrace = "{"
+ pretty RBrace = "}"
+ pretty LParen = "("
+ pretty RParen = ")"
+ pretty Lam = "λ"
+ pretty Dot = "."
+ pretty Caret = "^"
+ pretty Quot = "'"
+ pretty MapN = "`"
+ pretty Comma = ","
+ pretty Underscore = "_"
+ pretty QuestionMark = "?"
+ pretty CondSplit = ",."
+ pretty ArrL = "⟨"
+ pretty ArrR = "⟩"
+ pretty SymLog = "_."
+ pretty LBind = "⟜"
+ pretty PolyBind = "⇐"
+ pretty LRank = "`{"
+ pretty Compose = "∘"
+ pretty Arrow = "→"
+ pretty Sig = "::"
+ pretty MaxS = "⋉"
+ pretty MinS = "⋊"
+ pretty DIS = "\\`"
+ pretty Succ = "\\~"
+ pretty Conv = "⨳"
+
+-- | Reserved/special variables
+data Var = VarX | VarY deriving (Generic, NFData)
+
+instance Pretty Var where
+ pretty VarX = "x"
+ pretty VarY = "y"
+
+data Builtin = BuiltinFRange | BuiltinIota | BuiltinFloor | BuiltinE | BuiltinI
+ | BuiltinF | BuiltinTrue | BuiltinFalse | BuiltinSqrt | BuiltinPi
+ | BuiltinGen | BuiltinRep | BuiltinScan | BuiltinCons | BuiltinNil
+ | BuiltinMMul | BuiltinArr | BuiltinInt | BuiltinFloat
+ deriving (Generic, NFData)
+
+instance Pretty Builtin where
+ pretty BuiltinFRange = "frange"
+ pretty BuiltinIota = "⍳"
+ pretty BuiltinFloor = "⌊"
+ pretty BuiltinE = "ℯ"
+ pretty BuiltinI = "𝑖"
+ pretty BuiltinF = "𝓕"
+ pretty BuiltinTrue = "#t"
+ pretty BuiltinFalse = "#f"
+ pretty BuiltinSqrt = "√"
+ pretty BuiltinPi = "𝜋"
+ pretty BuiltinGen = "gen."
+ pretty BuiltinRep = "r:"
+ pretty BuiltinScan = "Λ"
+ pretty BuiltinCons = "`Cons`"
+ pretty BuiltinNil = "Nil"
+ pretty BuiltinMMul = "%."
+ pretty BuiltinArr = "Arr"
+ pretty BuiltinInt = "int"
+ pretty BuiltinFloat = "float"
+
+data Token a = EOF { loc :: a }
+ | TokSym { loc :: a, _sym :: Sym }
+ | TokName { loc :: a, _name :: Name a }
+ | TokBuiltin { loc :: a, _builtin :: Builtin }
+ | TokResVar { loc :: a, _var :: Var }
+ | TokInt { loc :: a, int :: Integer }
+ | TokFloat { loc :: a, float :: Double }
+ deriving (Generic, NFData)
+
+instance Pretty (Token a) where
+ pretty EOF{} = "(eof)"
+ pretty (TokSym _ s) = "symbol" <+> squotes (pretty s)
+ pretty (TokName _ n) = "identifier" <+> squotes (pretty n)
+ pretty (TokBuiltin _ b) = "builtin" <+> squotes (pretty b)
+ pretty (TokInt _ i) = pretty i
+ pretty (TokResVar _ v) = "reserved variable" <+> squotes (pretty v)
+ pretty (TokFloat _ f) = pretty f
+
+freshName :: T.Text -> Alex (Name AlexPosn)
+freshName t = do
+ pos <- get_pos
+ newIdentAlex pos t
+
+newIdentAlex :: AlexPosn -> T.Text -> Alex (Name AlexPosn)
+newIdentAlex pos t = do
+ st <- get_ust
+ let (st', n) = newIdent pos t st
+ set_ust st' $> (n $> pos)
+
+newIdent :: AlexPosn -> T.Text -> AlexUserState -> (AlexUserState, Name AlexPosn)
+newIdent pos t pre@(max', names, uniqs) =
+ case M.lookup t names of
+ Just i -> (pre, Name t (U i) pos)
+ Nothing -> let i = max' + 1
+ in let newName = Name t (U i) pos
+ in ((i, M.insert t i names, IM.insert i newName uniqs), newName)
+
+runAlexSt :: BSL.ByteString -> Alex a -> Either String (AlexUserState, a)
+runAlexSt inp = withAlexSt inp alexInitUserState
+
+withAlexSt :: BSL.ByteString -> AlexUserState -> Alex a -> Either String (AlexUserState, a)
+withAlexSt inp ust (Alex f) = first alex_ust <$> f
+ (AlexState { alex_bpos = 0
+ , alex_pos = alexStartPos
+ , alex_inp = inp
+ , alex_chr = '\n'
+ , alex_ust = ust
+ , alex_scd = 0
+ })
+
+}
diff --git a/src/LI.hs b/src/LI.hs
new file mode 100644
index 000000000..a4f16aae1
--- /dev/null
+++ b/src/LI.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+-- live intervals
+module LI ( intervals
+ ) where
+
+import CF
+import Control.Monad.State.Strict (execState, get, put)
+import Data.Copointed
+import Data.Foldable (traverse_)
+import qualified Data.IntMap.Lazy as IM
+import qualified Data.IntSet as IS
+import Data.Semigroup ((<>))
+
+-- {-# SCC collate #-}
+collate :: IM.IntMap Int -> IM.IntMap IS.IntSet
+collate = IM.unionsWith IS.union . fmap g . IM.toList where g (r, n) = IM.singleton n (IS.singleton r)
+
+-- forward pass (first mentioned, indexed by register)
+pF :: Copointed p => [p NLiveness] -> IM.IntMap Int
+pF is = snd $ execState (traverse_ g is) (IS.empty, IM.empty) where
+ g x = do
+ (previouslySeen, upd) <- get
+ let ann = copoint x
+ potentiallyNew = let lx = liveness ann in ins lx <> out lx
+ newS = potentiallyNew IS.\\ previouslySeen
+ nAt = IM.fromList (zip (IS.toList newS) (repeat $ nx ann))
+ put (previouslySeen `IS.union` newS, nAt `IM.union` upd)
+
+-- backward pass (last mentioned, ...)
+pB :: Copointed p => [p NLiveness] -> IM.IntMap Int
+pB = pF.reverse
+
+intervals :: (Copointed p, Functor p) => [p NLiveness] -> [p Interval]
+intervals asms = fmap (fmap lookupL) asms
+ where lookupL x = let n = nx x in Interval (lI n findFirst) (lI n findLast)
+ lI = IM.findWithDefault IS.empty
+ findFirst = collate (pF asms)
+ findLast = collate (pB asms)
diff --git a/src/LR.hs b/src/LR.hs
new file mode 100644
index 000000000..45cbfc8e7
--- /dev/null
+++ b/src/LR.hs
@@ -0,0 +1,64 @@
+-- Based on Appel
+--
+-- live ranges
+module LR ( reconstruct
+ ) where
+
+import CF hiding (done, liveness)
+import Data.Copointed
+-- this seems to be faster
+import qualified Data.IntMap.Lazy as IM
+import qualified Data.IntSet as IS
+import Data.Semigroup ((<>))
+
+emptyLiveness :: Liveness
+emptyLiveness = Liveness IS.empty IS.empty
+
+initLiveness :: Copointed p => [p ControlAnn] -> LivenessMap
+initLiveness = IM.fromList . fmap (\asm -> let x = copoint asm in (node x, (x, emptyLiveness)))
+
+type LivenessMap = IM.IntMap (ControlAnn, Liveness)
+
+-- | All program points accessible from some node.
+succNode :: ControlAnn -- ^ 'ControlAnn' associated w/ node @n@
+ -> LivenessMap
+ -> [Liveness] -- ^ 'Liveness' associated with 'succNode' @n@
+succNode x ns =
+ let conns = conn x
+ in fmap (snd . flip lookupNode ns) conns
+
+lookupNode :: Int -> LivenessMap -> (ControlAnn, Liveness)
+lookupNode = IM.findWithDefault (error "Internal error: failed to look up instruction")
+
+done :: LivenessMap -> LivenessMap -> Bool
+done n0 n1 = {-# SCC "done" #-} and $ zipWith (\(_, l) (_, l') -> l == l') (IM.elems n0) (IM.elems n1) -- should be safe b/c n0, n1 must have same length
+
+-- order in which to inspect nodes during liveness analysis
+inspectOrder :: Copointed p => [p ControlAnn] -> [Int]
+inspectOrder = fmap (node . copoint) -- don't need to reverse because thread goes in opposite order
+
+reconstruct :: (Copointed p, Functor p) => [p ControlAnn] -> [p NLiveness]
+reconstruct asms = {-# SCC "reconstructL" #-} fmap (fmap lookupL) asms
+ where l = {-# SCC "mkLiveness" #-} mkLiveness asms
+ lookupL x = let ni = node x in NLiveness ni (snd $ lookupNode ni l)
+
+mkLiveness :: Copointed p => [p ControlAnn] -> LivenessMap
+mkLiveness asms = liveness is (initLiveness asms)
+ where is = inspectOrder asms
+
+liveness :: [Int] -> LivenessMap -> LivenessMap
+liveness is nSt =
+ if done nSt nSt'
+ then nSt
+ else liveness is nSt'
+ where nSt' = {-# SCC "iterNodes" #-} iterNodes is nSt
+
+iterNodes :: [Int] -> LivenessMap -> LivenessMap
+iterNodes is = thread (fmap stepNode is)
+ where thread = foldr (.) id
+
+stepNode :: Int -> LivenessMap -> LivenessMap
+stepNode n ns = {-# SCC "stepNode" #-} IM.insert n (c, Liveness ins' out') ns
+ where (c, l) = lookupNode n ns
+ ins' = usesNode c <> (out l IS.\\ defsNode c)
+ out' = IS.unions (fmap ins (succNode c ns))
diff --git a/src/Name.hs b/src/Name.hs
new file mode 100644
index 000000000..683df3c2e
--- /dev/null
+++ b/src/Name.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE DeriveFunctor #-}
+
+module Name ( Name (..)
+ , TyName
+ ) where
+
+import Control.DeepSeq (NFData (..))
+import qualified Data.Text as T
+import Prettyprinter (Pretty (..))
+import U
+
+type TyName a = Name a
+
+data Name a = Name { name :: T.Text
+ , unique :: !U
+ , loc :: a
+ } deriving (Functor)
+
+instance Eq (Name a) where
+ (==) (Name _ u _) (Name _ u' _) = u == u'
+
+-- TODO: prettyprinter library?
+instance Pretty (Name a) where
+ pretty (Name n _ _) = pretty n
+ -- pretty (Name n (U i) _) = pretty n <> pretty i
+
+instance Show (Name a) where
+ show = show . pretty
+
+instance NFData a => NFData (Name a) where
+ rnf (Name _ u x) = rnf x `seq` u `seq` ()
diff --git a/src/P.hs b/src/P.hs
new file mode 100644
index 000000000..d4a0bb3e7
--- /dev/null
+++ b/src/P.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+-- pipeline
+module P ( Err (..)
+ , tyParse
+ , tyExpr
+ , parseInline
+ , parseRename
+ , opt
+ , ir
+ , x86
+ , bytes
+ , funP
+ ) where
+
+import A
+import A.Eta
+import A.Opt
+import Asm.X86
+import qualified Asm.X86.Alloc as X86
+import Asm.X86.Byte
+import qualified Asm.X86.CF as X86
+import Asm.X86.Opt
+import Asm.X86.Trans
+import Control.DeepSeq (NFData)
+import Control.Exception (Exception, throwIO)
+import Control.Monad ((<=<))
+import Control.Monad.State.Strict (evalState, state)
+import Data.Bifunctor (first, second)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BSL
+import Data.Typeable (Typeable)
+import Foreign.Ptr (FunPtr)
+import GHC.Generics (Generic)
+import I
+import IR
+import IR.Trans
+import L
+import LI
+import LR
+import Parser
+import Parser.Rw
+import Prettyprinter (Pretty (..))
+import R
+import R.Dfn
+import Ty
+
+data Err a = PErr (ParseE a) | TyErr (TyE a) deriving (Generic)
+
+instance Pretty a => Show (Err a) where
+ show = show . pretty
+
+instance (Pretty a, Typeable a) => Exception (Err a) where
+
+instance NFData a => NFData (Err a) where
+
+instance Pretty a => Pretty (Err a) where
+ pretty (PErr err) = pretty err
+ pretty (TyErr err) = pretty err
+
+parseRename :: BSL.ByteString -> Either (ParseE AlexPosn) (E AlexPosn, Int)
+parseRename = fmap (go.second rewrite) . parseWithMax where
+ go (i, ast) = let (e, m) = dedfn i ast in rG m e
+
+tyExpr :: BSL.ByteString -> Either (Err AlexPosn) (T ())
+tyExpr = fmap (eAnn.fst) . tyParse
+
+funP :: BSL.ByteString -> IO (FunPtr a)
+funP = aFp <=< either throwIO pure . x86
+
+bytes :: BSL.ByteString -> Either (Err AlexPosn) BS.ByteString
+bytes = fmap assemble . x86
+
+x86 :: BSL.ByteString -> Either (Err AlexPosn) [X86 X86Reg ()] -- TODO: save/restore clobbered regs.
+x86 = fmap (optX86 . X86.allocFrame . intervals . reconstruct . X86.mkControlFlow . (\(x, st) -> irToX86 st x)) . ir
+
+ir :: BSL.ByteString -> Either (Err AlexPosn) ([Stmt], WSt)
+ir = fmap writeC . opt
+
+opt :: BSL.ByteString -> Either (Err AlexPosn) (E (T ()))
+opt bsl =
+ uncurry go <$> parseInline bsl where
+ go e = evalState (β'=< Either (Err AlexPosn) (E (T ()), Int)
+parseInline bsl =
+ (\(e, i) -> inline i e) <$> tyParse bsl
+
+tyParse :: BSL.ByteString -> Either (Err AlexPosn) (E (T ()), Int)
+tyParse bsl =
+ case parseRename bsl of
+ Left err -> Left $ PErr err
+ Right (ast, m) -> first TyErr $ tyClosed m ast
diff --git a/src/Parser.y b/src/Parser.y
new file mode 100644
index 000000000..9fc1cb0a4
--- /dev/null
+++ b/src/Parser.y
@@ -0,0 +1,264 @@
+{
+ {-# LANGUAGE DeriveGeneric #-}
+ {-# LANGUAGE OverloadedStrings #-}
+ module Parser ( parse
+ , parseWithMax
+ , ParseE (..)
+ ) where
+
+import Control.Exception (Exception)
+import Control.Monad.Except (ExceptT, runExceptT, throwError)
+import Control.Monad.Trans.Class (lift)
+import Control.DeepSeq (NFData)
+import Data.Bifunctor (first)
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.ByteString.Char8 as ASCII
+import Data.Functor (void)
+import qualified Data.Text as T
+import Data.Typeable (Typeable)
+import GHC.Generics (Generic)
+import qualified Name
+import Name hiding (loc)
+import A
+import L
+import Prettyprinter (Pretty (pretty), (<+>))
+
+}
+
+%name parseE E
+%name parseBind B
+%tokentype { Token AlexPosn }
+%error { parseError }
+%monad { Parse } { (>>=) } { pure }
+%lexer { lift alexMonadScan >>= } { EOF _ }
+
+%token
+
+ lbrace { TokSym $$ LBrace }
+ rbrace { TokSym $$ RBrace }
+ lsqbracket { TokSym $$ LSqBracket }
+ rsqbracket { TokSym $$ RSqBracket }
+ lparen { TokSym $$ LParen }
+ rparen { TokSym $$ RParen }
+ dot { TokSym $$ Dot }
+ bind { TokSym $$ Bind }
+ lbind { TokSym $$ LBind }
+ polybind { TokSym $$ PolyBind }
+ semicolon { TokSym $$ Semicolon }
+ comma { TokSym $$ Comma }
+ underscore { TokSym $$ Underscore }
+ question { TokSym $$ QuestionMark }
+ condSplit { TokSym $$ CondSplit }
+ larr { TokSym $$ ArrL }
+ rarr { TokSym $$ ArrR }
+ colon { TokSym $$ Colon }
+ lrank { TokSym $$ LRank }
+ compose { TokSym $$ Compose }
+ sig { TokSym $$ Sig }
+ arrow { TokSym $$ L.Arrow }
+ di { TokSym $$ DIS }
+ succ { TokSym $$ L.Succ }
+ conv { TokSym $$ L.Conv }
+
+ plus { TokSym $$ L.Plus }
+ minus { TokSym $$ L.Minus }
+ times { TokSym $$ L.Times }
+ percent { TokSym $$ Percent }
+ caret { TokSym $$ Caret }
+ max { TokSym $$ MaxS }
+ min { TokSym $$ MinS }
+
+ fold { TokSym $$ L.Fold }
+ quot { TokSym $$ Quot }
+ mapN { TokSym $$ L.MapN }
+
+ lam { TokSym $$ L.Lam }
+
+ name { TokName _ $$ }
+
+ intLit { $$@(TokInt _ _) }
+ floatLit { $$@(TokFloat _ _) }
+
+ x { TokResVar $$ VarX }
+ y { TokResVar $$ VarY }
+
+ frange { TokBuiltin $$ BuiltinFRange }
+ iota { TokBuiltin $$ BuiltinIota }
+ floor { TokBuiltin $$ BuiltinFloor }
+ e { TokBuiltin $$ BuiltinE }
+ i { TokBuiltin $$ BuiltinI }
+ f { TokBuiltin $$ BuiltinF }
+ tt { TokBuiltin $$ BuiltinTrue }
+ ff { TokBuiltin $$ BuiltinFalse }
+ sqrt { TokBuiltin $$ BuiltinSqrt }
+ pi { TokBuiltin $$ BuiltinPi }
+ gen { TokBuiltin $$ BuiltinGen }
+ log { TokSym $$ SymLog }
+ re { TokBuiltin $$ BuiltinRep }
+ nil { TokBuiltin $$ BuiltinNil }
+ cons { TokBuiltin $$ BuiltinCons }
+ arr { TokBuiltin $$ BuiltinArr }
+ int { TokBuiltin $$ BuiltinInt }
+ float { TokBuiltin $$ BuiltinFloat }
+ scan { TokBuiltin $$ BuiltinScan }
+
+%left paren
+%nonassoc leq geq gt lt neq eq
+
+%%
+
+many(p)
+ : many(p) p { $2 : $1 }
+ | { [] }
+
+sepBy(p,q)
+ : sepBy(p,q) q p { $3 : $1 }
+ | p { [$1] }
+
+tupled(p,q)
+ : sepBy(p,q) q p { $3 : $1 }
+ | p q p { $3 : [$1] }
+
+braces(p)
+ : lbrace p rbrace { $2 }
+
+brackets(p)
+ : lsqbracket p rsqbracket { $2 }
+
+parens(p)
+ : lparen p rparen { $2 }
+
+flipSeq(p,q)
+ : p q { $1 }
+
+I :: { I AlexPosn }
+ : intLit { Ix (loc $1) (fromInteger $ int $1) }
+ | name { IVar (Name.loc $1) $1 }
+ | I plus I { StaPlus $2 $1 $3 }
+
+Sh :: { Sh AlexPosn }
+ : nil { Nil }
+ | I cons Sh { Cons $1 $3 }
+ | name { SVar $1 }
+ | parens(Sh) { $1 }
+
+T :: { T AlexPosn }
+ : arr Sh T { Arr $2 $3 }
+ | int { I }
+ | float { F }
+ | parens(T) { $1 }
+ | T arrow T { A.Arrow $1 $3 }
+
+R :: { (Int, Maybe [Int]) }
+ : intLit compose lsqbracket sepBy(intLit,comma) rsqbracket { (fromInteger $ int $1, Just (reverse (fmap (fromInteger.int) $4))) }
+ | intLit { (fromInteger $ int $1, Nothing) }
+
+-- binary operator
+BBin :: { E AlexPosn }
+ : plus { Builtin $1 A.Plus }
+ | minus { Builtin $1 A.Minus }
+ | times { Builtin $1 A.Times }
+ | percent { Builtin $1 Div }
+ | caret { Builtin $1 IntExp }
+ | max { Builtin $1 Max }
+ | min { Builtin $1 Min }
+ | scan { Builtin $1 Scan }
+ | quot intLit { Builtin $1 (Map (fromInteger $ int $2)) }
+ | di intLit { Builtin $1 (DI (fromInteger $ int $2)) }
+ | conv braces(sepBy(intLit,comma)) { Builtin $1 (A.Conv (reverse (fmap (fromInteger.int) $2))) }
+ -- FIXME: not necessarily binary operator!!
+ | mapN intLit intLit { Builtin $1 (A.MapN (fromInteger $ int $2) (fromInteger $ int $3)) }
+ | lrank sepBy(R,comma) rbrace { Builtin $1 (Rank (reverse $2)) }
+ | succ { Builtin $1 A.Succ }
+
+B :: { (Bnd, (Name AlexPosn, E AlexPosn)) }
+ : name bind E { (L, ($1, $3)) }
+ | name lbind E { (LL, ($1, $3)) }
+ | name polybind E { (D, ($1, $3)) }
+
+E :: { E AlexPosn }
+ : name { Var (Name.loc $1) $1 }
+ | intLit { ILit (loc $1) (int $1) }
+ | floatLit { FLit (loc $1) (float $1) }
+ | pi { FLit $1 pi }
+ | tt { BLit $1 True }
+ | ff { BLit $1 False }
+ | parens(BBin) { $1 }
+ | lparen E BBin rparen { EApp $1 $3 $2 }
+ | lparen BBin E rparen {% do { n <- lift $ freshName "x" ; pure (A.Lam $1 n (EApp $1 (EApp $1 $2 (Var (Name.loc n) n)) $3)) } }
+ | E BBin E { EApp (eAnn $1) (EApp (eAnn $3) $2 $1) $3 }
+ | parens(E) { Parens (eAnn $1) $1 }
+ | larr sepBy(E,comma) rarr { ALit $1 (reverse $2) }
+ | lparen tupled(E,comma) rparen { Tup $1 (reverse $2) }
+ | lam name dot E { A.Lam $1 $2 $4 }
+ | lbrace many(flipSeq(B,semicolon)) E rbrace { mkLet $1 (reverse $2) $3 }
+ | lsqbracket E rsqbracket { Dfn $1 $2 }
+ | frange { Builtin $1 FRange }
+ | iota { Builtin $1 IRange }
+ | floor { Builtin $1 Floor }
+ | underscore { Builtin $1 Neg }
+ | sqrt { Builtin $1 Sqrt }
+ | gen { Builtin $1 Gen }
+ | colon { Builtin $1 Size }
+ | log { Builtin $1 Log }
+ | i { Builtin $1 ItoF }
+ | E fold intLit E E { EApp (eAnn $1) (EApp (eAnn $1) (EApp $2 (Builtin $2 (A.Fold (fromInteger $ int $3))) $1) $4) $5 }
+ | E scan E E { EApp (eAnn $1) (EApp (eAnn $1) (EApp $2 (Builtin $2 Scan) $1) $3) $4 }
+ | E E { EApp (eAnn $1) $1 $2 }
+ | x { ResVar $1 X }
+ | y { ResVar $1 Y }
+ | f { Builtin $1 Fib }
+ | re { Builtin $1 Re }
+ | question E condSplit E condSplit E { Cond $1 $2 $4 $6 }
+ | E sig T { Ann $2 $1 (void $3) }
+ | e { EApp $1 (Builtin $1 Exp) (FLit $1 (exp 1)) }
+
+{
+
+parseError :: Token AlexPosn -> Parse a
+parseError = throwError . Unexpected
+
+data Bnd = L | LL | D
+
+mkLet :: a -> [(Bnd, (Name a, E a))] -> E a -> E a
+mkLet _ [] e = e
+mkLet l ((L, b):bs) e = Let l b (mkLet l bs e)
+mkLet l ((LL, b):bs) e = LLet l b (mkLet l bs e)
+mkLet l ((D, b):bs) e = Def l b (mkLet l bs e)
+
+data ParseE a = Unexpected (Token a)
+ | LexErr String
+ deriving (Generic)
+
+instance Pretty a => Pretty (ParseE a) where
+ pretty (Unexpected tok) = pretty (loc tok) <+> "Unexpected" <+> pretty tok
+ pretty (LexErr str) = pretty (T.pack str)
+
+instance Pretty a => Show (ParseE a) where
+ show = show . pretty
+
+instance (Pretty a, Typeable a) => Exception (ParseE a)
+
+instance NFData a => NFData (ParseE a) where
+
+type Parse = ExceptT (ParseE AlexPosn) Alex
+
+parse :: BSL.ByteString -> Either (ParseE AlexPosn) (E AlexPosn)
+parse = fmap snd . runParse parseE
+
+parseWithMax :: BSL.ByteString -> Either (ParseE AlexPosn) (Int, E AlexPosn)
+parseWithMax = fmap (first fst3) . runParse parseE
+ where fst3 (x, _, _) = x
+
+runParseSt :: Parse a -> AlexUserState -> BSL.ByteString -> Either (ParseE AlexPosn) (AlexUserState, a)
+runParseSt parser u bs = liftErr $ withAlexSt bs u (runExceptT parser)
+
+runParse :: Parse a -> BSL.ByteString -> Either (ParseE AlexPosn) (AlexUserState, a)
+runParse parser = runParseSt parser alexInitUserState
+
+liftErr :: Either String (b, Either (ParseE a) c) -> Either (ParseE a) (b, c)
+liftErr (Left err) = Left (LexErr err)
+liftErr (Right (_, Left err)) = Left err
+liftErr (Right (i, Right x)) = Right (i, x)
+
+}
diff --git a/src/Parser/Rw.hs b/src/Parser/Rw.hs
new file mode 100644
index 000000000..a817ec647
--- /dev/null
+++ b/src/Parser/Rw.hs
@@ -0,0 +1,47 @@
+module Parser.Rw ( rewrite
+ ) where
+
+import A
+
+rewrite = rw
+
+isBinOp :: Builtin -> Bool
+isBinOp Grade = False
+isBinOp FRange = False
+isBinOp IRange = False
+isBinOp Reverse = False
+isBinOp Transpose = False
+isBinOp MapN{} = False
+isBinOp Rank{} = False
+isBinOp Fib = False
+isBinOp Log = False
+isBinOp Size = False
+isBinOp Sqrt = False
+isBinOp Scan{} = False
+isBinOp ItoF = False
+isBinOp _ = True
+
+rw :: E a -> E a
+-- TODO: guard against rewriting unary ops (transpose, reverse, floor?)
+-- guard against rewriting binary infix
+rw (EApp l (EApp lϵ e0@(Builtin _ op) e1) e2) | isBinOp op = EApp l (EApp lϵ e0 (rw e1)) (rw e2)
+rw (EApp l e0 e') =
+ case rw e' of
+ (EApp lϵ e1@EApp{} e2) -> EApp l (rw $ EApp lϵ e0 e1) e2
+ (EApp lϵ e1 e2) -> EApp l (EApp lϵ (rw e0) e1) e2
+ eRw -> EApp l (rw e0) eRw
+rw (Let l (n, e') e) = Let l (n, rw e') (rw e)
+rw (Def l (n, e') e) = Def l (n, rw e') (rw e)
+rw (LLet l (n, e') e) = LLet l (n, rw e') (rw e)
+rw (Tup l es) = Tup l (rw<$>es)
+rw (ALit l es) = ALit l (rw<$>es)
+rw (Lam l n e) = Lam l n (rw e)
+rw (Dfn l e) = Dfn l (rw e)
+rw (Parens l e) = Parens l (rw e)
+rw (Ann l e t) = Ann l (rw e) (rt t)
+rw (Cond l p e e') = Cond l (rw p) (rw e) (rw e')
+rw e = e
+
+rt :: T a -> T a
+rt (Arr sh (Arrow t t')) = Arrow (Arr sh (rt t)) (rt t')
+rt t = t
diff --git a/src/Prettyprinter/Ext.hs b/src/Prettyprinter/Ext.hs
new file mode 100644
index 000000000..dce167a88
--- /dev/null
+++ b/src/Prettyprinter/Ext.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Prettyprinter.Ext ( (<#>)
+ , prettyLines
+ , tupledBy
+ ) where
+
+import Data.Semigroup ((<>))
+import Prettyprinter (Doc, concatWith, encloseSep, flatAlt, group, hardline)
+
+infixr 6 <#>
+(<#>) :: Doc a -> Doc a -> Doc a
+(<#>) x y = x <> hardline <> y
+
+prettyLines :: [Doc ann] -> Doc ann
+prettyLines = concatWith (<#>)
+
+tupledBy :: Doc ann -> [Doc ann] -> Doc ann
+tupledBy sep = group . encloseSep (flatAlt "( " "(") (flatAlt " )" ")") sep
diff --git a/src/R.hs b/src/R.hs
new file mode 100644
index 000000000..9056dbd1e
--- /dev/null
+++ b/src/R.hs
@@ -0,0 +1,108 @@
+{-# LANGUAGE RankNTypes #-}
+
+module R ( Renames (..)
+ , HasRenames (..)
+ , rG
+ , rE
+ ) where
+
+import A
+import Control.Monad.State.Strict (MonadState, runState)
+import Data.Bifunctor (second)
+import Data.Functor (($>))
+import qualified Data.IntMap as IM
+import Lens.Micro (Lens')
+import Lens.Micro.Mtl (use, (%=), (.=))
+import Name
+import Ty.Clone
+import U
+
+data Renames = Renames { max_ :: Int, bound :: IM.IntMap Int }
+
+class HasRenames a where
+ rename :: Lens' a Renames
+
+instance HasRenames Renames where
+ rename = id
+
+maxLens :: Lens' Renames Int
+maxLens f s = fmap (\x -> s { max_ = x }) (f (max_ s))
+
+boundLens :: Lens' Renames (IM.IntMap Int)
+boundLens f s = fmap (\x -> s { bound = x }) (f (bound s))
+
+mapBound :: (IM.IntMap Int -> IM.IntMap Int) -> Renames -> Renames
+mapBound f (Renames m b) = Renames m (f b)
+
+setMax :: Int -> Renames -> Renames
+setMax i r = r { max_ = i }
+
+-- Make sure you don't have cycles in the renames map!
+replaceUnique :: (MonadState s m, HasRenames s) => U -> m U
+replaceUnique u@(U i) = do
+ rSt <- use (rename.boundLens)
+ case IM.lookup i rSt of
+ Nothing -> pure u
+ Just j -> replaceUnique (U j)
+
+replaceVar :: (MonadState s m, HasRenames s) => Name a -> m (Name a)
+replaceVar (Name n u l) = do
+ u' <- replaceUnique u
+ pure $ Name n u' l
+
+withRenames :: (HasRenames s, MonadState s m) => (Renames -> Renames) -> m a -> m a
+withRenames modSt act = do
+ preSt <- use rename
+ rename %= modSt
+ res <- act
+ postMax <- use (rename.maxLens)
+ rename .= setMax postMax preSt
+ pure res
+
+withName :: (HasRenames s, MonadState s m)
+ => Name a
+ -> m (Name a, Renames -> Renames)
+withName (Name t (U i) l) = do
+ m <- use (rename.maxLens)
+ let newUniq = m+1
+ rename.maxLens .= newUniq
+ pure (Name t (U newUniq) l, mapBound (IM.insert i (m+1)))
+
+-- globally unique
+rG :: Int -> E a -> (E a, Int)
+rG i = second max_ . flip runState (Renames i IM.empty) . rE
+
+{-# INLINABLE liftR #-}
+liftR :: (HasRenames s, MonadState s m) => T a -> m (T a)
+liftR t = do
+ i <- use (rename.maxLens)
+ let (u,t',_) = cloneTClosed i t
+ (rename.maxLens .= u) $> t'
+
+{-# INLINABLE rE #-}
+rE :: (HasRenames s, MonadState s m) => E a -> m (E a)
+rE (Lam l n e) = do
+ (n', modR) <- withName n
+ Lam l n' <$> withRenames modR (rE e)
+rE (Let l (n, eϵ) e) = do
+ eϵ' <- rE eϵ
+ (n', modR) <- withName n
+ Let l (n', eϵ') <$> withRenames modR (rE e)
+rE (Def l (n, eϵ) e) = do
+ eϵ' <- rE eϵ
+ (n', modR) <- withName n
+ Def l (n', eϵ') <$> withRenames modR (rE e)
+rE (LLet l (n, eϵ) e) = do
+ eϵ' <- rE eϵ
+ (n', modR) <- withName n
+ LLet l (n', eϵ') <$> withRenames modR (rE e)
+rE e@Builtin{} = pure e
+rE e@FLit{} = pure e
+rE e@ILit{} = pure e
+rE e@BLit{} = pure e
+rE (ALit l es) = ALit l <$> traverse rE es
+rE (Tup l es) = Tup l <$> traverse rE es
+rE (EApp l e e') = EApp l <$> rE e <*> rE e'
+rE (Cond l e e' e'') = Cond l <$> rE e <*> rE e' <*> rE e''
+rE (Var l n) = Var l <$> replaceVar n
+rE (Ann l e t) = Ann l <$> rE e <*> liftR t
diff --git a/src/R/Dfn.hs b/src/R/Dfn.hs
new file mode 100644
index 000000000..7429dd859
--- /dev/null
+++ b/src/R/Dfn.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module R.Dfn ( dedfn ) where
+
+import A
+import Control.Monad.State.Strict (get, modify)
+import qualified Data.Text as T
+import Name
+import R.M
+import U
+
+dummyName :: T.Text -> RM (a -> Name a)
+dummyName n = do
+ st <- get
+ Name n (U$st+1) <$ modify (+1)
+
+dedfn :: Int -> E a -> (E a, Int)
+dedfn i = runR i . dedfnM
+
+-- bottom-up
+dedfnM :: E a -> RM (E a)
+dedfnM e@ILit{} = pure e
+dedfnM e@FLit{} = pure e
+dedfnM e@BLit{} = pure e
+dedfnM e@ALit{} = pure e
+dedfnM e@Var{} = pure e
+dedfnM e@Builtin{} = pure e
+dedfnM e@ResVar{} = pure e
+dedfnM (Ann l e t) = Ann l <$> dedfnM e <*> pure t
+dedfnM (ALit l es) = ALit l <$> traverse dedfnM es
+dedfnM (Tup l es) = Tup l <$> traverse dedfnM es
+dedfnM (EApp l e e') = EApp l <$> dedfnM e <*> dedfnM e'
+dedfnM (Cond l e e' e'') = Cond l <$> dedfnM e <*> dedfnM e' <*> dedfnM e''
+dedfnM (Lam l n e) = Lam l n <$> dedfnM e
+dedfnM (Let l (n, e) eBody) = do
+ e' <- dedfnM e
+ Let l (n, e') <$> dedfnM eBody
+dedfnM (Def l (n, e) eBody) = do
+ e' <- dedfnM e
+ Def l (n, e') <$> dedfnM eBody
+dedfnM (LLet l (n, e) eBody) = do
+ e' <- dedfnM e
+ LLet l (n, e') <$> dedfnM eBody
+dedfnM (Dfn l e) = do
+ e' <- dedfnM e
+ x <- dummyName "x" -- TODO: do we need uniques? could rename it later
+ y <- dummyName "y"
+ let (eDone, hasY) = replaceXY x y e'
+ pure $ if hasY
+ then Lam l (x l) (Lam l (y l) eDone)
+ else Lam l (x l) eDone
+dedfnM (Parens _ e) = dedfnM e
+
+-- this approach is criminally inefficient
+replaceXY :: (a -> Name a) -- ^ x
+ -> (a -> Name a) -- ^ y
+ -> E a -> (E a, Bool) -- True if it has 'y'
+replaceXY _ y (ResVar l Y) = (Var l (y l), True)
+replaceXY x _ (ResVar l X) = (Var l (x l), False)
+replaceXY _ _ e@FLit{} = (e, False)
+replaceXY _ _ e@ILit{} = (e, False)
+replaceXY _ _ e@BLit{} = (e, False)
+replaceXY _ _ e@Var{} = (e, False)
+replaceXY _ _ e@Builtin{} = (e, False)
+replaceXY x y (Ann l e t) =
+ let (e', b) = replaceXY x y e
+ in (Ann l e' t, b)
+replaceXY x y (Lam l n e) =
+ let (e', b) = replaceXY x y e
+ in (Lam l n e', b)
+replaceXY x y (EApp l e e') =
+ let (eR, b) = replaceXY x y e
+ (eR', b') = replaceXY x y e'
+ in (EApp l eR eR', b || b')
+replaceXY x y (Cond l p e e') =
+ let (pR, b0) = replaceXY x y p
+ (eR, b1) = replaceXY x y e
+ (eR', b2) = replaceXY x y e'
+ in (Cond l pR eR eR', b0 || b1 || b2)
+replaceXY x y (Let l (n, e) e') =
+ let (eR, b) = replaceXY x y e
+ (eR', b') = replaceXY x y e'
+ in (Let l (n, eR) eR', b || b')
+replaceXY x y (LLet l (n, e) e') =
+ let (eR, b) = replaceXY x y e
+ (eR', b') = replaceXY x y e'
+ in (LLet l (n, eR) eR', b || b')
+replaceXY x y (Def l (n, e) e') =
+ let (eR, b) = replaceXY x y e
+ (eR', b') = replaceXY x y e'
+ in (Def l (n, eR) eR', b || b')
+replaceXY x y (ALit l es) =
+ let (esR, bs) = unzip (fmap (replaceXY x y) es)
+ in (ALit l esR, or bs)
+replaceXY x y (Tup l es) =
+ let (esR, bs) = unzip (fmap (replaceXY x y) es)
+ in (Tup l esR, or bs)
diff --git a/src/R/M.hs b/src/R/M.hs
new file mode 100644
index 000000000..1c9c6a5ff
--- /dev/null
+++ b/src/R/M.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module R.M ( RM
+ , runR
+ , nextN
+ , nextU
+ ) where
+
+import Control.Monad.State.Strict (State, get, modify, runState)
+import Data.Functor (($>))
+import qualified Data.Text as T
+import Name
+import U
+
+type RM = State Int
+
+nextU :: T.Text -> a -> RM (Name a)
+nextU n l = do { i <- get; modify (+1) $> Name n (U$i+1) l }
+
+nextN :: a -> RM (Name a)
+nextN = nextU "x"
+
+runR :: Int -> RM x -> (x, Int)
+runR = flip runState
diff --git a/src/Sys/DL.chs b/src/Sys/DL.chs
new file mode 100644
index 000000000..1408e787d
--- /dev/null
+++ b/src/Sys/DL.chs
@@ -0,0 +1,22 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Sys.DL ( libc, mem' ) where
+
+import Data.Functor (($>))
+import Foreign.C.Types (CSize)
+import Foreign.Ptr (FunPtr, IntPtr (..), Ptr, castFunPtrToPtr, ptrToIntPtr)
+import System.Posix.DynamicLinker.ByteString (DL, RTLDFlags (RTLD_LAZY), dlclose, dlopen, dlsym)
+
+#include
+
+mem' :: IO (Int, Int)
+mem' = do {(m,f) <- mem; pure (g m, g f)}
+ where g = (\(IntPtr i) -> i) . ptrToIntPtr . castFunPtrToPtr
+
+mem :: IO (FunPtr (CSize -> IO (Ptr a)), FunPtr (Ptr a -> IO ()))
+mem = do {c <- libc; m <- dlsym c "malloc"; f <- dlsym c "free"; dlclose c$>(m, f)}
+
+ll p = dlopen p [RTLD_LAZY]
+
+libc :: IO DL
+libc = ll {# const LIBC_SO #}
diff --git a/src/Ty.hs b/src/Ty.hs
new file mode 100644
index 000000000..ae7674045
--- /dev/null
+++ b/src/Ty.hs
@@ -0,0 +1,629 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Ty ( TyE
+ , tyClosed
+ , match
+ -- * Substitutions
+ , Subst
+ , aT
+ ) where
+
+import A
+import Control.DeepSeq (NFData)
+import Control.Exception (Exception, throw)
+import Control.Monad (zipWithM)
+import Control.Monad.Except (liftEither, throwError)
+import Control.Monad.State.Strict (StateT (runStateT), gets, modify)
+import Data.Bifunctor (first, second)
+import Data.Foldable (traverse_)
+import Data.Functor (void, ($>))
+import qualified Data.IntMap as IM
+import qualified Data.IntSet as IS
+import Data.Semigroup (Semigroup (..))
+import qualified Data.Text as T
+import Data.Typeable (Typeable)
+import GHC.Generics (Generic)
+import Name
+import Prettyprinter (Doc, Pretty (..), hardline, indent, squotes, vsep, (<+>))
+import Prettyprinter.Ext
+import Ty.Clone
+import U
+
+data TySt a = TySt { maxU :: !Int
+ , staEnv :: IM.IntMap (T ())
+ , polyEnv :: IM.IntMap (T ())
+ , varConstr :: IM.IntMap (C, a)
+ }
+
+data Subst a = Subst { tySubst :: IM.IntMap (T a)
+ , iSubst :: IM.IntMap (I a) -- ^ Index variables
+ , sSubst :: IM.IntMap (Sh a) -- ^ Shape variables
+ } deriving (Functor)
+
+data TyE a = IllScoped a (Name a)
+ | UnificationFailed a (E a) (T a) (T a)
+ | UnificationIFailed a (I a) (I a)
+ | UnificationShFailed a (Sh a) (Sh a)
+ | OccursCheck a (T a) (T a)
+ | ExistentialArg (T ())
+ | MatchFailed (T ()) (T ())
+ | MatchShFailed (Sh ()) (Sh ())
+ | Doesn'tSatisfy a (T a) C
+ deriving (Generic)
+
+instance Semigroup (Subst a) where
+ (<>) (Subst t i s) (Subst t0 i0 s0) = Subst (t<>t0) (i<>i0) (s<>s0)
+
+instance Monoid (Subst a) where
+ mempty = Subst IM.empty IM.empty IM.empty
+ mappend = (<>)
+
+instance NFData a => NFData (TyE a) where
+
+instance Pretty a => Pretty (TyE a) where
+ pretty (IllScoped l n) = pretty l <> ":" <+> squotes (pretty n) <+> "is not in scope."
+ pretty (UnificationFailed l e ty ty') = pretty l <> ":" <+> "could not unify" <+> squotes (pretty ty) <+> "with" <+> squotes (pretty ty') <+> "in expression" <+> squotes (pretty e)
+ pretty (UnificationShFailed l sh sh') = pretty l <> ":" <+> "could not unify shape" <+> squotes (pretty sh) <+> "with" <+> squotes (pretty sh')
+ pretty (UnificationIFailed l ix ix') = pretty l <> ":" <+> "could not unify index" <+> squotes (pretty ix) <+> "with" <+> squotes (pretty ix')
+ pretty (OccursCheck l ty ty') = pretty l <> ":" <+> "occurs check failed when unifying" <+> squotes (pretty ty) <+> "and" <+> squotes (pretty ty')
+ pretty (ExistentialArg ty) = "Existential occurs as an argument in" <+> squotes (pretty ty)
+ pretty (MatchFailed t t') = "Failed to match" <+> squotes (pretty t) <+> "against type" <+> squotes (pretty t')
+ pretty (MatchShFailed sh sh') = "Failed to match" <+> squotes (pretty sh) <+> "against shape" <+> squotes (pretty sh')
+ pretty (Doesn'tSatisfy l ty c) = pretty l <+> squotes (pretty ty) <+> "is not a member of class" <+> pretty c
+
+instance (Pretty a) => Show (TyE a) where
+ show = show . pretty
+
+instance (Pretty a, Typeable a) => Exception (TyE a) where
+
+instance Pretty (Subst a) where
+ pretty (Subst ty i sh) =
+ "type:" <#*> prettyDumpBinds ty
+ <#> "index:" <#*> prettyDumpBinds i
+ <#> "shape:" <#*> prettyDumpBinds sh
+
+instance Show (Subst a) where show = show . pretty
+
+(<#*>) :: Doc a -> Doc a -> Doc a
+(<#*>) x y = x <> hardline <> indent 2 y
+
+prettyBind :: (Pretty c, Pretty b) => (c, b) -> Doc a
+prettyBind (i, j) = pretty i <+> "→" <+> pretty j
+
+prettyDumpBinds :: Pretty b => IM.IntMap b -> Doc a
+prettyDumpBinds b = vsep (prettyBind <$> IM.toList b)
+
+type TyM a = StateT (TySt a) (Either (TyE a))
+
+mI :: I a -> I a -> Either (TyE b) (Subst a)
+mI (Ix _ i) (Ix _ j) | i == j = Right mempty
+mI (IVar _ (Name _ (U i) _)) ix = Right $ Subst IM.empty (IM.singleton i ix) IM.empty
+mI (IEVar _ n) (IEVar _ n') | n == n' = Right mempty
+mI (StaPlus _ i j) (StaPlus _ i' j') = (<>) <$> mI i i' <*> mI j j'
+
+mSh :: Sh a -> Sh a -> Either (TyE b) (Subst a)
+mSh (SVar (Name _ (U i) _)) sh = Right $ Subst IM.empty IM.empty (IM.singleton i sh)
+mSh Nil Nil = Right mempty
+mSh (IxA i) (IxA i') = mI i i'
+mSh (Cons i sh) (Cons i' sh') = (<>) <$> mI i i' <*> mSh sh sh'
+mSh sh sh' = Left $ MatchShFailed (void sh) (void sh')
+
+match :: T a -> T a -> Subst a
+match t t' = either (throw :: TyE () -> Subst a) id (maM t t')
+
+maM :: T a -> T a -> Either (TyE b) (Subst a)
+maM I I = Right mempty
+maM F F = Right mempty
+maM B B = Right mempty
+maM (TVar n) (TVar n') | n == n' = Right mempty
+maM (TVar (Name _ (U i) _)) t = Right $ Subst (IM.singleton i t) IM.empty IM.empty
+maM (Arrow t0 t1) (Arrow t0' t1') = (<>) <$> maM t0 t0' <*> maM t1 t1'
+maM (Arr sh t) (Arr sh' t') = (<>) <$> mSh sh sh' <*> maM t t'
+maM (P ts) (P ts') = mconcat <$> zipWithM maM ts ts'
+maM t t' = Left $ MatchFailed (void t) (void t')
+
+shSubst :: Subst a -> Sh a -> Sh a
+shSubst s (IxA i) = IxA (iSubst s !> i)
+shSubst _ Nil = Nil
+shSubst s (Cons i sh) = Cons (iSubst s !> i) (shSubst s sh)
+shSubst s@(Subst ts is ss) sh'@(SVar (Name _ (U u) _)) =
+ case IM.lookup u ss of
+ Just sh''@SVar{} -> shSubst (Subst ts is (IM.delete u ss)) sh''
+ Just sh -> shSubst s sh
+ Nothing -> sh'
+
+infixr 4 !>
+(!>) :: IM.IntMap (I a) -> I a -> I a
+(!>) ixes ix'@(IVar _ (Name _ (U u) _)) =
+ case IM.lookup u ixes of
+ Just ix@IVar{} -> IM.delete u ixes !> ix
+ Just ix -> ixes !>ix
+ Nothing -> ix'
+(!>) ixes (StaPlus l ix ix') = StaPlus l (ixes !> ix) (ixes !> ix')
+(!>) _ ix@Ix{} = ix
+(!>) _ ix@IEVar{} = ix
+
+aT :: Subst a -> T a -> T a
+aT s@(Subst ts is ss) ty'@(TVar n) =
+ let u = unU $ unique n in
+ case IM.lookup u ts of
+ Just ty@TVar{} -> aT (Subst (IM.delete u ts) is ss) ty
+ Just ty -> aT s ty
+ Nothing -> ty'
+-- TODO: convert Arr Nil a to a here?
+aT s (Arr sh ty) = Arr (shSubst s sh) (aT s ty)
+aT s (Arrow t₁ t₂) = Arrow (aT s t₁) (aT s t₂)
+aT s (P ts) = P (aT s <$> ts)
+aT _ ty = ty
+
+runTyM :: Int -> TyM a b -> Either (TyE a) (b, Int)
+runTyM i = fmap (second maxU) . flip runStateT (TySt i IM.empty IM.empty IM.empty)
+
+mapMaxU :: (Int -> Int) -> TySt a -> TySt a
+mapMaxU f (TySt u l v vcs) = TySt (f u) l v vcs
+
+setMaxU :: Int -> TySt a -> TySt a
+setMaxU i (TySt _ l v vcs) = TySt i l v vcs
+
+addStaEnv :: Name a -> T () -> TySt a -> TySt a
+addStaEnv (Name _ (U i) _) t (TySt u l v vcs) = TySt u (IM.insert i t l) v vcs
+
+addPolyEnv :: Name a -> T () -> TySt a -> TySt a
+addPolyEnv (Name _ (U i) _) t (TySt u l v vcs) = TySt u l (IM.insert i t v) vcs
+
+addVarConstrI :: Int -> a -> C -> TySt a -> TySt a
+addVarConstrI i ann c (TySt u l v vcs) = TySt u l v (IM.insert i (c, ann) vcs)
+
+addVarConstr :: TyName a -> a -> C -> TySt a -> TySt a
+addVarConstr tn = addVarConstrI (unU$unique tn)
+
+pushVarConstraint :: TyName a -> a -> C -> TyM a ()
+pushVarConstraint tn l c = modify (addVarConstr tn l c)
+
+freshName :: T.Text -> b -> TyM a (Name b)
+freshName n l = do
+ st <- gets maxU
+ Name n (U$st+1) l
+ <$ modify (mapMaxU (+1))
+
+mapTySubst f (Subst t i sh) = Subst (f t) i sh
+
+mapShSubst f (Subst t i sh) = Subst t i (f sh)
+
+mguIPrep :: IM.IntMap (I a) -> I a -> I a -> Either (TyE a) (IM.IntMap (I a))
+mguIPrep is i0 i1 =
+ let i0' = is !> i0
+ i1' = is !> i1
+ in mguI is i0' i1'
+
+mguI :: IM.IntMap (I a) -> I a -> I a -> Either (TyE a) (IM.IntMap (I a))
+mguI inp (Ix _ i) (Ix _ j) | i == j = Right inp
+mguI inp ix0@(IEVar l i) ix1@(IEVar _ j) | i == j = Right inp
+ | otherwise = Left $ UnificationIFailed l ix0 ix1
+mguI inp (IVar _ i) (IVar _ j) | i == j = Right inp
+mguI inp (IVar _ (Name _ (U i) _)) ix = Right $ IM.insert i ix inp
+mguI inp ix (IVar _ (Name _ (U i) _)) = Right $ IM.insert i ix inp
+
+mgShPrep :: a -> Subst a -> Sh a -> Sh a -> Either (TyE a) (Subst a)
+mgShPrep l s sh0 sh1 =
+ let sh0' = shSubst s sh0
+ sh1' = shSubst s sh1
+ in mgSh l s sh0' sh1'
+
+mgSh :: a -> Subst a -> Sh a -> Sh a -> Either (TyE a) (Subst a)
+mgSh _ inp Nil Nil = Right inp
+mgSh _ inp (IxA i) (IxA i') = do {iSubst' <- mguIPrep (iSubst inp) i i' ; pure inp { iSubst = iSubst' }}
+mgSh l inp (Cons i sh) (Cons i' sh') = do
+ sI <- mguIPrep (iSubst inp) i i'
+ mgShPrep l (inp { iSubst = sI }) sh sh'
+mgSh _ inp (SVar sh) (SVar sh') | sh == sh' = Right inp
+mgSh _ inp (SVar (Name _ (U i) _)) sh = Right$ mapShSubst (IM.insert i sh) inp
+mgSh _ inp sh (SVar (Name _ (U i) _)) = Right$ mapShSubst (IM.insert i sh) inp
+mgSh l _ sh@Nil sh'@Cons{} = Left $ UnificationShFailed l sh sh'
+
+mguPrep :: (a, E a) -> Subst a -> T a -> T a -> Either (TyE a) (Subst a)
+mguPrep l s t0 t1 =
+ let t0' = aT s t0
+ t1' = aT s t1
+ in mgu l s t0' t1'
+
+occ :: T a -> IS.IntSet
+occ (TVar (Name _ (U i) _)) = IS.singleton i
+occ (Arrow t t') = occ t <> occ t'
+occ (Arr _ a) = occ a -- shouldn't need shape?
+occ I = IS.empty
+occ F = IS.empty
+occ B = IS.empty
+
+mgu :: (a, E a) -> Subst a -> T a -> T a -> Either (TyE a) (Subst a)
+mgu l s (Arrow t0 t1) (Arrow t0' t1') = do
+ s0 <- mguPrep l s t0 t0'
+ mguPrep l s0 t1 t1'
+mgu _ s I I = Right s
+mgu _ s F F = Right s
+mgu _ s B B = Right s
+mgu l s (Arr Nil t) t' = mguPrep l s t t'
+mgu l s t (Arr Nil t') = mguPrep l s t t'
+mgu _ s (TVar n) (TVar n') | n == n' = Right s
+mgu (l, _) s t'@(TVar (Name _ (U i) _)) t | i `IS.member` occ t = Left$ OccursCheck l t' t
+ | otherwise = Right $ mapTySubst (IM.insert i t) s
+mgu (l, _) s t t'@(TVar (Name _ (U i) _)) | i `IS.member` occ t = Left$ OccursCheck l t' t
+ | otherwise = Right $ mapTySubst (IM.insert i t) s
+mgu (l, e) _ t0@Arrow{} t1 = Left $ UnificationFailed l e t0 t1
+mgu (l, e) _ t0 t1@Arrow{} = Left $ UnificationFailed l e t0 t1
+-- TODO: Arr 1 (Arr 1 a) ~ Arr 2 a
+mgu l s (Arr sh t) (Arr sh' t') = do
+ s0 <- mguPrep l s t t'
+ mgShPrep (fst l) s0 sh sh'
+mgu (l, e) _ F I = Left$ UnificationFailed l e F I
+mgu (l, e) _ I F = Left$ UnificationFailed l e I F
+mgu l s (Arr (SVar (Name _ (U i) _)) t) F = mapShSubst (IM.insert i Nil) <$> mguPrep l s t F
+mgu l s (Arr (SVar (Name _ (U i) _)) t) I = mapShSubst (IM.insert i Nil) <$> mguPrep l s t I
+mgu l s F (Arr (SVar (Name _ (U i) _)) t) = mapShSubst (IM.insert i Nil) <$> mguPrep l s F t
+mgu l s I (Arr (SVar (Name _ (U i) _)) t) = mapShSubst (IM.insert i Nil) <$> mguPrep l s I t
+
+vx i = Cons i Nil
+
+tyNumBinOp :: a -> TyM a (T (), Subst a)
+tyNumBinOp l = do
+ n <- freshName "a" l
+ let n' = TVar (void n)
+ pushVarConstraint n l IsNum
+ pure (Arrow n' (Arrow n' n'), mempty)
+
+mm :: a -> TyM a (T (), Subst a)
+mm l = do
+ n <- freshName "o" l
+ let n' = TVar (void n)
+ pushVarConstraint n l IsOrd
+ pure (Arrow n' (Arrow n' n'), mempty)
+
+sel :: [Int] -> Sh a -> Sh a
+sel axes sh = roll Nil (fmap snd (filter ((`elem` axes) . fst) (zip [1..] unrolled))) where
+ (unrolled, _) = unroll sh
+
+tydrop :: Int -> Sh a -> Sh a
+tydrop 0 sh = sh
+tydrop n (_ `Cons` sh) = sh
+
+del :: [Int] -> Sh a -> Sh a
+del axes sh = roll t (fmap snd (filter ((`notElem` axes) . fst) (zip [1..] unrolled))) where
+ (unrolled, t) = unroll sh
+
+trim :: Sh a -> Sh a
+trim = roll Nil . fst . unroll
+
+unroll (Cons i shϵ) = first (i :) $ unroll shϵ
+unroll s = ([], s)
+
+roll :: Sh a -> [I a] -> Sh a
+roll = foldr Cons
+
+tyB :: a -> Builtin -> TyM a (T (), Subst a)
+tyB _ Floor = pure (Arrow F I, mempty)
+tyB _ ItoF = pure (Arrow I F, mempty)
+tyB _ Re = do
+ a <- TVar <$> freshName "a" ()
+ n <- IEVar () <$> freshName "n" ()
+ pure (Arrow I (Arrow a (Arr (n `Cons` Nil) a)), mempty)
+tyB _ FRange = do
+ n <- IEVar () <$> freshName "n" ()
+ pure (Arrow F (Arrow F (Arrow I (Arr (n `Cons` Nil) F))), mempty)
+tyB _ Fib = do
+ n <- IEVar () <$> freshName "n" ()
+ a <- freshName "a" ()
+ let a' = TVar a
+ arrTy = Arr (n `Cons` Nil) a'
+ pure (Arrow a' (Arrow a' (Arrow (Arrow a' (Arrow a' a')) (Arrow I arrTy))), mempty)
+tyB _ IRange = do
+ n <- IEVar () <$> freshName "n" ()
+ pure (Arrow I (Arrow I (Arrow I (Arr (n `Cons` Nil) I))), mempty)
+tyB l Plus = tyNumBinOp l
+tyB l Minus = tyNumBinOp l
+tyB l Times = tyNumBinOp l
+tyB l Exp = tyNumBinOp l
+tyB l Min = mm l
+tyB l Max = mm l
+tyB l IntExp = do
+ n <- freshName "a" l
+ let n' = TVar (void n)
+ pushVarConstraint n l IsNum
+ pure (Arrow n' (Arrow I n'), mempty)
+tyB l Neg = do
+ n <- freshName "a" l
+ let n' = TVar (void n)
+ pushVarConstraint n l IsNum
+ pure (Arrow n' n', mempty)
+tyB _ Sqrt = pure (Arrow F F, mempty)
+tyB _ Log = pure (Arrow F F, mempty)
+tyB _ Div = pure (Arrow F (Arrow F F), mempty)
+tyB _ Concat = do
+ i <- freshName "i" ()
+ j <- freshName "j" ()
+ n <- freshName "a" ()
+ let i' = IVar () i
+ j' = IVar () j
+ n' = TVar n
+ pure (Arrow (Arr (vx i') n') (Arrow (Arr (vx j') n') (Arr (vx $ StaPlus () i' j') n')), mempty)
+tyB l Scan = do
+ a <- TVar <$> freshName "a" ()
+ b <- TVar <$> freshName "b" ()
+ i <- IVar () <$> freshName "i" ()
+ sh <- SVar <$> freshName "sh" ()
+ let opTy = Arrow b (Arrow a b)
+ arrTy = Arr (Cons i sh)
+ pure (Arrow opTy (Arrow b (Arrow (arrTy a) (arrTy b))), mempty)
+tyB l (DI n) = tyB l (Conv [n])
+tyB _ (Conv ns) = do
+ sh <- SVar <$> freshName "sh" ()
+ is <- zipWithM (\_ t -> IVar () <$> freshName (T.singleton t) ()) ns ['i'..]
+ a <- TVar <$> freshName "a" ()
+ b <- TVar <$> freshName "b" ()
+ let nx = Ix () <$> ns
+ opTy = Arrow (Arr (foldr Cons sh nx) a) b
+ t = Arrow (Arr (foldr Cons sh (zipWith (StaPlus ()) is nx)) a) (Arr (foldr Cons Nil is) b)
+ pure (Arrow opTy t, mempty)
+tyB _ Succ = do
+ sh <- SVar <$> freshName "sh" ()
+ i <- IVar () <$> freshName "i" ()
+ a <- TVar <$> freshName "a" ()
+ b <- TVar <$> freshName "b" ()
+ let opTy = Arrow a (Arrow a b)
+ pure (Arrow opTy (Arrow (Arr (StaPlus () i (Ix () 1) `Cons` sh) a) (Arr (i `Cons` sh) b)), mempty)
+tyB l (Map n) = tyB l (MapN 1 n)
+tyB _ (MapN a d) = do
+ -- for n the shape is i1,i2,...in `Cons` Nil (this forces it to have
+ -- enough indices)
+ ixList <- zipWithM (\_ c -> freshName (T.singleton c) ()) [0..d] ['i'..]
+ as <- traverse (\_ -> freshName "a" ()) [1..a]
+ b <- freshName "b" ()
+ let arrSh = foldr Cons Nil (IVar () <$> tail ixList)
+ as' = TVar <$> as
+ b' = TVar b
+ fTy = foldr Arrow b' as'
+ codArrTys = Arr arrSh <$> as'
+ gTy = foldr Arrow (Arr arrSh b') codArrTys
+ -- depends on Arr nil a = a, Arr (i+j) a = Arr i (Arr j sh) etc.
+ pure (Arrow fTy gTy, mempty)
+tyB l (Rank as) = do
+ let ixN n = zipWithM (\_ c -> freshName (T.singleton c) ()) [1..n] ['i'..]
+ shs <- traverse (\(i,ax) -> do {is <- ixN (maybe i maximum ax); sh <- SVar <$> freshName "sh" (); pure $ foldr Cons sh (IVar () <$> is)}) as
+ vs <- zipWithM (\_ c -> TVar <$> freshName (T.singleton c) ()) as ['a'..]
+ codSh <- freshName "sh" ()
+ cod <- TVar <$> freshName "c" ()
+ let mArrs = zipWith Arr shs vs
+ codTy = Arr (SVar codSh) cod
+ fTy = foldr Arrow cod $ zipWith3 (\ax sh t -> case ax of {(_,Nothing) -> Arr (trim sh) t;(_,Just axs) -> Arr (sel axs sh) t}) as shs vs
+ rTy = foldr Arrow codTy mArrs
+ shsU = zipWith (\ax sh -> case ax of {(n,Nothing) -> tydrop n sh;(_,Just axs) -> del axs sh}) as shs
+ shUHere sh sh' = liftEither $ mgShPrep l mempty (sh$>l) (sh'$>l)
+ s <- zipWithM shUHere shsU (tail shsU++[SVar codSh])
+ pure (Arrow fTy rTy, mconcat s)
+tyB _ (Fold n) = do
+ ixList <- zipWithM (\_ c -> freshName (T.singleton c) ()) [1..n] ['i'..]
+ shV <- freshName "sh" ()
+ a <- freshName "a" ()
+ let sh = foldr Cons (SVar shV) (IVar () <$> ixList)
+ a' = TVar a
+ pure (Arrow (Arrow a' (Arrow a' a')) (Arrow a' (Arrow (Arr sh a') (Arr (SVar shV) a'))), mempty)
+tyB _ Size = do
+ shV <- SVar <$> freshName "sh" ()
+ a <- TVar <$> freshName "a" ()
+ pure (Arrow (Arr shV a) I, mempty)
+tyB _ Gen = do
+ a <- TVar <$> freshName "a" ()
+ n <- IEVar () <$> freshName "n" ()
+ let arrTy = Arr (n `Cons` Nil) a
+ pure (Arrow a (Arrow (Arrow a (Arrow a a)) (Arrow I arrTy)), mempty)
+
+liftCloneTy :: T b -> TyM a (T b, IM.IntMap Int)
+liftCloneTy t = do
+ i<- gets maxU
+ let (u,t',vs) = cloneTClosed i t
+ modify (setMaxU u) $> (t',vs)
+
+cloneWithConstraints :: T b -> TyM a (T b)
+cloneWithConstraints t = do
+ (t', vs) <- liftCloneTy t
+ traverse_ (\(k,v) -> do
+ cst <- gets varConstr
+ case IM.lookup k cst of
+ Just (c,l) -> modify (addVarConstrI v l c)
+ Nothing -> pure ())
+ (IM.toList vs)
+ pure t'
+
+rwArr :: T a -> T a
+rwArr (Arr Nil t) = rwArr t
+rwArr (Arr sh t) = Arr sh (rwArr t) -- TODO: Arr i (Arr j a) -> Arr (i+j) a
+rwArr (Arrow t t') = Arrow (rwArr t) (rwArr t')
+rwArr I = I
+rwArr B = B
+rwArr F = F
+rwArr t@TVar{} = t
+rwArr (P ts) = P (rwArr<$>ts)
+
+hasEI :: I a -> Bool
+hasEI IEVar{} = True
+hasEI (StaPlus _ ix ix') = hasEI ix || hasEI ix'
+hasEI _ = False
+
+hasESh :: Sh a -> Bool
+hasESh (IxA i) = hasEI i
+hasESh (Cons i sh) = hasEI i || hasESh sh
+hasESh _ = False
+
+hasE :: T a -> Bool
+hasE (Arrow t t'@Arrow{}) = hasE t || hasE t'
+hasE (Arr sh t) = hasESh sh || hasE t
+hasE _ = False
+
+-- {-# SCC chkE #-}
+chkE :: T () -> Either (TyE a) ()
+chkE t@Arrow{} | hasE t = Left (ExistentialArg t)
+chkE _ = Right ()
+
+checkTy :: T a -> (C, a) -> Either (TyE a) (Maybe (Name a, C))
+checkTy (TVar n) (c, _) = pure $ Just(n, c)
+checkTy I (IsNum, _) = pure Nothing
+checkTy F (IsNum, _) = pure Nothing
+checkTy I (IsOrd, _) = pure Nothing
+checkTy F (IsOrd, _) = pure Nothing
+checkTy t (c@IsNum, l) = Left$ Doesn'tSatisfy l t c
+
+substI :: Subst a -> Int -> Maybe (T a)
+substI s@(Subst ts is sh) i =
+ case IM.lookup i ts of
+ Just ty@TVar{} -> Just $ aT (Subst (IM.delete i ts) is sh) ty
+ Just ty -> Just $ aT s ty
+ Nothing -> Nothing
+
+checkClass :: Subst a -> Int -> (C, a) -> Either (TyE a) (Maybe (Name a, C))
+checkClass s i c =
+ case substI s i of
+ Just ty -> checkTy (rwArr ty) c
+ Nothing -> pure Nothing
+
+tyClosed :: Int -> E a -> Either (TyE a) (E (T ()), Int)
+tyClosed u e = do
+ ((e', s), i) <- runTyM u (do { res@(_, s) <- tyE e ; cvs <- gets varConstr ; liftEither $ traverse_ (uncurry$checkClass s) (IM.toList cvs) ; pure res })
+ let eS = {-# SCC "applySubst" #-} fmap (rwArr.aT (void s)) e'
+ eS' <- do {(e'', s') <- {-# SCC "match" #-} rAn eS; pure (fmap (aT s') e'') }
+ chkE (eAnn eS') $> (eS', i)
+
+rAn :: E (T ()) -> Either (TyE a) (E (T ()), Subst ())
+rAn (Ann _ e t) = do
+ s <- maM (eAnn e) t
+ pure (e, s)
+rAn (EApp t e0 e1) = do
+ (e0', s0) <- rAn e0
+ (e1', s1) <- rAn e1
+ pure (EApp t e0' e1', s0<>s1)
+rAn e@Builtin{} = pure (e, mempty)
+rAn e@FLit{} = pure (e, mempty)
+rAn e@ILit{} = pure (e, mempty)
+rAn e@Var{} = pure (e, mempty)
+rAn (Let t (n, e0) e1) = do
+ (e0', s) <- rAn e0
+ (e1', s') <- rAn e1
+ pure (Let t (n, e0') e1', s<>s')
+rAn (LLet t (n, e0) e1) = do
+ (e0', s) <- rAn e0
+ (e1', s') <- rAn e1
+ pure (LLet t (n, e0') e1', s<>s')
+rAn (Def t (n, e0) e1) = do
+ (e0', s) <- rAn e0
+ (e1', s') <- rAn e1
+ pure (Def t (n, e0') e1', s<>s')
+rAn (Lam t n e) = do
+ (e', s) <- rAn e
+ pure (Lam t n e', s)
+rAn (ALit t es) = do
+ (es', ss) <- unzip <$> traverse rAn es
+ pure (ALit t es', mconcat ss)
+rAn (Tup t es) = do
+ (es', ss) <- unzip <$> traverse rAn es
+ pure (Tup t es', mconcat ss)
+rAn (Cond t p e0 e1) = do
+ (p',sP) <- rAn p
+ (e0',s0) <- rAn e0
+ (e1',s1) <- rAn e1
+ pure (Cond t p' e0' e1', sP<>s0<>s1)
+
+-- TODO: check/dispatch constraints on type variables
+-- return all type variables mentioned thereto
+tyE :: E a -> TyM a (E (T ()), Subst a)
+tyE (EApp _ (Builtin _ Re) (ILit _ n)) = do
+ a <- TVar <$> freshName "a" ()
+ let arrTy = Arrow a (Arr (vx $ Ix () (fromInteger n)) a)
+ pure (EApp arrTy (Builtin (Arrow I arrTy) Re) (ILit I n), mempty)
+tyE (EApp _ (EApp _ (EApp _ (Builtin _ FRange) e0) e1) (ILit _ n)) = do
+ (e0',s0) <- tyE e0
+ (e1',s1) <- tyE e1
+ let tyE0 = eAnn e0'
+ tyE1 = eAnn e1'
+ arrTy = Arr (vx (Ix () (fromInteger n))) F
+ l0 = eAnn e0
+ l1 = eAnn e1
+ s0' <- liftEither $ mguPrep (l0,e0) (s0<>s1) F (eAnn e0' $> l0)
+ s1' <- liftEither $ mguPrep (l1,e1) s0' F (eAnn e1' $> l1)
+ pure (EApp arrTy (EApp (Arrow I arrTy) (EApp (Arrow tyE1 (Arrow I arrTy)) (Builtin (Arrow tyE0 (Arrow tyE1 (Arrow I arrTy))) FRange) e0') e1') (ILit I n), s1')
+tyE (EApp _ (EApp _ (EApp _ (Builtin _ IRange) (ILit _ b)) (ILit _ e)) (ILit _ s)) = do
+ let arrTy = Arr (vx (Ix () (fromInteger ((e-b+s) `div` s)))) I
+ pure (EApp arrTy (EApp (Arrow I arrTy) (EApp (Arrow I (Arrow I arrTy)) (Builtin (Arrow I (Arrow I (Arrow I arrTy))) IRange) (ILit I b)) (ILit I e)) (ILit I s), mempty)
+tyE (FLit _ x) = pure (FLit F x, mempty)
+tyE (BLit _ x) = pure (BLit B x, mempty)
+tyE (ILit l m) = do
+ n <- freshName "a" l
+ pushVarConstraint n l IsNum
+ pure (ILit (TVar (void n)) m, mempty)
+tyE (Builtin l b) = do {(t,s) <- tyB l b ; pure (Builtin t b, s)}
+tyE (Lam _ nϵ e) = do
+ n <- TVar <$> freshName "a" ()
+ modify (addStaEnv nϵ n)
+ (e', s) <- tyE e
+ let lamTy = Arrow n (eAnn e')
+ pure (Lam lamTy (nϵ { loc = n }) e', s)
+tyE (Let _ (n, e') e) = do
+ (e'Res, s') <- tyE e'
+ let e'Ty = eAnn e'Res
+ modify (addStaEnv n (aT (void s') e'Ty))
+ (eRes, s) <- tyE e
+ pure (Let (eAnn eRes) (n { loc = e'Ty }, e'Res) eRes, s<>s')
+tyE (Def _ (n, e') e) = do
+ (e'Res, s') <- tyE e'
+ let e'Ty = eAnn e'Res
+ modify (addPolyEnv n (aT (void s') e'Ty))
+ (eRes, s) <- tyE e
+ pure (Def (eAnn eRes) (n { loc = e'Ty }, e'Res) eRes, s<>s')
+tyE (LLet _ (n, e') e) = do
+ (e'Res, s') <- tyE e'
+ let e'Ty = eAnn e'Res
+ modify (addStaEnv n (aT (void s') e'Ty))
+ (eRes, s) <- tyE e
+ pure (LLet (eAnn eRes) (n { loc = e'Ty }, e'Res) eRes, s<>s')
+tyE e@(ALit l es) = do
+ a <- TVar <$> freshName "a" ()
+ (es', ss) <- unzip <$> traverse tyE es
+ let eTys = a : fmap eAnn es'
+ uHere t t' = liftEither $ mguPrep (l,e) (mconcat ss) (t$>l) (t'$>l)
+ -- FIXME: not stateful enough... apply substs forward?
+ ss' <- zipWithM uHere eTys (tail eTys)
+ pure (ALit (Arr (vx (Ix () $ length es)) a) es', mconcat ss')
+tyE (EApp l e0 e1) = do
+ a <- TVar <$> freshName "a" l
+ b <- TVar <$> freshName "b" l
+ (e0', s0) <- tyE e0
+ (e1', s1) <- tyE e1
+ let e0Ty = Arrow a b
+ s2 <- liftEither $ mguPrep (l,e0) (s0<>s1) (eAnn e0'$>l) e0Ty
+ s3 <- liftEither $ mguPrep (l,e1) s2 (eAnn e1'$>l) a
+ pure (EApp (void b) e0' e1', s3)
+tyE (Cond l p e0 e1) = do
+ (p',sP) <- tyE p
+ (e0',s0) <- tyE e0
+ (e1',s1) <- tyE e1
+ sP' <- liftEither $ mguPrep (eAnn p,p) sP B (eAnn p'$>eAnn p)
+ s0' <- liftEither $ mguPrep (l,e0) (s0<>s1) (eAnn e0'$>l) (eAnn e1'$>eAnn e1)
+ pure (Cond (eAnn e0') p' e0' e1', sP'<>s0')
+tyE (Var l n@(Name _ (U u) _)) = do
+ lSt<- gets staEnv
+ case IM.lookup u lSt of
+ Just t -> pure (Var t (n $> t), mempty)
+ -- TODO: polymorphic let
+ Nothing -> do
+ vSt<- gets polyEnv
+ case IM.lookup u vSt of
+ Just t -> do {t'<- cloneWithConstraints t; pure (Var t' (n$>t'), mempty)}
+ Nothing -> throwError $ IllScoped l n
+tyE (Tup _ es) = do
+ res <- traverse tyE es
+ let (es', ss) = unzip res
+ eTys = eAnn<$>es'
+ pure (Tup (P eTys) es', mconcat ss)
+tyE (Ann _ e t) = do
+ (e', s) <- tyE e
+ pure (Ann (eAnn e') e' t, s)
diff --git a/src/Ty/Clone.hs b/src/Ty/Clone.hs
new file mode 100644
index 000000000..ee30de284
--- /dev/null
+++ b/src/Ty/Clone.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE RankNTypes #-}
+
+module Ty.Clone ( cloneTClosed ) where
+
+
+import A
+import Control.Monad.State.Strict (State, gets, runState)
+import Data.Functor (($>))
+import qualified Data.IntMap as IM
+import Lens.Micro (Lens')
+import Lens.Micro.Mtl (modifying, use)
+import Name
+import U
+
+data TRenames = TRenames { maxT :: Int
+ , boundTV :: IM.IntMap Int
+ , boundSh :: IM.IntMap Int
+ , boundIx :: IM.IntMap Int
+ }
+
+type CM = State TRenames
+
+maxTLens :: Lens' TRenames Int
+maxTLens f s = fmap (\x -> s { maxT = x }) (f (maxT s))
+
+boundTVLens :: Lens' TRenames (IM.IntMap Int)
+boundTVLens f s = fmap (\x -> s { boundTV = x }) (f (boundTV s))
+
+boundShLens :: Lens' TRenames (IM.IntMap Int)
+boundShLens f s = fmap (\x -> s { boundSh = x }) (f (boundSh s))
+
+boundIxLens :: Lens' TRenames (IM.IntMap Int)
+boundIxLens f s = fmap (\x -> s { boundIx = x }) (f (boundIx s))
+
+-- for clone
+freshen :: Lens' TRenames (IM.IntMap Int) -- ^ TVars, shape var, etc.
+ -> Name a -> CM (Name a)
+freshen lens (Name n (U i) l) = do
+ j <- gets maxT
+ modifying lens (IM.insert i (j+1))
+ modifying maxTLens (+1) $> Name n (U$j+1) l
+
+tryReplaceInT :: Lens' TRenames (IM.IntMap Int) -> Name a -> CM (Name a)
+tryReplaceInT lens n@(Name t (U i) l) = do
+ st <- use lens
+ case IM.lookup i st of
+ Just j -> pure (Name t (U j) l)
+ Nothing -> freshen lens n
+
+cloneTClosed :: Int -> T a
+ -> (Int, T a, IM.IntMap Int) -- ^ Substition on type variables, returned so constraints can be propagated/copied
+cloneTClosed u = (\(t, TRenames uϵ tvs _ _) -> (uϵ,t,tvs)) . flip runState (TRenames u IM.empty IM.empty IM.empty) . cloneT
+ where
+ cloneIx :: I a -> CM (I a)
+ cloneIx i@Ix{} = pure i
+ cloneIx (StaPlus l i i') = StaPlus l <$> cloneIx i <*> cloneIx i'
+ cloneIx (IVar l n) = IVar l <$> tryReplaceInT boundIxLens n
+ cloneIx e@IEVar{} = pure e
+
+ cloneSh :: Sh a -> CM (Sh a)
+ cloneSh (IxA i) = IxA <$> cloneIx i
+ cloneSh Nil = pure Nil
+ cloneSh (Cons i sh) = Cons <$> cloneIx i <*> cloneSh sh
+ cloneSh (SVar n) = SVar <$> tryReplaceInT boundShLens n
+
+ cloneT :: T a -> CM (T a)
+ cloneT F = pure F
+ cloneT I = pure I
+ cloneT B = pure B
+ cloneT (Arrow t t') = Arrow <$> cloneT t <*> cloneT t'
+ cloneT (Arr sh t) = Arr <$> cloneSh sh <*> cloneT t
+ cloneT (TVar n) = TVar <$> tryReplaceInT boundTVLens n
diff --git a/src/U.hs b/src/U.hs
new file mode 100644
index 000000000..dda84d6eb
--- /dev/null
+++ b/src/U.hs
@@ -0,0 +1,4 @@
+module U ( U (..)
+ ) where
+
+newtype U = U { unU :: Int } deriving (Eq)
diff --git a/test/Spec.cpphs b/test/Spec.cpphs
new file mode 100644
index 000000000..b1fec4b94
--- /dev/null
+++ b/test/Spec.cpphs
@@ -0,0 +1,190 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main (main) where
+
+import Control.Exception (throw)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BSL
+import Data.Int (Int64)
+import Foreign.Marshal.Alloc (allocaBytes)
+import Foreign.Ptr (FunPtr, Ptr)
+import Foreign.Storable (Storable (..))
+import Hs.A
+import Hs.FFI
+import Math.Hypergeometric (erf, hypergeometric, ncdf)
+import Math.SpecialFunction (gammaln)
+import P
+import Test.Tasty
+import Test.Tasty.HUnit
+
+hsEntropy :: Floating a => [a] -> a
+hsEntropy xs = sum [ x * log x | x <- xs ]
+
+kl :: Floating a => [a] -> [a] -> a
+kl xs ys = sum [ x * log (x/y) | x <- xs, y <- ys ]
+
+infixl 1 .?=
+
+(.?=) :: (Show a, Ord a, Floating a) => a -> a -> Assertion
+x .?= y = assertBool ("expected " ++ show y ++ ", got " ++ show x) (x-y<1e-15&&y-x<1e-15)
+
+main :: IO ()
+main = defaultMain $ testGroup "All" $ rTy:
+#ifdef x86_64_HOST_ARCH
+ [x64T]
+#else
+ [tyT]
+#endif
+
+rTy :: TestTree
+rTy = testGroup "Regression tests"
+ [ tyF "test/data/polymorphic.🍎"
+ , tyF "test/examples/gammaln.🍏"
+ , tyF "test/examples/regress.🍎"
+ , tyF "test/data/rank.🍎"
+ , tyF "test/examples/weekMean.🍎"
+ , tyF "test/examples/convolve.🍎"
+ ]
+
+tyT :: TestTree
+tyT = testGroup "Type system"
+ [ tyF "test/examples/erfSum.🍏"
+ , tyF "test/examples/kl.🍎"
+ , tyS "[(+)/\\ 0 (irange 0 x 1)]"
+ , tyS "((-)\\~)"
+ ]
+
+x64T :: TestTree
+x64T = testGroup "x64"
+ [ rfTest
+ , testCase "Floats?" $ do { res <- jitFact 50 ; res @?= 3.0414093201713376e64 }
+ , testCase "exp (series)" $ do { res <- jitExp 20 1 ; res .?= exp 1 }
+ , testCase "f11" $ do { res <- f11 1 ; res @?= hypergeometric [1] [3/2] 1 }
+ , testCase "erf" $ do { res <- erfJit 1 ; res .?= erf 1 }
+ , testCase "erf" $ do { res <- erfJit 2 ; res .?= erf 2 }
+ , testCase "ncdf" $ do { res <- ncdfJit 2 ; res .?= ncdf 2 }
+ , testCase "entropy" $ do { res <- jitEntropy [0.25, 0.25, 0.5] ; res @?= hsEntropy [0.25, 0.25, 0.5] }
+ , testCase "k-l" $ do { res <- jitKl [0.25, 0.25, 0.5] [0.66, 0.33, 0] ; res @?= kl [0.25, 0.25, 0.5] [0.66, 0.33, 0] }
+ , testCase "array of floats" $ do { res <- fpAf "test/data/farr.🍎" [3, 6, 9] ; res @?= 36 }
+ , testCase "gammaln" $ do { res <- gammaJit 1.5 ; res @?= gammaln 1.5 }
+ , testCase "avg" $ do { res <- fpAf "test/examples/avg.🍎" [1,2,3] ; res @?= 2 }
+ , testCase "twoSum" $ do { res <- fpAaf "test/data/twoSum.🍎" [1,2,3] [2,4,5] ; res @?= 17 }
+ , testCase "dotprod" $ do { res <- fpAaf "test/examples/dotprod.🍏" [1,2,3] [2,4,6] ; res @?= 28 }
+ , testCase "euclidean" $ do { res <- fpAaf "test/examples/dist.🍎" [0,0,0] [3,4,5] ; res @?= sqrt 50 }
+ , testCase "b" $ do { res <- jitB [1,2,3] [2,4,6] ; res @?= 2 }
+ , testCase "map/alloc" $ do { res <- sSq 25 ; res @?= [ i^(2::Int) | i <- [0..25] ] }
+ , testCase "ℯ" $ do { res <- jitE 2.5 ; res @?= exp 2.5 }
+ , testCase "scan" $ do { res <- scan 5 ; res @?= [0,1,3,6,10] }
+ , testCase "maxscan" $ do { res <- aaFp "bench/apple/scanmax.🍏" [4,6,1] ; res @?= [0,4,6,6] }
+ ]
+
+scan i = do
+ f <- ia <$> funP "[(+) /\\ 0 (irange 1 x 1)]"
+ asI (f i)
+
+sSq i = do
+ f <- ia <$> funP "[(^2)'1 (irange 0 x 1)]"
+ asI (f i)
+
+asI :: Ptr (Apple Int) -> IO [Int]
+asI = fmap (\(AA _ _ xs) -> xs) . peek
+
+aaFp fp xs =
+ let xA = AA 1 [fromIntegral(length xs)] xs in
+ wA xA $ \p -> do
+ f <- fmap aa . funP =<< BSL.readFile fp
+ asI (f p)
+
+tyS :: BSL.ByteString -> TestTree
+tyS s = testCase "(expr)" $
+ case tyExpr s of
+ Left err -> assertFailure(show err)
+ Right{} -> assertBool "passed" True
+
+tyF :: FilePath -> TestTree
+tyF fp = testCase fp $ do
+ res <- tyExpr <$> BSL.readFile fp
+ case res of
+ Left err -> assertFailure (show err)
+ Right{} -> assertBool "Passes" True
+
+rfTest :: TestTree
+rfTest = testCase "rising factorial" $ do
+ res <- jitRF 5 15
+ res @?= 5068545850368000
+
+fpAf :: FilePath -> [Double] -> IO Double
+fpAf fp xs = do
+ f <- bytesE <$> BSL.readFile fp
+ jitAf f xs
+
+jitEntropy = fpAf "test/examples/entropy.🍏"
+jitKl = fpAaf "test/examples/kl.🍎"
+jitB = fpAaf "test/examples/b.🍎"
+
+fpAaf :: FilePath -> [Double] -> [Double] -> IO Double
+fpAaf fp xs ys = do
+ f <- bytesE <$> BSL.readFile fp
+ jitAaf f xs ys
+
+jitAaf :: BS.ByteString -> [Double] -> [Double] -> IO Double
+jitAaf code xs ys =
+ let a = AA 1 [fromIntegral(length xs)] xs
+ b = AA 1 [fromIntegral(length ys)] ys in
+ wA a $ \p -> wA b $ \q -> do
+ (fp,_) <- bsFp code
+ pure $ aaf fp p q
+
+jitAf :: BS.ByteString -> [Double] -> IO Double
+jitAf code xs =
+ let a = AA 1 [fromIntegral(length xs)] xs in
+ wA a $ \p -> do
+ (fp,_) <- bsFp code
+ pure $ af fp p
+
+jitE :: Double -> IO Double
+jitE x = do
+ fp <- funP "[e:x]"
+ pure $ ff fp x
+
+jitExp :: Int64 -> Double -> IO Double
+jitExp n x = do
+ fp <- funP =<< BSL.readFile "test/examples/exp.🍏"
+ pure $ iff fp n x
+
+fpFF :: FilePath -> Double -> IO Double
+fpFF fp x = do
+ f <- funP =<< BSL.readFile fp
+ pure $ ff f x
+
+gammaJit = fpFF "test/examples/gammaln.🍏"
+ncdfJit = fpFF "test/examples/ncdf.🍎"
+
+erfJit :: Double -> IO Double
+erfJit = fpFF "test/examples/erf.🍏"
+
+f11 :: Double -> IO Double
+f11 = fpFF "test/examples/hypergeometricEfficient.🍏"
+
+jitFact :: Double -> IO Double
+jitFact = fpFF "test/examples/ffact.🍎"
+
+jitRF :: Int -> Int -> IO Int
+jitRF m n = do
+ fp <- funP =<< BSL.readFile "test/examples/risingFactorial.🍎"
+ pure $ runRF fp m n
+
+wA :: Storable a => Apple a -> (Ptr (Apple a) -> IO b) -> IO b
+wA x act =
+ allocaBytes (sizeOf x) $ \p ->
+ poke p x *> act p
+
+bytesE = either throw id . bytes
+
+foreign import ccall "dynamic" af :: FunPtr (Ptr (Apple a) -> Double) -> Ptr (Apple a) -> Double
+foreign import ccall "dynamic" aaf :: FunPtr (Ptr (Apple a) -> Ptr (Apple a) -> Double) -> Ptr (Apple a) -> Ptr (Apple a) -> Double
+foreign import ccall "dynamic" ff :: FunPtr (Double -> Double) -> Double -> Double
+foreign import ccall "dynamic" iff :: FunPtr (Int64 -> Double -> Double) -> Int64 -> Double -> Double
+foreign import ccall "dynamic" runRF :: FunPtr (Int -> Int -> Int) -> (Int -> Int -> Int)
+foreign import ccall "dynamic" ia :: FunPtr (Int -> Ptr (Apple a)) -> Int -> Ptr (Apple a)
+foreign import ccall "dynamic" aa :: FunPtr (Ptr (Apple a) -> Ptr (Apple a)) -> Ptr (Apple a) -> Ptr (Apple a)
diff --git "a/test/data/addRank.\360\237\215\217" "b/test/data/addRank.\360\237\215\217"
new file mode 100644
index 000000000..273e7bc55
--- /dev/null
+++ "b/test/data/addRank.\360\237\215\217"
@@ -0,0 +1 @@
+\x.\y. (((+)`{0,0}) x) y
diff --git "a/test/data/farr.\360\237\215\216" "b/test/data/farr.\360\237\215\216"
new file mode 100644
index 000000000..1aae92608
--- /dev/null
+++ "b/test/data/farr.\360\237\215\216"
@@ -0,0 +1 @@
+[(+)/1 0 ((*2.0)'1 x)]
diff --git "a/test/data/log.\360\237\215\216" "b/test/data/log.\360\237\215\216"
new file mode 100644
index 000000000..fd3c19a02
--- /dev/null
+++ "b/test/data/log.\360\237\215\216"
@@ -0,0 +1 @@
+[_.x]
diff --git "a/test/data/polymorphic.\360\237\215\216" "b/test/data/polymorphic.\360\237\215\216"
new file mode 100644
index 000000000..6a6929d8d
--- /dev/null
+++ "b/test/data/polymorphic.\360\237\215\216"
@@ -0,0 +1,6 @@
+{
+ sum ⇐ [(+)/1 0 x];
+ sumI ← sum (⍳ 1 1 10);
+ sumF ← sum (𝒻 1 10 10);
+ sumI + (⌊sumF)
+}
diff --git "a/test/data/rank.\360\237\215\216" "b/test/data/rank.\360\237\215\216"
new file mode 100644
index 000000000..aa04db383
--- /dev/null
+++ "b/test/data/rank.\360\237\215\216"
@@ -0,0 +1,8 @@
+\x.\y.
+{
+ dotprod ←
+ { sq ← ((^2)'1);
+ [(+)/1 0 ((*) `2 1 (sq x) (sq y))]
+ };
+ (dotprod`{1,1∘[2]} x) y
+}
diff --git "a/test/data/scan.\360\237\215\217" "b/test/data/scan.\360\237\215\217"
new file mode 100644
index 000000000..f6af6926a
--- /dev/null
+++ "b/test/data/scan.\360\237\215\217"
@@ -0,0 +1 @@
+[(+) Λ 0 (⍳ 1 x 1)]
diff --git "a/test/data/twoSum.\360\237\215\216" "b/test/data/twoSum.\360\237\215\216"
new file mode 100644
index 000000000..175843a97
--- /dev/null
+++ "b/test/data/twoSum.\360\237\215\216"
@@ -0,0 +1,6 @@
+\xs.\ys.
+{
+ -- FIXME: this fails with polymorphic bind lol
+ Σ ← [(+)/1 0.0 x];
+ (Σ xs) + (Σ ys) + 0.0
+}
diff --git "a/test/examples/avg.\360\237\215\216" "b/test/examples/avg.\360\237\215\216"
new file mode 100644
index 000000000..319c8379a
--- /dev/null
+++ "b/test/examples/avg.\360\237\215\216"
@@ -0,0 +1,6 @@
+λxs.
+{
+ Σ ← [(+)/1 0 x];
+ n ← 𝑖(:xs);
+ (Σ xs) % n
+}
diff --git "a/test/examples/b.\360\237\215\216" "b/test/examples/b.\360\237\215\216"
new file mode 100644
index 000000000..2f284dcf4
--- /dev/null
+++ "b/test/examples/b.\360\237\215\216"
@@ -0,0 +1,12 @@
+\xs.\ys.
+{
+ -- FIXME: this fails with polymorphic bind lol
+ Σ ← [(+)/1 0 x];
+ n ⟜ 𝑖(:xs);
+ xbar ⟜ (Σ xs) % n;
+ ybar ← (Σ ys) % n;
+ xy ← Σ ((*)`2 1 xs ys);
+ x2 ← Σ ((^2)'1 xs);
+ denom ← (x2-(n*(xbar^2)));
+ (xy-(n*xbar*ybar))%denom
+}
diff --git "a/test/examples/continuedFraction.\360\237\215\216" "b/test/examples/continuedFraction.\360\237\215\216"
new file mode 100644
index 000000000..74c2ba347
--- /dev/null
+++ "b/test/examples/continuedFraction.\360\237\215\216"
@@ -0,0 +1 @@
+λa.λbs. [x+(1%y)]/1 a bs
diff --git "a/test/examples/convolve.\360\237\215\216" "b/test/examples/convolve.\360\237\215\216"
new file mode 100644
index 000000000..7224687d2
--- /dev/null
+++ "b/test/examples/convolve.\360\237\215\216"
@@ -0,0 +1,2 @@
+-- mean filter
+([((+)/2 0 x)%𝑖(:x)] ⨳ {7,7})
diff --git "a/test/examples/cube.\360\237\215\216" "b/test/examples/cube.\360\237\215\216"
new file mode 100644
index 000000000..b36e4f44c
--- /dev/null
+++ "b/test/examples/cube.\360\237\215\216"
@@ -0,0 +1,5 @@
+λn.
+{
+ ix ← irange 1 n 1;
+ (+)/1 0 ((^3)'1 ix)
+}
diff --git "a/test/examples/dilogarithm.\360\237\215\216" "b/test/examples/dilogarithm.\360\237\215\216"
new file mode 100644
index 000000000..699e28955
--- /dev/null
+++ "b/test/examples/dilogarithm.\360\237\215\216"
@@ -0,0 +1 @@
+\z.\N. (+)/1 0 ((\k.(z^k)%(itof (k^2)))'1 irange 1 N 1)
diff --git "a/test/examples/dist.\360\237\215\216" "b/test/examples/dist.\360\237\215\216"
new file mode 100644
index 000000000..ffcc25341
--- /dev/null
+++ "b/test/examples/dist.\360\237\215\216"
@@ -0,0 +1 @@
+[√((+)/1 0 ((^2)'1 ((-)`2 1 x y)))]
diff --git "a/test/examples/dotprod.\360\237\215\217" "b/test/examples/dotprod.\360\237\215\217"
new file mode 100644
index 000000000..9392ee417
--- /dev/null
+++ "b/test/examples/dotprod.\360\237\215\217"
@@ -0,0 +1 @@
+[(+)/1 0 ((*) `2 1 ((x::Arr (i `Cons` Nil) float)) (y))]
diff --git "a/test/examples/e.\360\237\215\217" "b/test/examples/e.\360\237\215\217"
new file mode 100644
index 000000000..41d231cdb
--- /dev/null
+++ "b/test/examples/e.\360\237\215\217"
@@ -0,0 +1,7 @@
+λN.
+{
+ sum ← λn.λN.λf. (+)/1 0 (f'1 (irange n N 1));
+ fact ← [(*)/1 1 (frange 1 x (⌊x))];
+ ix ← λn. 1%(fact (𝑖n));
+ sum 0 N ix
+}
diff --git "a/test/examples/entropy.\360\237\215\217" "b/test/examples/entropy.\360\237\215\217"
new file mode 100644
index 000000000..b45163006
--- /dev/null
+++ "b/test/examples/entropy.\360\237\215\217"
@@ -0,0 +1 @@
+\p. (+)/1 0 ([x*_.x]'1 p)
diff --git "a/test/examples/erf.\360\237\215\217" "b/test/examples/erf.\360\237\215\217"
new file mode 100644
index 000000000..3743d2612
--- /dev/null
+++ "b/test/examples/erf.\360\237\215\217"
@@ -0,0 +1,19 @@
+λz.
+{
+ exp ← λN.λx.
+ {
+ fact ← [(*)/1 1 (frange 1 x (⌊x))];
+ iix ← irange 0 N 1;
+ mkIx ← λn. (x^n)%(fact (𝑖n));
+ (+)/1 0 (mkIx'1 iix)
+ };
+ f11 ← λz.
+ {
+ rf ← [(*)/1 1 (frange x (x+y-1) (⌊y))];
+ ix ← irange 0 99 1;
+ -- FIXME: might be more efficient to have an frange too?
+ mkIx ← [(z^x)%(rf 1.5 (itof x))];
+ (+)/1 0 (mkIx'1 ix)
+ };
+ 2*z*(exp 20 (_(z^2)))*(f11 (z^2))%(√𝜋)
+}
diff --git "a/test/examples/erfSum.\360\237\215\217" "b/test/examples/erfSum.\360\237\215\217"
new file mode 100644
index 000000000..c67cf1f23
--- /dev/null
+++ "b/test/examples/erfSum.\360\237\215\217"
@@ -0,0 +1,18 @@
+λz.
+{
+ Σ ← λn.λN.λf. (+)/1 0 (f'1 (irange n N 0));
+ exp ← λN.λx.
+ {
+ fact ← [(*)/1 1 (frange 1 x (⌊x))];
+ mkIx ← λn. (x^n)%(fact (𝑖n));
+ Σ 0 N mkIx
+ };
+ f11 ← λz.
+ {
+ rf ← [(*)/1 1 (frange x (x+y-1) (⌊y))];
+ mkIx ← [(z^x)%(rf 1.5 (itof x))];
+ Σ 0 99 mkIx
+ };
+ z2 ⟜ z^2;
+ 2*z*(exp 20 (_(z2)))*(f11 (z2))%(√𝜋)
+}
diff --git "a/test/examples/exp.\360\237\215\217" "b/test/examples/exp.\360\237\215\217"
new file mode 100644
index 000000000..3ede67b41
--- /dev/null
+++ "b/test/examples/exp.\360\237\215\217"
@@ -0,0 +1,7 @@
+λN.λx.
+{
+ fact ← [(*)/1 1 (frange 1 x (⌊x))];
+ iix ← irange 0 N 1;
+ mkIx ← λn. (x^n)%(fact (𝑖n));
+ (+)/1 0 (mkIx'1 iix)
+}
diff --git "a/test/examples/expSum.\360\237\215\217" "b/test/examples/expSum.\360\237\215\217"
new file mode 100644
index 000000000..ddd331d37
--- /dev/null
+++ "b/test/examples/expSum.\360\237\215\217"
@@ -0,0 +1,7 @@
+λN.λx.
+{
+ sumi ← λn.λN.λf. (+)/1 0 (f'1 (irange n N 1));
+ fact ← [(*)/1 1 (frange 1 x (⌊x))];
+ mkIx ← λn. (x^n)%(fact (𝑖n));
+ sumi 0 N mkIx
+}
diff --git "a/test/examples/fact.\360\237\215\216" "b/test/examples/fact.\360\237\215\216"
new file mode 100644
index 000000000..839f4dc4e
--- /dev/null
+++ "b/test/examples/fact.\360\237\215\216"
@@ -0,0 +1 @@
+[(*)/1 ⍳ 1 x 1]
diff --git "a/test/examples/ffact.\360\237\215\216" "b/test/examples/ffact.\360\237\215\216"
new file mode 100644
index 000000000..9677aaceb
--- /dev/null
+++ "b/test/examples/ffact.\360\237\215\216"
@@ -0,0 +1 @@
+[(*)/1 1 (frange 1 x (|.x))]
diff --git "a/test/examples/fib.\360\237\215\217" "b/test/examples/fib.\360\237\215\217"
new file mode 100644
index 000000000..873f434d8
--- /dev/null
+++ "b/test/examples/fib.\360\237\215\217"
@@ -0,0 +1 @@
+\N. 𝓕 1 1 (+) N
diff --git "a/test/examples/gammaln.\360\237\215\217" "b/test/examples/gammaln.\360\237\215\217"
new file mode 100644
index 000000000..9c488f22c
--- /dev/null
+++ "b/test/examples/gammaln.\360\237\215\217"
@@ -0,0 +1,25 @@
+λz.
+{
+ zz ← z-1;
+ c0 ← 0.999999999999997092;
+ 𝛾 ← 607%128;
+ coeffs ← ⟨ 57.1562356658629235
+ , _59.5979603554754912
+ , 14.1360979747417471
+ , _0.491913816097620199
+ , 0.339946499848118887e-4
+ , 0.465236289270485756e-4
+ , _0.983744753048795646e-4
+ , 0.158088703224912494e-3
+ , _0.210264441724104883e-3
+ , 0.217439618115212643e-3
+ , _0.164318106536763890e-3
+ , 0.844182239838527433e-4
+ , _0.261908384015814087e-4
+ , 0.368991826595316234e-5
+ ⟩;
+ -- TODO: maybe faster w/ frange? (segfaults rip)
+ ss ← (+)/1 0 ([y%(zz+itof x)] `2 1 (irange 1 14 1) coeffs);
+ -- FIXME: these parentheses are annoying as shit!!
+ (((zz+0.5)*(_.(zz+𝛾+0.5)))-(zz+𝛾+0.5))+_.((√(2*𝜋))*(c0+ss))
+}
diff --git "a/test/examples/hypergeometric.\360\237\215\217" "b/test/examples/hypergeometric.\360\237\215\217"
new file mode 100644
index 000000000..2893ec4f0
--- /dev/null
+++ "b/test/examples/hypergeometric.\360\237\215\217"
@@ -0,0 +1,12 @@
+-- of aid in computing erf
+λz.
+{
+ -- frange (say) 1 99 99: go from 1 to 99 in 99 steps
+ -- (can't be as nice as ints...)
+ rf ← [(*)/1 1 (frange x (x+y-1) (⌊y))];
+ iix ← irange 1 99 1;
+ ix ← frange 1 99 99;
+ nums ← ((z^2)^)'1 iix;
+ denoms ← (rf 1.5)'1 ix;
+ (+)/1 0 ((%) `2 1 nums denoms)
+}
diff --git "a/test/examples/hypergeometricEfficient.\360\237\215\217" "b/test/examples/hypergeometricEfficient.\360\237\215\217"
new file mode 100644
index 000000000..153bc5d1f
--- /dev/null
+++ "b/test/examples/hypergeometricEfficient.\360\237\215\217"
@@ -0,0 +1,10 @@
+-- of aid in computing erf
+-- this is f_11(1,3/2,z), we need
+λz.
+{
+ -- frange (say) 1 99 99: go from 1 to 99 in 99 steps
+ rf ← [(*)/1 1 (frange x (x+y-1) (⌊y))];
+ ix ← irange 0 99 1;
+ mkIx ← [(z^x)%(rf 1.5 (itof x))];
+ (+)/1 0 (mkIx'1 ix)
+}
diff --git "a/test/examples/kl.\360\237\215\216" "b/test/examples/kl.\360\237\215\216"
new file mode 100644
index 000000000..9b490dc0b
--- /dev/null
+++ "b/test/examples/kl.\360\237\215\216"
@@ -0,0 +1 @@
+λp.λq. (+)/1 0 ([x*_.(x%y)]`2 1 p q)
diff --git "a/test/examples/linear.\360\237\215\216" "b/test/examples/linear.\360\237\215\216"
new file mode 100644
index 000000000..3d8342f0a
--- /dev/null
+++ "b/test/examples/linear.\360\237\215\216"
@@ -0,0 +1 @@
+[(*2)'1 x]
diff --git "a/test/examples/lnSeries.\360\237\215\217" "b/test/examples/lnSeries.\360\237\215\217"
new file mode 100644
index 000000000..8cef93a8e
--- /dev/null
+++ "b/test/examples/lnSeries.\360\237\215\217"
@@ -0,0 +1,10 @@
+-- ln(1+x) by x - x^2/2 + x^3/3 - x^4/4 + ...
+-- converges -1≤x≤1
+--
+-- not very good.
+λN.λx.
+{
+ iix ← irange 1 N 1;
+ mkIx ← λn. (_((_ x)^n))%(𝑖n);
+ (+)/1 0 (mkIx'1 iix)
+}
diff --git "a/test/examples/log.\360\237\215\216" "b/test/examples/log.\360\237\215\216"
new file mode 100644
index 000000000..58656b48c
--- /dev/null
+++ "b/test/examples/log.\360\237\215\216"
@@ -0,0 +1 @@
+[(_.x)%(_.10)]
diff --git "a/test/examples/mul.\360\237\215\217" "b/test/examples/mul.\360\237\215\217"
new file mode 100644
index 000000000..42c55e224
--- /dev/null
+++ "b/test/examples/mul.\360\237\215\217"
@@ -0,0 +1,8 @@
+\x.
+{
+ dotprod ←
+ { sq ← ((^2)'1);
+ [(+)/1 0 ((*) `2 1 (sq x) (sq y))]
+ };
+ ((dotprod x)'1)
+}
diff --git "a/test/examples/ncdf.\360\237\215\216" "b/test/examples/ncdf.\360\237\215\216"
new file mode 100644
index 000000000..c13cf6a2d
--- /dev/null
+++ "b/test/examples/ncdf.\360\237\215\216"
@@ -0,0 +1,24 @@
+λz.
+{
+ erf ← λz.
+ {
+ exp ← λN.λx.
+ {
+ fact ← [(*)/1 1 (frange 1 x (⌊x))];
+ iix ← irange 0 N 1;
+ mkIx ← λn. (x^n)%(fact (𝑖n));
+ (+)/1 0 (mkIx'1 iix)
+ };
+ f11 ← λz.
+ {
+ rf ← [(*)/1 1 (frange x (x+y-1) (⌊y))];
+ ix ← irange 0 99 1;
+ -- FIXME: might be more efficient to have an frange too?
+ mkIx ← [(z^x)%(rf 1.5 (itof x))];
+ (+)/1 0 (mkIx'1 ix)
+ };
+ 2*z*(exp 20 (_(z^2)))*(f11 (z^2))%(√𝜋)
+ };
+ zz ⟜ z%(√2);
+ 0.5*(1+erf(zz))
+}
diff --git "a/test/examples/neuralNetwork.\360\237\215\217" "b/test/examples/neuralNetwork.\360\237\215\217"
new file mode 100644
index 000000000..7a0e87cbf
--- /dev/null
+++ "b/test/examples/neuralNetwork.\360\237\215\217"
@@ -0,0 +1,10 @@
+{
+ softmax ← λx. {
+ -- TODO: softmax... what's the key for max?
+ xs ⟜ [ℯ(_x)]'1 x;
+ avg ← (+)/1 0 xs;
+ (%avg)'1 xs
+ };
+ sigmoid ← [1+ℯ(_x)];
+ sigmoid
+}
diff --git "a/test/examples/perimeter.\360\237\215\217" "b/test/examples/perimeter.\360\237\215\217"
new file mode 100644
index 000000000..a328d46ec
--- /dev/null
+++ "b/test/examples/perimeter.\360\237\215\217"
@@ -0,0 +1,5 @@
+λxs.λys.
+ { sum ← [(+)/1 0 x]
+ ; succDiff ← ((-)\~)
+ ; sum ([√((x^2)+y^2)]`2 1 (succDiff xs) (succDiff ys))
+ }
diff --git "a/test/examples/poly.\360\237\215\217" "b/test/examples/poly.\360\237\215\217"
new file mode 100644
index 000000000..9d50eae28
--- /dev/null
+++ "b/test/examples/poly.\360\237\215\217"
@@ -0,0 +1,2 @@
+λp.λx. (+)/1 0 ((*)`2 1 p (gen. x (*) (:p)))
+-- TODO: consider something that folds with seed? (x's power being the seed)
diff --git "a/test/examples/regress.\360\237\215\216" "b/test/examples/regress.\360\237\215\216"
new file mode 100644
index 000000000..effff7c7e
--- /dev/null
+++ "b/test/examples/regress.\360\237\215\216"
@@ -0,0 +1,13 @@
+\xs.\ys.
+{
+ Σ ← [(+)/1 0 x];
+ n ⟜ 𝑖(:xs);
+ xbar ⟜ (Σ xs) % n;
+ ybar ⟜ (Σ ys) % n;
+ xy ⟜ Σ ((*)`2 1 xs ys);
+ x2 ⟜ Σ ((^2)'1 xs);
+ denom ⟜ (x2-n*(xbar^2));
+ a ← ((ybar*x2)-(xbar*xy))%denom;
+ b ← (xy-(n*xbar*ybar))%denom;
+ (a,b)
+}
diff --git "a/test/examples/risingFactorial.\360\237\215\216" "b/test/examples/risingFactorial.\360\237\215\216"
new file mode 100644
index 000000000..5a5c9c76a
--- /dev/null
+++ "b/test/examples/risingFactorial.\360\237\215\216"
@@ -0,0 +1 @@
+[(*)/1 1 (⍳ x (x+y-1) 1)]
diff --git "a/test/examples/sum.\360\237\215\216" "b/test/examples/sum.\360\237\215\216"
new file mode 100644
index 000000000..fdb7754db
--- /dev/null
+++ "b/test/examples/sum.\360\237\215\216"
@@ -0,0 +1 @@
+[(+)/1 x]
diff --git "a/test/examples/sumVec.\360\237\215\216" "b/test/examples/sumVec.\360\237\215\216"
new file mode 100644
index 000000000..58b9e92bb
--- /dev/null
+++ "b/test/examples/sumVec.\360\237\215\216"
@@ -0,0 +1,2 @@
+([(+)/1 0 x] :: Arr (i `Cons` Nil) float → float)
+-- FIXME: this parses wrong...
diff --git "a/test/examples/tcdf.\360\237\215\216" "b/test/examples/tcdf.\360\237\215\216"
new file mode 100644
index 000000000..1bd7a83b4
--- /dev/null
+++ "b/test/examples/tcdf.\360\237\215\216"
@@ -0,0 +1,40 @@
+λx.λν.
+{
+ gammaln ←
+ λz.
+ {
+ zz ← z-1;
+ c0 ← 0.999999999999997092;
+ 𝛾 ← 607%128;
+ coeffs ← ⟨ 57.1562356658629235
+ , _59.5979603554754912
+ , 14.1360979747417471
+ , _0.491913816097620199
+ , 0.339946499848118887e-4
+ , 0.465236289270485756e-4
+ , _0.983744753048795646e-4
+ , 0.158088703224912494e-3
+ , _0.210264441724104883e-3
+ , 0.217439618115212643e-3
+ , _0.164318106536763890e-3
+ , 0.844182239838527433e-4
+ , _0.261908384015814087e-4
+ , 0.368991826595316234e-5
+ ⟩;
+ -- TODO: maybe faster w/ frange? (segfaults rip)
+ ss ← (+)/1 0 ([y%(zz+itof x)] `2 1 (irange 1 14 1) coeffs);
+ (((zz+0.5)*(_.(zz+𝛾+0.5)))-(zz+𝛾+0.5))+_.((√(2*𝜋))*(c0+ss))
+ };
+ f21 ← λz.
+ {
+ rf ← [(*)/1 1 (frange x (x+y-1) (⌊y))];
+ fact ← [(*)/1 1 (frange 1 x (⌊x))];
+ ix ← irange 0 99 1;
+ -- a₂
+ -- a2 ⟜ 1.5*(1.5*(ν+1));
+ mkIx ← [{xx⟜itof x;((z^x)*(rf 0.5 x)*(rf (1.5*(ν+1)) x))%((fact xx)*(rf 1.5 xx))}];
+ (+)/1 0 (mkIx'1 ix)
+ };
+ -- TODO: PARENTHESES!!
+ 0.5+f21 (((_x)^2)%ν)
+}
diff --git "a/test/examples/weekMean.\360\237\215\216" "b/test/examples/weekMean.\360\237\215\216"
new file mode 100644
index 000000000..81e0bce88
--- /dev/null
+++ "b/test/examples/weekMean.\360\237\215\216"
@@ -0,0 +1 @@
+\xs. [((+)/1 0 x)%(𝑖(:x))]\`7 xs
diff --git a/test/harness/a_harness.c b/test/harness/a_harness.c
new file mode 100644
index 000000000..83b918915
--- /dev/null
+++ b/test/harness/a_harness.c
@@ -0,0 +1,8 @@
+#include
+#include
+
+extern void* a(void);
+
+int main(int argc, char *argv[]) {
+ printf("%p\n", a());
+}
diff --git a/test/harness/aaf_harness.c b/test/harness/aaf_harness.c
new file mode 100644
index 000000000..eeafac053
--- /dev/null
+++ b/test/harness/aaf_harness.c
@@ -0,0 +1,19 @@
+#include
+#include
+#include
+
+#include "../../c/apple.c"
+
+extern F aaf(U, U);
+
+int main(int argc, char *argv[]) {
+ F xs[] = {1,2,3};
+ F ys[] = {2,4,6};
+ I d[] = {3};
+ Af a = {1,d,xs};
+ Af b = {1,d,ys};
+ U x = poke_af(a);
+ U y = poke_af(b);
+ printf("%f\n", aaf(x, y));
+ free(x);free(y);
+}
diff --git a/test/harness/af_harness.c b/test/harness/af_harness.c
new file mode 100644
index 000000000..5057262f2
--- /dev/null
+++ b/test/harness/af_harness.c
@@ -0,0 +1,16 @@
+#include
+#include
+#include
+
+#include "../../c/apple.c"
+
+extern F af(U);
+
+int main(int argc, char *argv[]) {
+ F xs[] = {1,2,3};
+ I d[] = {3};
+ Af a = {1, d, xs};
+ U x = poke_af(a);
+ printf("%f\n", af(x));
+ free(x);
+}
diff --git a/test/harness/ff_harness.c b/test/harness/ff_harness.c
new file mode 100644
index 000000000..bc575ee0f
--- /dev/null
+++ b/test/harness/ff_harness.c
@@ -0,0 +1,8 @@
+#include
+#include
+
+extern double ff(double);
+
+int main(int argc, char *argv[]) {
+ printf("%f\n", ff(1.0));
+}
diff --git a/vim/ftdetect/apple.vim b/vim/ftdetect/apple.vim
new file mode 100644
index 000000000..76363c8fc
--- /dev/null
+++ b/vim/ftdetect/apple.vim
@@ -0,0 +1 @@
+autocmd BufNewFile,BufRead *.🍏,*.🍎 set filetype=apple
diff --git a/vim/ftplugin/apple.vim b/vim/ftplugin/apple.vim
new file mode 100644
index 000000000..cf8d95478
--- /dev/null
+++ b/vim/ftplugin/apple.vim
@@ -0,0 +1,20 @@
+setlocal commentstring=--\ %s
+
+set smarttab
+
+setl shiftwidth=2
+
+setl foldmethod=indent
+normal zR
+
+digraphs <- 8592
+ \ ll 955
+ \ o- 10204
+ \ ee 8495
+ \ oo 8728
+ \ /\ 923
+ \ ff 119995
+ \ ii 119894
+
+" register atc as a checker
+let g:syntastic_apple_checkers = ['atc']
diff --git a/vim/syntax/apple.vim b/vim/syntax/apple.vim
new file mode 100644
index 000000000..cbb6028c5
--- /dev/null
+++ b/vim/syntax/apple.vim
@@ -0,0 +1,15 @@
+scriptencoding utf-8
+
+if exists('b:current_syntax')
+ finish
+endif
+
+syntax match appleComment "\v--.*$"
+syntax keyword appleKeyword frange irange itof
+syntax keyword appleType Arr Nil float int
+
+highlight link appleComment Comment
+highlight link appleKeyword Keyword
+highlight link appleType Type
+
+let b:current_syntax = 'apple'
diff --git a/vim/syntax_checkers/apple/atc.vim b/vim/syntax_checkers/apple/atc.vim
new file mode 100644
index 000000000..06ab5635f
--- /dev/null
+++ b/vim/syntax_checkers/apple/atc.vim
@@ -0,0 +1,26 @@
+if exists('g:loaded_syntastic_apple_atc_checker')
+ finish
+endif
+let g:loaded_syntastic_apple_atc_checker = 1
+
+let g:syntastic_apple_atc_exec = 'atc'
+
+function! SyntaxCheckers_apple_atc_GetLocList() dict
+ let makeprg = self.makeprgBuild({
+ \ 'exe': self.getExec(),
+ \ 'fname': shellescape(expand('%') )})
+
+ let errorformat =
+ \ 'atc: %m'
+
+ let loclist = SyntasticMake({
+ \ 'makeprg': makeprg,
+ \ 'errorformat': errorformat })
+
+ return loclist
+
+endfunction
+
+call g:SyntasticRegistry.CreateAndRegisterChecker({
+ \ 'filetype': 'apple',
+ \ 'name': 'atc' })