aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/lux/tool/compiler/phase
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/lux/tool/compiler/phase')
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux27
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/common.lux22
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux4
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/abstract.lux13
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable.lux4
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/partial/count.lux9
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux14
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux6
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux10
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux9
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux594
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/type.lux22
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux2
13 files changed, 592 insertions, 144 deletions
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 3240288f7..a56629158 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux
@@ -17,6 +17,7 @@
[encoding
["." unsigned]]]]]
["." // #_
+ ["#." type]
["#." runtime (#+ Operation Phase)]
["#." value]
[////
@@ -25,13 +26,11 @@
["." phase ("operation@." monad)
["." generation]]]])
-(def: $Object (type.class "java.lang.Object" (list)))
-
(def: equals-name
"equals")
(def: equals-type
- (type.method [(list //value.type) type.boolean (list)]))
+ (type.method [(list //type.value) type.boolean (list)]))
(def: (pop-alt stack-depth)
(-> Nat (Instruction Any))
@@ -60,15 +59,13 @@
(Instruction Any)
($_ _.compose
_.dup
- (..ldc/integer 0)
- _.aaload))
+ (//runtime.get //runtime.stack-head)))
(def: pop
(Instruction Any)
($_ _.compose
- (..ldc/integer 1)
- _.aaload
- (_.checkcast //runtime.$Stack)))
+ (//runtime.get //runtime.stack-tail)
+ (_.checkcast //type.stack)))
(def: (path' phase stack-depth @else @end path)
(-> Phase Nat Label Label Path (Operation (Instruction Any)))
@@ -108,7 +105,7 @@
(operation@wrap ($_ _.compose
..peek
(_.ldc/string value)
- (_.invokevirtual ..$Object ..equals-name ..equals-type)
+ (_.invokevirtual //type.text ..equals-name ..equals-type)
(_.ifeq @else)))
(#synthesis.Then bodyS)
@@ -127,7 +124,7 @@
@fail _.new-label]
($_ _.compose
..peek
- (_.checkcast //runtime.$Variant)
+ (_.checkcast //type.variant)
(..ldc/integer (<prepare> idx))
<flag>
//runtime.case
@@ -151,7 +148,7 @@
//runtime.left-projection)]
($_ _.compose
..peek
- (_.checkcast //runtime.$Tuple)
+ (_.checkcast //type.tuple)
(..ldc/integer lefts)
optimized-projection
//runtime.push)))
@@ -159,7 +156,7 @@
(^ (synthesis.member/right lefts))
(operation@wrap ($_ _.compose
..peek
- (_.checkcast //runtime.$Tuple)
+ (_.checkcast //type.tuple)
(..ldc/integer lefts)
//runtime.right-projection
//runtime.push))
@@ -172,8 +169,8 @@
[thenG (path' phase stack-depth @else @end thenP)]
(wrap ($_ _.compose
..peek
- (_.checkcast //runtime.$Tuple)
- (..ldc/integer 0)
+ (_.checkcast //type.tuple)
+ _.iconst-0
_.aaload
(_.astore (unsigned.u1 register))
thenG)))
@@ -187,7 +184,7 @@
[then! (path' phase stack-depth @else @end thenP)]
(wrap ($_ _.compose
..peek
- (_.checkcast //runtime.$Tuple)
+ (_.checkcast //type.tuple)
(..ldc/integer lefts)
<projection>
(_.astore (unsigned.u1 register))
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 8759bf2e8..d8ac81cc4 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
@@ -93,8 +93,6 @@
(_.set-label @end)
)))
-(def: unit (_.ldc/string //////synthesis.unit))
-
## TODO: Get rid of this ASAP
(def: lux::syntax-char-case!
(..custom [($_ <>.and
@@ -190,15 +188,11 @@
(#static MIN_VALUE java/lang/Double)
(#static MAX_VALUE java/lang/Double))
-(def: ldc/double
- (-> Frac (Instruction Any))
- (|>> constant.double _.ldc/double))
-
(template [<name> <const>]
[(def: (<name> _)
(Nullary (Instruction Any))
($_ _.compose
- (..ldc/double <const>)
+ (_.ldc/double (constant.double <const>))
(///value.wrap type.double)))]
[f64::smallest (java/lang/Double::MIN_VALUE)]
@@ -227,10 +221,6 @@
[f64::% type.double _.drem]
)
-(def: ldc/integer
- (-> (I64 Any) (Instruction Any))
- (|>> .i64 i32.i32 constant.integer _.ldc/integer))
-
(template [<eq> <lt> <type> <cmp>]
[(template [<name> <reference>]
[(def: (<name> [paramG subjectG])
@@ -239,11 +229,11 @@
subjectG (///value.unwrap <type>)
paramG (///value.unwrap <type>)
<cmp>
- (..ldc/integer <reference>)
+ <reference>
(..predicate _.if-icmpeq)))]
- [<eq> +0]
- [<lt> -1])]
+ [<eq> _.iconst-0]
+ [<lt> _.iconst-m1])]
[i64::= i64::< type.long _.lcmp]
[f64::= f64::< type.double _.dcmpg]
@@ -383,7 +373,7 @@
startG ..jvm-int
(_.invokevirtual ..$String "indexOf" index-method)
_.dup
- (ldc/integer -1)
+ _.iconst-m1
(_.if-icmpeq @not-found)
..lux-int
///runtime.some-injection
@@ -413,7 +403,7 @@
messageG
..ensure-string
(_.invokevirtual ..$PrintStream "println" ..string-method)
- ..unit))
+ ///runtime.unit))
(def: (io::error messageG)
(Unary (Instruction Any))
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 a0292ccc3..6a66f78f8 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux
@@ -71,7 +71,7 @@
list.indices
(list@map (|>> inc (/apply.method classT environment arity @begin body)))
(list& (/implementation.method arity @begin body)))
- (list (/implementation.method' /apply.name arity @begin body)))))]
+ (list (/implementation.method' //runtime.apply::name arity @begin body)))))]
(do phase.monad
[instance (/new.instance classT environment arity)]
(wrap [fields methods instance]))))
@@ -124,6 +124,6 @@
($_ _.compose
(_.checkcast /abstract.class)
(monad.seq _.monad batchG)
- (_.invokevirtual /abstract.class /apply.name (/apply.type (list.size batchG)))
+ (_.invokevirtual /abstract.class //runtime.apply::name (//runtime.apply::type (list.size batchG)))
))))
))))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/abstract.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/abstract.lux
index 9b653ec6c..419fca601 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/abstract.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/abstract.lux
@@ -1,7 +1,16 @@
(.module:
- [lux #*
+ [lux (#- Type)
[target
[jvm
- ["." type]]]])
+ ["." type (#+ Type)
+ [category (#+ Method)]]]]]
+ [//
+ [field
+ [constant
+ ["." arity]]]])
(def: #export class (type.class "LuxFunction" (list)))
+
+(def: #export init
+ (Type Method)
+ (type.method [(list arity.type) type.void (list)]))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable.lux
index 083d279ea..cbff8ea5e 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable.lux
@@ -16,12 +16,12 @@
[constant
[pool (#+ Pool)]]]]]
["." //// #_
- ["#." value]
+ ["#." type]
["#." reference]
[////
[reference (#+ Register)]]])
-(def: #export type ////value.type)
+(def: #export type ////type.value)
(def: #export (get class name)
(-> (Type Class) Text (Instruction Any))
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 b646ddbf6..4806e3ba1 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
@@ -8,9 +8,7 @@
["." unsigned]]
["." type]]]]
["." ///// #_
- ["#." abstract]
- ["/#" // #_
- ["#." reference]]])
+ ["#." abstract]])
(def: #export field "partials")
(def: #export type type.int)
@@ -19,9 +17,12 @@
(Instruction Any)
(_.bipush (unsigned.u1 0)))
+(def: this
+ _.aload-0)
+
(def: #export value
(Instruction Any)
($_ _.compose
- //////reference.this
+ ..this
(_.getfield /////abstract.class ..field ..type)
))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux
index 0d4e1f2b3..e25889a37 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux
@@ -44,14 +44,6 @@
[arity (#+ Arity)]
["." reference (#+ Register)]]]]])
-(def: #export name "apply")
-
-(def: #export (type arity)
- (-> Arity (Type category.Method))
- (type.method [(list.repeat arity ////value.type)
- ////value.type
- (list)]))
-
(def: (increment by)
(-> Nat (Instruction Any))
($_ _.compose
@@ -73,7 +65,7 @@
($_ _.compose
(_.checkcast ///abstract.class)
(..inputs offset arity)
- (_.invokevirtual ///abstract.class ..name (..type arity))
+ (_.invokevirtual ///abstract.class ////runtime.apply::name (////runtime.apply::type arity))
(if (n.> ///arity.maximum amount)
(apply (n.+ ///arity.maximum offset)
(n.- ///arity.maximum amount))
@@ -91,8 +83,8 @@
////runtime.apply-failure
_.aconst-null
_.areturn)]
- (method.method //.modifier ..name
- (..type apply-arity)
+ (method.method //.modifier ////runtime.apply::name
+ (////runtime.apply::type apply-arity)
(list)
(do _.monad
[@default _.new-label
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux
index 8643dc916..f7a3edb93 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux
@@ -15,7 +15,7 @@
["." category]]]]]
["." //
["//#" /// #_
- ["#." value]
+ ["#." type]
[////
[arity (#+ Arity)]]]])
@@ -23,8 +23,8 @@
(def: #export (type arity)
(-> Arity (Type category.Method))
- (type.method [(list.repeat arity ////value.type)
- ////value.type
+ (type.method [(list.repeat arity ////type.value)
+ ////type.value
(list)]))
(def: #export (method' name arity @begin body)
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux
index 5eddafb8a..691c4df70 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux
@@ -30,7 +30,7 @@
["#." foreign]
["#." partial]]]
["/#" // #_
- ["#." value]
+ ["#." type]
["#." reference]
[////
[reference (#+ Register)]
@@ -41,7 +41,7 @@
(def: (partials arity)
(-> Arity (List (Type Value)))
- (list.repeat arity ////value.type))
+ (list.repeat arity ////type.value))
(def: #export (type environment arity)
(-> Environment Arity (Type category.Method))
@@ -52,10 +52,6 @@
type.void
(list)]))
-(def: super-type
- (Type category.Method)
- (type.method [(list ///arity.type) type.void (list)]))
-
(def: #export (super environment-size arity)
(-> Nat Arity (Instruction Any))
(let [arity-register (inc environment-size)]
@@ -63,7 +59,7 @@
(if (arity.unary? arity)
(_.bipush (unsigned.u1 0))
(_.iload (unsigned.u1 arity-register)))
- (_.invokespecial ///abstract.class ..name ..super-type))))
+ (_.invokespecial ///abstract.class ..name ///abstract.init))))
(def: (store-all amount put offset)
(-> Nat
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 9e60e6cda..6c9a963d7 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux
@@ -18,7 +18,8 @@
["." unsigned]]]]]
["." // #_
[runtime (#+ Operation)]
- ["#." value]])
+ ["#." value]
+ ["#." type]])
(def: local
(-> Register (Instruction Any))
@@ -26,7 +27,7 @@
(def: #export this
(Instruction Any)
- (..local 0))
+ _.aload-0)
(template [<name> <prefix>]
[(def: #export <name>
@@ -45,7 +46,7 @@
..this
(_.getfield (type.class function-class (list))
(..foreign-name variable)
- //value.type)))))
+ //type.value)))))
(def: #export (variable variable)
(-> Variable (Operation (Instruction Any)))
@@ -60,4 +61,4 @@
(-> Name (Operation (Instruction Any)))
(do phase.monad
[bytecode-name (generation.remember name)]
- (wrap (_.getstatic (type.class bytecode-name (list)) //value.field //value.type))))
+ (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 3868b747f..a47892039 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux
@@ -1,27 +1,53 @@
(.module:
- [lux (#- Type Definition case)
+ [lux (#- Type Definition case log! false true)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ [state (#+ State)]]
[data
[binary (#+ Binary)]
[number
["." i32]
["." i64]
- ["n" nat]]]
+ ["n" nat]]
+ [collection
+ ["." list ("#@." functor)]
+ ["." row]]
+ [format
+ [".F" binary]]]
[target
[jvm
["_" instruction (#+ Label Instruction)]
- ["." constant]
+ ["." modifier (#+ Modifier) ("#@." monoid)]
+ ["." field (#+ Field)]
+ ["." method (#+ Method)]
+ ["." version]
+ ["." class (#+ Class)]
+ ["." constant
+ [pool (#+ Pool)]]
+ [encoding
+ ["." unsigned]
+ ["." name]]
["." type (#+ Type)
- ["." category (#+ Method)]]]]]
+ ["." category (#+ Return' Value')]
+ ["." reflection]]]]]
["." // #_
+ ["#." type]
["#." value]
["#." function #_
- ["#" abstract]]
+ ["#" abstract]
+ [field
+ [constant
+ ["#/." arity]]
+ [variable
+ [partial
+ ["#/." count]]]]]
["/#" //
["/#" //
[//
+ [arity (#+ Arity)]
[reference (#+ Register)]
- ["." synthesis]]]]]
- )
+ ["." synthesis]]]]])
(type: #export Byte-Code Binary)
@@ -44,83 +70,76 @@
(def: #export class (type.class "LuxRuntime" (list)))
-(def: $Text (type.class "java.lang.String" (list)))
-
-(def: #export $Tag type.int)
-(def: #export $Flag //value.type)
-(def: #export $Variant (type.array //value.type))
-
-(def: #export $Offset type.int)
-(def: #export $Tuple (type.array //value.type))
-
-(def: #export $Stack (type.array //value.type))
-
(def: procedure
- (-> Text (Type Method) (Instruction Any))
+ (-> Text (Type category.Method) (Instruction Any))
(_.invokestatic ..class))
-(def: failure-type
- (type.method [(list) type.void (list)]))
-
-(def: #export apply-failure
- (..procedure "apply_failure" ..failure-type))
-
-(def: #export pm-failure
- (..procedure "pm_failure" ..failure-type))
-
-(def: push-name
- "push")
-
-(def: push-type
- (type.method [(list ..$Stack //value.type) ..$Stack (list)]))
-
-(def: #export push
- (..procedure ..push-name ..push-type))
-
-(def: case-name
- "case")
-
-(def: case-type
- (type.method [(list ..$Variant ..$Tag ..$Flag) //value.type (list)]))
+(def: modifier
+ (Modifier Method)
+ ($_ modifier@compose
+ method.public
+ method.static
+ method.strict
+ ))
-(def: #export case
- (..procedure ..case-name ..case-type))
+(def: local
+ (-> Nat (Instruction Any))
+ (|>> unsigned.u1 _.aload))
-(def: projection-type
- (type.method [(list ..$Tuple $Offset) //value.type (list)]))
-
-(def: #export left-projection
- (..procedure "left" ..projection-type))
-
-(def: #export right-projection
- (..procedure "right" ..projection-type))
-
-(def: try-name
- "try")
-
-(def: try-type
- (type.method [(list //function.class) ..$Variant (list)]))
-
-(def: #export try
- (_.invokestatic ..class ..try-name ..try-type))
-
-(def: #export decode-frac
- (..procedure "decode_frac" (type.method [(list ..$Text) ..$Variant (list)])))
+(def: this
+ (Instruction Any)
+ _.aload-0)
-(def: #export variant
- (..procedure "variant" (type.method [(list ..$Tag ..$Flag //value.type) ..$Variant (list)])))
+(def: #export (get index)
+ (-> (Instruction Any) (Instruction Any))
+ ($_ _.compose
+ index
+ _.aaload))
-(def: ldc/integer
- (-> (I64 Any) (Instruction Any))
- (|>> .i64 i32.i32 constant.integer _.ldc/integer))
+(def: (set! index value)
+ (-> (Instruction Any) (Instruction Any) (Instruction Any))
+ ($_ _.compose
+ _.dup
+ index
+ value
+ _.aastore))
+
+(def: #export unit (_.ldc/string synthesis.unit))
+
+(def: variant::name "variant")
+(def: variant::type (type.method [(list //type.tag //type.flag //type.value) //type.variant (list)]))
+(def: #export variant (..procedure ..variant::name ..variant::type))
+
+(def: variant-tag _.iconst-0)
+(def: variant-last? _.iconst-1)
+(def: variant-value _.iconst-2)
+
+(def: variant::method
+ (let [new-variant ($_ _.compose
+ _.iconst-3
+ (_.anewarray //type.value))
+ $tag ($_ _.compose
+ _.iload-0
+ (//value.wrap type.int))
+ $last? _.aload-1
+ $value _.aload-2]
+ (method.method ..modifier ..variant::name
+ ..variant::type
+ (list)
+ ($_ _.compose
+ new-variant
+ (..set! ..variant-tag $tag)
+ (..set! ..variant-last? $last?)
+ (..set! ..variant-value $value)
+ _.areturn))))
(def: #export left-flag _.aconst-null)
-(def: #export right-flag (_.ldc/string ""))
+(def: #export right-flag ..unit)
(def: #export left-injection
(Instruction Any)
($_ _.compose
- (..ldc/integer +0)
+ _.iconst-0
..left-flag
_.dup2-x1
_.pop2
@@ -129,25 +148,448 @@
(def: #export right-injection
(Instruction Any)
($_ _.compose
- (..ldc/integer +1)
+ _.iconst-1
..right-flag
_.dup2-x1
_.pop2
..variant))
-(def: #export some-injection right-injection)
+(def: #export some-injection ..right-injection)
(def: #export none-injection
(Instruction Any)
($_ _.compose
- (..ldc/integer +0)
+ _.iconst-0
_.aconst-null
- (_.ldc/string synthesis.unit)
+ ..unit
..variant))
+(def: (risky $unsafe)
+ (-> (Instruction Any) (Instruction Any))
+ (do _.monad
+ [@from _.new-label
+ @to _.new-label
+ @handler _.new-label]
+ ($_ _.compose
+ (_.try @from @to @handler //type.error)
+ (_.set-label @from)
+ $unsafe
+ ..some-injection
+ _.areturn
+ (_.set-label @to)
+ (_.set-label @handler)
+ ..none-injection
+ _.areturn)))
+
+(def: decode-frac::name "decode_frac")
+(def: decode-frac::type (type.method [(list //type.text) //type.variant (list)]))
+(def: #export decode-frac (..procedure ..decode-frac::name ..decode-frac::type))
+
+(def: decode-frac::method
+ (method.method ..modifier ..variant::name
+ ..variant::type
+ (list)
+ (..risky
+ ($_ _.compose
+ ..this
+ (_.invokestatic //type.frac "parseDouble" (type.method [(list //type.text) type.double (list)]))
+ (//value.wrap type.double)))))
+
+(def: #export log!
+ (Instruction 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 _.swap (print! "println"))))
+
+(def: exception-constructor (type.method [(list //type.text) type.void (list)]))
+(def: (illegal-state-exception message)
+ (-> Text (Instruction Any))
+ (let [^IllegalStateException (type.class "java.lang.IllegalStateException" (list))]
+ ($_ _.compose
+ (_.new ^IllegalStateException)
+ _.dup
+ (_.ldc/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))
+ (method.method ..modifier name
+ ..failure::type
+ (list)
+ ($_ _.compose
+ (..illegal-state-exception message)
+ _.athrow)))
+
+(def: apply-failure::name "apply_failure")
+(def: #export apply-failure (..procedure ..apply-failure::name ..failure::type))
+
+(def: apply-failure::method
+ (..failure ..apply-failure::name "Error while applying function."))
+
+(def: pm-failure::name "pm_failure")
+(def: #export pm-failure (..procedure ..pm-failure::name ..failure::type))
+
+(def: pm-failure::method
+ (..failure ..pm-failure::name "Invalid expression for pattern-matching."))
+
+(def: #export stack-head _.iconst-0)
+(def: #export stack-tail _.iconst-1)
+
+(def: push::name "push")
+(def: push::type (type.method [(list //type.stack //type.value) //type.stack (list)]))
+(def: #export push (..procedure ..push::name ..push::type))
+
+(def: push::method
+ (method.method ..modifier ..push::name
+ ..push::type
+ (list)
+ (let [new-stack-frame! ($_ _.compose
+ _.iconst-2
+ (_.anewarray //type.value))
+ $head _.aload-1
+ $tail _.aload-0]
+ ($_ _.compose
+ new-stack-frame!
+ (..set! ..stack-head $head)
+ (..set! ..stack-tail $tail)
+ _.areturn))))
+
+(def: case::name "case")
+(def: case::type (type.method [(list //type.variant //type.tag //type.flag) //type.value (list)]))
+(def: #export case (..procedure ..case::name ..case::type))
+
+(def: case::method
+ (method.method ..modifier ..case::name ..case::type
+ (list)
+ (do _.monad
+ [@loop _.new-label
+ @perfect-match! _.new-label
+ @tags-match! _.new-label
+ @maybe-nested _.new-label
+ @maybe-super-nested _.new-label
+ @mismatch! _.new-label
+ #let [::tag ($_ _.compose
+ (..get ..variant-tag)
+ (//value.unwrap type.int))
+ ::last? (..get ..variant-last?)
+ ::value (..get ..variant-value)
+
+ $variant _.aload-0
+ $tag _.iload-1
+ $last? _.aload-2
+
+ not-found _.aconst-null
+
+ update-$tag ($_ _.compose
+ _.isub
+ _.istore-1)
+ update-$variant ($_ _.compose
+ $variant ::value
+ (_.checkcast //type.variant)
+ _.astore-0)
+ recur (: (-> Label (Instruction Any))
+ (function (_ @loop-start)
+ ($_ _.compose
+ update-$tag
+ update-$variant
+ (_.goto @loop-start))))
+
+ super-nested-tag ($_ _.compose
+ $variant ::tag
+ $tag _.isub)
+ super-nested ($_ _.compose
+ super-nested-tag
+ $variant ::last?
+ $variant ::value
+ ..variant)]]
+ ($_ _.compose
+ (_.set-label @loop)
+ $tag
+ $variant ::tag
+ _.dup2 (_.if-icmpeq @tags-match!)
+ _.dup2 (_.if-icmpgt @maybe-nested)
+ _.dup2 (_.if-icmplt @maybe-super-nested)
+ ## _.pop2
+ not-found
+ _.areturn
+ (_.set-label @tags-match!) ## tag, sumT
+ $last? ## tag, sumT, wants-last?
+ $variant ::last? ## tag, sumT, wants-last?, is-last?
+ (_.if-acmpeq @perfect-match!) ## tag, sumT
+ (_.set-label @maybe-nested) ## tag, sumT
+ $variant ::last? ## tag, sumT, last?
+ (_.ifnull @mismatch!) ## tag, sumT
+ (recur @loop)
+ (_.set-label @perfect-match!) ## tag, sumT
+ ## _.pop2
+ $variant ::value
+ _.areturn
+ (_.set-label @maybe-super-nested) ## tag, sumT
+ $last? (_.ifnull @mismatch!)
+ ## _.pop2
+ super-nested
+ _.areturn
+ (_.set-label @mismatch!) ## tag, sumT
+ ## _.pop2
+ not-found
+ _.areturn
+ ))))
+
+(def: projection-type (type.method [(list //type.tuple //type.offset) //type.value (list)]))
+
+(def: left-projection::name "left")
+(def: #export left-projection (..procedure ..left-projection::name ..projection-type))
+
+(def: right-projection::name "right")
+(def: #export right-projection (..procedure ..right-projection::name ..projection-type))
+
+(def: projection::method2
+ [(State Pool Method) (State Pool Method)]
+ (let [$tuple _.aload-0
+ $tuple::size ($_ _.compose
+ $tuple _.arraylength)
+
+ $lefts _.iload-1
+
+ $last-right ($_ _.compose
+ $tuple::size _.iconst-1 _.isub)
+
+ update-$lefts ($_ _.compose
+ $lefts $last-right _.isub
+ _.istore-1)
+ update-$tuple ($_ _.compose
+ $tuple $last-right _.aaload (_.checkcast //type.tuple)
+ _.astore-0)
+ recur (: (-> Label (Instruction Any))
+ (function (_ @loop)
+ ($_ _.compose
+ update-$lefts
+ update-$tuple
+ (_.goto @loop))))
+
+ left-projection::method
+ (method.method ..modifier ..left-projection::name ..projection-type
+ (list)
+ (do _.monad
+ [@loop _.new-label
+ @recursive _.new-label
+ #let [::left ($_ _.compose
+ $lefts _.aaload)]]
+ ($_ _.compose
+ (_.set-label @loop)
+ $lefts $last-right (_.if-icmpge @recursive)
+ $tuple ::left
+ _.areturn
+ (_.set-label @recursive)
+ ## Recursive
+ (recur @loop))))
+
+ right-projection::method
+ (method.method ..modifier ..right-projection::name ..projection-type
+ (list)
+ (do _.monad
+ [@loop _.new-label
+ @not-tail _.new-label
+ @slice _.new-label
+ #let [$right ($_ _.compose
+ $lefts
+ _.iconst-1
+ _.iadd)
+ $::nested ($_ _.compose
+ $tuple _.swap _.aaload)
+ super-nested ($_ _.compose
+ $tuple
+ $right
+ $tuple::size
+ (_.invokestatic (type.class "java.util.Arrays" (list)) "copyOfRange"
+ (type.method [(list //type.tuple //type.index //type.index) //type.tuple (list)])))]]
+ ($_ _.compose
+ (_.set-label @loop)
+ $last-right $right
+ _.dup2 (_.if-icmpne @not-tail)
+ ## _.pop
+ $::nested
+ _.areturn
+ (_.set-label @not-tail)
+ (_.if-icmpgt @slice)
+ ## Must recurse
+ (recur @loop)
+ (_.set-label @slice)
+ super-nested
+ _.areturn)))]
+ [left-projection::method
+ right-projection::method]))
+
+(def: #export apply::name "apply")
+
+(def: #export (apply::type arity)
+ (-> Arity (Type category.Method))
+ (type.method [(list.repeat arity //type.value) //type.value (list)]))
+
+(def: #export apply
+ (_.invokevirtual //function.class ..apply::name (..apply::type 1)))
+
+(def: try::name "try")
+(def: try::type (type.method [(list //function.class) //type.variant (list)]))
+(def: #export try (..procedure ..try::name ..try::type))
+
+(def: false _.iconst-0)
+(def: true _.iconst-1)
+
+(def: try::method
+ (method.method ..modifier ..try::name ..try::type
+ (list)
+ (do _.monad
+ [@from _.new-label
+ @to _.new-label
+ @handler _.new-label
+ #let [$unsafe ..this
+ unit _.aconst-null
+
+ ^StringWriter (type.class "java.io.StringWriter" (list))
+ string-writer ($_ _.compose
+ (_.new ^StringWriter)
+ _.dup
+ (_.invokespecial ^StringWriter "<init>" (type.method [(list) type.void (list)])))
+
+ ^PrintWriter (type.class "java.io.PrintWriter" (list))
+ print-writer ($_ _.compose
+ ## WTW
+ (_.new ^PrintWriter) ## WTWP
+ _.dup-x1 ## WTPWP
+ _.swap ## WTPPW
+ ..true ## WTPPWZ
+ (_.invokespecial ^PrintWriter "<init>" (type.method [(list (type.class "java.io.Writer" (list)) type.boolean) type.void (list)]))
+ ## WTP
+ )]]
+ ($_ _.compose
+ (_.try @from @to @handler //type.error)
+ (_.set-label @from)
+ $unsafe unit ..apply
+ ..right-injection _.areturn
+ (_.set-label @to)
+ (_.set-label @handler) ## T
+ string-writer ## TW
+ _.dup-x1 ## WTW
+ print-writer ## WTP
+ (_.invokevirtual //type.error "printStackTrace" (type.method [(list ^PrintWriter) type.void (list)])) ## W
+ (_.invokevirtual ^StringWriter "toString" (type.method [(list) //type.text (list)])) ## S
+ ..left-injection _.areturn
+ ))))
+
+(def: reflection
+ (All [category]
+ (-> (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)
+ modifier (: (Modifier Class)
+ ($_ modifier@compose
+ class.public
+ class.final))
+ bytecode (<| (binaryF.run class.writer)
+ (class.class version.v6_0
+ modifier
+ (name.internal class)
+ (name.internal (..reflection ^Object)) (list)
+ (list)
+ (let [[left-projection::method right-projection::method] projection::method2]
+ (list ..decode-frac::method
+ ..variant::method
+
+ ..apply-failure::method
+ ..pm-failure::method
+
+ ..push::method
+ ..case::method
+ left-projection::method
+ right-projection::method
+
+ ..try::method))
+ (row.row)))]
+ (do ////.monad
+ [_ (///.execute! class [class bytecode])]
+ (///.save! .false ["" class] [class bytecode]))))
+
+(def: translate-function
+ (Operation Any)
+ (let [apply::method+ (|> (list.n/range (inc //function/arity.minimum)
+ //function/arity.maximum)
+ (list@map (function (_ arity)
+ (method.method method.public ..apply::name (..apply::type arity)
+ (list)
+ (let [previous-inputs (|> arity
+ list.indices
+ (monad.map _.monad ..local))]
+ ($_ _.compose
+ previous-inputs
+ (_.invokevirtual //function.class ..apply::name (..apply::type (dec arity)))
+ (_.checkcast //function.class)
+ (..local arity)
+ (_.invokevirtual //function.class ..apply::name (..apply::type //function/arity.minimum))
+ _.areturn)))))
+ (list& (method.method (modifier@compose method.public method.abstract)
+ ..apply::name (..apply::type //function/arity.minimum)
+ (list)
+ ## TODO: It shouldn't be necessary to set the code for this method, since it's abstract.
+ ## Setting this might be a bug. Verify & fix ASAP.
+ ($_ _.compose
+ ..apply-failure
+ ..this
+ _.areturn))))
+ <init>::method (method.method method.public "<init>" //function.init
+ (list)
+ (let [$partials _.iload-1]
+ ($_ _.compose
+ ..this
+ (_.invokespecial ..^Object "<init>" (type.method [(list) type.void (list)]))
+ ..this
+ $partials
+ (_.putfield //function.class //function/count.field //function/count.type)
+ _.return)))
+ modifier (: (Modifier Class)
+ ($_ modifier@compose
+ class.public
+ class.abstract))
+ class (..reflection //function.class)
+ partial-count (: (State Pool Field)
+ (field.field (modifier@compose field.public field.final)
+ //function/count.field
+ //function/count.type
+ (row.row)))
+ bytecode (<| (binaryF.run class.writer)
+ (class.class version.v6_0
+ modifier
+ (name.internal class)
+ (name.internal (..reflection ..^Object)) (list)
+ (list partial-count)
+ (list& <init>::method apply::method+)
+ (row.row)))]
+ (do ////.monad
+ [_ (///.execute! class [class bytecode])]
+ (///.save! .false ["" class] [class bytecode]))))
+
+(def: #export translate
+ (Operation Any)
+ (do ////.monad
+ [_ ..translate-runtime]
+ ..translate-function))
+
(def: #export forge-label
(Operation Label)
- (let [shift (n./ 2 i64.width)]
+ (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.
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/type.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/type.lux
new file mode 100644
index 000000000..954740d2d
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/type.lux
@@ -0,0 +1,22 @@
+(.module:
+ [lux #*
+ [target
+ [jvm
+ ["." type]]]])
+
+(def: #export frac (type.class "java.lang.Double" (list)))
+(def: #export text (type.class "java.lang.String" (list)))
+
+(def: #export value (type.class "java.lang.Object" (list)))
+
+(def: #export tag type.int)
+(def: #export flag ..value)
+(def: #export variant (type.array ..value))
+
+(def: #export offset type.int)
+(def: #export index ..offset)
+(def: #export tuple (type.array ..value))
+
+(def: #export stack (type.array ..value))
+
+(def: #export error (type.class "java.lang.Throwable" (list)))
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 803ac2522..e6deaf205 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux
@@ -9,8 +9,6 @@
(def: #export field "value")
-(def: #export type (type.class "java.lang.Object" (list)))
-
(template [<name> <boolean> <byte> <short> <int> <long> <float> <double> <char>]
[(def: (<name> type)
(-> (Type Primitive) Text)