diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/jvm/runtime.lux')
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/runtime.lux | 361 |
1 files changed, 361 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.lux new file mode 100644 index 000000000..d21729d0e --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/runtime.lux @@ -0,0 +1,361 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [data + [text + format] + [collection + ["." list ("#/." functor)]]] + ["." math] + [tool + [compiler + [analysis (#+ Arity)] + ["." synthesis] + ["." phase + ["." generation]]]]] + [luxc + [lang + [host + ["$" jvm (#+ Label Inst Method Def Operation) + ["$t" type] + ["$d" def] + ["_" inst]]]]] + ["." // (#+ ByteCode)]) + +(def: $Object $.Type ($t.class "java.lang.Object" (list))) +(def: $Object-Array $.Type ($t.array 1 $Object)) +(def: $String $.Type ($t.class "java.lang.String" (list))) +(def: #export $Stack $.Type ($t.array 1 $Object)) +(def: #export $Tuple $.Type $Object-Array) +(def: #export $Variant $.Type $Object-Array) +(def: #export $Tag $.Type $t.int) +(def: #export $Flag $.Type $Object) +(def: #export $Datum $.Type $Object) +(def: #export $Function $.Type ($t.class //.function-class (list))) +(def: $Throwable $.Type ($t.class "java.lang.Throwable" (list))) +(def: $Runtime $.Type ($t.class "java.lang.Runtime" (list))) + +(def: #export logI + Inst + (let [outI (_.GETSTATIC "java.lang.System" "out" ($t.class "java.io.PrintStream" (list))) + printI (function (_ method) (_.INVOKEVIRTUAL "java.io.PrintStream" method ($t.method (list $Object) #.None (list)) #0))] + (|>> outI (_.string "LOG: ") (printI "print") + outI _.SWAP (printI "println")))) + +(def: variant-method + Method + ($t.method (list $t.int $Object $Object) (#.Some $Object-Array) (list))) + +(def: #export variantI + Inst + (_.INVOKESTATIC //.runtime-class "variant_make" variant-method #0)) + +(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: (try-methodI unsafeI) + (-> Inst Inst) + (<| _.with-label (function (_ @from)) + _.with-label (function (_ @to)) + _.with-label (function (_ @handler)) + (|>> (_.try @from @to @handler "java.lang.Exception") + (_.label @from) + unsafeI + someI + _.ARETURN + (_.label @to) + (_.label @handler) + noneI + _.ARETURN))) + +(def: #export string-concatI + Inst + (_.INVOKEVIRTUAL "java.lang.String" "concat" ($t.method (list $String) (#.Some $String) (list)) #0)) + +(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 Method) + ($t.method (list.repeat arity $Object) (#.Some $Object) (list))) + +(def: adt-methods + Def + (let [store-tagI (|>> _.DUP (_.int +0) (_.ILOAD 0) (_.wrap #$.Int) _.AASTORE) + store-flagI (|>> _.DUP (_.int +1) (_.ALOAD 1) _.AASTORE) + store-valueI (|>> _.DUP (_.int +2) (_.ALOAD 2) _.AASTORE)] + (|>> ($d.method #$.Public $.staticM "variant_make" + ($t.method (list $t.int $Object $Object) + (#.Some $Variant) + (list)) + (|>> (_.int +3) + (_.array $Object) + store-tagI + store-flagI + store-valueI + _.ARETURN))))) + +(def: frac-shiftI Inst (_.double (math.pow +32.0 +2.0))) + +(def: frac-methods + Def + (|>> ($d.method #$.Public $.staticM "decode_frac" ($t.method (list $String) (#.Some $Object-Array) (list)) + (try-methodI + (|>> (_.ALOAD 0) + (_.INVOKESTATIC "java.lang.Double" "parseDouble" ($t.method (list $String) (#.Some $t.double) (list)) #0) + (_.wrap #$.Double)))) + )) + +(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 ($t.descriptor $Tuple))) + recurI (: (-> Label Inst) + (function (_ @loop) + (|>> sub-leftsI (_.ISTORE 1) + sub-tupleI (_.ASTORE 0) + (_.GOTO @loop))))] + (|>> ($d.method #$.Public $.staticM "pm_fail" ($t.method (list) #.None (list)) + (|>> (_.NEW "java.lang.IllegalStateException") + _.DUP + (_.string "Invalid expression for pattern-matching.") + (_.INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t.method (list $String) #.None (list)) #0) + _.ATHROW)) + ($d.method #$.Public $.staticM "apply_fail" ($t.method (list) #.None (list)) + (|>> (_.NEW "java.lang.IllegalStateException") + _.DUP + (_.string "Error while applying function.") + (_.INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t.method (list $String) #.None (list)) #0) + _.ATHROW)) + ($d.method #$.Public $.staticM "pm_push" ($t.method (list $Stack $Object) (#.Some $Stack) (list)) + (|>> (_.int +2) + (_.ANEWARRAY "java.lang.Object") + _.DUP + (_.int +0) + (_.ALOAD 0) + _.AASTORE + _.DUP + (_.int +1) + (_.ALOAD 1) + _.AASTORE + _.ARETURN)) + ($d.method #$.Public $.staticM "pm_pop" ($t.method (list $Stack) (#.Some $Stack) (list)) + (|>> (_.ALOAD 0) + (_.int +0) + _.AALOAD + (_.CHECKCAST ($t.descriptor $Stack)) + _.ARETURN)) + ($d.method #$.Public $.staticM "pm_peek" ($t.method (list $Stack) (#.Some $Object) (list)) + (|>> (_.ALOAD 0) + (_.int +1) + _.AALOAD + _.ARETURN)) + ($d.method #$.Public $.staticM "pm_variant" ($t.method (list $Variant $Tag $Flag) (#.Some $Object) (list)) + (<| _.with-label (function (_ @loop)) + _.with-label (function (_ @just-return)) + _.with-label (function (_ @then)) + _.with-label (function (_ @further)) + _.with-label (function (_ @shorten)) + _.with-label (function (_ @wrong)) + (let [variant-partI (: (-> Nat Inst) + (function (_ idx) + (|>> (_.int (.int idx)) _.AALOAD))) + tagI (: Inst + (|>> (variant-partI 0) (_.unwrap #$.Int))) + flagI (variant-partI 1) + datumI (variant-partI 2) + shortenI (|>> (_.ALOAD 0) tagI ## Get tag + (_.ILOAD 1) _.ISUB ## Shorten tag + (_.ALOAD 0) flagI ## Get flag + (_.ALOAD 0) datumI ## Get value + variantI ## Build sum + _.ARETURN) + update-tagI (|>> _.ISUB (_.ISTORE 1)) + update-variantI (|>> (_.ALOAD 0) datumI (_.CHECKCAST ($t.descriptor $Variant)) (_.ASTORE 0)) + failureI (|>> _.NULL _.ARETURN) + return-datumI (|>> (_.ALOAD 0) datumI _.ARETURN)]) + (|>> (_.label @loop) + (_.ILOAD 1) ## tag + (_.ALOAD 0) tagI ## tag, sumT + _.DUP2 (_.IF_ICMPEQ @then) + _.DUP2 (_.IF_ICMPGT @further) + _.DUP2 (_.IF_ICMPLT @shorten) + ## _.POP2 + failureI + (_.label @then) ## tag, sumT + (_.ALOAD 2) ## tag, sumT, wants-last? + (_.ALOAD 0) flagI ## tag, sumT, wants-last?, is-last? + (_.IF_ACMPEQ @just-return) ## tag, sumT + (_.label @further) ## tag, sumT + (_.ALOAD 0) flagI ## tag, sumT, last? + (_.IFNULL @wrong) ## tag, sumT + update-tagI + update-variantI + (_.GOTO @loop) + (_.label @just-return) ## tag, sumT + ## _.POP2 + return-datumI + (_.label @shorten) ## tag, sumT + (_.ALOAD 2) (_.IFNULL @wrong) + ## _.POP2 + shortenI + (_.label @wrong) ## tag, sumT + ## _.POP2 + failureI))) + ($d.method #$.Public $.staticM "tuple_left" ($t.method (list $Tuple $t.int) (#.Some $Object) (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" ($t.method (list $Tuple $t.int) (#.Some $Object) (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 "java.util.Arrays" "copyOfRange" + ($t.method (list $Object-Array $t.int $t.int) + (#.Some $Object-Array) + (list)) + #0))]) + (|>> (_.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: io-methods + Def + (let [string-writerI (|>> (_.NEW "java.io.StringWriter") + _.DUP + (_.INVOKESPECIAL "java.io.StringWriter" "<init>" ($t.method (list) #.None (list)) #0)) + print-writerI (|>> (_.NEW "java.io.PrintWriter") + _.SWAP + _.DUP2 + _.POP + _.SWAP + (_.boolean #1) + (_.INVOKESPECIAL "java.io.PrintWriter" "<init>" ($t.method (list ($t.class "java.io.Writer" (list)) $t.boolean) #.None (list)) #0) + )] + (|>> ($d.method #$.Public $.staticM "try" ($t.method (list $Function) (#.Some $Variant) (list)) + (<| _.with-label (function (_ @from)) + _.with-label (function (_ @to)) + _.with-label (function (_ @handler)) + (|>> (_.try @from @to @handler "java.lang.Throwable") + (_.label @from) + (_.ALOAD 0) + _.NULL + (_.INVOKEVIRTUAL //.function-class apply-method (apply-signature 1) #0) + rightI + _.ARETURN + (_.label @to) + (_.label @handler) + string-writerI ## TW + _.DUP2 ## TWTW + print-writerI ## TWTP + (_.INVOKEVIRTUAL "java.lang.Throwable" "printStackTrace" ($t.method (list ($t.class "java.io.PrintWriter" (list))) #.None (list)) #0) ## TW + (_.INVOKEVIRTUAL "java.io.StringWriter" "toString" ($t.method (list) (#.Some $String) (list)) #0) ## TS + _.SWAP _.POP leftI + _.ARETURN))) + ))) + +(def: translate-runtime + (Operation ByteCode) + (let [bytecode ($d.class #$.V1_6 #$.Public $.finalC //.runtime-class (list) ["java.lang.Object" (list)] (list) + (|>> adt-methods + frac-methods + pm-methods + io-methods))] + (do phase.monad + [_ (generation.execute! //.runtime-class [//.runtime-class bytecode])] + (wrap bytecode)))) + +(def: translate-function + (Operation ByteCode) + (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-class apply-method (apply-signature (dec arity)) #0) + (_.CHECKCAST //.function-class) + (_.ALOAD arity) + (_.INVOKEVIRTUAL //.function-class apply-method (apply-signature 1) #0) + _.ARETURN))))) + (list& ($d.abstract-method #$.Public $.noneM apply-method (apply-signature 1))) + $d.fuse) + bytecode ($d.abstract #$.V1_6 #$.Public $.noneC //.function-class (list) ["java.lang.Object" (list)] (list) + (|>> ($d.field #$.Public $.finalF partials-field $t.int) + ($d.method #$.Public $.noneM "<init>" ($t.method (list $t.int) #.None (list)) + (|>> (_.ALOAD 0) + (_.INVOKESPECIAL "java.lang.Object" "<init>" ($t.method (list) #.None (list)) #0) + (_.ALOAD 0) + (_.ILOAD 1) + (_.PUTFIELD //.function-class partials-field $t.int) + _.RETURN)) + applyI))] + (do phase.monad + [_ (generation.execute! //.function-class [//.function-class bytecode])] + (wrap bytecode)))) + +(def: #export translate + (Operation Any) + (do phase.monad + [runtime-bc translate-runtime + function-bc translate-function] + (wrap []))) |