diff options
54 files changed, 2251 insertions, 561 deletions
diff --git a/documentation/research/Memory Management.md b/documentation/research/Memory Management.md index 0d761c700..abfe8a1e8 100644 --- a/documentation/research/Memory Management.md +++ b/documentation/research/Memory Management.md @@ -6,3 +6,23 @@ 1. [Counting Immutable Beans: Reference Counting Optimized for Purely Functional Programming](https://arxiv.org/abs/1908.05647) +# Layout + +1. [Floorplan: Spatial Layout in Memory Management Systems](https://conf.researchr.org/details/gpce-2019/gpce-2019-papers/6/Floorplan-Spatial-Layout-in-Memory-Management-Systems) + +# Reference + +1. https://uridiumauthor.blogspot.com/2018/06/memory-management.html +1. https://github.com/mtrebi/memory-allocators +1. http://www.newlisp.org/MemoryManagement.html +1. http://gee.cs.oswego.edu/dl/html/malloc.html +1. https://shipilev.net/blog/2014/jmm-pragmatics/ +1. https://floooh.github.io/2018/06/17/handles-vs-pointers.html +1. https://www.codemag.com/Article/1807051/Introducing-.NET-Core-2.1-Flagship-Types-Span-T-and-Memory-T +1. https://stefansf.de/post/pointers-are-more-abstract-than-you-might-expect/ +1. http://www.memorymanagement.org/ +1. [Pseudomonarchia jemallocum: The false kingdom of jemalloc, or On exploiting the jemalloc memory manager](http://phrack.com/issues/68/10.html#article) +1. https://gankro.github.io/blah/rust-layouts-and-abis/ +1. https://paul.bone.id.au/2018/10/19/gc-falsehoods/ +1. [Safe Programming with Pointers through Stateful Views](https://www.cs.bu.edu/~hwxi/academic/papers/padl05.pdf) + diff --git a/documentation/research/Security.md b/documentation/research/Security.md index f583bf12b..d6ec5abf9 100644 --- a/documentation/research/Security.md +++ b/documentation/research/Security.md @@ -1,3 +1,7 @@ +# Access Control List + +1. [Capirca: Multi-platform ACL generation system](https://github.com/google/capirca) + # Return-oriented programming 1. https://github.com/immunant/selfrando @@ -22,6 +26,7 @@ # Vulnerability +1. [CSS Injection Primitives](https://x-c3ll.github.io/posts/CSS-Injection-Primitives/) 1. https://medium.com/@shnatsel/how-rusts-standard-library-was-vulnerable-for-years-and-nobody-noticed-aebf0503c3d6 1. [ACLs don’t](http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.406.4684&rep=rep1&type=pdf) 1. https://www.cs.auckland.ac.nz/~pgut001/pubs/book.pdf diff --git a/documentation/research/architecture/microservice.md b/documentation/research/architecture/microservice.md new file mode 100644 index 000000000..ab15c99de --- /dev/null +++ b/documentation/research/architecture/microservice.md @@ -0,0 +1,3 @@ +# Reference + +1. [Convey - a simple recipe for .NET Core microservices.](https://www.youtube.com/watch?v=cxEXx4UT1FI) diff --git a/documentation/research/back-end/WebAssembly (WASM).md b/documentation/research/back-end/WebAssembly (WASM).md index 6d9368fbe..8b76d43bc 100644 --- a/documentation/research/back-end/WebAssembly (WASM).md +++ b/documentation/research/back-end/WebAssembly (WASM).md @@ -1,5 +1,6 @@ # Exemplar +1. [Towards a WebAssembly standalone runtime on GraalVM](https://dl.acm.org/citation.cfm?id=3362780) 1. https://github.com/vvanders/wasm_lua 1. https://github.com/AppCypher/webassemblylanguages 1. https://medium.com/perlin-network/life-a-secure-blazing-fast-cross-platform-webassembly-vm-in-go-ea3b31fa6e09 diff --git a/documentation/research/back-end/native.md b/documentation/research/back-end/native.md index f4491d8c5..56fa11e0a 100644 --- a/documentation/research/back-end/native.md +++ b/documentation/research/back-end/native.md @@ -3,22 +3,6 @@ 1. http://stffrdhrn.github.io/software/embedded/openrisc/2018/06/08/gcc_stack_frames.html 1. https://yurichev.com/blog/reg_alloc/ -# Memory Management - -1. https://uridiumauthor.blogspot.com/2018/06/memory-management.html -1. https://github.com/mtrebi/memory-allocators -1. http://www.newlisp.org/MemoryManagement.html -1. http://gee.cs.oswego.edu/dl/html/malloc.html -1. https://shipilev.net/blog/2014/jmm-pragmatics/ -1. https://floooh.github.io/2018/06/17/handles-vs-pointers.html -1. https://www.codemag.com/Article/1807051/Introducing-.NET-Core-2.1-Flagship-Types-Span-T-and-Memory-T -1. https://stefansf.de/post/pointers-are-more-abstract-than-you-might-expect/ -1. http://www.memorymanagement.org/ -1. [Pseudomonarchia jemallocum: The false kingdom of jemalloc, or On exploiting the jemalloc memory manager](http://phrack.com/issues/68/10.html#article) -1. https://gankro.github.io/blah/rust-layouts-and-abis/ -1. https://paul.bone.id.au/2018/10/19/gc-falsehoods/ -1. [Safe Programming with Pointers through Stateful Views](https://www.cs.bu.edu/~hwxi/academic/papers/padl05.pdf) - # Unicode 1. http://manishearth.github.io/blog/2017/01/14/stop-ascribing-meaning-to-unicode-code-points/ @@ -62,8 +46,18 @@ 1. https://www.newtv.co.th/video/video.php?v=topKYJgv6qA +# Floating point arithmetic + +1. [Faster floating point arithmetic with Exclusive OR](http://nfrechette.github.io/2019/10/22/float_xor_optimization/) +1. https://oded.ninja/2017/05/01/floating-point/ +1. [What Every Computer Scientist Should Know About Floating-Point Arithmetic](http://www.lsi.upc.edu/~robert/teaching/master/material/p5-goldberg.pdf) +1. https://lemire.me/blog/2017/11/16/fast-exact-integer-divisions-using-floating-point-operations/ + # Reference +1. http://luajit.org/ +1. http://luajit.org/ext_ffi.html +1. http://luajit.org/dynasm.html 1. [The Standard C Library](https://www.amazon.com/Standard-C-Library-P-J-Plauger/dp/0131315099) 1. [C Is Not a Low-level Language: Your computer is not a fast PDP-11.](https://queue.acm.org/detail.cfm?id=3212479) 1. http://www.ffconsultancy.com/ocaml/hlvm/ @@ -92,8 +86,6 @@ 1. http://www.mpfr.org/ 1. http://www.mpfr.org/algorithms.pdf 1. http://wilsonminesco.com/16bitMathTables/ -1. https://oded.ninja/2017/05/01/floating-point/ -1. [What Every Computer Scientist Should Know About Floating-Point Arithmetic](http://www.lsi.upc.edu/~robert/teaching/master/material/p5-goldberg.pdf) 1. http://blog.veitheller.de/Fixed_Point_Division.html 1. http://libdivide.com/ 1. [Modern Computer Arithmetic](https://members.loria.fr/PZimmermann/mca/mca-cup-0.5.9.pdf) @@ -105,7 +97,6 @@ 1. http://bellard.org/libbf/ 1. http://paulcavallaro.com/blog/hashed-and-hierarchical-timing-wheels/ 1. http://speleotrove.com/decimal/ -1. https://lemire.me/blog/2017/11/16/fast-exact-integer-divisions-using-floating-point-operations/ 1. http://eli.thegreenplace.net/2013/07/09/library-order-in-static-linking 1. [Skip the FFI!](http://llvm.org/devmtg/2014-10/Slides/Skip%20the%20FFI.pdf) 1. http://www.infoworld.com/article/3187370/application-development/kotlin-compiles-directly-to-native-code-via-llvm.html diff --git a/documentation/research/culture.md b/documentation/research/culture.md new file mode 100644 index 000000000..5abdff8d5 --- /dev/null +++ b/documentation/research/culture.md @@ -0,0 +1,3 @@ +# Reference + +1. [Five Worlds](https://www.joelonsoftware.com/2002/05/06/five-worlds/) diff --git a/documentation/research/database.md b/documentation/research/database.md index 5c1566fbe..52447b970 100644 --- a/documentation/research/database.md +++ b/documentation/research/database.md @@ -162,6 +162,10 @@ 1. https://www.aerospike.com/ 1. https://sirix.io/ +## Data-flow + +1. [Noria: data-flow for high-performance web applications](https://github.com/mit-pdos/noria) + ## Graph 1. https://github.com/hugegraph/hugegraph diff --git a/documentation/research/debugging.md b/documentation/research/debugging.md index 239663175..2dd5d74e7 100644 --- a/documentation/research/debugging.md +++ b/documentation/research/debugging.md @@ -1,3 +1,7 @@ +# Omniscient debugging + +1. https://pernos.co/ + # Tool 1. [Debug Adapter Protocol](https://microsoft.github.io/debug-adapter-protocol/) diff --git a/documentation/research/math.md b/documentation/research/math.md index 326d0f6db..27fab7503 100644 --- a/documentation/research/math.md +++ b/documentation/research/math.md @@ -40,6 +40,7 @@ # Number Theory +1. https://twitter.com/johncarlosbaez/status/1184492139897507840 1. https://en.wikipedia.org/wiki/Dual_number 1. https://en.wikipedia.org/wiki/Division_algebra 1. [Division algebras](https://www.youtube.com/watch?v=3BZyds_KFWM&list=PLNxhIPHaOTRZMO1VjJcs7_3dgyJ2qU1yZ) @@ -47,6 +48,10 @@ 1. http://illustratedtheoryofnumbers.com/ 1. [Topology of Numbers](http://pi.math.cornell.edu/~hatcher/TN/TNpage.html) +## Hyperreal number + +1. [Yes, You Can Manipulate Infinity—in Math](https://mindmatters.ai/2019/10/yes-you-can-manipulate-infinity-in-math/) + # Quaternions 1. [Dual Quaternions for Mere Mortals](https://www.jeremyong.com/math/2019/08/05/dual-quaternions-for-mere-mortals/) @@ -266,6 +271,7 @@ # Knot theory +1. [Primes and Knots - Akshay Venkatesh](https://www.youtube.com/watch?v=jvoYgNYKyk0) 1. [The Knot Book](http://math.harvard.edu/~ctm/home/text/books/adams/knot_book/knot_book.pdf) # Axiom diff --git a/documentation/research/operating_system.md b/documentation/research/operating_system.md index bd0c59f73..527d7d04f 100644 --- a/documentation/research/operating_system.md +++ b/documentation/research/operating_system.md @@ -89,6 +89,10 @@ 1. https://grapheneproject.io/ 1. https://ops.city/ +## Microkernel + +1. [Snap: a Microkernel Approach to Host Networking](https://storage.googleapis.com/pub-tools-public-publication-data/pdf/36f0f9b41e969a00d75da7693571e988996c9f4c.pdf) + ## Real-time 1. https://en.wikipedia.org/wiki/VxWorks diff --git a/documentation/research/paradigm/probabilistic_programming.md b/documentation/research/paradigm/probabilistic_programming.md index 6b37d6097..42738b80e 100644 --- a/documentation/research/paradigm/probabilistic_programming.md +++ b/documentation/research/paradigm/probabilistic_programming.md @@ -11,6 +11,7 @@ # Reference +1. [FACTORIE](http://factorie.cs.umass.edu/) 1. [End-User Probabilistic Programming (DRAFT)](https://www.cs.uoregon.edu/research/summerschool/summer19/lecture_notes/DRAFT___Probabilistic_Programming_for_End_Users.pdf) 1. http://willcrichton.net/notes/probabilistic-programming-under-the-hood/ 1. [Ask HN: What companies are using probabilistic programming?](https://news.ycombinator.com/item?id=17220861) diff --git a/documentation/research/text_editor & ide.md b/documentation/research/text_editor & ide.md index 0a3210eeb..e1eb5b6cc 100644 --- a/documentation/research/text_editor & ide.md +++ b/documentation/research/text_editor & ide.md @@ -43,6 +43,7 @@ # Reference +1. [Text Editing Hates You Too](https://lord.io/blog/2019/text-editing-hates-you-too/) 1. [Why ContentEditable is Terrible](https://medium.engineering/why-contenteditable-is-terrible-122d8a40e480) 1. [Broot: A better way to navigate directories](https://github.com/Canop/broot) 1. https://www.simplethread.com/editor-plugins-belong-in-lock-file/ @@ -132,6 +133,7 @@ ## General +1. https://howl.io/ 1. [The Whole Code Catalog](https://futureofcoding.org/catalog/) 1. http://substance.io/ 1. https://www.querystorm.com/ diff --git a/documentation/research/web_framework.md b/documentation/research/web_framework.md index 3c7d0220d..f84ca94c7 100644 --- a/documentation/research/web_framework.md +++ b/documentation/research/web_framework.md @@ -4,6 +4,7 @@ # Reference +1. [Introducing Concurrent Mode (Experimental)](https://reactjs.org/docs/concurrent-mode-intro.html) 1. https://github.com/daybrush/scenejs 1. https://blog.ionicframework.com/announcing-capacitor-1-0/ 1. http://joneisen.me/talk-frelp-ui/#/ diff --git a/stdlib/source/lux/abstract/equivalence.lux b/stdlib/source/lux/abstract/equivalence.lux index d23f37942..eacb4a48f 100644 --- a/stdlib/source/lux/abstract/equivalence.lux +++ b/stdlib/source/lux/abstract/equivalence.lux @@ -35,7 +35,9 @@ (def: (= left right) (sub (rec sub) left right)))) -(structure: #export contravariant (Contravariant Equivalence) +(structure: #export contravariant + (Contravariant Equivalence) + (def: (map-1 f equivalence) (structure (def: (= reference sample) diff --git a/stdlib/source/lux/abstract/monad.lux b/stdlib/source/lux/abstract/monad.lux index f0444a4cf..5aec10012 100644 --- a/stdlib/source/lux/abstract/monad.lux +++ b/stdlib/source/lux/abstract/monad.lux @@ -87,6 +87,13 @@ _ (#.Left "Wrong syntax for 'do'"))) +(def: #export (bind monad f) + (All [! a b] + (-> (Monad !) (-> a (! b)) + (-> (! a) (! b)))) + (|>> (:: monad map f) + (:: monad join))) + (def: #export (seq monad) {#.doc "Run all the monadic values in the list and produce a list of the base values."} (All [M a] diff --git a/stdlib/source/lux/data/format/binary.lux b/stdlib/source/lux/data/format/binary.lux index 03af219a7..81c8ceadd 100644 --- a/stdlib/source/lux/data/format/binary.lux +++ b/stdlib/source/lux/data/format/binary.lux @@ -44,7 +44,8 @@ (-> Specification Binary) (|> size binary.create [0] mutation product.right)) -(structure: #export monoid (Monoid Specification) +(structure: #export monoid + (Monoid Specification) (def: identity ..no-op) diff --git a/stdlib/source/lux/target/jvm/attribute.lux b/stdlib/source/lux/target/jvm/attribute.lux index 236ecf608..5f8892631 100644 --- a/stdlib/source/lux/target/jvm/attribute.lux +++ b/stdlib/source/lux/target/jvm/attribute.lux @@ -4,7 +4,6 @@ [monad (#+ do)] ["." equivalence (#+ Equivalence)]] [control - ["." state (#+ State)] ["." try] ["." exception (#+ exception:)]] [data @@ -18,7 +17,7 @@ [encoding ["#." unsigned (#+ U2 U4)]] ["#." constant (#+ UTF8 Class Value) - ["#/." pool (#+ Pool)]]] + ["#/." pool (#+ Pool Resource)]]] ["." / #_ ["#." constant (#+ Constant)] ["#." code]]) @@ -43,7 +42,7 @@ (Writer (Info about)))) (function (_ [name length info]) (let [[nameS nameT] (//index.writer name) - [lengthS lengthT] (//unsigned.u4-writer length) + [lengthS lengthT] (//unsigned.writer/4 length) [infoS infoT] (writer info)] [($_ n.+ nameS lengthS infoS) (|>> nameT lengthT infoT)]))) @@ -68,9 +67,9 @@ (def: fixed-attribute-length ($_ n.+ ## u2 attribute_name_index; - //unsigned.u2-bytes + //unsigned.bytes/2 ## u4 attribute_length; - //unsigned.u4-bytes + //unsigned.bytes/4 )) (def: (length attribute) @@ -78,7 +77,7 @@ (case attribute (^template [<tag>] (<tag> [name length info]) - (|> length //unsigned.nat .nat (n.+ fixed-attribute-length))) + (|> length //unsigned.value (n.+ fixed-attribute-length))) ([#Constant] [#Code]))) (def: constant-name "ConstantValue") @@ -86,12 +85,12 @@ (def: (constant' @name index) (-> (Index UTF8) Constant Attribute) (#Constant {#name @name - #length (//unsigned.u4 /constant.length) + #length (|> /constant.length //unsigned.u4 try.assume) #info index})) (def: #export (constant index) - (-> Constant (State Pool Attribute)) - (do state.monad + (-> Constant (Resource Attribute)) + (do //constant/pool.monad [@name (//constant/pool.utf8 ..constant-name)] (wrap (constant' @name index)))) @@ -101,13 +100,15 @@ (-> (Index UTF8) Code Attribute) (#Code {#name @name ## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.3 - #length (//unsigned.u4 - (/code.length ..length specification)) + #length (|> specification + (/code.length ..length) + //unsigned.u4 + try.assume) #info specification})) (def: #export (code specification) - (-> Code (State Pool Attribute)) - (do state.monad + (-> Code (Resource Attribute)) + (do //constant/pool.monad [@name (//constant/pool.utf8 ..code-name)] (wrap (code' @name specification)))) diff --git a/stdlib/source/lux/target/jvm/attribute/code.lux b/stdlib/source/lux/target/jvm/attribute/code.lux index 0bf1bec4e..3a9629c1f 100644 --- a/stdlib/source/lux/target/jvm/attribute/code.lux +++ b/stdlib/source/lux/target/jvm/attribute/code.lux @@ -12,15 +12,16 @@ [collection ["." row (#+ Row) ("#@." functor fold)]]]] ["." /// #_ - [instruction - ["#." resources (#+ Resources)]] + [bytecode + [environment + ["#." limit (#+ Limit)]]] [encoding ["#." unsigned (#+ U2)]]] ["." / #_ ["#." exception (#+ Exception)]]) (type: #export (Code Attribute) - {#resources Resources + {#limit Limit #code Binary #exception-table (Row Exception) #attributes (Row Attribute)}) @@ -30,20 +31,20 @@ ($_ n.+ ## u2 max_stack; ## u2 max_locals; - ///resources.length + ///limit.length ## u4 code_length; - ///unsigned.u4-bytes + ///unsigned.bytes/4 ## u1 code[code_length]; (binary.size (get@ #code code)) ## u2 exception_table_length; - ///unsigned.u2-bytes + ///unsigned.bytes/2 ## exception_table[exception_table_length]; (|> code (get@ #exception-table) row.size (n.* /exception.length)) ## u2 attributes_count; - ///unsigned.u2-bytes + ///unsigned.bytes/2 ## attribute_info attributes[attributes_count]; (|> code (get@ #attributes) @@ -54,7 +55,7 @@ (All [attribute] (-> (Equivalence attribute) (Equivalence (Code attribute)))) ($_ equivalence.product - ///resources.equivalence + ///limit.equivalence binary.equivalence (row.equivalence /exception.equivalence) (row.equivalence attribute-equivalence) @@ -66,7 +67,7 @@ ($_ binaryF@compose ## u2 max_stack; ## u2 max_locals; - (///resources.writer (get@ #resources code)) + (///limit.writer (get@ #limit code)) ## u4 code_length; ## u1 code[code_length]; (binaryF.binary/32 (get@ #code code)) diff --git a/stdlib/source/lux/target/jvm/attribute/code/exception.lux b/stdlib/source/lux/target/jvm/attribute/code/exception.lux index 97fe962e6..820e5c8a6 100644 --- a/stdlib/source/lux/target/jvm/attribute/code/exception.lux +++ b/stdlib/source/lux/target/jvm/attribute/code/exception.lux @@ -5,13 +5,13 @@ [data [number ["n" nat]] - [format - [".F" binary (#+ Writer)]]]] + ["." format #_ + ["#" binary (#+ Writer)]]]] ["." // #_ ["//#" /// #_ [constant (#+ Class)] ["#." index (#+ Index)] - [instruction + [bytecode ["#." address (#+ Address)]] [encoding ["#." unsigned (#+ U2)]]]]) @@ -36,18 +36,18 @@ Nat ($_ n.+ ## u2 start_pc; - ////unsigned.u2-bytes + ////unsigned.bytes/2 ## u2 end_pc; - ////unsigned.u2-bytes + ////unsigned.bytes/2 ## u2 handler_pc; - ////unsigned.u2-bytes + ////unsigned.bytes/2 ## u2 catch_type; - ////unsigned.u2-bytes + ////unsigned.bytes/2 )) (def: #export writer (Writer Exception) - ($_ binaryF.and + ($_ format.and ////address.writer ////address.writer ////address.writer diff --git a/stdlib/source/lux/target/jvm/attribute/constant.lux b/stdlib/source/lux/target/jvm/attribute/constant.lux index debf07abe..0206ed26e 100644 --- a/stdlib/source/lux/target/jvm/attribute/constant.lux +++ b/stdlib/source/lux/target/jvm/attribute/constant.lux @@ -19,7 +19,7 @@ ///index.equivalence) (def: #export length - ///unsigned.u2-bytes) + ///index.length) (def: #export writer (Writer Constant) diff --git a/stdlib/source/lux/target/jvm/bytecode.lux b/stdlib/source/lux/target/jvm/bytecode.lux new file mode 100644 index 000000000..7dc974658 --- /dev/null +++ b/stdlib/source/lux/target/jvm/bytecode.lux @@ -0,0 +1,823 @@ +(.module: + [lux (#- Type int) + ["." host] + [abstract + [monoid (#+ Monoid)] + ["." monad (#+ Monad do)]] + [control + [writer (#+ Writer)] + ["." state (#+ State')] + ["." function] + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." product] + ["." maybe] + [text + ["%" format (#+ format)]] + [number + ["n" nat] + ["i" int] + ["." i32]] + [collection + ["." list ("#@." functor fold)] + ["." dictionary (#+ Dictionary)] + ["." row (#+ Row)]]] + [macro + ["." template]]] + ["." / #_ + ["#." address (#+ Address)] + ["#." jump (#+ Jump Big-Jump)] + ["_" instruction (#+ Primitive-Array-Type Instruction Estimator) ("#@." monoid)] + ["#." environment (#+ Environment) + [limit + [registry (#+ Register)]]] + ["/#" // #_ + ["#." index (#+ Index)] + [encoding + ["#." name] + ["#." unsigned (#+ U1 U2)] + ["#." signed (#+ S4)]] + ["#." constant (#+ UTF8) + ["#/." pool (#+ Pool Resource)]] + [attribute + [code + ["#." exception (#+ Exception)]]] + ["." type (#+ Type) + [category (#+ Class Object Value' Value Return' Return Method)] + ["." reflection] + ["." parser]]]]) + +(type: #export Label Nat) + +(type: #export Resolver (Dictionary Label Address)) + +(type: #export Tracker + {#program-counter Address + #next Label + #known Resolver}) + +(def: fresh + Tracker + {#program-counter /address.start + #next 0 + #known (dictionary.new n.hash)}) + +(type: #export Relative + (-> Resolver (Try [(Row Exception) Instruction]))) + +(def: no-exceptions + (Row Exception) + row.empty) + +(def: relative-identity + Relative + (function.constant (#try.Success [..no-exceptions _.empty]))) + +(structure: relative-monoid + (Monoid Relative) + + (def: identity ..relative-identity) + + (def: (compose left right) + (cond (is? ..relative-identity left) + right + + (is? ..relative-identity right) + left + + ## else + (function (_ resolver) + (do try.monad + [[left-exceptions left-instruction] (left resolver) + [right-exceptions right-instruction] (right resolver)] + (wrap [(:: row.monoid compose left-exceptions right-exceptions) + (_@compose left-instruction right-instruction)])))))) + +(type: #export (Bytecode a) + (State' Try [Pool Environment Tracker] (Writer Relative a))) + +(def: #export new-label + (Bytecode Label) + (function (_ [pool environment tracker]) + (#try.Success [[pool + environment + (update@ #next inc tracker)] + [..relative-identity + (get@ #next tracker)]]))) + +(exception: #export (label-has-already-been-set {label Label}) + (exception.report + ["Label" (%.nat label)])) + +(def: #export (set-label label) + (-> Label (Bytecode Any)) + (function (_ [pool environment tracker]) + (if (dictionary.contains? label (get@ #known tracker)) + (exception.throw ..label-has-already-been-set [label]) + (#try.Success [[pool + environment + (update@ #known + (dictionary.put label (get@ #program-counter tracker)) + tracker)] + [..relative-identity + []]])))) + +(def: #export monad + (Monad Bytecode) + (:coerce (Monad Bytecode) + (state.with try.monad))) + +(def: #export (resolve bytecode) + (All [a] (-> (Bytecode a) (Resource [Environment (Row Exception) Instruction a]))) + (function (_ pool) + (do try.monad + [[[pool environment tracker] [relative output]] (bytecode [pool /environment.start ..fresh]) + [exceptions instruction] (relative (get@ #known tracker))] + (wrap [pool [environment exceptions instruction output]])))) + +(def: (step estimator counter) + (-> Estimator Address (Try Address)) + (/address.move (estimator counter) counter)) + +(def: (bytecode consumption production last-register [estimator bytecode] input) + (All [a] (-> U2 U2 Register [Estimator (-> [a] Instruction)] [a] (Bytecode Any))) + (function (_ [pool environment tracker]) + (do try.monad + [environment' (|> environment + (/environment.consumes consumption) + (monad.bind @ (/environment.produces production)) + (monad.bind @ (/environment.has last-register))) + program-counter' (step estimator (get@ #program-counter tracker))] + (wrap [[pool + environment' + (set@ #program-counter program-counter' tracker)] + [(function.constant (#try.Success [..no-exceptions (bytecode input)])) + []]])))) + +(template [<name> <frames>] + [(def: <name> U2 (|> <frames> //unsigned.u2 try.assume))] + + [$0 0] + [$1 1] + [$2 2] + [$3 3] + [$4 4] + [$5 5] + [$6 6] + ) + +(template [<name> <registry>] + [(def: <name> Register (|> <registry> //unsigned.u1 try.assume))] + + [@0 0] + [@1 1] + [@2 2] + [@3 3] + [@4 4] + ) + +(template [<name> <consumption> <production> <last-register> <instruction>] + [(def: #export <name> + (Bytecode Any) + (..bytecode <consumption> + <production> + <last-register> + <instruction> + []))] + + [nop $0 $0 @0 _.nop] + + [aconst-null $0 $1 @0 _.aconst-null] + + [iconst-m1 $0 $1 @0 _.iconst-m1] + [iconst-0 $0 $1 @0 _.iconst-0] + [iconst-1 $0 $1 @0 _.iconst-1] + [iconst-2 $0 $1 @0 _.iconst-2] + [iconst-3 $0 $1 @0 _.iconst-3] + [iconst-4 $0 $1 @0 _.iconst-4] + [iconst-5 $0 $1 @0 _.iconst-5] + + [lconst-0 $0 $2 @0 _.lconst-0] + [lconst-1 $0 $2 @0 _.lconst-1] + + [fconst-0 $0 $1 @0 _.fconst-0] + [fconst-1 $0 $1 @0 _.fconst-1] + [fconst-2 $0 $1 @0 _.fconst-2] + + [dconst-0 $0 $2 @0 _.dconst-0] + [dconst-1 $0 $2 @0 _.dconst-1] + + [pop $1 $0 @0 _.pop] + [pop2 $2 $0 @0 _.pop2] + + [dup $1 $2 @0 _.dup] + [dup-x1 $2 $3 @0 _.dup-x1] + [dup-x2 $3 $4 @0 _.dup-x2] + [dup2 $2 $4 @0 _.dup2] + [dup2-x1 $3 $5 @0 _.dup2-x1] + [dup2-x2 $4 $6 @0 _.dup2-x2] + + [swap $2 $2 @0 _.swap] + + [iaload $2 $1 @0 _.iaload] + [laload $2 $2 @0 _.laload] + [faload $2 $1 @0 _.faload] + [daload $2 $2 @0 _.daload] + [aaload $2 $1 @0 _.aaload] + [baload $2 $1 @0 _.baload] + [caload $2 $1 @0 _.caload] + [saload $2 $1 @0 _.saload] + + [iload-0 $0 $1 @0 _.iload-0] + [iload-1 $0 $1 @1 _.iload-1] + [iload-2 $0 $1 @2 _.iload-2] + [iload-3 $0 $1 @3 _.iload-3] + + [lload-0 $0 $2 @1 _.lload-0] + [lload-1 $0 $2 @2 _.lload-1] + [lload-2 $0 $2 @3 _.lload-2] + [lload-3 $0 $2 @4 _.lload-3] + + [fload-0 $0 $1 @0 _.fload-0] + [fload-1 $0 $1 @1 _.fload-1] + [fload-2 $0 $1 @2 _.fload-2] + [fload-3 $0 $1 @3 _.fload-3] + + [dload-0 $0 $2 @1 _.dload-0] + [dload-1 $0 $2 @2 _.dload-1] + [dload-2 $0 $2 @3 _.dload-2] + [dload-3 $0 $2 @4 _.dload-3] + + [aload-0 $0 $1 @0 _.aload-0] + [aload-1 $0 $1 @1 _.aload-1] + [aload-2 $0 $1 @2 _.aload-2] + [aload-3 $0 $1 @3 _.aload-3] + + [iastore $3 $1 @0 _.iastore] + [lastore $4 $1 @0 _.lastore] + [fastore $3 $1 @0 _.fastore] + [dastore $4 $1 @0 _.dastore] + [aastore $3 $1 @0 _.aastore] + [bastore $3 $1 @0 _.bastore] + [castore $3 $1 @0 _.castore] + [sastore $3 $1 @0 _.sastore] + + [istore-0 $1 $0 @0 _.istore-0] + [istore-1 $1 $0 @1 _.istore-1] + [istore-2 $1 $0 @2 _.istore-2] + [istore-3 $1 $0 @3 _.istore-3] + + [lstore-0 $2 $0 @1 _.lstore-0] + [lstore-1 $2 $0 @2 _.lstore-1] + [lstore-2 $2 $0 @3 _.lstore-2] + [lstore-3 $2 $0 @4 _.lstore-3] + + [fstore-0 $1 $0 @0 _.fstore-0] + [fstore-1 $1 $0 @1 _.fstore-1] + [fstore-2 $1 $0 @2 _.fstore-2] + [fstore-3 $1 $0 @3 _.fstore-3] + + [dstore-0 $2 $0 @1 _.dstore-0] + [dstore-1 $2 $0 @2 _.dstore-1] + [dstore-2 $2 $0 @3 _.dstore-2] + [dstore-3 $2 $0 @4 _.dstore-3] + + [astore-0 $1 $0 @0 _.astore-0] + [astore-1 $1 $0 @1 _.astore-1] + [astore-2 $1 $0 @2 _.astore-2] + [astore-3 $1 $0 @3 _.astore-3] + + [iadd $2 $1 @0 _.iadd] + [isub $2 $1 @0 _.isub] + [imul $2 $1 @0 _.imul] + [idiv $2 $1 @0 _.idiv] + [irem $2 $1 @0 _.irem] + [ineg $2 $1 @0 _.ineg] + [ishl $2 $1 @0 _.ishl] + [ishr $2 $1 @0 _.ishr] + [iushr $2 $1 @0 _.iushr] + [iand $2 $1 @0 _.iand] + [ior $2 $1 @0 _.ior] + [ixor $2 $1 @0 _.ixor] + + [ladd $4 $2 @0 _.ladd] + [lsub $4 $2 @0 _.lsub] + [lmul $4 $2 @0 _.lmul] + [ldiv $4 $2 @0 _.ldiv] + [lrem $4 $2 @0 _.lrem] + [lneg $4 $2 @0 _.lneg] + [land $4 $2 @0 _.land] + [lor $4 $2 @0 _.lor] + [lxor $4 $2 @0 _.lxor] + [lshl $3 $2 @0 _.lshl] + [lshr $3 $2 @0 _.lshr] + [lushr $3 $2 @0 _.lushr] + + [fadd $2 $1 @0 _.fadd] + [fsub $2 $1 @0 _.fsub] + [fmul $2 $1 @0 _.fmul] + [fdiv $2 $1 @0 _.fdiv] + [frem $2 $1 @0 _.frem] + [fneg $2 $1 @0 _.fneg] + + [dadd $4 $2 @0 _.dadd] + [dsub $4 $2 @0 _.dsub] + [dmul $4 $2 @0 _.dmul] + [ddiv $4 $2 @0 _.ddiv] + [drem $4 $2 @0 _.drem] + [dneg $4 $2 @0 _.dneg] + + [l2i $2 $1 @0 _.l2i] + [l2f $2 $1 @0 _.l2f] + [l2d $2 $2 @0 _.l2d] + + [f2i $1 $1 @0 _.f2i] + [f2l $1 $2 @0 _.f2l] + [f2d $1 $2 @0 _.f2d] + + [d2i $2 $1 @0 _.d2i] + [d2l $2 $2 @0 _.d2l] + [d2f $2 $1 @0 _.d2f] + + [i2l $1 $2 @0 _.i2l] + [i2f $1 $1 @0 _.i2f] + [i2d $1 $2 @0 _.i2d] + [i2b $1 $1 @0 _.i2b] + [i2c $1 $1 @0 _.i2c] + [i2s $1 $1 @0 _.i2s] + + [lcmp $4 $1 @0 _.lcmp] + + [fcmpl $2 $1 @0 _.fcmpl] + [fcmpg $2 $1 @0 _.fcmpg] + + [dcmpl $4 $1 @0 _.dcmpl] + [dcmpg $4 $1 @0 _.dcmpg] + + [ireturn $1 $0 @0 _.ireturn] + [lreturn $2 $0 @0 _.lreturn] + [freturn $1 $0 @0 _.freturn] + [dreturn $2 $0 @0 _.dreturn] + [areturn $1 $0 @0 _.areturn] + [return $0 $0 @0 _.return] + + [arraylength $1 $1 @0 _.arraylength] + + [athrow $1 $0 @0 _.athrow] + + [monitorenter $1 $0 @0 _.monitorenter] + [monitorexit $1 $0 @0 _.monitorexit] + ) + +(def: #export (bipush byte) + (-> U1 (Bytecode Any)) + (..bytecode $0 $1 @0 _.bipush [byte])) + +(def: (lift resource) + (All [a] + (-> (Resource a) + (Bytecode a))) + (function (_ [pool environment tracker]) + (do try.monad + [[pool' output] (resource pool)] + (wrap [[pool' environment tracker] + [..relative-identity + output]])))) + +(def: #export (string value) + (-> //constant.UTF8 (Bytecode Any)) + (do ..monad + [index (..lift (//constant/pool.string value))] + (case (|> index //index.value //unsigned.value //unsigned.u1) + (#try.Success index) + (..bytecode $0 $1 @0 _.ldc [index]) + + (#try.Failure _) + (..bytecode $0 $1 @0 _.ldc-w/string [index])))) + +(template [<size> <name> <type> <constant> <ldc> <to-lux> <specializations>] + [(def: #export (<name> value) + (-> <type> (Bytecode Any)) + (case (|> value //constant.value <to-lux>) + (^template [<special> <instruction>] + <special> (..bytecode $0 <size> @0 <instruction> [])) + <specializations> + + _ (do ..monad + [index (..lift (<constant> value))] + (..bytecode $0 <size> @0 <ldc> [index]))))] + + [$1 int //constant.Integer //constant/pool.integer _.ldc-w/integer + (<| .int i32.i64) + ([-1 _.iconst-m1] + [+0 _.iconst-0] + [+1 _.iconst-1] + [+2 _.iconst-2] + [+3 _.iconst-3] + [+4 _.iconst-4] + [+5 _.iconst-5])] + [$2 long //constant.Long //constant/pool.long _.ldc2-w/long + (<|) + ([+0 _.lconst-0] + [+1 _.lconst-1])] + [$1 float //constant.Float //constant/pool.float _.ldc-w/float + (<| host.float-to-double) + ([+0.0 _.fconst-0] + [+1.0 _.fconst-1] + [+2.0 _.fconst-2])] + [$2 double //constant.Double //constant/pool.double _.ldc2-w/double + (<|) + ([+0.0 _.fconst-0] + [+1.0 _.fconst-1])] + ) + +(template [<size> <name> <general> <specials>] + [(def: #export (<name> local) + (-> Register (Bytecode Any)) + (with-expansions [<specials>' (template.splice <specials>)] + (`` (case (//unsigned.value local) + (~~ (template [<case> <instruction> <last-register>] + [<case> (..bytecode $0 <size> <last-register> <instruction> [])] + + <specials>')) + _ (..bytecode $0 <size> local <general> [local])))))] + + [$1 iload _.iload + [[0 _.iload-0 @0] + [1 _.iload-1 @1] + [2 _.iload-2 @2] + [3 _.iload-3 @3]]] + [$2 lload _.lload + [[0 _.lload-0 @1] + [1 _.lload-1 @2] + [2 _.lload-2 @3] + [3 _.lload-3 @4]]] + [$1 fload _.fload + [[0 _.fload-0 @0] + [1 _.fload-1 @1] + [2 _.fload-2 @2] + [3 _.fload-3 @3]]] + [$2 dload _.dload + [[0 _.dload-0 @1] + [1 _.dload-1 @2] + [2 _.dload-2 @3] + [3 _.dload-3 @4]]] + [$1 aload _.aload + [[0 _.aload-0 @0] + [1 _.aload-1 @1] + [2 _.aload-2 @2] + [3 _.aload-3 @3]]] + ) + +(template [<size> <name> <general> <specials>] + [(def: #export (<name> local) + (-> Register (Bytecode Any)) + (with-expansions [<specials>' (template.splice <specials>)] + (`` (case (//unsigned.value local) + (~~ (template [<case> <instruction> <last-register>] + [<case> (..bytecode <size> $0 <last-register> <instruction> [])] + + <specials>')) + _ (..bytecode <size> $0 local <general> [local])))))] + + [$1 istore _.istore + [[0 _.istore-0 @0] + [1 _.istore-1 @1] + [2 _.istore-2 @2] + [3 _.istore-3 @3]]] + [$2 lstore _.lstore + [[0 _.lstore-0 @1] + [1 _.lstore-1 @2] + [2 _.lstore-2 @3] + [3 _.lstore-3 @4]]] + [$1 fstore _.fstore + [[0 _.fstore-0 @0] + [1 _.fstore-1 @1] + [2 _.fstore-2 @2] + [3 _.fstore-3 @3]]] + [$2 dstore _.dstore + [[0 _.dstore-0 @1] + [1 _.dstore-1 @2] + [2 _.dstore-2 @3] + [3 _.dstore-3 @4]]] + [$1 astore _.astore + [[0 _.astore-0 @0] + [1 _.astore-1 @1] + [2 _.astore-2 @2] + [3 _.astore-3 @3]]] + ) + +(template [<consumption> <production> <name> <instruction> <input>] + [(def: #export <name> + (-> <input> (Bytecode Any)) + (..bytecode <consumption> <production> @0 <instruction>))] + + [$0 $0 ret _.ret Register] + [$1 $1 newarray _.newarray Primitive-Array-Type] + [$0 $1 sipush _.sipush U2] + ) + +(exception: #export (unknown-label {label Label}) + (exception.report + ["Label" (%.nat label)])) + +(exception: #export (cannot-do-a-big-jump {label Label} + {@from Address} + {jump Big-Jump}) + (exception.report + ["Label" (%.nat label)] + ["Start" (|> @from /address.value //unsigned.value %.nat)] + ["Target" (|> jump //signed.value %.int)])) + +(type: Any-Jump (Either Big-Jump Jump)) + +(def: (jump @from @to) + (-> Address Address (Try Any-Jump)) + (do try.monad + [jump (:: @ map //signed.value + (/address.jump @from @to))] + (let [big? (n.> (//unsigned.value //unsigned.maximum/2) + (.nat (i.* (if (i.>= +0 jump) + +1 + -1) + jump)))] + (if big? + (:: @ map (|>> #.Left) (//signed.s4 jump)) + (:: @ map (|>> #.Right) (//signed.s2 jump)))))) + +(def: (resolve-label label resolver) + (-> Label Resolver (Try Address)) + (case (dictionary.get label resolver) + (#.Some address) + (#try.Success address) + + #.None + (exception.throw ..unknown-label [label]))) + +(template [<consumption> <name> <instruction>] + [(def: #export (<name> label) + (-> Label (Bytecode Any)) + (let [[estimator bytecode] <instruction>] + (function (_ [pool environment tracker]) + (do try.monad + [environment' (|> environment + (/environment.consumes <consumption>)) + program-counter' (step estimator (get@ #program-counter tracker))] + (wrap (let [@from (get@ #program-counter tracker)] + [[pool environment' (set@ #program-counter program-counter' tracker)] + [(function (_ resolver) + (do try.monad + [@to (..resolve-label label resolver) + jump (..jump @from @to)] + (case jump + (#.Left jump) + (exception.throw ..cannot-do-a-big-jump [label @from jump]) + + (#.Right jump) + (#try.Success [..no-exceptions (bytecode jump)])))) + []]]))))))] + + [$1 ifeq _.ifeq] + [$1 ifne _.ifne] + [$1 iflt _.iflt] + [$1 ifge _.ifge] + [$1 ifgt _.ifgt] + [$1 ifle _.ifle] + + [$2 if-icmpeq _.if-icmpeq] + [$2 if-icmpne _.if-icmpne] + [$2 if-icmplt _.if-icmplt] + [$2 if-icmpge _.if-icmpge] + [$2 if-icmpgt _.if-icmpgt] + [$2 if-icmple _.if-icmple] + + [$2 if-acmpeq _.if-acmpeq] + [$2 if-acmpne _.if-acmpne] + + [$1 ifnull _.ifnull] + [$1 ifnonnull _.ifnonnull] + ) + +(template [<production> <name> <bytecode>] + [(def: #export (<name> label) + (-> Label (Bytecode Any)) + (let [[estimator bytecode] <bytecode>] + (function (_ [pool environment tracker]) + (do try.monad + [environment' (|> environment + (/environment.produces <production>)) + program-counter' (step estimator (get@ #program-counter tracker))] + (wrap (let [@from (get@ #program-counter tracker)] + [[pool environment' (set@ #program-counter program-counter' tracker)] + [(function (_ resolver) + (case (dictionary.get label resolver) + (#.Some @to) + (do try.monad + [jump (..jump @from @to)] + (case jump + (#.Left jump) + (exception.throw ..cannot-do-a-big-jump [label @from jump]) + + (#.Right jump) + (#try.Success [..no-exceptions (bytecode jump)]))) + + #.None + (exception.throw ..unknown-label [label]))) + []]]))))))] + + [$0 goto _.goto] + [$1 jsr _.jsr] + ) + +(def: (big-jump jump) + (-> Any-Jump Big-Jump) + (case jump + (#.Left big) + big + + (#.Right small) + (/jump.lift small))) + +(exception: #export invalid-tableswitch) + +(def: #export (tableswitch minimum default cases) + (-> S4 Label (List Label) (Bytecode Any)) + (let [[estimator bytecode] _.tableswitch] + (function (_ [pool environment tracker]) + (do try.monad + [environment' (|> environment + (/environment.consumes $1)) + program-counter' (step (estimator (list.size cases)) (get@ #program-counter tracker))] + (wrap (let [@from (get@ #program-counter tracker)] + [[pool environment' (set@ #program-counter program-counter' tracker)] + [(function (_ resolver) + (let [get (: (-> Label (Maybe Address)) + (function (_ label) + (dictionary.get label resolver)))] + (case (do maybe.monad + [@default (get default) + @cases (monad.map @ get cases)] + (wrap [@default @cases])) + (#.Some [@default @cases]) + (do try.monad + [>default (:: @ map ..big-jump (..jump @from @default)) + >cases (monad.map @ (|>> (..jump @from) (:: @ map ..big-jump)) + @cases)] + (#try.Success [..no-exceptions (bytecode minimum >default >cases)])) + + #.None + (exception.throw ..invalid-tableswitch [])))) + []]])))))) + +(exception: #export invalid-lookupswitch) + +(def: #export (lookupswitch default cases) + (-> Label (List [S4 Label]) (Bytecode Any)) + (let [[estimator bytecode] _.lookupswitch] + (function (_ [pool environment tracker]) + (do try.monad + [environment' (|> environment + (/environment.consumes $1)) + program-counter' (step (estimator (list.size cases)) (get@ #program-counter tracker))] + (wrap (let [@from (get@ #program-counter tracker)] + [[pool environment' (set@ #program-counter program-counter' tracker)] + [(function (_ resolver) + (let [get (: (-> Label (Maybe Address)) + (function (_ label) + (dictionary.get label resolver)))] + (case (do maybe.monad + [@default (get default) + @cases (monad.map @ (|>> product.right get) cases)] + (wrap [@default @cases])) + (#.Some [@default @cases]) + (do try.monad + [>default (:: @ map ..big-jump (..jump @from @default)) + >cases (|> @cases + (monad.map @ (|>> (..jump @from) (:: @ map ..big-jump))) + (:: @ map (|>> (list.zip2 (list@map product.left cases)))))] + (#try.Success [..no-exceptions (bytecode >default >cases)])) + + #.None + (exception.throw ..invalid-lookupswitch [])))) + []]])))))) + +(def: reflection + (All [category] + (-> (Type (<| Return' Value' category)) Text)) + (|>> type.reflection reflection.reflection)) + +(template [<consumption> <production> <name> <category> <instruction>] + [(def: #export (<name> class) + (-> (Type <category>) (Bytecode Any)) + (do ..monad + ## TODO: Make sure it's impossible to have indexes greater than U2. + [index (..lift (//constant/pool.class (//name.internal (..reflection class))))] + (..bytecode <consumption> <production> @0 <instruction> [index])))] + + [$0 $1 new Class _.new] + [$1 $1 anewarray Object _.anewarray] + [$1 $1 checkcast Object _.checkcast] + [$1 $1 instanceof Object _.instanceof] + ) + +(def: #export (iinc register increase) + (-> Register U1 (Bytecode Any)) + (..bytecode $0 $0 register _.iinc [register increase])) + +(def: #export (multianewarray class dimensions) + (-> (Type Class) U1 (Bytecode Any)) + (do ..monad + [index (..lift (//constant/pool.class (//name.internal (..reflection class))))] + (..bytecode (//unsigned.lift/2 dimensions) $1 @0 _.multianewarray [index dimensions]))) + +(def: (type-size type) + (-> (Type Return) Nat) + (cond (is? type.void type) + 0 + + (or (is? type.long type) + (is? type.double type)) + 2 + + ## else + 1)) + +(template [<static?> <name> <instruction>] + [(def: #export (<name> class method type) + (-> (Type Class) Text (Type Method) (Bytecode Any)) + (let [[inputs output exceptions] (parser.method type)] + (do ..monad + [index (<| ..lift + (//constant/pool.method (..reflection class)) + {#//constant/pool.name method + #//constant/pool.descriptor (type.descriptor type)}) + #let [consumption (|> inputs + (list@map ..type-size) + (list@fold n.+ (if <static?> 0 1)) + //unsigned.u1 + try.assume) + production (|> output ..type-size //unsigned.u1 try.assume)]] + (..bytecode (//unsigned.lift/2 consumption) + (//unsigned.lift/2 production) + @0 + <instruction> [index consumption production]))))] + + [#1 invokestatic _.invokestatic] + [#0 invokevirtual _.invokevirtual] + [#0 invokespecial _.invokespecial] + [#0 invokeinterface _.invokeinterface] + ) + +(template [<consumption> <name> <1> <2>] + [(def: #export (<name> class field type) + (-> (Type Class) Text (Type Value) (Bytecode Any)) + (do ..monad + [index (<| ..lift + (//constant/pool.field (..reflection class)) + {#//constant/pool.name field + #//constant/pool.descriptor (type.descriptor type)})] + (if (or (is? type.long type) + (is? type.double type)) + (..bytecode <consumption> $2 @0 <2> [index]) + (..bytecode <consumption> $1 @0 <1> [index]))))] + + [$0 getstatic _.getstatic/1 _.getstatic/2] + [$1 putstatic _.putstatic/1 _.putstatic/2] + [$1 getfield _.getfield/1 _.getfield/2] + [$2 putfield _.putfield/1 _.putfield/2] + ) + +(exception: #export (invalid-range-for-try {start Address} {end Address}) + (exception.report + ["Start" (|> start /address.value //unsigned.value %.nat)] + ["End" (|> end /address.value //unsigned.value %.nat)])) + +(def: #export (try @start @end @handler catch) + (-> Label Label Label (Type Class) (Bytecode Any)) + (do ..monad + [@catch (..lift (//constant/pool.class (//name.internal (..reflection catch))))] + (function (_ [pool environment tracker]) + (#try.Success + [[pool environment tracker] + [(function (_ resolver) + (do try.monad + [@start (..resolve-label @start resolver) + @end (..resolve-label @end resolver) + _ (if (/address.after? @start @end) + (wrap []) + (exception.throw ..invalid-range-for-try [@start @end])) + @handler (..resolve-label @handler resolver)] + (wrap [(row.row {#//exception.start @start + #//exception.end @end + #//exception.handler @handler + #//exception.catch @catch}) + _.empty]))) + []]])))) + +(def: #export (compose pre post) + (All [pre post] + (-> (Bytecode pre) (Bytecode post) (Bytecode post))) + (do ..monad + [_ pre] + post)) diff --git a/stdlib/source/lux/target/jvm/bytecode/address.lux b/stdlib/source/lux/target/jvm/bytecode/address.lux new file mode 100644 index 000000000..4b58b1ca1 --- /dev/null +++ b/stdlib/source/lux/target/jvm/bytecode/address.lux @@ -0,0 +1,68 @@ +(.module: + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [monad (#+ do)]] + [control + ["." try (#+ Try)]] + [data + [format + [binary (#+ Writer)]] + [number + ["n" nat]]] + [type + abstract]] + ["." // #_ + [jump (#+ Big-Jump)] + ["/#" // #_ + [encoding + ["#." unsigned (#+ U2)] + ["#." signed (#+ S4)]]]]) + +(abstract: #export Address + {} + + U2 + + (def: #export value + (-> Address U2) + (|>> :representation)) + + (def: #export start + Address + (|> 0 ///unsigned.u2 try.assume :abstraction)) + + (def: #export (move distance) + (-> U2 (-> Address (Try Address))) + (|>> :representation + (///unsigned.+/2 distance) + (:: try.functor map (|>> :abstraction)))) + + (def: with-sign + (-> Address (Try S4)) + (|>> :representation ///unsigned.value .int ///signed.s4)) + + (def: #export (jump from to) + (-> Address Address (Try Big-Jump)) + (do try.monad + [from (with-sign from) + to (with-sign to)] + (///signed.-/4 from to))) + + (def: #export (after? reference subject) + (-> Address Address Bit) + (n.> (|> reference :representation ///unsigned.value) + (|> subject :representation ///unsigned.value))) + + (structure: #export equivalence + (Equivalence Address) + + (def: (= reference subject) + (:: ///unsigned.equivalence = + (:representation reference) + (:representation subject)))) + + (def: #export writer + (Writer Address) + (|>> :representation ///unsigned.writer/2)) + ) diff --git a/stdlib/source/lux/target/jvm/bytecode/environment.lux b/stdlib/source/lux/target/jvm/bytecode/environment.lux new file mode 100644 index 000000000..9056b0911 --- /dev/null +++ b/stdlib/source/lux/target/jvm/bytecode/environment.lux @@ -0,0 +1,63 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)] + [monoid (#+ Monoid)]] + [control + ["." try (#+ Try)]]] + [/ + ["/." limit (#+ Limit) + ["/." stack (#+ Stack)] + ["/." registry (#+ Register)]] + [/// + [encoding + [unsigned (#+ U2)]]]]) + +(type: #export Environment + {#limit Limit + #stack Stack}) + +(def: #export start + Environment + {#limit /limit.start + #stack /stack.empty}) + +(type: #export Condition + (-> Environment (Try Environment))) + +(structure: #export monoid + (Monoid Condition) + + (def: identity (|>> #try.Success)) + + (def: (compose left right) + (function (_ environment) + (do try.monad + [environment (left environment)] + (right environment))))) + +(def: #export (consumes amount) + (-> U2 Condition) + ## TODO: Revisit this definition once lenses/optics have been implemented, + ## since it can probably be simplified with them. + (function (_ environment) + (do try.monad + [stack' (/stack.pop amount (get@ #..stack environment))] + (wrap (set@ #..stack stack' environment))))) + +(def: #export (produces amount) + (-> U2 Condition) + (function (_ environment) + (do try.monad + [current (/stack.push amount (get@ #..stack environment)) + #let [limit (|> environment + (get@ [#..limit #/limit.stack]) + (/stack.max current))]] + (wrap (|> environment + (set@ #..stack current) + (set@ [#..limit #/limit.stack] limit)))))) + +(def: #export (has register) + (-> Register Condition) + (|>> (update@ [#..limit #/limit.registry] (/registry.has register)) + #try.Success)) diff --git a/stdlib/source/lux/target/jvm/bytecode/environment/limit.lux b/stdlib/source/lux/target/jvm/bytecode/environment/limit.lux new file mode 100644 index 000000000..2e2312fb5 --- /dev/null +++ b/stdlib/source/lux/target/jvm/bytecode/environment/limit.lux @@ -0,0 +1,42 @@ +(.module: + [lux #* + [abstract + ["." equivalence (#+ Equivalence)]] + [data + [number + ["n" nat]] + ["." format #_ + ["#" binary (#+ Writer) ("#@." monoid)]]]] + ["." / #_ + ["#." stack (#+ Stack)] + ["#." registry (#+ Registry)]]) + +(type: #export Limit + {#stack Stack + #registry Registry}) + +(def: #export start + Limit + {#stack /stack.empty + #registry /registry.empty}) + +(def: #export length + ($_ n.+ + ## u2 max_stack; + /stack.length + ## u2 max_locals; + /registry.length)) + +(def: #export equivalence + (Equivalence Limit) + ($_ equivalence.product + /stack.equivalence + /registry.equivalence + )) + +(def: #export (writer limit) + (Writer Limit) + ($_ format@compose + (/stack.writer (get@ #stack limit)) + (/registry.writer (get@ #registry limit)) + )) diff --git a/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux b/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux new file mode 100644 index 000000000..c04f6fa15 --- /dev/null +++ b/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux @@ -0,0 +1,44 @@ +(.module: + [lux #* + [abstract + ["." equivalence (#+ Equivalence)]] + [data + ["." maybe] + [format + [binary (#+ Writer)]]] + [type + abstract]] + ["." ///// #_ + [encoding + ["#." unsigned (#+ U1 U2)]]]) + +(type: #export Register U1) + +(abstract: #export Registry + {} + + U2 + + (def: #export empty + Registry + (|> 0 /////unsigned.u2 maybe.assume :abstraction)) + + (def: #export equivalence + (Equivalence Registry) + (:: equivalence.contravariant map-1 + (|>> :representation) + /////unsigned.equivalence)) + + (def: #export writer + (Writer Registry) + (|>> :representation /////unsigned.writer/2)) + + (def: #export (has register) + (-> Register (-> Registry Registry)) + (|>> :representation + (/////unsigned.max/2 (/////unsigned.lift/2 register)) + :abstraction)) + ) + +(def: #export length + /////unsigned.bytes/2) diff --git a/stdlib/source/lux/target/jvm/bytecode/environment/limit/stack.lux b/stdlib/source/lux/target/jvm/bytecode/environment/limit/stack.lux new file mode 100644 index 000000000..87ad6a31b --- /dev/null +++ b/stdlib/source/lux/target/jvm/bytecode/environment/limit/stack.lux @@ -0,0 +1,59 @@ +(.module: + [lux #* + [abstract + ["." equivalence (#+ Equivalence)]] + [control + ["." try (#+ Try)]] + [data + ["." maybe] + [format + [binary (#+ Writer)]]] + [type + abstract]] + ["." ///// #_ + [encoding + ["#." unsigned (#+ U2)]]]) + +(abstract: #export Stack + {} + + U2 + + (def: #export empty + Stack + (|> 0 /////unsigned.u2 maybe.assume :abstraction)) + + (def: #export equivalence + (Equivalence Stack) + (:: equivalence.contravariant map-1 + (|>> :representation) + /////unsigned.equivalence)) + + (def: #export writer + (Writer Stack) + (|>> :representation /////unsigned.writer/2)) + + (def: stack + (-> U2 Stack) + (|>> :abstraction)) + + (template [<op> <name>] + [(def: #export (<name> amount) + (-> U2 (-> Stack (Try Stack))) + (|>> :representation + (<op> amount) + (:: try.functor map ..stack)))] + + [/////unsigned.+/2 push] + [/////unsigned.-/2 pop] + ) + + (def: #export (max left right) + (-> Stack Stack Stack) + (:abstraction + (/////unsigned.max/2 (:representation left) + (:representation right)))) + ) + +(def: #export length + /////unsigned.bytes/2) diff --git a/stdlib/source/lux/target/jvm/bytecode/instruction.lux b/stdlib/source/lux/target/jvm/bytecode/instruction.lux new file mode 100644 index 000000000..0a80b067c --- /dev/null +++ b/stdlib/source/lux/target/jvm/bytecode/instruction.lux @@ -0,0 +1,685 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)] + [monoid (#+ Monoid)]] + [control + ["." function] + ["." try]] + [data + ["." product] + ["." binary] + [number (#+ hex) + ["n" nat]] + [format + [".F" binary (#+ Mutation Specification)]] + [collection + ["." list]]] + [macro + ["." template]] + [type + abstract]] + ["." // #_ + ["#." address (#+ Address)] + ["#." jump (#+ Jump Big-Jump)] + [environment + [limit + [registry (#+ Register)]]] + ["/#" // #_ + ["#." index (#+ Index)] + ["#." constant (#+ Class Reference)] + [encoding + ["#." unsigned (#+ U1 U2 U4)] + ["#." signed (#+ S4)]] + [type + [category (#+ Value Method)]]]]) + +(type: #export Size U2) + +(type: #export Estimator + (-> Address Size)) + +(def: fixed + (-> Size Estimator) + function.constant) + +(type: #export Instruction + (-> Specification Specification)) + +(def: #export empty + Instruction + function.identity) + +(def: #export run + (-> Instruction Specification) + (function.apply binaryF.no-op)) + +(type: Opcode Nat) + +(template [<name> <size>] + [(def: <name> Size (|> <size> ///unsigned.u2 try.assume))] + + [opcode-size 1] + [register-size 1] + [byte-size 1] + [index-size 2] + [big-jump-size 4] + [integer-size 4] + ) + +(def: (nullary' opcode) + (-> Opcode Mutation) + (function (_ [offset binary]) + [(n.+ (///unsigned.value ..opcode-size) + offset) + (try.assume + (binary.write/8 offset opcode binary))])) + +(def: nullary + [Estimator (-> Opcode Instruction)] + [(..fixed ..opcode-size) + (function (_ opcode [size mutation]) + [(n.+ (///unsigned.value ..opcode-size) + size) + (|>> mutation ((nullary' opcode)))])]) + +(template [<name> <size>] + [(def: <name> + Size + (|> ..opcode-size + (///unsigned.+/2 <size>) try.assume))] + + [size/1 ..register-size] + [size/2 ..index-size] + [size/4 ..big-jump-size] + ) + +(template [<shift> <name> <inputT> <writer> <unwrap>] + [(with-expansions [<private> (template.identifier [<name> "'"])] + (def: (<private> opcode input0) + (-> Opcode <inputT> Mutation) + (function (_ [offset binary]) + [(n.+ (///unsigned.value <shift>) offset) + (try.assume + (do try.monad + [_ (binary.write/8 offset opcode binary)] + (<writer> (n.+ (///unsigned.value ..opcode-size) offset) + (<unwrap> input0) + binary)))])) + + (def: <name> + [Estimator (-> Opcode <inputT> Instruction)] + [(..fixed <shift>) + (function (_ opcode input0 [size mutation]) + [(n.+ (///unsigned.value <shift>) size) + (|>> mutation ((<private> opcode input0)))])]))] + + [..size/1 unary/1 U1 binary.write/8 ///unsigned.value] + [..size/2 unary/2 U2 binary.write/16 ///unsigned.value] + [..size/2 jump/2 Jump binary.write/16 ///signed.value] + [..size/4 jump/4 Big-Jump binary.write/32 ///signed.value] + ) + +(def: size/11 + Size + (|> ..opcode-size + (///unsigned.+/2 ..register-size) try.assume + (///unsigned.+/2 ..byte-size) try.assume)) + +(def: (binary/11' opcode input0 input1) + (-> Opcode U1 U1 Mutation) + (function (_ [offset binary]) + [(n.+ (///unsigned.value ..size/11) offset) + (try.assume + (do try.monad + [_ (binary.write/8 offset opcode binary) + _ (binary.write/8 (n.+ (///unsigned.value ..opcode-size) offset) + (///unsigned.value input0) + binary)] + (binary.write/8 (n.+ (///unsigned.value ..size/1) offset) + (///unsigned.value input1) + binary)))])) + +(def: binary/11 + [Estimator (-> Opcode U1 U1 Instruction)] + [(..fixed ..size/11) + (function (_ opcode input0 input1 [size mutation]) + [(n.+ (///unsigned.value ..size/11) size) + (|>> mutation ((binary/11' opcode input0 input1)))])]) + +(def: size/21 + Size + (|> ..opcode-size + (///unsigned.+/2 ..index-size) try.assume + (///unsigned.+/2 ..byte-size) try.assume)) + +(def: (binary/21' opcode input0 input1) + (-> Opcode U2 U1 Mutation) + (function (_ [offset binary]) + [(n.+ (///unsigned.value ..size/21) offset) + (try.assume + (do try.monad + [_ (binary.write/8 offset opcode binary) + _ (binary.write/16 (n.+ (///unsigned.value ..opcode-size) offset) + (///unsigned.value input0) + binary)] + (binary.write/8 (n.+ (///unsigned.value ..size/2) offset) + (///unsigned.value input1) + binary)))])) + +(def: binary/21 + [Estimator (-> Opcode U2 U1 Instruction)] + [(..fixed ..size/21) + (function (_ opcode input0 input1 [size mutation]) + [(n.+ (///unsigned.value ..size/21) size) + (|>> mutation ((binary/21' opcode input0 input1)))])]) + +(def: size/211 + Size + (|> ..opcode-size + (///unsigned.+/2 ..index-size) try.assume + (///unsigned.+/2 ..byte-size) try.assume + (///unsigned.+/2 ..byte-size) try.assume)) + +(def: (trinary/211' opcode input0 input1 input2) + (-> Opcode U2 U1 U1 Mutation) + (function (_ [offset binary]) + [(n.+ (///unsigned.value ..size/211) offset) + (try.assume + (do try.monad + [_ (binary.write/8 offset opcode binary) + _ (binary.write/16 (n.+ (///unsigned.value ..opcode-size) offset) + (///unsigned.value input0) + binary) + _ (binary.write/8 (n.+ (///unsigned.value ..size/2) offset) + (///unsigned.value input1) + binary)] + (binary.write/8 (n.+ (///unsigned.value ..size/21) offset) + (///unsigned.value input2) + binary)))])) + +(def: trinary/211 + [Estimator (-> Opcode U2 U1 U1 Instruction)] + [(..fixed ..size/211) + (function (_ opcode input0 input1 input2 [size mutation]) + [(n.+ (///unsigned.value ..size/211) size) + (|>> mutation ((trinary/211' opcode input0 input1 input2)))])]) + +(abstract: #export Primitive-Array-Type + {} + + U1 + + (def: code + (-> Primitive-Array-Type U1) + (|>> :representation)) + + (template [<code> <name>] + [(def: #export <name> (|> <code> ///unsigned.u1 try.assume :abstraction))] + + [04 t-boolean] + [05 t-char] + [06 t-float] + [07 t-double] + [08 t-byte] + [09 t-short] + [10 t-int] + [11 t-long] + )) + +## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-6.html#jvms-6.5 +(with-expansions [<constants> (template [<code> <name>] + [[<code> <name> [] []]] + + ["01" aconst-null] + + ["02" iconst-m1] + ["03" iconst-0] + ["04" iconst-1] + ["05" iconst-2] + ["06" iconst-3] + ["07" iconst-4] + ["08" iconst-5] + + ["09" lconst-0] + ["0A" lconst-1] + + ["0B" fconst-0] + ["0C" fconst-1] + ["0D" fconst-2] + + ["0E" dconst-0] + ["0F" dconst-1]) + <register-loads> (template [<code> <name>] + [[<code> <name> [[register Register]] [register]]] + + ["15" iload] + ["16" lload] + ["17" fload] + ["18" dload] + ["19" aload]) + <simple-register-loads> (template [<code> <name>] + [[<code> <name> [] []]] + + ["1A" iload-0] + ["1B" iload-1] + ["1C" iload-2] + ["1D" iload-3] + + ["1E" lload-0] + ["1F" lload-1] + ["20" lload-2] + ["21" lload-3] + + ["22" fload-0] + ["23" fload-1] + ["24" fload-2] + ["25" fload-3] + + ["26" dload-0] + ["27" dload-1] + ["28" dload-2] + ["29" dload-3] + + ["2A" aload-0] + ["2B" aload-1] + ["2C" aload-2] + ["2D" aload-3]) + <register-stores> (template [<code> <name>] + [[<code> <name> [[register Register]] [register]]] + + ["36" istore] + ["37" lstore] + ["38" fstore] + ["39" dstore] + ["3A" astore]) + <simple-register-stores> (template [<code> <name>] + [[<code> <name> [] []]] + + ["3B" istore-0] + ["3C" istore-1] + ["3D" istore-2] + ["3E" istore-3] + + ["3F" lstore-0] + ["40" lstore-1] + ["41" lstore-2] + ["42" lstore-3] + + ["43" fstore-0] + ["44" fstore-1] + ["45" fstore-2] + ["46" fstore-3] + + ["47" dstore-0] + ["48" dstore-1] + ["49" dstore-2] + ["4A" dstore-3] + + ["4B" astore-0] + ["4C" astore-1] + ["4D" astore-2] + ["4E" astore-3]) + <array-loads> (template [<code> <name>] + [[<code> <name> [] []]] + + ["2E" iaload] + ["2F" laload] + ["30" faload] + ["31" daload] + ["32" aaload] + ["33" baload] + ["34" caload] + ["35" saload]) + <array-stores> (template [<code> <name>] + [[<code> <name> [] []]] + + ["4f" iastore] + ["50" lastore] + ["51" fastore] + ["52" dastore] + ["53" aastore] + ["54" bastore] + ["55" castore] + ["56" sastore]) + <arithmetic> (template [<code> <name>] + [[<code> <name> [] []]] + + ["60" iadd] + ["64" isub] + ["68" imul] + ["6c" idiv] + ["70" irem] + ["74" ineg] + ["78" ishl] + ["7a" ishr] + ["7c" iushr] + ["7e" iand] + ["80" ior] + ["82" ixor] + + ["61" ladd] + ["65" lsub] + ["69" lmul] + ["6D" ldiv] + ["71" lrem] + ["75" lneg] + ["7F" land] + ["81" lor] + ["83" lxor] + + ["62" fadd] + ["66" fsub] + ["6A" fmul] + ["6E" fdiv] + ["72" frem] + ["76" fneg] + + ["63" dadd] + ["67" dsub] + ["6B" dmul] + ["6F" ddiv] + ["73" drem] + ["77" dneg]) + <conversions> (template [<code> <name>] + [[<code> <name> [] []]] + + ["88" l2i] + ["89" l2f] + ["8A" l2d] + + ["8B" f2i] + ["8C" f2l] + ["8D" f2d] + + ["8E" d2i] + ["8F" d2l] + ["90" d2f] + + ["85" i2l] + ["86" i2f] + ["87" i2d] + ["91" i2b] + ["92" i2c] + ["93" i2s]) + <comparisons> (template [<code> <name>] + [[<code> <name> [] []]] + + ["94" lcmp] + + ["95" fcmpl] + ["96" fcmpg] + + ["97" dcmpl] + ["98" dcmpg]) + <returns> (template [<code> <name>] + [[<code> <name> [] []]] + + ["AC" ireturn] + ["AD" lreturn] + ["AE" freturn] + ["AF" dreturn] + ["B0" areturn] + ["B1" return] + ) + <jumps> (template [<code> <name>] + [[<code> <name> [[jump Jump]] [jump]]] + + ["99" ifeq] + ["9A" ifne] + ["9B" iflt] + ["9C" ifge] + ["9D" ifgt] + ["9E" ifle] + + ["9F" if-icmpeq] + ["A0" if-icmpne] + ["A1" if-icmplt] + ["A2" if-icmpge] + ["A3" if-icmpgt] + ["A4" if-icmple] + + ["A5" if-acmpeq] + ["A6" if-acmpne] + + ["A7" goto] + ["A8" jsr] + + ["C6" ifnull] + ["C7" ifnonnull]) + <fields> (template [<code> <name>] + [[<code> <name> [[index (Index (Reference Value))]] [(///index.value index)]]] + + ["B2" getstatic/1] ["B2" getstatic/2] + ["B3" putstatic/1] ["B3" putstatic/2] + ["B4" getfield/1] ["B4" getfield/2] + ["B5" putfield/1] ["B5" putfield/2])] + (template [<arity> <definitions>] + [(with-expansions [<definitions>' (template.splice <definitions>)] + (template [<code> <name> <instruction-inputs> <arity-inputs>] + [(with-expansions [<inputs>' (template.splice <instruction-inputs>) + <input-types> (template [<input-name> <input-type>] + [<input-type>] + + <inputs>') + <input-names> (template [<input-name> <input-type>] + [<input-name>] + + <inputs>')] + (def: #export <name> + [Estimator (-> [<input-types>] Instruction)] + (let [[estimator <arity>'] <arity>] + [estimator + (function (_ [<input-names>]) + (`` (<arity>' (hex <code>) (~~ (template.splice <arity-inputs>)))))])))] + + <definitions>' + ))] + + [..nullary + [["00" nop [] []] + <constants> + ["57" pop [] []] + ["58" pop2 [] []] + ["59" dup [] []] + ["5A" dup-x1 [] []] + ["5B" dup-x2 [] []] + ["5C" dup2 [] []] + ["5D" dup2-x1 [] []] + ["5E" dup2-x2 [] []] + ["5F" swap [] []] + <simple-register-loads> + <array-loads> + <simple-register-stores> + <array-stores> + <arithmetic> + ["79" lshl [] []] + ["7B" lshr [] []] + ["7D" lushr [] []] + <conversions> + <comparisons> + <returns> + ["BE" arraylength [] []] + ["BF" athrow [] []] + ["C2" monitorenter [] []] + ["C3" monitorexit [] []]]] + + [..unary/1 + [["10" bipush [[byte U1]] [byte]] + ["12" ldc [[index U1]] [index]] + <register-loads> + <register-stores> + ["A9" ret [[register Register]] [register]] + ["BC" newarray [[type Primitive-Array-Type]] [(..code type)]]]] + + [..unary/2 + [["11" sipush [[short U2]] [short]] + ["13" ldc-w/integer [[index (Index ///constant.Integer)]] [(///index.value index)]] + ["13" ldc-w/float [[index (Index ///constant.Float)]] [(///index.value index)]] + ["13" ldc-w/string [[index (Index ///constant.String)]] [(///index.value index)]] + ["14" ldc2-w/long [[index (Index ///constant.Long)]] [(///index.value index)]] + ["14" ldc2-w/double [[index (Index ///constant.Double)]] [(///index.value index)]] + <fields> + ["BB" new [[index (Index Class)]] [(///index.value index)]] + ["BD" anewarray [[index (Index Class)]] [(///index.value index)]] + ["C0" checkcast [[index (Index Class)]] [(///index.value index)]] + ["C1" instanceof [[index (Index Class)]] [(///index.value index)]] + ["B6" invokevirtual [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.value index)]] + ["B7" invokespecial [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.value index)]] + ["B8" invokestatic [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.value index)]]]] + + [..jump/2 + [<jumps>]] + + [..jump/4 + [["C8" goto-w [[jump Big-Jump]] [jump]] + ["C9" jsr-w [[jump Big-Jump]] [jump]]]] + + [..binary/11 + [["84" iinc [[register Register] [byte U1]] [register byte]]]] + + [..binary/21 + [["C5" multianewarray [[index (Index Class)] [count U1]] [(///index.value index) count]]]] + + [..trinary/211 + [["B9" invokeinterface [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.value index) count (try.assume (///unsigned.u1 0))]]]] + )) + +(def: (switch-padding offset) + (-> Nat Nat) + (let [parameter-start (n.+ (///unsigned.value ..opcode-size) + offset)] + (n.% 4 + (n.- (n.% 4 parameter-start) + 4)))) + +(def: #export tableswitch + [(-> Nat Estimator) + (-> S4 Big-Jump (List Big-Jump) Instruction)] + (let [estimator (: (-> Nat Estimator) + (function (_ amount-of-cases offset) + (|> ($_ n.+ + (///unsigned.value ..opcode-size) + (switch-padding (///unsigned.value (//address.value offset))) + (///unsigned.value ..big-jump-size) + (///unsigned.value ..integer-size) + (///unsigned.value ..integer-size) + (n.* amount-of-cases + (///unsigned.value ..big-jump-size))) + ///unsigned.u2 + try.assume)))] + [estimator + (function (_ minimum default cases) + (let [amount-of-cases (list.size cases) + estimator (estimator amount-of-cases)] + (function (_ [size mutation]) + (let [padding (switch-padding size) + tableswitch-size (try.assume + (do try.monad + [size (///unsigned.u2 size)] + (:: @ map (|>> estimator ///unsigned.value) + (//address.move size //address.start)))) + tableswitch-mutation (: Mutation + (function (_ [offset binary]) + [(n.+ tableswitch-size offset) + (try.assume + (do try.monad + [amount-of-cases (|> amount-of-cases .int ///signed.s4) + maximum (///signed.+/4 minimum amount-of-cases) + _ (binary.write/8 offset (hex "AA") binary) + #let [offset (n.+ (///unsigned.value ..opcode-size) offset)] + _ (case padding + 3 (do @ + [_ (binary.write/8 offset 0 binary)] + (binary.write/16 (inc offset) 0 binary)) + 2 (binary.write/16 offset 0 binary) + 1 (binary.write/8 offset 0 binary) + _ (wrap binary)) + #let [offset (n.+ padding offset)] + _ (binary.write/32 offset (///signed.value default) binary) + #let [offset (n.+ (///unsigned.value ..big-jump-size) offset)] + _ (binary.write/32 offset (///signed.value minimum) binary) + #let [offset (n.+ (///unsigned.value ..integer-size) offset)] + _ (binary.write/32 offset (///signed.value maximum) binary)] + (loop [offset (n.+ (///unsigned.value ..integer-size) offset) + cases cases] + (case cases + #.Nil + (wrap binary) + + (#.Cons head tail) + (do @ + [_ (binary.write/32 offset (///signed.value head) binary)] + (recur (n.+ (///unsigned.value ..big-jump-size) offset) + tail))))))]))] + [(n.+ tableswitch-size + size) + (|>> mutation tableswitch-mutation)]))))])) + +(def: #export lookupswitch + [(-> Nat Estimator) + (-> Big-Jump (List [S4 Big-Jump]) Instruction)] + (let [case-size (n.+ (///unsigned.value ..integer-size) + (///unsigned.value ..big-jump-size)) + estimator (: (-> Nat Estimator) + (function (_ amount-of-cases offset) + (|> ($_ n.+ + (///unsigned.value ..opcode-size) + (switch-padding (///unsigned.value (//address.value offset))) + (///unsigned.value ..big-jump-size) + (///unsigned.value ..integer-size) + (n.* amount-of-cases case-size)) + ///unsigned.u2 + try.assume)))] + [estimator + (function (_ default cases) + (let [amount-of-cases (list.size cases) + estimator (estimator amount-of-cases)] + (function (_ [size mutation]) + (let [padding (switch-padding size) + lookupswitch-size (try.assume + (do try.monad + [size (///unsigned.u2 size)] + (:: @ map (|>> estimator ///unsigned.value) + (//address.move size //address.start)))) + lookupswitch-mutation (: Mutation + (function (_ [offset binary]) + [(n.+ lookupswitch-size offset) + (try.assume + (do try.monad + [_ (binary.write/8 offset (hex "AB") binary) + #let [offset (n.+ (///unsigned.value ..opcode-size) offset)] + _ (case padding + 3 (do @ + [_ (binary.write/8 offset 0 binary)] + (binary.write/16 (inc offset) 0 binary)) + 2 (binary.write/16 offset 0 binary) + 1 (binary.write/8 offset 0 binary) + _ (wrap binary)) + #let [offset (n.+ padding offset)] + _ (binary.write/32 offset (///signed.value default) binary) + #let [offset (n.+ (///unsigned.value ..big-jump-size) offset)] + _ (binary.write/32 offset amount-of-cases binary)] + (loop [offset (n.+ (///unsigned.value ..integer-size) offset) + cases cases] + (case cases + #.Nil + (wrap binary) + + (#.Cons [value jump] tail) + (do @ + [_ (binary.write/32 offset (///signed.value value) binary) + _ (binary.write/32 (n.+ (///unsigned.value ..integer-size) offset) (///signed.value jump) binary)] + (recur (n.+ case-size offset) + tail))))))]))] + [(n.+ lookupswitch-size + size) + (|>> mutation lookupswitch-mutation)]))))])) + +(structure: #export monoid + (Monoid Instruction) + + (def: identity ..empty) + + (def: (compose left right) + (|>> left right))) diff --git a/stdlib/source/lux/target/jvm/instruction/jump.lux b/stdlib/source/lux/target/jvm/bytecode/jump.lux index fcda92bd1..47126631c 100644 --- a/stdlib/source/lux/target/jvm/instruction/jump.lux +++ b/stdlib/source/lux/target/jvm/bytecode/jump.lux @@ -12,10 +12,10 @@ ///signed.equivalence) (def: #export writer - ///signed.s2-writer) + ///signed.writer/2) (type: #export Big-Jump S4) (def: #export lift (-> Jump Big-Jump) - (|>> ///signed.int ///signed.s4)) + ///signed.lift/4) diff --git a/stdlib/source/lux/target/jvm/class.lux b/stdlib/source/lux/target/jvm/class.lux index bc3670110..ec2832b19 100644 --- a/stdlib/source/lux/target/jvm/class.lux +++ b/stdlib/source/lux/target/jvm/class.lux @@ -5,7 +5,8 @@ ["." equivalence (#+ Equivalence)] ["." monad (#+ do)]] [control - ["." state (#+ State)]] + ["." state] + ["." try (#+ Try)]] [data [number (#+) [i64 (#+)]] @@ -27,7 +28,7 @@ ["#." unsigned (#+)] ["#." name (#+ Internal)]] ["#." constant (#+ Constant) - ["#/." pool (#+ Pool)]]]) + ["#/." pool (#+ Pool Resource)]]]) (type: #export #rec Class {#magic Magic @@ -70,11 +71,11 @@ (def: (install-classes this super interfaces) (-> Internal Internal (List Internal) - (State Pool [(Index //constant.Class) (Index //constant.Class) (Row (Index //constant.Class))])) - (do state.monad + (Resource [(Index //constant.Class) (Index //constant.Class) (Row (Index //constant.Class))])) + (do //constant/pool.monad [@this (//constant/pool.class this) @super (//constant/pool.class super) - @interfaces (: (State Pool (Row (Index //constant.Class))) + @interfaces (: (Resource (Row (Index //constant.Class))) (monad.fold @ (function (_ interface @interfaces) (do @ [@interface (//constant/pool.class interface)] @@ -88,28 +89,29 @@ fields methods attributes) (-> Major (Modifier Class) Internal Internal (List Internal) - (List (State Pool Field)) - (List (State Pool Method)) + (List (Resource Field)) + (List (Resource Method)) (Row Attribute) - Class) - (let [[pool [@this @super @interfaces] =fields =methods] - (state.run //constant/pool.empty - (do state.monad - [classes (install-classes this super interfaces) - =fields (monad.seq state.monad fields) - =methods (monad.seq state.monad methods)] - (wrap [classes =fields =methods])))] - {#magic //magic.code - #minor-version //version.default-minor - #major-version version - #constant-pool pool - #modifier modifier - #this @this - #super @super - #interfaces @interfaces - #fields (row.from-list =fields) - #methods (row.from-list =methods) - #attributes attributes})) + (Try Class)) + (do try.monad + [[pool [@this @super @interfaces] =fields =methods] + (<| (state.run' //constant/pool.empty) + (do //constant/pool.monad + [classes (install-classes this super interfaces) + =fields (monad.seq //constant/pool.monad fields) + =methods (monad.seq //constant/pool.monad methods)] + (wrap [classes =fields =methods])))] + (wrap {#magic //magic.code + #minor-version //version.default-minor + #major-version version + #constant-pool pool + #modifier modifier + #this @this + #super @super + #interfaces @interfaces + #fields (row.from-list =fields) + #methods (row.from-list =methods) + #attributes attributes}))) (def: #export (writer class) (Writer Class) diff --git a/stdlib/source/lux/target/jvm/constant/pool.lux b/stdlib/source/lux/target/jvm/constant/pool.lux index c6dd5e45c..a839a4a3e 100644 --- a/stdlib/source/lux/target/jvm/constant/pool.lux +++ b/stdlib/source/lux/target/jvm/constant/pool.lux @@ -3,11 +3,10 @@ ["." host] [abstract ["." equivalence (#+ Equivalence)] - [monad (#+ do)]] + [monad (#+ Monad do)]] [control - ["." state (#+ State)] - ["." try (#+ Try)] - ["." exception (#+ exception:)]] + ["." state (#+ State')] + ["." try (#+ Try)]] [data [number ["." i32] @@ -16,8 +15,8 @@ ["." frac]] ["." text ["%" format (#+ format)]] - [format - [".F" binary (#+ Writer) ("specification@." monoid)]] + ["." format #_ + ["#" binary (#+ Writer) ("specification@." monoid)]] [collection ["." row (#+ Row) ("#@." fold)]]] [type @@ -42,7 +41,14 @@ (row.equivalence (equivalence.product //index.equivalence //.equivalence)))) -(template: (!add <tag> <=> <value>) +(type: #export (Resource a) + (State' Try Pool a)) + +(def: #export monad + (Monad Resource) + (state.with try.monad)) + +(template: (!add <tag> <equivalence> <value>) (function (_ [next pool]) (with-expansions [<try-again> (as-is (recur (.inc idx)))] (loop [idx 0] @@ -50,9 +56,9 @@ (#.Some entry) (case entry [index (<tag> reference)] - (if (:: <=> = reference <value>) - [[next pool] - index] + (if (:: <equivalence> = reference <value>) + (#try.Success [[next pool] + index]) <try-again>) _ @@ -60,98 +66,27 @@ #.None (let [new (<tag> <value>)] - [[(|> next - //index.number - (//unsigned.u2/+ (//unsigned.u2 (//.size new))) - //index.index) - (row.add [next new] pool)] - next])))))) - -(template: (!raw-index <index>) - (|> <index> //index.number //unsigned.nat)) - -(exception: #export (invalid-index {index (Index Any)}) - (exception.report - ["Index" (|> index !raw-index %.nat)])) - -(exception: #export (invalid-constant {index (Index Any)} - {tag Name}) - (exception.report - ["Index" (|> index !raw-index %.nat)] - ["Expected tag" (%.name tag)])) - -(template: (!fetch <tag> <index>) - (with-expansions [<failure> (as-is [[next pool] (exception.throw ..invalid-index [<index>])])] - (function (_ [next pool]) - (loop [idx 0] - (case (row.nth idx pool) - (#.Some [index entry]) - (let [index' (!raw-index index) - <index>' (!raw-index <index>)] - (cond (n.< index' <index>') - (recur (inc idx)) - - (n.= index' <index>') - (case entry - (<tag> value) - [[next pool] (#try.Success value)] - - _ - [[next pool] (exception.throw ..invalid-constant [<index> (name-of <tag>)])]) - - ## (n.> index' <index>') - <failure>)) - - #.None - <failure>)) - ))) - -(exception: #export (cannot-find {tag Name} {value Text}) - (exception.report - ["Expected tag" (%.name tag)] - ["Value" value])) - -(template: (!find <tag> <=> <%> <expected>) - (function (_ [next pool]) - (with-expansions [<try-again> (as-is (recur (.inc idx)))] - (loop [idx 0] - (case (row.nth idx pool) - (#.Some [index entry]) - (case entry - (<tag> actual) - (if (:: <=> = actual <expected>) - [[next pool] - (#try.Success index)] - <try-again>) - - _ - <try-again>) - - #.None - [[next pool] - (exception.throw ..cannot-find [(name-of <tag>) (<%> <expected>)])]))))) + (do try.monad + [@new (//unsigned.u2 (//.size new)) + next (: (Try Index) + (|> next + //index.value + (//unsigned.+/2 @new) + (:: @ map //index.index)))] + (wrap [[next + (row.add [next new] pool)] + next])))))))) + +(template: (!index <index>) + (|> <index> //index.value //unsigned.value)) (type: (Adder of) - (-> of (State Pool (Index of)))) - -(type: (Fetcher of) - (-> (Index of) (State Pool (Try of)))) - -(type: (Finder of) - (-> of (State Pool (Try (Index of))))) + (-> of (Resource (Index of)))) (template [<name> <type> <tag> <equivalence> <format>] [(def: #export (<name> value) (Adder <type>) - (!add <tag> <equivalence> value)) - - (`` (def: #export ((~~ (template.identifier ["fetch-" <name>])) index) - (Fetcher <type>) - (!fetch <tag> index))) - - (`` (def: #export ((~~ (template.identifier ["find-" <name>])) reference) - (Finder <type>) - (!find <tag> <equivalence> <format> reference)))] + (!add <tag> <equivalence> value))] [integer Integer #//.Integer (//.value-equivalence i32.equivalence) (|>> //.value .nat %.nat)] [float Float #//.Float (//.value-equivalence //.float-equivalence) (|>> //.value host.float-to-double (:coerce Frac) %.frac)] @@ -161,15 +96,15 @@ ) (def: #export (string value) - (-> Text (State Pool (Index String))) - (do state.monad + (-> Text (Resource (Index String))) + (do ..monad [@value (utf8 value) #let [value (//.string @value)]] (!add #//.String (//.value-equivalence //index.equivalence) value))) (def: #export (class name) - (-> Internal (State Pool (Index Class))) - (do state.monad + (-> Internal (Resource (Index Class))) + (do ..monad [@name (utf8 (//name.read name)) #let [value (//.class @name)]] (!add #//.Class //.class-equivalence value))) @@ -177,7 +112,7 @@ (def: #export (descriptor value) (All [kind] (-> (Descriptor kind) - (State Pool (Index (Descriptor kind))))) + (Resource (Index (Descriptor kind))))) (let [value (//descriptor.descriptor value)] (!add #//.UTF8 text.equivalence value))) @@ -187,8 +122,8 @@ (def: #export (name-and-type [name descriptor]) (All [of] - (-> (Member of) (State Pool (Index (Name-And-Type of))))) - (do state.monad + (-> (Member of) (Resource (Index (Name-And-Type of))))) + (do ..monad [@name (utf8 name) @descriptor (..descriptor descriptor)] (!add #//.Name-And-Type //.name-and-type-equivalence @@ -197,8 +132,8 @@ (template [<name> <tag> <of>] [(def: #export (<name> class member) - (-> External (Member <of>) (State Pool (Index (Reference <of>)))) - (do state.monad + (-> External (Member <of>) (Resource (Index (Reference <of>)))) + (do ..monad [@class (..class (//name.internal class)) @name-and-type (name-and-type member)] (!add <tag> //.reference-equivalence @@ -215,10 +150,10 @@ (function (_ [next pool]) (row@fold (function (_ [_index post] pre) (specification@compose pre (//.writer post))) - (binaryF.bits/16 (!raw-index next)) + (format.bits/16 (!index next)) pool))) (def: #export empty Pool - [(|> 1 //unsigned.u2 //index.index) + [(|> 1 //unsigned.u2 try.assume //index.index) row.empty]) diff --git a/stdlib/source/lux/target/jvm/constant/tag.lux b/stdlib/source/lux/target/jvm/constant/tag.lux index a3da84812..1771bfd19 100644 --- a/stdlib/source/lux/target/jvm/constant/tag.lux +++ b/stdlib/source/lux/target/jvm/constant/tag.lux @@ -2,14 +2,16 @@ [lux #* [abstract [equivalence (#+ Equivalence)]] + [control + ["." try]] [data [format [binary (#+ Writer)]]] [type abstract]] - [/// + ["." /// #_ [encoding - ["." unsigned (#+ U1) ("u1@." equivalence)]]]) + ["#." unsigned (#+ U1) ("u1@." equivalence)]]]) (abstract: #export Tag {} @@ -25,7 +27,7 @@ (template [<code> <name>] [(def: #export <name> Tag - (:abstraction (unsigned.u1 <code>)))] + (|> <code> ///unsigned.u1 try.assume :abstraction))] [01 utf8] [03 integer] @@ -45,5 +47,5 @@ (def: #export writer (Writer Tag) - (|>> :representation unsigned.u1-writer)) + (|>> :representation ///unsigned.writer/1)) ) diff --git a/stdlib/source/lux/target/jvm/encoding/signed.lux b/stdlib/source/lux/target/jvm/encoding/signed.lux index 3609142a3..8455d2dba 100644 --- a/stdlib/source/lux/target/jvm/encoding/signed.lux +++ b/stdlib/source/lux/target/jvm/encoding/signed.lux @@ -3,13 +3,18 @@ [abstract [equivalence (#+ Equivalence)] [order (#+ Order)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] [data [number ["." i64] ["n" nat] ["i" int]] - [format - [".F" binary (#+ Writer)]]] + [text + ["%" format (#+ format)]] + ["." format #_ + ["#" binary (#+ Writer)]]] [macro ["." template]] [type @@ -19,7 +24,7 @@ {} Int - (def: #export int + (def: #export value (-> (Signed Any) Int) (|>> :representation)) @@ -35,42 +40,67 @@ (def: (< reference sample) (i.< (:representation reference) (:representation sample)))) - (template [<bytes> <name> <size> <constructor> <max> <+>] + (exception: #export (value-exceeds-the-scope {value Int} + {scope Nat}) + (exception.report + ["Value" (%.int value)] + ["Scope (in bytes)" (%.nat scope)])) + + (template [<bytes> <name> <size> <constructor> <maximum> <+> <->] [(with-expansions [<raw> (template.identifier [<name> "'"])] (abstract: #export <raw> {} Any) (type: #export <name> (Signed <raw>))) - (def: #export <size> Nat <bytes>) + (def: #export <size> <bytes>) - (def: #export <max> + (def: #export <maximum> <name> (|> <bytes> (n.* i64.bits-per-byte) dec i64.mask :abstraction)) (def: #export <constructor> - (-> Int <name>) - (let [limit (|> <bytes> (n.* i64.bits-per-byte) i64.mask .nat)] - (|>> (i64.and limit) :abstraction))) + (-> Int (Try <name>)) + (let [positive (|> <bytes> (n.* i64.bits-per-byte) i64.mask .nat) + negative (|> positive (i64.arithmetic-right-shift 1) i64.not)] + (function (_ value) + (if (i.= (if (i.< +0 value) + (i64.or negative value) + (i64.and positive value)) + value) + (#try.Success (:abstraction value)) + (exception.throw ..value-exceeds-the-scope [value <size>]))))) + + (template [<abstract-operation> <concrete-operation>] + [(def: #export (<abstract-operation> parameter subject) + (-> <name> <name> (Try <name>)) + (<constructor> + (<concrete-operation> (:representation parameter) + (:representation subject))))] - (def: #export (<+> parameter subject) - (-> <name> <name> <name>) - (let [limit (|> <bytes> (n.* i64.bits-per-byte) i64.mask .nat)] - (:abstraction - (i64.and limit - (i.+ (:representation parameter) - (:representation subject))))))] + [<+> i.+] + [<-> i.-] + )] - [1 S1 s1-bytes s1 max-s1 s1/+] - [2 S2 s2-bytes s2 max-s2 s2/+] - [4 S4 s4-bytes s4 max-s4 s4/+] + [1 S1 bytes/1 s1 maximum/1 +/1 -/1] + [2 S2 bytes/2 s2 maximum/2 +/2 -/2] + [4 S4 bytes/4 s4 maximum/4 +/4 -/4] ) - ) -(template [<writer-name> <type> <writer>] - [(def: #export <writer-name> - (Writer <type>) - (|>> ..int <writer>))] + (template [<name> <from> <to>] + [(def: #export <name> + (-> <from> <to>) + (|>> :transmutation))] - [s1-writer S1 binaryF.bits/8] - [s2-writer S2 binaryF.bits/16] - [s4-writer S4 binaryF.bits/32] + [lift/2 S1 S2] + [lift/4 S2 S4] + ) + + (template [<writer-name> <type> <writer>] + [(def: #export <writer-name> + (Writer <type>) + (|>> :representation <writer>))] + + [writer/1 S1 format.bits/8] + [writer/2 S2 format.bits/16] + [writer/4 S4 format.bits/32] + ) ) diff --git a/stdlib/source/lux/target/jvm/encoding/unsigned.lux b/stdlib/source/lux/target/jvm/encoding/unsigned.lux index 56885d576..4286976dc 100644 --- a/stdlib/source/lux/target/jvm/encoding/unsigned.lux +++ b/stdlib/source/lux/target/jvm/encoding/unsigned.lux @@ -3,12 +3,17 @@ [abstract [equivalence (#+ Equivalence)] [order (#+ Order)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] [data [number ["." i64] ["n" nat]] - [format - [".F" binary (#+ Writer)]]] + [text + ["%" format (#+ format)]] + ["." format #_ + ["#" binary (#+ Writer)]]] [macro ["." template]] [type @@ -18,56 +23,94 @@ {} Nat - (def: #export nat + (def: #export value (-> (Unsigned Any) Nat) (|>> :representation)) (structure: #export equivalence (All [brand] (Equivalence (Unsigned brand))) (def: (= reference sample) - (n.= (:representation reference) (:representation sample)))) + (n.= (:representation reference) + (:representation sample)))) (structure: #export order (All [brand] (Order (Unsigned brand))) (def: &equivalence ..equivalence) (def: (< reference sample) - (n.< (:representation reference) (:representation sample)))) + (n.< (:representation reference) + (:representation sample)))) - (template [<bytes> <name> <size> <constructor> <max> <+>] + (exception: #export (value-exceeds-the-maximum {value Nat} + {maximum (Unsigned Any)}) + (exception.report + ["Value" (%.nat value)] + ["Maximum" (%.nat (:representation maximum))])) + + (exception: #export [brand] (subtraction-cannot-yield-negative-value + {parameter (Unsigned brand)} + {subject (Unsigned brand)}) + (exception.report + ["Parameter" (%.nat (:representation parameter))] + ["Subject" (%.nat (:representation subject))])) + + (template [<bytes> <name> <size> <constructor> <maximum> <+> <-> <max>] [(with-expansions [<raw> (template.identifier [<name> "'"])] (abstract: #export <raw> {} Any) (type: #export <name> (Unsigned <raw>))) - (def: #export <size> Nat <bytes>) + (def: #export <size> <bytes>) - (def: #export <max> + (def: #export <maximum> <name> (|> <bytes> (n.* i64.bits-per-byte) i64.mask :abstraction)) - (def: #export <constructor> - (-> Nat <name>) - (|>> (i64.and (:representation <max>)) :abstraction)) + (def: #export (<constructor> value) + (-> Nat (Try <name>)) + (if (n.<= (:representation <maximum>) value) + (#try.Success (:abstraction value)) + (exception.throw ..value-exceeds-the-maximum [value <maximum>]))) (def: #export (<+> parameter subject) + (-> <name> <name> (Try <name>)) + (<constructor> + (n.+ (:representation parameter) + (:representation subject)))) + + (def: #export (<-> parameter subject) + (-> <name> <name> (Try <name>)) + (let [parameter' (:representation parameter) + subject' (:representation subject)] + (if (n.<= subject' parameter') + (#try.Success (:abstraction (n.- parameter' subject'))) + (exception.throw ..subtraction-cannot-yield-negative-value [parameter subject])))) + + (def: #export (<max> left right) (-> <name> <name> <name>) - (:abstraction - (i64.and (:representation <max>) - (n.+ (:representation parameter) - (:representation subject)))))] - - [1 U1 u1-bytes u1 max-u1 u1/+] - [2 U2 u2-bytes u2 max-u2 u2/+] - [4 U4 u4-bytes u4 max-u4 u4/+] + (:abstraction (n.max (:representation left) + (:representation right))))] + + [1 U1 bytes/1 u1 maximum/1 +/1 -/1 max/1] + [2 U2 bytes/2 u2 maximum/2 +/2 -/2 max/2] + [4 U4 bytes/4 u4 maximum/4 +/4 -/4 max/4] ) - ) -(template [<writer-name> <type> <writer>] - [(def: #export <writer-name> - (Writer <type>) - (|>> ..nat <writer>))] + (template [<name> <from> <to>] + [(def: #export <name> + (-> <from> <to>) + (|>> :transmutation))] + + [lift/2 U1 U2] + [lift/4 U2 U4] + ) - [u1-writer U1 binaryF.bits/8] - [u2-writer U2 binaryF.bits/16] - [u4-writer U4 binaryF.bits/32] + (template [<writer-name> <type> <writer>] + [(def: #export <writer-name> + (Writer <type>) + (|>> :representation <writer>))] + + [writer/1 U1 format.bits/8] + [writer/2 U2 format.bits/16] + [writer/4 U4 format.bits/32] + ) ) diff --git a/stdlib/source/lux/target/jvm/field.lux b/stdlib/source/lux/target/jvm/field.lux index 1e7edac35..8541076f7 100644 --- a/stdlib/source/lux/target/jvm/field.lux +++ b/stdlib/source/lux/target/jvm/field.lux @@ -4,8 +4,6 @@ [monoid (#+)] ["." equivalence (#+ Equivalence)] ["." monad (#+ do)]] - [control - ["." state (#+ State)]] [data [number (#+) [i64 (#+)]] @@ -18,7 +16,7 @@ ["." // #_ ["." modifier (#+ Modifier modifiers:)] ["#." constant (#+ UTF8) - ["#/." pool (#+ Pool)]] + ["#/." pool (#+ Pool Resource)]] ["#." index (#+ Index)] ["#." attribute (#+ Attribute)] ["#." type (#+ Type) @@ -65,8 +63,8 @@ (def: #export (field modifier name type attributes) (-> (Modifier Field) UTF8 (Type Value) (Row Attribute) - (State Pool Field)) - (do state.monad + (Resource Field)) + (do //constant/pool.monad [@name (//constant/pool.utf8 name) @descriptor (//constant/pool.descriptor (//type.descriptor type))] (wrap {#modifier modifier diff --git a/stdlib/source/lux/target/jvm/index.lux b/stdlib/source/lux/target/jvm/index.lux index 430276f4b..490667436 100644 --- a/stdlib/source/lux/target/jvm/index.lux +++ b/stdlib/source/lux/target/jvm/index.lux @@ -11,6 +11,9 @@ [encoding ["#." unsigned (#+ U2)]]]) +(def: #export length + //unsigned.bytes/2) + (abstract: #export (Index kind) {} @@ -20,17 +23,17 @@ (All [kind] (-> U2 (Index kind))) (|>> :abstraction)) - (def: #export number + (def: #export value (-> (Index Any) U2) (|>> :representation)) (def: #export equivalence (All [kind] (Equivalence (Index kind))) (:: equivalence.contravariant map-1 - ..number + ..value //unsigned.equivalence)) (def: #export writer (All [kind] (Writer (Index kind))) - (|>> ..number //unsigned.u2-writer)) + (|>> :representation //unsigned.writer/2)) ) diff --git a/stdlib/source/lux/target/jvm/instruction/address.lux b/stdlib/source/lux/target/jvm/instruction/address.lux deleted file mode 100644 index 1be4460b2..000000000 --- a/stdlib/source/lux/target/jvm/instruction/address.lux +++ /dev/null @@ -1,31 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)]] - [data - [format - [binary (#+ Writer)]]] - [type - abstract]] - ["." /// #_ - [encoding - ["#." unsigned (#+ U2)]]]) - -(abstract: #export Address - {} - - U2 - - (def: #export address - (-> U2 Address) - (|>> :abstraction)) - - (structure: #export equivalence - (Equivalence Address) - (def: (= reference subject) - (:: ///unsigned.equivalence = (:representation reference) (:representation subject)))) - - (def: #export writer - (Writer Address) - (|>> :representation ///unsigned.u2-writer)) - ) diff --git a/stdlib/source/lux/target/jvm/instruction/condition.lux b/stdlib/source/lux/target/jvm/instruction/condition.lux deleted file mode 100644 index 50061b579..000000000 --- a/stdlib/source/lux/target/jvm/instruction/condition.lux +++ /dev/null @@ -1,83 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)] - [monoid (#+ Monoid)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." binary] - [number (#+ hex) - ["n" nat]] - [text - ["%" format (#+ format)]] - [format - [".F" binary (#+ Mutation Specification)]]]] - ["." // #_ - ["#." resources (#+ Resources)] - ["/#" // #_ - [encoding - ["#." unsigned (#+ U1 U2)]]]]) - -(type: #export Stack U2) - -(type: #export Environment - {#resources Resources - #stack Stack}) - -(def: #export start - Environment - {#resources //resources.start - #stack (///unsigned.u2 0)}) - -(type: #export Condition - (-> Environment (Try Environment))) - -(structure: #export monoid - (Monoid Condition) - - (def: identity (|>> #try.Success)) - - (def: (compose left right) - (function (_ environment) - (do try.monad - [environment (left environment)] - (right environment))))) - -(def: #export (produces amount env) - (-> Nat Condition) - (let [stack (n.+ amount - (///unsigned.nat (get@ #stack env))) - max-stack (n.max stack - (///unsigned.nat (get@ [#resources #//resources.max-stack] env)))] - (|> env - (set@ #stack (///unsigned.u2 stack)) - (set@ [#resources #//resources.max-stack] (///unsigned.u2 max-stack)) - #try.Success))) - -(exception: #export (cannot-pop-stack {stack-size Nat} - {wanted-pops Nat}) - (exception.report - ["Stack Size" (%.nat stack-size)] - ["Wanted Pops" (%.nat wanted-pops)])) - -(def: #export (consumes wanted-pops env) - (-> Nat Condition) - (let [stack-size (///unsigned.nat (get@ #stack env))] - (if (n.<= stack-size wanted-pops) - (#try.Success (update@ #stack - (|>> ///unsigned.nat (n.- wanted-pops) ///unsigned.u2) - env)) - (exception.throw ..cannot-pop-stack [stack-size wanted-pops])))) - -(type: #export Local U1) - -(def: #export (has-local local environment) - (-> Local Condition) - (let [max-locals (n.max (///unsigned.nat (get@ [#resources #//resources.max-locals] environment)) - (///unsigned.nat local))] - (|> environment - (set@ [#resources #//resources.max-locals] - (///unsigned.u2 max-locals)) - #try.Success))) diff --git a/stdlib/source/lux/target/jvm/instruction/resources.lux b/stdlib/source/lux/target/jvm/instruction/resources.lux deleted file mode 100644 index c7d741a1d..000000000 --- a/stdlib/source/lux/target/jvm/instruction/resources.lux +++ /dev/null @@ -1,46 +0,0 @@ -(.module: - [lux #* - [abstract - ["." equivalence (#+ Equivalence)]] - [data - [number - ["n" nat]] - [format - [".F" binary (#+ Writer) ("#@." monoid)]]]] - ["." /// #_ - [encoding - ["#." unsigned (#+ U2)]]]) - -(type: #export Resources - {#max-stack U2 - #max-locals U2}) - -(def: #export start - Resources - {#max-stack (///unsigned.u2 0) - #max-locals (///unsigned.u2 0)}) - -(def: #export length - ($_ n.+ - ## u2 max_stack; - ///unsigned.u2-bytes - ## u2 max_locals; - ///unsigned.u2-bytes)) - -(def: #export equivalence - (Equivalence Resources) - ($_ equivalence.product - ## u2 max_stack; - ///unsigned.equivalence - ## u2 max_locals; - ///unsigned.equivalence - )) - -(def: #export (writer resources) - (Writer Resources) - ($_ binaryF@compose - ## u2 max_stack; - (///unsigned.u2-writer (get@ #max-stack resources)) - ## u2 max_locals; - (///unsigned.u2-writer (get@ #max-locals resources)) - )) diff --git a/stdlib/source/lux/target/jvm/magic.lux b/stdlib/source/lux/target/jvm/magic.lux index ff2d119e4..408de3d84 100644 --- a/stdlib/source/lux/target/jvm/magic.lux +++ b/stdlib/source/lux/target/jvm/magic.lux @@ -1,5 +1,7 @@ (.module: [lux #* + [control + ["." try]] [data [number (#+ hex)]]] ["." // #_ @@ -11,7 +13,7 @@ (def: #export code Magic - (//unsigned.u4 (hex "CAFEBABE"))) + (|> (hex "CAFEBABE") //unsigned.u4 try.assume)) (def: #export writer - //unsigned.u4-writer) + //unsigned.writer/4) diff --git a/stdlib/source/lux/target/jvm/method.lux b/stdlib/source/lux/target/jvm/method.lux index af2d07de7..060ad1bc1 100644 --- a/stdlib/source/lux/target/jvm/method.lux +++ b/stdlib/source/lux/target/jvm/method.lux @@ -5,13 +5,12 @@ ["." equivalence (#+ Equivalence)] ["." monad (#+ do)]] [control - ["." try] - ["." state (#+ State)]] + ["." try]] [data [number (#+) [i64 (#+)]] - [format - [".F" binary (#+ Writer) ("#@." monoid)]] + ["." format #_ + ["#" binary (#+ Writer) ("#@." monoid)]] [collection ["." row (#+ Row)]]] [type @@ -22,10 +21,10 @@ ["#." attribute (#+ Attribute) ["#/." code]] ["#." constant (#+ UTF8) - ["#/." pool (#+ Pool)]] - ["#." instruction (#+ Instruction) - ["#/." condition] - ["#/." bytecode]] + ["#/." pool (#+ Pool Resource)]] + ["#." bytecode (#+ Bytecode) + ["#/." environment] + ["#/." instruction]] ["#." type (#+ Type) ["#/." category] ["#." descriptor (#+ Descriptor)]]]) @@ -52,25 +51,15 @@ ) (def: #export (method modifier name type attributes code) - (-> (Modifier Method) UTF8 (Type //type/category.Method) (List (State Pool Attribute)) (Instruction Any) - (State Pool Method)) - (do state.monad + (-> (Modifier Method) UTF8 (Type //type/category.Method) (List (Resource Attribute)) (Bytecode Any) + (Resource Method)) + (do //constant/pool.monad [@name (//constant/pool.utf8 name) @descriptor (//constant/pool.descriptor (//type.descriptor type)) attributes (monad.seq @ attributes) - ?code (//instruction.resolve code) - [environment exceptions bytecode] (case (do try.monad - [[bytecode exceptions output] ?code - [environment specification] (//instruction/bytecode.run bytecode)] - (wrap [environment exceptions (binaryF.instance specification)])) - (#try.Success [environment exceptions bytecode]) - (wrap [environment exceptions bytecode]) - - (#try.Failure error) - ## TODO: Allow error-management within - ## the monad. - (error! error)) - @code (//attribute.code {#//attribute/code.resources (get@ #//instruction/condition.resources environment) + [environment exceptions instruction output] (//bytecode.resolve code) + #let [bytecode (|> instruction //bytecode/instruction.run format.instance)] + @code (//attribute.code {#//attribute/code.limit (get@ #//bytecode/environment.limit environment) #//attribute/code.code bytecode #//attribute/code.exception-table exceptions #//attribute/code.attributes (row.row)})] @@ -89,12 +78,12 @@ (def: #export (writer field) (Writer Method) - (`` ($_ binaryF@compose + (`` ($_ format@compose (~~ (template [<writer> <slot>] [(<writer> (get@ <slot> field))] [//modifier.writer #modifier] [//index.writer #name] [//index.writer #descriptor] - [(binaryF.row/16 //attribute.writer) #attributes])) + [(format.row/16 //attribute.writer) #attributes])) ))) diff --git a/stdlib/source/lux/target/jvm/modifier.lux b/stdlib/source/lux/target/jvm/modifier.lux index f7024b669..3eafb170a 100644 --- a/stdlib/source/lux/target/jvm/modifier.lux +++ b/stdlib/source/lux/target/jvm/modifier.lux @@ -4,6 +4,7 @@ ["." equivalence (#+ Equivalence)] ["." monoid (#+ Monoid)]] [control + ["." try] ["<>" parser ["<c>" code]]] [data @@ -29,12 +30,13 @@ (template: (!wrap value) (|> value //unsigned.u2 + try.assume :abstraction)) (template: (!unwrap value) (|> value :representation - //unsigned.nat)) + //unsigned.value)) (def: #export code (-> (Modifier Any) //unsigned.U2) @@ -66,7 +68,7 @@ (def: #export writer (All [of] (Writer (Modifier of))) - (|>> :representation //unsigned.u2-writer)) + (|>> :representation //unsigned.writer/2)) ) (syntax: #export (modifiers: ofT {options (<>.many <c>.any)}) diff --git a/stdlib/source/lux/target/jvm/version.lux b/stdlib/source/lux/target/jvm/version.lux index 48d2dcaa9..8d5e40111 100644 --- a/stdlib/source/lux/target/jvm/version.lux +++ b/stdlib/source/lux/target/jvm/version.lux @@ -1,5 +1,7 @@ (.module: - [lux #*] + [lux #* + [control + ["." try]]] ["." // #_ [encoding ["#." unsigned (#+ U2)]]]) @@ -8,12 +10,14 @@ (type: #export Minor Version) (type: #export Major Version) -(def: #export default-minor Minor (//unsigned.u2 0)) +(def: #export default-minor + Minor + (|> 0 //unsigned.u2 try.assume)) (template [<number> <name>] [(def: #export <name> Major - (//unsigned.u2 <number>))] + (|> <number> //unsigned.u2 try.assume))] [45 v1_1] [46 v1_2] @@ -30,4 +34,4 @@ ) (def: #export writer - //unsigned.u2-writer) + //unsigned.writer/2) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux index a56629158..e583b36b7 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux @@ -11,7 +11,7 @@ [target [jvm ["." constant] - ["_" instruction (#+ Label Instruction) ("#@." monad)] + ["_" bytecode (#+ Label Bytecode) ("#@." monad)] ["." type (#+ Type) [category (#+ Method)]] [encoding @@ -33,7 +33,7 @@ (type.method [(list //type.value) type.boolean (list)])) (def: (pop-alt stack-depth) - (-> Nat (Instruction Any)) + (-> Nat (Bytecode Any)) (.case stack-depth 0 (_@wrap []) 1 _.pop @@ -44,31 +44,31 @@ (pop-alt (n.- 2 stack-depth))))) (def: ldc/integer - (-> (I64 Any) (Instruction Any)) + (-> (I64 Any) (Bytecode Any)) (|>> .i64 i32.i32 constant.integer _.ldc/integer)) (def: ldc/long - (-> (I64 Any) (Instruction Any)) + (-> (I64 Any) (Bytecode Any)) (|>> .int constant.long _.ldc/long)) (def: ldc/double - (-> Frac (Instruction Any)) + (-> Frac (Bytecode Any)) (|>> constant.double _.ldc/double)) (def: peek - (Instruction Any) + (Bytecode Any) ($_ _.compose _.dup (//runtime.get //runtime.stack-head))) (def: pop - (Instruction Any) + (Bytecode Any) ($_ _.compose (//runtime.get //runtime.stack-tail) (_.checkcast //type.stack))) (def: (path' phase stack-depth @else @end path) - (-> Phase Nat Label Label Path (Operation (Instruction Any))) + (-> Phase Nat Label Label Path (Operation (Bytecode Any))) (.case path #synthesis.Pop (operation@wrap ..pop) @@ -214,7 +214,7 @@ )) (def: (path phase path @end) - (-> Phase Path Label (Operation (Instruction Any))) + (-> Phase Path Label (Operation (Bytecode Any))) (do phase.monad [@else //runtime.forge-label pathG (..path' phase 1 @else @end path)] @@ -227,7 +227,7 @@ (_.goto @end))))) (def: #export (if phase conditionS thenS elseS) - (-> Phase Synthesis Synthesis Synthesis (Operation (Instruction Any))) + (-> Phase Synthesis Synthesis Synthesis (Operation (Bytecode Any))) (do phase.monad [conditionG (phase conditionS) thenG (phase thenS) @@ -246,7 +246,7 @@ (_.set-label @end)))))) (def: #export (let phase inputS register bodyS) - (-> Phase Synthesis Register Synthesis (Operation (Instruction Any))) + (-> Phase Synthesis Register Synthesis (Operation (Bytecode Any))) (do phase.monad [inputG (phase inputS) bodyG (phase bodyS)] @@ -256,7 +256,7 @@ bodyG)))) (def: #export (case phase valueS path) - (-> Phase Synthesis Path (Operation (Instruction Any))) + (-> Phase Synthesis Path (Operation (Bytecode Any))) (do phase.monad [@end //runtime.forge-label valueG (phase valueS) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/common.lux index d8ac81cc4..1fba35532 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/common.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/common.lux @@ -5,9 +5,9 @@ ["." monad (#+ do)]] [control ["." try] + ["." exception (#+ exception:)] ["<>" parser - ["<s>" synthesis (#+ Parser)]] - ["." exception (#+ exception:)]] + ["<s>" synthesis (#+ Parser)]]] [data ["." product] [number @@ -18,7 +18,7 @@ ["." dictionary]]] [target [jvm - ["_" instruction (#+ Label Instruction) ("#@." monad)] + ["_" bytecode (#+ Label Bytecode) ("#@." monad)] ["." constant] [encoding ["." signed (#+ S4)]] @@ -42,7 +42,7 @@ (def: #export (custom [parser handler]) (All [s] (-> [(Parser s) - (-> Text Phase s (Operation (Instruction Any)))] + (-> Text Phase s (Operation (Bytecode Any)))] Handler)) (function (_ extension-name phase input) (case (<s>.run parser input) @@ -63,29 +63,29 @@ (def: $Error (type.class "java.lang.Error" (list))) (def: lux-int - (Instruction Any) + (Bytecode Any) ($_ _.compose _.i2l (///value.wrap type.long))) (def: jvm-int - (Instruction Any) + (Bytecode Any) ($_ _.compose (///value.unwrap type.long) _.l2i)) (def: ensure-string - (Instruction Any) + (Bytecode Any) (_.checkcast $String)) -(def: (predicate instruction) - (-> (-> Label (Instruction Any)) - (Instruction Any)) +(def: (predicate bytecode) + (-> (-> Label (Bytecode Any)) + (Bytecode Any)) (do _.monad [@then _.new-label @end _.new-label] ($_ _.compose - (instruction @then) + (bytecode @then) (_.getstatic $Boolean "FALSE" $Boolean) (_.goto @end) (_.set-label @then) @@ -107,7 +107,7 @@ inputG (phase inputS) elseG (phase elseS) conditionalsG+ (: (Operation (List [(List [S4 Label]) - (Instruction Any)])) + (Bytecode Any)])) (monad.map @ (function (_ [chars branch]) (do @ [branchG (phase branch) @@ -138,14 +138,14 @@ )))))])) (def: (lux::is [referenceG sampleG]) - (Binary (Instruction Any)) + (Binary (Bytecode Any)) ($_ _.compose referenceG sampleG (..predicate _.if-acmpeq))) (def: (lux::try riskyG) - (Unary (Instruction Any)) + (Unary (Bytecode Any)) ($_ _.compose riskyG (_.checkcast ///function.class) @@ -160,7 +160,7 @@ (template [<name> <op>] [(def: (<name> [maskG inputG]) - (Binary (Instruction Any)) + (Binary (Bytecode Any)) ($_ _.compose inputG (///value.unwrap type.long) maskG (///value.unwrap type.long) @@ -173,7 +173,7 @@ (template [<name> <op>] [(def: (<name> [shiftG inputG]) - (Binary (Instruction Any)) + (Binary (Bytecode Any)) ($_ _.compose inputG (///value.unwrap type.long) shiftG ..jvm-int @@ -190,7 +190,7 @@ (template [<name> <const>] [(def: (<name> _) - (Nullary (Instruction Any)) + (Nullary (Bytecode Any)) ($_ _.compose (_.ldc/double (constant.double <const>)) (///value.wrap type.double)))] @@ -202,7 +202,7 @@ (template [<name> <type> <op>] [(def: (<name> [paramG subjectG]) - (Binary (Instruction Any)) + (Binary (Bytecode Any)) ($_ _.compose subjectG (///value.unwrap <type>) paramG (///value.unwrap <type>) @@ -224,7 +224,7 @@ (template [<eq> <lt> <type> <cmp>] [(template [<name> <reference>] [(def: (<name> [paramG subjectG]) - (Binary (Instruction Any)) + (Binary (Bytecode Any)) ($_ _.compose subjectG (///value.unwrap <type>) paramG (///value.unwrap <type>) @@ -240,12 +240,12 @@ ) (def: (to-string class from) - (-> (Type Class) (Type Primitive) (Instruction Any)) + (-> (Type Class) (Type Primitive) (Bytecode Any)) (_.invokestatic class "toString" (type.method [(list from) ..$String (list)]))) (template [<name> <prepare> <transform>] [(def: (<name> inputG) - (Unary (Instruction Any)) + (Unary (Bytecode Any)) ($_ _.compose inputG <prepare> @@ -318,18 +318,18 @@ (/////bundle.install "decode" (unary ..f64::decode))))) (def: (text::size inputG) - (Unary (Instruction Any)) + (Unary (Bytecode Any)) ($_ _.compose inputG ..ensure-string (_.invokevirtual ..$String "length" (type.method [(list) type.int (list)])) ..lux-int)) -(def: no-op (Instruction Any) (_@wrap [])) +(def: no-op (Bytecode Any) (_@wrap [])) (template [<name> <pre-subject> <pre-param> <op> <post>] [(def: (<name> [paramG subjectG]) - (Binary (Instruction Any)) + (Binary (Bytecode Any)) ($_ _.compose subjectG <pre-subject> paramG <pre-param> @@ -347,14 +347,14 @@ ) (def: (text::concat [leftG rightG]) - (Binary (Instruction Any)) + (Binary (Bytecode Any)) ($_ _.compose leftG ..ensure-string rightG ..ensure-string (_.invokevirtual ..$String "concat" (type.method [(list ..$String) ..$String (list)])))) (def: (text::clip [startG endG subjectG]) - (Trinary (Instruction Any)) + (Trinary (Bytecode Any)) ($_ _.compose subjectG ..ensure-string startG ..jvm-int @@ -363,7 +363,7 @@ (def: index-method (type.method [(list ..$String type.int) type.int (list)])) (def: (text::index [startG partG textG]) - (Trinary (Instruction Any)) + (Trinary (Bytecode Any)) (do _.monad [@not-found _.new-label @end _.new-label] @@ -397,7 +397,7 @@ (def: string-method (type.method [(list ..$String) type.void (list)])) (def: (io::log messageG) - (Unary (Instruction Any)) + (Unary (Bytecode Any)) ($_ _.compose (_.getstatic ..$System "out" ..$PrintStream) messageG @@ -406,7 +406,7 @@ ///runtime.unit)) (def: (io::error messageG) - (Unary (Instruction Any)) + (Unary (Bytecode Any)) ($_ _.compose (_.new ..$Error) _.dup @@ -417,7 +417,7 @@ (def: exit-method (type.method [(list type.int) type.void (list)])) (def: (io::exit codeG) - (Unary (Instruction Any)) + (Unary (Bytecode Any)) ($_ _.compose codeG ..jvm-int (_.invokestatic ..$System "exit" ..exit-method) @@ -425,7 +425,7 @@ (def: time-method (type.method [(list) type.long (list)])) (def: (io::current-time _) - (Nullary (Instruction Any)) + (Nullary (Bytecode Any)) ($_ _.compose (_.invokestatic ..$System "currentTimeMillis" ..time-method) (///value.wrap type.long))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux index 6a66f78f8..35137a77b 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux @@ -19,7 +19,7 @@ ["." modifier (#+ Modifier) ("#@." monoid)] ["." field (#+ Field)] ["." method (#+ Method)] - ["_" instruction (#+ Label Instruction) ("#@." monad)] + ["_" bytecode (#+ Label Bytecode) ("#@." monad)] ["." class (#+ Class)] ["." type (#+ Type) [category (#+ Return' Value')] @@ -54,10 +54,10 @@ ["." generation]]]]]) (def: #export (with @begin class environment arity body) - (-> Label External Environment Arity (Instruction Any) + (-> Label External Environment Arity (Bytecode Any) (Operation [(List (State Pool Field)) (List (State Pool Method)) - (Instruction Any)])) + (Bytecode Any)])) (let [classT (type.class class (list)) fields (: (List (State Pool Field)) (list& /arity.constant @@ -91,7 +91,7 @@ (|>> type.reflection reflection.reflection name.internal)) (def: #export (abstraction generate [environment arity bodyS]) - (-> Phase Abstraction (Operation (Instruction Any))) + (-> Phase Abstraction (Operation (Bytecode Any))) (do phase.monad [@begin //runtime.forge-label [function-class bodyG] (generation.with-context @@ -111,7 +111,7 @@ (wrap instance))) (def: #export (apply generate [abstractionS inputsS]) - (-> Phase Apply (Operation (Instruction Any))) + (-> Phase Apply (Operation (Bytecode Any))) (do phase.monad [abstractionG (generate abstractionS) inputsG (monad.map @ generate inputsS)] diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant.lux index 456e46b86..dd8144ea8 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant.lux @@ -1,7 +1,5 @@ (.module: [lux (#- Type type) - [control - [state (#+ State)]] [data [collection ["." row]]] @@ -12,7 +10,7 @@ [type (#+ Type) [category (#+ Value)]] [constant - [pool (#+ Pool)]]]]]) + [pool (#+ Resource)]]]]]) (def: modifier (Modifier Field) @@ -23,5 +21,5 @@ )) (def: #export (constant name type) - (-> Text (Type Value) (State Pool Field)) + (-> Text (Type Value) (Resource Field)) (field.field ..modifier name type (row.row))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant/arity.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant/arity.lux index 589d9c43d..d4d1a2a68 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant/arity.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant/arity.lux @@ -1,13 +1,11 @@ (.module: [lux (#- type) - [control - [state (#+ State)]] [target [jvm ["." type] ["." field (#+ Field)] [constant - [pool (#+ Pool)]]]]] + [pool (#+ Resource)]]]]] ["." // [/////// [arity (#+ Arity)]]]) @@ -19,5 +17,5 @@ (def: #export maximum Arity 8) (def: #export constant - (State Pool Field) + (Resource Field) (//.constant ..name ..type)) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/partial/count.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/partial/count.lux index 4806e3ba1..579a63992 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/partial/count.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/partial/count.lux @@ -1,8 +1,10 @@ (.module: [lux (#- type) + [control + ["." try]] [target [jvm - ["_" instruction (#+ Instruction)] + ["_" bytecode (#+ Bytecode)] [encoding [name (#+ External)] ["." unsigned]] @@ -14,14 +16,14 @@ (def: #export type type.int) (def: #export initial - (Instruction Any) - (_.bipush (unsigned.u1 0))) + (Bytecode Any) + (|> 0 unsigned.u1 try.assume _.bipush)) (def: this _.aload-0) (def: #export value - (Instruction Any) + (Bytecode Any) ($_ _.compose ..this (_.getfield /////abstract.class ..field ..type) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/loop.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/loop.lux index 6e7ac6f23..371b900a7 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/loop.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/loop.lux @@ -12,7 +12,7 @@ ["." list ("#@." functor)]]] [target [jvm - ["_" instruction (#+ Label Instruction) ("#@." monad)] + ["_" bytecode (#+ Label Bytecode) ("#@." monad)] [encoding ["." unsigned]]]]] ["." // #_ @@ -37,7 +37,7 @@ (_@wrap [])) (def: #export (recur translate updatesS) - (-> Phase (List Synthesis) (Operation (Instruction Any))) + (-> Phase (List Synthesis) (Operation (Bytecode Any))) (do phase.monad [[@begin offset] generation.anchor updatesG (|> updatesS @@ -71,7 +71,7 @@ (_.goto @begin))))) (def: #export (scope translate [offset initsS+ iterationS]) - (-> Phase [Nat (List Synthesis) Synthesis] (Operation (Instruction Any))) + (-> Phase [Nat (List Synthesis) Synthesis] (Operation (Bytecode Any))) (do phase.monad [@begin //runtime.forge-label initsI+ (monad.map @ translate initsS+) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/primitive.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/primitive.lux index f17b3f2d1..946ea34d5 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/primitive.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/primitive.lux @@ -5,7 +5,7 @@ [target [jvm ["." constant] - ["_" instruction (#+ Instruction)] + ["_" bytecode (#+ Bytecode)] ["." type]]] [macro ["." template]]] @@ -17,12 +17,12 @@ (def: $Double (type.class "java.lang.Double" (list))) (def: #export (bit value) - (-> Bit (Instruction Any)) + (-> Bit (Bytecode Any)) (_.getstatic $Boolean (if value "TRUE" "FALSE") $Boolean)) (template [<name> <inputT> <ldc> <class> <inputD>] [(def: #export (<name> value) - (-> <inputT> (Instruction Any)) + (-> <inputT> (Bytecode Any)) (do _.monad [_ (`` (|> value (~~ (template.splice <ldc>))))] (_.invokestatic <class> "valueOf" (type.method [(list <inputD>) <class> (list)]))))] @@ -31,4 +31,4 @@ [f64 Frac [constant.double _.ldc/double] $Double type.double] ) -(def: #export text _.ldc/string) +(def: #export text _.string) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux index 6c9a963d7..a5c4c3156 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux @@ -12,7 +12,7 @@ ["." generation]]]] [target [jvm - ["_" instruction (#+ Instruction)] + ["_" bytecode (#+ Bytecode)] ["." type] [encoding ["." unsigned]]]]] @@ -22,11 +22,11 @@ ["#." type]]) (def: local - (-> Register (Instruction Any)) + (-> Register (Bytecode Any)) (|>> unsigned.u1 _.aload)) (def: #export this - (Instruction Any) + (Bytecode Any) _.aload-0) (template [<name> <prefix>] @@ -39,7 +39,7 @@ ) (def: (foreign variable) - (-> Register (Operation (Instruction Any))) + (-> Register (Operation (Bytecode Any))) (do phase.monad [function-class generation.context] (wrap ($_ _.compose @@ -49,7 +49,7 @@ //type.value))))) (def: #export (variable variable) - (-> Variable (Operation (Instruction Any))) + (-> Variable (Operation (Bytecode Any))) (case variable (#reference.Local variable) (operation@wrap (..local variable)) @@ -58,7 +58,7 @@ (..foreign variable))) (def: #export (constant name) - (-> Name (Operation (Instruction Any))) + (-> Name (Operation (Bytecode Any))) (do phase.monad [bytecode-name (generation.remember name)] (wrap (_.getstatic (type.class bytecode-name (list)) //value.field //type.value)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux index a47892039..384193d99 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux @@ -3,7 +3,7 @@ [abstract ["." monad (#+ do)]] [control - [state (#+ State)]] + ["." try]] [data [binary (#+ Binary)] [number @@ -13,18 +13,18 @@ [collection ["." list ("#@." functor)] ["." row]] - [format - [".F" binary]]] + ["." format #_ + ["#" binary]]] [target [jvm - ["_" instruction (#+ Label Instruction)] + ["_" bytecode (#+ Label Bytecode)] ["." modifier (#+ Modifier) ("#@." monoid)] ["." field (#+ Field)] ["." method (#+ Method)] ["." version] ["." class (#+ Class)] ["." constant - [pool (#+ Pool)]] + [pool (#+ Resource)]] [encoding ["." unsigned] ["." name]] @@ -57,7 +57,7 @@ (template [<name> <base>] [(type: #export <name> - (<base> Anchor (Instruction Any) Definition))] + (<base> Anchor (Bytecode Any) Definition))] [Operation ///.Operation] [Phase ///.Phase] @@ -66,12 +66,12 @@ ) (type: #export (Generator i) - (-> Phase i (Operation (Instruction Any)))) + (-> Phase i (Operation (Bytecode Any)))) (def: #export class (type.class "LuxRuntime" (list))) (def: procedure - (-> Text (Type category.Method) (Instruction Any)) + (-> Text (Type category.Method) (Bytecode Any)) (_.invokestatic ..class)) (def: modifier @@ -83,28 +83,28 @@ )) (def: local - (-> Nat (Instruction Any)) - (|>> unsigned.u1 _.aload)) + (-> Nat (Bytecode Any)) + (|>> unsigned.u1 try.assume _.aload)) (def: this - (Instruction Any) + (Bytecode Any) _.aload-0) (def: #export (get index) - (-> (Instruction Any) (Instruction Any)) + (-> (Bytecode Any) (Bytecode Any)) ($_ _.compose index _.aaload)) (def: (set! index value) - (-> (Instruction Any) (Instruction Any) (Instruction Any)) + (-> (Bytecode Any) (Bytecode Any) (Bytecode Any)) ($_ _.compose _.dup index value _.aastore)) -(def: #export unit (_.ldc/string synthesis.unit)) +(def: #export unit (_.string synthesis.unit)) (def: variant::name "variant") (def: variant::type (type.method [(list //type.tag //type.flag //type.value) //type.variant (list)])) @@ -137,7 +137,7 @@ (def: #export right-flag ..unit) (def: #export left-injection - (Instruction Any) + (Bytecode Any) ($_ _.compose _.iconst-0 ..left-flag @@ -146,7 +146,7 @@ ..variant)) (def: #export right-injection - (Instruction Any) + (Bytecode Any) ($_ _.compose _.iconst-1 ..right-flag @@ -157,7 +157,7 @@ (def: #export some-injection ..right-injection) (def: #export none-injection - (Instruction Any) + (Bytecode Any) ($_ _.compose _.iconst-0 _.aconst-null @@ -165,7 +165,7 @@ ..variant)) (def: (risky $unsafe) - (-> (Instruction Any) (Instruction Any)) + (-> (Bytecode Any) (Bytecode Any)) (do _.monad [@from _.new-label @to _.new-label @@ -196,31 +196,31 @@ (//value.wrap type.double))))) (def: #export log! - (Instruction Any) + (Bytecode Any) (let [^PrintStream (type.class "java.io.PrintStream" (list)) ^System (type.class "java.lang.System" (list)) out (_.getstatic ^System "out" ^PrintStream) print-type (type.method [(list //type.value) type.void (list)]) print! (function (_ method) (_.invokevirtual ^PrintStream method print-type))] ($_ _.compose - out (_.ldc/string "LOG: ") (print! "print") + out (_.string "LOG: ") (print! "print") out _.swap (print! "println")))) (def: exception-constructor (type.method [(list //type.text) type.void (list)])) (def: (illegal-state-exception message) - (-> Text (Instruction Any)) + (-> Text (Bytecode Any)) (let [^IllegalStateException (type.class "java.lang.IllegalStateException" (list))] ($_ _.compose (_.new ^IllegalStateException) _.dup - (_.ldc/string message) + (_.string message) (_.invokespecial ^IllegalStateException "<init>" ..exception-constructor)))) (def: failure::type (type.method [(list) type.void (list)])) (def: (failure name message) - (-> Text Text (State Pool Method)) + (-> Text Text (Resource Method)) (method.method ..modifier name ..failure::type (list) @@ -295,7 +295,7 @@ $variant ::value (_.checkcast //type.variant) _.astore-0) - recur (: (-> Label (Instruction Any)) + recur (: (-> Label (Bytecode Any)) (function (_ @loop-start) ($_ _.compose update-$tag @@ -352,7 +352,7 @@ (def: #export right-projection (..procedure ..right-projection::name ..projection-type)) (def: projection::method2 - [(State Pool Method) (State Pool Method)] + [(Resource Method) (Resource Method)] (let [$tuple _.aload-0 $tuple::size ($_ _.compose $tuple _.arraylength) @@ -368,7 +368,7 @@ update-$tuple ($_ _.compose $tuple $last-right _.aaload (_.checkcast //type.tuple) _.astore-0) - recur (: (-> Label (Instruction Any)) + recur (: (-> Label (Bytecode Any)) (function (_ @loop) ($_ _.compose update-$lefts @@ -490,16 +490,16 @@ (-> (Type (<| Return' Value' category)) Text)) (|>> type.reflection reflection.reflection)) -(def: #export ^Object (type.class "java.lang.Object" (list))) - (def: translate-runtime (Operation Any) - (let [class (..reflection ..class) + (let [^Object (type.class "java.lang.Object" (list)) + class (..reflection ..class) modifier (: (Modifier Class) ($_ modifier@compose class.public class.final)) - bytecode (<| (binaryF.run class.writer) + bytecode (<| (format.run class.writer) + try.assume (class.class version.v6_0 modifier (name.internal class) @@ -554,7 +554,7 @@ (let [$partials _.iload-1] ($_ _.compose ..this - (_.invokespecial ..^Object "<init>" (type.method [(list) type.void (list)])) + (_.invokespecial ^Object "<init>" (type.method [(list) type.void (list)])) ..this $partials (_.putfield //function.class //function/count.field //function/count.type) @@ -564,16 +564,17 @@ class.public class.abstract)) class (..reflection //function.class) - partial-count (: (State Pool Field) + partial-count (: (Resource Field) (field.field (modifier@compose field.public field.final) //function/count.field //function/count.type (row.row))) - bytecode (<| (binaryF.run class.writer) + bytecode (<| (format.run class.writer) + try.assume (class.class version.v6_0 modifier (name.internal class) - (name.internal (..reflection ..^Object)) (list) + (name.internal (..reflection ^Object)) (list) (list partial-count) (list& <init>::method apply::method+) (row.row)))] @@ -592,5 +593,5 @@ (let [shift (n./ 4 i64.width)] ## This shift is done to avoid the possibility of forged labels ## to be in the range of the labels that are generated automatically - ## during the evaluation of Instruction expressions. + ## during the evaluation of Bytecode expressions. (:: ////.monad map (i64.left-shift shift) ///.next))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/structure.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/structure.lux index b75c646e8..b48711dd0 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/structure.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/structure.lux @@ -10,7 +10,7 @@ [target [jvm ["." constant] - ["_" instruction (#+ Instruction)] + ["_" bytecode (#+ Bytecode)] ["." type]]]] ["." // #_ ["#." runtime (#+ Operation Phase Generator)] @@ -22,7 +22,7 @@ (def: $Object (type.class "java.lang.Object" (list))) -(def: unitG (Instruction Any) (//primitive.text /////synthesis.unit)) +(def: unitG (Bytecode Any) (//primitive.text /////synthesis.unit)) (template: (!integer <value>) (|> <value> .i64 i32.i32 constant.integer)) @@ -54,7 +54,7 @@ (monad.seq @ membersI)))))) (def: (flagG right?) - (-> Bit (Instruction Any)) + (-> Bit (Bytecode Any)) (if right? ..unitG _.aconst-null)) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux index e6deaf205..462c625c9 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux @@ -2,7 +2,7 @@ [lux (#- Type type) [target [jvm - ["_" instruction (#+ Instruction)] + ["_" bytecode (#+ Bytecode)] ["." type (#+ Type) ("#@." equivalence) [category (#+ Primitive)] ["." box]]]]]) @@ -35,13 +35,13 @@ ) (def: #export (wrap type) - (-> (Type Primitive) (Instruction Any)) + (-> (Type Primitive) (Bytecode Any)) (let [wrapper (type.class (primitive-wrapper type) (list))] (_.invokestatic wrapper "valueOf" (type.method [(list type) wrapper (list)])))) (def: #export (unwrap type) - (-> (Type Primitive) (Instruction Any)) + (-> (Type Primitive) (Bytecode Any)) (let [wrapper (type.class (primitive-wrapper type) (list))] ($_ _.compose (_.checkcast wrapper) |