├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── array-forth.cabal ├── basic.pdf ├── graphs ├── complex distance.pdf ├── normal distance.pdf └── traces.pdf ├── mutations.org ├── notes.org ├── out.pdf ├── src ├── Chart.hs ├── Language │ └── ArrayForth │ │ ├── Channel.hs │ │ ├── Core.hs │ │ ├── Distance.hs │ │ ├── Interpreter.hs │ │ ├── Multicore.hs │ │ ├── NativeProgram.hs │ │ ├── Opcode.hs │ │ ├── Parse.hs │ │ ├── Program.hs │ │ ├── Stack.hs │ │ ├── State.hs │ │ └── Synthesis.hs ├── Main.hs ├── Run.hs ├── foo.pdf └── out.pdf ├── test ├── Language │ └── ArrayForth │ │ └── Test.hs └── performance │ ├── infinite-loop.f18 │ ├── loop.f18 │ └── unext.f18 └── traced.pdf /.gitignore: -------------------------------------------------------------------------------- 1 | # Ignore emacs backup files: 2 | *~ 3 | \#*\# 4 | 5 | # Compile artifacts 6 | *.hi 7 | *.o 8 | *.tex 9 | *.log 10 | *.hers 11 | 12 | # Sandboxing 13 | dist 14 | cabal-dev 15 | .cabal-sandbox 16 | cabal.sandbox.config 17 | 18 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | The GNU General Public License is a free, copyleft license for 11 | software and other kinds of works. 12 | 13 | The licenses for most software and other practical works are designed 14 | to take away your freedom to share and change the works. By contrast, 15 | the GNU General Public License is intended to guarantee your freedom to 16 | share and change all versions of a program--to make sure it remains free 17 | software for all its users. We, the Free Software Foundation, use the 18 | GNU General Public License for most of our software; it applies also to 19 | any other work released this way by its authors. You can apply it to 20 | your programs, too. 21 | 22 | When we speak of free software, we are referring to freedom, not 23 | price. Our General Public Licenses are designed to make sure that you 24 | have the freedom to distribute copies of free software (and charge for 25 | them if you wish), that you receive source code or can get it if you 26 | want it, that you can change the software or use pieces of it in new 27 | free programs, and that you know you can do these things. 28 | 29 | To protect your rights, we need to prevent others from denying you 30 | these rights or asking you to surrender the rights. Therefore, you have 31 | certain responsibilities if you distribute copies of the software, or if 32 | you modify it: responsibilities to respect the freedom of others. 33 | 34 | For example, if you distribute copies of such a program, whether 35 | gratis or for a fee, you must pass on to the recipients the same 36 | freedoms that you received. You must make sure that they, too, receive 37 | or can get the source code. And you must show them these terms so they 38 | know their rights. 39 | 40 | Developers that use the GNU GPL protect your rights with two steps: 41 | (1) assert copyright on the software, and (2) offer you this License 42 | giving you legal permission to copy, distribute and/or modify it. 43 | 44 | For the developers' and authors' protection, the GPL clearly explains 45 | that there is no warranty for this free software. For both users' and 46 | authors' sake, the GPL requires that modified versions be marked as 47 | changed, so that their problems will not be attributed erroneously to 48 | authors of previous versions. 49 | 50 | Some devices are designed to deny users access to install or run 51 | modified versions of the software inside them, although the manufacturer 52 | can do so. This is fundamentally incompatible with the aim of 53 | protecting users' freedom to change the software. The systematic 54 | pattern of such abuse occurs in the area of products for individuals to 55 | use, which is precisely where it is most unacceptable. Therefore, we 56 | have designed this version of the GPL to prohibit the practice for those 57 | products. If such problems arise substantially in other domains, we 58 | stand ready to extend this provision to those domains in future versions 59 | of the GPL, as needed to protect the freedom of users. 60 | 61 | Finally, every program is threatened constantly by software patents. 62 | States should not allow patents to restrict development and use of 63 | software on general-purpose computers, but in those that do, we wish to 64 | avoid the special danger that patents applied to a free program could 65 | make it effectively proprietary. To prevent this, the GPL assures that 66 | patents cannot be used to render the program non-free. 67 | 68 | The precise terms and conditions for copying, distribution and 69 | modification follow. 70 | 71 | TERMS AND CONDITIONS 72 | 73 | 0. Definitions. 74 | 75 | "This License" refers to version 3 of the GNU General Public License. 76 | 77 | "Copyright" also means copyright-like laws that apply to other kinds of 78 | works, such as semiconductor masks. 79 | 80 | "The Program" refers to any copyrightable work licensed under this 81 | License. Each licensee is addressed as "you". "Licensees" and 82 | "recipients" may be individuals or organizations. 83 | 84 | To "modify" a work means to copy from or adapt all or part of the work 85 | in a fashion requiring copyright permission, other than the making of an 86 | exact copy. The resulting work is called a "modified version" of the 87 | earlier work or a work "based on" the earlier work. 88 | 89 | A "covered work" means either the unmodified Program or a work based 90 | on the Program. 91 | 92 | To "propagate" a work means to do anything with it that, without 93 | permission, would make you directly or secondarily liable for 94 | infringement under applicable copyright law, except executing it on a 95 | computer or modifying a private copy. Propagation includes copying, 96 | distribution (with or without modification), making available to the 97 | public, and in some countries other activities as well. 98 | 99 | To "convey" a work means any kind of propagation that enables other 100 | parties to make or receive copies. Mere interaction with a user through 101 | a computer network, with no transfer of a copy, is not conveying. 102 | 103 | An interactive user interface displays "Appropriate Legal Notices" 104 | to the extent that it includes a convenient and prominently visible 105 | feature that (1) displays an appropriate copyright notice, and (2) 106 | tells the user that there is no warranty for the work (except to the 107 | extent that warranties are provided), that licensees may convey the 108 | work under this License, and how to view a copy of this License. If 109 | the interface presents a list of user commands or options, such as a 110 | menu, a prominent item in the list meets this criterion. 111 | 112 | 1. Source Code. 113 | 114 | The "source code" for a work means the preferred form of the work 115 | for making modifications to it. "Object code" means any non-source 116 | form of a work. 117 | 118 | A "Standard Interface" means an interface that either is an official 119 | standard defined by a recognized standards body, or, in the case of 120 | interfaces specified for a particular programming language, one that 121 | is widely used among developers working in that language. 122 | 123 | The "System Libraries" of an executable work include anything, other 124 | than the work as a whole, that (a) is included in the normal form of 125 | packaging a Major Component, but which is not part of that Major 126 | Component, and (b) serves only to enable use of the work with that 127 | Major Component, or to implement a Standard Interface for which an 128 | implementation is available to the public in source code form. A 129 | "Major Component", in this context, means a major essential component 130 | (kernel, window system, and so on) of the specific operating system 131 | (if any) on which the executable work runs, or a compiler used to 132 | produce the work, or an object code interpreter used to run it. 133 | 134 | The "Corresponding Source" for a work in object code form means all 135 | the source code needed to generate, install, and (for an executable 136 | work) run the object code and to modify the work, including scripts to 137 | control those activities. However, it does not include the work's 138 | System Libraries, or general-purpose tools or generally available free 139 | programs which are used unmodified in performing those activities but 140 | which are not part of the work. For example, Corresponding Source 141 | includes interface definition files associated with source files for 142 | the work, and the source code for shared libraries and dynamically 143 | linked subprograms that the work is specifically designed to require, 144 | such as by intimate data communication or control flow between those 145 | subprograms and other parts of the work. 146 | 147 | The Corresponding Source need not include anything that users 148 | can regenerate automatically from other parts of the Corresponding 149 | Source. 150 | 151 | The Corresponding Source for a work in source code form is that 152 | same work. 153 | 154 | 2. Basic Permissions. 155 | 156 | All rights granted under this License are granted for the term of 157 | copyright on the Program, and are irrevocable provided the stated 158 | conditions are met. This License explicitly affirms your unlimited 159 | permission to run the unmodified Program. The output from running a 160 | covered work is covered by this License only if the output, given its 161 | content, constitutes a covered work. This License acknowledges your 162 | rights of fair use or other equivalent, as provided by copyright law. 163 | 164 | You may make, run and propagate covered works that you do not 165 | convey, without conditions so long as your license otherwise remains 166 | in force. You may convey covered works to others for the sole purpose 167 | of having them make modifications exclusively for you, or provide you 168 | with facilities for running those works, provided that you comply with 169 | the terms of this License in conveying all material for which you do 170 | not control copyright. Those thus making or running the covered works 171 | for you must do so exclusively on your behalf, under your direction 172 | and control, on terms that prohibit them from making any copies of 173 | your copyrighted material outside their relationship with you. 174 | 175 | Conveying under any other circumstances is permitted solely under 176 | the conditions stated below. Sublicensing is not allowed; section 10 177 | makes it unnecessary. 178 | 179 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 180 | 181 | No covered work shall be deemed part of an effective technological 182 | measure under any applicable law fulfilling obligations under article 183 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 184 | similar laws prohibiting or restricting circumvention of such 185 | measures. 186 | 187 | When you convey a covered work, you waive any legal power to forbid 188 | circumvention of technological measures to the extent such circumvention 189 | is effected by exercising rights under this License with respect to 190 | the covered work, and you disclaim any intention to limit operation or 191 | modification of the work as a means of enforcing, against the work's 192 | users, your or third parties' legal rights to forbid circumvention of 193 | technological measures. 194 | 195 | 4. Conveying Verbatim Copies. 196 | 197 | You may convey verbatim copies of the Program's source code as you 198 | receive it, in any medium, provided that you conspicuously and 199 | appropriately publish on each copy an appropriate copyright notice; 200 | keep intact all notices stating that this License and any 201 | non-permissive terms added in accord with section 7 apply to the code; 202 | keep intact all notices of the absence of any warranty; and give all 203 | recipients a copy of this License along with the Program. 204 | 205 | You may charge any price or no price for each copy that you convey, 206 | and you may offer support or warranty protection for a fee. 207 | 208 | 5. Conveying Modified Source Versions. 209 | 210 | You may convey a work based on the Program, or the modifications to 211 | produce it from the Program, in the form of source code under the 212 | terms of section 4, provided that you also meet all of these conditions: 213 | 214 | a) The work must carry prominent notices stating that you modified 215 | it, and giving a relevant date. 216 | 217 | b) The work must carry prominent notices stating that it is 218 | released under this License and any conditions added under section 219 | 7. This requirement modifies the requirement in section 4 to 220 | "keep intact all notices". 221 | 222 | c) You must license the entire work, as a whole, under this 223 | License to anyone who comes into possession of a copy. This 224 | License will therefore apply, along with any applicable section 7 225 | additional terms, to the whole of the work, and all its parts, 226 | regardless of how they are packaged. This License gives no 227 | permission to license the work in any other way, but it does not 228 | invalidate such permission if you have separately received it. 229 | 230 | d) If the work has interactive user interfaces, each must display 231 | Appropriate Legal Notices; however, if the Program has interactive 232 | interfaces that do not display Appropriate Legal Notices, your 233 | work need not make them do so. 234 | 235 | A compilation of a covered work with other separate and independent 236 | works, which are not by their nature extensions of the covered work, 237 | and which are not combined with it such as to form a larger program, 238 | in or on a volume of a storage or distribution medium, is called an 239 | "aggregate" if the compilation and its resulting copyright are not 240 | used to limit the access or legal rights of the compilation's users 241 | beyond what the individual works permit. Inclusion of a covered work 242 | in an aggregate does not cause this License to apply to the other 243 | parts of the aggregate. 244 | 245 | 6. Conveying Non-Source Forms. 246 | 247 | You may convey a covered work in object code form under the terms 248 | of sections 4 and 5, provided that you also convey the 249 | machine-readable Corresponding Source under the terms of this License, 250 | in one of these ways: 251 | 252 | a) Convey the object code in, or embodied in, a physical product 253 | (including a physical distribution medium), accompanied by the 254 | Corresponding Source fixed on a durable physical medium 255 | customarily used for software interchange. 256 | 257 | b) Convey the object code in, or embodied in, a physical product 258 | (including a physical distribution medium), accompanied by a 259 | written offer, valid for at least three years and valid for as 260 | long as you offer spare parts or customer support for that product 261 | model, to give anyone who possesses the object code either (1) a 262 | copy of the Corresponding Source for all the software in the 263 | product that is covered by this License, on a durable physical 264 | medium customarily used for software interchange, for a price no 265 | more than your reasonable cost of physically performing this 266 | conveying of source, or (2) access to copy the 267 | Corresponding Source from a network server at no charge. 268 | 269 | c) Convey individual copies of the object code with a copy of the 270 | written offer to provide the Corresponding Source. This 271 | alternative is allowed only occasionally and noncommercially, and 272 | only if you received the object code with such an offer, in accord 273 | with subsection 6b. 274 | 275 | d) Convey the object code by offering access from a designated 276 | place (gratis or for a charge), and offer equivalent access to the 277 | Corresponding Source in the same way through the same place at no 278 | further charge. You need not require recipients to copy the 279 | Corresponding Source along with the object code. If the place to 280 | copy the object code is a network server, the Corresponding Source 281 | may be on a different server (operated by you or a third party) 282 | that supports equivalent copying facilities, provided you maintain 283 | clear directions next to the object code saying where to find the 284 | Corresponding Source. Regardless of what server hosts the 285 | Corresponding Source, you remain obligated to ensure that it is 286 | available for as long as needed to satisfy these requirements. 287 | 288 | e) Convey the object code using peer-to-peer transmission, provided 289 | you inform other peers where the object code and Corresponding 290 | Source of the work are being offered to the general public at no 291 | charge under subsection 6d. 292 | 293 | A separable portion of the object code, whose source code is excluded 294 | from the Corresponding Source as a System Library, need not be 295 | included in conveying the object code work. 296 | 297 | A "User Product" is either (1) a "consumer product", which means any 298 | tangible personal property which is normally used for personal, family, 299 | or household purposes, or (2) anything designed or sold for incorporation 300 | into a dwelling. In determining whether a product is a consumer product, 301 | doubtful cases shall be resolved in favor of coverage. For a particular 302 | product received by a particular user, "normally used" refers to a 303 | typical or common use of that class of product, regardless of the status 304 | of the particular user or of the way in which the particular user 305 | actually uses, or expects or is expected to use, the product. A product 306 | is a consumer product regardless of whether the product has substantial 307 | commercial, industrial or non-consumer uses, unless such uses represent 308 | the only significant mode of use of the product. 309 | 310 | "Installation Information" for a User Product means any methods, 311 | procedures, authorization keys, or other information required to install 312 | and execute modified versions of a covered work in that User Product from 313 | a modified version of its Corresponding Source. The information must 314 | suffice to ensure that the continued functioning of the modified object 315 | code is in no case prevented or interfered with solely because 316 | modification has been made. 317 | 318 | If you convey an object code work under this section in, or with, or 319 | specifically for use in, a User Product, and the conveying occurs as 320 | part of a transaction in which the right of possession and use of the 321 | User Product is transferred to the recipient in perpetuity or for a 322 | fixed term (regardless of how the transaction is characterized), the 323 | Corresponding Source conveyed under this section must be accompanied 324 | by the Installation Information. But this requirement does not apply 325 | if neither you nor any third party retains the ability to install 326 | modified object code on the User Product (for example, the work has 327 | been installed in ROM). 328 | 329 | The requirement to provide Installation Information does not include a 330 | requirement to continue to provide support service, warranty, or updates 331 | for a work that has been modified or installed by the recipient, or for 332 | the User Product in which it has been modified or installed. Access to a 333 | network may be denied when the modification itself materially and 334 | adversely affects the operation of the network or violates the rules and 335 | protocols for communication across the network. 336 | 337 | Corresponding Source conveyed, and Installation Information provided, 338 | in accord with this section must be in a format that is publicly 339 | documented (and with an implementation available to the public in 340 | source code form), and must require no special password or key for 341 | unpacking, reading or copying. 342 | 343 | 7. Additional Terms. 344 | 345 | "Additional permissions" are terms that supplement the terms of this 346 | License by making exceptions from one or more of its conditions. 347 | Additional permissions that are applicable to the entire Program shall 348 | be treated as though they were included in this License, to the extent 349 | that they are valid under applicable law. If additional permissions 350 | apply only to part of the Program, that part may be used separately 351 | under those permissions, but the entire Program remains governed by 352 | this License without regard to the additional permissions. 353 | 354 | When you convey a copy of a covered work, you may at your option 355 | remove any additional permissions from that copy, or from any part of 356 | it. (Additional permissions may be written to require their own 357 | removal in certain cases when you modify the work.) You may place 358 | additional permissions on material, added by you to a covered work, 359 | for which you have or can give appropriate copyright permission. 360 | 361 | Notwithstanding any other provision of this License, for material you 362 | add to a covered work, you may (if authorized by the copyright holders of 363 | that material) supplement the terms of this License with terms: 364 | 365 | a) Disclaiming warranty or limiting liability differently from the 366 | terms of sections 15 and 16 of this License; or 367 | 368 | b) Requiring preservation of specified reasonable legal notices or 369 | author attributions in that material or in the Appropriate Legal 370 | Notices displayed by works containing it; or 371 | 372 | c) Prohibiting misrepresentation of the origin of that material, or 373 | requiring that modified versions of such material be marked in 374 | reasonable ways as different from the original version; or 375 | 376 | d) Limiting the use for publicity purposes of names of licensors or 377 | authors of the material; or 378 | 379 | e) Declining to grant rights under trademark law for use of some 380 | trade names, trademarks, or service marks; or 381 | 382 | f) Requiring indemnification of licensors and authors of that 383 | material by anyone who conveys the material (or modified versions of 384 | it) with contractual assumptions of liability to the recipient, for 385 | any liability that these contractual assumptions directly impose on 386 | those licensors and authors. 387 | 388 | All other non-permissive additional terms are considered "further 389 | restrictions" within the meaning of section 10. If the Program as you 390 | received it, or any part of it, contains a notice stating that it is 391 | governed by this License along with a term that is a further 392 | restriction, you may remove that term. If a license document contains 393 | a further restriction but permits relicensing or conveying under this 394 | License, you may add to a covered work material governed by the terms 395 | of that license document, provided that the further restriction does 396 | not survive such relicensing or conveying. 397 | 398 | If you add terms to a covered work in accord with this section, you 399 | must place, in the relevant source files, a statement of the 400 | additional terms that apply to those files, or a notice indicating 401 | where to find the applicable terms. 402 | 403 | Additional terms, permissive or non-permissive, may be stated in the 404 | form of a separately written license, or stated as exceptions; 405 | the above requirements apply either way. 406 | 407 | 8. Termination. 408 | 409 | You may not propagate or modify a covered work except as expressly 410 | provided under this License. Any attempt otherwise to propagate or 411 | modify it is void, and will automatically terminate your rights under 412 | this License (including any patent licenses granted under the third 413 | paragraph of section 11). 414 | 415 | However, if you cease all violation of this License, then your 416 | license from a particular copyright holder is reinstated (a) 417 | provisionally, unless and until the copyright holder explicitly and 418 | finally terminates your license, and (b) permanently, if the copyright 419 | holder fails to notify you of the violation by some reasonable means 420 | prior to 60 days after the cessation. 421 | 422 | Moreover, your license from a particular copyright holder is 423 | reinstated permanently if the copyright holder notifies you of the 424 | violation by some reasonable means, this is the first time you have 425 | received notice of violation of this License (for any work) from that 426 | copyright holder, and you cure the violation prior to 30 days after 427 | your receipt of the notice. 428 | 429 | Termination of your rights under this section does not terminate the 430 | licenses of parties who have received copies or rights from you under 431 | this License. If your rights have been terminated and not permanently 432 | reinstated, you do not qualify to receive new licenses for the same 433 | material under section 10. 434 | 435 | 9. Acceptance Not Required for Having Copies. 436 | 437 | You are not required to accept this License in order to receive or 438 | run a copy of the Program. Ancillary propagation of a covered work 439 | occurring solely as a consequence of using peer-to-peer transmission 440 | to receive a copy likewise does not require acceptance. However, 441 | nothing other than this License grants you permission to propagate or 442 | modify any covered work. These actions infringe copyright if you do 443 | not accept this License. Therefore, by modifying or propagating a 444 | covered work, you indicate your acceptance of this License to do so. 445 | 446 | 10. Automatic Licensing of Downstream Recipients. 447 | 448 | Each time you convey a covered work, the recipient automatically 449 | receives a license from the original licensors, to run, modify and 450 | propagate that work, subject to this License. You are not responsible 451 | for enforcing compliance by third parties with this License. 452 | 453 | An "entity transaction" is a transaction transferring control of an 454 | organization, or substantially all assets of one, or subdividing an 455 | organization, or merging organizations. If propagation of a covered 456 | work results from an entity transaction, each party to that 457 | transaction who receives a copy of the work also receives whatever 458 | licenses to the work the party's predecessor in interest had or could 459 | give under the previous paragraph, plus a right to possession of the 460 | Corresponding Source of the work from the predecessor in interest, if 461 | the predecessor has it or can get it with reasonable efforts. 462 | 463 | You may not impose any further restrictions on the exercise of the 464 | rights granted or affirmed under this License. For example, you may 465 | not impose a license fee, royalty, or other charge for exercise of 466 | rights granted under this License, and you may not initiate litigation 467 | (including a cross-claim or counterclaim in a lawsuit) alleging that 468 | any patent claim is infringed by making, using, selling, offering for 469 | sale, or importing the Program or any portion of it. 470 | 471 | 11. Patents. 472 | 473 | A "contributor" is a copyright holder who authorizes use under this 474 | License of the Program or a work on which the Program is based. The 475 | work thus licensed is called the contributor's "contributor version". 476 | 477 | A contributor's "essential patent claims" are all patent claims 478 | owned or controlled by the contributor, whether already acquired or 479 | hereafter acquired, that would be infringed by some manner, permitted 480 | by this License, of making, using, or selling its contributor version, 481 | but do not include claims that would be infringed only as a 482 | consequence of further modification of the contributor version. For 483 | purposes of this definition, "control" includes the right to grant 484 | patent sublicenses in a manner consistent with the requirements of 485 | this License. 486 | 487 | Each contributor grants you a non-exclusive, worldwide, royalty-free 488 | patent license under the contributor's essential patent claims, to 489 | make, use, sell, offer for sale, import and otherwise run, modify and 490 | propagate the contents of its contributor version. 491 | 492 | In the following three paragraphs, a "patent license" is any express 493 | agreement or commitment, however denominated, not to enforce a patent 494 | (such as an express permission to practice a patent or covenant not to 495 | sue for patent infringement). To "grant" such a patent license to a 496 | party means to make such an agreement or commitment not to enforce a 497 | patent against the party. 498 | 499 | If you convey a covered work, knowingly relying on a patent license, 500 | and the Corresponding Source of the work is not available for anyone 501 | to copy, free of charge and under the terms of this License, through a 502 | publicly available network server or other readily accessible means, 503 | then you must either (1) cause the Corresponding Source to be so 504 | available, or (2) arrange to deprive yourself of the benefit of the 505 | patent license for this particular work, or (3) arrange, in a manner 506 | consistent with the requirements of this License, to extend the patent 507 | license to downstream recipients. "Knowingly relying" means you have 508 | actual knowledge that, but for the patent license, your conveying the 509 | covered work in a country, or your recipient's use of the covered work 510 | in a country, would infringe one or more identifiable patents in that 511 | country that you have reason to believe are valid. 512 | 513 | If, pursuant to or in connection with a single transaction or 514 | arrangement, you convey, or propagate by procuring conveyance of, a 515 | covered work, and grant a patent license to some of the parties 516 | receiving the covered work authorizing them to use, propagate, modify 517 | or convey a specific copy of the covered work, then the patent license 518 | you grant is automatically extended to all recipients of the covered 519 | work and works based on it. 520 | 521 | A patent license is "discriminatory" if it does not include within 522 | the scope of its coverage, prohibits the exercise of, or is 523 | conditioned on the non-exercise of one or more of the rights that are 524 | specifically granted under this License. You may not convey a covered 525 | work if you are a party to an arrangement with a third party that is 526 | in the business of distributing software, under which you make payment 527 | to the third party based on the extent of your activity of conveying 528 | the work, and under which the third party grants, to any of the 529 | parties who would receive the covered work from you, a discriminatory 530 | patent license (a) in connection with copies of the covered work 531 | conveyed by you (or copies made from those copies), or (b) primarily 532 | for and in connection with specific products or compilations that 533 | contain the covered work, unless you entered into that arrangement, 534 | or that patent license was granted, prior to 28 March 2007. 535 | 536 | Nothing in this License shall be construed as excluding or limiting 537 | any implied license or other defenses to infringement that may 538 | otherwise be available to you under applicable patent law. 539 | 540 | 12. No Surrender of Others' Freedom. 541 | 542 | If conditions are imposed on you (whether by court order, agreement or 543 | otherwise) that contradict the conditions of this License, they do not 544 | excuse you from the conditions of this License. If you cannot convey a 545 | covered work so as to satisfy simultaneously your obligations under this 546 | License and any other pertinent obligations, then as a consequence you may 547 | not convey it at all. For example, if you agree to terms that obligate you 548 | to collect a royalty for further conveying from those to whom you convey 549 | the Program, the only way you could satisfy both those terms and this 550 | License would be to refrain entirely from conveying the Program. 551 | 552 | 13. Use with the GNU Affero General Public License. 553 | 554 | Notwithstanding any other provision of this License, you have 555 | permission to link or combine any covered work with a work licensed 556 | under version 3 of the GNU Affero General Public License into a single 557 | combined work, and to convey the resulting work. The terms of this 558 | License will continue to apply to the part which is the covered work, 559 | but the special requirements of the GNU Affero General Public License, 560 | section 13, concerning interaction through a network will apply to the 561 | combination as such. 562 | 563 | 14. Revised Versions of this License. 564 | 565 | The Free Software Foundation may publish revised and/or new versions of 566 | the GNU General Public License from time to time. Such new versions will 567 | be similar in spirit to the present version, but may differ in detail to 568 | address new problems or concerns. 569 | 570 | Each version is given a distinguishing version number. If the 571 | Program specifies that a certain numbered version of the GNU General 572 | Public License "or any later version" applies to it, you have the 573 | option of following the terms and conditions either of that numbered 574 | version or of any later version published by the Free Software 575 | Foundation. If the Program does not specify a version number of the 576 | GNU General Public License, you may choose any version ever published 577 | by the Free Software Foundation. 578 | 579 | If the Program specifies that a proxy can decide which future 580 | versions of the GNU General Public License can be used, that proxy's 581 | public statement of acceptance of a version permanently authorizes you 582 | to choose that version for the Program. 583 | 584 | Later license versions may give you additional or different 585 | permissions. However, no additional obligations are imposed on any 586 | author or copyright holder as a result of your choosing to follow a 587 | later version. 588 | 589 | 15. Disclaimer of Warranty. 590 | 591 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 592 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 593 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 594 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 595 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 596 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 597 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 598 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 599 | 600 | 16. Limitation of Liability. 601 | 602 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 603 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 604 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 605 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 606 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 607 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 608 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 609 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 610 | SUCH DAMAGES. 611 | 612 | 17. Interpretation of Sections 15 and 16. 613 | 614 | If the disclaimer of warranty and limitation of liability provided 615 | above cannot be given local legal effect according to their terms, 616 | reviewing courts shall apply local law that most closely approximates 617 | an absolute waiver of all civil liability in connection with the 618 | Program, unless a warranty or assumption of liability accompanies a 619 | copy of the Program in return for a fee. 620 | 621 | END OF TERMS AND CONDITIONS 622 | 623 | How to Apply These Terms to Your New Programs 624 | 625 | If you develop a new program, and you want it to be of the greatest 626 | possible use to the public, the best way to achieve this is to make it 627 | free software which everyone can redistribute and change under these terms. 628 | 629 | To do so, attach the following notices to the program. It is safest 630 | to attach them to the start of each source file to most effectively 631 | state the exclusion of warranty; and each file should have at least 632 | the "copyright" line and a pointer to where the full notice is found. 633 | 634 | 635 | Copyright (C) 636 | 637 | This program is free software: you can redistribute it and/or modify 638 | it under the terms of the GNU General Public License as published by 639 | the Free Software Foundation, either version 3 of the License, or 640 | (at your option) any later version. 641 | 642 | This program is distributed in the hope that it will be useful, 643 | but WITHOUT ANY WARRANTY; without even the implied warranty of 644 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 645 | GNU General Public License for more details. 646 | 647 | You should have received a copy of the GNU General Public License 648 | along with this program. If not, see . 649 | 650 | Also add information on how to contact you by electronic and paper mail. 651 | 652 | If the program does terminal interaction, make it output a short 653 | notice like this when it starts in an interactive mode: 654 | 655 | Copyright (C) 656 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 657 | This is free software, and you are welcome to redistribute it 658 | under certain conditions; type `show c' for details. 659 | 660 | The hypothetical commands `show w' and `show c' should show the appropriate 661 | parts of the General Public License. Of course, your program's commands 662 | might be different; for a GUI interface, you would use an "about box". 663 | 664 | You should also get your employer (if you work as a programmer) or school, 665 | if any, to sign a "copyright disclaimer" for the program, if necessary. 666 | For more information on this, and how to apply and follow the GNU GPL, see 667 | . 668 | 669 | The GNU General Public License does not permit incorporating your program 670 | into proprietary programs. If your program is a subroutine library, you 671 | may consider it more useful to permit linking proprietary applications with 672 | the library. If this is what you want to do, use the GNU Lesser General 673 | Public License instead of this License. But first, please read 674 | . 675 | 676 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # F18A Emulator 2 | 3 | This is a simple F18A emulator. It can run a code on a single core and has some untested support for simulating all 144 cores and the communication between them. It does not emulate any of the chip's IO facilities, however. 4 | 5 | It was originally written to implement a superoptimizer based on [Stochastic Superoptimization][1]; however, it's useful as a standalone program as well. 6 | 7 | [1]: https://cs.stanford.edu/people/sharmar/pubs/asplos291-schkufza.pdf 8 | 9 | ## Installation 10 | 11 | `array-forth` is now up on [Hackage](http://hackage.haskell.org/package/array-forth). You can just install it with: 12 | 13 | cabal install array-forth 14 | 15 | This creates two executables: `array-forth`, which runs the interpreter interactively and `mcmc-demo` that runs an example using the superoptimizer. 16 | 17 | If you want to try optimizing your own programs, you will either have to modify `Main.hs` or write your own program using `Language.ArrayForth.Synthesis`. This is a bit of a pain, but it also allows you to play around with different scoring functions and mutations. If anyone's actually interested, I'd be happy to extract this into a usable executable, but right now it's too slow to be terribly useful. (That said, it should scale well to multiple machines, so if you have a nice cluster...) 18 | 19 | If anyone has any thoughts about speeding up the synthesizer, I would *really* love to hear them! 20 | 21 | ## Features 22 | 23 | ### Emulator 24 | 25 | The emulator has two distinct parts: a library which makes it easy to work with F18A programs and a frontend that includes a nice REPL for playing around with F18A code. 26 | 27 | You can get to the REPL just by running `array-forth`. 28 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /array-forth.cabal: -------------------------------------------------------------------------------- 1 | -- Initial arrayForth.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: array-forth 5 | version: 0.2.1.4 6 | 7 | synopsis: A simple interpreter for arrayForth, the language used on GreenArrays chips. 8 | description: This is a package for working with arrayForth. This is a variant of Forth used by GreenArrays chips. This package contains an arrayForth simulator, two different representations of arrayForth programs and some utilities like parsing. 9 | 10 | It also supports synthesizing arrayForth programs using MCMC. The basic idea is to find arrayForth programs by taking a simple prior distribution of programs and using a randomized hill-climbing algorithm to find a program fulfilling certain tests. 11 | 12 | license: GPL-3 13 | license-file: LICENSE 14 | 15 | author: Tikhon Jelvis 16 | maintainer: Tikhon Jelvis 17 | 18 | category: Language 19 | build-type: Simple 20 | cabal-version: >=1.8 21 | 22 | source-repository head 23 | type: git 24 | location: git://github.com/TikhonJelvis/array-forth.git 25 | 26 | flag synthesis 27 | description: build the mcmc synthesis demo app 28 | default: False 29 | 30 | flag chart 31 | description: build the charting facilities for analyzing the synthesizer 32 | default: False 33 | 34 | 35 | library 36 | exposed-modules: Language.ArrayForth.Core 37 | Language.ArrayForth.Channel 38 | Language.ArrayForth.Distance, 39 | Language.ArrayForth.Interpreter, 40 | Language.ArrayForth.NativeProgram, 41 | Language.ArrayForth.Opcode, 42 | Language.ArrayForth.Parse, 43 | Language.ArrayForth.Program, 44 | Language.ArrayForth.Stack, 45 | Language.ArrayForth.State, 46 | Language.ArrayForth.Synthesis 47 | hs-source-dirs: src 48 | build-depends: base >=4.7 && <=5, 49 | array >=0.4, 50 | mcmc-synthesis >=0.1.2.1, 51 | modular-arithmetic ==1.*, 52 | MonadRandom ==0.1.*, 53 | OddWord >=1.0.0, 54 | split ==0.1.*, 55 | vector >=0.9 && <0.11 56 | 57 | GHC-options: -Wall -funbox-strict-fields -rtsopts 58 | 59 | executable mcmc-demo 60 | Main-is: src/Main.hs 61 | 62 | if flag(synthesis) 63 | build-depends: array-forth, 64 | base >4.7 && <=5, 65 | mcmc-synthesis >=0.1.2.1, 66 | MonadRandom ==0.1.*, 67 | optparse-applicative >=0.7 && <0.10 68 | GHC-options: -Wall -rtsopts 69 | else 70 | buildable: False 71 | 72 | executable array-forth 73 | Main-is: src/Run.hs 74 | 75 | build-depends: array-forth, 76 | base >4.7 && <=5, 77 | split ==0.1.*, 78 | vector >=0.9 && <0.11 79 | 80 | GHC-options: -Wall -rtsopts 81 | 82 | executable chart 83 | Main-is: src/Chart.hs 84 | 85 | if flag(chart) 86 | build-depends: array-forth, 87 | base >4.7 && <=5, 88 | Chart >=0.16 && <1.0, 89 | mcmc-synthesis >=0.1.2.1, 90 | MonadRandom ==0.1.*, 91 | optparse-applicative >=0.7 && <0.10 92 | 93 | GHC-options: -Wall -rtsopts -O2 94 | else 95 | buildable: False 96 | 97 | test-suite test-array-forth 98 | Type: exitcode-stdio-1.0 99 | Main-is: test/Language/ArrayForth/Test.hs 100 | 101 | build-depends: array-forth, 102 | base >4.7 && <=5, 103 | HUnit >= 1 && < 2, 104 | QuickCheck >= 2 && <3, 105 | test-framework-hunit ==0.*, 106 | test-framework-quickcheck2 ==0.*, 107 | test-framework-th ==0.* 108 | -------------------------------------------------------------------------------- /basic.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TikhonJelvis/array-forth/66d3d20af970d8be256f7999b1dd35ea69200045/basic.pdf -------------------------------------------------------------------------------- /graphs/complex distance.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TikhonJelvis/array-forth/66d3d20af970d8be256f7999b1dd35ea69200045/graphs/complex distance.pdf -------------------------------------------------------------------------------- /graphs/normal distance.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TikhonJelvis/array-forth/66d3d20af970d8be256f7999b1dd35ea69200045/graphs/normal distance.pdf -------------------------------------------------------------------------------- /graphs/traces.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TikhonJelvis/array-forth/66d3d20af970d8be256f7999b1dd35ea69200045/graphs/traces.pdf -------------------------------------------------------------------------------- /mutations.org: -------------------------------------------------------------------------------- 1 | * Useful F18A-specific mutations: 2 | - opposites: push, pop... 3 | - "uninitialized" values 4 | - problem-specific "meaningful" instructions 5 | - too much control flow 6 | - common patterns 7 | - "uninitialized" stack? 8 | - self-modification? 9 | - disallow jump outside of code? 10 | - disallow all jumps? 11 | -------------------------------------------------------------------------------- /notes.org: -------------------------------------------------------------------------------- 1 | * Evaluation Function 2 | ** Problem 3 | - gets stuck around bad scores: ≈ -13—-10 4 | - worst score would be ≈-18 5 | - really bad scores might correspond to *good* programs! 6 | - does not reflect program semantics well 7 | - most close programs *do not* differ by a small number of bits 8 | - is actively counter-productive for things like bitwise not 9 | - can find relatively odd almost-correct programs 10 | ** Benchmarks 11 | - try finding better function from existing benchmarks 12 | - some sort of (non?)linear regression? 13 | - I don't think this would solve the fundamental issues 14 | - let programmer specify it somehow? 15 | - do more random cases help smooth out the evaluation function? 16 | - fails to address the fundamental issue 17 | - more cases would only be good for catching weird edge cases 18 | - have some way of evaluating the evaluation function (very meta) 19 | - a graph would probably help 20 | - surprise: turns out they're uniformly horrible 21 | ** Uniqueness 22 | - come up with a bunch of metrics and then look for ones that stand 23 | out rather than having a preconceived notion of "goodness" 24 | - this really needs fleshing out and I haven't explained it very well 25 | ** Random Thoughts 26 | - look at program traces instead of results 27 | - trace inherently carry more information 28 | - especially for Forth, the results are far too volatile 29 | - maybe look at Δtraces—something like how states change rather than 30 | the states themselve 31 | - philosophy: the distance function depends more on the programs 32 | than their outputs 33 | - rather than trying to see how close two outputs are, in some 34 | sense (like popCount or arithmetic), estimate how far a program 35 | to generate them would be 36 | - maybe mix popCount and so on with one or two layers of 37 | transformations based on instructions? That is: take the answer 38 | and apply a bunch of random operations to it like bitwise 39 | negation and shifting, and average the popCount metric over 40 | those 41 | - hedge: try to account for weird shapes in the evaluation function 42 | rather than assuming any particular pattern ahead of time. 43 | * Prior Distribution 44 | - how can we come up with a better distribution of mutations? 45 | - look at existing code 46 | - find common patterns 47 | - build up model of code: something like a Markov chain? 48 | - there simply isn't enough existing code to make this 49 | worthwhile 50 | - immediate problem: multi-instruction sequences 51 | - having a noop like b! !b in the candidate stalls the search 52 | - should be easy to fix by tweaking the jump distribution 53 | * Test Cases 54 | - randomly generate initial cases 55 | - fix things like unspecified parts of the stack 56 | - use something like CEGIS 57 | - would need a rebuilt verifier—maybe with sbv (I hope)? 58 | - write my own SKETCH frontend, based on sbv? 59 | * Numbers 60 | - relatively good at generating programs, especially with certain 61 | constraints (large memory usage, high bit precision, 62 | self-modifying, branching, looping...) 63 | - relatively *bad* at finding good numeric constants 64 | - could be helped by better distribution over constants: I 65 | currently just have a uniform distribution, which is indubitably 66 | horrible. 67 | - however: perhaps it is better to use an intelligent solver for 68 | just this? That is: MCMC generates a program with a constant, 69 | but without specifying the *value* of the constant; when running 70 | the test, we could use a different solver to find a good value 71 | for the constant (if possible) 72 | - perhaps this is too slow? maybe a very specific solver/search 73 | algorithm would help here? 74 | -------------------------------------------------------------------------------- /out.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TikhonJelvis/array-forth/66d3d20af970d8be256f7999b1dd35ea69200045/out.pdf -------------------------------------------------------------------------------- /src/Chart.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module Main where 5 | 6 | import Control.Arrow ((&&&)) 7 | import Control.Monad.Random (evalRandIO) 8 | 9 | import Data.Bits (complement) 10 | import Data.Functor ((<$>)) 11 | import Data.Function (on) 12 | import Data.List 13 | import Data.Monoid ((<>), Sum (..), Monoid) 14 | 15 | import Graphics.Rendering.Chart.Simple 16 | 17 | import Language.ArrayForth.Distance (Distance, matching, registers) 18 | import Language.ArrayForth.Interpreter (eval) 19 | import Language.ArrayForth.Parse () 20 | import Language.ArrayForth.Program (Program, load, readProgram) 21 | import qualified Language.ArrayForth.Stack as S 22 | import Language.ArrayForth.State (State (..), startState) 23 | import Language.ArrayForth.Synthesis (DefaultScore (..), 24 | defaultMutations, defaultOps, 25 | evaluate, trace, withPerformance) 26 | import qualified Language.Synthesis.Distribution as Distr 27 | import Language.Synthesis.Synthesis (Problem (..), Score (..), 28 | runningBest, synthesizeMhList) 29 | 30 | import Options.Applicative 31 | 32 | import Text.Printf 33 | 34 | data Options = Options { out :: Maybe FilePath 35 | , problem :: Problem Program DefaultScore 36 | , points, resolution :: Int 37 | , maxScore :: Maybe Double } 38 | 39 | options :: Parser Options 40 | options = Options 41 | <$> nullOption (long "out" 42 | <> short 'o' 43 | <> value Nothing 44 | <> metavar "PATH" 45 | <> reader (return . Just) 46 | <> help "Filepath for the resulting chart.") 47 | <*> nullOption (long "problem" 48 | <> short 'p' 49 | <> value inclusiveOr 50 | <> metavar "NAME" 51 | <> eitherReader parseProblem 52 | <> help problemHelp) 53 | <*> option (long "samples" 54 | <> short 's' 55 | <> value 2500 56 | <> metavar "SAMPLES" 57 | <> help "The number of samples to take. Each sample corresponds to something like ~6k programs considered.") 58 | <*> option (long "resolution" 59 | <> short 'r' 60 | <> value 25 61 | <> metavar "N" 62 | <> help "Sample every N generated candidate programs.") 63 | <*> nullOption (long "max" 64 | <> short 'x' 65 | <> value Nothing 66 | <> metavar "MAX_SCORE" 67 | <> reader (return . Just . read) 68 | <> help "Stop at the given score.") 69 | 70 | -- I wish existential types were better :/ 71 | problems :: [(String, Problem Program DefaultScore)] 72 | problems = [("traceOr", traceOr), ("inclusiveOr", inclusiveOr)] 73 | 74 | problemHelp :: String 75 | problemHelp = printf "The problem to run. Currently, the valid choices are:\n%s" names 76 | where names = init . unlines $ map (((replicate 30 ' ' ++ "- ") ++ ) . fst) problems 77 | 78 | parseProblem :: String -> Either String (Problem Program DefaultScore) 79 | parseProblem problem = case lookup problem problems of 80 | Just p -> return p 81 | Nothing -> Left $ printf "Problem name %s is not recognized." problem 82 | 83 | range :: [Double] 84 | range = [0..] 85 | 86 | main :: IO () 87 | main = execParser go >>= run 88 | where go = info (helper <*> options) 89 | (fullDesc 90 | <> progDesc "Synthesize arrayForth programs using different strategies and graph the performances of the evaluation function." 91 | <> header "chart - chart the performance of MCMC synthesis") 92 | 93 | good :: Score s => (Program, s) -> Bool 94 | good (_, val) = toScore val >= 0 95 | 96 | run :: Options -> IO () 97 | run Options {..} = 98 | do programs <- evalRandIO $ synthesizeMhList problem 99 | let getMax = maybe id (takeWhile . (<)) maxScore 100 | process = take points . sample resolution . movingAvg (2 * resolution) . drop 10 101 | results = snd . head <$> group programs 102 | scores = process . getMax $ map toScore results 103 | correctness = take (length scores) . process $ map corr results 104 | printf "Result: %s.\n" . show $ programs !! (resolution * points) 105 | case out of 106 | Just filepath -> plotPDF filepath range scores Solid correctness Solid 107 | Nothing -> return () 108 | 109 | corr :: DefaultScore -> Double 110 | corr (DefaultScore a _) = a 111 | 112 | sample :: Int -> [a] -> [a] 113 | sample _ [] = [] 114 | sample n (x:xs) = x : sample n (drop n xs) 115 | 116 | movingAvg :: Fractional a => Int -> [a] -> [a] 117 | movingAvg _ [] = [0] 118 | movingAvg window ls@(_:xs) = (sum start / genericLength start) : movingAvg window xs 119 | where start = take window ls 120 | 121 | cases :: [State] 122 | cases = [startState {t = 0, s = 123}, startState {t = maxBound, s = 123}, 123 | startState {t = 1, s = 123}, startState {t = maxBound - 1, s = 123}, 124 | startState {t = 37, s = 123}, startState {t = 52, s = 123}] 125 | 126 | orSpec :: Program 127 | orSpec = "over over or a! and a or" 128 | 129 | inclusiveOr :: Problem Program DefaultScore 130 | inclusiveOr = Problem { score = evaluate orSpec cases distance 131 | , prior = Distr.constant orSpec 132 | , jump = defaultMutations } 133 | where complemented σ₁ σ₂@State {t = t₂} = 134 | Sum . negate . getSum . registers [t] σ₁ $ σ₂ {t = complement t₂} 135 | distance = registers [t] 136 | 137 | traceOr :: Problem Program DefaultScore 138 | traceOr = Problem { score = trace orSpec cases $ withPerformance sc 139 | , prior = Distr.constant orSpec 140 | , jump = defaultMutations } 141 | where sc = matching (s &&& t) <> (registers [t] `on` last) 142 | -------------------------------------------------------------------------------- /src/Language/ArrayForth/Channel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MonadComprehensions #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | -- | Defines the basic operations for reading and writing through ports. 5 | -- 6 | -- Each core has four ports connecting it to its neighbors. The cores 7 | -- around the edges have ports connected to IO devices. A "Channel" is 8 | -- just a type containing the four ports that you can write to or read 9 | -- from. 10 | module Language.ArrayForth.Channel where 11 | 12 | import Control.Applicative ((<|>)) 13 | 14 | import Data.Bits (testBit) 15 | import Data.Monoid (Monoid (..)) 16 | 17 | import Language.ArrayForth.Opcode (F18Word) 18 | 19 | -- | A channel representing the four communication directions a core 20 | -- may use. In practice, these will either be hooked up to other cores 21 | -- or to IO. Nothing represents no message; if there is a word, 22 | -- execution will block. 23 | data Channel = Channel { right, down, left, up :: Maybe F18Word } deriving (Show, Eq) 24 | 25 | -- | The four possible port directions. 26 | data Port = R | D | L | U deriving (Show, Eq, Bounded, Enum) 27 | 28 | -- The monoid instance is based around *replacement*. 29 | instance Monoid Channel where 30 | mempty = emptyChannel 31 | c₁ `mappend` c₂ = Channel { right = right c₁ <|> right c₂ 32 | , down = down c₁ <|> down c₂ 33 | , left = left c₁ <|> left c₂ 34 | , up = up c₁ <|> up c₂ } 35 | 36 | -- | An empty channel has no reads or writes and doesn't block execution. 37 | emptyChannel :: Channel 38 | emptyChannel = Channel Nothing Nothing Nothing Nothing 39 | 40 | -- | Write to the ports specified by the given memory address. This 41 | -- will clear all the channels not being written to (by setting them 42 | -- to Nothing). 43 | -- 44 | -- The ports to use are specified by bits 5–8 of the address. These 45 | -- bits correspond respectively to up, left, down and right. Bits 5 46 | -- and 7 are inverted—0 turns the channel *on*. 47 | writePort :: F18Word -- ^ The address to write to. Only bits 5–8 are considered. 48 | -> F18Word -- ^ The word to write to the channel. 49 | -> Channel -- ^ The resulting channel, with any unused ports empty. 50 | writePort ports word = Channel { right = [ word | testBit ports 8 ] 51 | , down = [ word | not $ testBit ports 7 ] 52 | , left = [ word | testBit ports 6 ] 53 | , up = [ word | not $ testBit ports 5 ] } 54 | 55 | -- | Read the inputs from the ports specified by the given 56 | -- address. The address is handled the same way as in 57 | -- @'writePort'@. Returns @Nothing@ if blocked on the read. 58 | -- 59 | -- If more than one of the read ports has data, this currently just 60 | -- chooses the first one based on the right, down, left, up order. I 61 | -- don't know if this is the correct behavior—perhaps I should just 62 | -- xor them together or something? 63 | readPort :: F18Word -> Channel -> Maybe F18Word 64 | readPort ports Channel {..} = [ word | testBit ports 8, word <- right ] 65 | <|> [ word | not $ testBit ports 7, word <- down ] 66 | <|> [ word | testBit ports 6, word <- left ] 67 | <|> [ word | not $ testBit ports 5, word <- up ] 68 | -------------------------------------------------------------------------------- /src/Language/ArrayForth/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE MonadComprehensions #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | -- | This module defines a type representing the location of a core in 7 | -- the 8 × 18 grid. 8 | -- 9 | -- All of the actually interesting code is in the typeclass instances. 10 | module Language.ArrayForth.Core where 11 | 12 | import Data.Modular 13 | 14 | import Text.Printf (printf) 15 | 16 | -- | The address of a core. There are 144 cores in an 8 × 18 17 | -- array. The address has the row number followed by the column 18 | -- number. 19 | -- 20 | -- As a string, the core addresses are displayed as a single 21 | -- three-digit number, just like in the GreenArray documentation. So 22 | -- @Core 7 17@ becomes @\"717\"@. 23 | -- 24 | -- Core addresses behave like numbers: you can use numeric literals 25 | -- and add them together. For example, @[0..] :: [Core]@ gets you the 26 | -- list of all the core addresses. @(move core = core + Core 1 1)@ is 27 | -- a function that moves you up and over by one core. 28 | data Core = Core !(ℤ/8) !(ℤ/18) 29 | 30 | -- | Returns all the neighbors of a core. Most cores have four 31 | -- neighbors; the ones along the edges only have three and the ones at 32 | -- the corners two. 33 | -- 34 | -- They always come in the order right, down, left up, with Nothing in 35 | -- place of non-existant cores. 36 | neighbors :: Core -> [Maybe Core] 37 | neighbors core@(Core row col) = [ [ core + Core 1 0 | row /= maxBound ] 38 | , [ core + Core 0 1 | col /= maxBound ] 39 | , [ core + Core (-1) 0 | row /= minBound ] 40 | , [ core + Core 0 (- 1) | col /= minBound ] ] 41 | 42 | -- Follows the same format as the documentation does: (7, 17) becomes 717. 43 | instance Show Core where show (Core row col) = printf "%d%.2d" (unMod row) (unMod col) 44 | 45 | deriving instance Eq Core 46 | deriving instance Ord Core 47 | 48 | instance Enum Core where 49 | fromEnum (Core r c) = fromInteger $ unMod r * 18 + unMod c 50 | toEnum n 51 | | n >= 0 && n < 144 = Core (toMod' $ n `div` 18) (toMod' $ n `mod` 18) 52 | | otherwise = error "Core index out of bounds." 53 | 54 | -- Taken directly from the documentation for Enum: 55 | enumFrom x = enumFromTo x maxBound 56 | enumFromThen x y = enumFromThenTo x y bound 57 | where bound | fromEnum y >= fromEnum x = maxBound 58 | | otherwise = minBound 59 | 60 | instance Bounded Core where 61 | minBound = Core 0 0 62 | maxBound = Core 7 17 63 | 64 | -- Core addresses from a group, eh? 65 | instance Num Core where 66 | fromInteger = toEnum . fromIntegral 67 | 68 | Core r₁ c₁ + Core r₂ c₂ = Core (r₁ + r₂) (c₁ + c₂) 69 | Core r₁ c₁ * Core r₂ c₂ = Core (r₁ * r₂) (c₁ * c₂) 70 | 71 | signum (Core r c) = Core (signum r) (signum c) 72 | abs (Core r c) = Core (abs r) (abs c) 73 | negate (Core r c) = Core (negate r) (negate c) 74 | -------------------------------------------------------------------------------- /src/Language/ArrayForth/Distance.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | module Language.ArrayForth.Distance where 3 | 4 | import Data.Bits (Bits, popCount, xor) 5 | import Data.List (genericLength) 6 | import Data.Maybe (fromJust) 7 | import Data.Monoid 8 | 9 | import Language.ArrayForth.Interpreter (Trace) 10 | import Language.ArrayForth.Opcode (F18Word) 11 | import Language.ArrayForth.State 12 | 13 | import Language.Synthesis.Synthesis (Score (..)) 14 | 15 | type Distance = Sum Double 16 | 17 | instance Score Distance where toScore = getSum 18 | 19 | -- | Counts the number of bits that differ between two numbers. 20 | countBits :: (Integral n, Bits n) => n -> n -> Int 21 | countBits n₁ n₂ = popCount $ (fromIntegral n₁ :: Int) `xor` fromIntegral n₂ 22 | 23 | -- | Return a distance function that counts the different bits between 24 | -- the given registers. You could use it like `compareRegisters [s, t]`. 25 | registers :: [State -> F18Word] -> (State -> State -> Distance) 26 | registers regs s₁ s₂ = Sum . fromIntegral . sum $ zipWith countBits (go s₁) (go s₂) 27 | where go state = map ($ state) regs 28 | 29 | -- | Returns a distance function that counts the different bits 30 | -- between the given memory locations. 31 | locations :: [F18Word] -> (State -> State -> Distance) 32 | locations addresses s₁ s₂ = Sum . fromIntegral . sum $ zipWith countBits (go s₁) (go s₂) 33 | where go state = map (fromJust . (memory state !)) addresses 34 | 35 | -- | Returns a score that counts the number of matching states 36 | -- according to some projection function. 37 | matching :: Eq a => (State -> a) -> (Trace -> Trace -> Distance) 38 | matching f t₁ t₂ = Sum $ -(genericLength t₂ - resultLength) 39 | where resultLength = genericLength $ filter (`elem` map f t₁) (map f t₂) -------------------------------------------------------------------------------- /src/Language/ArrayForth/Interpreter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MonadComprehensions #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | module Language.ArrayForth.Interpreter where 5 | 6 | import Data.Bits 7 | import Data.Functor ((<$>)) 8 | import Data.Maybe (fromJust, fromMaybe, mapMaybe) 9 | 10 | import Language.ArrayForth.NativeProgram 11 | import Language.ArrayForth.Opcode 12 | import Language.ArrayForth.State 13 | 14 | -- | A trace of a progam is the state after every word is executed. 15 | type Trace = [State] 16 | 17 | -- | Runs a single word's worth of instructions starting from the 18 | -- given state, returning the intermediate states for each executed 19 | -- opcode. 20 | wordAll :: Instrs -> State -> [State] 21 | wordAll (Instrs a b c d) state = 22 | let s₁ = [execute a state] 23 | s₂ = if endWord a then s₁ else run b s₁ 24 | s₃ = if endWord a || endWord b 25 | then s₂ else run c s₂ in 26 | if endWord a || endWord b || endWord c then s₃ else s₃ ++ run d s₃ 27 | wordAll (Jump3 a b c addr) state = let s₁ = [execute a state] 28 | s₂ = if endWord a then s₁ else run b s₁ in 29 | if endWord a || endWord b 30 | then s₂ else s₂ ++ [jump c addr (last s₂)] 31 | wordAll (Jump2 a b addr) state = let s' = execute a state in 32 | if endWord a then [s'] else [s', jump b addr s'] 33 | wordAll (Jump1 a addr) state = [jump a addr state] 34 | wordAll (Constant _) _ = error "Cannot execute a constant!" 35 | 36 | -- | Runs a single word's worth of instructions, returning only the 37 | -- final state. 38 | word :: Instrs -> State -> State 39 | word instr σ = last $ wordAll instr σ 40 | 41 | -- | Executes a single word in the given state, incrementing 42 | -- the program counter and returning all the intermediate states. 43 | stepAll :: State -> [State] 44 | stepAll state = fromMaybe [] $ go <$> next state 45 | where go instrs = wordAll instrs . incrP $ state {i = toBits <$> next state} 46 | 47 | -- | Executes a single word in the given state, returning the last 48 | -- resulting state.q 49 | step :: State -> State 50 | step = last . stepAll 51 | 52 | -- | Trace the given program, including all the intermediate states. 53 | traceAll :: State -> Trace 54 | traceAll program = let steps = stepAll program in steps ++ traceAll (last steps) 55 | 56 | -- | Returns a trace of the program's execution. The trace is a list 57 | -- of the state of the chip after each step. 58 | traceProgram :: State -> Trace 59 | traceProgram = iterate step 60 | 61 | -- | Trace a program until it either hits four nops or all 0s. 62 | stepProgram :: State -> Trace 63 | stepProgram = takeWhile (not . done) . traceProgram 64 | where done state = i state == Just 0x39ce7 || i state == Just 0 65 | 66 | -- | Runs the program unil it hits a terminal state, returning only 67 | -- the resulting state. 68 | eval :: State -> State 69 | eval state = last $ state : stepProgram state 70 | 71 | -- | Executes the specified program on the given state until it hits a 72 | -- "terminal" word--a word made up of four nops or all 0s. 73 | runNativeProgram :: State -> NativeProgram -> State 74 | runNativeProgram start program = eval $ setProgram 0 program start 75 | 76 | -- | Estimates the execution time of a program trace. 77 | countTime :: Trace -> Double 78 | countTime = runningTime . mapMaybe (fmap fromBits . i) 79 | 80 | -- | Checks that the program trace terminated in at most n steps, 81 | -- returning Nothing otherwise. 82 | throttle :: Int -> Trace -> Either Trace Trace 83 | throttle n states | null res = Right [startState] 84 | | length res == n = Left res 85 | | otherwise = Right res 86 | where res = take n states 87 | 88 | -- | Does the given opcode cause the current word to stop executing? 89 | endWord :: Opcode -> Bool 90 | endWord = (`elem` [Ret, Exec, Jmp, Call, Unext, Next, If, MinusIf]) 91 | 92 | -- | Extends the given trace by a single execution step. The trace 93 | -- cannot be empty. 94 | run :: Opcode -> [State] -> [State] 95 | run op trace = trace ++ [execute op $ last trace] 96 | 97 | -- | Executes an opcode on the given state. If the state is blocked on 98 | -- some communication, nothing changes. 99 | execute :: Opcode -> State -> State 100 | execute op state@State {..} = fromMaybe state [ res | res <- result, not $ blocked res ] 101 | where result = case op of 102 | FetchP -> dpush (incrP state) <$> memory ! p 103 | FetchPlus -> dpush (state {a = a + 1}) <$> memory ! a 104 | FetchB -> dpush state <$> memory ! b 105 | Fetch -> dpush state <$> memory ! a 106 | _ -> Just normal 107 | normal = case op of 108 | Ret -> fst . rpop $ state {p = r} 109 | Exec -> state {r = p, p = r} 110 | Unext -> if r == 0 then fst $ rpop state 111 | else state {r = r - 1, p = p - 1} 112 | StoreP -> incrP $ set state' p top 113 | StorePlus -> set (state' { a = a + 1 }) a top 114 | StoreB -> set state' b top 115 | Store -> set state' a top 116 | MultiplyStep -> multiplyStep 117 | Times2 -> state {t = t `shift` 1} 118 | Div2 -> state {t = t `shift` (-1)} 119 | Not -> state {t = complement t} 120 | Plus -> state' {t = s + t} 121 | And -> state' {t = s .&. t} 122 | Or -> state' {t = s `xor` t} 123 | Drop -> fst $ dpop state 124 | Dup -> dpush state t 125 | Pop -> uncurry dpush $ rpop state 126 | Over -> dpush state s 127 | ReadA -> dpush state a 128 | Nop -> state 129 | Push -> rpush state' top 130 | SetB -> state' {b = top} 131 | 132 | SetA -> state' {a = top} 133 | _ -> error "Cannot jump without an address!" 134 | 135 | (state', top) = dpop state 136 | -- TODO: support different word sizes? 137 | multiplyStep 138 | | even a = let t0 = (t .&. 1) `shift` (size - 1) in 139 | state { a = t0 .|. a `shift` (-1) 140 | , t = t .&. bit (size - 1) .|. t `shift` (-1)} 141 | | otherwise = let sum0 = (s + t) `shift` (size - 1) 142 | sum17 = (s + t) .&. bit (size - 1) in 143 | state { a = sum0 .|. a `shift` (-1) 144 | , t = sum17 .|. (s + t) `shift` (-1) } 145 | size = bitSize t 146 | 147 | -- | Execute a jump instruction to the given address. 148 | jump :: Opcode -> F18Word -> State -> State 149 | jump op addr state@State{p, r, t} = case op of 150 | Jmp -> state {p = addr} 151 | Call -> (rpush state p) {p = addr} 152 | Next -> if r == 0 then fst $ rpop state else state {r = r - 1, p = addr} 153 | If -> if t /= 0 then state {p = addr} else state 154 | MinusIf -> if t `testBit` pred size then state else state {p = addr} 155 | _ -> error "Non-jump instruction given a jump address!" 156 | where size = bitSize (0 :: F18Word) 157 | -------------------------------------------------------------------------------- /src/Language/ArrayForth/Multicore.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | 3 | -- | This module extends the interpreter to model all 144 cores on a 4 | -- chip. The basic idea is simple: we use the single-core interpreter 5 | -- for a step and then update all the neighbor's communication ports. 6 | -- 7 | -- Right now, we model one core at a time. The order in which cores 8 | -- fire off is customizable. You control this order by passing in a 9 | -- "schedule", which is just a list of core addresses; the cores are 10 | -- then executed following this list. 11 | -- 12 | -- For example, you could write a "round-robin" schedule using only 13 | -- the first 10 cores as @cycle [Core 0 0..Core 0 9]@. Cores also work 14 | -- like numbers, so you could use the following shorthand: @cycle 15 | -- [0..9]@. 16 | -- 17 | -- A @'CPU'@ is just a vector of 144 cores. To run a program, you first 18 | -- have to load each core in the vector with its appropriate 19 | -- program. You can do this using the @'//'@ operator which allows 20 | -- bulk updates. For example, if you want to put states @s₁@, @s₂@ and 21 | -- @s₃@ in addresses @[0..2]@, you could write: 22 | -- 23 | -- @ 24 | -- base // [(0, s₁), (1, s₂), (2, s₃)] 25 | -- -- or: 26 | -- base // zip [0..] [s₁, s₂, s₃] 27 | -- @ 28 | -- 29 | -- This creates a @'CPU'@ with all of the cores in their starting 30 | -- configuration except for the explictly modified ones. 31 | -- 32 | -- Once you have the starting configuration, you can run it with the 33 | -- @'runCPU'@ function. This accepts the starting @'CPU'@ and a 34 | -- schedule. So if you want to run the above state with a round-robin 35 | -- schedule for the three active cores, you would do this: 36 | -- 37 | -- @ 38 | -- runCPU (cycle [0..2]) (base // zip [0..] [s₁, s₂, s₃]) 39 | -- @ 40 | -- 41 | -- @'cycle'@ just repeats a given list forever. You can also define 42 | -- your own schedules that are more interesting. For example, you 43 | -- could write one where each core gets increasingly many steps at a 44 | -- time: 45 | -- 46 | -- @ 47 | -- [0..] >>= ([0,1,2] >>=) . replicate 48 | -- @ 49 | -- 50 | -- (Here @'>>='@ for lists is just @'concatMap'@.) 51 | -- 52 | -- More generally, you can use any list functions you want. 53 | -- 54 | -- Another interesting thing would be to define a random schedule. You 55 | -- can do this using @'Control.Monad.Random'@. The random generator 56 | -- depends on a seed, so the easiest thing is to write a function that 57 | -- generates a schedule given a seed: 58 | -- 59 | -- @ 60 | -- randomSchedule seed = evalRand randomList $ mkStdGen seed 61 | -- where randomList = do addr <- fromList . zip addresses $ repeat 1 62 | -- fmap (addr :) randomList 63 | -- @ 64 | -- 65 | -- The @zip addresses $ repeat 1@ determines the possible addresses 66 | -- and their weights. If you want some core to have a higher 67 | -- probability of being chosen at each turn, just set its weight to 68 | -- something other than 1. 69 | module Language.ArrayForth.Multicore where 70 | 71 | import qualified Data.Vector as V 72 | 73 | import Control.Applicative ((<$>)) 74 | import Control.Arrow (first) 75 | 76 | import Data.Maybe (catMaybes) 77 | 78 | import Language.ArrayForth.Channel 79 | import Language.ArrayForth.Core 80 | import Language.ArrayForth.Interpreter 81 | import Language.ArrayForth.State (Memory (..), State (..)) 82 | import qualified Language.ArrayForth.State as S 83 | 84 | -- | The state of every core in the chip. 85 | newtype CPU = CPU (V.Vector State) 86 | 87 | -- | The state made up of all 144 cores in their start configurations. 88 | base :: CPU 89 | base = CPU $ V.replicate 144 S.startState 90 | 91 | -- | We can index into the cores by core address. 92 | (!) :: CPU -> Core -> State 93 | CPU cpu ! core = cpu V.! fromEnum core 94 | 95 | (//) :: CPU -> [(Core, State)] -> CPU 96 | CPU cpu // updates = CPU $ cpu V.// map (first fromEnum) updates 97 | 98 | -- | Runs every core according to the given schedule, starting from 99 | -- the given initial state. 100 | runCPU :: CPU -- ^ The start state 101 | -> [Core] -- ^ The schedule. This is a list of core addresses to 102 | -- call. The execution trace will not be longer than 103 | -- the schedule. 104 | -> [CPU] -- ^ The result is just a list of all the intermediate states. 105 | runCPU cpu (core:cores) = 106 | let steps = stepCPU core cpu in steps ++ runCPU (last steps) cores 107 | 108 | -- | Execute a single step of the simulation, running the specified 109 | -- core. This executes a single word and returns all the intermediate 110 | -- states for each instruction. 111 | -- 112 | -- Since the schedule has to be discrete, communication only gets 113 | -- propagated *after* the instructions all get executed. This is 114 | -- probably bad, but meh. 115 | stepCPU :: Core -> CPU -> [CPU] 116 | stepCPU addr cpu = scanl (//) cpu $ steps : [(addr, end) : neighborUpdates addr end cpu] 117 | where states = stepAll $ cpu ! addr 118 | (steps, end) = (zip (repeat addr) $ init states, last states) 119 | 120 | -- | Given an address, returns how to update neighbors with relevant 121 | -- communication. 122 | neighborUpdates :: Core -> State -> CPU -> [(Core, State)] 123 | neighborUpdates addr state cpu = catMaybes cores `zip` catMaybes updated 124 | where Channel { right, down, left, up } = output $ memory state 125 | cores@[r, d, l, u] = neighbors addr 126 | updated = [go right R <$> r, go down D <$> d, go left L <$> l, go up U <$> u] 127 | 128 | go (Just value) port core = S.sendInput port value $ cpu ! core 129 | go Nothing _ core = cpu ! core 130 | -------------------------------------------------------------------------------- /src/Language/ArrayForth/NativeProgram.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE OverlappingInstances #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | module Language.ArrayForth.NativeProgram where 5 | 6 | import Control.Applicative ((<$>), (<*>)) 7 | import Control.Monad ((<=<)) 8 | 9 | import Data.Bits (shift, (.&.), (.|.)) 10 | import Data.List.Split (chunk, keepDelimsR, split, whenElt) 11 | import Data.String (IsString, fromString) 12 | 13 | import Language.ArrayForth.Opcode 14 | import Language.ArrayForth.Parse 15 | 16 | -- | Represents a word in memory. This word can either contain 17 | -- opcodes, opcodes and a jump address or just a constant number. 18 | data Instrs = Instrs Opcode Opcode Opcode Opcode 19 | | Jump3 Opcode Opcode Opcode F18Word 20 | | Jump2 Opcode Opcode F18Word 21 | | Jump1 Opcode F18Word 22 | | Constant F18Word deriving (Eq) 23 | 24 | instance Show Instrs where 25 | show (Instrs a b c d) = unwords $ map show [a, b, c, d] 26 | show (Jump3 a b c addr) = unwords (map show [a, b, c]) ++ " " ++ show addr 27 | show (Jump2 a b addr) = unwords (map show [a, b]) ++ " " ++ show addr 28 | show (Jump1 a addr) = show a ++ " " ++ show addr 29 | show (Constant n) = show n 30 | showList = (++) . unwords . map show 31 | 32 | -- | A program in the F18A instruction set. 33 | type NativeProgram = [Instrs] 34 | 35 | -- | Splits a list into chunks of at most four, breaking off a chunk 36 | -- whenever it sees an element matching the given predicate. This is 37 | -- useful for splitting a program along word boundaries, accounting 38 | -- for jump addresses. 39 | splitWords :: (a -> Bool) -> [a] -> [[a]] 40 | splitWords isNum = chunk 4 <=< split (keepDelimsR $ whenElt isNum) 41 | 42 | -- | Read a whole program, splitting instructions up into words. 43 | readNativeProgram :: String -> Either ParseError NativeProgram 44 | readNativeProgram = mapM go . splitWords isNumber . words 45 | where go [a, b, c, d] = do c' <- readOpcode c 46 | if not $ isJump c' 47 | then Instrs <$> op a <*> op b <*> op c <*> op3 d 48 | else Jump3 <$> op a <*> op b <*> jump c <*> readWord d 49 | go [a, b, c] = Jump2 <$> op a <*> jump b <*> readWord c 50 | go [a, b] = Jump1 <$> jump a <*> readWord b 51 | go [a] = Constant <$> readWord a 52 | go _ = error "Wrong number of instruction tokens!" 53 | wrap cond err str = do code <- readOpcode str 54 | if cond code then Right code else Left $ err code 55 | op = wrap (not . isJump) $ NoAddr . show 56 | op3 = wrap slot3 $ NotSlot3 . show 57 | jump = wrap isJump $ NotJump . show 58 | 59 | instance Read NativeProgram where 60 | readsPrec _ str = [(result, "")] 61 | where result = case readNativeProgram str of 62 | Right res -> res 63 | Left err -> error $ show err 64 | 65 | instance IsString NativeProgram where fromString = read 66 | 67 | -- | Returns the given instructions as an actual word. This assumes 68 | -- the address is sized appropriately. 69 | toBits :: Instrs -> F18Word 70 | toBits (Instrs a b c d) = fromOpcode a `shift` 13 .|. fromOpcode b `shift` 8 .|. 71 | fromOpcode c `shift` 3 .|. fromOpcode d `shift` (-2) 72 | toBits (Jump3 a b c addr) = fromOpcode a `shift` 13 .|. fromOpcode b `shift` 8 .|. 73 | fromOpcode c `shift` 3 .|. addr 74 | toBits (Jump2 a b addr) = fromOpcode a `shift` 13 .|. fromOpcode b `shift` 8 .|. addr 75 | toBits (Jump1 a addr) = fromOpcode a `shift` 13 .|. addr 76 | toBits (Constant n) = n 77 | 78 | -- | Reads in a word as a set of opcodes. 79 | fromBits :: F18Word -> Instrs 80 | fromBits n | isJump a = Jump1 a $ n .&. 0x3FF 81 | | isJump b = Jump2 a b $ n .&. 0xFF 82 | | isJump c = Jump3 a b c $ n .&. 0x7 83 | | otherwise = Instrs a b c d 84 | where a = toOpcode $ n `shift` (-13) 85 | b = toOpcode $ n `shift` (-8) .&. 0x1F 86 | c = toOpcode $ n `shift` (-3) .&. 0x1F 87 | d = toOpcode $ (n .&. 0x7) `shift` 2 88 | 89 | -- | Returns the opcodes in the given instruction word. A constant 90 | -- corresponds to not having any opcodes. 91 | toOpcodes :: Instrs -> [Opcode] 92 | toOpcodes (Instrs a b c d) = [a, b, c, d] 93 | toOpcodes (Jump3 a b c _) = [a, b, c] 94 | toOpcodes (Jump2 a b _) = [a, b] 95 | toOpcodes (Jump1 a _) = [a] 96 | toOpcodes Constant{} = [] 97 | 98 | -- | Estimates the running time of the program in nanoseconds. This is 99 | -- based on the numbers provided in the manual: faster instructions 100 | -- take 1.5 nanoseconds and slower ones take 5. For now, this estimate 101 | -- ignores control flow like ifs and loops. 102 | runningTime :: NativeProgram -> Double 103 | runningTime = sum . map opcodeTime . reverse . dropWhile (== Nop) . reverse . concatMap toOpcodes 104 | -------------------------------------------------------------------------------- /src/Language/ArrayForth/Opcode.hs: -------------------------------------------------------------------------------- 1 | module Language.ArrayForth.Opcode where 2 | 3 | import Data.List (elemIndex) 4 | import Data.Word.Odd (Word18) 5 | 6 | import Language.ArrayForth.Parse (ParseError (..)) 7 | 8 | -- | The 18-bit word type used by Greenarrays chips. 9 | type F18Word = Word18 10 | 11 | -- | Each F18A instruction, ordered by opcode. 12 | data Opcode = Ret -- ; 13 | | Exec -- ex 14 | | Jmp -- name ; 15 | | Call -- name 16 | | Unext -- unext 17 | | Next -- next 18 | | If -- if 19 | | MinusIf -- -if 20 | | FetchP -- @p 21 | | FetchPlus -- @+ 22 | | FetchB -- @b 23 | | Fetch -- @ 24 | | StoreP -- !p 25 | | StorePlus -- !+ 26 | | StoreB -- !b 27 | | Store -- ! 28 | | MultiplyStep -- +* 29 | | Times2 -- 2* 30 | | Div2 -- 2/ 31 | | Not -- - 32 | | Plus -- + 33 | | And -- and 34 | | Or -- or 35 | | Drop -- drop 36 | | Dup -- dup 37 | | Pop -- pop 38 | | Over -- over 39 | | ReadA -- a 40 | | Nop -- . 41 | | Push -- push 42 | | SetB -- b! 43 | | SetA -- a! 44 | deriving (Eq, Bounded, Enum) 45 | 46 | -- | The names of the different instructions, ordered by opcode. 47 | names :: [String] 48 | names = [";", "ex", "jump", "call", "unext", "next", "if", "-if", "@p", "@+", "@b", "@", 49 | "!p", "!+", "!b", "!", "+*", "2*", "2/", "-", "+", "and", "or", "drop", "dup", 50 | "pop", "over", "a", ".", "push", "b!", "a!"] 51 | 52 | -- | All of the opcodes, in order. 53 | opcodes :: [Opcode] 54 | opcodes = [minBound..maxBound] 55 | 56 | instance Show Opcode where show op = names !! fromEnum op 57 | 58 | -- | Tries to read a given string as an opcode from the list of names. 59 | readOpcode :: String -> Either ParseError Opcode 60 | readOpcode token = case elemIndex token names of 61 | Just res -> Right $ toEnum res 62 | Nothing -> Left $ BadOpcode token 63 | 64 | instance Read Opcode where readsPrec _ str = case readOpcode str of 65 | Left err -> error $ show err 66 | Right r -> [(r, "")] 67 | 68 | -- | Converts a word to an opcode. The word has to be < 32. 69 | toOpcode :: F18Word -> Opcode 70 | toOpcode = toEnum . fromIntegral 71 | 72 | -- | Converts an Opcode to its 18-bit word representation. 73 | fromOpcode :: Opcode -> F18Word 74 | fromOpcode = fromIntegral . fromEnum 75 | 76 | -- | Returns whether the given opcode is a jump instruction expecting 77 | -- an address. 78 | isJump :: Opcode -> Bool 79 | isJump = (`elem` [Jmp, Call, Next, If, MinusIf]) 80 | 81 | -- | Can the given opcode go in the last slot? 82 | slot3 :: Opcode -> Bool 83 | slot3 = (`elem` [Ret, MultiplyStep, Unext, Plus, FetchP, Dup, StoreP, Nop]) 84 | 85 | -- | Estimates how long a given opcode will take to execute. Normal 86 | -- opcodes take 1.5 nanoseconds where ones that access the memory take 87 | -- 5 nanoseconds. 88 | opcodeTime :: Opcode -> Double 89 | opcodeTime op = if memoryOp op then 5 else 1.5 90 | where memoryOp = (`elem` [FetchP, FetchPlus, FetchB, Fetch, StoreP, 91 | StorePlus, StoreB, Store]) 92 | -------------------------------------------------------------------------------- /src/Language/ArrayForth/Parse.hs: -------------------------------------------------------------------------------- 1 | module Language.ArrayForth.Parse (ParseError (..), isNumber, readWord) where 2 | 3 | import Text.Printf (printf) 4 | 5 | -- | Possible ways the input string can be malformed. 6 | data ParseError = BadOpcode String 7 | | NotSlot3 String 8 | | NotJump String 9 | | NoAddr String 10 | | BadNumber String 11 | 12 | instance Show ParseError where 13 | show (BadOpcode op) = printf "Invalid opcode `%s'." op 14 | show (NotSlot3 op) = printf "`%s' cannot go into the last slot." op 15 | show (NotJump op) = 16 | printf "`%s' is not a jump instruction and cannot get an address." op 17 | show (NoAddr op) = printf "Missing a jump address for `%s'" op 18 | show (BadNumber n) = printf "`%s' is not a valid number." n 19 | 20 | -- | Is the given string a valid number with no other tokens? 21 | isNumber :: String -> Bool 22 | isNumber str = let asNumber = reads str :: [(Integer, String)] in 23 | not (null asNumber) && (null . snd $ head asNumber) 24 | 25 | -- | Tries to read a word, giving an error if it fails. 26 | readWord :: Read a => String -> Either ParseError a 27 | readWord str = case reads str of 28 | (x, _) : _ -> Right x 29 | [] -> Left $ BadNumber str 30 | -------------------------------------------------------------------------------- /src/Language/ArrayForth/Program.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE OverlappingInstances #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | module Language.ArrayForth.Program where 6 | 7 | import Control.Monad ((<=<)) 8 | 9 | import Data.Functor ((<$>)) 10 | import Data.List (find, (\\)) 11 | import Data.String (IsString, fromString) 12 | 13 | import Language.ArrayForth.Interpreter 14 | import Language.ArrayForth.NativeProgram 15 | import Language.ArrayForth.Opcode 16 | import qualified Language.ArrayForth.Parse as P 17 | import Language.ArrayForth.State (State, setProgram) 18 | 19 | data Addr = Concrete F18Word | Abstract String deriving Eq 20 | 21 | instance Show Addr where 22 | show (Concrete n) = show n 23 | show (Abstract s) = ':' : s 24 | 25 | -- | Represents a single instruction as viewed by the 26 | -- synthesizer. This can be an opcode, a numeric literal or a token 27 | -- representing an unused slot. 28 | data Instruction = Opcode Opcode 29 | | Jump Opcode Addr 30 | | Number F18Word 31 | | Label String 32 | | Unused deriving Eq 33 | 34 | -- | A program to be manipulated by the MCMC synthesizer 35 | type Program = [Instruction] 36 | 37 | instance Show Instruction where 38 | show (Opcode op) = show op 39 | show (Jump op addr) = show op ++ " " ++ show addr 40 | show (Number n) = show n 41 | show (Label s) = ':' : s 42 | show Unused = "_" 43 | showList = (++) . unwords . map show 44 | 45 | -- | Tries to parse the given string as an instruction, which can 46 | -- either be a number, an opcode or "_" representing Unused. 47 | readInstruction :: String -> Either P.ParseError Instruction 48 | readInstruction "_" = Right Unused 49 | readInstruction (':':label) = Right $ Label label 50 | readInstruction str | P.isNumber str = Number <$> P.readWord str 51 | | otherwise = Opcode <$> readOpcode str 52 | 53 | -- | Reads a program in the synthesizer's format. 54 | readProgram :: String -> Either P.ParseError Program 55 | readProgram = fixJumps <=< mapM readInstruction . words 56 | where fixJumps [] = Right [] 57 | fixJumps (Opcode op : rest) | isJump op = case rest of 58 | Number n : program -> (Jump op (Concrete n) :) <$> fixJumps program 59 | Label s : program -> (Jump op (Abstract s) :) <$> fixJumps program 60 | _ -> Left . P.NoAddr $ show op 61 | fixJumps (good : rest) = (good :) <$> fixJumps rest 62 | 63 | instance Read Program where 64 | readsPrec _ str = [(result, "")] 65 | where result = case readProgram str of 66 | Right res -> res 67 | Left err -> error $ show err 68 | 69 | instance IsString Program where fromString = read 70 | 71 | -- | Takes a program as handled by the synthesizer and makes it native 72 | -- by turning literal numbers into @p and fixing any issues with 73 | -- instructions going into the last slot as well as prepending 74 | -- nops before + instructions. 75 | toNative :: Program -> NativeProgram 76 | toNative = (>>= toInstrs) . splitWords boundary . fixSlot3 . 77 | (>>= nopsPlus) . labels 0 . filter (/= Unused) 78 | where nopsPlus (Opcode Plus) = ". +" 79 | nopsPlus x = [x] 80 | toInstrs ls = let (ops, numbers) = addFetchP ls in 81 | convert ops : map (\ (Number n) -> Constant n) numbers 82 | addFetchP [] = ([], []) 83 | addFetchP (n@Number{} : rest) = 84 | let (instrs, consts) = addFetchP rest in (Opcode FetchP : instrs, n : consts) 85 | addFetchP (instr : rest) = 86 | let (instrs, consts) = addFetchP rest in (instr : instrs, consts) 87 | convert [Opcode a, Opcode b, Opcode c, Opcode d] = Instrs a b c d 88 | convert [Opcode a, Opcode b, Jump c addr] = Jump3 a b c $ concrete addr 89 | convert [Opcode a, Jump b addr] = Jump2 a b $ concrete addr 90 | convert [Jump a addr] = Jump1 a $ concrete addr 91 | convert instrs = convert . take 4 $ instrs ++ repeat (Opcode Nop) 92 | concrete Abstract{} = error "Need concrete address at this stage." 93 | concrete (Concrete addr) = addr 94 | 95 | -- | Does this instruction force a word boundary? 96 | boundary :: Instruction -> Bool 97 | boundary Jump{} = True 98 | boundary _ = False 99 | 100 | -- | Resolves labels into addresses, assuming the program starts at 101 | -- the given memory location. 102 | labels :: F18Word -> Program -> Program 103 | labels start program = map fixLabel $ filter (not . label) program 104 | where label Label{} = True 105 | label _ = False 106 | values = go start program 107 | go _ [] = [] 108 | go n (Label name : rest) = (name, n) : go n rest 109 | go n (_ : rest) = go (n + 1) rest 110 | fixLabel (Jump op (Abstract l)) = 111 | maybe (error $ "Unknown label " ++ l) 112 | (Jump op . Concrete) $ lookup l values 113 | fixLabel x = x 114 | 115 | -- | Insert extra nops to account for instructions that cannot go into 116 | -- the last slot. 117 | fixSlot3 :: Program -> Program 118 | fixSlot3 program = case splitWords boundary program of 119 | [] -> [] 120 | (next:rest) -> take 4 (go next) ++ fixSlot3 (drop 4 (go next) ++ concat rest) 121 | where go instrs@[_, _, _, op3] | valid op3 = instrs 122 | | otherwise = init instrs ++ "." ++ [op3] 123 | go instrs = instrs 124 | valid (Opcode op) = slot3 op 125 | valid Number{} = True 126 | valid _ = False 127 | 128 | -- | Gets a synthesizer program from a native program. Currently does 129 | -- not support jumps. 130 | fromNative :: NativeProgram -> Program 131 | fromNative = fixNumbers . concatMap extract 132 | where extract (Instrs a b c d) = [Opcode a, Opcode b, Opcode c, Opcode d] 133 | extract (Jump3 a b c addr) = [Opcode a, Opcode b, Jump c $ Concrete addr] 134 | extract (Jump2 a b addr) = [Opcode a, Jump b $ Concrete addr] 135 | extract (Jump1 a addr) = [Jump a $ Concrete addr] 136 | extract (Constant n) = [Number n] 137 | fixNumbers [] = [] 138 | fixNumbers (Opcode FetchP : rest) = case find isNumber rest of 139 | Just n -> n : (fixNumbers $ rest \\ [n]) 140 | Nothing -> Opcode FetchP : fixNumbers rest 141 | fixNumbers (x : rest) = x : fixNumbers rest 142 | isNumber Number{} = True 143 | isNumber _ = False 144 | 145 | -- | Runs a given program from the default starting state. 146 | runProgram :: State -> Program -> State 147 | runProgram start = runNativeProgram start . toNative 148 | 149 | -- | Loads the given synthesizer-friendly program into the given 150 | -- state. 151 | load :: Program -> State -> State 152 | load prog state = setProgram 0 (toNative prog) state 153 | -------------------------------------------------------------------------------- /src/Language/ArrayForth/Stack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module Language.ArrayForth.Stack (empty, push, pop, fill, Stack) where 3 | 4 | import Prelude hiding ((++)) 5 | 6 | import Data.List (foldl') 7 | import Data.Vector.Unboxed ((!), (++)) 8 | import qualified Data.Vector.Unboxed as V 9 | 10 | import Language.ArrayForth.Opcode (F18Word) 11 | 12 | newtype Stack = Stack (V.Vector Int) deriving (Eq) 13 | 14 | instance Show Stack where show (Stack body) = unwords . map show $ V.toList body 15 | 16 | -- | A stack containing only 0s. 17 | empty :: Stack 18 | empty = Stack $ V.replicate 8 0 19 | 20 | -- | Pushes the given element on top of the stack, discarding the last element. 21 | push :: Stack -> F18Word -> Stack 22 | push !(Stack body) word = Stack . V.cons (fromIntegral word) $ V.init body 23 | 24 | -- | Pops the top of the stack, returning the value and the new stack. 25 | pop :: Stack -> (Stack, F18Word) 26 | pop !(Stack body) = let x = V.take 1 body in (Stack $ V.tail body ++ x, fromIntegral $ x ! 0) 27 | 28 | -- | Push the given elements onto the stack one-by-one. 29 | fill :: Stack -> [F18Word] -> Stack 30 | fill = foldl' push 31 | 32 | -------------------------------------------------------------------------------- /src/Language/ArrayForth/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | -- | This module defines types and functions for working with the 4 | -- state of a single core. 5 | -- 6 | -- The most important type is State, which contains all the 7 | -- information about the core. This includes the registers, the 8 | -- memory, both stacks and communication ports. Right now, it's just a 9 | -- big record; in the future, I might make it more polymorphic using 10 | -- lenses. 11 | -- 12 | -- There are also some useful types and functions for working with the 13 | -- memory of a chip and its communication channels. 14 | module Language.ArrayForth.State where 15 | 16 | import Data.Functor ((<$>)) 17 | import Data.Vector.Unboxed (Vector, (//)) 18 | import qualified Data.Vector.Unboxed as V 19 | 20 | import Text.Printf (printf) 21 | 22 | import Language.ArrayForth.Channel 23 | import Language.ArrayForth.NativeProgram 24 | import Language.ArrayForth.Opcode (F18Word) 25 | import Language.ArrayForth.Stack 26 | 27 | -- TODO: Figure out how to deal with different reads in ports. 28 | 29 | -- | The chip's RAM, ROM and IO channels. The RAM and ROM should each 30 | -- contain 64 words. 31 | -- 32 | -- For now, input and output is split into two different types, even 33 | -- though they're combined on the physical chip. I'm simply not sure 34 | -- how to handle the case that both chips simultaneously write to the 35 | -- same channel. 36 | data Memory = Memory { ram :: Vector Int 37 | , rom :: Vector Int 38 | , input :: Channel 39 | , output :: Channel } deriving (Show, Eq) 40 | 41 | -- | Memory with RAM and ROM zeroed out and nothing on the 42 | -- communication channels. 43 | emptyMem :: Memory 44 | emptyMem = Memory { ram = V.replicate 64 0 45 | , rom = V.replicate 64 0 46 | , input = emptyChannel 47 | , output = emptyChannel } 48 | 49 | -- | The number of words in memory. Both ram and rom are this 50 | -- size. For some reason, the ram and rom address spaces are *double* 51 | -- this size respectively, wrapping around at the half-way point. 52 | memSize :: Num a => a 53 | memSize = 0x03F 54 | 55 | -- | A state representing the registers, stacks, memory and 56 | -- communication channels of a core. Note that all the fields are 57 | -- strict; they should also be unboxed thanks to 58 | -- @-funbox-strict-fields@ (set in the .cabal file). 59 | -- 60 | -- For now, this is just a record; however, I might rewrite it to use 61 | -- lenses in the near future. 62 | data State = 63 | State { a, b, p, r, s, t :: !F18Word 64 | , i :: !(Maybe F18Word) 65 | -- ^ the i register can be @Nothing@ if it is blocked on a 66 | -- communication port. 67 | , dataStack, returnStack :: !Stack 68 | , memory :: !Memory } 69 | 70 | instance Show State where 71 | show State {p, a, b, r, s, t, dataStack} = 72 | printf "p:%s a:%s b:%s r:%s\n %s %s %s" p' a' b' r' t' s' (show dataStack) 73 | where [p', a', b', r', s', t'] = map show [p, a, b, r, s, t] 74 | 75 | -- | The state corresponding to a core with no programs loaded and no 76 | -- instructions executed. 77 | startState :: State 78 | startState = State 0 0 0 0 0 0 (Just 0) empty empty emptyMem 79 | 80 | 81 | -- | Increment the p register for the given state. If p is in RAM or 82 | -- ROM, this wraps p as appropriate. If p is in IO, this does nothing 83 | -- and p remains unchanged. 84 | incrP :: State -> State 85 | incrP state@State { p } = state { p = nextP } 86 | where nextP | p < 2 * memSize = succ p `mod` (2 * memSize) 87 | | p < 4 * memSize = (succ p `mod` (2 * memSize)) + 2 * memSize 88 | | otherwise = p 89 | 90 | -- | The next word of instructions to execute in the given 91 | -- state. Returns @Nothing@ if @p@ is blocked on a communication 92 | -- channel. 93 | next :: State -> Maybe Instrs 94 | next State { memory, p } = fromBits <$> memory ! p 95 | 96 | -- | Pops the data stack of the given state, updating @s@ and @t@. 97 | dpop :: State -> (State, F18Word) 98 | dpop state@State {s, t, dataStack} = 99 | let (ds', res) = pop dataStack in (state {t = s, s = res, dataStack = ds'}, t) 100 | 101 | -- | Push a word onto the data stack, updating @s@ and @t@. 102 | dpush :: State -> F18Word -> State 103 | dpush state@State {s, t, dataStack} word = 104 | state {t = word, s = t, dataStack = push dataStack s} 105 | 106 | -- | Pops the return stack of the given state, updating @r@. 107 | rpop :: State -> (State, F18Word) 108 | rpop state@State {r, returnStack} = 109 | let (rs', res) = pop returnStack in (state {r = res, returnStack = rs'}, r) 110 | 111 | -- | Push a word onto the return stack, updating @r@. 112 | rpush :: State -> F18Word -> State 113 | rpush state@State {r, returnStack} word = 114 | state {r = word, returnStack = push returnStack r} 115 | 116 | -- | Force an address to be in range of memory: [0,64), also 117 | -- converting between different integral types. 118 | toMem :: (Integral a, Integral b) => a -> b 119 | toMem = fromIntegral . (`mod` 64) 120 | 121 | -- | Read the memory at a location given by a Forth word. Returns 122 | -- @Nothing@ if blocked on a communication channel. 123 | (!) :: Memory -> F18Word -> Maybe F18Word 124 | Memory {..} ! i | i < 2 * memSize = Just . fromIntegral $ ram V.! toMem i 125 | | i < 4 * memSize = Just . fromIntegral $ rom V.! toMem i 126 | | otherwise = readPort i input 127 | 128 | -- | Set the memory using Forth words. A state with anything in the 129 | -- output channel remains blocked until one of the active ports is 130 | -- read. 131 | set :: State -> F18Word -> F18Word -> State 132 | set state@State {memory = memory@Memory {..}} i value 133 | | i < 2 * memSize = state { memory = updatedRam } 134 | | i < 4 * memSize = error "Cannot set memory in the ROM!" 135 | | otherwise = state { memory = updatedOutput } 136 | where updatedRam = memory { ram = ram // [(toMem i, fromIntegral value)] } 137 | updatedOutput = memory { output = writePort i value } 138 | 139 | -- | Is the state is blocked because it has written to a port? Note 140 | -- that this does *not* consider being blocked on a read! 141 | blocked :: State -> Bool 142 | blocked State { memory = Memory { output } } = output /= emptyChannel 143 | 144 | -- | Loads the given program into memory at the given starting 145 | -- position. 146 | setProgram :: F18Word -> NativeProgram -> State -> State 147 | setProgram start program state = state' { i = toBits <$> next state' } 148 | where state' = loadMemory start (fromIntegral . toBits <$> program) state 149 | 150 | -- | Load the given memory words into the state starting at the given 151 | -- address. 152 | loadMemory :: F18Word -> [F18Word] -> State -> State 153 | loadMemory start values state@State {memory = memory@Memory {..}} = 154 | state { memory = memory { 155 | ram = ram // zip [toMem start..] (fromIntegral <$> values) } } 156 | 157 | -- This code in particular would probably have been much nicer with lenses! 158 | -- | Sets the input value at the given port. 159 | sendInput :: Port -> F18Word -> State -> State 160 | sendInput port value state@(State { memory = memory@Memory {..} }) = updated 161 | where updated = state { 162 | memory = case port of 163 | R -> memory { input = input { right = Just value } } 164 | D -> memory { input = input { down = Just value } } 165 | L -> memory { input = input { left = Just value } } 166 | U -> memory { input = input { up = Just value } } 167 | } 168 | -------------------------------------------------------------------------------- /src/Language/ArrayForth/Synthesis.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE OverlappingInstances #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeSynonymInstances #-} 7 | module Language.ArrayForth.Synthesis where 8 | 9 | import Control.Arrow (first) 10 | import Control.Monad.Random (Random, random, randomR) 11 | 12 | import Data.Function (on) 13 | import Data.Functor ((<$>)) 14 | import Data.List (elemIndices, genericLength, (\\)) 15 | import Data.Monoid (Monoid (..)) 16 | 17 | import Language.ArrayForth.Distance 18 | import Language.ArrayForth.Interpreter 19 | import Language.ArrayForth.Opcode 20 | import Language.ArrayForth.Program 21 | import Language.ArrayForth.State 22 | 23 | import Language.Synthesis.Distribution (Distr (..), mix, 24 | negativeInfinity, randInt, 25 | uniform) 26 | import Language.Synthesis.Mutations hiding (mix) 27 | import qualified Language.Synthesis.Mutations as M 28 | import Language.Synthesis.Synthesis (Score (..)) 29 | 30 | import Text.Printf 31 | 32 | -- | A score type that contains a correctness value and a performance 33 | -- value. 34 | data DefaultScore = DefaultScore Double Double deriving (Ord, Eq) 35 | 36 | instance Score DefaultScore where 37 | toScore (DefaultScore correctness performance) = correctness + 0.1 * performance 38 | 39 | instance Show DefaultScore where show (DefaultScore a b) = printf "<%.2f, %.2f>" a b 40 | 41 | instance Monoid DefaultScore where 42 | mempty = DefaultScore 0 0 43 | DefaultScore c₁ p₁ `mappend` DefaultScore c₂ p₂ = DefaultScore (c₁ + c₂) (p₁ + p₂) 44 | 45 | -- | Creates an evaluation function from a spec, a set of inputs and a 46 | -- function for comparing program traces. 47 | trace :: Monoid score => Program -> [State] -> (Trace -> Trace -> score) -> Program -> score 48 | trace spec inputs score program = mconcat $ zipWith score specs throttled 49 | where specs = stepProgram . load spec <$> inputs 50 | results = stepProgram . load program <$> inputs 51 | throttled = zipWith go specs results 52 | where go spec' trace' = either id id $ throttle (length spec') trace' 53 | 54 | -- | Using a given correctness measure, produce a score also 55 | -- containing performance. 56 | withPerformance :: Score s => (Trace -> Trace -> s) -> (Trace -> Trace -> DefaultScore) 57 | withPerformance score spec result = DefaultScore (toScore $ score spec res) performance 58 | where res = either id id $ throttle (length spec) result 59 | performance = case throttle (length spec) result of 60 | Right res' -> (countTime spec - countTime res') / 10 61 | Left res' -> countTime spec - countTime res' - 1e10 62 | 63 | -- | Given a specification program and some inputs, evaluate a program 64 | -- against the specification for both performance and 65 | -- correctness. Normalize the score based on the number of test cases. 66 | evaluate :: Program -> [State] -> (State -> State -> Distance) -> Program -> DefaultScore 67 | evaluate spec inputs distance = 68 | normalize . trace spec inputs (withPerformance (distance `on` last)) 69 | where normalize (DefaultScore c p) = DefaultScore (c / len) (p / len) 70 | len = genericLength inputs 71 | 72 | -- I need this so that I can get a distribution over Forth words. 73 | instance Random F18Word where 74 | randomR (start, end) gen = 75 | first fromInteger $ randomR (fromIntegral start, fromIntegral end) gen 76 | random = randomR (0, maxBound) 77 | 78 | -- | The default distribution of instructions. For now, we do not 79 | -- support any sort of jumps. All the other possible instructions 80 | -- along with constant numbers and unused slots are equally 81 | -- likely. The numeric value of constants is currently a uniform 82 | -- distribution over 18-bit words. 83 | defaultOps :: Distr Instruction 84 | defaultOps = mix [(constants, 1.0), (uniform [Unused], 1.0), 85 | (uniform instrs, genericLength instrs)] 86 | where instrs = map Opcode $ filter (not . isJump) opcodes \\ [Unext, Nop] 87 | constants = let Distr {..} = randInt (0, maxBound) 88 | logProb (Number n) = logProbability n 89 | logProb _ = negativeInfinity in 90 | Distr { sample = Number <$> sample 91 | , logProbability = logProb } 92 | 93 | pairs :: [(Instruction, Instruction)] 94 | pairs = map (\ (a, b) -> (Opcode a, Opcode b)) 95 | [ (SetA, ReadA) 96 | , (Push, Pop) 97 | , (Over, Drop) ] 98 | 99 | removePairs :: Distr Instruction -> Mutation Program 100 | removePairs instrDistr program = 101 | mix [(mutateInstructionsAt instrDistr is program, 1.0) | is <- findPairs program] 102 | where findPairs program' = do (a, b) <- pairs 103 | indexA <- elemIndices a program' 104 | indexB <- elemIndices b program' 105 | return [indexA, indexB] 106 | 107 | -- | The default mutations to try. For now, this will either change an 108 | -- instruction or swap two instructions in the program, with equal 109 | -- probability. 110 | defaultMutations :: Mutation Program 111 | defaultMutations = M.mix [(mutateInstruction defaultOps, 1), (swapInstructions, 1)] 112 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main where 4 | 5 | import Control.Arrow ((&&&), second) 6 | import Control.Monad.Random (evalRandIO) 7 | 8 | import Data.Bits (complement) 9 | import Data.Function (on) 10 | import Data.List (find) 11 | import Data.Monoid (Sum (..)) 12 | 13 | import Options.Applicative 14 | 15 | import Language.ArrayForth.Distance (Distance, matching, registers) 16 | import Language.ArrayForth.Interpreter (eval) 17 | import Language.ArrayForth.Parse () 18 | import Language.ArrayForth.Program (Program, load, readProgram) 19 | import qualified Language.ArrayForth.Stack as S 20 | import Language.ArrayForth.State (State (..), startState) 21 | import Language.ArrayForth.Synthesis (DefaultScore (..), defaultMutations, defaultOps, 22 | evaluate, trace, withPerformance) 23 | 24 | import qualified Language.Synthesis.Distribution as Distr 25 | import Language.Synthesis.Synthesis (Problem (..), Score (..), runningBest, 26 | synthesizeMhList) 27 | 28 | data Options = Options { verbose :: Bool } 29 | 30 | options :: Parser Options 31 | options = Options <$> switch (long "verbose" <> 32 | short 'v' <> 33 | help "Print intermediate state to STDOUT.") 34 | 35 | specP :: Parser Program 36 | specP = argument (either (const Nothing) Just . readProgram) (metavar "SPEC") 37 | 38 | main :: IO () 39 | main = do Options { verbose } <- execParser go 40 | if verbose then verbosely else run 41 | where go = info (helper <*> options) 42 | (fullDesc <> 43 | progDesc "Synthesize arrayForth programs using MCMC." <> 44 | header "mcmc-demo - simple synthesis with MCMC") 45 | 46 | good :: Score s => (Program, s) -> Bool 47 | good (_, val) = toScore val >= 0.5 48 | 49 | verbosely :: IO () 50 | verbosely = do ls <- evalRandIO (synthesizeMhList inclusiveOr) 51 | mapM_ (print . second toScore . fst) . zip ls . takeWhile (not . good) $ runningBest ls 52 | 53 | run :: IO () 54 | run = evalRandIO (synthesizeMhList inclusiveOr) >>= print . find good . runningBest 55 | 56 | test :: (State -> State -> t) -> String -> String -> State -> t 57 | test distance p₁ p₂ input = let r₁ = eval $ load (read p₁) input 58 | r₂ = eval $ load (read p₂) input in 59 | distance r₁ r₂ 60 | 61 | orSpec :: Program 62 | orSpec = "over over or a! and a or" 63 | 64 | cases :: [State] 65 | cases = [startState {t = 0, s = 123}, startState {t = maxBound, s = 123}, 66 | startState {t = 1, s = 123}, startState {t = maxBound - 1, s = 123}, 67 | startState {t = 37, s = 123}, startState {t = 52, s = 123}] 68 | 69 | inclusiveOr :: Problem Program DefaultScore 70 | inclusiveOr = Problem { score = evaluate orSpec cases distance 71 | , prior = Distr.constant orSpec 72 | , jump = defaultMutations } 73 | where complemented σ₁ σ₂@State {t = t₂} = 74 | Sum . negate . getSum . registers [t] σ₁ $ σ₂ {t = complement t₂} 75 | distance = registers [t] <> complemented 76 | 77 | traceOr :: Problem Program DefaultScore 78 | traceOr = Problem { score = trace orSpec cases $ withPerformance sc 79 | , prior = Distr.constant orSpec 80 | , jump = defaultMutations } 81 | where sc = matching (s &&& t) <> (registers [t] `on` last) 82 | 83 | -- bitwiseSwap :: Problem Program DefaultScore 84 | -- bitwiseSwap = Problem { score = evaluate program cases distance 85 | -- , prior = Distr.constant program 86 | -- , jump = defaultMutations } 87 | -- where program = "a! over over . a - and . push a and . pop over over . or push and . pop or . ." 88 | -- cases = [ startState {t = 46, s = 18, dataStack = st 43} 89 | -- , startState {t = 232, s = 123, dataStack = st 0} 90 | -- , startState {t = 2352, s = 123, dataStack = st 1} 91 | -- , startState {t = maxBound - 5, s = 123, dataStack = st 13} 92 | -- ] 93 | -- distance = registers [t] 94 | -- st = S.push S.empty 95 | -------------------------------------------------------------------------------- /src/Run.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | module Main where 3 | 4 | import Data.Functor ((<$)) 5 | import Data.List.Split (chunk) 6 | import qualified Data.Vector.Unboxed as V 7 | 8 | import Language.ArrayForth.Interpreter (eval, runNativeProgram) 9 | import Language.ArrayForth.Parse (isNumber) 10 | import Language.ArrayForth.Program (readProgram, toNative) 11 | import Language.ArrayForth.State (Memory (..), State (..), 12 | setProgram, startState) 13 | 14 | import System.Environment (getArgs) 15 | import System.IO (hFlush, stdout) 16 | 17 | import Text.Printf (printf) 18 | 19 | main :: IO () 20 | main = do args <- getArgs 21 | case args of 22 | [] -> repl 23 | [file] -> readFile file >>= print . runNativeProgram startState . read 24 | _ -> putStrLn $ "Too many arguments!" 25 | 26 | repl :: IO () 27 | repl = putStrLn errorMessage >> go (0, startState) 28 | where errorMessage = "Type :help for a list of possible command." 29 | 30 | go (loc, state) = do 31 | inp <- putStr "λ>" >> hFlush stdout >> getLine 32 | case inp of 33 | ":" -> do 34 | putStrLn ("Please specify a valid command. " ++ errorMessage) 35 | go (loc, state) 36 | ':' : commands -> let command : args = words commands in 37 | run command args >>= go 38 | program -> execute $ readProgram program 39 | where helpMessage = unlines $ [ 40 | ":help — list the possible commands", 41 | ":reset — reset all the registers and memory to 0", 42 | ":p — print the value of the p register (the program counter)", 43 | ":p — set the p register to the given address n; a manual jump instruction", 44 | ":memory — print all of the memory in a reasonably easy to read format"] 45 | 46 | execute (Left err) = print err >> go (loc, state) 47 | execute (Right program) = print res >> go (p, res) 48 | where res@State {p} = eval $ setProgram loc (toNative program) state 49 | run "reset" _ = (0, startState) <$ print startState 50 | run "p" [] = (loc, state) <$ print (p state) 51 | run "p" args 52 | | not (isNumber $ head args) = 53 | (loc, state) <$ putStrLn "Invalid arguments!" 54 | | otherwise = let n = read $ head args in 55 | (n, state { p = n }) <$ print state { p = n } 56 | run cmd args = (loc, state) <$ continue cmd args 57 | continue "help" _ = putStr helpMessage 58 | continue "memory" _ = mapM_ print . chunk 8 . V.toList . ram $ memory state 59 | continue cmd _ = printf "Unknown command `%s'!\n%s" cmd errorMessage 60 | -------------------------------------------------------------------------------- /src/foo.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TikhonJelvis/array-forth/66d3d20af970d8be256f7999b1dd35ea69200045/src/foo.pdf -------------------------------------------------------------------------------- /src/out.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TikhonJelvis/array-forth/66d3d20af970d8be256f7999b1dd35ea69200045/src/out.pdf -------------------------------------------------------------------------------- /test/Language/ArrayForth/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE ImplicitParams #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | module Main where 6 | 7 | import Control.Applicative ((<$>), (<*>)) 8 | 9 | import Data.Bits (complement, xor, (.&.)) 10 | import Data.Maybe (fromJust) 11 | 12 | import Language.ArrayForth.Interpreter hiding (run) 13 | import Language.ArrayForth.NativeProgram 14 | import Language.ArrayForth.Opcode 15 | import Language.ArrayForth.Parse () 16 | import Language.ArrayForth.Program 17 | import Language.ArrayForth.Stack 18 | import Language.ArrayForth.State hiding (State (..), (!)) 19 | import qualified Language.ArrayForth.State as S 20 | 21 | import Test.Framework.Providers.HUnit 22 | import Test.Framework.Providers.QuickCheck2 23 | import Test.Framework.TH 24 | import Test.HUnit 25 | import Test.QuickCheck (forAll, (==>)) 26 | import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) 27 | import Test.QuickCheck.Gen (Gen, elements, listOf, 28 | oneof) 29 | 30 | instance Arbitrary F18Word where arbitrary = fromInteger <$> arbitrary 31 | 32 | wordBits bits = (((2 ^ bits) - 1) .&.) <$> arbitrary 33 | 34 | instance Arbitrary Stack where arbitrary = foldl push empty <$> arbitrary 35 | 36 | instance Arbitrary Opcode where arbitrary = elements opcodes 37 | 38 | straight, jumps, fast, slow, inSlot3 :: Gen Opcode 39 | straight = elements $ filter (not . isJump) opcodes 40 | jumps = elements $ filter isJump opcodes 41 | fast = elements $ filter (\ e -> opcodeTime e == 1.5) opcodes 42 | slow = elements $ filter (\ e -> opcodeTime e == 5) opcodes 43 | inSlot3 = elements $ filter slot3 opcodes 44 | 45 | instance Arbitrary Instrs where arbitrary = oneof [instrs, jump3, jump2, jump1, constant] 46 | 47 | instrs, jump3, jump2, jump1, constant :: Gen Instrs 48 | instrs = Instrs <$> straight <*> straight <*> straight <*> inSlot3 49 | jump3 = Jump3 <$> straight <*> straight <*> jumps <*> wordBits 3 50 | jump2 = Jump2 <$> straight <*> jumps <*> wordBits 8 51 | jump1 = Jump1 <$> jumps <*> wordBits 10 52 | constant = Constant <$> arbitrary 53 | 54 | instance Arbitrary Instruction where 55 | arbitrary = oneof [opcode, number, unused] 56 | 57 | opcode, number, unused :: Gen Instruction 58 | opcode = Opcode <$> straight 59 | jump = Jump <$> jumps <*> (Concrete <$> arbitrary) 60 | number = Number <$> arbitrary 61 | unused = return Unused 62 | 63 | straightlineProgram :: Gen Program 64 | straightlineProgram = listOf $ oneof [Opcode <$> straight, number, unused] 65 | 66 | main = $(defaultMainGenerator) 67 | 68 | run = runNativeProgram startState . read 69 | 70 | memory ! address = fromJust $ memory S.! address 71 | 72 | -- Instruction utilities tests: 73 | prop_bits word = word == (toBits $ fromBits word) 74 | prop_opcode word = word < 0x20 ==> word == (fromOpcode $ toOpcode word) 75 | prop_pushPop word stack = word == snd (pop $ push stack word) 76 | prop_pop stack = stack == foldl1 (.) (replicate 8 $ fst . pop) stack 77 | prop_runningTimeConstant program = forAll constant $ \ c -> 78 | runningTime (program ++ [c]) == runningTime program 79 | 80 | prop_showReadProgram :: Program -> Bool 81 | prop_showReadProgram program = program == read (show program) 82 | 83 | prop_showReadNative :: NativeProgram -> Bool 84 | prop_showReadNative program = program == read (show program) 85 | 86 | -- Returns whether the given instruction word has jump addresses for 87 | -- all the jumps and has no jumps without addresses. 88 | isValid :: Instrs -> Bool 89 | isValid (Instrs a b c d) = all (not . isJump) [a, b, c] && slot3 d 90 | isValid (Jump3 a b c addr) = all (not . isJump) [a, b] && isJump c 91 | isValid (Jump2 a b addr) = not (isJump a) && isJump b 92 | isValid (Jump1 a addr) = isJump a 93 | isValid Constant{} = True 94 | 95 | -- For now, we do not really support jumps in the Program type. 96 | prop_validNative = all isValid . toNative 97 | 98 | case_runningTime = do let time = runningTime . read 99 | 11.0 @=? time ". . . . @p . . . 10" 100 | 0 @=? time ". . . ." 101 | 20 @=? time "@p @p @p @p 1 2 3 4" 102 | 103 | -- Testing the utility functions for actually synthesizing programs: 104 | case_toNative = do read "@p . @p . 2 10 or . . ." @=? 105 | toNative [Number 2, Opcode Nop, Number 10, Opcode Or] 106 | read "@p . @p . 2 10 + . . ." @=? 107 | toNative [Number 2, Opcode Nop, Number 10, Opcode Plus] 108 | read "jump 5 . + @p @p 1 2 @p . . . 3" @=? 109 | toNative (read ":foo jump :bar + 1 2 3 :bar") 110 | case_fromNative = do [Opcode Nop, Opcode Nop, Opcode Nop, Opcode Nop] @=? 111 | fromNative (read ". . . .") 112 | [Opcode Nop, Number 1, Number 2, Opcode Nop] @=? 113 | fromNative (read ". @p @p . 1 2") 114 | 115 | -- Interpreter tests (ported from Racket): 116 | unchanged = assertBool "Something changed!" . all (== 0) 117 | a,b,p,r,s,t :: (?res :: S.State) => F18Word 118 | a = S.a ?res 119 | b = S.b ?res 120 | p = S.p ?res 121 | r = S.r ?res 122 | s = S.s ?res 123 | t = S.t ?res 124 | 125 | memory :: (?res :: S.State) => Memory 126 | memory = S.memory ?res 127 | 128 | dataStack :: (?res :: S.State) => Stack 129 | dataStack = S.dataStack ?res 130 | 131 | case_1 = do let ?res = run "@p @p . + 2 3" 132 | 3 @=? p 133 | 5 @=? t 134 | unchanged [a, b, r, s] 135 | case_2 = do let ?res = run "@p - . . 0" 136 | 2 @=? p 137 | (- 1) @=? t 138 | unchanged [a, b, r, s] 139 | case_3 = do let ?res = run "@p b! @p . 4 42 !b @p . ." 140 | 5 @=? p 141 | 42 @=? t 142 | 4 @=? b 143 | 42 @=? memory ! 4 144 | unchanged [a, r, s] 145 | case_4 = do let ?res = run "- dup dup dup dup dup dup dup" 146 | 2 @=? p 147 | (- 1) @=? t 148 | (- 1) @=? s 149 | fill empty [0, 0, -1, -1, -1, -1, -1, -1] @=? dataStack 150 | unchanged [a, b, r] 151 | case_5 = do let ?res = run "dup or a! @p 123 !+ @p ! . 456 dup or a! . @+ 2* @+ . 2/ + ! ." 152 | 2 @=? a 153 | 123 @=? memory ! 0 154 | 456 @=? memory ! 1 155 | 474 @=? memory ! 2 156 | 7 @=? p 157 | unchanged [b, r, s, t] 158 | case_ret = do let ?res = run "call 2 . . . . ; . . ." 159 | 1 @=? p 160 | unchanged [a, b, r, s, t] 161 | case_jump = do let ?res = run "jump 42" 162 | 42 @=? p 163 | unchanged [a, b, r, s, t] 164 | case_call = do let ?res = run "call 10" 165 | 1 @=? r 166 | 10 @=? p 167 | unchanged [a, b, s, t] 168 | case_unext = do let ?res = run ". . unext ." 169 | 1 @=? p 170 | unchanged [a, b, r, s, t] 171 | case_unext' = do let ?res = run "@p push . . 41 @+ . . unext" 172 | 3 @=? p 173 | 42 @=? a 174 | unchanged [b, r, s, t] 175 | case_if = do let ?res = run "if 42" 176 | 1 @=? p 177 | unchanged [a, b, r, s, t] 178 | case_if' = do let ?res = run "@p if 42 10" 179 | 42 @=? p 180 | unchanged [a, b, r, s] 181 | case_minusIf = do let ?res = run "-if 42" 182 | 42 @=? p 183 | unchanged [a, b, r, s, t] 184 | case_minusIf' = do let ?res = run "- -if 42" 185 | 1 @=? p 186 | unchanged [a, b, r, s] 187 | case_fetchP = do let ?res = run "@p . . . 42" 188 | 2 @=? p 189 | 42 @=? t 190 | unchanged [a, b, r, s] 191 | case_fetchPlus = do let ?res = run "@+ . . ." 192 | 1 @=? a 193 | memory ! 0 @=? t 194 | unchanged [b, r, s] 195 | case_fetchB = do let ?res = run "@b . . ." 196 | memory ! 0 @=? t 197 | unchanged [b, r, s] 198 | case_fetch = do let ?res = run "@ . . ." 199 | memory ! 0 @=? t 200 | unchanged [b, r, s] 201 | case_storeP = do let ?res = run "@p !p . . 42" 202 | 3 @=? p 203 | 42 @=? memory ! (p - 1) 204 | unchanged [a, b, r, s] 205 | case_storePlus = do let ?res = run "@p !+ . . 42" 206 | 1 @=? a 207 | 2 @=? p 208 | 42 @=? memory ! 0 209 | unchanged [b, r, s] 210 | case_storePlus' = do let ?res = run "@p @p a! . 42 10 !+ . . ." 211 | 11 @=? a 212 | 4 @=? p 213 | 42 @=? memory ! 10 214 | unchanged [b, r, s] 215 | case_storePlus'' = do let ?res = run "dup or a! @p 123 !+ @p ! . 456" 216 | 1 @=? a 217 | 123 @=? memory ! 0 218 | 456 @=? memory ! 1 219 | unchanged [b, r, s, t] 220 | case_storeB = do let ?res = run "@p !b . . 42" 221 | 2 @=? p 222 | 42 @=? memory ! 0 223 | unchanged [a, b, r, s] 224 | case_storeB' = do let ?res = run "@p @p b! . 42 10 !b . . ." 225 | 4 @=? p 226 | 42 @=? memory ! 10 227 | 10 @=? b 228 | unchanged [a, r, s] 229 | case_store = do let ?res = run "@p ! . . 42" 230 | 2 @=? p 231 | 42 @=? memory ! 0 232 | unchanged [a, b, r, s] 233 | case_store' = do let ?res = run "@p @p a! . 42 10 ! . . ." 234 | 10 @=? a 235 | 4 @=? p 236 | 42 @=? memory ! 10 237 | unchanged [b, r, s] 238 | case_store'' = do let ?res = run "dup or a! @p 123 ! . . ." 239 | 0 @=? a 240 | 123 @=? memory ! 0 241 | unchanged [b, r, s, t] 242 | case_multiplyStepEven = do let ?res = run "@p @p @p . 10 0 10 a! +* . ." 243 | 5 @=? a 244 | 10 @=? s 245 | 0 @=? t 246 | unchanged [b, r] 247 | case_multiplyStepOdd = do let ?res = run "@p @p @p . 10 0 11 a! +* . ." 248 | 5 @=? a 249 | 10 @=? s 250 | 5 @=? t 251 | unchanged [b, r] 252 | case_multiplyStep = do let ?res = run "@p @p @p . 262143 0 1 a! +* . ." 253 | 0x20000 @=? a 254 | 0x3ffff @=? s 255 | 0x3ffff @=? t 256 | unchanged [b, r] 257 | case_multiply = do let ?res = run "@p @p @p . 10 0 11 a! +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* ." 258 | 110 @=? a 259 | 10 @=? s 260 | 0 @=? t 261 | unchanged [b, r] 262 | case_multiply' = do let ?res = run "@p @p @p . 262143 0 1 a! +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* ." 263 | 0x3ffff @=? a 264 | 0x3ffff @=? s 265 | 0x3ffff @=? t 266 | unchanged [b, r] 267 | case_multiply'' = do let ?res = run "@p @p @p . 262143 0 262143 a! +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* ." 268 | 1 @=? a 269 | 0x3ffff @=? s 270 | 0x3ffff @=? t 271 | unchanged [b, r] 272 | case_multiply''' = do let ?res = run "@p @p @p . 1 0 262143 a! +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* ." 273 | 0x3ffff @=? a 274 | 1 @=? s 275 | 0 @=? t 276 | unchanged [b, r] 277 | case_multiply'''' = do let ?res = run "@p @p @p . 261612 0 7276 a! +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* ." 278 | 0xef90 @=? a 279 | 0x3fdec @=? s 280 | 0x3fff1 @=? t 281 | unchanged [b, r] 282 | case_times2 = do let ?res = run "@p 2* . . 2" 283 | 4 @=? t 284 | 2 @=? p 285 | unchanged [a, b, r, s] 286 | case_div2 = do let ?res = run "@p 2/ . . 4" 287 | 2 @=? t 288 | 2 @=? p 289 | unchanged [a, b, r, s] 290 | case_not = do let ?res = run "- . . ." 291 | (- 1) @=? t 292 | 1 @=? p 293 | unchanged [a, b, r, s] 294 | case_not' = do let ?res = run "@p - . . 42" 295 | complement 42 @=? t 296 | 2 @=? p 297 | unchanged [a, b, r, s] 298 | case_plus = do let ?res = run "@p @p . + 12 30" 299 | 42 @=? t 300 | 3 @=? p 301 | unchanged [a, b, r, s] 302 | case_and = do let ?res = run "@p @p and . 12 30" 303 | 12 .&. 30 @=? t 304 | 3 @=? p 305 | unchanged [a, b, r, s] 306 | case_or = do let ?res = run "@p @p or . 12 30" 307 | 12 `xor` 30 @=? t 308 | 3 @=? p 309 | unchanged [a, b, r, s] 310 | case_drop = do let ?res = run "@p @p drop . 1 2" 311 | 1 @=? t 312 | 3 @=? p 313 | unchanged [a, b, r, s] 314 | case_dup = do let ?res = run "@p dup . . 42" 315 | 42 @=? t 316 | 42 @=? s 317 | 2 @=? p 318 | unchanged [a, b, r] 319 | case_dup' = do let ?res = run "@p dup or . 42" 320 | 0 @=? t 321 | 2 @=? p 322 | unchanged [a, b, r, s] 323 | case_pop = do let ?res = run "call 2 0 pop . . ." 324 | 1 @=? t 325 | unchanged [a, b, r, s] 326 | case_over = do let ?res = run "@p @p over . 1 2" 327 | 1 @=? t 328 | 2 @=? s 329 | 3 @=? p 330 | unchanged [a, b, r] 331 | case_a = do let ?res = run "@p a! a . 42" 332 | 42 @=? a 333 | 42 @=? t 334 | 2 @=? p 335 | unchanged [b, r, s] 336 | case_nop = do let ?res = step $ run ". . . ." 337 | 1 @=? p 338 | unchanged [a, b, r, s, t] 339 | case_push = do let ?res = run "@p push . . 42" 340 | 42 @=? r 341 | 2 @=? p 342 | unchanged [a, b, s, t] 343 | case_setB = do let ?res = run "@p b! . . 42" 344 | 42 @=? b 345 | 2 @=? p 346 | unchanged [a, r, s, t] 347 | case_setA = do let ?res = run "@p a! . . 42" 348 | 42 @=? a 349 | 2 @=? p 350 | unchanged [b, r, s, t] 351 | -------------------------------------------------------------------------------- /test/performance/infinite-loop.f18: -------------------------------------------------------------------------------- 1 | @p . if 0 1 2 | -------------------------------------------------------------------------------- /test/performance/loop.f18: -------------------------------------------------------------------------------- 1 | @p push . . 213568 2 | @p a + . 1 3 | pop dup a! . 4 | or a push . 5 | a! next 2 6 | -------------------------------------------------------------------------------- /test/performance/unext.f18: -------------------------------------------------------------------------------- 1 | @p push . . -1 2 | -------------------------------------------------------------------------------- /traced.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TikhonJelvis/array-forth/66d3d20af970d8be256f7999b1dd35ea69200045/traced.pdf --------------------------------------------------------------------------------