diff options
Diffstat (limited to 'stdlib/source/lux/tool')
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) |