(;module: lux (lux (control monad) (data ["R" error] text/format (coll [list "L/" Functor])) [math] [meta #+ Monad "Meta/" Monad] [host #+ do-to]) (luxc ["&" base] (lang ["la" analysis] ["ls" synthesis]) ["&;" analyser] ["&;" synthesizer] (generator ["&;" common] (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst]))))) (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: #export runtime-class Text "LuxRuntime") (def: #export function-class Text "LuxFunction") (def: #export unit Text "\u0000") (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 ($t;array +1 $Object)) (def: #export $Variant $;Type ($t;array +1 $Object)) (def: #export $Tag $;Type $t;int) (def: #export $Flag $;Type $Object) (def: #export $Datum $;Type $Object) (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: variant-makeI $;Inst ($i;INVOKESTATIC runtime-class "variant_make" variant-method false)) (def: #export someI $;Inst (|>. ($i;int 1) ($i;string "") $i;DUP2_X1 $i;POP2 variant-makeI)) (def: #export noneI $;Inst (|>. ($i;int 0) $i;NULL ($i;string unit) variant-makeI)) (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)] (|>. ($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: 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-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 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 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 $Stack $t;int $Object) (#;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 variant-makeI ## 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: generate-runtime (Meta &common;Bytecode) (do Monad [_ (wrap []) #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-class (list) ["java.lang.Object" (list)] (list) (|>. adt-methods nat-methods frac-methods deg-methods pm-methods))] _ (&common;store-class runtime-class bytecode)] (wrap bytecode))) (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: generate-function (Meta &common;Bytecode) (do Monad [_ (wrap []) #let [applyI (|> (list;n.range +2 num-apply-variants) (L/map (function [arity] ($d;method #$;Public $;noneM apply-method (apply-signature arity) (let [preI (|> (list;n.range +0 (n.dec arity)) (L/map $i;ALOAD) $i;fuse)] (|>. preI ($i;INVOKEVIRTUAL function-class apply-method (apply-signature (n.dec arity)) false) ($i;CHECKCAST function-class) ($i;ALOAD arity) ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false) $i;ARETURN))))) (list& ($d;abstract-method #$;Public $;noneM apply-method (apply-signature +1)) ## ($d;method #$;Public $;noneM apply-method (apply-signature +1) ## (|>. $i;NULL ## $i;ARETURN)) ) $d;fuse) bytecode ($d;abstract #$;V1.6 #$;Public $;noneC 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 function-class partials-field $t;int) $i;RETURN)) applyI))] _ (&common;store-class function-class bytecode)] (wrap bytecode))) (def: #export generate (Meta [&common;Bytecode &common;Bytecode]) (do Monad [runtime-bc generate-runtime function-bc generate-function] (wrap [runtime-bc function-bc])))