diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/runtime.jvm.lux')
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/runtime.jvm.lux | 608 |
1 files changed, 608 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/translation/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/runtime.jvm.lux new file mode 100644 index 000000000..e5d237fc7 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/runtime.jvm.lux @@ -0,0 +1,608 @@ +(;module: + lux + (lux (control monad) + (data text/format + (coll [list "list/" Functor<List>])) + [math] + [meta] + [host]) + (luxc ["&" base] + [";L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + (lang ["la" analysis] + ["ls" synthesis] + (translation [";T" common])))) + +(host;import java.lang.Object) +(host;import java.lang.String) + +(host;import java.lang.reflect.Field + (get [Object] #try Object)) + +(host;import (java.lang.Class a) + (getField [String] Field)) + +(host;import org.objectweb.asm.Opcodes + (#static ACC_PUBLIC int) + (#static ACC_SUPER int) + (#static ACC_FINAL int) + (#static ACC_STATIC int) + (#static V1_6 int)) + +(host;import org.objectweb.asm.ClassWriter + (#static COMPUTE_MAXS int) + (new [int]) + (visit [int int String String String (Array String)] void) + (visitEnd [] void) + (toByteArray [] (Array byte))) + +(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 hostL;function-class (list))) +(def: $Throwable $;Type ($t;class "java.lang.Throwable" (list))) + +(def: #export logI + $;Inst + (let [outI ($i;GETSTATIC "java.lang.System" "out" ($t;class "java.io.PrintStream" (list))) + printI (function [method] ($i;INVOKEVIRTUAL "java.io.PrintStream" method ($t;method (list $Object) #;None (list)) false))] + (|>. outI ($i;string "LOG: ") (printI "print") + outI $i;SWAP (printI "println")))) + +(def: variant-method + $;Method + ($t;method (list $t;int $Object $Object) (#;Some $Object-Array) (list))) + +(def: variantI + $;Inst + ($i;INVOKESTATIC hostL;runtime-class "variant_make" variant-method false)) + +(def: #export leftI + $;Inst + (|>. ($i;int 0) + $i;NULL + $i;DUP2_X1 + $i;POP2 + variantI)) + +(def: #export rightI + $;Inst + (|>. ($i;int 1) + ($i;string "") + $i;DUP2_X1 + $i;POP2 + variantI)) + +(def: #export someI $;Inst rightI) + +(def: #export noneI + $;Inst + (|>. ($i;int 0) + $i;NULL + ($i;string hostL;unit) + variantI)) + +(def: #export string-concatI + $;Inst + ($i;INVOKEVIRTUAL "java.lang.String" "concat" ($t;method (list $String) (#;Some $String) (list)) false)) + +(def: #export partials-field Text "partials") +(def: #export apply-method Text "apply") +(def: #export num-apply-variants Nat +8) + +(def: #export (apply-signature arity) + (-> ls;Arity $;Method) + ($t;method (list;repeat arity $Object) (#;Some $Object) (list))) + +(def: adt-methods + $;Def + (let [store-tagI (|>. $i;DUP ($i;int 0) ($i;ILOAD +0) ($i;wrap #$;Int) $i;AASTORE) + store-flagI (|>. $i;DUP ($i;int 1) ($i;ALOAD +1) $i;AASTORE) + store-valueI (|>. $i;DUP ($i;int 2) ($i;ALOAD +2) $i;AASTORE) + force-textMT ($t;method (list $Object) (#;Some $String) (list))] + (|>. ($d;method #$;Public $;staticM "force_text" force-textMT + (<| $i;with-label (function [@is-null]) + $i;with-label (function [@normal-object]) + $i;with-label (function [@array-loop]) + $i;with-label (function [@within-bounds]) + $i;with-label (function [@is-first]) + $i;with-label (function [@elem-end]) + $i;with-label (function [@fold-end]) + (let [on-normal-objectI (|>. ($i;ALOAD +0) + ($i;INVOKEVIRTUAL "java.lang.Object" "toString" ($t;method (list) (#;Some $String) (list)) false)) + on-null-objectI ($i;string "NULL") + arrayI (|>. ($i;ALOAD +0) + ($i;CHECKCAST ($t;descriptor $Object-Array))) + recurseI ($i;INVOKESTATIC hostL;runtime-class "force_text" force-textMT false) + force-elemI (|>. $i;DUP arrayI $i;SWAP $i;AALOAD recurseI) + swap2 (|>. $i;DUP2_X2 ## X,Y => Y,X,Y + $i;POP2 ## Y,X,Y => Y,X + ) + add-spacingI (|>. ($i;string ", ") $i;SWAP string-concatI) + merge-with-totalI (|>. $i;DUP_X2 $i;POP ## TSIP => TPSI + swap2 ## TPSI => SITP + string-concatI ## SITP => SIT + $i;DUP_X2 $i;POP ## SIT => TSI + ) + foldI (|>. $i;DUP ## TSI => TSII + ($i;IFEQ @is-first) ## TSI + force-elemI add-spacingI merge-with-totalI ($i;GOTO @elem-end) + ($i;label @is-first) ## TSI + force-elemI merge-with-totalI + ($i;label @elem-end) ## TSI + ) + inc-idxI (|>. ($i;int 1) $i;IADD) + on-array-objectI (|>. ($i;string "[") ## T + arrayI $i;ARRAYLENGTH ## TS + ($i;int 0) ## TSI + ($i;label @array-loop) ## TSI + $i;DUP2 + ($i;IF_ICMPGT @within-bounds) ## TSI + $i;POP2 ($i;string "]") string-concatI ($i;GOTO @fold-end) + ($i;label @within-bounds) + foldI inc-idxI ($i;GOTO @array-loop) + ($i;label @fold-end))]) + (|>. ($i;ALOAD +0) + ($i;IFNULL @is-null) + ($i;ALOAD +0) + ($i;INSTANCEOF ($t;descriptor $Object-Array)) + ($i;IFEQ @normal-object) + on-array-objectI $i;ARETURN + ($i;label @normal-object) on-normal-objectI $i;ARETURN + ($i;label @is-null) on-null-objectI $i;ARETURN))) + ($d;method #$;Public $;staticM "variant_make" + ($t;method (list $t;int $Object $Object) + (#;Some $Variant) + (list)) + (|>. ($i;int 3) + ($i;array $Object) + store-tagI + store-flagI + store-valueI + $i;ARETURN))))) + +(def: #export force-textI + $;Inst + ($i;INVOKESTATIC hostL;runtime-class "force_text" ($t;method (list $Object) (#;Some $String) (list)) false)) + +(def: nat-methods + $;Def + (let [compare-nat-method ($t;method (list $t;long $t;long) (#;Some $t;int) (list)) + less-thanI (function [@where] (|>. ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false) ($i;IFLT @where))) + $BigInteger ($t;class "java.math.BigInteger" (list)) + upcast-method ($t;method (list $t;long) (#;Some $BigInteger) (list)) + div-method ($t;method (list $t;long $t;long) (#;Some $t;long) (list)) + upcastI ($i;INVOKESTATIC hostL;runtime-class "_toUnsignedBigInteger" upcast-method false) + downcastI ($i;INVOKEVIRTUAL "java.math.BigInteger" "longValue" ($t;method (list) (#;Some $t;long) (list)) false)] + ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215 + (|>. ($d;method #$;Public $;staticM "_toUnsignedBigInteger" upcast-method + (let [upcastI ($i;INVOKESTATIC "java.math.BigInteger" "valueOf" upcast-method false) + discernI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFGE @where))) + prepare-upperI (|>. ($i;LLOAD +0) ($i;int 32) $i;LUSHR + upcastI + ($i;int 32) ($i;INVOKEVIRTUAL "java.math.BigInteger" "shiftLeft" ($t;method (list $t;int) (#;Some $BigInteger) (list)) false)) + prepare-lowerI (|>. ($i;LLOAD +0) ($i;int 32) $i;LSHL + ($i;int 32) $i;LUSHR + upcastI)] + (<| $i;with-label (function [@simple]) + (|>. (discernI @simple) + ## else + prepare-upperI + prepare-lowerI + ($i;INVOKEVIRTUAL "java.math.BigInteger" "add" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false) + $i;ARETURN + ## then + ($i;label @simple) + ($i;LLOAD +0) + upcastI + $i;ARETURN)))) + ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267 + ($d;method #$;Public $;staticM "compare_nat" compare-nat-method + (let [shiftI (|>. ($i;GETSTATIC "java.lang.Long" "MIN_VALUE" $t;long) $i;LADD)] + (|>. ($i;LLOAD +0) shiftI + ($i;LLOAD +2) shiftI + $i;LCMP + $i;IRETURN))) + ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290 + ($d;method #$;Public $;staticM "div_nat" div-method + (let [is-param-largeI (function [@where] (|>. ($i;LLOAD +2) ($i;long 0) $i;LCMP ($i;IFLT @where))) + is-subject-smallI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFGT @where))) + small-division (|>. ($i;LLOAD +0) ($i;LLOAD +2) $i;LDIV $i;LRETURN) + big-divisionI ($i;INVOKEVIRTUAL "java.math.BigInteger" "divide" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false)] + (<| $i;with-label (function [@is-zero]) + $i;with-label (function [@param-is-large]) + $i;with-label (function [@subject-is-small]) + (|>. (is-param-largeI @param-is-large) + ## Param is not too large + (is-subject-smallI @subject-is-small) + ## Param is small, but subject is large + ($i;LLOAD +0) upcastI + ($i;LLOAD +2) upcastI + big-divisionI downcastI $i;LRETURN + ## Both param and subject are small, + ## and can thus be divided normally. + ($i;label @subject-is-small) + small-division + ## Param is too large. Cannot simply divide. + ## Depending on the result of the + ## comparison, a result will be determined. + ($i;label @param-is-large) + ($i;LLOAD +0) ($i;LLOAD +2) (less-thanI @is-zero) + ## Greater-than or equals + ($i;long 1) $i;LRETURN + ## Less than + ($i;label @is-zero) + ($i;long 0) $i;LRETURN)))) + ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323 + ($d;method #$;Public $;staticM "rem_nat" div-method + (let [is-subject-largeI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFLE @where))) + is-param-largeI (function [@where] (|>. ($i;LLOAD +2) ($i;long 0) $i;LCMP ($i;IFLE @where))) + small-remainderI (|>. ($i;LLOAD +0) ($i;LLOAD +2) $i;LREM $i;LRETURN) + big-remainderI ($i;INVOKEVIRTUAL "java.math.BigInteger" "remainder" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false)] + (<| $i;with-label (function [@large-number]) + $i;with-label (function [@subject-is-smaller-than-param]) + (|>. (is-subject-largeI @large-number) + (is-param-largeI @large-number) + small-remainderI + + ($i;label @large-number) + ($i;LLOAD +0) ($i;LLOAD +2) (less-thanI @subject-is-smaller-than-param) + + ($i;LLOAD +0) upcastI + ($i;LLOAD +2) upcastI + big-remainderI downcastI $i;LRETURN + + ($i;label @subject-is-smaller-than-param) + ($i;LLOAD +0) + $i;LRETURN)))) + ))) + +(def: frac-shiftI $;Inst ($i;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)) + (<| $i;with-label (function [@from]) + $i;with-label (function [@to]) + $i;with-label (function [@handler]) + (|>. ($i;try @from @to @handler "java.lang.Exception") + ($i;label @from) + ($i;ALOAD +0) + ($i;INVOKESTATIC "java.lang.Double" "parseDouble" ($t;method (list $String) (#;Some $t;double) (list)) false) + ($i;wrap #$;Double) + someI + $i;ARETURN + ($i;label @to) + ($i;label @handler) + noneI + $i;ARETURN))) + ($d;method #$;Public $;staticM "frac_to_deg" ($t;method (list $t;double) (#;Some $t;long) (list)) + (let [swap2 (|>. $i;DUP2_X2 $i;POP2) + drop-excessI (|>. ($i;double 1.0) $i;DREM) + shiftI (|>. frac-shiftI $i;DMUL)] + (|>. ($i;DLOAD +0) + ## Get upper half + drop-excessI + shiftI + ## Make a copy, so the lower half can be extracted + $i;DUP2 + ## Get lower half + drop-excessI + shiftI + ## Turn it into a deg + $i;D2L + ## Turn the upper half into deg too + swap2 + $i;D2L + ## Combine both pieces + $i;LADD + ## FINISH + $i;LRETURN + ))) + )) + +(def: deg-bits Nat +64) +(def: deg-method $;Method ($t;method (list $t;long $t;long) (#;Some $t;long) (list))) +(def: clz-method $;Method ($t;method (list $t;long) (#;Some $t;int) (list))) + +(def: deg-methods + $;Def + (let [## "And" mask corresponding to -1 (FFFF...), on the low 32 bits. + low-half (|>. ($i;int -1) $i;I2L $i;LAND) + high-half (|>. ($i;int 32) $i;LUSHR)] + (|>. ($d;method #$;Public $;staticM "mul_deg" deg-method + ## Based on: http://stackoverflow.com/a/31629280/6823464 + (let [shift-downI (|>. ($i;int 32) $i;LUSHR) + low-leftI (|>. ($i;LLOAD +0) low-half) + high-leftI (|>. ($i;LLOAD +0) high-half) + low-rightI (|>. ($i;LLOAD +2) low-half) + high-rightI (|>. ($i;LLOAD +2) high-half) + bottomI (|>. low-leftI low-rightI $i;LMUL) + middleLI (|>. high-leftI low-rightI $i;LMUL) + middleRI (|>. low-leftI high-rightI $i;LMUL) + middleI (|>. middleLI middleRI $i;LADD) + topI (|>. high-leftI high-rightI $i;LMUL)] + (|>. bottomI shift-downI + middleI $i;LADD shift-downI + topI $i;LADD + $i;LRETURN))) + ($d;method #$;Public $;staticM "count_leading_zeros" clz-method + (let [when-zeroI (function [@where] (|>. ($i;long 0) $i;LCMP ($i;IFEQ @where))) + shift-rightI (function [amount] (|>. ($i;int amount) $i;LUSHR)) + decI (|>. ($i;int 1) $i;ISUB)] + (<| $i;with-label (function [@start]) + $i;with-label (function [@done]) + (|>. ($i;int 64) + ($i;label @start) + ($i;LLOAD +0) (when-zeroI @done) + ($i;LLOAD +0) (shift-rightI 1) ($i;LSTORE +0) + decI + ($i;GOTO @start) + ($i;label @done) + $i;IRETURN)))) + ($d;method #$;Public $;staticM "div_deg" deg-method + (<| $i;with-label (function [@same]) + (let [subjectI ($i;LLOAD +0) + paramI ($i;LLOAD +2) + equal?I (function [@where] (|>. $i;LCMP ($i;IFEQ @where))) + count-leading-zerosI ($i;INVOKESTATIC hostL;runtime-class "count_leading_zeros" clz-method false) + calc-max-shiftI (|>. subjectI count-leading-zerosI + paramI count-leading-zerosI + ($i;INVOKESTATIC "java.lang.Math" "min" ($t;method (list $t;int $t;int) (#;Some $t;int) (list)) false) + ($i;ISTORE +4)) + shiftI (|>. ($i;ILOAD +4) $i;LSHL) + imprecise-divisionI (|>. subjectI shiftI + paramI shiftI high-half + $i;LDIV) + scale-downI (|>. ($i;int 32) $i;LSHL)] + (|>. subjectI paramI + (equal?I @same) + ## Based on: http://stackoverflow.com/a/8510587/6823464 + ## Shifting the operands as much as possible can help + ## avoid some loss of precision later. + calc-max-shiftI + imprecise-divisionI + scale-downI + $i;LRETURN + ($i;label @same) + ($i;long -1) ## ~= 1.0 Degrees + $i;LRETURN)))) + ($d;method #$;Public $;staticM "deg_to_frac" ($t;method (list $t;long) (#;Some $t;double) (list)) + (let [highI (|>. ($i;LLOAD +0) high-half $i;L2D) + lowI (|>. ($i;LLOAD +0) low-half $i;L2D) + scaleI (|>. frac-shiftI $i;DDIV)] + (|>. highI scaleI + lowI scaleI scaleI + $i;DADD + $i;DRETURN))) + ))) + +(def: pm-methods + $;Def + (let [tuple-sizeI (|>. ($i;ALOAD +0) $i;ARRAYLENGTH) + tuple-elemI (|>. ($i;ALOAD +0) ($i;ILOAD +1) $i;AALOAD) + expected-last-sizeI (|>. ($i;ILOAD +1) ($i;int 1) $i;IADD) + tuple-tailI (|>. ($i;ALOAD +0) tuple-sizeI ($i;int 1) $i;ISUB $i;AALOAD ($i;CHECKCAST ($t;descriptor $Tuple)))] + (|>. ($d;method #$;Public $;staticM "pm_fail" ($t;method (list) #;None (list)) + (|>. ($i;NEW "java.lang.IllegalStateException") + $i;DUP + ($i;string "Invalid expression for pattern-matching.") + ($i;INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t;method (list $String) #;None (list)) false) + $i;ATHROW)) + ($d;method #$;Public $;staticM "apply_fail" ($t;method (list) #;None (list)) + (|>. ($i;NEW "java.lang.IllegalStateException") + $i;DUP + ($i;string "Error while applying function.") + ($i;INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t;method (list $String) #;None (list)) false) + $i;ATHROW)) + ($d;method #$;Public $;staticM "pm_push" ($t;method (list $Stack $Object) (#;Some $Stack) (list)) + (|>. ($i;int 2) + ($i;ANEWARRAY "java.lang.Object") + $i;DUP + ($i;int 0) + ($i;ALOAD +0) + $i;AASTORE + $i;DUP + ($i;int 1) + ($i;ALOAD +1) + $i;AASTORE + $i;ARETURN)) + ($d;method #$;Public $;staticM "pm_pop" ($t;method (list $Stack) (#;Some $Stack) (list)) + (|>. ($i;ALOAD +0) + ($i;int 0) + $i;AALOAD + ($i;CHECKCAST ($t;descriptor $Stack)) + $i;ARETURN)) + ($d;method #$;Public $;staticM "pm_peek" ($t;method (list $Stack) (#;Some $Object) (list)) + (|>. ($i;ALOAD +0) + ($i;int 1) + $i;AALOAD + $i;ARETURN)) + ($d;method #$;Public $;staticM "pm_variant" ($t;method (list $Variant $Tag $Flag) (#;Some $Object) (list)) + (<| $i;with-label (function [@begin]) + $i;with-label (function [@just-return]) + $i;with-label (function [@then]) + $i;with-label (function [@further]) + $i;with-label (function [@shorten]) + $i;with-label (function [@wrong]) + (let [variant-partI (: (-> Nat $;Inst) + (function [idx] + (|>. ($i;int (nat-to-int idx)) $i;AALOAD))) + tagI (: $;Inst + (|>. (variant-partI +0) ($i;unwrap #$;Int))) + flagI (variant-partI +1) + datumI (variant-partI +2) + shortenI (|>. ($i;ALOAD +0) tagI ## Get tag + ($i;ILOAD +1) $i;ISUB ## Shorten tag + ($i;ALOAD +0) flagI ## Get flag + ($i;ALOAD +0) datumI ## Get value + variantI ## Build sum + $i;ARETURN) + update-tagI (|>. $i;ISUB ($i;ISTORE +1)) + update-variantI (|>. ($i;ALOAD +0) datumI ($i;CHECKCAST ($t;descriptor $Variant)) ($i;ASTORE +0)) + wrongI (|>. $i;NULL $i;ARETURN) + return-datumI (|>. ($i;ALOAD +0) datumI $i;ARETURN)]) + (|>. ($i;label @begin) + ($i;ILOAD +1) ## tag + ($i;ALOAD +0) tagI ## tag, sumT + $i;DUP2 ($i;IF_ICMPEQ @then) + $i;DUP2 ($i;IF_ICMPGT @further) + $i;DUP2 ($i;IF_ICMPLT @shorten) + ## $i;POP2 + wrongI + ($i;label @then) ## tag, sumT + ($i;ALOAD +2) ## tag, sumT, wants-last? + ($i;ALOAD +0) flagI ## tag, sumT, wants-last?, is-last? + ($i;IF_ACMPEQ @just-return) ## tag, sumT + ($i;label @further) ## tag, sumT + ($i;ALOAD +0) flagI ## tag, sumT, last? + ($i;IFNULL @wrong) ## tag, sumT + update-tagI + update-variantI + ($i;GOTO @begin) + ($i;label @just-return) ## tag, sumT + ## $i;POP2 + return-datumI + ($i;label @shorten) ## tag, sumT + ($i;ALOAD +2) ($i;IFNULL @wrong) + ## $i;POP2 + shortenI + ($i;label @wrong) ## tag, sumT + ## $i;POP2 + wrongI))) + ($d;method #$;Public $;staticM "pm_left" ($t;method (list $Tuple $t;int) (#;Some $Object) (list)) + (<| $i;with-label (function [@begin]) + $i;with-label (function [@not-recursive]) + (let [updated-idxI (|>. $i;SWAP $i;ISUB)]) + (|>. ($i;label @begin) + tuple-sizeI + expected-last-sizeI + $i;DUP2 ($i;IF_ICMPGT @not-recursive) + ## Recursive + updated-idxI ($i;ISTORE +1) + tuple-tailI ($i;ASTORE +0) + ($i;GOTO @begin) + ($i;label @not-recursive) + ## $i;POP2 + tuple-elemI + $i;ARETURN))) + ($d;method #$;Public $;staticM "pm_right" ($t;method (list $Tuple $t;int) (#;Some $Object) (list)) + (<| $i;with-label (function [@begin]) + $i;with-label (function [@tail]) + $i;with-label (function [@slice]) + (let [updated-idxI (|>. ($i;ILOAD +1) ($i;int 1) $i;IADD tuple-sizeI $i;ISUB) + sliceI (|>. ($i;ALOAD +0) ($i;ILOAD +1) tuple-sizeI + ($i;INVOKESTATIC "java.util.Arrays" "copyOfRange" ($t;method (list $Object-Array $t;int $t;int) (#;Some $Object-Array) (list)) false))]) + (|>. ($i;label @begin) + tuple-sizeI + expected-last-sizeI + $i;DUP2 ($i;IF_ICMPEQ @tail) + ($i;IF_ICMPGT @slice) + ## Must recurse + tuple-tailI ($i;ASTORE +0) + updated-idxI ($i;ISTORE +1) + ($i;GOTO @begin) + ($i;label @slice) + sliceI + $i;ARETURN + ($i;label @tail) + ## $i;POP2 + tuple-elemI + $i;ARETURN))) + ))) + +(def: io-methods + $;Def + (let [string-writerI (|>. ($i;NEW "java.io.StringWriter") + $i;DUP + ($i;INVOKESPECIAL "java.io.StringWriter" "<init>" ($t;method (list) #;None (list)) false)) + print-writerI (|>. ($i;NEW "java.io.PrintWriter") + $i;SWAP + $i;DUP2 + $i;POP + $i;SWAP + ($i;boolean true) + ($i;INVOKESPECIAL "java.io.PrintWriter" "<init>" ($t;method (list ($t;class "java.io.Writer" (list)) $t;boolean) #;None (list)) false) + )] + (|>. ($d;method #$;Public $;staticM "try" ($t;method (list $Function) (#;Some $Variant) (list)) + (<| $i;with-label (function [@from]) + $i;with-label (function [@to]) + $i;with-label (function [@handler]) + (|>. ($i;try @from @to @handler "java.lang.Throwable") + ($i;label @from) + ($i;ALOAD +0) + $i;NULL + ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature +1) false) + rightI + $i;ARETURN + ($i;label @to) + ($i;label @handler) + string-writerI ## TW + $i;DUP2 ## TWTW + print-writerI ## TWTP + ($i;INVOKEVIRTUAL "java.lang.Throwable" "printStackTrace" ($t;method (list ($t;class "java.io.PrintWriter" (list))) #;None (list)) false) ## TW + ($i;INVOKEVIRTUAL "java.io.StringWriter" "toString" ($t;method (list) (#;Some $String) (list)) false) ## TS + $i;SWAP $i;POP leftI + $i;ARETURN))) + ))) + +(def: generate-runtime + (Meta commonT;Bytecode) + (do meta;Monad<Meta> + [_ (wrap []) + #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC hostL;runtime-class (list) ["java.lang.Object" (list)] (list) + (|>. adt-methods + nat-methods + frac-methods + deg-methods + pm-methods + io-methods))] + _ (commonT;store-class hostL;runtime-class bytecode)] + (wrap bytecode))) + +(def: generate-function + (Meta commonT;Bytecode) + (do meta;Monad<Meta> + [_ (wrap []) + #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 (n.dec arity)) + (list/map $i;ALOAD) + $i;fuse)] + (|>. preI + ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature (n.dec arity)) false) + ($i;CHECKCAST hostL;function-class) + ($i;ALOAD arity) + ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature +1) false) + $i;ARETURN))))) + (list& ($d;abstract-method #$;Public $;noneM apply-method (apply-signature +1))) + $d;fuse) + bytecode ($d;abstract #$;V1.6 #$;Public $;noneC hostL;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)) + (|>. ($i;ALOAD +0) + ($i;INVOKESPECIAL "java.lang.Object" "<init>" ($t;method (list) #;None (list)) false) + ($i;ALOAD +0) + ($i;ILOAD +1) + ($i;PUTFIELD hostL;function-class partials-field $t;int) + $i;RETURN)) + applyI))] + _ (commonT;store-class hostL;function-class bytecode)] + (wrap bytecode))) + +(def: #export generate + (Meta [commonT;Bytecode commonT;Bytecode]) + (do meta;Monad<Meta> + [runtime-bc generate-runtime + function-bc generate-function] + (wrap [runtime-bc function-bc]))) |