aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/generator
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/generator')
-rw-r--r--new-luxc/source/luxc/generator/host/jvm/def.lux26
-rw-r--r--new-luxc/source/luxc/generator/host/jvm/inst.lux256
-rw-r--r--new-luxc/source/luxc/generator/procedure/common.jvm.lux12
-rw-r--r--new-luxc/source/luxc/generator/runtime.jvm.lux118
4 files changed, 257 insertions, 155 deletions
diff --git a/new-luxc/source/luxc/generator/host/jvm/def.lux b/new-luxc/source/luxc/generator/host/jvm/def.lux
index 6f0f97d9b..42cfa2d68 100644
--- a/new-luxc/source/luxc/generator/host/jvm/def.lux
+++ b/new-luxc/source/luxc/generator/host/jvm/def.lux
@@ -2,6 +2,7 @@
lux
(lux (data [text]
text/format
+ [product]
(coll ["a" array]
[list "L/" Functor<List>]))
[host #+ jvm-import do-to])
@@ -154,11 +155,11 @@
<flag>
(visibility-flag visibility)
(class-flag config))
- name
+ ($t;binary-name name)
(parameters-signature parameters super interfaces)
- (|> super class-to-type $t;descriptor)
+ (|> super product;left $t;binary-name)
(|> interfaces
- (L/map (|>. class-to-type $t;descriptor))
+ (L/map (|>. product;left $t;binary-name))
string-array)]))
definitions)
_ (ClassWriter.visitEnd [] writer)]
@@ -181,11 +182,11 @@
Opcodes.ACC_INTERFACE
(visibility-flag visibility)
(class-flag config))
- name
+ ($t;binary-name name)
(parameters-signature parameters $Object interfaces)
- (|> $Object class-to-type $t;descriptor)
+ (|> $Object product;left $t;binary-name)
(|> interfaces
- (L/map (|>. class-to-type $t;descriptor))
+ (L/map (|>. product;left $t;binary-name))
string-array)]))
definitions)
_ (ClassWriter.visitEnd [] writer)]
@@ -198,7 +199,7 @@
(let [=method (ClassWriter.visitMethod [($_ i.+
(visibility-flag visibility)
(method-flag config))
- name
+ ($t;binary-name name)
($t;method-descriptor type)
($t;method-signature type)
(exceptions-array type)]
@@ -217,7 +218,7 @@
(visibility-flag visibility)
(method-flag config)
Opcodes.ACC_ABSTRACT)
- name
+ ($t;binary-name name)
($t;method-descriptor type)
($t;method-signature type)
(exceptions-array type)]
@@ -231,7 +232,10 @@
(let [=field (do-to (ClassWriter.visitField [($_ i.+
(visibility-flag visibility)
(field-flag config))
- name ($t;descriptor type) ($t;signature type) (host;null)] writer)
+ ($t;binary-name name)
+ ($t;descriptor type)
+ ($t;signature type)
+ (host;null)] writer)
(FieldVisitor.visitEnd []))]
writer)))
@@ -242,7 +246,9 @@
(let [=field (do-to (ClassWriter.visitField [($_ i.+
(visibility-flag visibility)
(field-flag config))
- name ($t;descriptor <jvm-type>) ($t;signature <jvm-type>)
+ ($t;binary-name name)
+ ($t;descriptor <jvm-type>)
+ ($t;signature <jvm-type>)
(<prepare> value)]
writer)
(FieldVisitor.visitEnd []))]
diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux
index 824598ab8..30148c4e5 100644
--- a/new-luxc/source/luxc/generator/host/jvm/inst.lux
+++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux
@@ -1,6 +1,13 @@
(;module:
[lux #- char]
- (lux [host #+ jvm-import do-to])
+ (lux (control monad
+ ["p" parser])
+ (data text/format
+ (coll [list "L/" Functor<List>]))
+ [host #+ jvm-import do-to]
+ [macro]
+ (macro [code]
+ ["s" syntax #+ syntax:]))
["$" ..]
(.. ["$t" type]))
@@ -8,83 +15,85 @@
(jvm-import #long java.lang.Object)
(jvm-import #long java.lang.String)
-(jvm-import org.objectweb.asm.Opcodes
- (#static T_BOOLEAN int)
- (#static T_CHAR int)
- (#static T_FLOAT int)
- (#static T_DOUBLE int)
- (#static T_BYTE int)
- (#static T_SHORT int)
- (#static T_INT int)
- (#static T_LONG int)
-
- (#static CHECKCAST int)
- (#static NEW int)
- (#static NEWARRAY int)
- (#static ANEWARRAY int)
-
- (#static DUP int)
- (#static DUP2_X1 int)
- (#static POP int)
- (#static POP2 int)
-
- (#static IF_ICMPEQ int)
- (#static IF_ACMPEQ int)
- (#static IFNULL int)
- (#static GOTO int)
-
- (#static ACONST_NULL int)
-
- (#static ILOAD int)
- (#static ALOAD int)
-
- (#static IADD int)
-
- (#static LAND int)
- (#static LOR int)
- (#static LXOR int)
- (#static LSHL int)
- (#static LSHR int)
- (#static LUSHR int)
-
- (#static LADD int)
- (#static LSUB int)
- (#static LMUL int)
- (#static LDIV int)
- (#static LREM int)
- (#static LCMP int)
-
- (#static DADD int)
- (#static DSUB int)
- (#static DMUL int)
- (#static DDIV int)
- (#static DREM int)
- (#static DCMPG int)
-
- (#static I2L int)
- (#static L2I int)
- (#static L2D int)
- (#static D2L int)
- (#static I2C int)
-
- (#static AALOAD int)
- (#static AASTORE int)
- (#static ARRAYLENGTH int)
-
- (#static GETSTATIC int)
- (#static PUTSTATIC int)
- (#static GETFIELD int)
- (#static PUTFIELD int)
-
- (#static INVOKESTATIC int)
- (#static INVOKESPECIAL int)
- (#static INVOKEVIRTUAL int)
-
- (#static ATHROW int)
-
- (#static RETURN int)
- (#static ARETURN int)
- )
+(syntax: (declare [codes (p;many s;local-symbol)])
+ (|> codes
+ (L/map (function [code] (` ((~' #static) (~ (code;local-symbol code)) (~' int)))))
+ wrap))
+
+(with-expansions [<primitive> (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE
+ T_BYTE T_SHORT T_INT T_LONG)
+ <stack> (declare DUP DUP2_X1
+ POP POP2
+ SWAP)
+ <jump> (declare IF_ICMPEQ IF_ACMPEQ IFNULL
+ IFLT IFLE IFGT IFGE
+ GOTO)]
+ (jvm-import org.objectweb.asm.Opcodes
+ <primitive>
+
+ (#static CHECKCAST int)
+ (#static NEW int)
+ (#static NEWARRAY int)
+ (#static ANEWARRAY int)
+
+ <stack>
+ <jump>
+
+ (#static ACONST_NULL int)
+
+ (#static ILOAD int)
+ (#static LLOAD int)
+ (#static ALOAD int)
+
+ (#static IADD int)
+
+ (#static LAND int)
+ (#static LOR int)
+ (#static LXOR int)
+ (#static LSHL int)
+ (#static LSHR int)
+ (#static LUSHR int)
+
+ (#static LADD int)
+ (#static LSUB int)
+ (#static LMUL int)
+ (#static LDIV int)
+ (#static LREM int)
+ (#static LCMP int)
+
+ (#static DADD int)
+ (#static DSUB int)
+ (#static DMUL int)
+ (#static DDIV int)
+ (#static DREM int)
+ (#static DCMPG int)
+
+ (#static I2L int)
+ (#static L2I int)
+ (#static L2D int)
+ (#static D2L int)
+ (#static I2C int)
+
+ (#static AALOAD int)
+ (#static AASTORE int)
+ (#static ARRAYLENGTH int)
+
+ (#static GETSTATIC int)
+ (#static PUTSTATIC int)
+ (#static GETFIELD int)
+ (#static PUTFIELD int)
+
+ (#static INVOKESTATIC int)
+ (#static INVOKESPECIAL int)
+ (#static INVOKEVIRTUAL int)
+
+ (#static ATHROW int)
+
+ (#static RETURN int)
+ (#static IRETURN int)
+ (#static LRETURN int)
+ (#static ARETURN int)
+ ))
(jvm-import org.objectweb.asm.FieldVisitor
(visitEnd [] void))
@@ -126,57 +135,48 @@
[string Text id]
)
-(do-template [<name> <inst>]
+(syntax: (prefix [base s;local-symbol])
+ (wrap (list (code;local-symbol (format "Opcodes." base)))))
+
+(def: #export NULL
+ $;Inst
+ (function [visitor]
+ (do-to visitor
+ (MethodVisitor.visitInsn [(prefix ACONST_NULL)]))))
+
+(do-template [<name>]
[(def: #export <name>
$;Inst
(function [visitor]
(do-to visitor
- (MethodVisitor.visitInsn [<inst>]))))]
+ (MethodVisitor.visitInsn [(prefix <name>)]))))]
- [DUP Opcodes.DUP]
- [DUP2_X1 Opcodes.DUP2_X1]
- [POP Opcodes.POP]
- [POP2 Opcodes.POP2]
+ ## Stack
+ [DUP] [DUP2_X1] [POP] [POP2] [SWAP]
- [NULL Opcodes.ACONST_NULL]
-
- [IADD Opcodes.IADD]
-
- [LAND Opcodes.LAND]
- [LOR Opcodes.LOR]
- [LXOR Opcodes.LXOR]
- [LSHL Opcodes.LSHL]
- [LSHR Opcodes.LSHR]
- [LUSHR Opcodes.LUSHR]
-
- [LADD Opcodes.LADD]
- [LSUB Opcodes.LSUB]
- [LMUL Opcodes.LMUL]
- [LDIV Opcodes.LDIV]
- [LREM Opcodes.LREM]
- [LCMP Opcodes.LCMP]
-
- [DADD Opcodes.DADD]
- [DSUB Opcodes.DSUB]
- [DMUL Opcodes.DMUL]
- [DDIV Opcodes.DDIV]
- [DREM Opcodes.DREM]
- [DCMPG Opcodes.DCMPG]
-
- [I2L Opcodes.I2L]
- [L2I Opcodes.L2I]
- [L2D Opcodes.L2D]
- [D2L Opcodes.D2L]
- [I2C Opcodes.I2C]
-
- [AALOAD Opcodes.AALOAD]
- [AASTORE Opcodes.AASTORE]
- [ARRAYLENGTH Opcodes.ARRAYLENGTH]
+ ## Integer arithmetic
+ [IADD]
+
+ ## Long bitwise
+ [LAND] [LOR] [LXOR] [LSHL] [LSHR] [LUSHR]
- [ATHROW Opcodes.ATHROW]
+ ## Long arithmethic
+ [LADD] [LSUB] [LMUL] [LDIV] [LREM] [LCMP]
- [RETURN Opcodes.RETURN]
- [ARETURN Opcodes.ARETURN]
+ ## Double arithmetic
+ [DADD] [DSUB] [DMUL] [DDIV] [DREM] [DCMPG]
+
+ ## Conversions
+ [I2L] [L2I] [L2D] [D2L] [I2C]
+
+ ## Array
+ [AALOAD] [AASTORE] [ARRAYLENGTH]
+
+ ## Exceptions
+ [ATHROW]
+
+ ## Return
+ [RETURN] [IRETURN] [LRETURN] [ARETURN]
)
(do-template [<name> <inst>]
@@ -186,8 +186,9 @@
(do-to visitor
(MethodVisitor.visitVarInsn [<inst> (nat-to-int register)]))))]
- [ALOAD Opcodes.ALOAD]
[ILOAD Opcodes.ILOAD]
+ [LLOAD Opcodes.LLOAD]
+ [ALOAD Opcodes.ALOAD]
)
(do-template [<name> <inst>]
@@ -242,17 +243,16 @@
[INVOKESPECIAL Opcodes.INVOKESPECIAL]
)
-(do-template [<name> <inst>]
+(do-template [<name>]
[(def: #export (<name> @where)
(-> $;Label $;Inst)
(function [visitor]
(do-to visitor
- (MethodVisitor.visitJumpInsn [<inst> @where]))))]
+ (MethodVisitor.visitJumpInsn [(prefix <name>) @where]))))]
- [IF_ICMPEQ Opcodes.IF_ICMPEQ]
- [IF_ACMPEQ Opcodes.IF_ACMPEQ]
- [IFNULL Opcodes.IFNULL]
- [GOTO Opcodes.GOTO]
+ [IF_ICMPEQ] [IF_ACMPEQ] [IFNULL]
+ [IFLT] [IFLE] [IFGT] [IFGE]
+ [GOTO]
)
(def: #export (label @label)
diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
index 957a2efa4..fcfba7682 100644
--- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
@@ -172,7 +172,7 @@
(def: (bit//count inputI)
Unary
- (|>. inputI
+ (|>. inputI $i;unwrap-long
($i;INVOKESTATIC "java.lang.Long" "bitCount" ($t;method (list $t;long) (#;Some $t;int) (list)) false)
lux-intI))
@@ -231,7 +231,7 @@
(def: deg-method $;Method nat-method)
-(def: compare-unsigned-method
+(def: compare-nat-method
$;Method
($t;method (list $t;long $t;long) (#;Some $t;int) (list)))
@@ -305,8 +305,8 @@
($i;int <reference>)
(predicateI $i;IF_ICMPEQ)))]
- [nat//eq 0 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compareUnsigned" compare-unsigned-method false)]
- [nat//lt -1 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compareUnsigned" compare-unsigned-method false)]
+ [nat//eq 0 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compare_nat" compare-nat-method false)]
+ [nat//lt -1 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compare_nat" compare-nat-method false)]
[int//eq 0 $i;unwrap-long $i;LCMP]
[int//lt -1 $i;unwrap-long $i;LCMP]
@@ -314,8 +314,8 @@
[real//eq 0 $i;unwrap-double $i;DCMPG]
[real//lt -1 $i;unwrap-double $i;DCMPG]
- [deg//eq 0 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compareUnsigned" compare-unsigned-method false)]
- [deg//lt -1 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compareUnsigned" compare-unsigned-method false)]
+ [deg//eq 0 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compare_nat" compare-nat-method false)]
+ [deg//lt -1 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compare_nat" compare-nat-method false)]
)
(do-template [<name> <prepare> <transform>]
diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux
index 8c0b294c1..e6a12d6fa 100644
--- a/new-luxc/source/luxc/generator/runtime.jvm.lux
+++ b/new-luxc/source/luxc/generator/runtime.jvm.lux
@@ -39,20 +39,25 @@
(visitEnd [] void)
(toByteArray [] Byte-Array))
-(def: #export runtime-name Text "LuxRT")
+(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 true #$;finalM false #$;synchronizedM false}
- "sum_make"
+ (|>. ($d;method #$;Public $;staticM "sum_make"
($t;method (list $t;int $Object $Object)
(#;Some ($t;array +1 $Object))
(list))
@@ -62,16 +67,107 @@
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<Lux>
[_ (wrap [])
- #let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS)
- (ClassWriter.visit [&common;bytecode-version
- ($_ i.+ Opcodes.ACC_PUBLIC Opcodes.ACC_FINAL Opcodes.ACC_SUPER)
- runtime-name (host;null)
- "java/lang/Object" (host;null)]))
- add-adt-methods)
- bytecode (ClassWriter.toByteArray [] (do-to writer (ClassWriter.visitEnd [])))]
+ #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)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 19:39:23 +0000