From 9eaaaf953ba7ce1eeb805603f4e113aa15f5178f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 8 Jan 2018 21:40:06 -0400 Subject: - Moved all translation code under the JVM path (in preparation for porting the JS back-end). --- .../luxc/lang/translation/jvm/runtime.jvm.lux | 603 +++++++++++++++++++++ 1 file changed, 603 insertions(+) create mode 100644 new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux (limited to 'new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux') diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux new file mode 100644 index 000000000..87a47f338 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux @@ -0,0 +1,603 @@ +(.module: + lux + (lux (control monad) + (data text/format + (coll [list "list/" Functor])) + [math] + [macro]) + (luxc ["&" lang] + (lang [".L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["la" analysis] + ["ls" synthesis])) + (// [".T" common])) + +(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: #export 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: (try-methodI unsafeI) + (-> $.Inst $.Inst) + (<| $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) + unsafeI + someI + $i.ARETURN + ($i.label @to) + ($i.label @handler) + noneI + $i.ARETURN))) + +(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)] + (|>> ($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)))) + ($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))) + ($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)))) + ($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)) + (try-methodI + (|>> ($i.ALOAD +0) + ($i.INVOKESTATIC "java.lang.Double" "parseDouble" ($t.method (list $String) (#.Some $t.double) (list)) false) + ($i.wrap #$.Double)))) + ($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: text-methods + $.Def + (|>> ($d.method #$.Public $.staticM "text_clip" ($t.method (list $String $t.int $t.int) (#.Some $Variant) (list)) + (try-methodI + (|>> ($i.ALOAD +0) + ($i.ILOAD +1) + ($i.ILOAD +2) + ($i.INVOKEVIRTUAL "java.lang.String" "substring" ($t.method (list $t.int $t.int) (#.Some $String) (list)) false)))) + ($d.method #$.Public $.staticM "text_char" ($t.method (list $String $t.int) (#.Some $Variant) (list)) + (try-methodI + (|>> ($i.ALOAD +0) + ($i.ILOAD +1) + ($i.INVOKEVIRTUAL "java.lang.String" "codePointAt" ($t.method (list $t.int) (#.Some $t.int) (list)) false) + $i.I2L + ($i.wrap #$.Long)))) + )) + +(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" "" ($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" "" ($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)) + failureI (|>> $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 + failureI + ($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 + failureI))) + ($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" "" ($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" "" ($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: translate-runtime + (Meta commonT.Bytecode) + (do macro.Monad + [_ (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 + text-methods + pm-methods + io-methods))] + _ (commonT.store-class hostL.runtime-class bytecode)] + (wrap bytecode))) + +(def: translate-function + (Meta commonT.Bytecode) + (do macro.Monad + [_ (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 "" ($t.method (list $t.int) #.None (list)) + (|>> ($i.ALOAD +0) + ($i.INVOKESPECIAL "java.lang.Object" "" ($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 translate + (Meta [commonT.Bytecode commonT.Bytecode]) + (do macro.Monad + [runtime-bc translate-runtime + function-bc translate-function] + (wrap [runtime-bc function-bc]))) -- cgit v1.2.3