aboutsummaryrefslogtreecommitdiff
path: root/lux-jvm/source/luxc/lang/host
diff options
context:
space:
mode:
Diffstat (limited to 'lux-jvm/source/luxc/lang/host')
-rw-r--r--lux-jvm/source/luxc/lang/host/jvm.lux131
-rw-r--r--lux-jvm/source/luxc/lang/host/jvm/def.lux298
-rw-r--r--lux-jvm/source/luxc/lang/host/jvm/inst.lux464
3 files changed, 893 insertions, 0 deletions
diff --git a/lux-jvm/source/luxc/lang/host/jvm.lux b/lux-jvm/source/luxc/lang/host/jvm.lux
new file mode 100644
index 000000000..d957bdb1d
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/host/jvm.lux
@@ -0,0 +1,131 @@
+(.module:
+ [lux (#- Definition Type)
+ [host (#+ import:)]
+ [abstract
+ monad]
+ [control
+ ["p" parser
+ ["s" code]]]
+ [data
+ [binary (#+ Binary)]
+ [collection
+ ["." list ("#/." functor)]]]
+ [macro
+ ["." code]
+ [syntax (#+ syntax:)]]
+ [target
+ [jvm
+ ["." type (#+ Type)
+ [category (#+ Class)]]]]
+ [tool
+ [compiler
+ [reference (#+ Register)]
+ [language
+ [lux
+ ["." generation]]]
+ [meta
+ [archive (#+ Archive)]]]]])
+
+(import: org/objectweb/asm/MethodVisitor)
+
+(import: org/objectweb/asm/ClassWriter)
+
+(import: #long org/objectweb/asm/Label
+ (new []))
+
+(type: #export Def
+ (-> ClassWriter ClassWriter))
+
+(type: #export Inst
+ (-> MethodVisitor MethodVisitor))
+
+(type: #export Label
+ org/objectweb/asm/Label)
+
+(type: #export Visibility
+ #Public
+ #Protected
+ #Private
+ #Default)
+
+(type: #export Version
+ #V1_1
+ #V1_2
+ #V1_3
+ #V1_4
+ #V1_5
+ #V1_6
+ #V1_7
+ #V1_8)
+
+(type: #export ByteCode Binary)
+
+(type: #export Definition [Text ByteCode])
+
+(type: #export Anchor [Label Register])
+
+(type: #export Host
+ (generation.Host Inst Definition))
+
+(template [<name> <base>]
+ [(type: #export <name>
+ (<base> ..Anchor Inst Definition))]
+
+ [State generation.State]
+ [Operation generation.Operation]
+ [Phase generation.Phase]
+ [Handler generation.Handler]
+ [Bundle generation.Bundle]
+ [Extender generation.Extender]
+ )
+
+(type: #export (Generator i)
+ (-> Phase Archive i (Operation Inst)))
+
+(syntax: (config: {type s.local-identifier}
+ {none s.local-identifier}
+ {++ s.local-identifier}
+ {options (s.tuple (p.many s.local-identifier))})
+ (let [g!type (code.local-identifier type)
+ g!none (code.local-identifier none)
+ g!tags+ (list/map code.local-tag options)
+ g!_left (code.local-identifier "_left")
+ g!_right (code.local-identifier "_right")
+ g!options+ (list/map (function (_ option)
+ (` (def: (~' #export) (~ (code.local-identifier option))
+ (~ g!type)
+ (|> (~ g!none)
+ (set@ (~ (code.local-tag option)) #1)))))
+ options)]
+ (wrap (list& (` (type: (~' #export) (~ g!type)
+ (~ (code.record (list/map (function (_ tag)
+ [tag (` .Bit)])
+ g!tags+)))))
+
+ (` (def: (~' #export) (~ g!none)
+ (~ g!type)
+ (~ (code.record (list/map (function (_ tag)
+ [tag (` #0)])
+ g!tags+)))))
+
+ (` (def: (~' #export) ((~ (code.local-identifier ++)) (~ g!_left) (~ g!_right))
+ (-> (~ g!type) (~ g!type) (~ g!type))
+ (~ (code.record (list/map (function (_ tag)
+ [tag (` (or (get@ (~ tag) (~ g!_left))
+ (get@ (~ tag) (~ g!_right))))])
+ g!tags+)))))
+
+ g!options+))))
+
+(config: Class-Config noneC ++C [finalC])
+(config: Method-Config noneM ++M [finalM staticM synchronizedM strictM])
+(config: Field-Config noneF ++F [finalF staticF transientF volatileF])
+
+(def: #export new-label
+ (-> Any Label)
+ (function (_ _)
+ (org/objectweb/asm/Label::new)))
+
+(def: #export (simple-class name)
+ (-> Text (Type Class))
+ (type.class name (list)))
diff --git a/lux-jvm/source/luxc/lang/host/jvm/def.lux b/lux-jvm/source/luxc/lang/host/jvm/def.lux
new file mode 100644
index 000000000..f274da61f
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/host/jvm/def.lux
@@ -0,0 +1,298 @@
+(.module:
+ [lux (#- Type)
+ ["." host (#+ import: do-to)]
+ [control
+ ["." function]]
+ [data
+ ["." product]
+ [number
+ ["i" int]]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." array (#+ Array)]
+ ["." list ("#@." functor)]]]
+ [target
+ [jvm
+ [encoding
+ ["." name]]
+ ["." type (#+ Type Constraint)
+ [category (#+ Class Value Method)]
+ ["." signature]
+ ["." descriptor]]]]]
+ ["." //])
+
+(def: signature (|>> type.signature signature.signature))
+(def: descriptor (|>> type.descriptor descriptor.descriptor))
+(def: class-name (|>> type.descriptor descriptor.class-name name.read))
+
+(import: #long java/lang/Object)
+(import: #long java/lang/String)
+
+(import: org/objectweb/asm/Opcodes
+ (#static ACC_PUBLIC int)
+ (#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_STRICT 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)
+ )
+
+(import: org/objectweb/asm/FieldVisitor
+ (visitEnd [] void))
+
+(import: org/objectweb/asm/MethodVisitor
+ (visitCode [] void)
+ (visitMaxs [int int] void)
+ (visitEnd [] void))
+
+(import: org/objectweb/asm/ClassWriter
+ (#static COMPUTE_MAXS int)
+ (#static COMPUTE_FRAMES int)
+ (new [int])
+ (visit [int int String String String [String]] void)
+ (visitEnd [] void)
+ (visitField [int String String String Object] FieldVisitor)
+ (visitMethod [int String String String [String]] MethodVisitor)
+ (toByteArray [] [byte]))
+
+(def: (string-array values)
+ (-> (List Text) (Array Text))
+ (let [output (host.array String (list.size values))]
+ (exec (list@map (function (_ [idx value])
+ (host.array-write idx value output))
+ (list.enumerate values))
+ output)))
+
+(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
+ #//.Public (Opcodes::ACC_PUBLIC)
+ #//.Protected (Opcodes::ACC_PROTECTED)
+ #//.Private (Opcodes::ACC_PRIVATE)
+ #//.Default +0))
+
+(def: (class-flags config)
+ (-> //.Class-Config Int)
+ ($_ i.+
+ (if (get@ #//.finalC config) (Opcodes::ACC_FINAL) +0)))
+
+(def: (method-flags config)
+ (-> //.Method-Config Int)
+ ($_ i.+
+ (if (get@ #//.staticM config) (Opcodes::ACC_STATIC) +0)
+ (if (get@ #//.finalM config) (Opcodes::ACC_FINAL) +0)
+ (if (get@ #//.synchronizedM config) (Opcodes::ACC_SYNCHRONIZED) +0)
+ (if (get@ #//.strictM config) (Opcodes::ACC_STRICT) +0)))
+
+(def: (field-flags config)
+ (-> //.Field-Config Int)
+ ($_ i.+
+ (if (get@ #//.staticF config) (Opcodes::ACC_STATIC) +0)
+ (if (get@ #//.finalF config) (Opcodes::ACC_FINAL) +0)
+ (if (get@ #//.transientF config) (Opcodes::ACC_TRANSIENT) +0)
+ (if (get@ #//.volatileF config) (Opcodes::ACC_VOLATILE) +0)))
+
+(def: param-signature
+ (-> (Type Class) Text)
+ (|>> ..signature (format ":")))
+
+(def: (formal-param [name super interfaces])
+ (-> Constraint Text)
+ (format name
+ (param-signature super)
+ (|> interfaces
+ (list@map param-signature)
+ (text.join-with ""))))
+
+(def: (constraints-signature constraints super interfaces)
+ (-> (List Constraint) (Type Class) (List (Type Class))
+ Text)
+ (let [formal-params (if (list.empty? constraints)
+ ""
+ (format "<"
+ (|> constraints
+ (list@map formal-param)
+ (text.join-with ""))
+ ">"))]
+ (format formal-params
+ (..signature super)
+ (|> interfaces
+ (list@map ..signature)
+ (text.join-with "")))))
+
+(def: class-computes
+ Int
+ ($_ i.+
+ (ClassWriter::COMPUTE_MAXS)
+ ## (ClassWriter::COMPUTE_FRAMES)
+ ))
+
+(def: binary-name (|>> name.internal name.read))
+
+(template [<name> <flag>]
+ [(def: #export (<name> version visibility config name constraints super interfaces
+ definitions)
+ (-> //.Version //.Visibility //.Class-Config Text (List Constraint) (Type Class) (List (Type Class)) //.Def
+ (host.type [byte]))
+ (let [writer (|> (do-to (ClassWriter::new class-computes)
+ (ClassWriter::visit (version-flag version)
+ ($_ i.+
+ (Opcodes::ACC_SUPER)
+ <flag>
+ (visibility-flag visibility)
+ (class-flags config))
+ (..binary-name name)
+ (constraints-signature constraints super interfaces)
+ (..class-name super)
+ (|> interfaces
+ (list@map ..class-name)
+ string-array)))
+ definitions)
+ _ (ClassWriter::visitEnd writer)]
+ (ClassWriter::toByteArray writer)))]
+
+ [class +0]
+ [abstract (Opcodes::ACC_ABSTRACT)]
+ )
+
+(def: $Object
+ (Type Class)
+ (type.class "java.lang.Object" (list)))
+
+(def: #export (interface version visibility config name constraints interfaces
+ definitions)
+ (-> //.Version //.Visibility //.Class-Config Text (List Constraint) (List (Type Class)) //.Def
+ (host.type [byte]))
+ (let [writer (|> (do-to (ClassWriter::new class-computes)
+ (ClassWriter::visit (version-flag version)
+ ($_ i.+
+ (Opcodes::ACC_SUPER)
+ (Opcodes::ACC_INTERFACE)
+ (visibility-flag visibility)
+ (class-flags config))
+ (..binary-name name)
+ (constraints-signature constraints $Object interfaces)
+ (..class-name $Object)
+ (|> interfaces
+ (list@map ..class-name)
+ string-array)))
+ definitions)
+ _ (ClassWriter::visitEnd writer)]
+ (ClassWriter::toByteArray writer)))
+
+(def: #export (method visibility config name type then)
+ (-> //.Visibility //.Method-Config Text (Type Method) //.Inst
+ //.Def)
+ (function (_ writer)
+ (let [=method (ClassWriter::visitMethod ($_ i.+
+ (visibility-flag visibility)
+ (method-flags config))
+ (..binary-name name)
+ (..descriptor type)
+ (..signature type)
+ (string-array (list))
+ writer)
+ _ (MethodVisitor::visitCode =method)
+ _ (then =method)
+ _ (MethodVisitor::visitMaxs +0 +0 =method)
+ _ (MethodVisitor::visitEnd =method)]
+ writer)))
+
+(def: #export (abstract-method visibility config name type)
+ (-> //.Visibility //.Method-Config Text (Type Method)
+ //.Def)
+ (function (_ writer)
+ (let [=method (ClassWriter::visitMethod ($_ i.+
+ (visibility-flag visibility)
+ (method-flags config)
+ (Opcodes::ACC_ABSTRACT))
+ (..binary-name name)
+ (..descriptor type)
+ (..signature type)
+ (string-array (list))
+ writer)
+ _ (MethodVisitor::visitEnd =method)]
+ writer)))
+
+(def: #export (field visibility config name type)
+ (-> //.Visibility //.Field-Config Text (Type Value) //.Def)
+ (function (_ writer)
+ (let [=field (do-to (ClassWriter::visitField ($_ i.+
+ (visibility-flag visibility)
+ (field-flags config))
+ (..binary-name name)
+ (..descriptor type)
+ (..signature type)
+ (host.null)
+ writer)
+ (FieldVisitor::visitEnd))]
+ writer)))
+
+(template [<name> <lux-type> <jvm-type> <prepare>]
+ [(def: #export (<name> visibility config name value)
+ (-> //.Visibility //.Field-Config Text <lux-type> //.Def)
+ (function (_ writer)
+ (let [=field (do-to (ClassWriter::visitField ($_ i.+
+ (visibility-flag visibility)
+ (field-flags config))
+ (..binary-name name)
+ (..descriptor <jvm-type>)
+ (..signature <jvm-type>)
+ (<prepare> value)
+ writer)
+ (FieldVisitor::visitEnd))]
+ writer)))]
+
+ [boolean-field Bit type.boolean function.identity]
+ [byte-field Int type.byte host.long-to-byte]
+ [short-field Int type.short host.long-to-short]
+ [int-field Int type.int host.long-to-int]
+ [long-field Int type.long function.identity]
+ [float-field Frac type.float host.double-to-float]
+ [double-field Frac type.double function.identity]
+ [char-field Nat type.char (|>> .int host.long-to-int host.int-to-char)]
+ [string-field Text (type.class "java.lang.String" (list)) function.identity]
+ )
+
+(def: #export (fuse defs)
+ (-> (List //.Def) //.Def)
+ (case defs
+ #.Nil
+ function.identity
+
+ (#.Cons singleton #.Nil)
+ singleton
+
+ (#.Cons head tail)
+ (function.compose (fuse tail) head)))
diff --git a/lux-jvm/source/luxc/lang/host/jvm/inst.lux b/lux-jvm/source/luxc/lang/host/jvm/inst.lux
new file mode 100644
index 000000000..b673c7d7e
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/host/jvm/inst.lux
@@ -0,0 +1,464 @@
+(.module:
+ [lux (#- Type int char)
+ ["." host (#+ import: do-to)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." function]
+ ["." try]
+ ["p" parser
+ ["s" code]]]
+ [data
+ ["." product]
+ ["." maybe]
+ [number
+ ["n" nat]
+ ["i" int]]
+ [collection
+ ["." list ("#@." functor)]]]
+ [macro
+ ["." code]
+ ["." template]
+ [syntax (#+ syntax:)]]
+ [target
+ [jvm
+ [encoding
+ ["." name (#+ External)]]
+ ["." type (#+ Type) ("#@." equivalence)
+ [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
+ ["." box]
+ ["." descriptor]
+ ["." reflection]]]]
+ [tool
+ [compiler
+ [phase (#+ Operation)]]]]
+ ["." // (#+ Inst)])
+
+(def: class-name (|>> type.descriptor descriptor.class-name name.read))
+(def: descriptor (|>> type.descriptor descriptor.descriptor))
+(def: reflection (|>> type.reflection reflection.reflection))
+
+## [Host]
+(import: #long java/lang/Object)
+(import: #long java/lang/String)
+
+(syntax: (declare {codes (p.many s.local-identifier)})
+ (|> codes
+ (list@map (function (_ code) (` ((~' #static) (~ (code.local-identifier code)) (~' int)))))
+ wrap))
+
+(`` (import: #long org/objectweb/asm/Opcodes
+ (#static NOP int)
+
+ ## Conversion
+ (~~ (declare D2F D2I D2L
+ F2D F2I F2L
+ I2B I2C I2D I2F I2L I2S
+ L2D L2F L2I))
+
+ ## Primitive
+ (~~ (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE
+ T_BYTE T_SHORT T_INT T_LONG))
+
+ ## Class
+ (~~ (declare CHECKCAST NEW INSTANCEOF))
+
+ ## Stack
+ (~~ (declare DUP DUP_X1 DUP_X2
+ DUP2 DUP2_X1 DUP2_X2
+ POP POP2
+ SWAP))
+
+ ## Jump
+ (~~ (declare IF_ICMPEQ IF_ICMPGT IF_ICMPLT
+ IF_ICMPNE IF_ICMPGE IF_ICMPLE
+ IF_ACMPEQ IF_ACMPNE IFNULL IFNONNULL
+ IFEQ IFNE IFLT IFLE IFGT IFGE
+ GOTO))
+
+ (~~ (declare BIPUSH SIPUSH))
+ (~~ (declare ICONST_M1 ICONST_0 ICONST_1 ICONST_2 ICONST_3 ICONST_4 ICONST_5
+ LCONST_0 LCONST_1
+ FCONST_0 FCONST_1 FCONST_2
+ DCONST_0 DCONST_1))
+ (#static ACONST_NULL int)
+
+ ## Var
+ (~~ (declare IINC
+ ILOAD LLOAD FLOAD DLOAD ALOAD
+ ISTORE LSTORE FSTORE DSTORE ASTORE))
+
+ ## Arithmetic
+ (~~ (declare IADD ISUB IMUL IDIV IREM INEG
+ LADD LSUB LMUL LDIV LREM LNEG LCMP
+ FADD FSUB FMUL FDIV FREM FNEG FCMPG FCMPL
+ DADD DSUB DMUL DDIV DREM DNEG DCMPG DCMPL))
+
+ ## Bit-wise
+ (~~ (declare IAND IOR IXOR ISHL ISHR IUSHR
+ LAND LOR LXOR LSHL LSHR LUSHR))
+
+ ## Array
+ (~~ (declare ARRAYLENGTH NEWARRAY ANEWARRAY
+ AALOAD AASTORE
+ BALOAD BASTORE
+ SALOAD SASTORE
+ IALOAD IASTORE
+ LALOAD LASTORE
+ FALOAD FASTORE
+ DALOAD DASTORE
+ CALOAD CASTORE))
+
+ ## Member
+ (~~ (declare GETSTATIC PUTSTATIC GETFIELD PUTFIELD
+ INVOKESTATIC INVOKESPECIAL INVOKEVIRTUAL INVOKEINTERFACE))
+
+ (#static ATHROW int)
+
+ ## Concurrency
+ (~~ (declare MONITORENTER MONITOREXIT))
+
+ ## Return
+ (~~ (declare RETURN IRETURN LRETURN FRETURN DRETURN ARETURN))
+ ))
+
+(import: #long org/objectweb/asm/Label
+ (new []))
+
+(import: #long org/objectweb/asm/MethodVisitor
+ (visitCode [] void)
+ (visitMaxs [int int] void)
+ (visitEnd [] void)
+ (visitInsn [int] void)
+ (visitLdcInsn [java/lang/Object] void)
+ (visitFieldInsn [int java/lang/String java/lang/String java/lang/String] void)
+ (visitTypeInsn [int java/lang/String] void)
+ (visitVarInsn [int int] void)
+ (visitIntInsn [int int] void)
+ (visitMethodInsn [int java/lang/String java/lang/String java/lang/String boolean] void)
+ (visitLabel [org/objectweb/asm/Label] void)
+ (visitJumpInsn [int org/objectweb/asm/Label] void)
+ (visitTryCatchBlock [org/objectweb/asm/Label org/objectweb/asm/Label org/objectweb/asm/Label java/lang/String] void)
+ (visitLookupSwitchInsn [org/objectweb/asm/Label [int] [org/objectweb/asm/Label]] void)
+ (visitTableSwitchInsn [int int org/objectweb/asm/Label [org/objectweb/asm/Label]] void)
+ )
+
+## [Insts]
+(def: #export make-label
+ (All [s] (Operation s org/objectweb/asm/Label))
+ (function (_ state)
+ (#try.Success [state (org/objectweb/asm/Label::new)])))
+
+(def: #export (with-label action)
+ (All [a] (-> (-> org/objectweb/asm/Label a) a))
+ (action (org/objectweb/asm/Label::new)))
+
+(template [<name> <type> <prepare>]
+ [(def: #export (<name> value)
+ (-> <type> Inst)
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitLdcInsn (<prepare> value)))))]
+
+ [boolean Bit function.identity]
+ [int Int host.long-to-int]
+ [long Int function.identity]
+ [double Frac function.identity]
+ [char Nat (|>> .int host.long-to-int host.int-to-char)]
+ [string Text function.identity]
+ )
+
+(template: (!prefix short)
+ (`` ((~~ (template.identifier ["org/objectweb/asm/Opcodes::" short])))))
+
+(template [<constant>]
+ [(def: #export <constant>
+ Inst
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitInsn (!prefix <constant>)))))]
+
+ [ICONST_M1] [ICONST_0] [ICONST_1] [ICONST_2] [ICONST_3] [ICONST_4] [ICONST_5]
+ [LCONST_0] [LCONST_1]
+ [FCONST_0] [FCONST_1] [FCONST_2]
+ [DCONST_0] [DCONST_1]
+ )
+
+(def: #export NULL
+ Inst
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitInsn (!prefix ACONST_NULL)))))
+
+(template [<constant>]
+ [(def: #export (<constant> constant)
+ (-> Int Inst)
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitIntInsn (!prefix <constant>) constant))))]
+
+ [BIPUSH]
+ [SIPUSH]
+ )
+
+(template [<name>]
+ [(def: #export <name>
+ Inst
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitInsn (!prefix <name>)))))]
+
+ [NOP]
+
+ ## Stack
+ [DUP] [DUP_X1] [DUP_X2] [DUP2] [DUP2_X1] [DUP2_X2]
+ [POP] [POP2]
+ [SWAP]
+
+ ## Conversions
+ [D2F] [D2I] [D2L]
+ [F2D] [F2I] [F2L]
+ [I2B] [I2C] [I2D] [I2F] [I2L] [I2S]
+ [L2D] [L2F] [L2I]
+
+ ## Integer arithmetic
+ [IADD] [ISUB] [IMUL] [IDIV] [IREM] [INEG]
+
+ ## Integer bitwise
+ [IAND] [IOR] [IXOR] [ISHL] [ISHR] [IUSHR]
+
+ ## Long arithmetic
+ [LADD] [LSUB] [LMUL] [LDIV] [LREM] [LNEG]
+ [LCMP]
+
+ ## Long bitwise
+ [LAND] [LOR] [LXOR] [LSHL] [LSHR] [LUSHR]
+
+ ## Float arithmetic
+ [FADD] [FSUB] [FMUL] [FDIV] [FREM] [FNEG] [FCMPG] [FCMPL]
+
+ ## Double arithmetic
+ [DADD] [DSUB] [DMUL] [DDIV] [DREM] [DNEG]
+ [DCMPG] [DCMPL]
+
+ ## Array
+ [ARRAYLENGTH]
+ [AALOAD] [AASTORE]
+ [BALOAD] [BASTORE]
+ [SALOAD] [SASTORE]
+ [IALOAD] [IASTORE]
+ [LALOAD] [LASTORE]
+ [FALOAD] [FASTORE]
+ [DALOAD] [DASTORE]
+ [CALOAD] [CASTORE]
+
+ ## Exceptions
+ [ATHROW]
+
+ ## Concurrency
+ [MONITORENTER] [MONITOREXIT]
+
+ ## Return
+ [RETURN] [IRETURN] [LRETURN] [FRETURN] [DRETURN] [ARETURN]
+ )
+
+(type: #export Register Nat)
+
+(template [<name>]
+ [(def: #export (<name> register)
+ (-> Register Inst)
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitVarInsn (!prefix <name>) (.int register)))))]
+
+ [IINC]
+ [ILOAD] [LLOAD] [FLOAD] [DLOAD] [ALOAD]
+ [ISTORE] [LSTORE] [FSTORE] [DSTORE] [ASTORE]
+ )
+
+(template [<name> <inst>]
+ [(def: #export (<name> class field type)
+ (-> (Type Class) Text (Type Value) Inst)
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitFieldInsn (<inst>) (..class-name class) field (..descriptor type)))))]
+
+ [GETSTATIC org/objectweb/asm/Opcodes::GETSTATIC]
+ [PUTSTATIC org/objectweb/asm/Opcodes::PUTSTATIC]
+
+ [PUTFIELD org/objectweb/asm/Opcodes::PUTFIELD]
+ [GETFIELD org/objectweb/asm/Opcodes::GETFIELD]
+ )
+
+(template [<category> <instructions>+]
+ [(`` (template [<name> <inst>]
+ [(def: #export (<name> class)
+ (-> (Type <category>) Inst)
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitTypeInsn (<inst>) (..class-name class)))))]
+
+ (~~ (template.splice <instructions>+))))]
+
+ [Object
+ [[CHECKCAST org/objectweb/asm/Opcodes::CHECKCAST]
+ [ANEWARRAY org/objectweb/asm/Opcodes::ANEWARRAY]]]
+
+ [Class
+ [[NEW org/objectweb/asm/Opcodes::NEW]
+ [INSTANCEOF org/objectweb/asm/Opcodes::INSTANCEOF]]]
+ )
+
+(def: #export (NEWARRAY type)
+ (-> (Type Primitive) Inst)
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitIntInsn (org/objectweb/asm/Opcodes::NEWARRAY)
+ (`` (cond (~~ (template [<descriptor> <opcode>]
+ [(type@= <descriptor> type) (<opcode>)]
+
+ [type.boolean org/objectweb/asm/Opcodes::T_BOOLEAN]
+ [type.byte org/objectweb/asm/Opcodes::T_BYTE]
+ [type.short org/objectweb/asm/Opcodes::T_SHORT]
+ [type.int org/objectweb/asm/Opcodes::T_INT]
+ [type.long org/objectweb/asm/Opcodes::T_LONG]
+ [type.float org/objectweb/asm/Opcodes::T_FLOAT]
+ [type.double org/objectweb/asm/Opcodes::T_DOUBLE]
+ [type.char org/objectweb/asm/Opcodes::T_CHAR]))
+ ## else
+ (undefined)))))))
+
+(template [<name> <inst> <interface?>]
+ [(def: #export (<name> class method-name method)
+ (-> (Type Class) Text (Type Method) Inst)
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitMethodInsn (<inst>)
+ (..class-name class)
+ method-name
+ (|> method type.descriptor descriptor.descriptor)
+ <interface?>))))]
+
+ [INVOKESTATIC org/objectweb/asm/Opcodes::INVOKESTATIC false]
+ [INVOKEVIRTUAL org/objectweb/asm/Opcodes::INVOKEVIRTUAL false]
+ [INVOKESPECIAL org/objectweb/asm/Opcodes::INVOKESPECIAL false]
+ [INVOKEINTERFACE org/objectweb/asm/Opcodes::INVOKEINTERFACE true]
+ )
+
+(template [<name>]
+ [(def: #export (<name> @where)
+ (-> //.Label Inst)
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitJumpInsn (!prefix <name>) @where))))]
+
+ [IF_ICMPEQ] [IF_ICMPGT] [IF_ICMPLT]
+ [IF_ICMPNE] [IF_ICMPGE] [IF_ICMPLE]
+ [IF_ACMPEQ] [IF_ACMPNE] [IFNULL] [IFNONNULL]
+ [IFEQ] [IFNE] [IFLT] [IFLE] [IFGT] [IFGE]
+ [GOTO]
+ )
+
+(def: #export (LOOKUPSWITCH default keys+labels)
+ (-> //.Label (List [Int //.Label]) Inst)
+ (function (_ visitor)
+ (let [keys+labels (list.sort (function (_ left right)
+ (i.< (product.left left) (product.left right)))
+ keys+labels)
+ array-size (list.size keys+labels)
+ keys-array (host.array int array-size)
+ labels-array (host.array org/objectweb/asm/Label array-size)
+ _ (loop [idx 0]
+ (if (n.< array-size idx)
+ (let [[key label] (maybe.assume (list.nth idx keys+labels))]
+ (exec
+ (host.array-write idx (host.long-to-int key) keys-array)
+ (host.array-write idx label labels-array)
+ (recur (inc idx))))
+ []))]
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitLookupSwitchInsn default keys-array labels-array)))))
+
+(def: #export (TABLESWITCH min max default labels)
+ (-> Int Int //.Label (List //.Label) Inst)
+ (function (_ visitor)
+ (let [num-labels (list.size labels)
+ labels-array (host.array org/objectweb/asm/Label num-labels)
+ _ (loop [idx 0]
+ (if (n.< num-labels idx)
+ (exec (host.array-write idx
+ (maybe.assume (list.nth idx labels))
+ labels-array)
+ (recur (inc idx)))
+ []))]
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitTableSwitchInsn min max default labels-array)))))
+
+(def: #export (try @from @to @handler exception)
+ (-> //.Label //.Label //.Label (Type Class) Inst)
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitTryCatchBlock @from @to @handler (..class-name exception)))))
+
+(def: #export (label @label)
+ (-> //.Label Inst)
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitLabel @label))))
+
+(def: #export (array elementT)
+ (-> (Type Value) Inst)
+ (case (type.primitive? elementT)
+ (#.Left elementT)
+ (ANEWARRAY elementT)
+
+ (#.Right elementT)
+ (NEWARRAY elementT)))
+
+(template [<name> <boolean> <byte> <short> <int> <long> <float> <double> <char>]
+ [(def: (<name> type)
+ (-> (Type Primitive) Text)
+ (`` (cond (~~ (template [<descriptor> <output>]
+ [(type@= <descriptor> type) <output>]
+
+ [type.boolean <boolean>]
+ [type.byte <byte>]
+ [type.short <short>]
+ [type.int <int>]
+ [type.long <long>]
+ [type.float <float>]
+ [type.double <double>]
+ [type.char <char>]))
+ ## else
+ (undefined))))]
+
+ [primitive-wrapper
+ box.boolean box.byte box.short box.int
+ box.long box.float box.double box.char]
+ [primitive-unwrap
+ "booleanValue" "byteValue" "shortValue" "intValue"
+ "longValue" "floatValue" "doubleValue" "charValue"]
+ )
+
+(def: #export (wrap type)
+ (-> (Type Primitive) Inst)
+ (let [wrapper (type.class (primitive-wrapper type) (list))]
+ (INVOKESTATIC wrapper "valueOf" (type.method [(list type) wrapper (list)]))))
+
+(def: #export (unwrap type)
+ (-> (Type Primitive) Inst)
+ (let [wrapper (type.class (primitive-wrapper type) (list))]
+ (|>> (CHECKCAST wrapper)
+ (INVOKEVIRTUAL wrapper (primitive-unwrap type) (type.method [(list) type (list)])))))
+
+(def: #export (fuse insts)
+ (-> (List Inst) Inst)
+ (case insts
+ #.Nil
+ function.identity
+
+ (#.Cons singleton #.Nil)
+ singleton
+
+ (#.Cons head tail)
+ (function.compose (fuse tail) head)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-07 18:17:43 +0000