diff options
Diffstat (limited to 'stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux')
| -rw-r--r-- | stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux | 594 |
1 files changed, 518 insertions, 76 deletions
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. |