diff options
Diffstat (limited to 'lux-jvm/source/luxc/lang')
19 files changed, 4600 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)))) 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))) diff --git a/lux-jvm/source/luxc/lang/synthesis/variable.lux b/lux-jvm/source/luxc/lang/synthesis/variable.lux new file mode 100644 index 000000000..f6a45b02e --- /dev/null +++ b/lux-jvm/source/luxc/lang/synthesis/variable.lux @@ -0,0 +1,98 @@ +(.module: + lux + (lux (data [number] + (coll [list "list/" Fold<List> Monoid<List>] + ["s" set]))) + (luxc (lang ["la" analysis] + ["ls" synthesis] + [".L" variable #+ Variable]))) + +(def: (bound-vars path) + (-> ls.Path (List Variable)) + (case path + (#ls.BindP register) + (list (.int register)) + + (^or (#ls.SeqP pre post) (#ls.AltP pre post)) + (list/compose (bound-vars pre) (bound-vars post)) + + _ + (list))) + +(def: (path-bodies path) + (-> ls.Path (List ls.Synthesis)) + (case path + (#ls.ExecP body) + (list body) + + (#ls.SeqP pre post) + (path-bodies post) + + (#ls.AltP pre post) + (list/compose (path-bodies pre) (path-bodies post)) + + _ + (list))) + +(def: (non-arg? arity var) + (-> ls.Arity Variable Bit) + (and (variableL.local? var) + (n/> arity (.nat var)))) + +(type: Tracker (s.Set Variable)) + +(def: init-tracker Tracker (s.new number.Hash<Int>)) + +(def: (unused-vars current-arity bound exprS) + (-> ls.Arity (List Variable) ls.Synthesis (List Variable)) + (let [tracker (loop [exprS exprS + tracker (list/fold s.add init-tracker bound)] + (case exprS + (#ls.Variable var) + (if (non-arg? current-arity var) + (s.remove var tracker) + tracker) + + (#ls.Variant tag last? memberS) + (recur memberS tracker) + + (#ls.Tuple membersS) + (list/fold recur tracker membersS) + + (#ls.Call funcS argsS) + (list/fold recur (recur funcS tracker) argsS) + + (^or (#ls.Recur argsS) + (#ls.Procedure name argsS)) + (list/fold recur tracker argsS) + + (#ls.Let offset inputS outputS) + (|> tracker (recur inputS) (recur outputS)) + + (#ls.If testS thenS elseS) + (|> tracker (recur testS) (recur thenS) (recur elseS)) + + (#ls.Loop offset initsS bodyS) + (recur bodyS (list/fold recur tracker initsS)) + + (#ls.Case inputS outputPS) + (let [tracker' (list/fold s.add + (recur inputS tracker) + (bound-vars outputPS))] + (list/fold recur tracker' (path-bodies outputPS))) + + (#ls.Function arity env bodyS) + (list/fold s.remove tracker env) + + _ + tracker + ))] + (s.to-list tracker))) + +## (def: (optimize-register-use current-arity [pathS bodyS]) +## (-> ls.Arity [ls.Path ls.Synthesis] [ls.Path ls.Synthesis]) +## (let [bound (bound-vars pathS) +## unused (unused-vars current-arity bound bodyS) +## adjusted (adjust-vars unused bound)] +## [(|> pathS (clean-pattern adjusted) simplify-pattern) +## (clean-expression adjusted bodyS)])) diff --git a/lux-jvm/source/luxc/lang/translation/jvm.lux b/lux-jvm/source/luxc/lang/translation/jvm.lux new file mode 100644 index 000000000..141e70184 --- /dev/null +++ b/lux-jvm/source/luxc/lang/translation/jvm.lux @@ -0,0 +1,182 @@ +(.module: + [lux (#- Module Definition) + ["." host (#+ import: do-to object)] + [abstract + [monad (#+ do)]] + [control + pipe + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["." io (#+ IO io)] + [concurrency + ["." atom (#+ Atom atom)]]] + [data + [binary (#+ Binary)] + ["." product] + ["." text ("#@." hash) + ["%" format (#+ format)]] + [collection + ["." array] + ["." dictionary (#+ Dictionary)]]] + [target + [jvm + ["." loader (#+ Library)] + ["." type + ["." descriptor]]]] + [tool + [compiler + [language + [lux + ["." generation]]] + ["." meta + [io (#+ lux-context)] + [archive + [descriptor (#+ Module)] + ["." artifact]]]]]] + [/// + [host + ["." jvm (#+ Inst Definition Host State) + ["." def] + ["." inst]]]] + ) + +(import: #long java/lang/reflect/Field + (get [#? java/lang/Object] #try #? java/lang/Object)) + +(import: #long (java/lang/Class a) + (getField [java/lang/String] #try java/lang/reflect/Field)) + +(import: #long java/lang/Object + (getClass [] (java/lang/Class java/lang/Object))) + +(import: #long java/lang/ClassLoader) + +(type: #export ByteCode Binary) + +(def: #export value-field Text "_value") +(def: #export $Value (type.class "java.lang.Object" (list))) + +(exception: #export (cannot-load {class Text} {error Text}) + (exception.report + ["Class" class] + ["Error" error])) + +(exception: #export (invalid-field {class Text} {field Text} {error Text}) + (exception.report + ["Class" class] + ["Field" field] + ["Error" error])) + +(exception: #export (invalid-value {class Text}) + (exception.report + ["Class" class])) + +(def: (class-value class-name class) + (-> Text (java/lang/Class java/lang/Object) (Try Any)) + (case (java/lang/Class::getField ..value-field class) + (#try.Success field) + (case (java/lang/reflect/Field::get #.None field) + (#try.Success ?value) + (case ?value + (#.Some value) + (#try.Success value) + + #.None + (exception.throw ..invalid-value class-name)) + + (#try.Failure error) + (exception.throw ..cannot-load [class-name error])) + + (#try.Failure error) + (exception.throw ..invalid-field [class-name ..value-field error]))) + +(def: class-path-separator ".") + +(def: #export bytecode-name + (-> Text Text) + (text.replace-all ..class-path-separator .module-separator)) + +(def: #export (class-name [module-id artifact-id]) + (-> generation.Context Text) + (format lux-context + ..class-path-separator (%.nat meta.version) + ..class-path-separator (%.nat module-id) + ..class-path-separator (%.nat artifact-id))) + +(def: (evaluate! library loader eval-class valueI) + (-> Library java/lang/ClassLoader Text Inst (Try [Any Definition])) + (let [bytecode-name (..bytecode-name eval-class) + bytecode (def.class #jvm.V1_6 + #jvm.Public jvm.noneC + bytecode-name + (list) $Value + (list) + (|>> (def.field #jvm.Public ($_ jvm.++F jvm.finalF jvm.staticF) + ..value-field ..$Value) + (def.method #jvm.Public ($_ jvm.++M jvm.staticM jvm.strictM) + "<clinit>" + (type.method [(list) type.void (list)]) + (|>> valueI + (inst.PUTSTATIC (type.class bytecode-name (list)) ..value-field ..$Value) + inst.RETURN))))] + (io.run (do (try.with io.monad) + [_ (loader.store eval-class bytecode library) + class (loader.load eval-class loader) + value (:: io.monad wrap (..class-value eval-class class))] + (wrap [value + [eval-class bytecode]]))))) + +(def: (execute! library loader temp-label [class-name class-bytecode]) + (-> Library java/lang/ClassLoader Text Definition (Try Any)) + (io.run (do (try.with io.monad) + [existing-class? (|> (atom.read library) + (:: io.monad map (dictionary.contains? class-name)) + (try.lift io.monad) + (: (IO (Try Bit)))) + _ (if existing-class? + (wrap []) + (loader.store class-name class-bytecode library))] + (loader.load class-name loader)))) + +(def: (define! library loader context valueI) + (-> Library java/lang/ClassLoader generation.Context Inst (Try [Text Any Definition])) + (let [class-name (..class-name context)] + (do try.monad + [[value definition] (evaluate! library loader class-name valueI)] + (wrap [class-name value definition])))) + +(def: #export host + (IO Host) + (io (let [library (loader.new-library []) + loader (loader.memory library)] + (: Host + (structure + (def: (evaluate! temp-label valueI) + (:: try.monad map product.left + (..evaluate! library loader (text.replace-all " " "$" temp-label) valueI))) + + (def: execute! + (..execute! library loader)) + + (def: define! + (..define! library loader)) + + (def: (ingest context bytecode) + [(..class-name context) bytecode]) + + (def: (re-learn context [_ bytecode]) + (io.run + (loader.store (..class-name context) bytecode library))) + + (def: (re-load context [_ bytecode]) + (io.run + (do (try.with io.monad) + [#let [class-name (..class-name context)] + _ (loader.store class-name bytecode library) + class (loader.load class-name loader)] + (:: io.monad wrap (..class-value class-name class)))))))))) + +(def: #export $Variant (type.array ..$Value)) +(def: #export $Tuple (type.array ..$Value)) +(def: #export $Runtime (type.class (..class-name [0 0]) (list))) +(def: #export $Function (type.class (..class-name [0 1]) (list))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/case.lux b/lux-jvm/source/luxc/lang/translation/jvm/case.lux new file mode 100644 index 000000000..0d8aaa91e --- /dev/null +++ b/lux-jvm/source/luxc/lang/translation/jvm/case.lux @@ -0,0 +1,239 @@ +(.module: + [lux (#- Type if let case) + [abstract + [monad (#+ do)]] + [control + ["." function] + ["ex" exception (#+ exception:)]] + [data + [number + ["n" nat]]] + [target + [jvm + ["." type (#+ Type) + ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] + ["." descriptor (#+ Descriptor)] + ["." signature (#+ Signature)]]]] + [tool + [compiler + ["." phase ("operation@." monad)] + [meta + [archive (#+ Archive)]] + [language + [lux + ["." synthesis (#+ Path Synthesis)]]]]]] + [luxc + [lang + [host + ["$" jvm (#+ Label Inst Operation Phase Generator) + ["_" inst]]]]] + ["." // + ["." runtime]]) + +(def: (pop-altI stack-depth) + (-> Nat Inst) + (.case stack-depth + 0 function.identity + 1 _.POP + 2 _.POP2 + _ ## (n.> 2) + (|>> _.POP2 + (pop-altI (n.- 2 stack-depth))))) + +(def: peekI + Inst + (|>> _.DUP + (_.int +0) + _.AALOAD)) + +(def: pushI + Inst + (_.INVOKESTATIC //.$Runtime "pm_push" (type.method [(list runtime.$Stack //.$Value) runtime.$Stack (list)]))) + +(def: popI + (|>> (_.int +1) + _.AALOAD + (_.CHECKCAST runtime.$Stack))) + +(def: (path' stack-depth @else @end phase archive path) + (-> Nat Label Label Phase Archive Path (Operation Inst)) + (.case path + #synthesis.Pop + (operation@wrap ..popI) + + (#synthesis.Bind register) + (operation@wrap (|>> peekI + (_.ASTORE register))) + + (^ (synthesis.path/bit value)) + (operation@wrap (.let [jumpI (.if value _.IFEQ _.IFNE)] + (|>> peekI + (_.unwrap type.boolean) + (jumpI @else)))) + + (^ (synthesis.path/i64 value)) + (operation@wrap (|>> peekI + (_.unwrap type.long) + (_.long (.int value)) + _.LCMP + (_.IFNE @else))) + + (^ (synthesis.path/f64 value)) + (operation@wrap (|>> peekI + (_.unwrap type.double) + (_.double value) + _.DCMPL + (_.IFNE @else))) + + (^ (synthesis.path/text value)) + (operation@wrap (|>> peekI + (_.string value) + (_.INVOKEVIRTUAL (type.class "java.lang.Object" (list)) + "equals" + (type.method [(list //.$Value) type.boolean (list)])) + (_.IFEQ @else))) + + (#synthesis.Then bodyS) + (do phase.monad + [bodyI (phase archive bodyS)] + (wrap (|>> (pop-altI stack-depth) + bodyI + (_.GOTO @end)))) + + (^template [<pattern> <flag> <prepare>] + (^ (<pattern> idx)) + (operation@wrap (<| _.with-label (function (_ @success)) + _.with-label (function (_ @fail)) + (|>> peekI + (_.CHECKCAST //.$Variant) + (_.int (.int (<prepare> idx))) + <flag> + (_.INVOKESTATIC //.$Runtime "pm_variant" (type.method [(list //.$Variant runtime.$Tag runtime.$Flag) runtime.$Value (list)])) + _.DUP + (_.IFNULL @fail) + (_.GOTO @success) + (_.label @fail) + _.POP + (_.GOTO @else) + (_.label @success) + pushI)))) + ([synthesis.side/left _.NULL function.identity] + [synthesis.side/right (_.string "") .inc]) + + (^ (synthesis.member/left lefts)) + (operation@wrap (.let [accessI (.case lefts + 0 + _.AALOAD + + lefts + (_.INVOKESTATIC //.$Runtime "tuple_left" (type.method [(list //.$Tuple runtime.$Index) //.$Value (list)])))] + (|>> peekI + (_.CHECKCAST //.$Tuple) + (_.int (.int lefts)) + accessI + pushI))) + + (^ (synthesis.member/right lefts)) + (operation@wrap (|>> peekI + (_.CHECKCAST //.$Tuple) + (_.int (.int lefts)) + (_.INVOKESTATIC //.$Runtime "tuple_right" (type.method [(list //.$Tuple runtime.$Index) //.$Value (list)])) + pushI)) + + ## Extra optimization + (^ (synthesis.path/seq + (synthesis.member/left 0) + (synthesis.!bind-top register thenP))) + (do phase.monad + [then! (path' stack-depth @else @end phase archive thenP)] + (wrap (|>> peekI + (_.CHECKCAST //.$Tuple) + (_.int +0) + _.AALOAD + (_.ASTORE register) + then!))) + + ## Extra optimization + (^template [<pm> <getter>] + (^ (synthesis.path/seq + (<pm> lefts) + (synthesis.!bind-top register thenP))) + (do phase.monad + [then! (path' stack-depth @else @end phase archive thenP)] + (wrap (|>> peekI + (_.CHECKCAST //.$Tuple) + (_.int (.int lefts)) + (_.INVOKESTATIC //.$Runtime <getter> (type.method [(list //.$Tuple runtime.$Index) //.$Value (list)])) + (_.ASTORE register) + then!)))) + ([synthesis.member/left "tuple_left"] + [synthesis.member/right "tuple_right"]) + + (#synthesis.Alt leftP rightP) + (do phase.monad + [@alt-else _.make-label + leftI (path' (inc stack-depth) @alt-else @end phase archive leftP) + rightI (path' stack-depth @else @end phase archive rightP)] + (wrap (|>> _.DUP + leftI + (_.label @alt-else) + _.POP + rightI))) + + (#synthesis.Seq leftP rightP) + (do phase.monad + [leftI (path' stack-depth @else @end phase archive leftP) + rightI (path' stack-depth @else @end phase archive rightP)] + (wrap (|>> leftI + rightI))) + )) + +(def: (path @end phase archive path) + (-> Label Phase Archive Path (Operation Inst)) + (do phase.monad + [@else _.make-label + pathI (..path' 1 @else @end phase archive path)] + (wrap (|>> pathI + (_.label @else) + _.POP + (_.INVOKESTATIC //.$Runtime "pm_fail" (type.method [(list) type.void (list)])) + _.NULL + (_.GOTO @end))))) + +(def: #export (if phase archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do phase.monad + [testI (phase archive testS) + thenI (phase archive thenS) + elseI (phase archive elseS)] + (wrap (<| _.with-label (function (_ @else)) + _.with-label (function (_ @end)) + (|>> testI + (_.unwrap type.boolean) + (_.IFEQ @else) + thenI + (_.GOTO @end) + (_.label @else) + elseI + (_.label @end)))))) + +(def: #export (let phase archive [inputS register exprS]) + (Generator [Synthesis Nat Synthesis]) + (do phase.monad + [inputI (phase archive inputS) + exprI (phase archive exprS)] + (wrap (|>> inputI + (_.ASTORE register) + exprI)))) + +(def: #export (case phase archive [valueS path]) + (Generator [Synthesis Path]) + (do phase.monad + [@end _.make-label + valueI (phase archive valueS) + pathI (..path @end phase archive path)] + (wrap (|>> _.NULL + valueI + pushI + pathI + (_.label @end))))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/common.lux b/lux-jvm/source/luxc/lang/translation/jvm/common.lux new file mode 100644 index 000000000..6cd7f4f2f --- /dev/null +++ b/lux-jvm/source/luxc/lang/translation/jvm/common.lux @@ -0,0 +1,72 @@ +(.module: + [lux #* + ## [abstract + ## [monad (#+ do)]] + ## [control + ## ["." try (#+ Try)] + ## ["ex" exception (#+ exception:)] + ## ["." io]] + ## [data + ## [binary (#+ Binary)] + ## ["." text ("#/." hash) + ## format] + ## [collection + ## ["." dictionary (#+ Dictionary)]]] + ## ["." macro] + ## [host (#+ import:)] + ## [tool + ## [compiler + ## [reference (#+ Register)] + ## ["." name] + ## ["." phase]]] + ] + ## [luxc + ## [lang + ## [host + ## ["." jvm + ## [type]]]]] + ) + +## (def: #export (with-artifacts action) +## (All [a] (-> (Meta a) (Meta [Artifacts a]))) +## (function (_ state) +## (case (action (update@ #.host +## (|>> (:coerce Host) +## (set@ #artifacts (dictionary.new text.hash)) +## (:coerce Nothing)) +## state)) +## (#try.Success [state' output]) +## (#try.Success [(update@ #.host +## (|>> (:coerce Host) +## (set@ #artifacts (|> (get@ #.host state) (:coerce Host) (get@ #artifacts))) +## (:coerce Nothing)) +## state') +## [(|> state' (get@ #.host) (:coerce Host) (get@ #artifacts)) +## output]]) + +## (#try.Failure error) +## (#try.Failure error)))) + +## (def: #export (load-definition state) +## (-> Lux (-> Name Binary (Try Any))) +## (function (_ (^@ def-name [def-module def-name]) def-bytecode) +## (let [normal-name (format (name.normalize def-name) (%n (text/hash def-name))) +## class-name (format (text.replace-all "/" "." def-module) "." normal-name)] +## (<| (macro.run state) +## (do macro.monad +## [_ (..store-class class-name def-bytecode) +## class (..load-class class-name)] +## (case (do try.monad +## [field (Class::getField [..value-field] class)] +## (Field::get [#.None] field)) +## (#try.Success (#.Some def-value)) +## (wrap def-value) + +## (#try.Success #.None) +## (phase.throw invalid-definition-value (%name def-name)) + +## (#try.Failure error) +## (phase.throw cannot-load-definition +## (format "Definition: " (%name def-name) "\n" +## "Error:\n" +## error)))))))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/expression.lux b/lux-jvm/source/luxc/lang/translation/jvm/expression.lux new file mode 100644 index 000000000..144e35f9b --- /dev/null +++ b/lux-jvm/source/luxc/lang/translation/jvm/expression.lux @@ -0,0 +1,72 @@ +(.module: + [lux #* + [tool + [compiler + [language + [lux + ["." synthesis] + [phase + ["." extension]]]]]]] + [luxc + [lang + [host + [jvm (#+ Phase)]]]] + [// + ["." common] + ["." primitive] + ["." structure] + ["." reference] + ["." case] + ["." loop] + ["." function]]) + +(def: #export (translate archive synthesis) + Phase + (case synthesis + (^ (synthesis.bit value)) + (primitive.bit value) + + (^ (synthesis.i64 value)) + (primitive.i64 value) + + (^ (synthesis.f64 value)) + (primitive.f64 value) + + (^ (synthesis.text value)) + (primitive.text value) + + (^ (synthesis.variant data)) + (structure.variant translate archive data) + + (^ (synthesis.tuple members)) + (structure.tuple translate archive members) + + (^ (synthesis.variable variable)) + (reference.variable archive variable) + + (^ (synthesis.constant constant)) + (reference.constant archive constant) + + (^ (synthesis.branch/let data)) + (case.let translate archive data) + + (^ (synthesis.branch/if data)) + (case.if translate archive data) + + (^ (synthesis.branch/case data)) + (case.case translate archive data) + + (^ (synthesis.loop/recur data)) + (loop.recur translate archive data) + + (^ (synthesis.loop/scope data)) + (loop.scope translate archive data) + + (^ (synthesis.function/apply data)) + (function.call translate archive data) + + (^ (synthesis.function/abstraction data)) + (function.function translate archive data) + + (#synthesis.Extension extension) + (extension.apply archive translate extension))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension.lux new file mode 100644 index 000000000..9066dd156 --- /dev/null +++ b/lux-jvm/source/luxc/lang/translation/jvm/extension.lux @@ -0,0 +1,16 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + [//// + [host + [jvm (#+ Bundle)]]] + ["." / #_ + ["#." common] + ["#." host]]) + +(def: #export bundle + Bundle + (dictionary.merge /common.bundle + /host.bundle)) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux new file mode 100644 index 000000000..383415c0a --- /dev/null +++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux @@ -0,0 +1,388 @@ +(.module: + [lux (#- Type) + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + ["." product] + [number + ["f" frac]] + [collection + ["." list ("#@." monad)] + ["." dictionary]]] + [target + [jvm + ["." type]]] + [tool + [compiler + ["." phase] + [meta + [archive (#+ Archive)]] + [language + [lux + ["." synthesis (#+ Synthesis %synthesis)] + [phase + [generation + [extension (#+ Nullary Unary Binary Trinary Variadic + nullary unary binary trinary variadic)]] + ["." extension + ["." bundle]]]]]]] + [host (#+ import:)]] + [luxc + [lang + [host + ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase) + ["_" inst]]]]] + ["." /// + ["." runtime]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text Phase Archive s (Operation Inst))] + Handler)) + (function (_ extension-name phase archive input) + (case (<s>.run parser input) + (#try.Success input') + (handler extension-name phase archive input') + + (#try.Failure error) + (phase.throw extension.invalid-syntax [extension-name %synthesis input])))) + +(import: java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double)) + +(def: $String (type.class "java.lang.String" (list))) +(def: $CharSequence (type.class "java.lang.CharSequence" (list))) +(def: $System (type.class "java.lang.System" (list))) +(def: $Object (type.class "java.lang.Object" (list))) + +(def: lux-intI Inst (|>> _.I2L (_.wrap type.long))) +(def: jvm-intI Inst (|>> (_.unwrap type.long) _.L2I)) +(def: check-stringI Inst (_.CHECKCAST $String)) + +(def: (predicateI tester) + (-> (-> Label Inst) + Inst) + (let [$Boolean (type.class "java.lang.Boolean" (list))] + (<| _.with-label (function (_ @then)) + _.with-label (function (_ @end)) + (|>> (tester @then) + (_.GETSTATIC $Boolean "FALSE" $Boolean) + (_.GOTO @end) + (_.label @then) + (_.GETSTATIC $Boolean "TRUE" $Boolean) + (_.label @end) + )))) + +(def: unitI Inst (_.string synthesis.unit)) + +## TODO: Get rid of this ASAP +(def: lux::syntax-char-case! + (..custom [($_ <>.and + <s>.any + <s>.any + (<>.some (<s>.tuple ($_ <>.and + (<s>.tuple (<>.many <s>.i64)) + <s>.any)))) + (function (_ extension-name phase archive [input else conditionals]) + (<| _.with-label (function (_ @end)) + _.with-label (function (_ @else)) + (do {@ phase.monad} + [inputG (phase archive input) + elseG (phase archive else) + conditionalsG+ (: (Operation (List [(List [Int Label]) + Inst])) + (monad.map @ (function (_ [chars branch]) + (do @ + [branchG (phase archive branch)] + (wrap (<| _.with-label (function (_ @branch)) + [(list@map (function (_ char) + [(.int char) @branch]) + chars) + (|>> (_.label @branch) + branchG + (_.GOTO @end))])))) + conditionals)) + #let [table (|> conditionalsG+ + (list@map product.left) + list@join) + conditionalsG (|> conditionalsG+ + (list@map product.right) + _.fuse)]] + (wrap (|>> inputG (_.unwrap type.long) _.L2I + (_.LOOKUPSWITCH @else table) + conditionalsG + (_.label @else) + elseG + (_.label @end) + )))))])) + +(def: (lux::is [referenceI sampleI]) + (Binary Inst) + (|>> referenceI + sampleI + (predicateI _.IF_ACMPEQ))) + +(def: (lux::try riskyI) + (Unary Inst) + (|>> riskyI + (_.CHECKCAST ///.$Function) + (_.INVOKESTATIC ///.$Runtime "try" runtime.try))) + +(template [<name> <op>] + [(def: (<name> [maskI inputI]) + (Binary Inst) + (|>> inputI (_.unwrap type.long) + maskI (_.unwrap type.long) + <op> (_.wrap type.long)))] + + [i64::and _.LAND] + [i64::or _.LOR] + [i64::xor _.LXOR] + ) + +(template [<name> <op>] + [(def: (<name> [shiftI inputI]) + (Binary Inst) + (|>> inputI (_.unwrap type.long) + shiftI jvm-intI + <op> + (_.wrap type.long)))] + + [i64::left-shift _.LSHL] + [i64::arithmetic-right-shift _.LSHR] + [i64::logical-right-shift _.LUSHR] + ) + +(template [<name> <const> <type>] + [(def: (<name> _) + (Nullary Inst) + (|>> <const> (_.wrap <type>)))] + + [f64::smallest (_.double (Double::MIN_VALUE)) type.double] + [f64::min (_.double (f.* -1.0 (Double::MAX_VALUE))) type.double] + [f64::max (_.double (Double::MAX_VALUE)) type.double] + ) + +(template [<name> <type> <op>] + [(def: (<name> [paramI subjectI]) + (Binary Inst) + (|>> subjectI (_.unwrap <type>) + paramI (_.unwrap <type>) + <op> + (_.wrap <type>)))] + + [i64::+ type.long _.LADD] + [i64::- type.long _.LSUB] + [i64::* type.long _.LMUL] + [i64::/ type.long _.LDIV] + [i64::% type.long _.LREM] + + [f64::+ type.double _.DADD] + [f64::- type.double _.DSUB] + [f64::* type.double _.DMUL] + [f64::/ type.double _.DDIV] + [f64::% type.double _.DREM] + ) + +(template [<eq> <lt> <type> <cmp>] + [(template [<name> <reference>] + [(def: (<name> [paramI subjectI]) + (Binary Inst) + (|>> subjectI (_.unwrap <type>) + paramI (_.unwrap <type>) + <cmp> + (_.int <reference>) + (predicateI _.IF_ICMPEQ)))] + + [<eq> +0] + [<lt> -1])] + + [i64::= i64::< type.long _.LCMP] + [f64::= f64::< type.double _.DCMPG] + ) + +(template [<name> <prepare> <transform>] + [(def: (<name> inputI) + (Unary Inst) + (|>> inputI <prepare> <transform>))] + + [i64::f64 (_.unwrap type.long) (<| (_.wrap type.double) _.L2D)] + [i64::char (_.unwrap type.long) + ((|>> _.L2I _.I2C (_.INVOKESTATIC (type.class "java.lang.Character" (list)) "toString" (type.method [(list type.char) $String (list)]))))] + + [f64::i64 (_.unwrap type.double) (<| (_.wrap type.long) _.D2L)] + [f64::encode (_.unwrap type.double) + (_.INVOKESTATIC (type.class "java.lang.Double" (list)) "toString" (type.method [(list type.double) $String (list)]))] + [f64::decode ..check-stringI + (_.INVOKESTATIC ///.$Runtime "decode_frac" (type.method [(list $String) ///.$Variant (list)]))] + ) + +(def: (text::size inputI) + (Unary Inst) + (|>> inputI + ..check-stringI + (_.INVOKEVIRTUAL $String "length" (type.method [(list) type.int (list)])) + lux-intI)) + +(template [<name> <pre-subject> <pre-param> <op> <post>] + [(def: (<name> [paramI subjectI]) + (Binary Inst) + (|>> subjectI <pre-subject> + paramI <pre-param> + <op> <post>))] + + [text::= (<|) (<|) + (_.INVOKEVIRTUAL $Object "equals" (type.method [(list $Object) type.boolean (list)])) + (_.wrap type.boolean)] + [text::< ..check-stringI ..check-stringI + (_.INVOKEVIRTUAL $String "compareTo" (type.method [(list $String) type.int (list)])) + (predicateI _.IFLT)] + [text::char ..check-stringI jvm-intI + (_.INVOKEVIRTUAL $String "charAt" (type.method [(list type.int) type.char (list)])) + lux-intI] + ) + +(def: (text::concat [leftI rightI]) + (Binary Inst) + (|>> leftI ..check-stringI + rightI ..check-stringI + (_.INVOKEVIRTUAL $String "concat" (type.method [(list $String) $String (list)])))) + +(def: (text::clip [startI endI subjectI]) + (Trinary Inst) + (|>> subjectI ..check-stringI + startI jvm-intI + endI jvm-intI + (_.INVOKEVIRTUAL $String "substring" (type.method [(list type.int type.int) $String (list)])))) + +(def: index-method (type.method [(list $String type.int) type.int (list)])) +(def: (text::index [startI partI textI]) + (Trinary Inst) + (<| _.with-label (function (_ @not-found)) + _.with-label (function (_ @end)) + (|>> textI ..check-stringI + partI ..check-stringI + startI jvm-intI + (_.INVOKEVIRTUAL $String "indexOf" index-method) + _.DUP + (_.int -1) + (_.IF_ICMPEQ @not-found) + lux-intI + runtime.someI + (_.GOTO @end) + (_.label @not-found) + _.POP + runtime.noneI + (_.label @end)))) + +(def: string-method (type.method [(list $String) type.void (list)])) +(def: (io::log messageI) + (Unary Inst) + (let [$PrintStream (type.class "java.io.PrintStream" (list))] + (|>> (_.GETSTATIC $System "out" $PrintStream) + messageI + ..check-stringI + (_.INVOKEVIRTUAL $PrintStream "println" string-method) + unitI))) + +(def: (io::error messageI) + (Unary Inst) + (let [$Error (type.class "java.lang.Error" (list))] + (|>> (_.NEW $Error) + _.DUP + messageI + ..check-stringI + (_.INVOKESPECIAL $Error "<init>" string-method) + _.ATHROW))) + +(def: (io::exit codeI) + (Unary Inst) + (|>> codeI jvm-intI + (_.INVOKESTATIC $System "exit" (type.method [(list type.int) type.void (list)])) + _.NULL)) + +(def: (io::current-time _) + (Nullary Inst) + (|>> (_.INVOKESTATIC $System "currentTimeMillis" (type.method [(list) type.long (list)])) + (_.wrap type.long))) + +(def: bundle::lux + Bundle + (|> (: Bundle bundle.empty) + (bundle.install "syntax char case!" lux::syntax-char-case!) + (bundle.install "is" (binary lux::is)) + (bundle.install "try" (unary lux::try)))) + +(def: bundle::i64 + Bundle + (<| (bundle.prefix "i64") + (|> (: Bundle bundle.empty) + (bundle.install "and" (binary i64::and)) + (bundle.install "or" (binary i64::or)) + (bundle.install "xor" (binary i64::xor)) + (bundle.install "left-shift" (binary i64::left-shift)) + (bundle.install "logical-right-shift" (binary i64::logical-right-shift)) + (bundle.install "arithmetic-right-shift" (binary i64::arithmetic-right-shift)) + (bundle.install "=" (binary i64::=)) + (bundle.install "<" (binary i64::<)) + (bundle.install "+" (binary i64::+)) + (bundle.install "-" (binary i64::-)) + (bundle.install "*" (binary i64::*)) + (bundle.install "/" (binary i64::/)) + (bundle.install "%" (binary i64::%)) + (bundle.install "f64" (unary i64::f64)) + (bundle.install "char" (unary i64::char))))) + +(def: bundle::f64 + Bundle + (<| (bundle.prefix "f64") + (|> (: Bundle bundle.empty) + (bundle.install "+" (binary f64::+)) + (bundle.install "-" (binary f64::-)) + (bundle.install "*" (binary f64::*)) + (bundle.install "/" (binary f64::/)) + (bundle.install "%" (binary f64::%)) + (bundle.install "=" (binary f64::=)) + (bundle.install "<" (binary f64::<)) + (bundle.install "smallest" (nullary f64::smallest)) + (bundle.install "min" (nullary f64::min)) + (bundle.install "max" (nullary f64::max)) + (bundle.install "i64" (unary f64::i64)) + (bundle.install "encode" (unary f64::encode)) + (bundle.install "decode" (unary f64::decode))))) + +(def: bundle::text + Bundle + (<| (bundle.prefix "text") + (|> (: Bundle bundle.empty) + (bundle.install "=" (binary text::=)) + (bundle.install "<" (binary text::<)) + (bundle.install "concat" (binary text::concat)) + (bundle.install "index" (trinary text::index)) + (bundle.install "size" (unary text::size)) + (bundle.install "char" (binary text::char)) + (bundle.install "clip" (trinary text::clip))))) + +(def: bundle::io + Bundle + (<| (bundle.prefix "io") + (|> (: Bundle bundle.empty) + (bundle.install "log" (unary io::log)) + (bundle.install "error" (unary io::error)) + (bundle.install "exit" (unary io::exit)) + (bundle.install "current-time" (nullary io::current-time))))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lux") + (|> bundle::lux + (dictionary.merge bundle::i64) + (dictionary.merge bundle::f64) + (dictionary.merge bundle::text) + (dictionary.merge bundle::io)))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux new file mode 100644 index 000000000..7b90a8e4f --- /dev/null +++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux @@ -0,0 +1,1047 @@ +(.module: + [lux (#- Type primitive int char type) + [host (#+ import:)] + [abstract + ["." monad (#+ do)]] + [control + ["." exception (#+ exception:)] + ["." function] + ["<>" parser ("#@." monad) + ["<t>" text] + ["<s>" synthesis (#+ Parser)]]] + [data + ["." product] + ["." maybe] + ["." text ("#@." equivalence) + ["%" format (#+ format)]] + [number + ["." nat]] + [collection + ["." list ("#@." monad)] + ["." dictionary (#+ Dictionary)] + ["." set]]] + [target + [jvm + ["." type (#+ Type Typed Argument) + ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] + ["." box] + ["." reflection] + ["." signature] + ["." parser]]]] + [tool + [compiler + ["." reference (#+ Variable)] + ["." phase ("#@." monad)] + [meta + [archive (#+ Archive)]] + [language + [lux + [analysis (#+ Environment)] + ["." synthesis (#+ Synthesis Path %synthesis)] + ["." generation] + [phase + [generation + [extension (#+ Nullary Unary Binary + nullary unary binary)]] + [analysis + [".A" reference]] + ["." extension + ["." bundle] + [analysis + ["/" jvm]]]]]]]]] + [luxc + [lang + [host + ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase) + ["_" inst] + ["_." def]]]]] + ["." // #_ + [common (#+ custom)] + ["/#" // + ["#." reference] + ["#." function]]]) + +(template [<name> <category> <parser>] + [(def: #export <name> + (Parser (Type <category>)) + (<t>.embed <parser> <s>.text))] + + [var Var parser.var] + [class Class parser.class] + [object Object parser.object] + [value Value parser.value] + [return Return parser.return] + ) + +(exception: #export (not-an-object-array {arrayJT (Type Array)}) + (exception.report + ["JVM Type" (|> arrayJT type.signature signature.signature)])) + +(def: #export object-array + (Parser (Type Object)) + (do <>.monad + [arrayJT (<t>.embed parser.array <s>.text)] + (case (parser.array? arrayJT) + (#.Some elementJT) + (case (parser.object? elementJT) + (#.Some elementJT) + (wrap elementJT) + + #.None + (<>.fail (exception.construct ..not-an-object-array arrayJT))) + + #.None + (undefined)))) + +(template [<name> <inst>] + [(def: <name> + Inst + <inst>)] + + [L2S (|>> _.L2I _.I2S)] + [L2B (|>> _.L2I _.I2B)] + [L2C (|>> _.L2I _.I2C)] + ) + +(template [<conversion> <name>] + [(def: (<name> inputI) + (Unary Inst) + (if (is? _.NOP <conversion>) + inputI + (|>> inputI + <conversion>)))] + + [_.D2F conversion::double-to-float] + [_.D2I conversion::double-to-int] + [_.D2L conversion::double-to-long] + [_.F2D conversion::float-to-double] + [_.F2I conversion::float-to-int] + [_.F2L conversion::float-to-long] + [_.I2B conversion::int-to-byte] + [_.I2C conversion::int-to-char] + [_.I2D conversion::int-to-double] + [_.I2F conversion::int-to-float] + [_.I2L conversion::int-to-long] + [_.I2S conversion::int-to-short] + [_.L2D conversion::long-to-double] + [_.L2F conversion::long-to-float] + [_.L2I conversion::long-to-int] + [..L2S conversion::long-to-short] + [..L2B conversion::long-to-byte] + [..L2C conversion::long-to-char] + [_.I2B conversion::char-to-byte] + [_.I2S conversion::char-to-short] + [_.NOP conversion::char-to-int] + [_.I2L conversion::char-to-long] + [_.I2L conversion::byte-to-long] + [_.I2L conversion::short-to-long] + ) + +(def: conversion + Bundle + (<| (bundle.prefix "conversion") + (|> (: Bundle bundle.empty) + (bundle.install "double-to-float" (unary conversion::double-to-float)) + (bundle.install "double-to-int" (unary conversion::double-to-int)) + (bundle.install "double-to-long" (unary conversion::double-to-long)) + (bundle.install "float-to-double" (unary conversion::float-to-double)) + (bundle.install "float-to-int" (unary conversion::float-to-int)) + (bundle.install "float-to-long" (unary conversion::float-to-long)) + (bundle.install "int-to-byte" (unary conversion::int-to-byte)) + (bundle.install "int-to-char" (unary conversion::int-to-char)) + (bundle.install "int-to-double" (unary conversion::int-to-double)) + (bundle.install "int-to-float" (unary conversion::int-to-float)) + (bundle.install "int-to-long" (unary conversion::int-to-long)) + (bundle.install "int-to-short" (unary conversion::int-to-short)) + (bundle.install "long-to-double" (unary conversion::long-to-double)) + (bundle.install "long-to-float" (unary conversion::long-to-float)) + (bundle.install "long-to-int" (unary conversion::long-to-int)) + (bundle.install "long-to-short" (unary conversion::long-to-short)) + (bundle.install "long-to-byte" (unary conversion::long-to-byte)) + (bundle.install "long-to-char" (unary conversion::long-to-char)) + (bundle.install "char-to-byte" (unary conversion::char-to-byte)) + (bundle.install "char-to-short" (unary conversion::char-to-short)) + (bundle.install "char-to-int" (unary conversion::char-to-int)) + (bundle.install "char-to-long" (unary conversion::char-to-long)) + (bundle.install "byte-to-long" (unary conversion::byte-to-long)) + (bundle.install "short-to-long" (unary conversion::short-to-long)) + ))) + +(template [<name> <op>] + [(def: (<name> [xI yI]) + (Binary Inst) + (|>> xI + yI + <op>))] + + [int::+ _.IADD] + [int::- _.ISUB] + [int::* _.IMUL] + [int::/ _.IDIV] + [int::% _.IREM] + [int::and _.IAND] + [int::or _.IOR] + [int::xor _.IXOR] + [int::shl _.ISHL] + [int::shr _.ISHR] + [int::ushr _.IUSHR] + + [long::+ _.LADD] + [long::- _.LSUB] + [long::* _.LMUL] + [long::/ _.LDIV] + [long::% _.LREM] + [long::and _.LAND] + [long::or _.LOR] + [long::xor _.LXOR] + [long::shl _.LSHL] + [long::shr _.LSHR] + [long::ushr _.LUSHR] + + [float::+ _.FADD] + [float::- _.FSUB] + [float::* _.FMUL] + [float::/ _.FDIV] + [float::% _.FREM] + + [double::+ _.DADD] + [double::- _.DSUB] + [double::* _.DMUL] + [double::/ _.DDIV] + [double::% _.DREM] + ) + +(def: $Boolean (type.class box.boolean (list))) +(def: falseI (_.GETSTATIC $Boolean "FALSE" $Boolean)) +(def: trueI (_.GETSTATIC $Boolean "TRUE" $Boolean)) + +(template [<name> <op>] + [(def: (<name> [xI yI]) + (Binary Inst) + (<| _.with-label (function (_ @then)) + _.with-label (function (_ @end)) + (|>> xI + yI + (<op> @then) + falseI + (_.GOTO @end) + (_.label @then) + trueI + (_.label @end))))] + + [int::= _.IF_ICMPEQ] + [int::< _.IF_ICMPLT] + + [char::= _.IF_ICMPEQ] + [char::< _.IF_ICMPLT] + ) + +(template [<name> <op> <reference>] + [(def: (<name> [xI yI]) + (Binary Inst) + (<| _.with-label (function (_ @then)) + _.with-label (function (_ @end)) + (|>> xI + yI + <op> + (_.int <reference>) + (_.IF_ICMPEQ @then) + falseI + (_.GOTO @end) + (_.label @then) + trueI + (_.label @end))))] + + [long::= _.LCMP +0] + [long::< _.LCMP -1] + + [float::= _.FCMPG +0] + [float::< _.FCMPG -1] + + [double::= _.DCMPG +0] + [double::< _.DCMPG -1] + ) + +(def: int + Bundle + (<| (bundle.prefix (reflection.reflection reflection.int)) + (|> (: Bundle bundle.empty) + (bundle.install "+" (binary int::+)) + (bundle.install "-" (binary int::-)) + (bundle.install "*" (binary int::*)) + (bundle.install "/" (binary int::/)) + (bundle.install "%" (binary int::%)) + (bundle.install "=" (binary int::=)) + (bundle.install "<" (binary int::<)) + (bundle.install "and" (binary int::and)) + (bundle.install "or" (binary int::or)) + (bundle.install "xor" (binary int::xor)) + (bundle.install "shl" (binary int::shl)) + (bundle.install "shr" (binary int::shr)) + (bundle.install "ushr" (binary int::ushr)) + ))) + +(def: long + Bundle + (<| (bundle.prefix (reflection.reflection reflection.long)) + (|> (: Bundle bundle.empty) + (bundle.install "+" (binary long::+)) + (bundle.install "-" (binary long::-)) + (bundle.install "*" (binary long::*)) + (bundle.install "/" (binary long::/)) + (bundle.install "%" (binary long::%)) + (bundle.install "=" (binary long::=)) + (bundle.install "<" (binary long::<)) + (bundle.install "and" (binary long::and)) + (bundle.install "or" (binary long::or)) + (bundle.install "xor" (binary long::xor)) + (bundle.install "shl" (binary long::shl)) + (bundle.install "shr" (binary long::shr)) + (bundle.install "ushr" (binary long::ushr)) + ))) + +(def: float + Bundle + (<| (bundle.prefix (reflection.reflection reflection.float)) + (|> (: Bundle bundle.empty) + (bundle.install "+" (binary float::+)) + (bundle.install "-" (binary float::-)) + (bundle.install "*" (binary float::*)) + (bundle.install "/" (binary float::/)) + (bundle.install "%" (binary float::%)) + (bundle.install "=" (binary float::=)) + (bundle.install "<" (binary float::<)) + ))) + +(def: double + Bundle + (<| (bundle.prefix (reflection.reflection reflection.double)) + (|> (: Bundle bundle.empty) + (bundle.install "+" (binary double::+)) + (bundle.install "-" (binary double::-)) + (bundle.install "*" (binary double::*)) + (bundle.install "/" (binary double::/)) + (bundle.install "%" (binary double::%)) + (bundle.install "=" (binary double::=)) + (bundle.install "<" (binary double::<)) + ))) + +(def: char + Bundle + (<| (bundle.prefix (reflection.reflection reflection.char)) + (|> (: Bundle bundle.empty) + (bundle.install "=" (binary char::=)) + (bundle.install "<" (binary char::<)) + ))) + +(def: (primitive-array-length-handler jvm-primitive) + (-> (Type Primitive) Handler) + (..custom + [<s>.any + (function (_ extension-name generate archive arrayS) + (do phase.monad + [arrayI (generate archive arrayS)] + (wrap (|>> arrayI + (_.CHECKCAST (type.array jvm-primitive)) + _.ARRAYLENGTH))))])) + +(def: array::length::object + Handler + (..custom + [($_ <>.and ..object-array <s>.any) + (function (_ extension-name generate archive [elementJT arrayS]) + (do phase.monad + [arrayI (generate archive arrayS)] + (wrap (|>> arrayI + (_.CHECKCAST (type.array elementJT)) + _.ARRAYLENGTH))))])) + +(def: (new-primitive-array-handler jvm-primitive) + (-> (Type Primitive) Handler) + (function (_ extension-name generate archive inputs) + (case inputs + (^ (list lengthS)) + (do phase.monad + [lengthI (generate archive lengthS)] + (wrap (|>> lengthI + (_.array jvm-primitive)))) + + _ + (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))) + +(def: array::new::object + Handler + (..custom + [($_ <>.and ..object <s>.any) + (function (_ extension-name generate archive [objectJT lengthS]) + (do phase.monad + [lengthI (generate archive lengthS)] + (wrap (|>> lengthI + (_.ANEWARRAY objectJT)))))])) + +(def: (read-primitive-array-handler jvm-primitive loadI) + (-> (Type Primitive) Inst Handler) + (function (_ extension-name generate archive inputs) + (case inputs + (^ (list idxS arrayS)) + (do phase.monad + [arrayI (generate archive arrayS) + idxI (generate archive idxS)] + (wrap (|>> arrayI + (_.CHECKCAST (type.array jvm-primitive)) + idxI + loadI))) + + _ + (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))) + +(def: array::read::object + Handler + (..custom + [($_ <>.and ..object-array <s>.any <s>.any) + (function (_ extension-name generate archive [elementJT idxS arrayS]) + (do phase.monad + [arrayI (generate archive arrayS) + idxI (generate archive idxS)] + (wrap (|>> arrayI + (_.CHECKCAST (type.array elementJT)) + idxI + _.AALOAD))))])) + +(def: (write-primitive-array-handler jvm-primitive storeI) + (-> (Type Primitive) Inst Handler) + (function (_ extension-name generate archive inputs) + (case inputs + (^ (list idxS valueS arrayS)) + (do phase.monad + [arrayI (generate archive arrayS) + idxI (generate archive idxS) + valueI (generate archive valueS)] + (wrap (|>> arrayI + (_.CHECKCAST (type.array jvm-primitive)) + _.DUP + idxI + valueI + storeI))) + + _ + (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))) + +(def: array::write::object + Handler + (..custom + [($_ <>.and ..object-array <s>.any <s>.any <s>.any) + (function (_ extension-name generate archive [elementJT idxS valueS arrayS]) + (do phase.monad + [arrayI (generate archive arrayS) + idxI (generate archive idxS) + valueI (generate archive valueS)] + (wrap (|>> arrayI + (_.CHECKCAST (type.array elementJT)) + _.DUP + idxI + valueI + _.AASTORE))))])) + +(def: array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (dictionary.merge (<| (bundle.prefix "length") + (|> bundle.empty + (bundle.install (reflection.reflection reflection.boolean) (primitive-array-length-handler type.boolean)) + (bundle.install (reflection.reflection reflection.byte) (primitive-array-length-handler type.byte)) + (bundle.install (reflection.reflection reflection.short) (primitive-array-length-handler type.short)) + (bundle.install (reflection.reflection reflection.int) (primitive-array-length-handler type.int)) + (bundle.install (reflection.reflection reflection.long) (primitive-array-length-handler type.long)) + (bundle.install (reflection.reflection reflection.float) (primitive-array-length-handler type.float)) + (bundle.install (reflection.reflection reflection.double) (primitive-array-length-handler type.double)) + (bundle.install (reflection.reflection reflection.char) (primitive-array-length-handler type.char)) + (bundle.install "object" array::length::object)))) + (dictionary.merge (<| (bundle.prefix "new") + (|> bundle.empty + (bundle.install (reflection.reflection reflection.boolean) (new-primitive-array-handler type.boolean)) + (bundle.install (reflection.reflection reflection.byte) (new-primitive-array-handler type.byte)) + (bundle.install (reflection.reflection reflection.short) (new-primitive-array-handler type.short)) + (bundle.install (reflection.reflection reflection.int) (new-primitive-array-handler type.int)) + (bundle.install (reflection.reflection reflection.long) (new-primitive-array-handler type.long)) + (bundle.install (reflection.reflection reflection.float) (new-primitive-array-handler type.float)) + (bundle.install (reflection.reflection reflection.double) (new-primitive-array-handler type.double)) + (bundle.install (reflection.reflection reflection.char) (new-primitive-array-handler type.char)) + (bundle.install "object" array::new::object)))) + (dictionary.merge (<| (bundle.prefix "read") + (|> bundle.empty + (bundle.install (reflection.reflection reflection.boolean) (read-primitive-array-handler type.boolean _.BALOAD)) + (bundle.install (reflection.reflection reflection.byte) (read-primitive-array-handler type.byte _.BALOAD)) + (bundle.install (reflection.reflection reflection.short) (read-primitive-array-handler type.short _.SALOAD)) + (bundle.install (reflection.reflection reflection.int) (read-primitive-array-handler type.int _.IALOAD)) + (bundle.install (reflection.reflection reflection.long) (read-primitive-array-handler type.long _.LALOAD)) + (bundle.install (reflection.reflection reflection.float) (read-primitive-array-handler type.float _.FALOAD)) + (bundle.install (reflection.reflection reflection.double) (read-primitive-array-handler type.double _.DALOAD)) + (bundle.install (reflection.reflection reflection.char) (read-primitive-array-handler type.char _.CALOAD)) + (bundle.install "object" array::read::object)))) + (dictionary.merge (<| (bundle.prefix "write") + (|> bundle.empty + (bundle.install (reflection.reflection reflection.boolean) (write-primitive-array-handler type.boolean _.BASTORE)) + (bundle.install (reflection.reflection reflection.byte) (write-primitive-array-handler type.byte _.BASTORE)) + (bundle.install (reflection.reflection reflection.short) (write-primitive-array-handler type.short _.SASTORE)) + (bundle.install (reflection.reflection reflection.int) (write-primitive-array-handler type.int _.IASTORE)) + (bundle.install (reflection.reflection reflection.long) (write-primitive-array-handler type.long _.LASTORE)) + (bundle.install (reflection.reflection reflection.float) (write-primitive-array-handler type.float _.FASTORE)) + (bundle.install (reflection.reflection reflection.double) (write-primitive-array-handler type.double _.DASTORE)) + (bundle.install (reflection.reflection reflection.char) (write-primitive-array-handler type.char _.CASTORE)) + (bundle.install "object" array::write::object)))) + ))) + +(def: (object::null _) + (Nullary Inst) + _.NULL) + +(def: (object::null? objectI) + (Unary Inst) + (<| _.with-label (function (_ @then)) + _.with-label (function (_ @end)) + (|>> objectI + (_.IFNULL @then) + falseI + (_.GOTO @end) + (_.label @then) + trueI + (_.label @end)))) + +(def: (object::synchronized [monitorI exprI]) + (Binary Inst) + (|>> monitorI + _.DUP + _.MONITORENTER + exprI + _.SWAP + _.MONITOREXIT)) + +(def: (object::throw exceptionI) + (Unary Inst) + (|>> exceptionI + _.ATHROW)) + +(def: $Class (type.class "java.lang.Class" (list))) + +(def: (object::class extension-name generate archive inputs) + Handler + (case inputs + (^ (list (synthesis.text class))) + (do phase.monad + [] + (wrap (|>> (_.string class) + (_.INVOKESTATIC $Class "forName" (type.method [(list (type.class "java.lang.String" (list))) $Class (list)]))))) + + _ + (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) + +(def: object::instance? + Handler + (..custom + [($_ <>.and <s>.text <s>.any) + (function (_ extension-name generate archive [class objectS]) + (do phase.monad + [objectI (generate archive objectS)] + (wrap (|>> objectI + (_.INSTANCEOF (type.class class (list))) + (_.wrap type.boolean)))))])) + +(def: (object::cast extension-name generate archive inputs) + Handler + (case inputs + (^ (list (synthesis.text from) (synthesis.text to) valueS)) + (do phase.monad + [valueI (generate archive valueS)] + (`` (cond (~~ (template [<object> <type>] + [(and (text@= (reflection.reflection (type.reflection <type>)) + from) + (text@= <object> + to)) + (wrap (|>> valueI (_.wrap <type>))) + + (and (text@= <object> + from) + (text@= (reflection.reflection (type.reflection <type>)) + to)) + (wrap (|>> valueI (_.unwrap <type>)))] + + [box.boolean type.boolean] + [box.byte type.byte] + [box.short type.short] + [box.int type.int] + [box.long type.long] + [box.float type.float] + [box.double type.double] + [box.char type.char])) + ## else + (wrap valueI)))) + + _ + (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) + +(def: object-bundle + Bundle + (<| (bundle.prefix "object") + (|> (: Bundle bundle.empty) + (bundle.install "null" (nullary object::null)) + (bundle.install "null?" (unary object::null?)) + (bundle.install "synchronized" (binary object::synchronized)) + (bundle.install "throw" (unary object::throw)) + (bundle.install "class" object::class) + (bundle.install "instance?" object::instance?) + (bundle.install "cast" object::cast) + ))) + +(def: primitives + (Dictionary Text (Type Primitive)) + (|> (list [(reflection.reflection reflection.boolean) type.boolean] + [(reflection.reflection reflection.byte) type.byte] + [(reflection.reflection reflection.short) type.short] + [(reflection.reflection reflection.int) type.int] + [(reflection.reflection reflection.long) type.long] + [(reflection.reflection reflection.float) type.float] + [(reflection.reflection reflection.double) type.double] + [(reflection.reflection reflection.char) type.char]) + (dictionary.from-list text.hash))) + +(def: get::static + Handler + (..custom + [($_ <>.and <s>.text <s>.text <s>.text) + (function (_ extension-name generate archive [class field unboxed]) + (do phase.monad + [] + (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (wrap (_.GETSTATIC (type.class class (list)) field primitive)) + + #.None + (wrap (_.GETSTATIC (type.class class (list)) field (type.class unboxed (list)))))))])) + +(def: put::static + Handler + (..custom + [($_ <>.and <s>.text <s>.text <s>.text <s>.any) + (function (_ extension-name generate archive [class field unboxed valueS]) + (do phase.monad + [valueI (generate archive valueS) + #let [$class (type.class class (list))]] + (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (wrap (|>> valueI + (_.PUTSTATIC $class field primitive) + (_.string synthesis.unit))) + + #.None + (wrap (|>> valueI + (_.CHECKCAST $class) + (_.PUTSTATIC $class field $class) + (_.string synthesis.unit))))))])) + +(def: get::virtual + Handler + (..custom + [($_ <>.and <s>.text <s>.text <s>.text <s>.any) + (function (_ extension-name generate archive [class field unboxed objectS]) + (do phase.monad + [objectI (generate archive objectS) + #let [$class (type.class class (list)) + getI (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (_.GETFIELD $class field primitive) + + #.None + (_.GETFIELD $class field (type.class unboxed (list))))]] + (wrap (|>> objectI + (_.CHECKCAST $class) + getI))))])) + +(def: put::virtual + Handler + (..custom + [($_ <>.and <s>.text <s>.text <s>.text <s>.any <s>.any) + (function (_ extension-name generate archive [class field unboxed valueS objectS]) + (do phase.monad + [valueI (generate archive valueS) + objectI (generate archive objectS) + #let [$class (type.class class (list)) + putI (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (_.PUTFIELD $class field primitive) + + #.None + (let [$unboxed (type.class unboxed (list))] + (|>> (_.CHECKCAST $unboxed) + (_.PUTFIELD $class field $unboxed))))]] + (wrap (|>> objectI + (_.CHECKCAST $class) + _.DUP + valueI + putI))))])) + +(type: Input (Typed Synthesis)) + +(def: input + (Parser Input) + (<s>.tuple (<>.and ..value <s>.any))) + +(def: (generate-input generate archive [valueT valueS]) + (-> Phase Archive Input + (Operation (Typed Inst))) + (do phase.monad + [valueI (generate archive valueS)] + (case (type.primitive? valueT) + (#.Right valueT) + (wrap [valueT valueI]) + + (#.Left valueT) + (wrap [valueT (|>> valueI + (_.CHECKCAST valueT))])))) + +(def: voidI (_.string synthesis.unit)) + +(def: (prepare-output outputT) + (-> (Type Return) Inst) + (case (type.void? outputT) + (#.Right outputT) + ..voidI + + (#.Left outputT) + function.identity)) + +(def: invoke::static + Handler + (..custom + [($_ <>.and ..class <s>.text ..return (<>.some ..input)) + (function (_ extension-name generate archive [class method outputT inputsTS]) + (do {@ phase.monad} + [inputsTI (monad.map @ (generate-input generate archive) inputsTS)] + (wrap (|>> (_.fuse (list@map product.right inputsTI)) + (_.INVOKESTATIC class method (type.method [(list@map product.left inputsTI) outputT (list)])) + (prepare-output outputT)))))])) + +(template [<name> <invoke>] + [(def: <name> + Handler + (..custom + [($_ <>.and ..class <s>.text ..return <s>.any (<>.some ..input)) + (function (_ extension-name generate archive [class method outputT objectS inputsTS]) + (do {@ phase.monad} + [objectI (generate archive objectS) + inputsTI (monad.map @ (generate-input generate archive) inputsTS)] + (wrap (|>> objectI + (_.CHECKCAST class) + (_.fuse (list@map product.right inputsTI)) + (<invoke> class method + (type.method [(list@map product.left inputsTI) + outputT + (list)])) + (prepare-output outputT)))))]))] + + [invoke::virtual _.INVOKEVIRTUAL] + [invoke::special _.INVOKESPECIAL] + [invoke::interface _.INVOKEINTERFACE] + ) + +(def: invoke::constructor + Handler + (..custom + [($_ <>.and ..class (<>.some ..input)) + (function (_ extension-name generate archive [class inputsTS]) + (do {@ phase.monad} + [inputsTI (monad.map @ (generate-input generate archive) inputsTS)] + (wrap (|>> (_.NEW class) + _.DUP + (_.fuse (list@map product.right inputsTI)) + (_.INVOKESPECIAL class "<init>" (type.method [(list@map product.left inputsTI) type.void (list)]))))))])) + +(def: member + Bundle + (<| (bundle.prefix "member") + (|> (: Bundle bundle.empty) + (dictionary.merge (<| (bundle.prefix "get") + (|> (: Bundle bundle.empty) + (bundle.install "static" get::static) + (bundle.install "virtual" get::virtual)))) + (dictionary.merge (<| (bundle.prefix "put") + (|> (: Bundle bundle.empty) + (bundle.install "static" put::static) + (bundle.install "virtual" put::virtual)))) + (dictionary.merge (<| (bundle.prefix "invoke") + (|> (: Bundle bundle.empty) + (bundle.install "static" invoke::static) + (bundle.install "virtual" invoke::virtual) + (bundle.install "special" invoke::special) + (bundle.install "interface" invoke::interface) + (bundle.install "constructor" invoke::constructor)))) + ))) + +(def: annotation-parameter + (Parser (/.Annotation-Parameter Synthesis)) + (<s>.tuple (<>.and <s>.text <s>.any))) + +(def: annotation + (Parser (/.Annotation Synthesis)) + (<s>.tuple (<>.and <s>.text (<>.some ..annotation-parameter)))) + +(def: argument + (Parser Argument) + (<s>.tuple (<>.and <s>.text ..value))) + +(def: overriden-method-definition + (Parser [Environment (/.Overriden-Method Synthesis)]) + (<s>.tuple (do <>.monad + [_ (<s>.text! /.overriden-tag) + ownerT ..class + name <s>.text + strict-fp? <s>.bit + annotations (<s>.tuple (<>.some ..annotation)) + vars (<s>.tuple (<>.some ..var)) + self-name <s>.text + arguments (<s>.tuple (<>.some ..argument)) + returnT ..return + exceptionsT (<s>.tuple (<>.some ..class)) + [environment body] (<s>.function 1 + (<s>.tuple <s>.any))] + (wrap [environment + [ownerT name + strict-fp? annotations vars + self-name arguments returnT exceptionsT + body]])))) + +(def: (normalize-path normalize) + (-> (-> Synthesis Synthesis) + (-> Path Path)) + (function (recur path) + (case path + (^ (synthesis.path/then bodyS)) + (synthesis.path/then (normalize bodyS)) + + (^template [<tag>] + (^ (<tag> leftP rightP)) + (<tag> (recur leftP) (recur rightP))) + ([#synthesis.Alt] + [#synthesis.Seq]) + + (^template [<tag>] + (^ (<tag> value)) + path) + ([#synthesis.Pop] + [#synthesis.Test] + [#synthesis.Bind] + [#synthesis.Access])))) + +(def: (normalize-method-body mapping) + (-> (Dictionary Variable Variable) Synthesis Synthesis) + (function (recur body) + (case body + (^template [<tag>] + (^ (<tag> value)) + body) + ([#synthesis.Primitive] + [synthesis.constant]) + + (^ (synthesis.variant [lefts right? sub])) + (synthesis.variant [lefts right? (recur sub)]) + + (^ (synthesis.tuple members)) + (synthesis.tuple (list@map recur members)) + + (^ (synthesis.variable var)) + (|> mapping + (dictionary.get var) + (maybe.default var) + synthesis.variable) + + (^ (synthesis.branch/case [inputS pathS])) + (synthesis.branch/case [(recur inputS) (normalize-path recur pathS)]) + + (^ (synthesis.branch/let [inputS register outputS])) + (synthesis.branch/let [(recur inputS) register (recur outputS)]) + + (^ (synthesis.branch/if [testS thenS elseS])) + (synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)]) + + (^ (synthesis.loop/scope [offset initsS+ bodyS])) + (synthesis.loop/scope [offset (list@map recur initsS+) (recur bodyS)]) + + (^ (synthesis.loop/recur updatesS+)) + (synthesis.loop/recur (list@map recur updatesS+)) + + (^ (synthesis.function/abstraction [environment arity bodyS])) + (synthesis.function/abstraction [(|> environment (list@map (function (_ local) + (|> mapping + (dictionary.get local) + (maybe.default local))))) + arity + bodyS]) + + (^ (synthesis.function/apply [functionS inputsS+])) + (synthesis.function/apply [(recur functionS) (list@map recur inputsS+)]) + + (#synthesis.Extension [name inputsS+]) + (#synthesis.Extension [name (list@map recur inputsS+)])))) + +(def: $Object (type.class "java.lang.Object" (list))) + +(def: (anonymous-init-method env) + (-> Environment (Type Method)) + (type.method [(list.repeat (list.size env) $Object) + type.void + (list)])) + +(def: (with-anonymous-init class env super-class inputsTI) + (-> (Type Class) Environment (Type Class) (List (Typed Inst)) Def) + (let [store-capturedI (|> env + list.size + list.indices + (list@map (.function (_ register) + (|>> (_.ALOAD 0) + (_.ALOAD (inc register)) + (_.PUTFIELD class (///reference.foreign-name register) $Object)))) + _.fuse)] + (_def.method #$.Public $.noneM "<init>" (anonymous-init-method env) + (|>> (_.ALOAD 0) + ((_.fuse (list@map product.right inputsTI))) + (_.INVOKESPECIAL super-class "<init>" (type.method [(list@map product.left inputsTI) type.void (list)])) + store-capturedI + _.RETURN)))) + +(def: (anonymous-instance archive class env) + (-> Archive (Type Class) Environment (Operation Inst)) + (do {@ phase.monad} + [captureI+ (monad.map @ (///reference.variable archive) env)] + (wrap (|>> (_.NEW class) + _.DUP + (_.fuse captureI+) + (_.INVOKESPECIAL class "<init>" (anonymous-init-method env)))))) + +(def: (returnI returnT) + (-> (Type Return) Inst) + (case (type.void? returnT) + (#.Right returnT) + _.RETURN + + (#.Left returnT) + (case (type.primitive? returnT) + (#.Left returnT) + (|>> (_.CHECKCAST returnT) + _.ARETURN) + + (#.Right returnT) + (cond (or (:: type.equivalence = type.boolean returnT) + (:: type.equivalence = type.byte returnT) + (:: type.equivalence = type.short returnT) + (:: type.equivalence = type.int returnT) + (:: type.equivalence = type.char returnT)) + _.IRETURN + + (:: type.equivalence = type.long returnT) + _.LRETURN + + (:: type.equivalence = type.float returnT) + _.FRETURN + + ## (:: type.equivalence = type.double returnT) + _.DRETURN)))) + +(def: class::anonymous + Handler + (..custom + [($_ <>.and + ..class + (<s>.tuple (<>.some ..class)) + (<s>.tuple (<>.some ..input)) + (<s>.tuple (<>.some ..overriden-method-definition))) + (function (_ extension-name generate archive [super-class super-interfaces + inputsTS + overriden-methods]) + (do {@ phase.monad} + [[context _] (generation.with-new-context archive (wrap [])) + #let [[module-id artifact-id] context + anonymous-class-name (///.class-name context) + class (type.class anonymous-class-name (list)) + total-environment (|> overriden-methods + ## Get all the environments. + (list@map product.left) + ## Combine them. + list@join + ## Remove duplicates. + (set.from-list reference.hash) + set.to-list) + global-mapping (|> total-environment + ## Give them names as "foreign" variables. + list.enumerate + (list@map (function (_ [id capture]) + [capture (#reference.Foreign id)])) + (dictionary.from-list reference.hash)) + normalized-methods (list@map (function (_ [environment + [ownerT name + strict-fp? annotations vars + self-name arguments returnT exceptionsT + body]]) + (let [local-mapping (|> environment + list.enumerate + (list@map (function (_ [foreign-id capture]) + [(#reference.Foreign foreign-id) + (|> global-mapping + (dictionary.get capture) + maybe.assume)])) + (dictionary.from-list reference.hash))] + [ownerT name + strict-fp? annotations vars + self-name arguments returnT exceptionsT + (normalize-method-body local-mapping body)])) + overriden-methods)] + inputsTI (monad.map @ (generate-input generate archive) inputsTS) + method-definitions (|> normalized-methods + (monad.map @ (function (_ [ownerT name + strict-fp? annotations vars + self-name arguments returnT exceptionsT + bodyS]) + (do @ + [bodyG (generation.with-context artifact-id + (generate archive bodyS))] + (wrap (_def.method #$.Public + (if strict-fp? + ($_ $.++M $.finalM $.strictM) + $.finalM) + name + (type.method [(list@map product.right arguments) + returnT + exceptionsT]) + (|>> bodyG (returnI returnT))))))) + (:: @ map _def.fuse)) + _ (generation.save! true ["" (%.nat artifact-id)] + [anonymous-class-name + (_def.class #$.V1_6 #$.Public $.finalC + anonymous-class-name (list) + super-class super-interfaces + (|>> (///function.with-environment total-environment) + (..with-anonymous-init class total-environment super-class inputsTI) + method-definitions))])] + (anonymous-instance archive class total-environment)))])) + +(def: bundle::class + Bundle + (<| (bundle.prefix "class") + (|> (: Bundle bundle.empty) + (bundle.install "anonymous" class::anonymous) + ))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "jvm") + (|> ..conversion + (dictionary.merge ..int) + (dictionary.merge ..long) + (dictionary.merge ..float) + (dictionary.merge ..double) + (dictionary.merge ..char) + (dictionary.merge ..array) + (dictionary.merge ..object-bundle) + (dictionary.merge ..member) + (dictionary.merge ..bundle::class) + ))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/function.lux b/lux-jvm/source/luxc/lang/translation/jvm/function.lux new file mode 100644 index 000000000..888ad9545 --- /dev/null +++ b/lux-jvm/source/luxc/lang/translation/jvm/function.lux @@ -0,0 +1,331 @@ +(.module: + [lux (#- Type function) + [abstract + ["." monad (#+ do)]] + [control + [pipe (#+ when> new>)] + ["." function]] + [data + ["." product] + [text + ["%" format (#+ format)]] + [number + ["n" nat] + ["i" int]] + [collection + ["." list ("#@." functor monoid)]]] + [target + [jvm + ["." type (#+ Type) + ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)]]]] + [tool + [compiler + [arity (#+ Arity)] + [reference (#+ Register)] + ["." phase] + [language + [lux + [analysis (#+ Environment)] + [synthesis (#+ Synthesis Abstraction Apply)] + ["." generation]]] + [meta + [archive (#+ Archive)]]]]] + [luxc + [lang + [host + ["$" jvm (#+ Label Inst Def Operation Phase Generator) + ["." def] + ["_" inst]]]]] + ["." // + ["#." runtime] + ["." reference]]) + +(def: arity-field Text "arity") + +(def: (poly-arg? arity) + (-> Arity Bit) + (n.> 1 arity)) + +(def: (captured-args env) + (-> Environment (List (Type Value))) + (list.repeat (list.size env) //.$Value)) + +(def: (init-method env arity) + (-> Environment Arity (Type Method)) + (if (poly-arg? arity) + (type.method [(list.concat (list (captured-args env) + (list type.int) + (list.repeat (dec arity) //.$Value))) + type.void + (list)]) + (type.method [(captured-args env) type.void (list)]))) + +(def: (implementation-method arity) + (type.method [(list.repeat arity //.$Value) //.$Value (list)])) + +(def: get-amount-of-partialsI + Inst + (|>> (_.ALOAD 0) + (_.GETFIELD //.$Function //runtime.partials-field type.int))) + +(def: (load-fieldI class field) + (-> (Type Class) Text Inst) + (|>> (_.ALOAD 0) + (_.GETFIELD class field //.$Value))) + +(def: (inputsI start amount) + (-> Register Nat Inst) + (|> (list.n/range start (n.+ start (dec amount))) + (list@map _.ALOAD) + _.fuse)) + +(def: (applysI start amount) + (-> Register Nat Inst) + (let [max-args (n.min amount //runtime.num-apply-variants) + later-applysI (if (n.> //runtime.num-apply-variants amount) + (applysI (n.+ //runtime.num-apply-variants start) (n.- //runtime.num-apply-variants amount)) + function.identity)] + (|>> (_.CHECKCAST //.$Function) + (inputsI start max-args) + (_.INVOKEVIRTUAL //.$Function //runtime.apply-method (//runtime.apply-signature max-args)) + later-applysI))) + +(def: (inc-intI by) + (-> Nat Inst) + (|>> (_.int (.int by)) + _.IADD)) + +(def: (nullsI amount) + (-> Nat Inst) + (|> _.NULL + (list.repeat amount) + _.fuse)) + +(def: (instance archive class arity env) + (-> Archive (Type Class) Arity Environment (Operation Inst)) + (do {@ phase.monad} + [captureI+ (monad.map @ (reference.variable archive) env) + #let [argsI (if (poly-arg? arity) + (|> (nullsI (dec arity)) + (list (_.int +0)) + _.fuse) + function.identity)]] + (wrap (|>> (_.NEW class) + _.DUP + (_.fuse captureI+) + argsI + (_.INVOKESPECIAL class "<init>" (init-method env arity)))))) + +(def: (reset-method return) + (-> (Type Class) (Type Method)) + (type.method [(list) return (list)])) + +(def: (with-reset class arity env) + (-> (Type Class) Arity Environment Def) + (def.method #$.Public $.noneM "reset" (reset-method class) + (if (poly-arg? arity) + (let [env-size (list.size env) + captureI (|> (case env-size + 0 (list) + _ (list.n/range 0 (dec env-size))) + (list@map (.function (_ source) + (|>> (_.ALOAD 0) + (_.GETFIELD class (reference.foreign-name source) //.$Value)))) + _.fuse) + argsI (|> (nullsI (dec arity)) + (list (_.int +0)) + _.fuse)] + (|>> (_.NEW class) + _.DUP + captureI + argsI + (_.INVOKESPECIAL class "<init>" (init-method env arity)) + _.ARETURN)) + (|>> (_.ALOAD 0) + _.ARETURN)))) + +(def: (with-implementation arity @begin bodyI) + (-> Nat Label Inst Def) + (def.method #$.Public $.strictM "impl" (implementation-method arity) + (|>> (_.label @begin) + bodyI + _.ARETURN))) + +(def: function-init-method + (type.method [(list type.int) type.void (list)])) + +(def: (function-init arity env-size) + (-> Arity Nat Inst) + (if (n.= 1 arity) + (|>> (_.int +0) + (_.INVOKESPECIAL //.$Function "<init>" function-init-method)) + (|>> (_.ILOAD (inc env-size)) + (_.INVOKESPECIAL //.$Function "<init>" function-init-method)))) + +(def: (with-init class env arity) + (-> (Type Class) Environment Arity Def) + (let [env-size (list.size env) + offset-partial (: (-> Nat Nat) + (|>> inc (n.+ env-size))) + store-capturedI (|> (case env-size + 0 (list) + _ (list.n/range 0 (dec env-size))) + (list@map (.function (_ register) + (|>> (_.ALOAD 0) + (_.ALOAD (inc register)) + (_.PUTFIELD class (reference.foreign-name register) //.$Value)))) + _.fuse) + store-partialI (if (poly-arg? arity) + (|> (list.n/range 0 (n.- 2 arity)) + (list@map (.function (_ idx) + (let [register (offset-partial idx)] + (|>> (_.ALOAD 0) + (_.ALOAD (inc register)) + (_.PUTFIELD class (reference.partial-name idx) //.$Value))))) + _.fuse) + function.identity)] + (def.method #$.Public $.noneM "<init>" (init-method env arity) + (|>> (_.ALOAD 0) + (function-init arity env-size) + store-capturedI + store-partialI + _.RETURN)))) + +(def: (with-apply class env function-arity @begin bodyI apply-arity) + (-> (Type Class) Environment Arity Label Inst Arity + Def) + (let [num-partials (dec function-arity) + @default ($.new-label []) + @labels (list@map $.new-label (list.repeat num-partials [])) + over-extent (|> (.int function-arity) (i.- (.int apply-arity))) + casesI (|> (list@compose @labels (list @default)) + (list.zip2 (list.n/range 0 num-partials)) + (list@map (.function (_ [stage @label]) + (let [load-partialsI (if (n.> 0 stage) + (|> (list.n/range 0 (dec stage)) + (list@map (|>> reference.partial-name (load-fieldI class))) + _.fuse) + function.identity)] + (cond (i.= over-extent (.int stage)) + (|>> (_.label @label) + (_.ALOAD 0) + (when> [(new> (n.> 0 stage) [])] + [(_.INVOKEVIRTUAL class "reset" (reset-method class))]) + load-partialsI + (inputsI 1 apply-arity) + (_.INVOKEVIRTUAL class "impl" (implementation-method function-arity)) + _.ARETURN) + + (i.> over-extent (.int stage)) + (let [args-to-completion (|> function-arity (n.- stage)) + args-left (|> apply-arity (n.- args-to-completion))] + (|>> (_.label @label) + (_.ALOAD 0) + (_.INVOKEVIRTUAL class "reset" (reset-method class)) + load-partialsI + (inputsI 1 args-to-completion) + (_.INVOKEVIRTUAL class "impl" (implementation-method function-arity)) + (applysI (inc args-to-completion) args-left) + _.ARETURN)) + + ## (i.< over-extent (.int stage)) + (let [env-size (list.size env) + load-capturedI (|> (case env-size + 0 (list) + _ (list.n/range 0 (dec env-size))) + (list@map (|>> reference.foreign-name (load-fieldI class))) + _.fuse)] + (|>> (_.label @label) + (_.NEW class) + _.DUP + load-capturedI + get-amount-of-partialsI + (inc-intI apply-arity) + load-partialsI + (inputsI 1 apply-arity) + (nullsI (|> num-partials (n.- apply-arity) (n.- stage))) + (_.INVOKESPECIAL class "<init>" (init-method env function-arity)) + _.ARETURN)) + )))) + _.fuse)] + (def.method #$.Public $.noneM //runtime.apply-method (//runtime.apply-signature apply-arity) + (|>> get-amount-of-partialsI + (_.TABLESWITCH +0 (|> num-partials dec .int) + @default @labels) + casesI + )))) + +(def: #export with-environment + (-> Environment Def) + (|>> list.enumerate + (list@map (.function (_ [env-idx env-source]) + (def.field #$.Private $.finalF (reference.foreign-name env-idx) //.$Value))) + def.fuse)) + +(def: (with-partial arity) + (-> Arity Def) + (if (poly-arg? arity) + (|> (list.n/range 0 (n.- 2 arity)) + (list@map (.function (_ idx) + (def.field #$.Private $.finalF (reference.partial-name idx) //.$Value))) + def.fuse) + function.identity)) + +(def: #export (with-function archive @begin class env arity bodyI) + (-> Archive Label Text Environment Arity Inst + (Operation [Def Inst])) + (let [classD (type.class class (list)) + applyD (: Def + (if (poly-arg? arity) + (|> (n.min arity //runtime.num-apply-variants) + (list.n/range 1) + (list@map (with-apply classD env arity @begin bodyI)) + (list& (with-implementation arity @begin bodyI)) + def.fuse) + (def.method #$.Public $.strictM //runtime.apply-method (//runtime.apply-signature 1) + (|>> (_.label @begin) + bodyI + _.ARETURN)))) + functionD (: Def + (|>> (def.int-field #$.Public ($_ $.++F $.staticF $.finalF) arity-field (.int arity)) + (with-environment env) + (with-partial arity) + (with-init classD env arity) + (with-reset classD arity env) + applyD + ))] + (do phase.monad + [instanceI (instance archive classD arity env)] + (wrap [functionD instanceI])))) + +(def: #export (function generate archive [env arity bodyS]) + (Generator Abstraction) + (do phase.monad + [@begin _.make-label + [function-context bodyI] (generation.with-new-context archive + (generation.with-anchor [@begin 1] + (generate archive bodyS))) + #let [function-class (//.class-name function-context)] + [functionD instanceI] (with-function archive @begin function-class env arity bodyI) + _ (generation.save! true ["" (%.nat (product.right function-context))] + [function-class + (def.class #$.V1_6 #$.Public $.finalC + function-class (list) + //.$Function (list) + functionD)])] + (wrap instanceI))) + +(def: #export (call generate archive [functionS argsS]) + (Generator Apply) + (do {@ phase.monad} + [functionI (generate archive functionS) + argsI (monad.map @ (generate archive) argsS) + #let [applyI (|> argsI + (list.split-all //runtime.num-apply-variants) + (list@map (.function (_ chunkI+) + (|>> (_.CHECKCAST //.$Function) + (_.fuse chunkI+) + (_.INVOKEVIRTUAL //.$Function //runtime.apply-method (//runtime.apply-signature (list.size chunkI+)))))) + _.fuse)]] + (wrap (|>> functionI + applyI)))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/loop.lux b/lux-jvm/source/luxc/lang/translation/jvm/loop.lux new file mode 100644 index 000000000..1f2168fed --- /dev/null +++ b/lux-jvm/source/luxc/lang/translation/jvm/loop.lux @@ -0,0 +1,81 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function]] + [data + [number + ["n" nat]] + [collection + ["." list ("#/." functor monoid)]]] + [tool + [compiler + [reference (#+ Register)] + ["." phase] + [language + [lux + ["." synthesis (#+ Synthesis)] + ["." generation]]]]]] + [luxc + [lang + [host + [jvm (#+ Inst Operation Phase Generator) + ["_" inst]]]]] + ["." //]) + +(def: (invariant? register changeS) + (-> Register Synthesis Bit) + (case changeS + (^ (synthesis.variable/local var)) + (n.= register var) + + _ + false)) + +(def: #export (recur translate archive argsS) + (Generator (List Synthesis)) + (do {@ phase.monad} + [[@begin start] generation.anchor + #let [end (|> argsS list.size dec (n.+ start)) + pairs (list.zip2 (list.n/range start end) + argsS)] + ## It may look weird that first I compile the values separately, + ## and then I compile the stores/allocations. + ## It must be done that way in order to avoid a potential bug. + ## Let's say that you'll recur with 2 expressions: X and Y. + ## If Y depends on the value of X, and you don't compile values + ## and stores separately, then by the time Y is evaluated, it + ## will refer to the new value of X, instead of the old value, as + ## should be the case. + valuesI+ (monad.map @ (function (_ [register argS]) + (: (Operation Inst) + (if (invariant? register argS) + (wrap function.identity) + (translate archive argS)))) + pairs) + #let [storesI+ (list/map (function (_ [register argS]) + (: Inst + (if (invariant? register argS) + function.identity + (_.ASTORE register)))) + (list.reverse pairs))]] + (wrap (|>> (_.fuse valuesI+) + (_.fuse storesI+) + (_.GOTO @begin))))) + +(def: #export (scope translate archive [start initsS+ iterationS]) + (Generator [Nat (List Synthesis) Synthesis]) + (do {@ phase.monad} + [@begin _.make-label + initsI+ (monad.map @ (translate archive) initsS+) + iterationI (generation.with-anchor [@begin start] + (translate archive iterationS)) + #let [initializationI (|> (list.enumerate initsI+) + (list/map (function (_ [register initI]) + (|>> initI + (_.ASTORE (n.+ start register))))) + _.fuse)]] + (wrap (|>> initializationI + (_.label @begin) + iterationI)))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/primitive.lux b/lux-jvm/source/luxc/lang/translation/jvm/primitive.lux new file mode 100644 index 000000000..873c363bd --- /dev/null +++ b/lux-jvm/source/luxc/lang/translation/jvm/primitive.lux @@ -0,0 +1,30 @@ +(.module: + [lux (#- i64) + [target + [jvm + ["." type]]] + [tool + [compiler + [phase ("operation@." monad)]]]] + [luxc + [lang + [host + ["." jvm (#+ Inst Operation) + ["_" inst]]]]]) + +(def: #export bit + (-> Bit (Operation Inst)) + (let [Boolean (type.class "java.lang.Boolean" (list))] + (function (_ value) + (operation@wrap (_.GETSTATIC Boolean (if value "TRUE" "FALSE") Boolean))))) + +(template [<name> <type> <load> <wrap>] + [(def: #export (<name> value) + (-> <type> (Operation Inst)) + (let [loadI (|> value <load>)] + (operation@wrap (|>> loadI <wrap>))))] + + [i64 (I64 Any) (<| _.long .int) (_.wrap type.long)] + [f64 Frac _.double (_.wrap type.double)] + [text Text _.string (<|)] + ) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/program.lux b/lux-jvm/source/luxc/lang/translation/jvm/program.lux new file mode 100644 index 000000000..7ac897009 --- /dev/null +++ b/lux-jvm/source/luxc/lang/translation/jvm/program.lux @@ -0,0 +1,82 @@ +(.module: + [lux #* + [target + [jvm + ["$t" type]]]] + [luxc + [lang + [host + ["_" jvm + ["$d" def] + ["$i" inst]]] + [translation + ["." jvm + ["." runtime]]]]]) + +(def: #export class "LuxProgram") + +(def: ^Object ($t.class "java.lang.Object" (list))) + +(def: #export (program programI) + (-> _.Inst _.Definition) + (let [nilI runtime.noneI + num-inputsI (|>> ($i.ALOAD 0) $i.ARRAYLENGTH) + decI (|>> ($i.int +1) $i.ISUB) + headI (|>> $i.DUP + ($i.ALOAD 0) + $i.SWAP + $i.AALOAD + $i.SWAP + $i.DUP_X2 + $i.POP) + pairI (|>> ($i.int +2) + ($i.ANEWARRAY ..^Object) + $i.DUP_X1 + $i.SWAP + ($i.int +0) + $i.SWAP + $i.AASTORE + $i.DUP_X1 + $i.SWAP + ($i.int +1) + $i.SWAP + $i.AASTORE) + consI (|>> ($i.int +1) + ($i.string "") + $i.DUP2_X1 + $i.POP2 + runtime.variantI) + prepare-input-listI (<| $i.with-label (function (_ @loop)) + $i.with-label (function (_ @end)) + (|>> nilI + num-inputsI + ($i.label @loop) + decI + $i.DUP + ($i.IFLT @end) + headI + pairI + consI + $i.SWAP + ($i.GOTO @loop) + ($i.label @end) + $i.POP)) + feed-inputsI ($i.INVOKEVIRTUAL jvm.$Function runtime.apply-method (runtime.apply-signature 1)) + run-ioI (|>> ($i.CHECKCAST jvm.$Function) + $i.NULL + ($i.INVOKEVIRTUAL jvm.$Function runtime.apply-method (runtime.apply-signature 1))) + main-type ($t.method [(list ($t.array ($t.class "java.lang.String" (list)))) + $t.void + (list)])] + [..class + ($d.class #_.V1_6 + #_.Public _.finalC + ..class + (list) ..^Object + (list) + (|>> ($d.method #_.Public _.staticM "main" main-type + (|>> programI + prepare-input-listI + feed-inputsI + run-ioI + $i.RETURN))))])) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/reference.lux b/lux-jvm/source/luxc/lang/translation/jvm/reference.lux new file mode 100644 index 000000000..6bcf4a2e5 --- /dev/null +++ b/lux-jvm/source/luxc/lang/translation/jvm/reference.lux @@ -0,0 +1,65 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [data + [text + ["%" format (#+ format)]]] + [target + [jvm + ["." type]]] + [tool + [compiler + ["." reference (#+ Register Variable)] + ["." phase ("operation@." monad)] + [meta + [archive (#+ Archive)]] + [language + [lux + ["." generation]]]]]] + [luxc + [lang + [host + [jvm (#+ Inst Operation) + ["_" inst]]]]] + ["." // + ["#." runtime]]) + +(template [<name> <prefix>] + [(def: #export <name> + (-> Nat Text) + (|>> %.nat (format <prefix>)))] + + [foreign-name "f"] + [partial-name "p"] + ) + +(def: (foreign archive variable) + (-> Archive Register (Operation Inst)) + (do {@ phase.monad} + [class-name (:: @ map //.class-name + (generation.context archive))] + (wrap (|>> (_.ALOAD 0) + (_.GETFIELD (type.class class-name (list)) + (|> variable .nat foreign-name) + //.$Value))))) + +(def: local + (-> Register Inst) + (|>> _.ALOAD)) + +(def: #export (variable archive variable) + (-> Archive Variable (Operation Inst)) + (case variable + (#reference.Local variable) + (operation@wrap (local variable)) + + (#reference.Foreign variable) + (foreign archive variable))) + +(def: #export (constant archive name) + (-> Archive Name (Operation Inst)) + (do {@ phase.monad} + [class-name (:: @ map //.class-name + (generation.remember archive name))] + (wrap (_.GETSTATIC (type.class class-name (list)) //.value-field //.$Value)))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux b/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux new file mode 100644 index 000000000..a657a7a38 --- /dev/null +++ b/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux @@ -0,0 +1,387 @@ +(.module: + [lux (#- Type) + [abstract + [monad (#+ do)]] + [data + [binary (#+ Binary)] + ["." product] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#@." functor)] + ["." row]]] + ["." math] + [target + [jvm + ["." type (#+ Type) + ["." category (#+ Void Value' Value Return' Return Primitive Object Class Array Var Parameter Method)] + ["." reflection]]]] + [tool + [compiler (#+ Output) + [arity (#+ Arity)] + ["." phase] + [language + [lux + ["." synthesis] + ["." generation]]] + [meta + [archive + ["." artifact (#+ Registry)]]]]]] + [luxc + [lang + [host + ["$" jvm (#+ Label Inst Def Operation) + ["$d" def] + ["_" inst]]]]] + ["." // (#+ ByteCode)]) + +(def: $Text (type.class "java.lang.String" (list))) +(def: #export $Tag type.int) +(def: #export $Flag (type.class "java.lang.Object" (list))) +(def: #export $Value (type.class "java.lang.Object" (list))) +(def: #export $Index type.int) +(def: #export $Stack (type.array $Value)) +(def: $Throwable (type.class "java.lang.Throwable" (list))) + +(def: nullary-init-methodT + (type.method [(list) type.void (list)])) + +(def: throw-methodT + (type.method [(list) type.void (list)])) + +(def: #export logI + Inst + (let [PrintStream (type.class "java.io.PrintStream" (list)) + outI (_.GETSTATIC (type.class "java.lang.System" (list)) "out" PrintStream) + printI (function (_ method) + (_.INVOKEVIRTUAL PrintStream method (type.method [(list $Value) type.void (list)])))] + (|>> outI (_.string "LOG: ") (printI "print") + outI _.SWAP (printI "println")))) + +(def: variant-method + (type.method [(list $Tag $Flag $Value) //.$Variant (list)])) + +(def: #export variantI + Inst + (_.INVOKESTATIC //.$Runtime "variant_make" variant-method)) + +(def: #export leftI + Inst + (|>> (_.int +0) + _.NULL + _.DUP2_X1 + _.POP2 + variantI)) + +(def: #export rightI + Inst + (|>> (_.int +1) + (_.string "") + _.DUP2_X1 + _.POP2 + variantI)) + +(def: #export someI Inst rightI) + +(def: #export noneI + Inst + (|>> (_.int +0) + _.NULL + (_.string synthesis.unit) + variantI)) + +(def: (tryI unsafeI) + (-> Inst Inst) + (<| _.with-label (function (_ @from)) + _.with-label (function (_ @to)) + _.with-label (function (_ @handler)) + (|>> (_.try @from @to @handler (type.class "java.lang.Exception" (list))) + (_.label @from) + unsafeI + someI + _.ARETURN + (_.label @to) + (_.label @handler) + noneI + _.ARETURN))) + +(def: #export partials-field Text "partials") +(def: #export apply-method Text "apply") +(def: #export num-apply-variants Nat 8) + +(def: #export (apply-signature arity) + (-> Arity (Type Method)) + (type.method [(list.repeat arity $Value) $Value (list)])) + +(def: adt-methods + Def + (let [store-tagI (|>> _.DUP (_.int +0) (_.ILOAD 0) (_.wrap type.int) _.AASTORE) + store-flagI (|>> _.DUP (_.int +1) (_.ALOAD 1) _.AASTORE) + store-valueI (|>> _.DUP (_.int +2) (_.ALOAD 2) _.AASTORE)] + (|>> ($d.method #$.Public $.staticM "variant_make" + (type.method [(list $Tag $Flag $Value) //.$Variant (list)]) + (|>> (_.int +3) + (_.ANEWARRAY $Value) + store-tagI + store-flagI + store-valueI + _.ARETURN))))) + +(def: frac-methods + Def + (|>> ($d.method #$.Public $.staticM "decode_frac" (type.method [(list $Text) //.$Variant (list)]) + (tryI + (|>> (_.ALOAD 0) + (_.INVOKESTATIC (type.class "java.lang.Double" (list)) "parseDouble" (type.method [(list $Text) type.double (list)])) + (_.wrap type.double)))) + )) + +(def: (illegal-state-exception message) + (-> Text Inst) + (let [IllegalStateException (type.class "java.lang.IllegalStateException" (list))] + (|>> (_.NEW IllegalStateException) + _.DUP + (_.string message) + (_.INVOKESPECIAL IllegalStateException "<init>" (type.method [(list $Text) type.void (list)]))))) + +(def: pm-methods + Def + (let [tuple-sizeI (|>> (_.ALOAD 0) _.ARRAYLENGTH) + last-rightI (|>> tuple-sizeI (_.int +1) _.ISUB) + leftsI (_.ILOAD 1) + left-indexI leftsI + sub-leftsI (|>> leftsI + last-rightI + _.ISUB) + sub-tupleI (|>> (_.ALOAD 0) last-rightI _.AALOAD (_.CHECKCAST //.$Tuple)) + recurI (: (-> Label Inst) + (function (_ @loop) + (|>> sub-leftsI (_.ISTORE 1) + sub-tupleI (_.ASTORE 0) + (_.GOTO @loop))))] + (|>> ($d.method #$.Public $.staticM "pm_fail" throw-methodT + (|>> (illegal-state-exception "Invalid expression for pattern-matching.") + _.ATHROW)) + ($d.method #$.Public $.staticM "apply_fail" throw-methodT + (|>> (illegal-state-exception "Error while applying function.") + _.ATHROW)) + ($d.method #$.Public $.staticM "pm_push" (type.method [(list $Stack $Value) $Stack (list)]) + (|>> (_.int +2) + (_.ANEWARRAY $Value) + _.DUP + (_.int +1) + (_.ALOAD 0) + _.AASTORE + _.DUP + (_.int +0) + (_.ALOAD 1) + _.AASTORE + _.ARETURN)) + ($d.method #$.Public $.staticM "pm_variant" (type.method [(list //.$Variant $Tag $Flag) $Value (list)]) + (<| _.with-label (function (_ @loop)) + _.with-label (function (_ @perfect-match!)) + _.with-label (function (_ @tags-match!)) + _.with-label (function (_ @maybe-nested)) + _.with-label (function (_ @mismatch!)) + (let [$variant (_.ALOAD 0) + $tag (_.ILOAD 1) + $last? (_.ALOAD 2) + + variant-partI (: (-> Nat Inst) + (function (_ idx) + (|>> (_.int (.int idx)) _.AALOAD))) + ::tag (: Inst + (|>> (variant-partI 0) (_.unwrap type.int))) + ::last? (variant-partI 1) + ::value (variant-partI 2) + + super-nested-tag (|>> _.SWAP ## variant::tag, tag + _.ISUB) + super-nested (|>> super-nested-tag ## super-tag + $variant ::last? ## super-tag, super-last + $variant ::value ## super-tag, super-last, super-value + ..variantI) + + update-$tag _.ISUB + update-$variant (|>> $variant ::value + (_.CHECKCAST //.$Variant) + (_.ASTORE 0)) + iterate! (: (-> Label Inst) + (function (_ @loop) + (|>> update-$variant + update-$tag + (_.GOTO @loop)))) + + not-found _.NULL]) + (|>> $tag ## tag + (_.label @loop) + $variant ::tag ## tag, variant::tag + _.DUP2 (_.IF_ICMPEQ @tags-match!) ## tag, variant::tag + _.DUP2 (_.IF_ICMPGT @maybe-nested) ## tag, variant::tag + $last? (_.IFNULL @mismatch!) ## tag, variant::tag + super-nested ## super-variant + _.ARETURN + (_.label @tags-match!) ## tag, variant::tag + $last? ## tag, variant::tag, last? + $variant ::last? ## tag, variant::tag, last?, variant::last? + (_.IF_ACMPEQ @perfect-match!) ## tag, variant::tag + (_.label @maybe-nested) ## tag, variant::tag + $variant ::last? ## tag, variant::tag, variant::last? + (_.IFNULL @mismatch!) ## tag, variant::tag + (iterate! @loop) + (_.label @perfect-match!) ## tag, variant::tag + ## _.POP2 + $variant ::value + _.ARETURN + (_.label @mismatch!) ## tag, variant::tag + ## _.POP2 + not-found + _.ARETURN))) + ($d.method #$.Public $.staticM "tuple_left" (type.method [(list //.$Tuple $Index) $Value (list)]) + (<| _.with-label (function (_ @loop)) + _.with-label (function (_ @recursive)) + (let [left-accessI (|>> (_.ALOAD 0) left-indexI _.AALOAD)]) + (|>> (_.label @loop) + leftsI last-rightI (_.IF_ICMPGE @recursive) + left-accessI + _.ARETURN + (_.label @recursive) + ## Recursive + (recurI @loop)))) + ($d.method #$.Public $.staticM "tuple_right" (type.method [(list //.$Tuple $Index) $Value (list)]) + (<| _.with-label (function (_ @loop)) + _.with-label (function (_ @not-tail)) + _.with-label (function (_ @slice)) + (let [right-indexI (|>> leftsI + (_.int +1) + _.IADD) + right-accessI (|>> (_.ALOAD 0) + _.SWAP + _.AALOAD) + sub-rightI (|>> (_.ALOAD 0) + right-indexI + tuple-sizeI + (_.INVOKESTATIC (type.class "java.util.Arrays" (list)) "copyOfRange" + (type.method [(list //.$Tuple $Index $Index) + //.$Tuple + (list)])))]) + (|>> (_.label @loop) + last-rightI right-indexI + _.DUP2 (_.IF_ICMPNE @not-tail) + ## _.POP + right-accessI + _.ARETURN + (_.label @not-tail) + (_.IF_ICMPGT @slice) + ## Must recurse + (recurI @loop) + (_.label @slice) + sub-rightI + _.ARETURN + ))) + ))) + +(def: #export try (type.method [(list //.$Function) //.$Variant (list)])) + +(def: io-methods + Def + (let [StringWriter (type.class "java.io.StringWriter" (list)) + PrintWriter (type.class "java.io.PrintWriter" (list)) + string-writerI (|>> (_.NEW StringWriter) + _.DUP + (_.INVOKESPECIAL StringWriter "<init>" nullary-init-methodT)) + print-writerI (|>> (_.NEW PrintWriter) + _.SWAP + _.DUP2 + _.POP + _.SWAP + (_.boolean true) + (_.INVOKESPECIAL PrintWriter "<init>" (type.method [(list (type.class "java.io.Writer" (list)) type.boolean) type.void (list)])) + )] + (|>> ($d.method #$.Public $.staticM "try" ..try + (<| _.with-label (function (_ @from)) + _.with-label (function (_ @to)) + _.with-label (function (_ @handler)) + (|>> (_.try @from @to @handler $Throwable) + (_.label @from) + (_.ALOAD 0) + _.NULL + (_.INVOKEVIRTUAL //.$Function apply-method (apply-signature 1)) + rightI + _.ARETURN + (_.label @to) + (_.label @handler) + string-writerI ## TW + _.DUP2 ## TWTW + print-writerI ## TWTP + (_.INVOKEVIRTUAL $Throwable "printStackTrace" (type.method [(list (type.class "java.io.PrintWriter" (list))) type.void (list)])) ## TW + (_.INVOKEVIRTUAL StringWriter "toString" (type.method [(list) $Text (list)])) ## TS + _.SWAP _.POP leftI + _.ARETURN))) + ))) + +(def: reflection + (All [category] + (-> (Type (<| Return' Value' category)) Text)) + (|>> type.reflection reflection.reflection)) + +(def: translate-runtime + (Operation [Text Binary]) + (let [runtime-class (..reflection //.$Runtime) + bytecode ($d.class #$.V1_6 #$.Public $.finalC runtime-class (list) (type.class "java.lang.Object" (list)) (list) + (|>> adt-methods + frac-methods + pm-methods + io-methods)) + payload ["0" bytecode]] + (do phase.monad + [_ (generation.execute! runtime-class [runtime-class bytecode]) + _ (generation.save! false ["" "0"] payload)] + (wrap payload)))) + +(def: translate-function + (Operation [Text Binary]) + (let [applyI (|> (list.n/range 2 num-apply-variants) + (list@map (function (_ arity) + ($d.method #$.Public $.noneM apply-method (apply-signature arity) + (let [preI (|> (list.n/range 0 (dec arity)) + (list@map _.ALOAD) + _.fuse)] + (|>> preI + (_.INVOKEVIRTUAL //.$Function apply-method (apply-signature (dec arity))) + (_.CHECKCAST //.$Function) + (_.ALOAD arity) + (_.INVOKEVIRTUAL //.$Function apply-method (apply-signature 1)) + _.ARETURN))))) + (list& ($d.abstract-method #$.Public $.noneM apply-method (apply-signature 1))) + $d.fuse) + $Object (type.class "java.lang.Object" (list)) + function-class (..reflection //.$Function) + bytecode ($d.abstract #$.V1_6 #$.Public $.noneC function-class (list) $Object (list) + (|>> ($d.field #$.Public $.finalF partials-field type.int) + ($d.method #$.Public $.noneM "<init>" (type.method [(list type.int) type.void (list)]) + (|>> (_.ALOAD 0) + (_.INVOKESPECIAL $Object "<init>" nullary-init-methodT) + (_.ALOAD 0) + (_.ILOAD 1) + (_.PUTFIELD //.$Function partials-field type.int) + _.RETURN)) + applyI)) + payload ["1" bytecode]] + (do phase.monad + [_ (generation.execute! function-class [function-class bytecode]) + _ (generation.save! false ["" "1"] payload)] + (wrap payload)))) + +(def: #export translate + (Operation [Registry Output]) + (do phase.monad + [runtime-payload ..translate-runtime + function-payload ..translate-function] + (wrap [(|> artifact.empty + artifact.resource + product.right + artifact.resource + product.right) + (row.row runtime-payload + function-payload)]))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/structure.lux b/lux-jvm/source/luxc/lang/translation/jvm/structure.lux new file mode 100644 index 000000000..46f87142a --- /dev/null +++ b/lux-jvm/source/luxc/lang/translation/jvm/structure.lux @@ -0,0 +1,79 @@ +(.module: + [lux (#- Type) + [abstract + ["." monad (#+ do)]] + [control + ["ex" exception (#+ exception:)]] + [data + [number + ["n" nat]] + [text + ["%" format (#+ format)]] + [collection + ["." list]]] + [target + [jvm + ["." type (#+ Type) + ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] + ["." descriptor (#+ Descriptor)] + ["." signature (#+ Signature)]]]] + [tool + [compiler + ["." phase] + [meta + [archive (#+ Archive)]] + [language + [lux + [synthesis (#+ Synthesis)]]]]]] + [luxc + [lang + [host + [jvm (#+ Inst Operation Phase Generator) + ["_" inst]]]]] + ["." // + ["#." runtime]]) + +(exception: #export (not-a-tuple {size Nat}) + (ex.report ["Expected size" ">= 2"] + ["Actual size" (%.nat size)])) + +(def: #export (tuple generate archive members) + (Generator (List Synthesis)) + (do {@ phase.monad} + [#let [size (list.size members)] + _ (phase.assert not-a-tuple size + (n.>= 2 size)) + membersI (|> members + list.enumerate + (monad.map @ (function (_ [idx member]) + (do @ + [memberI (generate archive member)] + (wrap (|>> _.DUP + (_.int (.int idx)) + memberI + _.AASTORE))))) + (:: @ map _.fuse))] + (wrap (|>> (_.int (.int size)) + (_.array //runtime.$Value) + membersI)))) + +(def: (flagI right?) + (-> Bit Inst) + (if right? + (_.string "") + _.NULL)) + +(def: #export (variant generate archive [lefts right? member]) + (Generator [Nat Bit Synthesis]) + (do phase.monad + [memberI (generate archive member)] + (wrap (|>> (_.int (.int (if right? + (.inc lefts) + lefts))) + (flagI right?) + memberI + (_.INVOKESTATIC //.$Runtime + "variant_make" + (type.method [(list //runtime.$Tag //runtime.$Flag //runtime.$Value) + //.$Variant + (list)])))))) |