diff options
Diffstat (limited to 'new-luxc/source/luxc/generator/host')
| -rw-r--r-- | new-luxc/source/luxc/generator/host/jvm.lux | 61 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/host/jvm/def.lux | 142 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/host/jvm/inst.lux | 195 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/host/jvm/type.lux | 138 |
4 files changed, 536 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/generator/host/jvm.lux b/new-luxc/source/luxc/generator/host/jvm.lux new file mode 100644 index 000000000..f1eb61166 --- /dev/null +++ b/new-luxc/source/luxc/generator/host/jvm.lux @@ -0,0 +1,61 @@ +(;module: + [lux #- Type Def] + (lux [host #+ jvm-import])) + +## [Host] +(jvm-import org.objectweb.asm.MethodVisitor) + +(jvm-import org.objectweb.asm.ClassWriter) + +## [Type] +(type: #export Bound + #Upper + #Lower) + +(type: #export Primitive + #Boolean + #Byte + #Short + #Int + #Long + #Float + #Double + #Char) + +(type: #export #rec Generic + (#Var Text) + (#Wildcard (Maybe [Bound Generic])) + (#Class Text (List Generic))) + +(type: #export #rec Type + (#Primitive Primitive) + (#Generic Generic) + (#Array Type)) + +(type: #export Method + {#args (List Type) + #return (Maybe Type) + #exceptions (List Generic)}) + +(type: #export Def + (-> ClassWriter ClassWriter)) + +(type: #export Inst + (-> MethodVisitor MethodVisitor)) + +(type: #export Visibility + #Public + #Protected + #Private + #Default) + +(type: #export Method-Config + {#staticM Bool + #finalM Bool + #synchronizedM Bool}) + +(type: #export Field-Config + {#staticF Bool + #finalF Bool + #transientF Bool + #volatileF Bool}) diff --git a/new-luxc/source/luxc/generator/host/jvm/def.lux b/new-luxc/source/luxc/generator/host/jvm/def.lux new file mode 100644 index 000000000..1fd87caea --- /dev/null +++ b/new-luxc/source/luxc/generator/host/jvm/def.lux @@ -0,0 +1,142 @@ +(;module: + lux + (lux (data (coll ["a" array] + [list "L/" Functor<List>])) + [host #+ jvm-import do-to]) + ["$" ..] + (.. ["$t" type])) + +## [Host] +(jvm-import #long java.lang.Object) +(jvm-import #long java.lang.String) + +(jvm-import org.objectweb.asm.Opcodes + (#static ACC_PUBLIC int) + (#static ACC_PROTECTED int) + (#static ACC_PRIVATE int) + + (#static ACC_ABSTRACT int) + (#static ACC_FINAL int) + (#static ACC_STATIC int) + (#static ACC_SYNCHRONIZED int) + + (#static ACC_TRANSIENT int) + (#static ACC_VOLATILE int)) + +(jvm-import org.objectweb.asm.FieldVisitor + (visitEnd [] void)) + +(jvm-import org.objectweb.asm.MethodVisitor + (visitCode [] void) + (visitMaxs [int int] void) + (visitEnd [] void)) + +(jvm-import org.objectweb.asm.ClassWriter + (#static COMPUTE_MAXS int) + (new [int]) + (visit [int int String String String (Array String)] void) + (visitEnd [] void) + (visitField [int String String String Object] FieldVisitor) + (visitMethod [int String String String (Array String)] MethodVisitor) + (toByteArray [] Byte-Array)) + +## [Defs] +(def: (exceptions-array type) + (-> $;Method (a;Array Text)) + (let [exs (|> type (get@ #$;exceptions) (L/map (|>. #$;Generic $t;descriptor))) + output (host;array String (list;size exs))] + (exec (L/map (function [[idx value]] + (host;array-store idx value output)) + (list;enumerate exs)) + output))) + +(def: (visibility-flag visibility) + (-> $;Visibility Int) + (case visibility + #$;Public Opcodes.ACC_PUBLIC + #$;Protected Opcodes.ACC_PROTECTED + #$;Private Opcodes.ACC_PRIVATE + #$;Default 0)) + +(def: (method-flag 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))) + +(def: (field-flag 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: #export (method visibility config name type then) + (-> $;Visibility $;Method-Config Text $;Method $;Inst + $;Def) + (function [writer] + (let [=method (ClassWriter.visitMethod [($_ i.+ + (visibility-flag visibility) + (method-flag config)) + name + ($t;method-descriptor type) + ($t;method-signature type) + (exceptions-array type)] + 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 $;Method + $;Def) + (function [writer] + (let [=method (ClassWriter.visitMethod [($_ i.+ + (visibility-flag visibility) + (method-flag config) + Opcodes.ACC_ABSTRACT) + name + ($t;method-descriptor type) + ($t;method-signature type) + (exceptions-array type)] + writer) + _ (MethodVisitor.visitEnd [] =method)] + writer))) + +(def: #export (field visibility config name type) + (-> $;Visibility $;Field-Config Text $;Type $;Def) + (function [writer] + (let [=field (do-to (ClassWriter.visitField [($_ i.+ + (visibility-flag visibility) + (field-flag config)) + name ($t;descriptor type) ($t;signature type) (host;null)] writer) + (FieldVisitor.visitEnd []))] + writer))) + +(do-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-flag config)) + name ($t;descriptor <jvm-type>) ($t;signature <jvm-type>) + (<prepare> value)] + writer) + (FieldVisitor.visitEnd []))] + writer)))] + + [boolean-field Bool $t;boolean id] + [byte-field Int $t;byte host;l2b] + [short-field Int $t;short host;l2s] + [int-field Int $t;int host;l2i] + [long-field Int $t;long id] + [float-field Real $t;float host;d2f] + [double-field Real $t;double id] + [char-field Char $t;char id] + [string-field Text ($t;class "java.lang.String" (list)) id] + ) diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux new file mode 100644 index 000000000..f340be055 --- /dev/null +++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux @@ -0,0 +1,195 @@ +(;module: + lux + (lux [host #+ jvm-import do-to]) + ["$" ..] + (.. ["$t" type])) + +## [Host] +(jvm-import #long java.lang.Object) +(jvm-import #long java.lang.String) + +(jvm-import org.objectweb.asm.Opcodes + (#static T_BOOLEAN int) + (#static T_CHAR int) + (#static T_FLOAT int) + (#static T_DOUBLE int) + (#static T_BYTE int) + (#static T_SHORT int) + (#static T_INT int) + (#static T_LONG int) + + (#static DUP int) + (#static RETURN int) + (#static ARETURN int) + (#static ACONST_NULL int) + (#static ILOAD int) + (#static ALOAD int) + (#static NEWARRAY int) + (#static ANEWARRAY int) + (#static AASTORE int) + (#static PUTSTATIC int) + (#static GETFIELD int) + (#static INVOKESTATIC int) + (#static INVOKEVIRTUAL int) + (#static INVOKESPECIAL int) + (#static CHECKCAST int)) + +(jvm-import org.objectweb.asm.FieldVisitor + (visitEnd [] void)) + +(jvm-import org.objectweb.asm.MethodVisitor + (visitCode [] void) + (visitMaxs [int int] void) + (visitEnd [] void) + (visitInsn [int] void) + (visitLdcInsn [Object] void) + (visitFieldInsn [int String String String] void) + (visitTypeInsn [int String] void) + (visitVarInsn [int int] void) + (visitIntInsn [int int] void) + (visitMethodInsn [int String String String boolean] void)) + +## [Insts] +(do-template [<name> <type> <prepare>] + [(def: #export (<name> value) + (-> <type> $;Inst) + (function [visitor] + (do-to visitor + (MethodVisitor.visitLdcInsn [(<prepare> value)]))))] + + [boolean Bool id] + [int Int host;l2i] + [long Int id] + [double Real id] + [char Char id] + [string Text id] + ) + +(do-template [<name> <inst>] + [(def: #export <name> + $;Inst + (function [visitor] + (do-to visitor + (MethodVisitor.visitInsn [<inst>]))))] + + [RETURN Opcodes.RETURN] + [ARETURN Opcodes.ARETURN] + [NULL Opcodes.ACONST_NULL] + [DUP Opcodes.DUP] + [AASTORE Opcodes.AASTORE] + ) + +(do-template [<name> <inst>] + [(def: #export (<name> register) + (-> Nat $;Inst) + (function [visitor] + (do-to visitor + (MethodVisitor.visitVarInsn [<inst> (nat-to-int register)]))))] + + [ALOAD Opcodes.ALOAD] + [ILOAD Opcodes.ILOAD] + ) + +(do-template [<name> <inst>] + [(def: #export (<name> class field type) + (-> Text Text $;Type $;Inst) + (function [visitor] + (do-to visitor + (MethodVisitor.visitFieldInsn [<inst> ($t;binary-name class) field ($t;descriptor type)]))))] + + [PUTSTATIC Opcodes.PUTSTATIC] + ) + +(do-template [<name> <inst>] + [(def: #export (<name> class) + (-> Text $;Inst) + (function [visitor] + (do-to visitor + (MethodVisitor.visitTypeInsn [<inst> ($t;binary-name class)]))))] + + [ANEWARRAY Opcodes.ANEWARRAY] + [CHECKCAST Opcodes.CHECKCAST] + ) + +(def: #export (NEWARRAY type) + (-> $;Primitive $;Inst) + (function [visitor] + (do-to visitor + (MethodVisitor.visitIntInsn [Opcodes.NEWARRAY (case type + #$;Boolean Opcodes.T_BOOLEAN + #$;Byte Opcodes.T_SHORT + #$;Short Opcodes.T_SHORT + #$;Int Opcodes.T_INT + #$;Long Opcodes.T_LONG + #$;Float Opcodes.T_FLOAT + #$;Double Opcodes.T_DOUBLE + #$;Char Opcodes.T_CHAR)])))) + +(do-template [<name> <inst>] + [(def: #export (<name> class method-name method-signature interface?) + (-> Text Text $;Method Bool $;Inst) + (function [visitor] + (do-to visitor + (MethodVisitor.visitMethodInsn [<inst> ($t;binary-name class) method-name ($t;method-descriptor method-signature) interface?]))))] + + [INVOKESTATIC Opcodes.INVOKESTATIC] + [INVOKEVIRTUAL Opcodes.INVOKEVIRTUAL] + ) + +(def: #export (array type size) + (-> $;Type Nat $;Inst) + (case type + (#$;Primitive prim) + (|>. (int (nat-to-int size)) + (NEWARRAY prim)) + + (#$;Generic generic) + (let [elem-class (case generic + (#$;Class class params) + ($t;binary-name class) + + _ + ($t;binary-name "java.lang.Object"))] + (|>. (int (nat-to-int size)) + (ANEWARRAY elem-class))) + + _ + (|>. (int (nat-to-int size)) + (ANEWARRAY ($t;descriptor type))))) + +(do-template [<wrap> <unwrap> <class> <unwrap-method> <prim>] + [(def: #export <wrap> + $;Inst + (|>. (INVOKESTATIC <class> "valueOf" + ($t;method (list <prim>) + (#;Some ($t;class <class> (list))) + (list)) + false))) + (def: #export <unwrap> + $;Inst + (|>. (CHECKCAST <class>) + (INVOKEVIRTUAL <class> <unwrap-method> + ($t;method (list) (#;Some <prim>) (list)) + false)))] + + [wrap-boolean unwrap-boolean "java.lang.Boolean" "booleanValue" $t;boolean] + [wrap-byte unwrap-byte "java.lang.Byte" "byteValue" $t;byte] + [wrap-short unwrap-short "java.lang.Short" "shortValue" $t;short] + [wrap-int unwrap-int "java.lang.Integer" "intValue" $t;int] + [wrap-long unwrap-long "java.lang.Long" "longValue" $t;long] + [wrap-float unwrap-float "java.lang.Float" "floatValue" $t;float] + [wrap-double unwrap-double "java.lang.Double" "doubleValue" $t;double] + [wrap-char unwrap-char "java.lang.Character" "charValue" $t;char] + ) + +(def: #export (fuse insts) + (-> (List $;Inst) $;Inst) + (case insts + #;Nil + id + + (#;Cons singleton #;Nil) + singleton + + (#;Cons head tail) + (. head (fuse tail)))) diff --git a/new-luxc/source/luxc/generator/host/jvm/type.lux b/new-luxc/source/luxc/generator/host/jvm/type.lux new file mode 100644 index 000000000..b457ac636 --- /dev/null +++ b/new-luxc/source/luxc/generator/host/jvm/type.lux @@ -0,0 +1,138 @@ +(;module: + lux + (lux (data [text] + text/format + (coll [list "L/" Functor<List>]))) + ["$" ..]) + +## Types +(do-template [<name> <primitive>] + [(def: #export <name> $;Type (#$;Primitive <primitive>))] + + [boolean #$;Boolean] + [byte #$;Byte] + [short #$;Short] + [int #$;Int] + [long #$;Long] + [float #$;Float] + [double #$;Double] + [char #$;Char] + ) + +(def: #export (class name params) + (-> Text (List $;Generic) $;Type) + (#$;Generic (#$;Class name params))) + +(def: #export (var name) + (-> Text $;Type) + (#$;Generic (#$;Var name))) + +(def: #export (wildcard bound) + (-> (Maybe [$;Bound $;Generic]) $;Type) + (#$;Generic (#$;Wildcard bound))) + +(def: #export (array depth elemT) + (-> Nat $;Type $;Type) + (case depth + +0 elemT + _ (#$;Array (array (n.dec depth) elemT)))) + +(def: #export (binary-name class) + (-> Text Text) + (text;replace-all "." "/" class)) + +(def: #export (descriptor type) + (-> $;Type Text) + (case type + (#$;Primitive prim) + (case prim + #$;Boolean "Z" + #$;Byte "B" + #$;Short "S" + #$;Int "I" + #$;Long "J" + #$;Float "F" + #$;Double "D" + #$;Char "C") + + (#$;Array sub) + (format "[" (descriptor sub)) + + (#$;Generic generic) + (case generic + (#$;Class class params) + (format "L" (binary-name class) ";") + + (^or (#$;Var name) (#$;Wildcard ?bound)) + (descriptor (#$;Generic (#$;Class "java.lang.Object" (list))))) + )) + +(def: #export (signature type) + (-> $;Type Text) + (case type + (#$;Primitive prim) + (case prim + #$;Boolean "Z" + #$;Byte "B" + #$;Short "S" + #$;Int "I" + #$;Long "J" + #$;Float "F" + #$;Double "D" + #$;Char "C") + + (#$;Array sub) + (format "[" (signature sub)) + + (#$;Generic generic) + (case generic + (#$;Class class params) + (let [=params (if (list;empty? params) + "" + (format "<" + (|> params + (L/map (|>. #$;Generic signature)) + (text;join-with "")) + ">"))] + (format "L" (binary-name class) =params ";")) + + (#$;Var name) + (format "T" name ";") + + (#$;Wildcard #;None) + "*" + + (^template [<tag> <prefix>] + (#$;Wildcard (#;Some [<tag> bound])) + (format <prefix> (signature (#$;Generic bound)))) + ([#$;Upper "+"] + [#$;Lower "-"])) + )) + +## Methods +(def: #export (method args return exceptions) + (-> (List $;Type) (Maybe $;Type) (List $;Generic) $;Method) + {#$;args args #$;return return #$;exceptions exceptions}) + +(def: #export (method-descriptor method) + (-> $;Method Text) + (format "(" (text;join-with "" (L/map descriptor (get@ #$;args method))) ")" + (case (get@ #$;return method) + #;None + "V" + + (#;Some return) + (descriptor return)))) + +(def: #export (method-signature method) + (-> $;Method Text) + (format "(" (|> (get@ #$;args method) (L/map signature) (text;join-with "")) ")" + (case (get@ #$;return method) + #;None + "V" + + (#;Some return) + (signature return)) + (|> (get@ #$;exceptions method) + (L/map (|>. #$;Generic signature (format "^"))) + (text;join-with "")))) |