(;module: lux (lux (control monad) (data ["R" result] text/format) [macro #+ Monad "Lux/" Monad] [host #+ jvm-import do-to]) (luxc ["&" base] (lang ["la" analysis] ["ls" synthesis]) ["&;" analyser] ["&;" synthesizer] (generator ["&;" common] (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst]))))) (jvm-import java.lang.Object) (jvm-import java.lang.String) (jvm-import java.lang.reflect.Field (get [Object] #try Object)) (jvm-import (java.lang.Class a) (getField [String] Field)) (jvm-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)) (jvm-import org.objectweb.asm.ClassWriter (#static COMPUTE_MAXS int) (new [int]) (visit [int int String String String (Array String)] void) (visitEnd [] void) (toByteArray [] Byte-Array)) (def: #export runtime-name Text "LuxRuntime") (def: #export function-name Text "LuxFunction") (def: #export unit Text "\u0000") (def: $Object $;Type ($t;class "java.lang.Object" (list))) (def: 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: add-adt-methods $;Def (let [store-tag (|>. $i;DUP ($i;int 0) ($i;ILOAD +0) $i;wrap-int $i;AASTORE) store-flag (|>. $i;DUP ($i;int 1) ($i;ALOAD +1) $i;AASTORE) store-value (|>. $i;DUP ($i;int 2) ($i;ALOAD +2) $i;AASTORE)] (|>. ($d;method #$;Public $;staticM "sum_make" ($t;method (list $t;int $Object $Object) (#;Some ($t;array +1 $Object)) (list)) (|>. ($i;array $Object +3) store-tag store-flag store-value $i;ARETURN))))) (def: add-nat-methods $;Def (let [compare-nat-method ($t;method (list $t;long $t;long) (#;Some $t;int) (list)) less-thanI (function [@where] (|>. ($i;INVOKESTATIC runtime-name "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 runtime-name "_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: init-method $;Method ($t;method (list) #;None (list))) (def: #export generate (Lux &common;Bytecode) (do Monad [_ (wrap []) #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-name (list) ["java.lang.Object" (list)] (list) (|>. add-adt-methods add-nat-methods ))] _ (&common;store-class runtime-name bytecode)] (wrap bytecode)))