diff options
| -rw-r--r-- | new-luxc/source/luxc/lang/directive/jvm.lux | 537 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/host/jvm/inst.lux | 73 | ||||
| -rw-r--r-- | new-luxc/source/program.lux | 10 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm.lux | 282 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/phase/extension/directive/lux.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/spec/compositor/common.lux | 20 | ||||
| -rw-r--r-- | stdlib/source/test/lux/extension.lux | 65 |
7 files changed, 942 insertions, 47 deletions
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 [<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 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)))) diff --git a/new-luxc/source/luxc/lang/host/jvm/inst.lux b/new-luxc/source/luxc/lang/host/jvm/inst.lux index e52d11d9b..b673c7d7e 100644 --- a/new-luxc/source/luxc/lang/host/jvm/inst.lux +++ b/new-luxc/source/luxc/lang/host/jvm/inst.lux @@ -72,21 +72,27 @@ ## Jump (~~ (declare IF_ICMPEQ IF_ICMPGT IF_ICMPLT IF_ICMPNE IF_ICMPGE IF_ICMPLE - IF_ACMPEQ IFNULL + 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 ILOAD LLOAD DLOAD ALOAD - ISTORE LSTORE ASTORE)) + (~~ (declare IINC + ILOAD LLOAD FLOAD DLOAD ALOAD + ISTORE LSTORE FSTORE DSTORE ASTORE)) ## Arithmetic - (~~ (declare IADD ISUB IMUL IDIV IREM - LADD LSUB LMUL LDIV LREM LCMP - FADD FSUB FMUL FDIV FREM FCMPG FCMPL - DADD DSUB DMUL DDIV DREM DCMPG DCMPL)) + (~~ (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 @@ -162,21 +168,45 @@ [string Text function.identity] ) -(template: (prefix short) +(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))))) + (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>)))))] + (org/objectweb/asm/MethodVisitor::visitInsn (!prefix <name>)))))] [NOP] @@ -192,23 +222,23 @@ [L2D] [L2F] [L2I] ## Integer arithmetic - [IADD] [ISUB] [IMUL] [IDIV] [IREM] + [IADD] [ISUB] [IMUL] [IDIV] [IREM] [INEG] ## Integer bitwise [IAND] [IOR] [IXOR] [ISHL] [ISHR] [IUSHR] ## Long arithmetic - [LADD] [LSUB] [LMUL] [LDIV] [LREM] + [LADD] [LSUB] [LMUL] [LDIV] [LREM] [LNEG] [LCMP] ## Long bitwise [LAND] [LOR] [LXOR] [LSHL] [LSHR] [LUSHR] ## Float arithmetic - [FADD] [FSUB] [FMUL] [FDIV] [FREM] [FCMPG] [FCMPL] + [FADD] [FSUB] [FMUL] [FDIV] [FREM] [FNEG] [FCMPG] [FCMPL] ## Double arithmetic - [DADD] [DSUB] [DMUL] [DDIV] [DREM] + [DADD] [DSUB] [DMUL] [DDIV] [DREM] [DNEG] [DCMPG] [DCMPL] ## Array @@ -232,15 +262,18 @@ [RETURN] [IRETURN] [LRETURN] [FRETURN] [DRETURN] [ARETURN] ) +(type: #export Register Nat) + (template [<name>] [(def: #export (<name> register) - (-> Nat Inst) + (-> Register Inst) (function (_ visitor) (do-to visitor - (org/objectweb/asm/MethodVisitor::visitVarInsn (prefix <name>) (.int register)))))] + (org/objectweb/asm/MethodVisitor::visitVarInsn (!prefix <name>) (.int register)))))] - [ILOAD] [LLOAD] [DLOAD] [ALOAD] - [ISTORE] [LSTORE] [ASTORE] + [IINC] + [ILOAD] [LLOAD] [FLOAD] [DLOAD] [ALOAD] + [ISTORE] [LSTORE] [FSTORE] [DSTORE] [ASTORE] ) (template [<name> <inst>] @@ -317,11 +350,11 @@ (-> //.Label Inst) (function (_ visitor) (do-to visitor - (org/objectweb/asm/MethodVisitor::visitJumpInsn (prefix <name>) @where))))] + (org/objectweb/asm/MethodVisitor::visitJumpInsn (!prefix <name>) @where))))] [IF_ICMPEQ] [IF_ICMPGT] [IF_ICMPLT] [IF_ICMPNE] [IF_ICMPGE] [IF_ICMPLE] - [IF_ACMPEQ] [IFNULL] + [IF_ACMPEQ] [IF_ACMPNE] [IFNULL] [IFNONNULL] [IFEQ] [IFNE] [IFLT] [IFLE] [IFGT] [IFGE] [GOTO] ) diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux index d802f7f32..51f817b6f 100644 --- a/new-luxc/source/program.lux +++ b/new-luxc/source/program.lux @@ -25,11 +25,11 @@ [phase ["." macro (#+ Expander)] [extension (#+ Phase Bundle Operation Handler Extender) - ["." bundle] ["." analysis #_ ["#" jvm]] - ["." directive #_ - ["#" jvm]]] + ## ["." directive #_ + ## ["#" jvm]] + ] ["." generation #_ ["#" jvm/extension] ["." jvm #_ @@ -46,6 +46,8 @@ [lang [host ["_" jvm]] + ["." directive #_ + ["#" jvm]] [translation ["." jvm ["." runtime] @@ -149,7 +151,7 @@ ..platform ## generation.bundle translation.bundle - bundle.empty + (directive.bundle extender) jvm/program.program ..extender service diff --git a/stdlib/source/lux/target/jvm.lux b/stdlib/source/lux/target/jvm.lux new file mode 100644 index 000000000..4998f0f05 --- /dev/null +++ b/stdlib/source/lux/target/jvm.lux @@ -0,0 +1,282 @@ +(.module: + [lux (#- Type) + [data + [collection + [row (#+ Row)]]] + [target + [jvm + [type (#+ Type) + ["." category (#+ Primitive Class Value Method)]]]]]) + +(type: #export Literal + (#Boolean Bit) + (#Int Int) + (#Long Int) + (#Double Frac) + (#Char Nat) + (#String Text)) + +(type: #export Constant + (#BIPUSH Int) + + (#SIPUSH Int) + + #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 + + #ACONST_NULL + + (#LDC Literal)) + +(type: #export Int-Arithmetic + #IADD + #ISUB + #IMUL + #IDIV + #IREM + #INEG) + +(type: #export Long-Arithmetic + #LADD + #LSUB + #LMUL + #LDIV + #LREM + #LNEG) + +(type: #export Float-Arithmetic + #FADD + #FSUB + #FMUL + #FDIV + #FREM + #FNEG) + +(type: #export Double-Arithmetic + #DADD + #DSUB + #DMUL + #DDIV + #DREM + #DNEG) + +(type: #export Arithmetic + (#Int-Arithmetic Int-Arithmetic) + (#Long-Arithmetic Long-Arithmetic) + (#Float-Arithmetic Float-Arithmetic) + (#Double-Arithmetic Double-Arithmetic)) + +(type: #export Int-Bitwise + #IOR + #IXOR + #IAND + #ISHL + #ISHR + #IUSHR) + +(type: #export Long-Bitwise + #LOR + #LXOR + #LAND + #LSHL + #LSHR + #LUSHR) + +(type: #export Bitwise + (#Int-Bitwise Int-Bitwise) + (#Long-Bitwise Long-Bitwise)) + +(type: #export Conversion + #I2B + #I2S + #I2L + #I2F + #I2D + #I2C + + #L2I + #L2F + #L2D + + #F2I + #F2L + #F2D + + #D2I + #D2L + #D2F) + +(type: #export Array + #ARRAYLENGTH + + (#NEWARRAY (Type Primitive)) + (#ANEWARRAY (Type category.Object)) + + #BALOAD + #BASTORE + + #SALOAD + #SASTORE + + #IALOAD + #IASTORE + + #LALOAD + #LASTORE + + #FALOAD + #FASTORE + + #DALOAD + #DASTORE + + #CALOAD + #CASTORE + + #AALOAD + #AASTORE) + +(type: #export Object + (#GETSTATIC (Type Class) Text (Type Value)) + (#PUTSTATIC (Type Class) Text (Type Value)) + + (#NEW (Type Class)) + + (#INSTANCEOF (Type Class)) + (#CHECKCAST (Type category.Object)) + + (#GETFIELD (Type Class) Text (Type Value)) + (#PUTFIELD (Type Class) Text (Type Value)) + + (#INVOKEINTERFACE (Type Class) Text (Type Method)) + (#INVOKESPECIAL (Type Class) Text (Type Method)) + (#INVOKESTATIC (Type Class) Text (Type Method)) + (#INVOKEVIRTUAL (Type Class) Text (Type Method))) + +(type: #export Register Nat) + +(type: #export Local-Int + (#ILOAD Register) + (#ISTORE Register)) + +(type: #export Local-Long + (#LLOAD Register) + (#LSTORE Register)) + +(type: #export Local-Float + (#FLOAD Register) + (#FSTORE Register)) + +(type: #export Local-Double + (#DLOAD Register) + (#DSTORE Register)) + +(type: #export Local-Object + (#ALOAD Register) + (#ASTORE Register)) + +(type: #export Local + (#Local-Int Local-Int) + (#IINC Register) + (#Local-Long Local-Long) + (#Local-Float Local-Float) + (#Local-Double Local-Double) + (#Local-Object Local-Object)) + +(type: #export Stack + #DUP + #DUP_X1 + #DUP_X2 + #DUP2 + #DUP2_X1 + #DUP2_X2 + #SWAP + #POP + #POP2) + +(type: #export Comparison + #LCMP + + #FCMPG + #FCMPL + + #DCMPG + #DCMPL) + +(type: #export Label Nat) + +(type: #export (Branching label) + (#IF_ICMPEQ label) + (#IF_ICMPGE label) + (#IF_ICMPGT label) + (#IF_ICMPLE label) + (#IF_ICMPLT label) + (#IF_ICMPNE label) + (#IFEQ label) + (#IFNE label) + (#IFGE label) + (#IFGT label) + (#IFLE label) + (#IFLT label) + + (#TABLESWITCH Int Int label (List label)) + (#LOOKUPSWITCH label (List [Int label])) + + (#IF_ACMPEQ label) + (#IF_ACMPNE label) + (#IFNONNULL label) + (#IFNULL label)) + +(type: #export (Exception label) + (#Try label label label (Type Class)) + #ATHROW) + +(type: #export Concurrency + #MONITORENTER + #MONITOREXIT) + +(type: #export Return + #RETURN + #IRETURN + #LRETURN + #FRETURN + #DRETURN + #ARETURN) + +(type: #export (Control label) + (#GOTO label) + (#Branching (Branching label)) + (#Exception (Exception label)) + (#Concurrency Concurrency) + (#Return Return)) + +(type: #export (Instruction label) + #NOP + (#Constant Constant) + (#Arithmetic Arithmetic) + (#Bitwise Bitwise) + (#Conversion Conversion) + (#Array Array) + (#Object Object) + (#Local Local) + (#Stack Stack) + (#Comparison Comparison) + (#Control (Control label))) + +(type: #export (Bytecode label) + (Row (Instruction label))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/directive/lux.lux b/stdlib/source/lux/tool/compiler/phase/extension/directive/lux.lux index ccf8c8d96..856648097 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/directive/lux.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/directive/lux.lux @@ -65,7 +65,7 @@ codeV (////generation.evaluate! (format "evaluate" (%.nat id)) codeT)] (wrap [code//type codeT codeV])))) -(def: (evaluate! type codeC) +(def: #export (evaluate! type codeC) (All [anchor expression directive] (-> Type Code (Operation anchor expression directive [Type expression Any]))) (do ////.monad diff --git a/stdlib/source/spec/compositor/common.lux b/stdlib/source/spec/compositor/common.lux index 05fbe7fc2..df351c008 100644 --- a/stdlib/source/spec/compositor/common.lux +++ b/stdlib/source/spec/compositor/common.lux @@ -8,12 +8,13 @@ [tool [compiler ["." reference] + ["." analysis] ["." synthesis (#+ Synthesis)] ["." directive] ["." phase ["." macro (#+ Expander)] - ["." generation (#+ Operation Bundle)] - [extension + ["." generation (#+ Operation)] + [extension (#+ Extender) ["." bundle]]] [default ["." platform (#+ Platform)]]]]]) @@ -53,17 +54,20 @@ (phase (synthesis.constant lux-name))))] (:: host evaluate! "definer" definitionG)))) -(def: #export (executors platform bundle expander program) +(def: #export (executors target expander platform + analysis-bundle generation-bundle directive-bundle + program extender) (All [anchor expression directive] - (-> (Platform IO anchor expression directive) - (Bundle anchor expression directive) - Expander - (-> expression directive) + (-> Text Expander (Platform IO anchor expression directive) + analysis.Bundle + (generation.Bundle anchor expression directive) + (directive.Bundle anchor expression directive) + (-> expression directive) Extender (IO (Try [(directive.State+ anchor expression directive) Runner Definer])))) (do io.monad - [?state (platform.initialize expander platform bundle program)] + [?state (platform.initialize target expander analysis-bundle platform generation-bundle directive-bundle program extender)] (wrap (do try.monad [[directive-bundle directive-state] ?state #let [generation-state (get@ [#directive.generation diff --git a/stdlib/source/test/lux/extension.lux b/stdlib/source/test/lux/extension.lux index 7b2d9ffd5..23c33c620 100644 --- a/stdlib/source/test/lux/extension.lux +++ b/stdlib/source/test/lux/extension.lux @@ -1,9 +1,11 @@ (.module: [lux #* - ["@" target] + ["@" target + ["." jvm]] [abstract [monad (#+ do)]] [control + ["." try] ["<>" parser ["<c>" code] ["<a>" analysis]]] @@ -20,33 +22,68 @@ ["." type]]]]] ["_" test (#+ Test)]] {1 - ["." / (#+ analysis: synthesis: directive:)]}) + ["." / (#+ analysis: synthesis: generation: directive:)]}) -(def: my-extension "example YOLO") +(def: my-analysis "my analysis") +(def: my-synthesis "my synthesis") +(def: my-generation "my generation") +(def: my-directive "my directive") (`` (for {(~~ (static @.old)) - (as-is)} - (as-is (analysis: (..my-extension self phase {parameters (<>.some <c>.any)}) + (as-is) + + (~~ (static @.jvm)) + (as-is (generation: (..my-generation self phase {parameters (<>.some <a>.any)}) + (#try.Success (#jvm.Constant (#jvm.LDC (#jvm.String Text))))))} + (as-is (analysis: (..my-analysis self phase {parameters (<>.some <c>.any)}) + (do @ + [_ (type.infer .Text)] + (wrap (#analysis.Text self)))) + + ## Synthesis + (analysis: (..my-synthesis self phase {parameters (<>.some <c>.any)}) (do @ [_ (type.infer .Text)] (wrap (#analysis.Extension self (list))))) - (synthesis: (..my-extension self phase {parameters (<>.some <a>.any)}) + (synthesis: (..my-synthesis self phase {parameters (<>.some <a>.any)}) (wrap (synthesis.text self))) + + ## Generation + (analysis: (..my-generation self phase {parameters (<>.some <c>.any)}) + (do @ + [_ (type.infer .Text)] + (wrap (#analysis.Extension self (list))))) + + (synthesis: (..my-generation self phase {parameters (<>.some <a>.any)}) + (wrap (#synthesis.Extension self (list)))) - (directive: (..my-extension self phase {parameters (<>.some <c>.any)}) + ## Directive + (directive: (..my-directive self phase {parameters (<>.some <c>.any)}) (do @ - [#let [_ (log! (format "directive: " (%.text self)))]] + [#let [_ (log! (format "Successfully installed directive " (%.text self) "!"))]] (wrap directive.no-requirements))) - ("example YOLO") + (`` ((~~ (static ..my-directive)))) ))) (def: #export test Test (<| (_.context (%.name (name-of /._))) - (_.test "Can define and use analysis & synthesis extensions." - (`` (for {(~~ (static @.old)) - false} - (text@= ("example YOLO") - "example YOLO")))))) + ($_ _.and + (_.test "Can define and use analysis extensions." + (`` (for {(~~ (static @.old)) + false} + (text@= ((~~ (static ..my-analysis))) + ..my-analysis)))) + (_.test "Can define and use synthesis extensions." + (`` (for {(~~ (static @.old)) + false} + (text@= ((~~ (static ..my-synthesis))) + ..my-synthesis)))) + (_.test "Can define and use generation extensions." + (`` (for {(~~ (static @.old)) + false} + (text@= ((~~ (static ..my-generation))) + ..my-generation)))) + ))) |