aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2017-06-14 17:56:24 -0400
committerEduardo Julian2017-06-14 17:56:24 -0400
commitc7e53036704b1a89b740c023c7b4bcc74b7e956a (patch)
treefa75c05b4233e654c17edd4de2d2b0b6fb3cece9
parent9cd2927a4f6175784e081d6b512d3e900c8069e7 (diff)
- Heavy refactoring.
-rw-r--r--new-luxc/source/luxc/generator/base.jvm.lux29
-rw-r--r--new-luxc/source/luxc/generator/common.jvm.lux87
-rw-r--r--new-luxc/source/luxc/generator/eval.jvm.lux55
-rw-r--r--new-luxc/source/luxc/generator/expr.jvm.lux30
-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
-rw-r--r--new-luxc/source/luxc/generator/primitive.jvm.lux45
-rw-r--r--new-luxc/source/luxc/generator/runtime.jvm.lux103
-rw-r--r--new-luxc/source/luxc/generator/structure.jvm.lux80
-rw-r--r--new-luxc/source/luxc/host.jvm.lux3
-rw-r--r--new-luxc/test/test/luxc/synthesizer/loop.lux2
13 files changed, 662 insertions, 308 deletions
diff --git a/new-luxc/source/luxc/generator/base.jvm.lux b/new-luxc/source/luxc/generator/base.jvm.lux
deleted file mode 100644
index 01a97aec4..000000000
--- a/new-luxc/source/luxc/generator/base.jvm.lux
+++ /dev/null
@@ -1,29 +0,0 @@
-(;module:
- lux
- (lux (control monad)
- [io #- run]
- (concurrency ["A" atom])
- (data [text]
- text/format)
- host)
- (luxc ["&" base]))
-
-(jvm-import java.lang.Class)
-(jvm-import java.lang.ClassLoader)
-(jvm-import org.objectweb.asm.MethodVisitor)
-
-(type: Blob Byte-Array)
-
-(type: JVM-State
- {#visitor (Maybe MethodVisitor)
- #loader ClassLoader
- #store (A;Atom (D;Dict Text Blob))
- })
-
-(def: host-state
- JVM-State
- (let [store (A;new (D;new text;Hash<Text>))]
- {#visitor #;None
- #loader (memory-class-loader store)
- #store store
- }))
diff --git a/new-luxc/source/luxc/generator/common.jvm.lux b/new-luxc/source/luxc/generator/common.jvm.lux
index e5d3552c4..2c943c5e5 100644
--- a/new-luxc/source/luxc/generator/common.jvm.lux
+++ b/new-luxc/source/luxc/generator/common.jvm.lux
@@ -5,23 +5,13 @@
(data ["R" result]
(coll ["d" dict])
text/format)
- [macro #+ Monad<Lux>]
- [host #+ jvm-import do-to]))
+ [host #+ jvm-import]))
## [Host]
(jvm-import org.objectweb.asm.Opcodes
- (#static V1_6 int)
- (#static CHECKCAST int)
- (#static INVOKESTATIC int)
- (#static INVOKEVIRTUAL int))
+ (#static V1_6 int))
-(jvm-import org.objectweb.asm.MethodVisitor
- (visitLdcInsn [Object] void)
- (visitTypeInsn [int String] void)
- (visitMethodInsn [int String String String boolean] void))
-
-(jvm-import java.lang.Object
- (toString [] String))
+(jvm-import java.lang.Object)
(jvm-import (java.lang.Class a))
@@ -34,49 +24,11 @@
(type: #export Class-Store (A;Atom (d;Dict Text Bytecode)))
(type: #export Host
- {#visitor (Maybe MethodVisitor)
- #loader ClassLoader
+ {#loader ClassLoader
#store Class-Store})
(def: #export unit Text "\u0000")
-(def: (visitor::get compiler)
- (-> Compiler (Maybe MethodVisitor))
- (|> (get@ #;host compiler)
- (:! Host)
- (get@ #visitor)))
-
-(def: (visitor::put ?visitor compiler)
- (-> (Maybe MethodVisitor) Compiler Compiler)
- (update@ #;host
- (function [host]
- (|> host
- (:! Host)
- (set@ #visitor ?visitor)
- (:! Void)))
- compiler))
-
-(def: #export get-visitor
- (Lux MethodVisitor)
- (function [compiler]
- (case (visitor::get compiler)
- #;None
- (#R;Error "No visitor has been set.")
-
- (#;Some visitor)
- (#R;Success [compiler visitor]))))
-
-(def: #export (with-visitor visitor body)
- (All [a] (-> MethodVisitor (Lux a) (Lux a)))
- (function [compiler]
- (case (macro;run' (visitor::put (#;Some visitor) compiler) body)
- (#R;Error error)
- (#R;Error error)
-
- (#R;Success [compiler' output])
- (#R;Success [(visitor::put (visitor::get compiler) compiler')
- output]))))
-
(def: #export (store-class name byte-code)
(-> Text Bytecode (Lux Unit))
(function [compiler]
@@ -97,34 +49,5 @@
(#R;Success [compiler (ClassLoader.loadClass [name] (get@ #loader host))])
(#R;Error (format "Unknown class: " name))))))
-
-(do-template [<wrap> <unwrap> <class> <unwrap-method> <prim> <dup>]
- [(def: #export (<wrap> writer)
- (-> MethodVisitor MethodVisitor)
- (do-to writer
- (MethodVisitor.visitMethodInsn [Opcodes.INVOKESTATIC
- <class> "valueOf" (format "(" <prim> ")" "L" <class> ";")
- false])))
- (def: #export (<unwrap> writer)
- (-> MethodVisitor MethodVisitor)
- (do-to writer
- (MethodVisitor.visitTypeInsn [Opcodes.CHECKCAST <class>])
- (MethodVisitor.visitMethodInsn [Opcodes.INVOKEVIRTUAL
- <class> <unwrap-method> (format "()" <prim>)
- false])))]
-
- [wrap-boolean unwrap-boolean "java/lang/Boolean" "booleanValue" "Z" Opcodes.DUP_X1]
- [wrap-byte unwrap-byte "java/lang/Byte" "byteValue" "B" Opcodes.DUP_X1]
- [wrap-short unwrap-short "java/lang/Short" "shortValue" "S" Opcodes.DUP_X1]
- [wrap-int unwrap-int "java/lang/Integer" "intValue" "I" Opcodes.DUP_X1]
- [wrap-long unwrap-long "java/lang/Long" "longValue" "J" Opcodes.DUP_X2]
- [wrap-float unwrap-float "java/lang/Float" "floatValue" "F" Opcodes.DUP_X1]
- [wrap-double unwrap-double "java/lang/Double" "doubleValue" "D" Opcodes.DUP_X2]
- [wrap-char unwrap-char "java/lang/Character" "charValue" "C" Opcodes.DUP_X1]
- )
-
-(type: #export Flags Int)
-(type: #export Descriptor Text)
-
-(def: #export bytecode-version Flags Opcodes.V1_6)
+(def: #export bytecode-version Int Opcodes.V1_6)
(def: #export runtime-class-name Text "LuxRT")
diff --git a/new-luxc/source/luxc/generator/eval.jvm.lux b/new-luxc/source/luxc/generator/eval.jvm.lux
index 5fcf0b288..e7567f1fa 100644
--- a/new-luxc/source/luxc/generator/eval.jvm.lux
+++ b/new-luxc/source/luxc/generator/eval.jvm.lux
@@ -10,7 +10,12 @@
["ls" synthesis])
["&;" analyser]
["&;" synthesizer]
- (generator ["&;" common])))
+ (generator ["&;" common]
+ (host ["$" jvm]
+ (jvm ["$t" type]
+ ["$d" def]
+ ["$i" inst])))
+ ))
(jvm-import java.lang.Object)
(jvm-import java.lang.String)
@@ -51,39 +56,33 @@
(visitMethod [int String String String (Array String)] MethodVisitor)
(toByteArray [] Byte-Array))
-(def: (make-field flags name descriptor writer)
- (-> &common;Flags Text &common;Descriptor ClassWriter FieldVisitor)
- (do-to (ClassWriter.visitField [flags name descriptor (host;null) (host;null)] writer)
- (FieldVisitor.visitEnd [])))
-
-(def: eval-field-name Text "_value")
-(def: eval-field-desc Text "Ljava/lang/Object;")
+(def: eval-field Text "_value")
+(def: $Object $;Type ($t;class "java.lang.Object" (list)))
(def: #export (eval generator)
- (-> (Lux Unit) (Lux Top))
+ (-> (Lux $;Inst) (Lux Top))
(do Monad<Lux>
[class-name (:: @ map %code (macro;gensym "eval"))
- #let [writer (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS)
- (ClassWriter.visit [&common;bytecode-version
- (i.+ Opcodes.ACC_PUBLIC Opcodes.ACC_SUPER)
- class-name
- (host;null)
- "java/lang/Object"
- (host;null)]))
- value-field (make-field ($_ i.+ Opcodes.ACC_PUBLIC Opcodes.ACC_STATIC Opcodes.ACC_FINAL)
- eval-field-name eval-field-desc
- writer)
- visitor (do-to (ClassWriter.visitMethod [Opcodes.ACC_STATIC "<clinit>" "()V" (host;null) (host;null)] writer)
- (MethodVisitor.visitCode []))]
- _ (&common;with-visitor visitor generator)
- #let [_ (do-to visitor
- (MethodVisitor.visitFieldInsn [Opcodes.PUTSTATIC class-name eval-field-name eval-field-desc])
- (MethodVisitor.visitInsn [Opcodes.RETURN])
- (MethodVisitor.visitMaxs [0 0])
- (MethodVisitor.visitEnd []))
+ valueI generator
+ #let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS)
+ (ClassWriter.visit [&common;bytecode-version
+ (i.+ Opcodes.ACC_PUBLIC Opcodes.ACC_SUPER)
+ class-name
+ (host;null)
+ "java/lang/Object"
+ (host;null)]))
+ ($d;field #$;Public {#$;staticF true #$;finalF true #$;transientF false #$;volatileF false}
+ eval-field $Object)
+ ($d;method #$;Public
+ {#$;staticM true #$;finalM false #$;synchronizedM false}
+ "<clinit>"
+ ($t;method (list) #;None (list))
+ (|>. valueI
+ ($i;PUTSTATIC class-name eval-field $Object)
+ $i;RETURN)))
bytecode (ClassWriter.toByteArray [] (do-to writer (ClassWriter.visitEnd [])))]
_ (&common;store-class class-name bytecode)
class (&common;load-class class-name)]
(wrap (|> class
- (Class.getField [eval-field-name])
+ (Class.getField [eval-field])
(Field.get (host;null))))))
diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux
index 4b038378a..7a99ecc18 100644
--- a/new-luxc/source/luxc/generator/expr.jvm.lux
+++ b/new-luxc/source/luxc/generator/expr.jvm.lux
@@ -1,20 +1,19 @@
(;module:
lux
(lux (control monad)
- (data text/format)
- [macro #+ Monad<Lux> "Lux/" Monad<Lux>]
- [host #+ jvm-import])
+ [macro #+ Monad<Lux> "Lux/" Monad<Lux>])
(luxc ["&" base]
- (lang ["la" analysis]
- ["ls" synthesis])
+ (lang ["ls" synthesis])
["&;" analyser]
["&;" synthesizer]
(generator ["&;" common]
["&;" primitive]
- ["&;" structure])))
+ ["&;" structure]
+ ["&;" eval]
+ (host ["$" jvm]))))
(def: #export (generate synthesis)
- (-> ls;Synthesis (Lux Unit))
+ (-> ls;Synthesis (Lux $;Inst))
(case synthesis
#ls;Unit
&primitive;generate-unit
@@ -23,9 +22,9 @@
(<tag> value)
(<generator> value))
([#ls;Bool &primitive;generate-bool]
- [#ls;Nat &primitive;generate-nat]
- [#ls;Int &primitive;generate-int]
- [#ls;Deg &primitive;generate-deg]
+ [#ls;Nat &primitive;generate-nat]
+ [#ls;Int &primitive;generate-int]
+ [#ls;Deg &primitive;generate-deg]
[#ls;Real &primitive;generate-real]
[#ls;Char &primitive;generate-char]
[#ls;Text &primitive;generate-text])
@@ -39,9 +38,14 @@
_
(macro;fail "Unrecognized synthesis.")))
-## (def: (eval type code)
-## &;Eval
-## (undefined))
+## (def: #export (eval type code)
+## (-> Type Code (Lux Top))
+## (do Monad<Lux>
+## [analysis (&;with-expected-type leftT
+## (&analyser;analyser eval code))
+## #let [synthesis (&synthesizer;synthesize analysis)]
+## inst (generate synthesis)]
+## (&eval;eval inst)))
## (def: analyse
## &;Analyser
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 ""))))
diff --git a/new-luxc/source/luxc/generator/primitive.jvm.lux b/new-luxc/source/luxc/generator/primitive.jvm.lux
index 2c879dd48..18ce2e24a 100644
--- a/new-luxc/source/luxc/generator/primitive.jvm.lux
+++ b/new-luxc/source/luxc/generator/primitive.jvm.lux
@@ -2,43 +2,30 @@
lux
(lux (control monad)
(data text/format)
- [macro #+ Monad<Lux> "Lux/" Monad<Lux>]
- [host #+ jvm-import])
+ [macro #+ Monad<Lux> "Lux/" Monad<Lux>])
(luxc ["&" base]
(lang ["la" analysis]
["ls" synthesis])
["&;" analyser]
["&;" synthesizer]
- (generator ["&;" common])))
-
-(jvm-import #long java.lang.Object)
-
-(jvm-import org.objectweb.asm.Opcodes)
-
-(jvm-import org.objectweb.asm.MethodVisitor
- (visitLdcInsn [Object] void))
+ (generator ["&;" common]
+ (host ["$" jvm]
+ (jvm ["$i" inst])))))
(def: #export generate-unit
- (Lux Unit)
- (do Monad<Lux>
- [visitor &common;get-visitor
- #let [_ (MethodVisitor.visitLdcInsn [(:! java.lang.Object &common;unit)] visitor)]]
- (wrap [])))
+ (Lux $;Inst)
+ (Lux/wrap ($i;string &common;unit)))
-(do-template [<name> <type> <wrap>]
+(do-template [<name> <type> <load> <wrap>]
[(def: #export (<name> value)
- (-> <type> (Lux Unit))
- (do Monad<Lux>
- [visitor &common;get-visitor
- #let [_ (MethodVisitor.visitLdcInsn [(:! java.lang.Object value)] visitor)
- _ (<wrap> visitor)]]
- (wrap [])))]
+ (-> <type> (Lux $;Inst))
+ (Lux/wrap (|>. (<load> value) <wrap>)))]
- [generate-bool Bool &common;wrap-boolean]
- [generate-nat Nat &common;wrap-long]
- [generate-int Int &common;wrap-long]
- [generate-deg Deg &common;wrap-long]
- [generate-real Real &common;wrap-double]
- [generate-char Char &common;wrap-char]
- [generate-text Text id]
+ [generate-bool Bool $i;boolean $i;wrap-boolean]
+ [generate-nat Nat (|>. (:! Int) $i;long) $i;wrap-long]
+ [generate-int Int $i;long $i;wrap-long]
+ [generate-deg Deg (|>. (:! Int) $i;long) $i;wrap-long]
+ [generate-real Real $i;double $i;wrap-double]
+ [generate-char Char $i;char $i;wrap-char]
+ [generate-text Text $i;string id]
)
diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux
index e8831d005..5c6ce29a6 100644
--- a/new-luxc/source/luxc/generator/runtime.jvm.lux
+++ b/new-luxc/source/luxc/generator/runtime.jvm.lux
@@ -10,7 +10,11 @@
["ls" synthesis])
["&;" analyser]
["&;" synthesizer]
- (generator ["&;" common])))
+ (generator ["&;" common]
+ (host ["$" jvm]
+ (jvm ["$t" type]
+ ["$d" def]
+ ["$i" inst])))))
(jvm-import java.lang.Object)
(jvm-import java.lang.String)
@@ -21,95 +25,38 @@
(jvm-import (java.lang.Class a)
(getField [String] Field))
-(type: Flags Int)
-(type: Descriptor Text)
-
(jvm-import org.objectweb.asm.Opcodes
(#static ACC_PUBLIC int)
(#static ACC_SUPER int)
(#static ACC_FINAL int)
(#static ACC_STATIC int)
- (#static DUP int)
- (#static PUTSTATIC int)
- (#static ILOAD int)
- (#static ALOAD int)
- (#static ANEWARRAY int)
- (#static AASTORE int)
- (#static RETURN int)
- (#static ARETURN int)
- (#static V1_6 int)
- )
-
-(jvm-import org.objectweb.asm.MethodVisitor
- (visitCode [] void)
- (visitEnd [] void)
- (visitInsn [int] void)
- (visitLdcInsn [Object] void)
- (visitFieldInsn [int String String String] void)
- (visitVarInsn [int int] void)
- (visitTypeInsn [int String] void)
- (visitMaxs [int int] void))
-
-(jvm-import org.objectweb.asm.FieldVisitor
- (visitEnd [] void))
+ (#static V1_6 int))
(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))
-(def: (generate-adt-methods writer)
- (-> ClassWriter ClassWriter)
- (let [## I commented-out some parts because a null-check was
- ## done to ensure variants were never created with null
- ## values (this would interfere later with
- ## pattern-matching).
- ## Since Lux itself does not have null values as part of
- ## the language, the burden of ensuring non-nulls was
- ## shifted to library code dealing with host-interop, to
- ## ensure variant-making was as fast as possible.
- ## The null-checking code was left as comments in case I
- ## ever change my mind.
- _ (let [## $is-null (new Label)
- visitor (ClassWriter.visitMethod [(i.+ Opcodes.ACC_PUBLIC Opcodes.ACC_STATIC)
- "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"
- (host;null) (host;null)]
- writer)
- _ (do-to visitor
- (MethodVisitor.visitCode [])
- ## (MethodVisitor.visitVarInsn [Opcodes.ALOAD 2])
- ## (MethodVisitor.visitJumpInsn [Opcodes.IFNULL $is-null])
- (MethodVisitor.visitLdcInsn [(host;l2i 3)])
- (MethodVisitor.visitTypeInsn [Opcodes.ANEWARRAY "java/lang/Object"])
- (MethodVisitor.visitInsn [Opcodes.DUP])
- (MethodVisitor.visitLdcInsn [(host;l2i 0)])
- (MethodVisitor.visitVarInsn [Opcodes.ILOAD 0]))
- _ (&common;wrap-int visitor)
- _ (do-to visitor
- (MethodVisitor.visitInsn [Opcodes.AASTORE])
- (MethodVisitor.visitInsn [Opcodes.DUP])
- (MethodVisitor.visitLdcInsn [(host;l2i 1)])
- (MethodVisitor.visitVarInsn [Opcodes.ALOAD 1])
- (MethodVisitor.visitInsn [Opcodes.AASTORE])
- (MethodVisitor.visitInsn [Opcodes.DUP])
- (MethodVisitor.visitLdcInsn [(host;l2i 2)])
- (MethodVisitor.visitVarInsn [Opcodes.ALOAD 2])
- (MethodVisitor.visitInsn [Opcodes.AASTORE])
- (MethodVisitor.visitInsn [Opcodes.ARETURN])
- ## (MethodVisitor.visitLabel [$is-null])
- ## (MethodVisitor.visitTypeInsn [Opcodes.NEW "java/lang/IllegalStateException"])
- ## (MethodVisitor.visitInsn [Opcodes.DUP])
- ## (MethodVisitor.visitLdcInsn ["Cannot create variant for null pointer"])
- ## (MethodVisitor.visitMethodInsn [Opcodes.INVOKESPECIAL "java/lang/IllegalStateException" "<init>" "(Ljava/lang/String;)V"])
- ## (MethodVisitor.visitInsn [Opcodes.ATHROW])
- (MethodVisitor.visitMaxs [0 0])
- (MethodVisitor.visitEnd []))]
- [])]
- writer))
+(def: $Object $;Type ($t;class "java.lang.Object" (list)))
+
+(def: add-adt-methods
+ $;Def
+ (let [store-tag (|>. $i;DUP ($i;int 0) ($i;ILOAD +0) $i;wrap-int $i;AASTORE)
+ store-flag (|>. $i;DUP ($i;int 1) ($i;ALOAD +1) $i;AASTORE)
+ store-value (|>. $i;DUP ($i;int 2) ($i;ALOAD +2) $i;AASTORE)]
+ (|>. ($d;method #$;Public
+ {#$;staticM true #$;finalM false #$;synchronizedM false}
+ "sum_make"
+ ($t;method (list $t;int $Object $Object)
+ (#;Some ($t;array +1 $Object))
+ (list))
+ (|>. ($i;array $Object +3)
+ store-tag
+ store-flag
+ store-value
+ $i;ARETURN)))))
(def: #export generate
(Lux &common;Bytecode)
@@ -120,7 +67,7 @@
($_ i.+ Opcodes.ACC_PUBLIC Opcodes.ACC_FINAL Opcodes.ACC_SUPER)
&common;runtime-class-name (host;null)
"java/lang/Object" (host;null)]))
- generate-adt-methods)
+ add-adt-methods)
bytecode (ClassWriter.toByteArray [] (do-to writer (ClassWriter.visitEnd [])))]
_ (&common;store-class &common;runtime-class-name bytecode)]
(wrap bytecode)))
diff --git a/new-luxc/source/luxc/generator/structure.jvm.lux b/new-luxc/source/luxc/generator/structure.jvm.lux
index 1584cb170..74e44d1ca 100644
--- a/new-luxc/source/luxc/generator/structure.jvm.lux
+++ b/new-luxc/source/luxc/generator/structure.jvm.lux
@@ -1,3 +1,4 @@
+
(;module:
lux
(lux (control monad)
@@ -10,61 +11,48 @@
["ls" synthesis])
["&;" analyser]
["&;" synthesizer]
- (generator ["&;" common])))
-
-(jvm-import #long java.lang.Object)
-
-(jvm-import org.objectweb.asm.Opcodes
- (#static ANEWARRAY int)
- (#static DUP int)
- (#static AASTORE int)
- (#static ACONST_NULL int)
- (#static INVOKESTATIC int))
+ (generator ["&;" common]
+ (host ["$" jvm]
+ (jvm ["$t" type]
+ ["$d" def]
+ ["$i" inst])))))
-(jvm-import org.objectweb.asm.MethodVisitor
- (visitInsn [int] void)
- (visitLdcInsn [Object] void)
- (visitTypeInsn [int String] void)
- (visitMethodInsn [int String String String boolean] void))
+(def: $Object $;Type ($t;class "java.lang.Object" (list)))
(def: #export (generate-tuple generate members)
- (-> (-> ls;Synthesis (Lux Unit)) (List ls;Synthesis) (Lux Unit))
+ (-> (-> ls;Synthesis (Lux $;Inst)) (List ls;Synthesis) (Lux $;Inst))
(do Monad<Lux>
[#let [size (list;size members)]
_ (&;assert "Cannot generate tuples with less than 2 elements."
(n.>= +2 size))
- visitor &common;get-visitor
- #let [_ (do-to visitor
- (MethodVisitor.visitLdcInsn [(|> size nat-to-int host;l2i (:! java.lang.Object))])
- (MethodVisitor.visitTypeInsn [Opcodes.ANEWARRAY "java/lang/Object"]))]
- _ (mapM @ (function [[idx member]]
- (do @
- [#let [_ (do-to visitor
- (MethodVisitor.visitInsn [Opcodes.DUP])
- (MethodVisitor.visitLdcInsn [(|> idx nat-to-int host;l2i (:! java.lang.Object))]))]
- _ (generate member)
- #let [_ (MethodVisitor.visitInsn [Opcodes.AASTORE] visitor)]]
- (wrap [])))
- (list;enumerate members))]
- (wrap [])))
+ membersI (|> members
+ list;enumerate
+ (mapM @ (function [[idx member]]
+ (do @
+ [memberI (generate member)]
+ (wrap (|>. $i;DUP
+ ($i;int (nat-to-int idx))
+ memberI
+ $i;AASTORE)))))
+ (:: @ map $i;fuse))]
+ (wrap (|>. ($i;array $Object size) membersI))))
-(def: (generate-variant-flag tail? visitor)
- (-> Bool MethodVisitor MethodVisitor)
+(def: (flagI tail?)
+ (-> Bool $;Inst)
(if tail?
- (do-to visitor (MethodVisitor.visitLdcInsn [(:! java.lang.Object "")]))
- (do-to visitor (MethodVisitor.visitInsn [Opcodes.ACONST_NULL]))))
+ ($i;string "")
+ $i;NULL))
(def: #export (generate-variant generate tag tail? member)
- (-> (-> ls;Synthesis (Lux Unit)) Nat Bool ls;Synthesis (Lux Unit))
+ (-> (-> ls;Synthesis (Lux $;Inst)) Nat Bool ls;Synthesis (Lux $;Inst))
(do Monad<Lux>
- [visitor &common;get-visitor
- #let [_ (do-to visitor
- (MethodVisitor.visitLdcInsn [(|> tag nat-to-int host;l2i (:! java.lang.Object))]))
- _ (generate-variant-flag tail? visitor)]
- _ (generate member)
- #let [_ (do-to visitor
- (MethodVisitor.visitMethodInsn [Opcodes.INVOKESTATIC
- &common;runtime-class-name
- "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"
- false]))]]
- (wrap [])))
+ [memberI (generate member)]
+ (wrap (|>. ($i;int (nat-to-int tag))
+ (flagI tail?)
+ memberI
+ ($i;INVOKESTATIC &common;runtime-class-name
+ "sum_make"
+ ($t;method (list $t;int $Object $Object)
+ (#;Some ($t;array +1 $Object))
+ (list))
+ false)))))
diff --git a/new-luxc/source/luxc/host.jvm.lux b/new-luxc/source/luxc/host.jvm.lux
index c46e1cf1f..37b62b30d 100644
--- a/new-luxc/source/luxc/host.jvm.lux
+++ b/new-luxc/source/luxc/host.jvm.lux
@@ -81,6 +81,5 @@
(-> Top &&common;Host)
(let [store (: &&common;Class-Store
(A;atom (d;new text;Hash<Text>)))]
- {#&&common;visitor #;None
- #&&common;loader (memory-class-loader store)
+ {#&&common;loader (memory-class-loader store)
#&&common;store store}))
diff --git a/new-luxc/test/test/luxc/synthesizer/loop.lux b/new-luxc/test/test/luxc/synthesizer/loop.lux
index b89e09659..07f2b8a13 100644
--- a/new-luxc/test/test/luxc/synthesizer/loop.lux
+++ b/new-luxc/test/test/luxc/synthesizer/loop.lux
@@ -128,7 +128,7 @@
[plus-or-minus? r;bool
how-much (|> r;nat (:: @ map (|>. (n.% arity) (n.max +1))))
#let [shift (if plus-or-minus? n.+ n.-)]]
- (wrap (make-apply selfA (list;repeat (shift how-much arity) argA)))))
+ (wrap (make-apply selfA (list;repeat (shift how-much arity) #la;Unit)))))
bodyS (gen-body arity outputS)]
(wrap [(and recur? (not self-ref?))
arity