From 012f6bd41e527479dddbccbdab10daa78fd9a0fd Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 1 Nov 2017 00:51:45 -0400 Subject: - Re-organized code-generation, and re-named it "translation". --- new-luxc/source/luxc/generator/runtime.jvm.lux | 608 ------------------------- 1 file changed, 608 deletions(-) delete mode 100644 new-luxc/source/luxc/generator/runtime.jvm.lux (limited to 'new-luxc/source/luxc/generator/runtime.jvm.lux') diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux deleted file mode 100644 index 4b57e802e..000000000 --- a/new-luxc/source/luxc/generator/runtime.jvm.lux +++ /dev/null @@ -1,608 +0,0 @@ -(;module: - lux - (lux (control monad) - (data text/format - (coll [list "list/" Functor])) - [math] - [meta] - [host]) - (luxc ["&" base] - [";L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - (lang ["la" analysis] - ["ls" synthesis]) - (generator ["&;" 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" "" ($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)) - 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" "" ($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: generate-runtime - (Meta &common;Bytecode) - (do meta;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 - pm-methods - io-methods))] - _ (&common;store-class hostL;runtime-class bytecode)] - (wrap bytecode))) - -(def: generate-function - (Meta &common;Bytecode) - (do meta;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))] - _ (&common;store-class hostL;function-class bytecode)] - (wrap bytecode))) - -(def: #export generate - (Meta [&common;Bytecode &common;Bytecode]) - (do meta;Monad - [runtime-bc generate-runtime - function-bc generate-function] - (wrap [runtime-bc function-bc]))) -- cgit v1.2.3