aboutsummaryrefslogtreecommitdiff
path: root/lux-jvm/source/luxc/lang/directive/jvm.lux
diff options
context:
space:
mode:
Diffstat (limited to 'lux-jvm/source/luxc/lang/directive/jvm.lux')
-rw-r--r--lux-jvm/source/luxc/lang/directive/jvm.lux538
1 files changed, 538 insertions, 0 deletions
diff --git a/lux-jvm/source/luxc/lang/directive/jvm.lux b/lux-jvm/source/luxc/lang/directive/jvm.lux
new file mode 100644
index 000000000..27b1c8688
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/directive/jvm.lux
@@ -0,0 +1,538 @@
+(.module:
+ [lux #*
+ [host (#+ import:)]
+ [type (#+ :share)]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]]
+ [target
+ ["/" jvm]]
+ [data
+ [identity (#+ Identity)]
+ ["." product]
+ [number
+ ["." nat]]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#@." fold)]
+ ["." dictionary (#+ Dictionary)]
+ ["." row (#+ Row) ("#@." functor fold)]]]
+ [tool
+ [compiler
+ ["." phase]
+ [language
+ [lux
+ [synthesis (#+ Synthesis)]
+ ["." generation]
+ ["." directive]
+ [phase
+ ["." extension
+ ["." bundle]
+ [directive
+ ["./" lux]]]]]]]]]
+ [///
+ [host
+ ["." jvm (#+ Inst)
+ ["_" inst]]]])
+
+(import: #long org/objectweb/asm/Label
+ (new []))
+
+(def: (literal literal)
+ (-> /.Literal Inst)
+ (case literal
+ (#/.Boolean value) (_.boolean value)
+ (#/.Int value) (_.int value)
+ (#/.Long value) (_.long value)
+ (#/.Double value) (_.double value)
+ (#/.Char value) (_.char value)
+ (#/.String value) (_.string value)))
+
+(def: (constant instruction)
+ (-> /.Constant Inst)
+ (case instruction
+ (#/.BIPUSH constant) (_.BIPUSH constant)
+
+ (#/.SIPUSH constant) (_.SIPUSH constant)
+
+ #/.ICONST_M1 _.ICONST_M1
+ #/.ICONST_0 _.ICONST_0
+ #/.ICONST_1 _.ICONST_1
+ #/.ICONST_2 _.ICONST_2
+ #/.ICONST_3 _.ICONST_3
+ #/.ICONST_4 _.ICONST_4
+ #/.ICONST_5 _.ICONST_5
+
+ #/.LCONST_0 _.LCONST_0
+ #/.LCONST_1 _.LCONST_1
+
+ #/.FCONST_0 _.FCONST_0
+ #/.FCONST_1 _.FCONST_1
+ #/.FCONST_2 _.FCONST_2
+
+ #/.DCONST_0 _.DCONST_0
+ #/.DCONST_1 _.DCONST_1
+
+ #/.ACONST_NULL _.NULL
+
+ (#/.LDC literal)
+ (..literal literal)
+ ))
+
+(def: (int-arithmetic instruction)
+ (-> /.Int-Arithmetic Inst)
+ (case instruction
+ #/.IADD _.IADD
+ #/.ISUB _.ISUB
+ #/.IMUL _.IMUL
+ #/.IDIV _.IDIV
+ #/.IREM _.IREM
+ #/.INEG _.INEG))
+
+(def: (long-arithmetic instruction)
+ (-> /.Long-Arithmetic Inst)
+ (case instruction
+ #/.LADD _.LADD
+ #/.LSUB _.LSUB
+ #/.LMUL _.LMUL
+ #/.LDIV _.LDIV
+ #/.LREM _.LREM
+ #/.LNEG _.LNEG))
+
+(def: (float-arithmetic instruction)
+ (-> /.Float-Arithmetic Inst)
+ (case instruction
+ #/.FADD _.FADD
+ #/.FSUB _.FSUB
+ #/.FMUL _.FMUL
+ #/.FDIV _.FDIV
+ #/.FREM _.FREM
+ #/.FNEG _.FNEG))
+
+(def: (double-arithmetic instruction)
+ (-> /.Double-Arithmetic Inst)
+ (case instruction
+ #/.DADD _.DADD
+ #/.DSUB _.DSUB
+ #/.DMUL _.DMUL
+ #/.DDIV _.DDIV
+ #/.DREM _.DREM
+ #/.DNEG _.DNEG))
+
+(def: (arithmetic instruction)
+ (-> /.Arithmetic Inst)
+ (case instruction
+ (#/.Int-Arithmetic int-arithmetic)
+ (..int-arithmetic int-arithmetic)
+
+ (#/.Long-Arithmetic long-arithmetic)
+ (..long-arithmetic long-arithmetic)
+
+ (#/.Float-Arithmetic float-arithmetic)
+ (..float-arithmetic float-arithmetic)
+
+ (#/.Double-Arithmetic double-arithmetic)
+ (..double-arithmetic double-arithmetic)))
+
+(def: (int-bitwise instruction)
+ (-> /.Int-Bitwise Inst)
+ (case instruction
+ #/.IOR _.IOR
+ #/.IXOR _.IXOR
+ #/.IAND _.IAND
+ #/.ISHL _.ISHL
+ #/.ISHR _.ISHR
+ #/.IUSHR _.IUSHR))
+
+(def: (long-bitwise instruction)
+ (-> /.Long-Bitwise Inst)
+ (case instruction
+ #/.LOR _.LOR
+ #/.LXOR _.LXOR
+ #/.LAND _.LAND
+ #/.LSHL _.LSHL
+ #/.LSHR _.LSHR
+ #/.LUSHR _.LUSHR))
+
+(def: (bitwise instruction)
+ (-> /.Bitwise Inst)
+ (case instruction
+ (#/.Int-Bitwise int-bitwise)
+ (..int-bitwise int-bitwise)
+
+ (#/.Long-Bitwise long-bitwise)
+ (..long-bitwise long-bitwise)))
+
+(def: (conversion instruction)
+ (-> /.Conversion Inst)
+ (case instruction
+ #/.I2B _.I2B
+ #/.I2S _.I2S
+ #/.I2L _.I2L
+ #/.I2F _.I2F
+ #/.I2D _.I2D
+ #/.I2C _.I2C
+
+ #/.L2I _.L2I
+ #/.L2F _.L2F
+ #/.L2D _.L2D
+
+ #/.F2I _.F2I
+ #/.F2L _.F2L
+ #/.F2D _.F2D
+
+ #/.D2I _.D2I
+ #/.D2L _.D2L
+ #/.D2F _.D2F))
+
+(def: (array instruction)
+ (-> /.Array Inst)
+ (case instruction
+ #/.ARRAYLENGTH _.ARRAYLENGTH
+
+ (#/.NEWARRAY type) (_.NEWARRAY type)
+ (#/.ANEWARRAY type) (_.ANEWARRAY type)
+
+ #/.BALOAD _.BALOAD
+ #/.BASTORE _.BASTORE
+
+ #/.SALOAD _.SALOAD
+ #/.SASTORE _.SASTORE
+
+ #/.IALOAD _.IALOAD
+ #/.IASTORE _.IASTORE
+
+ #/.LALOAD _.LALOAD
+ #/.LASTORE _.LASTORE
+
+ #/.FALOAD _.FALOAD
+ #/.FASTORE _.FASTORE
+
+ #/.DALOAD _.DALOAD
+ #/.DASTORE _.DASTORE
+
+ #/.CALOAD _.CALOAD
+ #/.CASTORE _.CASTORE
+
+ #/.AALOAD _.AALOAD
+ #/.AASTORE _.AASTORE))
+
+(def: (object instruction)
+ (-> /.Object Inst)
+ (case instruction
+ (^template [<tag> <inst>]
+ (<tag> class field-name field-type)
+ (<inst> class field-name field-type))
+ ([#/.GETSTATIC _.GETSTATIC]
+ [#/.PUTSTATIC _.PUTSTATIC]
+ [#/.GETFIELD _.GETFIELD]
+ [#/.PUTFIELD _.PUTFIELD])
+
+ (#/.NEW type) (_.NEW type)
+
+ (#/.INSTANCEOF type) (_.INSTANCEOF type)
+ (#/.CHECKCAST type) (_.CHECKCAST type)
+
+ (^template [<tag> <inst>]
+ (<tag> class method-name method-type)
+ (<inst> class method-name method-type))
+ ([#/.INVOKEINTERFACE _.INVOKEINTERFACE]
+ [#/.INVOKESPECIAL _.INVOKESPECIAL]
+ [#/.INVOKESTATIC _.INVOKESTATIC]
+ [#/.INVOKEVIRTUAL _.INVOKEVIRTUAL])
+ ))
+
+(def: (local-int instruction)
+ (-> /.Local-Int Inst)
+ (case instruction
+ (#/.ILOAD register) (_.ILOAD register)
+ (#/.ISTORE register) (_.ISTORE register)))
+
+(def: (local-long instruction)
+ (-> /.Local-Long Inst)
+ (case instruction
+ (#/.LLOAD register) (_.LLOAD register)
+ (#/.LSTORE register) (_.LSTORE register)))
+
+(def: (local-float instruction)
+ (-> /.Local-Float Inst)
+ (case instruction
+ (#/.FLOAD register) (_.FLOAD register)
+ (#/.FSTORE register) (_.FSTORE register)))
+
+(def: (local-double instruction)
+ (-> /.Local-Double Inst)
+ (case instruction
+ (#/.DLOAD register) (_.DLOAD register)
+ (#/.DSTORE register) (_.DSTORE register)))
+
+(def: (local-object instruction)
+ (-> /.Local-Object Inst)
+ (case instruction
+ (#/.ALOAD register) (_.ALOAD register)
+ (#/.ASTORE register) (_.ASTORE register)))
+
+(def: (local instruction)
+ (-> /.Local Inst)
+ (case instruction
+ (#/.Local-Int instruction) (..local-int instruction)
+ (#/.IINC register) (_.IINC register)
+ (#/.Local-Long instruction) (..local-long instruction)
+ (#/.Local-Float instruction) (..local-float instruction)
+ (#/.Local-Double instruction) (..local-double instruction)
+ (#/.Local-Object instruction) (..local-object instruction)))
+
+(def: (stack instruction)
+ (-> /.Stack Inst)
+ (case instruction
+ #/.DUP _.DUP
+ #/.DUP_X1 _.DUP_X1
+ #/.DUP_X2 _.DUP_X2
+ #/.DUP2 _.DUP2
+ #/.DUP2_X1 _.DUP2_X1
+ #/.DUP2_X2 _.DUP2_X2
+ #/.SWAP _.SWAP
+ #/.POP _.POP
+ #/.POP2 _.POP2))
+
+(def: (comparison instruction)
+ (-> /.Comparison Inst)
+ (case instruction
+ #/.LCMP _.LCMP
+
+ #/.FCMPG _.FCMPG
+ #/.FCMPL _.FCMPL
+
+ #/.DCMPG _.DCMPG
+ #/.DCMPL _.DCMPL))
+
+(def: (branching instruction)
+ (-> (/.Branching org/objectweb/asm/Label) Inst)
+ (case instruction
+ (#/.IF_ICMPEQ label) (_.IF_ICMPEQ label)
+ (#/.IF_ICMPGE label) (_.IF_ICMPGE label)
+ (#/.IF_ICMPGT label) (_.IF_ICMPGT label)
+ (#/.IF_ICMPLE label) (_.IF_ICMPLE label)
+ (#/.IF_ICMPLT label) (_.IF_ICMPLT label)
+ (#/.IF_ICMPNE label) (_.IF_ICMPNE label)
+ (#/.IFEQ label) (_.IFEQ label)
+ (#/.IFGE label) (_.IFGE label)
+ (#/.IFGT label) (_.IFGT label)
+ (#/.IFLE label) (_.IFLE label)
+ (#/.IFLT label) (_.IFLT label)
+ (#/.IFNE label) (_.IFNE label)
+
+ (#/.TABLESWITCH min max default labels)
+ (_.TABLESWITCH min max default labels)
+
+ (#/.LOOKUPSWITCH default keys+labels)
+ (_.LOOKUPSWITCH default keys+labels)
+
+ (#/.IF_ACMPEQ label) (_.IF_ACMPEQ label)
+ (#/.IF_ACMPNE label) (_.IF_ACMPNE label)
+ (#/.IFNONNULL label) (_.IFNONNULL label)
+ (#/.IFNULL label) (_.IFNULL label)))
+
+(def: (exception instruction)
+ (-> (/.Exception org/objectweb/asm/Label) Inst)
+ (case instruction
+ (#/.Try start end handler exception) (_.try start end handler exception)
+ #/.ATHROW _.ATHROW))
+
+(def: (concurrency instruction)
+ (-> /.Concurrency Inst)
+ (case instruction
+ #/.MONITORENTER _.MONITORENTER
+ #/.MONITOREXIT _.MONITOREXIT))
+
+(def: (return instruction)
+ (-> /.Return Inst)
+ (case instruction
+ #/.RETURN _.RETURN
+ #/.IRETURN _.IRETURN
+ #/.LRETURN _.LRETURN
+ #/.FRETURN _.FRETURN
+ #/.DRETURN _.DRETURN
+ #/.ARETURN _.ARETURN))
+
+(def: (control instruction)
+ (-> (/.Control org/objectweb/asm/Label) Inst)
+ (case instruction
+ (#/.GOTO label) (_.GOTO label)
+ (#/.Branching instruction) (..branching instruction)
+ (#/.Exception instruction) (..exception instruction)
+ (#/.Concurrency instruction) (..concurrency instruction)
+ (#/.Return instruction) (..return instruction)))
+
+(def: (instruction instruction)
+ (-> (/.Instruction org/objectweb/asm/Label) Inst)
+ (case instruction
+ #/.NOP _.NOP
+ (#/.Constant instruction) (..constant instruction)
+ (#/.Arithmetic instruction) (..arithmetic instruction)
+ (#/.Bitwise instruction) (..bitwise instruction)
+ (#/.Conversion instruction) (..conversion instruction)
+ (#/.Array instruction) (..array instruction)
+ (#/.Object instruction) (..object instruction)
+ (#/.Local instruction) (..local instruction)
+ (#/.Stack instruction) (..stack instruction)
+ (#/.Comparison instruction) (..comparison instruction)
+ (#/.Control instruction) (..control instruction)))
+
+(type: Mapping
+ (Dictionary /.Label org/objectweb/asm/Label))
+
+(type: (Re-labeler context)
+ (-> [Mapping (context /.Label)]
+ [Mapping (context org/objectweb/asm/Label)]))
+
+(def: (relabel [mapping label])
+ (Re-labeler Identity)
+ (case (dictionary.get label mapping)
+ (#.Some label)
+ [mapping label]
+
+ #.None
+ (let [label' (org/objectweb/asm/Label::new)]
+ [(dictionary.put label label' mapping) label'])))
+
+(def: (relabel-branching [mapping instruction])
+ (Re-labeler /.Branching)
+ (case instruction
+ (^template [<tag>]
+ (<tag> label)
+ (let [[mapping label] (..relabel [mapping label])]
+ [mapping (<tag> label)]))
+ ([#/.IF_ICMPEQ] [#/.IF_ICMPGE] [#/.IF_ICMPGT] [#/.IF_ICMPLE] [#/.IF_ICMPLT] [#/.IF_ICMPNE]
+ [#/.IFEQ] [#/.IFNE] [#/.IFGE] [#/.IFGT] [#/.IFLE] [#/.IFLT]
+
+ [#/.IF_ACMPEQ] [#/.IF_ACMPNE] [#/.IFNONNULL] [#/.IFNULL])
+
+ (#/.TABLESWITCH min max default labels)
+ (let [[mapping default] (..relabel [mapping default])
+ [mapping labels] (list@fold (function (_ input [mapping output])
+ (let [[mapping input] (..relabel [mapping input])]
+ [mapping (list& input output)]))
+ [mapping (list)] labels)]
+ [mapping (#/.TABLESWITCH min max default (list.reverse labels))])
+
+ (#/.LOOKUPSWITCH default keys+labels)
+ (let [[mapping default] (..relabel [mapping default])
+ [mapping keys+labels] (list@fold (function (_ [expected input] [mapping output])
+ (let [[mapping input] (..relabel [mapping input])]
+ [mapping (list& [expected input] output)]))
+ [mapping (list)] keys+labels)]
+ [mapping (#/.LOOKUPSWITCH default (list.reverse keys+labels))])
+ ))
+
+(def: (relabel-exception [mapping instruction])
+ (Re-labeler /.Exception)
+ (case instruction
+ (#/.Try start end handler exception)
+ (let [[mapping start] (..relabel [mapping start])
+ [mapping end] (..relabel [mapping end])
+ [mapping handler] (..relabel [mapping handler])]
+ [mapping (#/.Try start end handler exception)])
+
+ #/.ATHROW
+ [mapping #/.ATHROW]
+ ))
+
+(def: (relabel-control [mapping instruction])
+ (Re-labeler /.Control)
+ (case instruction
+ (^template [<tag> <relabel>]
+ (<tag> instruction)
+ (let [[mapping instruction] (<relabel> [mapping instruction])]
+ [mapping (<tag> instruction)]))
+ ([#/.GOTO ..relabel]
+ [#/.Branching ..relabel-branching]
+ [#/.Exception ..relabel-exception])
+
+ (^template [<tag>]
+ (<tag> instruction)
+ [mapping (<tag> instruction)])
+ ([#/.Concurrency] [#/.Return])
+ ))
+
+(def: (relabel-instruction [mapping instruction])
+ (Re-labeler /.Instruction)
+ (case instruction
+ #/.NOP [mapping #/.NOP]
+
+ (^template [<tag>]
+ (<tag> instruction)
+ [mapping (<tag> instruction)])
+ ([#/.Constant]
+ [#/.Arithmetic]
+ [#/.Bitwise]
+ [#/.Conversion]
+ [#/.Array]
+ [#/.Object]
+ [#/.Local]
+ [#/.Stack]
+ [#/.Comparison])
+
+ (#/.Control instruction)
+ (let [[mapping instruction] (..relabel-control [mapping instruction])]
+ [mapping (#/.Control instruction)])))
+
+(def: (relabel-bytecode [mapping bytecode])
+ (Re-labeler /.Bytecode)
+ (row@fold (function (_ input [mapping output])
+ (let [[mapping input] (..relabel-instruction [mapping input])]
+ [mapping (row.add input output)]))
+ [mapping (row.row)]
+ bytecode))
+
+(def: fresh
+ Mapping
+ (dictionary.new nat.hash))
+
+(def: bytecode
+ (-> (/.Bytecode /.Label) Inst)
+ (|>> [..fresh]
+ ..relabel-bytecode
+ product.right
+ (row@map ..instruction)
+ row.to-list
+ _.fuse))
+
+(type: Pseudo-Handler
+ (-> Text (List Synthesis) (Try (/.Bytecode /.Label))))
+
+(def: (true-handler pseudo)
+ (-> Pseudo-Handler jvm.Handler)
+ (function (_ extension-name phase archive inputs)
+ (|> (pseudo extension-name inputs)
+ (:: try.monad map ..bytecode)
+ phase.lift)))
+
+(def: (def::generation extender)
+ (-> jvm.Extender
+ (directive.Handler jvm.Anchor jvm.Inst jvm.Definition))
+ (function (handler extension-name phase archive inputsC+)
+ (case inputsC+
+ (^ (list nameC valueC))
+ (do phase.monad
+ [[_ _ name] (lux/.evaluate! archive Text nameC)
+ [_ _ pseudo-handlerV] (lux/.evaluate! archive ..Pseudo-Handler valueC)
+ _ (|> pseudo-handlerV
+ (:coerce ..Pseudo-Handler)
+ ..true-handler
+ (extension.install extender (:coerce Text name))
+ directive.lift-generation)
+ _ (directive.lift-generation
+ (generation.log! (format "Generation " (%.text (:coerce Text name)))))]
+ (wrap directive.no-requirements))
+
+ _
+ (phase.throw extension.invalid-syntax [extension-name %.code inputsC+]))))
+
+(def: #export (bundle extender)
+ (-> jvm.Extender
+ (directive.Bundle jvm.Anchor jvm.Inst jvm.Definition))
+ (|> bundle.empty
+ (dictionary.put "lux def generation" (..def::generation extender))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-05 00:57:42 +0000