From b4d0eba7485caf0c6cf58de1193a9114fa273d8b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 30 May 2020 15:19:28 -0400 Subject: Split new-luxc into lux-jvm and lux-r. --- new-luxc/source/luxc/lang/directive/jvm.lux | 538 ---------------------------- 1 file changed, 538 deletions(-) delete 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 deleted file mode 100644 index 27b1c8688..000000000 --- a/new-luxc/source/luxc/lang/directive/jvm.lux +++ /dev/null @@ -1,538 +0,0 @@ -(.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 [ ] - ( 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 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)))) -- cgit v1.2.3