diff options
Diffstat (limited to 'lux-jvm/source/luxc/lang/translation/jvm/runtime.lux')
| -rw-r--r-- | lux-jvm/source/luxc/lang/translation/jvm/runtime.lux | 387 |
1 files changed, 387 insertions, 0 deletions
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux b/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux new file mode 100644 index 000000000..a657a7a38 --- /dev/null +++ b/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux @@ -0,0 +1,387 @@ +(.module: + [lux (#- Type) + [abstract + [monad (#+ do)]] + [data + [binary (#+ Binary)] + ["." product] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#@." functor)] + ["." row]]] + ["." math] + [target + [jvm + ["." type (#+ Type) + ["." category (#+ Void Value' Value Return' Return Primitive Object Class Array Var Parameter Method)] + ["." reflection]]]] + [tool + [compiler (#+ Output) + [arity (#+ Arity)] + ["." phase] + [language + [lux + ["." synthesis] + ["." generation]]] + [meta + [archive + ["." artifact (#+ Registry)]]]]]] + [luxc + [lang + [host + ["$" jvm (#+ Label Inst Def Operation) + ["$d" def] + ["_" inst]]]]] + ["." // (#+ ByteCode)]) + +(def: $Text (type.class "java.lang.String" (list))) +(def: #export $Tag type.int) +(def: #export $Flag (type.class "java.lang.Object" (list))) +(def: #export $Value (type.class "java.lang.Object" (list))) +(def: #export $Index type.int) +(def: #export $Stack (type.array $Value)) +(def: $Throwable (type.class "java.lang.Throwable" (list))) + +(def: nullary-init-methodT + (type.method [(list) type.void (list)])) + +(def: throw-methodT + (type.method [(list) type.void (list)])) + +(def: #export logI + Inst + (let [PrintStream (type.class "java.io.PrintStream" (list)) + outI (_.GETSTATIC (type.class "java.lang.System" (list)) "out" PrintStream) + printI (function (_ method) + (_.INVOKEVIRTUAL PrintStream method (type.method [(list $Value) type.void (list)])))] + (|>> outI (_.string "LOG: ") (printI "print") + outI _.SWAP (printI "println")))) + +(def: variant-method + (type.method [(list $Tag $Flag $Value) //.$Variant (list)])) + +(def: #export variantI + Inst + (_.INVOKESTATIC //.$Runtime "variant_make" variant-method)) + +(def: #export leftI + Inst + (|>> (_.int +0) + _.NULL + _.DUP2_X1 + _.POP2 + variantI)) + +(def: #export rightI + Inst + (|>> (_.int +1) + (_.string "") + _.DUP2_X1 + _.POP2 + variantI)) + +(def: #export someI Inst rightI) + +(def: #export noneI + Inst + (|>> (_.int +0) + _.NULL + (_.string synthesis.unit) + variantI)) + +(def: (tryI unsafeI) + (-> Inst Inst) + (<| _.with-label (function (_ @from)) + _.with-label (function (_ @to)) + _.with-label (function (_ @handler)) + (|>> (_.try @from @to @handler (type.class "java.lang.Exception" (list))) + (_.label @from) + unsafeI + someI + _.ARETURN + (_.label @to) + (_.label @handler) + noneI + _.ARETURN))) + +(def: #export partials-field Text "partials") +(def: #export apply-method Text "apply") +(def: #export num-apply-variants Nat 8) + +(def: #export (apply-signature arity) + (-> Arity (Type Method)) + (type.method [(list.repeat arity $Value) $Value (list)])) + +(def: adt-methods + Def + (let [store-tagI (|>> _.DUP (_.int +0) (_.ILOAD 0) (_.wrap type.int) _.AASTORE) + store-flagI (|>> _.DUP (_.int +1) (_.ALOAD 1) _.AASTORE) + store-valueI (|>> _.DUP (_.int +2) (_.ALOAD 2) _.AASTORE)] + (|>> ($d.method #$.Public $.staticM "variant_make" + (type.method [(list $Tag $Flag $Value) //.$Variant (list)]) + (|>> (_.int +3) + (_.ANEWARRAY $Value) + store-tagI + store-flagI + store-valueI + _.ARETURN))))) + +(def: frac-methods + Def + (|>> ($d.method #$.Public $.staticM "decode_frac" (type.method [(list $Text) //.$Variant (list)]) + (tryI + (|>> (_.ALOAD 0) + (_.INVOKESTATIC (type.class "java.lang.Double" (list)) "parseDouble" (type.method [(list $Text) type.double (list)])) + (_.wrap type.double)))) + )) + +(def: (illegal-state-exception message) + (-> Text Inst) + (let [IllegalStateException (type.class "java.lang.IllegalStateException" (list))] + (|>> (_.NEW IllegalStateException) + _.DUP + (_.string message) + (_.INVOKESPECIAL IllegalStateException "<init>" (type.method [(list $Text) type.void (list)]))))) + +(def: pm-methods + Def + (let [tuple-sizeI (|>> (_.ALOAD 0) _.ARRAYLENGTH) + last-rightI (|>> tuple-sizeI (_.int +1) _.ISUB) + leftsI (_.ILOAD 1) + left-indexI leftsI + sub-leftsI (|>> leftsI + last-rightI + _.ISUB) + sub-tupleI (|>> (_.ALOAD 0) last-rightI _.AALOAD (_.CHECKCAST //.$Tuple)) + recurI (: (-> Label Inst) + (function (_ @loop) + (|>> sub-leftsI (_.ISTORE 1) + sub-tupleI (_.ASTORE 0) + (_.GOTO @loop))))] + (|>> ($d.method #$.Public $.staticM "pm_fail" throw-methodT + (|>> (illegal-state-exception "Invalid expression for pattern-matching.") + _.ATHROW)) + ($d.method #$.Public $.staticM "apply_fail" throw-methodT + (|>> (illegal-state-exception "Error while applying function.") + _.ATHROW)) + ($d.method #$.Public $.staticM "pm_push" (type.method [(list $Stack $Value) $Stack (list)]) + (|>> (_.int +2) + (_.ANEWARRAY $Value) + _.DUP + (_.int +1) + (_.ALOAD 0) + _.AASTORE + _.DUP + (_.int +0) + (_.ALOAD 1) + _.AASTORE + _.ARETURN)) + ($d.method #$.Public $.staticM "pm_variant" (type.method [(list //.$Variant $Tag $Flag) $Value (list)]) + (<| _.with-label (function (_ @loop)) + _.with-label (function (_ @perfect-match!)) + _.with-label (function (_ @tags-match!)) + _.with-label (function (_ @maybe-nested)) + _.with-label (function (_ @mismatch!)) + (let [$variant (_.ALOAD 0) + $tag (_.ILOAD 1) + $last? (_.ALOAD 2) + + variant-partI (: (-> Nat Inst) + (function (_ idx) + (|>> (_.int (.int idx)) _.AALOAD))) + ::tag (: Inst + (|>> (variant-partI 0) (_.unwrap type.int))) + ::last? (variant-partI 1) + ::value (variant-partI 2) + + super-nested-tag (|>> _.SWAP ## variant::tag, tag + _.ISUB) + super-nested (|>> super-nested-tag ## super-tag + $variant ::last? ## super-tag, super-last + $variant ::value ## super-tag, super-last, super-value + ..variantI) + + update-$tag _.ISUB + update-$variant (|>> $variant ::value + (_.CHECKCAST //.$Variant) + (_.ASTORE 0)) + iterate! (: (-> Label Inst) + (function (_ @loop) + (|>> update-$variant + update-$tag + (_.GOTO @loop)))) + + not-found _.NULL]) + (|>> $tag ## tag + (_.label @loop) + $variant ::tag ## tag, variant::tag + _.DUP2 (_.IF_ICMPEQ @tags-match!) ## tag, variant::tag + _.DUP2 (_.IF_ICMPGT @maybe-nested) ## tag, variant::tag + $last? (_.IFNULL @mismatch!) ## tag, variant::tag + super-nested ## super-variant + _.ARETURN + (_.label @tags-match!) ## tag, variant::tag + $last? ## tag, variant::tag, last? + $variant ::last? ## tag, variant::tag, last?, variant::last? + (_.IF_ACMPEQ @perfect-match!) ## tag, variant::tag + (_.label @maybe-nested) ## tag, variant::tag + $variant ::last? ## tag, variant::tag, variant::last? + (_.IFNULL @mismatch!) ## tag, variant::tag + (iterate! @loop) + (_.label @perfect-match!) ## tag, variant::tag + ## _.POP2 + $variant ::value + _.ARETURN + (_.label @mismatch!) ## tag, variant::tag + ## _.POP2 + not-found + _.ARETURN))) + ($d.method #$.Public $.staticM "tuple_left" (type.method [(list //.$Tuple $Index) $Value (list)]) + (<| _.with-label (function (_ @loop)) + _.with-label (function (_ @recursive)) + (let [left-accessI (|>> (_.ALOAD 0) left-indexI _.AALOAD)]) + (|>> (_.label @loop) + leftsI last-rightI (_.IF_ICMPGE @recursive) + left-accessI + _.ARETURN + (_.label @recursive) + ## Recursive + (recurI @loop)))) + ($d.method #$.Public $.staticM "tuple_right" (type.method [(list //.$Tuple $Index) $Value (list)]) + (<| _.with-label (function (_ @loop)) + _.with-label (function (_ @not-tail)) + _.with-label (function (_ @slice)) + (let [right-indexI (|>> leftsI + (_.int +1) + _.IADD) + right-accessI (|>> (_.ALOAD 0) + _.SWAP + _.AALOAD) + sub-rightI (|>> (_.ALOAD 0) + right-indexI + tuple-sizeI + (_.INVOKESTATIC (type.class "java.util.Arrays" (list)) "copyOfRange" + (type.method [(list //.$Tuple $Index $Index) + //.$Tuple + (list)])))]) + (|>> (_.label @loop) + last-rightI right-indexI + _.DUP2 (_.IF_ICMPNE @not-tail) + ## _.POP + right-accessI + _.ARETURN + (_.label @not-tail) + (_.IF_ICMPGT @slice) + ## Must recurse + (recurI @loop) + (_.label @slice) + sub-rightI + _.ARETURN + ))) + ))) + +(def: #export try (type.method [(list //.$Function) //.$Variant (list)])) + +(def: io-methods + Def + (let [StringWriter (type.class "java.io.StringWriter" (list)) + PrintWriter (type.class "java.io.PrintWriter" (list)) + string-writerI (|>> (_.NEW StringWriter) + _.DUP + (_.INVOKESPECIAL StringWriter "<init>" nullary-init-methodT)) + print-writerI (|>> (_.NEW PrintWriter) + _.SWAP + _.DUP2 + _.POP + _.SWAP + (_.boolean true) + (_.INVOKESPECIAL PrintWriter "<init>" (type.method [(list (type.class "java.io.Writer" (list)) type.boolean) type.void (list)])) + )] + (|>> ($d.method #$.Public $.staticM "try" ..try + (<| _.with-label (function (_ @from)) + _.with-label (function (_ @to)) + _.with-label (function (_ @handler)) + (|>> (_.try @from @to @handler $Throwable) + (_.label @from) + (_.ALOAD 0) + _.NULL + (_.INVOKEVIRTUAL //.$Function apply-method (apply-signature 1)) + rightI + _.ARETURN + (_.label @to) + (_.label @handler) + string-writerI ## TW + _.DUP2 ## TWTW + print-writerI ## TWTP + (_.INVOKEVIRTUAL $Throwable "printStackTrace" (type.method [(list (type.class "java.io.PrintWriter" (list))) type.void (list)])) ## TW + (_.INVOKEVIRTUAL StringWriter "toString" (type.method [(list) $Text (list)])) ## TS + _.SWAP _.POP leftI + _.ARETURN))) + ))) + +(def: reflection + (All [category] + (-> (Type (<| Return' Value' category)) Text)) + (|>> type.reflection reflection.reflection)) + +(def: translate-runtime + (Operation [Text Binary]) + (let [runtime-class (..reflection //.$Runtime) + bytecode ($d.class #$.V1_6 #$.Public $.finalC runtime-class (list) (type.class "java.lang.Object" (list)) (list) + (|>> adt-methods + frac-methods + pm-methods + io-methods)) + payload ["0" bytecode]] + (do phase.monad + [_ (generation.execute! runtime-class [runtime-class bytecode]) + _ (generation.save! false ["" "0"] payload)] + (wrap payload)))) + +(def: translate-function + (Operation [Text Binary]) + (let [applyI (|> (list.n/range 2 num-apply-variants) + (list@map (function (_ arity) + ($d.method #$.Public $.noneM apply-method (apply-signature arity) + (let [preI (|> (list.n/range 0 (dec arity)) + (list@map _.ALOAD) + _.fuse)] + (|>> preI + (_.INVOKEVIRTUAL //.$Function apply-method (apply-signature (dec arity))) + (_.CHECKCAST //.$Function) + (_.ALOAD arity) + (_.INVOKEVIRTUAL //.$Function apply-method (apply-signature 1)) + _.ARETURN))))) + (list& ($d.abstract-method #$.Public $.noneM apply-method (apply-signature 1))) + $d.fuse) + $Object (type.class "java.lang.Object" (list)) + function-class (..reflection //.$Function) + bytecode ($d.abstract #$.V1_6 #$.Public $.noneC function-class (list) $Object (list) + (|>> ($d.field #$.Public $.finalF partials-field type.int) + ($d.method #$.Public $.noneM "<init>" (type.method [(list type.int) type.void (list)]) + (|>> (_.ALOAD 0) + (_.INVOKESPECIAL $Object "<init>" nullary-init-methodT) + (_.ALOAD 0) + (_.ILOAD 1) + (_.PUTFIELD //.$Function partials-field type.int) + _.RETURN)) + applyI)) + payload ["1" bytecode]] + (do phase.monad + [_ (generation.execute! function-class [function-class bytecode]) + _ (generation.save! false ["" "1"] payload)] + (wrap payload)))) + +(def: #export translate + (Operation [Registry Output]) + (do phase.monad + [runtime-payload ..translate-runtime + function-payload ..translate-function] + (wrap [(|> artifact.empty + artifact.resource + product.right + artifact.resource + product.right) + (row.row runtime-payload + function-payload)]))) |