aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/generator/host
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/generator/host/jvm.lux85
-rw-r--r--new-luxc/source/luxc/generator/host/jvm/def.lux146
-rw-r--r--new-luxc/source/luxc/generator/host/jvm/inst.lux151
3 files changed, 351 insertions, 31 deletions
diff --git a/new-luxc/source/luxc/generator/host/jvm.lux b/new-luxc/source/luxc/generator/host/jvm.lux
index f1eb61166..d67b6ef91 100644
--- a/new-luxc/source/luxc/generator/host/jvm.lux
+++ b/new-luxc/source/luxc/generator/host/jvm.lux
@@ -1,12 +1,21 @@
(;module:
[lux #- Type Def]
- (lux [host #+ jvm-import]))
+ (lux (control monad
+ ["p" parser])
+ (data (coll [list "L/" Functor<List>]))
+ [macro]
+ (macro [code]
+ ["s" syntax #+ syntax:])
+ [host #+ jvm-import]))
## [Host]
(jvm-import org.objectweb.asm.MethodVisitor)
(jvm-import org.objectweb.asm.ClassWriter)
+(jvm-import #long org.objectweb.asm.Label
+ (new []))
+
## [Type]
(type: #export Bound
#Upper
@@ -27,6 +36,12 @@
(#Wildcard (Maybe [Bound Generic]))
(#Class Text (List Generic)))
+(type: #export Class
+ [Text (List Generic)])
+
+(type: #export Parameter
+ [Text Class (List Class)])
+
(type: #export #rec Type
(#Primitive Primitive)
(#Generic Generic)
@@ -43,19 +58,69 @@
(type: #export Inst
(-> MethodVisitor MethodVisitor))
+(type: #export Label
+ org.objectweb.asm.Label)
+
+(type: #export Register Nat)
+
(type: #export Visibility
#Public
#Protected
#Private
#Default)
-(type: #export Method-Config
- {#staticM Bool
- #finalM Bool
- #synchronizedM Bool})
+(type: #export Version
+ #V1.1
+ #V1.2
+ #V1.3
+ #V1.4
+ #V1.5
+ #V1.6
+ #V1.7
+ #V1.8)
+
+## [Values]
+(syntax: (config: [type s;local-symbol]
+ [none s;local-symbol]
+ [++ s;local-symbol]
+ [options (s;tuple (p;many s;local-symbol))])
+ (let [g!type (code;local-symbol type)
+ g!none (code;local-symbol none)
+ g!tags+ (L/map code;local-tag options)
+ g!_left (code;local-symbol "_left")
+ g!_right (code;local-symbol "_right")
+ g!options+ (L/map (function [option]
+ (` (def: (~' #export) (~ (code;local-symbol option))
+ (~ g!type)
+ (|> (~ g!none)
+ (set@ (~ (code;local-tag option)) true)))))
+ options)]
+ (wrap (list& (` (type: (~' #export) (~ g!type)
+ (~ (code;record (L/map (function [tag]
+ [tag (` ;Bool)])
+ g!tags+)))))
+
+ (` (def: (~' #export) (~ g!none)
+ (~ g!type)
+ (~ (code;record (L/map (function [tag]
+ [tag (` false)])
+ g!tags+)))))
+
+ (` (def: (~' #export) ((~ (code;local-symbol ++)) (~ g!_left) (~ g!_right))
+ (-> (~ g!type) (~ g!type) (~ g!type))
+ (~ (code;record (L/map (function [tag]
+ [tag (` (and (get@ (~ tag) (~ g!_left))
+ (get@ (~ tag) (~ g!_right))))])
+ g!tags+)))))
+
+ g!options+))))
+
+## Configs
+(config: Class-Config noneC ++C [finalC])
+(config: Method-Config noneM ++M [staticM finalM synchronizedM])
+(config: Field-Config noneF ++F [staticF finalF transientF volatileF])
-(type: #export Field-Config
- {#staticF Bool
- #finalF Bool
- #transientF Bool
- #volatileF Bool})
+## Labels
+(def: #export new-label
+ (-> Unit Label)
+ org.objectweb.asm.Label.new)
diff --git a/new-luxc/source/luxc/generator/host/jvm/def.lux b/new-luxc/source/luxc/generator/host/jvm/def.lux
index 1fd87caea..39fab2f2a 100644
--- a/new-luxc/source/luxc/generator/host/jvm/def.lux
+++ b/new-luxc/source/luxc/generator/host/jvm/def.lux
@@ -1,6 +1,8 @@
(;module:
lux
- (lux (data (coll ["a" array]
+ (lux (data [text]
+ text/format
+ (coll ["a" array]
[list "L/" Functor<List>]))
[host #+ jvm-import do-to])
["$" ..]
@@ -15,13 +17,26 @@
(#static ACC_PROTECTED int)
(#static ACC_PRIVATE int)
+ (#static ACC_TRANSIENT int)
+ (#static ACC_VOLATILE int)
+
(#static ACC_ABSTRACT int)
(#static ACC_FINAL int)
(#static ACC_STATIC int)
(#static ACC_SYNCHRONIZED int)
- (#static ACC_TRANSIENT int)
- (#static ACC_VOLATILE int))
+ (#static ACC_SUPER int)
+ (#static ACC_INTERFACE int)
+
+ (#static V1_1 int)
+ (#static V1_2 int)
+ (#static V1_3 int)
+ (#static V1_4 int)
+ (#static V1_5 int)
+ (#static V1_6 int)
+ (#static V1_7 int)
+ (#static V1_8 int)
+ )
(jvm-import org.objectweb.asm.FieldVisitor
(visitEnd [] void))
@@ -41,15 +56,32 @@
(toByteArray [] Byte-Array))
## [Defs]
-(def: (exceptions-array type)
- (-> $;Method (a;Array Text))
- (let [exs (|> type (get@ #$;exceptions) (L/map (|>. #$;Generic $t;descriptor)))
- output (host;array String (list;size exs))]
+(def: (string-array values)
+ (-> (List Text) (a;Array Text))
+ (let [output (host;array String (list;size values))]
(exec (L/map (function [[idx value]]
(host;array-store idx value output))
- (list;enumerate exs))
+ (list;enumerate values))
output)))
+(def: exceptions-array
+ (-> $;Method (a;Array Text))
+ (|>. (get@ #$;exceptions)
+ (L/map (|>. #$;Generic $t;descriptor))
+ string-array))
+
+(def: (version-flag version)
+ (-> $;Version Int)
+ (case version
+ #$;V1.1 Opcodes.V1_1
+ #$;V1.2 Opcodes.V1_2
+ #$;V1.3 Opcodes.V1_3
+ #$;V1.4 Opcodes.V1_4
+ #$;V1.5 Opcodes.V1_5
+ #$;V1.6 Opcodes.V1_6
+ #$;V1.7 Opcodes.V1_7
+ #$;V1.8 Opcodes.V1_8))
+
(def: (visibility-flag visibility)
(-> $;Visibility Int)
(case visibility
@@ -58,6 +90,11 @@
#$;Private Opcodes.ACC_PRIVATE
#$;Default 0))
+(def: (class-flag config)
+ (-> $;Class-Config Int)
+ ($_ i.+
+ (if (get@ #$;finalC config) Opcodes.ACC_FINAL 0)))
+
(def: (method-flag config)
(-> $;Method-Config Int)
($_ i.+
@@ -73,6 +110,87 @@
(if (get@ #$;transientF config) Opcodes.ACC_TRANSIENT 0)
(if (get@ #$;volatileF config) Opcodes.ACC_VOLATILE 0)))
+(def: class-to-type
+ (-> $;Class $;Type)
+ (|>. #$;Class #$;Generic))
+
+(def: param-signature
+ (-> $;Class Text)
+ (|>. class-to-type $t;signature (format ":")))
+
+(def: (formal-param [name super interfaces])
+ (-> $;Parameter Text)
+ (format name
+ (param-signature super)
+ (|> interfaces
+ (L/map param-signature)
+ (text;join-with ""))))
+
+(def: (parameters-signature parameters super interfaces)
+ (-> (List $;Parameter) $;Class (List $;Class)
+ Text)
+ (let [formal-params (if (list;empty? parameters)
+ ""
+ (format "<"
+ (|> parameters
+ (L/map formal-param)
+ (text;join-with ""))
+ ">"))]
+ (format formal-params
+ (|> super class-to-type $t;signature)
+ (|> interfaces
+ (L/map (|>. class-to-type $t;signature))
+ (text;join-with "")))))
+
+(do-template [<name> <flag>]
+ [(def: #export (<name> version visibility config name parameters super interfaces
+ definitions)
+ (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) $;Class (List $;Class) $;Def
+ host;Byte-Array)
+ (let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS)
+ (ClassWriter.visit [(version-flag version)
+ ($_ i.+
+ Opcodes.ACC_SUPER
+ <flag>
+ (visibility-flag visibility)
+ (class-flag config))
+ name
+ (parameters-signature parameters super interfaces)
+ (|> super class-to-type $t;descriptor)
+ (|> interfaces
+ (L/map (|>. class-to-type $t;descriptor))
+ string-array)]))
+ definitions)
+ _ (ClassWriter.visitEnd [] writer)]
+ (ClassWriter.toByteArray [] writer)))]
+
+ [class 0]
+ [abstract Opcodes.ACC_ABSTRACT]
+ )
+
+(def: $Object $;Class ["java.lang.Object" (list)])
+
+(def: #export (interface version visibility config name parameters interfaces
+ definitions)
+ (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) (List $;Class) $;Def
+ host;Byte-Array)
+ (let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS)
+ (ClassWriter.visit [(version-flag version)
+ ($_ i.+
+ Opcodes.ACC_SUPER
+ Opcodes.ACC_INTERFACE
+ (visibility-flag visibility)
+ (class-flag config))
+ name
+ (parameters-signature parameters $Object interfaces)
+ (|> $Object class-to-type $t;descriptor)
+ (|> interfaces
+ (L/map (|>. class-to-type $t;descriptor))
+ string-array)]))
+ definitions)
+ _ (ClassWriter.visitEnd [] writer)]
+ (ClassWriter.toByteArray [] writer)))
+
(def: #export (method visibility config name type then)
(-> $;Visibility $;Method-Config Text $;Method $;Inst
$;Def)
@@ -140,3 +258,15 @@
[char-field Char $t;char id]
[string-field Text ($t;class "java.lang.String" (list)) id]
)
+
+(def: #export (fuse defs)
+ (-> (List $;Def) $;Def)
+ (case defs
+ #;Nil
+ id
+
+ (#;Cons singleton #;Nil)
+ singleton
+
+ (#;Cons head tail)
+ (. head (fuse tail))))
diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux
index f340be055..82b360883 100644
--- a/new-luxc/source/luxc/generator/host/jvm/inst.lux
+++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux
@@ -18,25 +18,80 @@
(#static T_INT int)
(#static T_LONG int)
+ (#static CHECKCAST int)
+ (#static NEW int)
+ (#static NEWARRAY int)
+ (#static ANEWARRAY int)
+
(#static DUP int)
- (#static RETURN int)
- (#static ARETURN 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 NEWARRAY int)
- (#static ANEWARRAY 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 INVOKEVIRTUAL int)
(#static INVOKESPECIAL int)
- (#static CHECKCAST int))
+ (#static INVOKEVIRTUAL int)
+
+ (#static ATHROW int)
+
+ (#static RETURN int)
+ (#static ARETURN int)
+ )
(jvm-import org.objectweb.asm.FieldVisitor
(visitEnd [] void))
+(jvm-import org.objectweb.asm.Label
+ (new []))
+
(jvm-import org.objectweb.asm.MethodVisitor
(visitCode [] void)
(visitMaxs [int int] void)
@@ -47,9 +102,15 @@
(visitTypeInsn [int String] void)
(visitVarInsn [int int] void)
(visitIntInsn [int int] void)
- (visitMethodInsn [int String String String boolean] void))
+ (visitMethodInsn [int String String String boolean] void)
+ (visitLabel [Label] void)
+ (visitJumpInsn [int Label] void))
## [Insts]
+(def: #export (with-label action)
+ (-> (-> Label $;Inst) $;Inst)
+ (action (Label.new [])))
+
(do-template [<name> <type> <prepare>]
[(def: #export (<name> value)
(-> <type> $;Inst)
@@ -72,11 +133,50 @@
(do-to visitor
(MethodVisitor.visitInsn [<inst>]))))]
- [RETURN Opcodes.RETURN]
- [ARETURN Opcodes.ARETURN]
- [NULL Opcodes.ACONST_NULL]
- [DUP Opcodes.DUP]
- [AASTORE Opcodes.AASTORE]
+ [DUP Opcodes.DUP]
+ [DUP2_X1 Opcodes.DUP2_X1]
+ [POP Opcodes.POP]
+ [POP2 Opcodes.POP2]
+
+ [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]
+
+ [ATHROW Opcodes.ATHROW]
+
+ [RETURN Opcodes.RETURN]
+ [ARETURN Opcodes.ARETURN]
)
(do-template [<name> <inst>]
@@ -97,7 +197,11 @@
(do-to visitor
(MethodVisitor.visitFieldInsn [<inst> ($t;binary-name class) field ($t;descriptor type)]))))]
+ [GETSTATIC Opcodes.GETSTATIC]
[PUTSTATIC Opcodes.PUTSTATIC]
+
+ [PUTFIELD Opcodes.PUTFIELD]
+ [GETFIELD Opcodes.GETFIELD]
)
(do-template [<name> <inst>]
@@ -107,8 +211,9 @@
(do-to visitor
(MethodVisitor.visitTypeInsn [<inst> ($t;binary-name class)]))))]
- [ANEWARRAY Opcodes.ANEWARRAY]
[CHECKCAST Opcodes.CHECKCAST]
+ [NEW Opcodes.NEW]
+ [ANEWARRAY Opcodes.ANEWARRAY]
)
(def: #export (NEWARRAY type)
@@ -134,8 +239,28 @@
[INVOKESTATIC Opcodes.INVOKESTATIC]
[INVOKEVIRTUAL Opcodes.INVOKEVIRTUAL]
+ [INVOKESPECIAL Opcodes.INVOKESPECIAL]
)
+(do-template [<name> <inst>]
+ [(def: #export (<name> @where)
+ (-> $;Label $;Inst)
+ (function [visitor]
+ (do-to visitor
+ (MethodVisitor.visitJumpInsn [<inst> @where]))))]
+
+ [IF_ICMPEQ Opcodes.IF_ICMPEQ]
+ [IF_ACMPEQ Opcodes.IF_ACMPEQ]
+ [IFNULL Opcodes.IFNULL]
+ [GOTO Opcodes.GOTO]
+ )
+
+(def: #export (label @label)
+ (-> $;Label $;Inst)
+ (function [visitor]
+ (do-to visitor
+ (MethodVisitor.visitLabel [@label]))))
+
(def: #export (array type size)
(-> $;Type Nat $;Inst)
(case type
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-27 14:46:18 +0000