├── COPYING ├── HBEAM.cabal ├── README.md ├── Setup.hs ├── mymath.beam └── src ├── Language └── Erlang │ └── BEAM │ ├── Emulator.hs │ ├── Loader.hs │ ├── Mailbox.hs │ ├── Opcodes.hs │ ├── Operation.hs │ ├── Types.hs │ ├── Utils.hs │ ├── genop.rb │ └── genop.tab └── Main.hs /COPYING: -------------------------------------------------------------------------------- 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 | -------------------------------------------------------------------------------- /HBEAM.cabal: -------------------------------------------------------------------------------- 1 | Name: HBEAM 2 | Version: 0.0 3 | Description: Haskell virtual machine for Erlang's BEAM bytecode 4 | License: GPL 5 | License-file: COPYING 6 | Author: Mikael Brockman 7 | Maintainer: phubuh@gmail.com 8 | Build-Type: Simple 9 | Cabal-Version: >=1.2 10 | 11 | Executable hbeam 12 | hs-source-dirs: src 13 | Main-is: Main.hs 14 | Build-Depends: base >= 3 && < 5, binary, bytestring, text, monad-loops, 15 | zlib, array, containers, transformers, stm >= 2.2 16 | ghc-options: -Wall 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | HBEAM 2 | ===== 3 | 4 | Hello! This is a sketchy implementation of a BEAM emulator. It is supposed 5 | to read & evaluate Erlang bytecode files. 6 | 7 | Right now it doesn't understand very much, but if you have the simplest 8 | possible factorial function exported from `mymath.beam` — it's included — you 9 | can run it like this: 10 | 11 | $ hbeam mymath factorial '[EVInteger 6]' 12 | ... after lots of debug spam ... 13 | Return value: EVInteger 720 14 | 15 | Wow! 16 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain -------------------------------------------------------------------------------- /mymath.beam: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mbrock/HBEAM/4f8e2dc6816afdefc622398613b676cd0e307b3c/mymath.beam -------------------------------------------------------------------------------- /src/Language/Erlang/BEAM/Emulator.hs: -------------------------------------------------------------------------------- 1 | module Language.Erlang.BEAM.Emulator where 2 | 3 | import Language.Erlang.BEAM.Loader 4 | import Language.Erlang.BEAM.Types 5 | import Language.Erlang.BEAM.Utils 6 | import Language.Erlang.BEAM.Mailbox 7 | 8 | import Data.Map (Map) 9 | import qualified Data.Map as Map 10 | 11 | import Data.Char (ord, chr) 12 | import Data.List (tails) 13 | 14 | import Data.Array.IO (IOArray) 15 | import Data.Array.MArray (readArray, writeArray, getBounds, newArray) 16 | 17 | import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) 18 | 19 | import Control.Applicative ((<$>), (<*>)) 20 | 21 | import Control.Monad (when, forM_, join) 22 | import Control.Monad.IO.Class (liftIO) 23 | import Control.Monad.Trans.Reader (ReaderT, runReaderT, local, asks) 24 | 25 | import Control.Monad.STM (STM, atomically) 26 | 27 | import Control.Concurrent (forkIO) 28 | import Control.Concurrent.STM.TVar 29 | 30 | 31 | --- Data types relevant to the emulator. 32 | 33 | data Function = Function { functionArity :: Arity 34 | , functionLabels :: Map Label CodePointer 35 | , functionEntry :: Label 36 | , functionModule :: Module } 37 | deriving Show 38 | 39 | data Module = Module { moduleFunctions :: Map (Atom, Arity) Function 40 | , moduleEntries :: Map Label Function 41 | , moduleImports :: [MFA] } 42 | deriving Show 43 | 44 | data Node = Node { nodeAtoms :: [Atom] 45 | , nodeModules :: Map Atom Module 46 | , nodePIDs :: TVar (Map PID Process) 47 | , nodeNextPID :: TVar PID } 48 | 49 | type Stack = IOArray Int EValue 50 | type CodePointer = [Operation] 51 | 52 | data Process = Process { procRegs :: IOArray Int EValue 53 | , procStack :: IORef Stack 54 | , procSP :: IORef Int 55 | , procRetStack :: IORef [(Function, CodePointer)] 56 | , procPID :: PID 57 | , procMailbox :: Mailbox } 58 | 59 | data EmulationCtx = 60 | EmulationCtx { emuNode :: Node 61 | , emuProcess :: Process 62 | , emuFunction :: Function 63 | , emuTuple :: (Arity, [EValue], Operand) } 64 | 65 | type Emulation a = ReaderT EmulationCtx IO a 66 | 67 | liftSTM :: STM a -> Emulation a 68 | liftSTM = liftIO . atomically 69 | 70 | --- Emulation state data stuff. 71 | 72 | findMFA :: Node -> MFA -> Maybe Function 73 | findMFA node (MFA m f a) = 74 | do m' <- Map.lookup m (nodeModules node) 75 | Map.lookup (f, a) (moduleFunctions m') 76 | 77 | emuModule :: EmulationCtx -> Module 78 | emuModule = functionModule . emuFunction 79 | 80 | nodeFromBEAMFile :: BEAMFile -> IO Node 81 | nodeFromBEAMFile b = 82 | do pids <- newTVarIO Map.empty 83 | nextPID <- newTVarIO 0 84 | return Node { nodeAtoms = beamFileAtoms b 85 | , nodeModules = Map.fromList [(name, moduleFromBEAMFile b)] 86 | , nodePIDs = pids 87 | , nodeNextPID = nextPID } 88 | where name = head (beamFileAtoms b) 89 | 90 | moduleFromBEAMFile :: BEAMFile -> Module 91 | moduleFromBEAMFile b = 92 | let m = Module { moduleFunctions = Map.fromList fs 93 | , moduleEntries = es 94 | , moduleImports = beamFileImports b } 95 | fs = map (functionFromFunDef m) (beamFileFunDefs b) 96 | es = Map.fromList [(functionEntry f, f) | (_, f) <- fs] 97 | in m 98 | 99 | functionFromFunDef :: Module -> FunDef -> ((Atom, Arity), Function) 100 | functionFromFunDef m (FunDef name arity entry code) = 101 | ((name, arity), Function { functionArity = arity 102 | , functionLabels = splitBlocks code 103 | , functionEntry = entry 104 | , functionModule = m }) 105 | 106 | -- Scan a function block for labels. 107 | splitBlocks :: [Operation] -> Map Label CodePointer 108 | splitBlocks code = foldr f Map.empty (zip code (tail (tails code))) 109 | where f (OpLabel i, pc) m = Map.insert i pc m 110 | f _ m = m 111 | 112 | 113 | --- Processes, PIDs, and messages. 114 | 115 | spawnProcess :: Node -> MFA -> [EValue] -> IO PID 116 | spawnProcess n mfa args = 117 | do pid <- atomically $ incrementTVar (nodeNextPID n) 118 | p <- newProcess pid 119 | atomically $ modifyTVar (nodePIDs n) (Map.insert pid p) 120 | let Just f = findMFA n mfa 121 | forkIO $ do 122 | result <- runReaderT (moveArgsToRegs args >> call >> getReg 0) 123 | EmulationCtx { emuNode = n 124 | , emuProcess = p 125 | , emuFunction = f 126 | , emuTuple = undefined } 127 | putStrLn $ "PROCESS " ++ show pid ++ ": " ++ show result 128 | return pid 129 | 130 | lookupPID :: EValue -> Emulation Process 131 | lookupPID (EVPID pid) = 132 | (Map.! pid) <$> (asks (nodePIDs . emuNode) >>= liftIO . readTVarIO) 133 | lookupPID x = 134 | fail $ "lookupPID: " ++ show x ++ " is not a PID" 135 | 136 | newProcess :: PID -> IO Process 137 | newProcess pid = 138 | Process 139 | <$> newArray (0, 7) (EVInteger 0) 140 | <*> (newArray (0, 7) (EVInteger 0) >>= newIORef) 141 | <*> newIORef 0 142 | <*> newIORef [] 143 | <*> return pid 144 | <*> atomically newMailbox 145 | 146 | send :: EValue -> EValue -> Emulation () 147 | send pid x = 148 | do p <- lookupPID pid 149 | liftSTM $ deliverMessage (procMailbox p) x 150 | 151 | currentMailbox :: Emulation Mailbox 152 | currentMailbox = asks (procMailbox . emuProcess) 153 | 154 | 155 | --- Registers and stack. 156 | 157 | setReg :: Int -> EValue -> Emulation () 158 | setReg i x = do asks emuProcess >>= \p -> liftIO $ writeArray (procRegs p) i x 159 | pid <- asks (procPID . emuProcess) 160 | liftIO . putStrLn $ show pid ++ " >> x " ++ show i ++ 161 | " := " ++ show x 162 | 163 | getReg :: Int -> Emulation EValue 164 | getReg i = asks emuProcess >>= \p -> liftIO $ readArray (procRegs p) i 165 | 166 | getRegistersUpTo :: Int -> Emulation [EValue] 167 | getRegistersUpTo n = mapM (getOperand . XOperand) [0..(n-1)] 168 | 169 | moveArgsToRegs :: [EValue] -> Emulation () 170 | moveArgsToRegs args = mapM_ (uncurry setReg) (zip [0..] args) 171 | 172 | setStack :: Int -> EValue -> Emulation () 173 | setStack i x = do p <- asks emuProcess 174 | liftIO $ do 175 | stack <- readIORef (procStack p) 176 | sp <- readIORef (procSP p) 177 | writeArray stack (sp - i) x 178 | putStrLn $ show (procPID p) ++ " >> y " ++ show sp ++ 179 | "-" ++ show i ++ " := " ++ show x 180 | 181 | getStack :: Int -> Emulation EValue 182 | getStack i = do p <- asks emuProcess 183 | liftIO $ do 184 | stack <- readIORef (procStack p) 185 | sp <- readIORef (procSP p) 186 | readArray stack (sp - i) 187 | 188 | getSP :: Emulation Int 189 | getSP = asks emuProcess >>= liftIO . readIORef . procSP 190 | 191 | advanceSP :: Int -> Emulation () 192 | advanceSP n = asks emuProcess >>= \p -> liftIO (modifyIORef (procSP p) (+ n)) 193 | 194 | allocate :: Int -> Emulation () 195 | allocate size = 196 | do getSP >>= ensureStackSize . (+ size) 197 | advanceSP size 198 | 199 | ensureStackSize :: Int -> Emulation () 200 | ensureStackSize n = 201 | do p <- asks emuProcess 202 | liftIO $ do 203 | stack <- readIORef (procStack p) 204 | size <- ((+ 1) . snd) <$> getBounds stack 205 | when (size <= n) 206 | (do newStack <- newArray (0, n * 2) (EVInteger 0) 207 | forM_ [0..(size - 1)] 208 | (\i -> readArray stack i >>= writeArray newStack i) 209 | writeIORef (procStack p) newStack) 210 | 211 | 212 | --- The return stack. 213 | 214 | pushRetStack :: CodePointer -> Emulation () 215 | pushRetStack cp = 216 | do p <- asks emuProcess 217 | f <- asks emuFunction 218 | liftIO (modifyIORef (procRetStack p) ((f, cp):)) 219 | 220 | popRetStack :: Emulation (Maybe (Function, CodePointer)) 221 | popRetStack = do p <- asks emuProcess 222 | stack <- liftIO $ readIORef (procRetStack p) 223 | case stack of 224 | (pc:pcs) -> do liftIO $ writeIORef (procRetStack p) pcs 225 | return (Just pc) 226 | _ -> return Nothing 227 | 228 | doReturn :: Emulation () 229 | doReturn = do x <- popRetStack 230 | case x of 231 | Just (f, pc) -> 232 | local (\c -> c { emuFunction = f }) (interpret pc) 233 | Nothing -> 234 | return () 235 | 236 | 237 | --- Evaluation. 238 | 239 | interpret :: CodePointer -> Emulation () 240 | interpret [] = return () 241 | interpret (o:os) = do p <- asks emuProcess 242 | liftIO . putStrLn $ show (procPID p) ++ ": " ++ show o 243 | interpret1 o os 244 | 245 | -- Emulates a single instruction & then continues. 246 | interpret1 :: Operation -> CodePointer -> Emulation () 247 | interpret1 o os = 248 | case o of 249 | OpLabel _ -> interpret os 250 | 251 | -- Supposed to test whether heap is full and if so GC. 252 | OpTestHeap -> interpret os 253 | 254 | -- Stack & heap management stuff. 255 | OpAllocate size -> allocate size >> interpret os 256 | OpInit a -> setOperand a (EVList []) >> interpret os 257 | OpDeallocate m -> 258 | do advanceSP (- (fromIntegral m)) 259 | interpret os 260 | 261 | -- Basic flow control. 262 | OpJump label -> jump label 263 | OpReturn -> doReturn 264 | 265 | -- Conditionals. 266 | OpIsEqExact label a b -> 267 | do eq <- (==) <$> getOperand a <*> getOperand b 268 | if eq then interpret os else jump label 269 | OpTestArity label x n -> 270 | do EVTuple x' <- getOperand x 271 | if length x' == n 272 | then interpret os 273 | else jump label 274 | 275 | -- Type checks. 276 | OpIsTuple label x -> 277 | do x' <- getOperand x 278 | case x' of 279 | EVTuple _ -> interpret os 280 | _ -> jump label 281 | 282 | -- Invocations. 283 | OpBIF0 i dest -> 284 | do getBIF i >>= ($ []) >>= setOperand dest 285 | interpret os 286 | OpBIF2 i a b dest -> 287 | do (a', b') <- (,) <$> getOperand a <*> getOperand b 288 | getBIF i >>= ($ [a', b']) >>= setOperand dest 289 | interpret os 290 | OpCall _ label -> 291 | do pushRetStack os 292 | callByLabel label 293 | OpCallLast label dealloc -> 294 | do advanceSP (- (fromIntegral dealloc)) 295 | jump label 296 | OpCallExt n i -> 297 | do getRegistersUpTo n >>= callImportedFunction i 298 | interpret os 299 | OpCallExtOnly n i -> 300 | -- FIXME: Should this be more tail recursive? 301 | do getRegistersUpTo n >>= callImportedFunction i 302 | doReturn 303 | OpCallExtLast n i dealloc -> 304 | do args <- getRegistersUpTo n 305 | advanceSP (- (fromIntegral dealloc)) 306 | callImportedFunction i args 307 | doReturn 308 | 309 | -- Message sending and receiving. 310 | OpSend -> 311 | do join $ send <$> getReg 0 <*> getReg 1 312 | interpret os 313 | OpLoopRec label dest -> 314 | currentMailbox >>= liftSTM . pollMailbox >>= 315 | maybe (jump label) (\x -> setOperand dest x >> interpret os) 316 | OpLoopRecEnd label -> 317 | do currentMailbox >>= liftSTM . moveMessageToSaveQueue 318 | jump label 319 | OpRemoveMessage -> 320 | do m <- currentMailbox 321 | liftSTM (removeMessage m >> unreadSaveQueue m) 322 | interpret os 323 | OpWait label -> 324 | do currentMailbox >>= liftSTM . awaitMessage 325 | jump label 326 | OpWaitTimeout label x -> 327 | do timeout <- getOperand x 328 | mailbox <- currentMailbox 329 | case timeout of 330 | EVAtom (Atom "infinity") -> 331 | liftSTM (awaitMessage mailbox) >> jump label 332 | EVInteger n -> 333 | join . liftIO $ 334 | awaitMessageTimeout mailbox (fromIntegral n) 335 | (jump label) (interpret os) 336 | _ -> 337 | fail $ "wait_timeout: " ++ show timeout ++ " not a timeout" 338 | OpTimeout -> 339 | do currentMailbox >>= liftSTM . unreadSaveQueue 340 | interpret os 341 | 342 | -- Data stuff. 343 | OpMove src dest -> 344 | do getOperand src >>= setOperand dest 345 | interpret os 346 | OpPutList car cdr dest -> 347 | do car' <- getOperand car 348 | EVList cdr' <- getOperand cdr 349 | setOperand dest (EVList (car':cdr')) 350 | interpret os 351 | OpPutTuple n dest -> 352 | local (\c -> c { emuTuple = (n, [], dest) }) (interpret os) 353 | OpPut x -> 354 | do x' <- getOperand x 355 | (n, xs, dest) <- asks emuTuple 356 | case n of 357 | 1 -> do setOperand dest (EVTuple (reverse (x':xs))) 358 | interpret os 359 | _ -> local (\c -> c { emuTuple = (n - 1, x':xs, dest) }) $ 360 | interpret os 361 | OpGetTupleElement x i dest -> 362 | do getOperand x >>= \(EVTuple xs) -> setOperand dest (xs !! i) 363 | interpret os 364 | 365 | _ -> fail $ "unhandled instruction: " ++ show o 366 | 367 | 368 | --- Helpers for the evaluator. 369 | 370 | call :: Emulation () 371 | call = asks emuFunction >>= callByLabel . functionEntry 372 | 373 | -- Call the local function having a given entry point. 374 | callByLabel :: Label -> Emulation () 375 | callByLabel label = 376 | do f <- asks ((Map.! label) . moduleEntries . emuModule) 377 | local (\c -> c { emuFunction = f }) 378 | (interpret (functionLabels f Map.! label)) 379 | 380 | jump :: Label -> Emulation () 381 | jump label = do f <- asks emuFunction 382 | interpret (functionLabels f Map.! label) 383 | 384 | 385 | --- Handling nonlocal function calls. 386 | 387 | callImportedFunction :: Index -> [EValue] -> Emulation() 388 | callImportedFunction i args = 389 | getImportedFunction i >>= ($ args) >>= setOperand (XOperand 0) 390 | 391 | getImportedFunction :: Index -> Emulation ([EValue] -> Emulation EValue) 392 | getImportedFunction i = 393 | do thisModule <- asks emuModule 394 | case moduleImports thisModule !! fromIntegral i of 395 | MFA (Atom "erlang") (Atom "spawn") 3 -> 396 | return $ \[EVAtom m, EVAtom f, EVList args] -> 397 | do n <- asks emuNode 398 | let mfa = MFA m f (fromIntegral (length args)) 399 | pid <- liftIO $ spawnProcess n mfa args 400 | return (EVPID pid) 401 | MFA (Atom "hbeam") (Atom "display") _ -> 402 | return $ \xs -> 403 | do liftIO $ putStrLn ("!! " ++ displayEVs xs) 404 | return (EVInteger 0) 405 | mfa -> fail $ "no such imported function " ++ showMFA mfa 406 | 407 | getBIF :: Index -> Emulation ([EValue] -> Emulation EValue) 408 | getBIF i = 409 | do f <- asks emuFunction 410 | p <- asks emuProcess 411 | case moduleImports (functionModule f) !! fromIntegral i of 412 | MFA (Atom "erlang") (Atom "-") 2 -> 413 | return $ \([EVInteger x, EVInteger y]) -> return (EVInteger (x - y)) 414 | MFA (Atom "erlang") (Atom "+") 2 -> 415 | return $ \([EVInteger x, EVInteger y]) -> return (EVInteger (x + y)) 416 | MFA (Atom "erlang") (Atom "*") 2 -> 417 | return $ \([EVInteger x, EVInteger y]) -> return (EVInteger (x * y)) 418 | MFA (Atom "erlang") (Atom "self") 0 -> 419 | return $ \[] -> return $ EVPID (procPID p) 420 | mfa -> fail $ "no BIF for " ++ showMFA mfa 421 | 422 | --- Handling operands. 423 | 424 | getOperand :: Operand -> Emulation EValue 425 | getOperand o = 426 | case o of 427 | IOperand x -> return (EVInteger x) 428 | XOperand i -> getReg (fromIntegral i) 429 | YOperand i -> getStack (fromIntegral i) 430 | AOperand (Atom "nil") -> return (EVList []) 431 | AOperand a -> return (EVAtom a) 432 | LOperand (ExtString s) -> 433 | return (EVList (map (EVInteger . fromIntegral . ord) s)) 434 | _ -> fail $ "getOperand: " ++ show o 435 | 436 | setOperand :: Operand -> EValue -> Emulation () 437 | setOperand o v = 438 | case o of 439 | XOperand i -> setReg (fromIntegral i) v 440 | YOperand i -> setStack (fromIntegral i) v 441 | _ -> fail $ "setOperand: " ++ show (o, v) 442 | 443 | 444 | --- Formatting utility functions. 445 | 446 | displayEVs :: [EValue] -> String 447 | displayEVs evs = concatMap f evs 448 | where f (EVList xs) = displayEVList xs 449 | f x = show x 450 | 451 | displayEVList :: [EValue] -> String 452 | displayEVList xs = if all p xs 453 | then map (\(EVInteger x) -> chr (fromIntegral x)) xs 454 | else show xs 455 | where p (EVInteger x) = (0 <= x) && (x <= 255) 456 | p _ = False 457 | 458 | showMFA :: MFA -> String 459 | showMFA (MFA (Atom m) (Atom f) a) = m ++ ":" ++ f ++ "/" ++ show a 460 | -------------------------------------------------------------------------------- /src/Language/Erlang/BEAM/Loader.hs: -------------------------------------------------------------------------------- 1 | module Language.Erlang.BEAM.Loader where 2 | 3 | import Language.Erlang.BEAM.Opcodes 4 | import Language.Erlang.BEAM.Operation 5 | import Language.Erlang.BEAM.Types 6 | 7 | import qualified Data.ByteString.Lazy as B 8 | import qualified Codec.Compression.Zlib as Zlib 9 | 10 | import Data.Binary () 11 | import Data.Binary.Get 12 | 13 | import Data.Char (chr) 14 | import Data.Bits 15 | 16 | import qualified Data.Text.Lazy as T 17 | import Data.Text.Lazy.Encoding (decodeASCII) 18 | 19 | import Control.Applicative ((<$>), (<*>)) 20 | 21 | import Control.Monad (unless, replicateM) 22 | import Control.Monad.Loops (untilM) 23 | 24 | data BEAMFile = BEAMFile { beamFileAtoms :: [Atom] 25 | , beamFileFunDefs :: [FunDef] 26 | , beamFileImports :: [MFA] 27 | , beamFileExports :: [Export] } 28 | deriving Show 29 | 30 | type ChunkData = B.ByteString 31 | type Chunk = (String, ChunkData) 32 | 33 | readBEAMFile :: ChunkData -> [Chunk] 34 | readBEAMFile binary = runGet (getHeader >> getChunks) binary 35 | where 36 | getHeader = skip 12 37 | getChunks = getChunk `untilM` isEmpty 38 | getChunk = 39 | do name <- getString (4 :: Int) 40 | content <- getInt32 >>= getLazyByteString 41 | align 4 42 | return (name, content) 43 | 44 | parseBEAMFile :: [Chunk] -> Maybe BEAMFile 45 | parseBEAMFile chunks = 46 | do atoms <- parseAtomChunk <$> lookup "Atom" chunks 47 | imports <- parseImportChunk atoms <$> lookup "ImpT" chunks 48 | exports <- parseExportChunk atoms <$> lookup "ExpT" chunks 49 | let literals = maybe [] parseLiteralChunk (lookup "LitT" chunks) 50 | fundefs <- parseCodeChunk atoms literals <$> lookup "Code" chunks 51 | return BEAMFile { beamFileAtoms = atoms 52 | , beamFileFunDefs = fundefs 53 | , beamFileImports = imports 54 | , beamFileExports = exports } 55 | 56 | parseImportChunk :: [Atom] -> ChunkData -> [MFA] 57 | parseImportChunk atoms = 58 | readListChunk $ MFA <$> getAtom <*> getAtom <*> getInt32 59 | where getAtom = readAtom atoms 60 | 61 | parseExportChunk :: [Atom] -> ChunkData -> [Export] 62 | parseExportChunk atoms = 63 | readListChunk $ Export <$> readAtom atoms <*> getInt32 <*> getInt32 64 | 65 | parseAtomChunk :: ChunkData -> [Atom] 66 | parseAtomChunk = 67 | readListChunk $ Atom <$> (getWord8 >>= getString) 68 | 69 | readListChunk :: Get a -> ChunkData -> [a] 70 | readListChunk m = runGet (readMany32 m) 71 | 72 | parseLiteralChunk :: ChunkData -> [External] 73 | parseLiteralChunk x = 74 | readListChunk (parseLiteral <$> (getInt32 >>= getLazyByteString)) y 75 | where y = Zlib.decompress $ B.drop 4 x 76 | 77 | parseLiteral :: ChunkData -> External 78 | parseLiteral = runGet (verify >> readExternal) 79 | where verify = getInt8 `expecting` ("external version magic", 131 :: Int) 80 | 81 | readExternal :: Get External 82 | readExternal = 83 | do tag <- getLatin1Char 84 | case tag of 85 | 'a' -> ExtInteger <$> getInt8 86 | 'h' -> ExtTuple <$> readMany8 readExternal 87 | 'd' -> ExtAtom <$> (getWord16be >>= getString) 88 | 'k' -> ExtString <$> (getWord16be >>= getString) 89 | 'l' -> ExtList <$> readMany32 readExternal 90 | 'j' -> ExtList <$> return [] 91 | _ -> fail $ "readExternal: can't do tag " ++ show tag 92 | 93 | parseCodeChunk :: [Atom] -> [External] -> ChunkData -> [FunDef] 94 | parseCodeChunk atoms literals = 95 | runGet $ do verifyHeader 96 | operations <- readOperation literals atoms `untilM` isEmpty 97 | return $ parseOperations atoms operations 98 | where verifyHeader = 99 | do getInt32 `expecting` ("code info length", 16 :: Int) 100 | getInt32 `expecting` ("instruction set", 0 :: Int) 101 | maxOpcode' <- getInt32 102 | unless (maxOpcode' <= maxOpcode) $ 103 | fail ("max opcode too big: " ++ show maxOpcode') 104 | skip 8 -- label & function counts 105 | 106 | parseOperations :: [Atom] -> [Operation] -> [FunDef] 107 | parseOperations atoms (_ : OpFuncInfo _ f a : xs@(OpLabel entry : _)) = 108 | let (code, rest) = splitToNextFunctionLabel [] xs 109 | in FunDef f a entry code : parseOperations atoms rest 110 | parseOperations _ [] = [] 111 | parseOperations _ xs = 112 | error $ "parseOperations: misformed function " ++ show xs 113 | 114 | splitToNextFunctionLabel :: [Operation] -> [Operation] -> 115 | ([Operation], [Operation]) 116 | splitToNextFunctionLabel acc ops = 117 | case ops of 118 | (_ : OpFuncInfo _ _ _ : _) -> (reverse acc, ops) 119 | [OpIntCodeEnd] -> (reverse acc, []) 120 | (x:xs) -> splitToNextFunctionLabel (x:acc) xs 121 | [] -> error "code chunk ended prematurely" 122 | 123 | readAtom :: [Atom] -> Get Atom 124 | readAtom atoms = atomIndex atoms <$> (getInt32 :: Get Int) 125 | 126 | readOperation :: [External] -> [Atom] -> Get Operation 127 | readOperation literals atoms = 128 | do (opcode, argCount) <- (opcodeInfo . fromIntegral) <$> getWord8 129 | args <- replicateM argCount (readOperand literals atoms) 130 | return (makeOperation opcode args) 131 | 132 | readOperand :: [External] -> [Atom] -> Get Operand 133 | readOperand literals atoms = 134 | do taggedByte <- getInt8 135 | case parseTag taggedByte of 136 | TagZ -> readZOperand literals taggedByte 137 | TagA -> readAOperand atoms taggedByte 138 | _ -> readIntegralOperand taggedByte 139 | 140 | parseTag :: Integer -> OperandTag 141 | parseTag x = 142 | case x .&. 7 of 143 | 0 -> TagU 144 | 1 -> TagI 145 | 2 -> TagA 146 | 3 -> TagX 147 | 4 -> TagY 148 | 5 -> TagF 149 | 6 -> TagH 150 | 7 -> TagZ 151 | _ -> error $ "weird tag: " ++ show x 152 | 153 | readAOperand :: [Atom] -> Integer -> Get Operand 154 | readAOperand atoms tag = 155 | do i <- readInteger tag 156 | return $ AOperand (case i of 157 | 0 -> Atom "nil" 158 | _ -> atomIndex atoms i) 159 | 160 | readZOperand :: [External] -> Integer -> Get Operand 161 | readZOperand literals tag = 162 | case tag `shiftR` 4 of 163 | 4 -> do UOperand i <- getInt8 >>= readIntegralOperand 164 | return $ LOperand (literalIndex literals i) 165 | _ -> fail $ "readZOperand: ? " ++ show (tag `shiftR` 4) 166 | 167 | readIntegralOperand :: Integer -> Get Operand 168 | readIntegralOperand tag = 169 | do i <- readInteger tag 170 | return $ case parseTag tag of 171 | TagU -> UOperand (fromIntegral i) 172 | TagI -> IOperand i 173 | TagX -> XOperand (fromIntegral i) 174 | TagY -> YOperand (fromIntegral i) 175 | TagF -> FOperand (fromIntegral i) 176 | x -> error ("readIntegralOperand: ? " ++ show x) 177 | 178 | readInteger :: Integer -> Get Integer 179 | readInteger tag | tag .&. 0x8 == 0 = 180 | return (tag `shiftR` 4) 181 | readInteger tag | tag .&. 0x10 == 0 = 182 | do b <- getInt8 183 | return (((tag .&. 0xe0) `shiftL` 3) .|. b) 184 | readInteger _ = 185 | fail "integer too big for me" 186 | 187 | 188 | -- Helper functions for BEAM data. 189 | 190 | atomIndex :: Integral a => [Atom] -> a -> Atom 191 | atomIndex xs i = xs !! (fromIntegral i - 1) 192 | 193 | literalIndex :: Integral a => [External] -> a -> External 194 | literalIndex xs i = xs !! fromIntegral i 195 | 196 | 197 | -- Helper functions for reading binary stuff. 198 | 199 | getString :: Integral a => a -> Get String 200 | getString n = unpackByteString <$> getLazyByteString (fromIntegral n) 201 | 202 | unpackByteString :: B.ByteString -> String 203 | unpackByteString = T.unpack . decodeASCII 204 | 205 | getInt32 :: Integral a => Get a 206 | getInt32 = fromIntegral <$> getWord32be 207 | 208 | getInt8 :: Integral a => Get a 209 | getInt8 = fromIntegral <$> getWord8 210 | 211 | getLatin1Char :: Get Char 212 | getLatin1Char = chr <$> getInt8 213 | 214 | readMany32 :: Get a -> Get [a] 215 | readMany32 m = getInt32 >>= flip replicateM m 216 | 217 | readMany8 :: Get a -> Get [a] 218 | readMany8 m = getInt8 >>= flip replicateM m 219 | 220 | align :: Int -> Get () 221 | align n = 222 | do m <- fromIntegral <$> bytesRead 223 | skip ((((m + n - 1) `div` n) * n) - m) 224 | 225 | expecting :: (Eq a, Show a) => Get a -> (String, a) -> Get () 226 | expecting m (name, x) = 227 | do y <- m 228 | unless (y == x) (fail ("Wrong " ++ name ++ ": expected " ++ 229 | show x ++ ", not " ++ show y)) 230 | -------------------------------------------------------------------------------- /src/Language/Erlang/BEAM/Mailbox.hs: -------------------------------------------------------------------------------- 1 | module Language.Erlang.BEAM.Mailbox 2 | ( 3 | Mailbox 4 | , newMailbox 5 | , pollMailbox 6 | , removeMessage 7 | , awaitMessage 8 | , awaitMessageTimeout 9 | , deliverMessage 10 | , moveMessageToSaveQueue 11 | , unreadSaveQueue 12 | ) where 13 | 14 | import Language.Erlang.BEAM.Utils (modifyTVar) 15 | import Language.Erlang.BEAM.Types (EValue) 16 | 17 | import Control.Monad (liftM2) 18 | 19 | import Control.Monad.STM (STM, atomically, orElse) 20 | 21 | import Control.Concurrent (forkIO, threadDelay) 22 | import Control.Concurrent.STM.TChan 23 | import Control.Concurrent.STM.TVar 24 | 25 | data Mailbox = Mailbox { mailboxChan :: TChan EValue 26 | , mailboxSaveQueue :: TVar [EValue] } 27 | 28 | newMailbox :: STM Mailbox 29 | newMailbox = liftM2 Mailbox newTChan (newTVar []) 30 | 31 | pollMailbox :: Mailbox -> STM (Maybe EValue) 32 | pollMailbox (Mailbox { mailboxChan = c }) = 33 | do empty <- isEmptyTChan c 34 | if empty 35 | then return Nothing 36 | else do x <- readTChan c 37 | unGetTChan c x 38 | return (Just x) 39 | 40 | removeMessage :: Mailbox -> STM () 41 | removeMessage m = readTChan (mailboxChan m) >> return () 42 | 43 | moveMessageToSaveQueue :: Mailbox -> STM EValue 44 | moveMessageToSaveQueue m = 45 | do x <- readTChan (mailboxChan m) 46 | modifyTVar (mailboxSaveQueue m) (x:) 47 | return x 48 | 49 | unreadSaveQueue :: Mailbox -> STM () 50 | unreadSaveQueue m = 51 | do xs <- readTVar (mailboxSaveQueue m) 52 | mapM_ (unGetTChan (mailboxChan m)) (reverse xs) 53 | writeTVar (mailboxSaveQueue m) [] 54 | 55 | deliverMessage :: Mailbox -> EValue -> STM () 56 | deliverMessage (Mailbox { mailboxChan = c }) x = writeTChan c x 57 | 58 | awaitMessage :: Mailbox -> STM () 59 | awaitMessage (Mailbox { mailboxChan = c }) = readTChan c >>= unGetTChan c 60 | 61 | newtype Milliseconds = Milliseconds Int 62 | 63 | startTimerChan :: Milliseconds -> IO (TChan ()) 64 | startTimerChan (Milliseconds n) = 65 | do c <- newTChanIO 66 | forkIO $ do threadDelay (n * 1000) 67 | atomically (writeTChan c ()) 68 | return c 69 | 70 | awaitMessageTimeout :: Mailbox -> Int -> a -> a -> IO a 71 | awaitMessageTimeout m msecs success failure = 72 | do timer <- startTimerChan (Milliseconds msecs) 73 | atomically $ orElse (awaitMessage m >> return success) 74 | (readTChan timer >> return failure) 75 | 76 | -------------------------------------------------------------------------------- /src/Language/Erlang/BEAM/Opcodes.hs: -------------------------------------------------------------------------------- 1 | module Language.Erlang.BEAM.Opcodes where 2 | 3 | opcodeInfo :: Int -> (String, Int) 4 | opcodeInfo 1 = ("label", 1) 5 | opcodeInfo 2 = ("func_info", 3) 6 | opcodeInfo 3 = ("int_code_end", 0) 7 | opcodeInfo 4 = ("call", 2) 8 | opcodeInfo 5 = ("call_last", 3) 9 | opcodeInfo 6 = ("call_only", 2) 10 | opcodeInfo 7 = ("call_ext", 2) 11 | opcodeInfo 8 = ("call_ext_last", 3) 12 | opcodeInfo 9 = ("bif0", 2) 13 | opcodeInfo 10 = ("bif1", 4) 14 | opcodeInfo 11 = ("bif2", 5) 15 | opcodeInfo 12 = ("allocate", 2) 16 | opcodeInfo 13 = ("allocate_heap", 3) 17 | opcodeInfo 14 = ("allocate_zero", 2) 18 | opcodeInfo 15 = ("allocate_heap_zero", 3) 19 | opcodeInfo 16 = ("test_heap", 2) 20 | opcodeInfo 17 = ("init", 1) 21 | opcodeInfo 18 = ("deallocate", 1) 22 | opcodeInfo 19 = ("return", 0) 23 | opcodeInfo 20 = ("send", 0) 24 | opcodeInfo 21 = ("remove_message", 0) 25 | opcodeInfo 22 = ("timeout", 0) 26 | opcodeInfo 23 = ("loop_rec", 2) 27 | opcodeInfo 24 = ("loop_rec_end", 1) 28 | opcodeInfo 25 = ("wait", 1) 29 | opcodeInfo 26 = ("wait_timeout", 2) 30 | opcodeInfo 27 = ("m_plus", 4) 31 | opcodeInfo 28 = ("m_minus", 4) 32 | opcodeInfo 29 = ("m_times", 4) 33 | opcodeInfo 30 = ("m_div", 4) 34 | opcodeInfo 31 = ("int_div", 4) 35 | opcodeInfo 32 = ("int_rem", 4) 36 | opcodeInfo 33 = ("int_band", 4) 37 | opcodeInfo 34 = ("int_bor", 4) 38 | opcodeInfo 35 = ("int_bxor", 4) 39 | opcodeInfo 36 = ("int_bsl", 4) 40 | opcodeInfo 37 = ("int_bsr", 4) 41 | opcodeInfo 38 = ("int_bnot", 3) 42 | opcodeInfo 39 = ("is_lt", 3) 43 | opcodeInfo 40 = ("is_ge", 3) 44 | opcodeInfo 41 = ("is_eq", 3) 45 | opcodeInfo 42 = ("is_ne", 3) 46 | opcodeInfo 43 = ("is_eq_exact", 3) 47 | opcodeInfo 44 = ("is_ne_exact", 3) 48 | opcodeInfo 45 = ("is_integer", 2) 49 | opcodeInfo 46 = ("is_float", 2) 50 | opcodeInfo 47 = ("is_number", 2) 51 | opcodeInfo 48 = ("is_atom", 2) 52 | opcodeInfo 49 = ("is_pid", 2) 53 | opcodeInfo 50 = ("is_reference", 2) 54 | opcodeInfo 51 = ("is_port", 2) 55 | opcodeInfo 52 = ("is_nil", 2) 56 | opcodeInfo 53 = ("is_binary", 2) 57 | opcodeInfo 54 = ("is_constant", 2) 58 | opcodeInfo 55 = ("is_list", 2) 59 | opcodeInfo 56 = ("is_nonempty_list", 2) 60 | opcodeInfo 57 = ("is_tuple", 2) 61 | opcodeInfo 58 = ("test_arity", 3) 62 | opcodeInfo 59 = ("select_val", 3) 63 | opcodeInfo 60 = ("select_tuple_arity", 3) 64 | opcodeInfo 61 = ("jump", 1) 65 | opcodeInfo 62 = ("catch", 2) 66 | opcodeInfo 63 = ("catch_end", 1) 67 | opcodeInfo 64 = ("move", 2) 68 | opcodeInfo 65 = ("get_list", 3) 69 | opcodeInfo 66 = ("get_tuple_element", 3) 70 | opcodeInfo 67 = ("set_tuple_element", 3) 71 | opcodeInfo 68 = ("put_string", 3) 72 | opcodeInfo 69 = ("put_list", 3) 73 | opcodeInfo 70 = ("put_tuple", 2) 74 | opcodeInfo 71 = ("put", 1) 75 | opcodeInfo 72 = ("badmatch", 1) 76 | opcodeInfo 73 = ("if_end", 0) 77 | opcodeInfo 74 = ("case_end", 1) 78 | opcodeInfo 75 = ("call_fun", 1) 79 | opcodeInfo 76 = ("make_fun", 3) 80 | opcodeInfo 77 = ("is_function", 2) 81 | opcodeInfo 78 = ("call_ext_only", 2) 82 | opcodeInfo 79 = ("bs_start_match", 2) 83 | opcodeInfo 80 = ("bs_get_integer", 5) 84 | opcodeInfo 81 = ("bs_get_float", 5) 85 | opcodeInfo 82 = ("bs_get_binary", 5) 86 | opcodeInfo 83 = ("bs_skip_bits", 4) 87 | opcodeInfo 84 = ("bs_test_tail", 2) 88 | opcodeInfo 85 = ("bs_save", 1) 89 | opcodeInfo 86 = ("bs_restore", 1) 90 | opcodeInfo 87 = ("bs_init", 2) 91 | opcodeInfo 88 = ("bs_final", 2) 92 | opcodeInfo 89 = ("bs_put_integer", 5) 93 | opcodeInfo 90 = ("bs_put_binary", 5) 94 | opcodeInfo 91 = ("bs_put_float", 5) 95 | opcodeInfo 92 = ("bs_put_string", 2) 96 | opcodeInfo 93 = ("bs_need_buf", 1) 97 | opcodeInfo 94 = ("fclearerror", 0) 98 | opcodeInfo 95 = ("fcheckerror", 1) 99 | opcodeInfo 96 = ("fmove", 2) 100 | opcodeInfo 97 = ("fconv", 2) 101 | opcodeInfo 98 = ("fadd", 4) 102 | opcodeInfo 99 = ("fsub", 4) 103 | opcodeInfo 100 = ("fmul", 4) 104 | opcodeInfo 101 = ("fdiv", 4) 105 | opcodeInfo 102 = ("fnegate", 3) 106 | opcodeInfo 103 = ("make_fun2", 1) 107 | opcodeInfo 104 = ("try", 2) 108 | opcodeInfo 105 = ("try_end", 1) 109 | opcodeInfo 106 = ("try_case", 1) 110 | opcodeInfo 107 = ("try_case_end", 1) 111 | opcodeInfo 108 = ("raise", 2) 112 | opcodeInfo 109 = ("bs_init2", 6) 113 | opcodeInfo 110 = ("bs_bits_to_bytes", 3) 114 | opcodeInfo 111 = ("bs_add", 5) 115 | opcodeInfo 112 = ("apply", 1) 116 | opcodeInfo 113 = ("apply_last", 2) 117 | opcodeInfo 114 = ("is_boolean", 2) 118 | opcodeInfo 115 = ("is_function2", 3) 119 | opcodeInfo 116 = ("bs_start_match2", 5) 120 | opcodeInfo 117 = ("bs_get_integer2", 7) 121 | opcodeInfo 118 = ("bs_get_float2", 7) 122 | opcodeInfo 119 = ("bs_get_binary2", 7) 123 | opcodeInfo 120 = ("bs_skip_bits2", 5) 124 | opcodeInfo 121 = ("bs_test_tail2", 3) 125 | opcodeInfo 122 = ("bs_save2", 2) 126 | opcodeInfo 123 = ("bs_restore2", 2) 127 | opcodeInfo 124 = ("gc_bif1", 5) 128 | opcodeInfo 125 = ("gc_bif2", 6) 129 | opcodeInfo 126 = ("bs_final2", 2) 130 | opcodeInfo 127 = ("bs_bits_to_bytes2", 2) 131 | opcodeInfo 128 = ("put_literal", 2) 132 | opcodeInfo 129 = ("is_bitstr", 2) 133 | opcodeInfo 130 = ("bs_context_to_binary", 1) 134 | opcodeInfo 131 = ("bs_test_unit", 3) 135 | opcodeInfo 132 = ("bs_match_string", 4) 136 | opcodeInfo 133 = ("bs_init_writable", 0) 137 | opcodeInfo 134 = ("bs_append", 8) 138 | opcodeInfo 135 = ("bs_private_append", 6) 139 | opcodeInfo 136 = ("trim", 2) 140 | opcodeInfo 137 = ("bs_init_bits", 6) 141 | opcodeInfo 138 = ("bs_get_utf8", 5) 142 | opcodeInfo 139 = ("bs_skip_utf8", 4) 143 | opcodeInfo 140 = ("bs_get_utf16", 5) 144 | opcodeInfo 141 = ("bs_skip_utf16", 4) 145 | opcodeInfo 142 = ("bs_get_utf32", 5) 146 | opcodeInfo 143 = ("bs_skip_utf32", 4) 147 | opcodeInfo 144 = ("bs_utf8_size", 3) 148 | opcodeInfo 145 = ("bs_put_utf8", 3) 149 | opcodeInfo 146 = ("bs_utf16_size", 3) 150 | opcodeInfo 147 = ("bs_put_utf16", 3) 151 | opcodeInfo 148 = ("bs_put_utf32", 3) 152 | opcodeInfo 149 = ("on_load", 0) 153 | opcodeInfo 150 = ("recv_mark", 1) 154 | opcodeInfo 151 = ("recv_set", 1) 155 | opcodeInfo 152 = ("gc_bif3", 7) 156 | opcodeInfo n = error $ "no such opcode " ++ show n 157 | 158 | maxOpcode :: Integer 159 | maxOpcode = 152 160 | -------------------------------------------------------------------------------- /src/Language/Erlang/BEAM/Operation.hs: -------------------------------------------------------------------------------- 1 | module Language.Erlang.BEAM.Operation where 2 | 3 | import Language.Erlang.BEAM.Types 4 | 5 | makeOperation :: String -> [Operand] -> Operation 6 | makeOperation name args = 7 | case (name, args) of 8 | ("func_info", [AOperand a, AOperand b, UOperand c]) -> 9 | OpFuncInfo a b c 10 | ("int_code_end", []) -> OpIntCodeEnd 11 | ("label", [UOperand a]) -> OpLabel a 12 | ("is_eq_exact", [FOperand a, b, c]) -> OpIsEqExact a b c 13 | ("is_tuple", [FOperand a, b]) -> OpIsTuple a b 14 | ("init", [a]) -> OpInit a 15 | ("allocate", [UOperand a, _]) -> OpAllocate a 16 | ("allocate_zero", [UOperand a, _]) -> OpAllocate a 17 | 18 | -- ignore heap allocation but do the stack allocation 19 | ("allocate_heap_zero", [UOperand a, _, _]) -> OpAllocate a 20 | 21 | ("bif0", [UOperand a, b]) -> OpBIF0 a b 22 | ("gc_bif2", [_, _, UOperand a, b, c, d]) -> OpBIF2 a b c d 23 | ("get_tuple_element", [a, UOperand b, c]) -> OpGetTupleElement a b c 24 | ("call", [UOperand a, FOperand b]) -> OpCall a b 25 | ("call_ext", [UOperand a, UOperand b]) -> OpCallExt a b 26 | ("call_ext_only", [UOperand a, UOperand b]) -> OpCallExtOnly a b 27 | ("call_ext_last", [UOperand a, UOperand b, UOperand c]) -> 28 | OpCallExtLast a b c 29 | ("move", [a, b]) -> OpMove a b 30 | ("jump", [FOperand a]) -> OpJump a 31 | ("call_last", [_, FOperand a, UOperand b]) -> OpCallLast a b 32 | ("return", []) -> OpReturn 33 | ("deallocate", [UOperand a]) -> OpDeallocate a 34 | ("send", []) -> OpSend 35 | ("loop_rec", [FOperand a, b]) -> OpLoopRec a b 36 | ("loop_rec_end", [FOperand a]) -> OpLoopRecEnd a 37 | ("remove_message", []) -> OpRemoveMessage 38 | ("wait", [FOperand a]) -> OpWait a 39 | ("wait_timeout", [FOperand a, b]) -> OpWaitTimeout a b 40 | ("timeout", []) -> OpTimeout 41 | ("put_tuple", [UOperand a, b]) -> OpPutTuple a b 42 | ("put", [a]) -> OpPut a 43 | ("put_list", [a, b, c]) -> OpPutList a b c 44 | ("test_heap", _) -> OpTestHeap 45 | ("test_arity", [FOperand a, b, UOperand c]) -> OpTestArity a b c 46 | _ -> OpUnknown name args 47 | -------------------------------------------------------------------------------- /src/Language/Erlang/BEAM/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module Language.Erlang.BEAM.Types where 4 | 5 | newtype Atom = Atom String deriving (Show, Read, Ord, Eq) 6 | 7 | type Index = Int 8 | type Arity = Int 9 | type Label = Int 10 | 11 | data External = ExtInteger Integer 12 | | ExtTuple [External] 13 | | ExtAtom String 14 | | ExtString String 15 | | ExtList [External] 16 | deriving Show 17 | 18 | data MFA = MFA Atom Atom Arity deriving Show 19 | data Export = Export Atom Arity Label deriving Show 20 | data FunDef = FunDef Atom Arity Label [Operation] deriving Show 21 | 22 | data EValue = EVInteger Integer 23 | | EVAtom Atom 24 | | EVList [EValue] 25 | | EVTuple [EValue] -- FIXME: O(1) 26 | | EVPID PID 27 | deriving (Show, Eq, Read) 28 | 29 | newtype PID = PID Int 30 | deriving (Show, Eq, Read, Ord, Num, Real, Enum, Integral) 31 | 32 | data OperandTag = TagA | TagF | TagH | TagI | TagU 33 | | TagX | TagY | TagZ 34 | | TagFR | TagAtom | TagFloat | TagLiteral 35 | deriving Show 36 | 37 | data Operand = IOperand Integer 38 | | UOperand Int 39 | | XOperand Int 40 | | YOperand Int 41 | | FOperand Int 42 | | AOperand Atom 43 | | LOperand External 44 | deriving Show 45 | 46 | data Operation = 47 | OpAllocate Int 48 | | OpBIF0 Index Operand 49 | | OpBIF2 Index Operand Operand Operand 50 | | OpCall Int Label 51 | | OpCallExt Arity Index 52 | | OpCallExtLast Arity Index Int 53 | | OpCallExtOnly Arity Index 54 | | OpCallLast Label Int 55 | | OpDeallocate Index 56 | | OpFuncInfo Atom Atom Arity 57 | | OpGetTupleElement Operand Index Operand 58 | | OpInit Operand 59 | | OpIntCodeEnd 60 | | OpIsEqExact Label Operand Operand 61 | | OpIsTuple Label Operand 62 | | OpJump Label 63 | | OpLabel Label 64 | | OpLoopRec Label Operand 65 | | OpLoopRecEnd Label 66 | | OpMove Operand Operand 67 | | OpPut Operand 68 | | OpPutList Operand Operand Operand 69 | | OpPutTuple Arity Operand 70 | | OpRemoveMessage 71 | | OpReturn 72 | | OpSend 73 | | OpTestArity Label Operand Arity 74 | | OpTestHeap 75 | | OpTimeout 76 | | OpUnknown String [Operand] 77 | | OpWait Label 78 | | OpWaitTimeout Label Operand 79 | deriving Show 80 | -------------------------------------------------------------------------------- /src/Language/Erlang/BEAM/Utils.hs: -------------------------------------------------------------------------------- 1 | module Language.Erlang.BEAM.Utils 2 | ( 3 | modifyTVar 4 | , incrementTVar 5 | ) where 6 | 7 | import Control.Monad.STM (STM) 8 | 9 | import Control.Concurrent.STM.TVar (TVar, readTVar, writeTVar) 10 | 11 | modifyTVar :: TVar a -> (a -> a) -> STM () 12 | modifyTVar v f = readTVar v >>= writeTVar v . f 13 | 14 | incrementTVar :: (Num a) => TVar a -> STM a 15 | incrementTVar v = 16 | do x <- readTVar v 17 | writeTVar v (x + 1) 18 | return x 19 | -------------------------------------------------------------------------------- /src/Language/Erlang/BEAM/genop.rb: -------------------------------------------------------------------------------- 1 | puts "module Language.Erlang.BEAM.Opcodes where" 2 | puts 3 | 4 | max_opcode = 0 5 | 6 | puts "opcodeInfo :: Int -> (String, Int)" 7 | 8 | STDIN.each_line do |line| 9 | case line 10 | when /^#/: next 11 | when /^BEAM_FORMAT_NUMBER=(.*)/ 12 | fail unless $1 == '0' 13 | when /^(\d+): -?(.*?)\/(\d+)$/ 14 | op = $1.to_i 15 | max_opcode = op if op > max_opcode 16 | puts "opcodeInfo #{$1.to_i} = (\"#$2\", #$3)" 17 | end 18 | end 19 | 20 | puts 'opcodeInfo n = error $ "no such opcode " ++ show n' 21 | 22 | puts 23 | puts "maxOpcode :: Integer" 24 | puts "maxOpcode = #{max_opcode}" 25 | -------------------------------------------------------------------------------- /src/Language/Erlang/BEAM/genop.tab: -------------------------------------------------------------------------------- 1 | # 2 | # %CopyrightBegin% 3 | # 4 | # Copyright Ericsson AB 1998-2010. All Rights Reserved. 5 | # 6 | # The contents of this file are subject to the Erlang Public License, 7 | # Version 1.1, (the "License"); you may not use this file except in 8 | # compliance with the License. You should have received a copy of the 9 | # Erlang Public License along with this software. If not, it can be 10 | # retrieved online at http://www.erlang.org/. 11 | # 12 | # Software distributed under the License is distributed on an "AS IS" 13 | # basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 14 | # the License for the specific language governing rights and limitations 15 | # under the License. 16 | # 17 | # %CopyrightEnd% 18 | # 19 | BEAM_FORMAT_NUMBER=0 20 | 21 | # 22 | # Generic instructions, generated by the compiler. If any of them change number, 23 | # arity or semantics, the format number above must be bumped. 24 | # 25 | 26 | 1: label/1 27 | 2: func_info/3 28 | 3: int_code_end/0 29 | 30 | # 31 | # Function and BIF calls. 32 | # 33 | 4: call/2 34 | 5: call_last/3 35 | 6: call_only/2 36 | 37 | 7: call_ext/2 38 | 8: call_ext_last/3 39 | 40 | 9: bif0/2 41 | 10: bif1/4 42 | 11: bif2/5 43 | 44 | # 45 | # Allocating, deallocating and returning. 46 | # 47 | 12: allocate/2 48 | 13: allocate_heap/3 49 | 14: allocate_zero/2 50 | 15: allocate_heap_zero/3 51 | 16: test_heap/2 52 | 17: init/1 53 | 18: deallocate/1 54 | 19: return/0 55 | 56 | # 57 | # Sending & receiving. 58 | # 59 | 20: send/0 60 | 21: remove_message/0 61 | 22: timeout/0 62 | 23: loop_rec/2 63 | 24: loop_rec_end/1 64 | 25: wait/1 65 | 26: wait_timeout/2 66 | 67 | # 68 | # Arithmethic opcodes. 69 | # 70 | 27: -m_plus/4 71 | 28: -m_minus/4 72 | 29: -m_times/4 73 | 30: -m_div/4 74 | 31: -int_div/4 75 | 32: -int_rem/4 76 | 33: -int_band/4 77 | 34: -int_bor/4 78 | 35: -int_bxor/4 79 | 36: -int_bsl/4 80 | 37: -int_bsr/4 81 | 38: -int_bnot/3 82 | 83 | # 84 | # Comparision operators. 85 | # 86 | 39: is_lt/3 87 | 40: is_ge/3 88 | 41: is_eq/3 89 | 42: is_ne/3 90 | 43: is_eq_exact/3 91 | 44: is_ne_exact/3 92 | 93 | # 94 | # Type tests. 95 | # 96 | 45: is_integer/2 97 | 46: is_float/2 98 | 47: is_number/2 99 | 48: is_atom/2 100 | 49: is_pid/2 101 | 50: is_reference/2 102 | 51: is_port/2 103 | 52: is_nil/2 104 | 53: is_binary/2 105 | 54: -is_constant/2 106 | 55: is_list/2 107 | 56: is_nonempty_list/2 108 | 57: is_tuple/2 109 | 58: test_arity/3 110 | 111 | # 112 | # Indexing & jumping. 113 | # 114 | 59: select_val/3 115 | 60: select_tuple_arity/3 116 | 61: jump/1 117 | 118 | # 119 | # Catch. 120 | # 121 | 62: catch/2 122 | 63: catch_end/1 123 | 124 | # 125 | # Moving, extracting, modifying. 126 | # 127 | 64: move/2 128 | 65: get_list/3 129 | 66: get_tuple_element/3 130 | 67: set_tuple_element/3 131 | 132 | # 133 | # Building terms. 134 | # 135 | 68: -put_string/3 136 | 69: put_list/3 137 | 70: put_tuple/2 138 | 71: put/1 139 | 140 | # 141 | # Raising errors. 142 | # 143 | 72: badmatch/1 144 | 73: if_end/0 145 | 74: case_end/1 146 | 147 | # 148 | # 'fun' support. 149 | # 150 | 75: call_fun/1 151 | 76: -make_fun/3 152 | 77: is_function/2 153 | 154 | # 155 | # Late additions to R5. 156 | # 157 | 78: call_ext_only/2 158 | 159 | # 160 | # Binary matching (R7). 161 | # 162 | 79: -bs_start_match/2 163 | 80: -bs_get_integer/5 164 | 81: -bs_get_float/5 165 | 82: -bs_get_binary/5 166 | 83: -bs_skip_bits/4 167 | 84: -bs_test_tail/2 168 | 85: -bs_save/1 169 | 86: -bs_restore/1 170 | 171 | # 172 | # Binary construction (R7A). 173 | # 174 | 87: -bs_init/2 175 | 88: -bs_final/2 176 | 89: bs_put_integer/5 177 | 90: bs_put_binary/5 178 | 91: bs_put_float/5 179 | 92: bs_put_string/2 180 | 181 | # 182 | # Binary construction (R7B). 183 | # 184 | 93: -bs_need_buf/1 185 | 186 | # 187 | # Floating point arithmetic (R8). 188 | # 189 | 94: fclearerror/0 190 | 95: fcheckerror/1 191 | 96: fmove/2 192 | 97: fconv/2 193 | 98: fadd/4 194 | 99: fsub/4 195 | 100: fmul/4 196 | 101: fdiv/4 197 | 102: fnegate/3 198 | 199 | # New fun construction (R8). 200 | 103: make_fun2/1 201 | 202 | # Try/catch/raise (R10B). 203 | 104: try/2 204 | 105: try_end/1 205 | 106: try_case/1 206 | 107: try_case_end/1 207 | 108: raise/2 208 | 209 | # New instructions in R10B. 210 | 109: bs_init2/6 211 | 110: -bs_bits_to_bytes/3 212 | 111: bs_add/5 213 | 112: apply/1 214 | 113: apply_last/2 215 | 114: is_boolean/2 216 | 217 | # New instructions in R10B-6. 218 | 115: is_function2/3 219 | 220 | # New bit syntax matching in R11B. 221 | 222 | 116: bs_start_match2/5 223 | 117: bs_get_integer2/7 224 | 118: bs_get_float2/7 225 | 119: bs_get_binary2/7 226 | 120: bs_skip_bits2/5 227 | 121: bs_test_tail2/3 228 | 122: bs_save2/2 229 | 123: bs_restore2/2 230 | 231 | # New GC bifs introduced in R11B. 232 | 124: gc_bif1/5 233 | 125: gc_bif2/6 234 | 235 | # Experimental new bit_level bifs introduced in R11B. 236 | # NOT used in R12B. 237 | 126: -bs_final2/2 238 | 127: -bs_bits_to_bytes2/2 239 | 240 | # R11B-4 241 | 128: -put_literal/2 242 | 243 | # R11B-5 244 | 129: is_bitstr/2 245 | 246 | # R12B 247 | 130: bs_context_to_binary/1 248 | 131: bs_test_unit/3 249 | 132: bs_match_string/4 250 | 133: bs_init_writable/0 251 | 134: bs_append/8 252 | 135: bs_private_append/6 253 | 136: trim/2 254 | 137: bs_init_bits/6 255 | 256 | # R12B-5 257 | 138: bs_get_utf8/5 258 | 139: bs_skip_utf8/4 259 | 260 | 140: bs_get_utf16/5 261 | 141: bs_skip_utf16/4 262 | 263 | 142: bs_get_utf32/5 264 | 143: bs_skip_utf32/4 265 | 266 | 144: bs_utf8_size/3 267 | 145: bs_put_utf8/3 268 | 269 | 146: bs_utf16_size/3 270 | 147: bs_put_utf16/3 271 | 272 | 148: bs_put_utf32/3 273 | 274 | # R13B03 275 | 276 | 149: on_load/0 277 | 278 | # R14A 279 | 280 | 150: recv_mark/1 281 | 151: recv_set/1 282 | 152: gc_bif3/7 283 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import System.Environment (getArgs) 4 | 5 | import Language.Erlang.BEAM.Types 6 | import Language.Erlang.BEAM.Loader 7 | import Language.Erlang.BEAM.Emulator 8 | 9 | import qualified Data.ByteString.Lazy as B 10 | 11 | import Control.Applicative 12 | 13 | import Control.Concurrent (threadDelay) 14 | 15 | main :: IO () 16 | main = do Just x <- (parseBEAMFile . readBEAMFile) <$> B.getContents 17 | putStrLn "Imports: " 18 | mapM_ (\(i, MFA (Atom m) (Atom f) a) -> 19 | putStrLn (" " ++ show i ++ ": " ++ m ++ ":" ++ f 20 | ++ "/" ++ show a)) 21 | (zip [(0::Int)..] (beamFileImports x)) 22 | putStrLn "" 23 | putStrLn "Exports: " 24 | mapM_ (\(Export (Atom f) a e) -> 25 | putStrLn (" " ++ f ++ "/" ++ show a ++ " @ " ++ show e)) 26 | (beamFileExports x) 27 | putStrLn "" 28 | 29 | mapM_ (\(FunDef (Atom name) arity label ops) -> 30 | do putStrLn (name ++ "/" ++ show arity ++ " (@" ++ 31 | show label ++ "):") 32 | mapM_ (\op -> putStrLn (" " ++ show op)) ops 33 | putStrLn "") (beamFileFunDefs x) 34 | 35 | putStrLn "" 36 | [m', f', args'] <- getArgs 37 | node <- nodeFromBEAMFile x 38 | let mfa = MFA (Atom m') (Atom f') (length args) 39 | args = read args' 40 | putStrLn $ "Spawning " ++ showMFA mfa ++ "." 41 | spawnProcess node mfa args 42 | 43 | threadDelay 10000000 44 | 45 | return () 46 | --------------------------------------------------------------------------------