aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/generator/host
diff options
context:
space:
mode:
authorEduardo Julian2017-06-14 17:56:24 -0400
committerEduardo Julian2017-06-14 17:56:24 -0400
commitc7e53036704b1a89b740c023c7b4bcc74b7e956a (patch)
treefa75c05b4233e654c17edd4de2d2b0b6fb3cece9 /new-luxc/source/luxc/generator/host
parent9cd2927a4f6175784e081d6b512d3e900c8069e7 (diff)
- Heavy refactoring.
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/generator/host/jvm.lux61
-rw-r--r--new-luxc/source/luxc/generator/host/jvm/def.lux142
-rw-r--r--new-luxc/source/luxc/generator/host/jvm/inst.lux195
-rw-r--r--new-luxc/source/luxc/generator/host/jvm/type.lux138
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 ""))))