aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/generator/runtime.jvm.lux
diff options
context:
space:
mode:
authorEduardo Julian2017-11-01 00:51:45 -0400
committerEduardo Julian2017-11-01 00:51:45 -0400
commit012f6bd41e527479dddbccbdab10daa78fd9a0fd (patch)
tree621f344a09acd52736f343d94582b3f1a2f0c5f9 /new-luxc/source/luxc/generator/runtime.jvm.lux
parent71d7a4c7206155e09f3e1e1d8699561ea6967382 (diff)
- Re-organized code-generation, and re-named it "translation".
Diffstat (limited to 'new-luxc/source/luxc/generator/runtime.jvm.lux')
-rw-r--r--new-luxc/source/luxc/generator/runtime.jvm.lux608
1 files changed, 0 insertions, 608 deletions
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<List>]))
- [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" "<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 &common;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))]
- _ (&common;store-class hostL;runtime-class bytecode)]
- (wrap bytecode)))
-
-(def: generate-function
- (Meta &common;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))]
- _ (&common;store-class hostL;function-class bytecode)]
- (wrap bytecode)))
-
-(def: #export generate
- (Meta [&common;Bytecode &common;Bytecode])
- (do meta;Monad<Meta>
- [runtime-bc generate-runtime
- function-bc generate-function]
- (wrap [runtime-bc function-bc])))