aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/abstract/equivalence.lux4
-rw-r--r--stdlib/source/lux/abstract/monad.lux7
-rw-r--r--stdlib/source/lux/data/format/binary.lux3
-rw-r--r--stdlib/source/lux/target/jvm/attribute.lux27
-rw-r--r--stdlib/source/lux/target/jvm/attribute/code.lux19
-rw-r--r--stdlib/source/lux/target/jvm/attribute/code/exception.lux16
-rw-r--r--stdlib/source/lux/target/jvm/attribute/constant.lux2
-rw-r--r--stdlib/source/lux/target/jvm/bytecode.lux823
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/address.lux68
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/environment.lux63
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/environment/limit.lux42
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux44
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/environment/limit/stack.lux59
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/instruction.lux685
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/jump.lux (renamed from stdlib/source/lux/target/jvm/instruction/jump.lux)4
-rw-r--r--stdlib/source/lux/target/jvm/class.lux54
-rw-r--r--stdlib/source/lux/target/jvm/constant/pool.lux149
-rw-r--r--stdlib/source/lux/target/jvm/constant/tag.lux10
-rw-r--r--stdlib/source/lux/target/jvm/encoding/signed.lux84
-rw-r--r--stdlib/source/lux/target/jvm/encoding/unsigned.lux97
-rw-r--r--stdlib/source/lux/target/jvm/field.lux8
-rw-r--r--stdlib/source/lux/target/jvm/index.lux9
-rw-r--r--stdlib/source/lux/target/jvm/instruction/address.lux31
-rw-r--r--stdlib/source/lux/target/jvm/instruction/condition.lux83
-rw-r--r--stdlib/source/lux/target/jvm/instruction/resources.lux46
-rw-r--r--stdlib/source/lux/target/jvm/magic.lux6
-rw-r--r--stdlib/source/lux/target/jvm/method.lux41
-rw-r--r--stdlib/source/lux/target/jvm/modifier.lux6
-rw-r--r--stdlib/source/lux/target/jvm/version.lux12
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux24
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/common.lux62
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux10
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant.lux6
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant/arity.lux6
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/partial/count.lux10
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/loop.lux6
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/primitive.lux8
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux12
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux71
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/structure.lux6
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux6
41 files changed, 2187 insertions, 542 deletions
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)