From ecb53b05a226d8d3d8e612f949cb3ad6ac0600ce Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 28 Dec 2019 17:00:04 -0400 Subject: Implemented an alternative method for extensible JVM bytecode generation. --- new-luxc/source/luxc/lang/directive/jvm.lux | 537 ++++++++++++++++++++++++++++ 1 file changed, 537 insertions(+) create mode 100644 new-luxc/source/luxc/lang/directive/jvm.lux (limited to 'new-luxc/source/luxc/lang/directive/jvm.lux') diff --git a/new-luxc/source/luxc/lang/directive/jvm.lux b/new-luxc/source/luxc/lang/directive/jvm.lux new file mode 100644 index 000000000..821ee7605 --- /dev/null +++ b/new-luxc/source/luxc/lang/directive/jvm.lux @@ -0,0 +1,537 @@ +(.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 + [synthesis (#+ Synthesis)] + ["." directive] + ["." phase + ["." generation] + ["." extension (#+ Extender) + ["." 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 [ ] + ( class field-name field-type) + ( 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 [ ] + ( class method-name method-type) + ( 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 [] + ( label) + (let [[mapping label] (..relabel [mapping label])] + [mapping ( 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 [ ] + ( instruction) + (let [[mapping instruction] ( [mapping instruction])] + [mapping ( instruction)])) + ([#/.GOTO ..relabel] + [#/.Branching ..relabel-branching] + [#/.Exception ..relabel-exception]) + + (^template [] + ( instruction) + [mapping ( instruction)]) + ([#/.Concurrency] [#/.Return]) + )) + +(def: (relabel-instruction [mapping instruction]) + (Re-labeler /.Instruction) + (case instruction + #/.NOP [mapping #/.NOP] + + (^template [] + ( instruction) + [mapping ( 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 inputs) + (|> (pseudo extension-name inputs) + (:: try.monad map ..bytecode) + phase.lift))) + +(def: (def::generation extender) + (All [anchor expression directive] + (-> Extender (directive.Handler anchor expression directive))) + (function (handler extension-name phase inputsC+) + (case inputsC+ + (^ (list nameC valueC)) + (do phase.monad + [[_ _ name] (lux/.evaluate! Text nameC) + [_ _ pseudo-handlerV] (lux/.evaluate! ..Pseudo-Handler valueC) + _ (<| directive.lift-generation + (extension.install extender (:coerce Text name)) + (:share [anchor expression directive] + {(directive.Handler anchor expression directive) + handler} + {(generation.Handler anchor expression directive) + (<| ..true-handler + (:coerce ..Pseudo-Handler) + pseudo-handlerV)})) + #let [_ (log! (format "Generation " (%.text (:coerce Text name))))]] + (wrap directive.no-requirements)) + + _ + (phase.throw extension.invalid-syntax [extension-name %.code inputsC+])))) + +(def: #export (bundle extender) + (-> Extender directive.Bundle) + (|> bundle.empty + (dictionary.put "lux def generation" (..def::generation extender)))) -- cgit v1.2.3