diff options
author | Eduardo Julian | 2017-06-12 21:14:55 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-06-12 21:14:55 -0400 |
commit | 9cd2927a4f6175784e081d6b512d3e900c8069e7 (patch) | |
tree | d1fe512bc84ea1e3a50ad86eeb3265771edd23c6 /new-luxc/source | |
parent | c50667a431a5ca67328a230f0c59956dc6ff43fa (diff) |
- Renamed the "compilation" phase as the "generation" phase.
- Implemented compilation of primitives.
- Implemented compilation of structures.
Diffstat (limited to 'new-luxc/source')
-rw-r--r-- | new-luxc/source/luxc/base.lux | 8 | ||||
-rw-r--r-- | new-luxc/source/luxc/compiler/common.jvm.lux | 65 | ||||
-rw-r--r-- | new-luxc/source/luxc/compiler/expr.jvm.lux | 62 | ||||
-rw-r--r-- | new-luxc/source/luxc/compiler/runtime.jvm.lux | 11 | ||||
-rw-r--r-- | new-luxc/source/luxc/generator.lux (renamed from new-luxc/source/luxc/compiler.lux) | 70 | ||||
-rw-r--r-- | new-luxc/source/luxc/generator/base.jvm.lux (renamed from new-luxc/source/luxc/compiler/base.jvm.lux) | 0 | ||||
-rw-r--r-- | new-luxc/source/luxc/generator/common.jvm.lux | 130 | ||||
-rw-r--r-- | new-luxc/source/luxc/generator/eval.jvm.lux | 89 | ||||
-rw-r--r-- | new-luxc/source/luxc/generator/expr.jvm.lux | 55 | ||||
-rw-r--r-- | new-luxc/source/luxc/generator/primitive.jvm.lux | 44 | ||||
-rw-r--r-- | new-luxc/source/luxc/generator/runtime.jvm.lux | 126 | ||||
-rw-r--r-- | new-luxc/source/luxc/generator/statement.jvm.lux (renamed from new-luxc/source/luxc/compiler/statement.jvm.lux) | 0 | ||||
-rw-r--r-- | new-luxc/source/luxc/generator/structure.jvm.lux | 70 | ||||
-rw-r--r-- | new-luxc/source/luxc/host.jvm.lux | 86 |
14 files changed, 611 insertions, 205 deletions
diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux index abd154190..bf9368abe 100644 --- a/new-luxc/source/luxc/base.lux +++ b/new-luxc/source/luxc/base.lux @@ -22,6 +22,8 @@ #Eval #REPL) +(def: #export compiler-version Text "0.6.0") + (def: #export (fail message) (All [a] (-> Text (Lux a))) (do Monad<Lux> @@ -32,6 +34,12 @@ (macro;fail (format "@ " location "\n" message)))) +(def: #export (assert message test) + (-> Text Bool (Lux Unit)) + (if test + (:: Monad<Lux> wrap []) + (fail message))) + (def: #export (with-expected-type expected action) (All [a] (-> Type (Lux a) (Lux a))) (function [compiler] diff --git a/new-luxc/source/luxc/compiler/common.jvm.lux b/new-luxc/source/luxc/compiler/common.jvm.lux deleted file mode 100644 index bd5487ef6..000000000 --- a/new-luxc/source/luxc/compiler/common.jvm.lux +++ /dev/null @@ -1,65 +0,0 @@ -(;module: - lux - (lux (concurrency ["A" atom]) - (data ["R" result] - (coll ["D" dict])) - [macro] - [host #+ jvm-import])) - -## [Host] -(jvm-import org.objectweb.asm.MethodVisitor - (visitLdcInsn [Object] void)) - -(jvm-import java.lang.ClassLoader) - -## [Types] -(type: #export Compiled - Unit) - -(type: #export Blob host;Byte-Array) - -(type: #export Class-Store (A;Atom (D;Dict Text Blob))) - -(type: #export Host - {#visitor (Maybe MethodVisitor) - #loader ClassLoader - #store Class-Store}) - -(def: #export unit-value Text "\u0000unit\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])))) diff --git a/new-luxc/source/luxc/compiler/expr.jvm.lux b/new-luxc/source/luxc/compiler/expr.jvm.lux deleted file mode 100644 index b2e4923c4..000000000 --- a/new-luxc/source/luxc/compiler/expr.jvm.lux +++ /dev/null @@ -1,62 +0,0 @@ -(;module: - lux - (lux (control monad) - (data text/format) - [macro #+ Monad<Lux> "Lux/" Monad<Lux>] - [host #+ jvm-import]) - (luxc ["&" base] - (lang ["la" analysis] - ["ls" synthesis]) - ["&;" analyser] - ["&;" synthesizer] - (compiler ["&;" common]))) - -(jvm-import #long java.lang.Object) - -(jvm-import org.objectweb.asm.Opcodes) - -(jvm-import org.objectweb.asm.MethodVisitor - (visitLdcInsn [Object] void)) - -(def: unit-value Text "\u0000unit\u0000") - -(def: (compiler-literal value) - (-> Top (Lux &common;Compiled)) - (do Monad<Lux> - [visitor &common;get-visitor - #let [_ (MethodVisitor.visitLdcInsn [(:! java.lang.Object value)])]] - (wrap []))) - -(def: (compile-synthesis synthesis) - (-> ls;Synthesis (Lux &common;Compiled)) - (case synthesis - #ls;Unit - (compiler-literal &common;unit-value) - - (^template [<tag>] - (<tag> value) - (compiler-literal value)) - ([#ls;Bool] - [#ls;Nat] - [#ls;Int] - [#ls;Deg] - [#ls;Real] - [#ls;Char] - [#ls;Text]) - - _ - (macro;fail "Unrecognized synthesis."))) - -(def: (eval type code) - &;Eval - (undefined)) - -(def: analyse - &;Analyser - (&analyser;analyser eval)) - -(def: #export (compile input) - (-> Code (Lux &common;Compiled)) - (do Monad<Lux> - [analysis (analyse input)] - (compile-synthesis (&synthesizer;synthesize analysis)))) diff --git a/new-luxc/source/luxc/compiler/runtime.jvm.lux b/new-luxc/source/luxc/compiler/runtime.jvm.lux deleted file mode 100644 index 16e072194..000000000 --- a/new-luxc/source/luxc/compiler/runtime.jvm.lux +++ /dev/null @@ -1,11 +0,0 @@ -(;module: - lux - (lux (control monad) - (concurrency ["P" promise "P/" Monad<Promise>]) - (data text/format - ["R" result])) - (luxc ["&" base])) - -(def: #export (compile-runtime compiler) - (-> Compiler (P;Promise (R;Result Compiler))) - (P/wrap (#R;Success compiler))) diff --git a/new-luxc/source/luxc/compiler.lux b/new-luxc/source/luxc/generator.lux index 55fe3c738..d095023ff 100644 --- a/new-luxc/source/luxc/compiler.lux +++ b/new-luxc/source/luxc/generator.lux @@ -15,6 +15,7 @@ ["&;" io] ["&;" module] ["&;" parser] + ["&;" host] (compiler ["&&;" runtime] ["&&;" statement] ["&&;" common]) @@ -109,69 +110,6 @@ (jvm-import org.objectweb.asm.MethodVisitor) -(jvm-import java.lang.reflect.AccessibleObject - (setAccessible [boolean] void)) - -(jvm-import java.lang.reflect.Method - (invoke [Object (Array Object)] #try Object)) - -(jvm-import (java.lang.Class a) - (getDeclaredMethod [String (Array (Class Object))] #try Method)) - -(jvm-import java.lang.Object - (getClass [] (Class Object))) - -(jvm-import java.lang.Integer - (#static TYPE (Class Integer))) - -(jvm-import java.lang.ClassLoader) - -(def: ClassLoader::defineClass - Method - (case (Class.getDeclaredMethod ["defineClass" - (|> (array (Class Object) +4) - (array-store +0 (:! (Class Object) (class-for String))) - (array-store +1 (Object.getClass [] (array byte +0))) - (array-store +2 (:! (Class Object) Integer.TYPE)) - (array-store +3 (:! (Class Object) Integer.TYPE)))] - (class-for java.lang.ClassLoader)) - (#R;Success method) - (do-to method - (AccessibleObject.setAccessible [true])) - - (#R;Error error) - (error! error))) - -(def: (memory-class-loader store) - (-> &&common;Class-Store ClassLoader) - (object ClassLoader [] - [] - (ClassLoader (findClass [class-name String]) void - (case (|> store A;get io;run (D;get class-name)) - (#;Some bytecode) - (case (Method.invoke [(:! Object _jvm_this) - (array;from-list (list (:! Object class-name) - (:! Object bytecode) - (:! Object (l2i 0)) - (:! Object (l2i (nat-to-int (array-length bytecode))))))] - ClassLoader::defineClass) - (#R;Success output) - [] - - (#R;Error error) - (error! error)) - - _ - (error! (format "Unknown class: " class-name)))))) - -(def: (init-host _) - (-> 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;store store})) - (def: init-cursor Cursor ["" +0 +0]) (def: init-type-context @@ -180,11 +118,9 @@ #;var-counter +0 #;var-bindings (list)}) -(def: compiler-version Text "0.6.0") - (def: init-compiler-info Compiler-Info - {#;compiler-version compiler-version + {#;compiler-version &;compiler-version #;compiler-mode #;Build}) (def: (init-compiler host) @@ -214,7 +150,7 @@ (def: #export (compile-program program target sources) (-> &;Path &;Path (List &;Path) (P;Promise Unit)) (do P;Monad<Promise> - [#let [compiler (init-compiler (init-host []))] + [#let [compiler (init-compiler (&host;init-host []))] compiler (or-crash! (&&runtime;compile-runtime compiler)) compiler (or-crash! (compile-module sources prelude compiler)) compiler (or-crash! (compile-module sources program compiler)) diff --git a/new-luxc/source/luxc/compiler/base.jvm.lux b/new-luxc/source/luxc/generator/base.jvm.lux index 01a97aec4..01a97aec4 100644 --- a/new-luxc/source/luxc/compiler/base.jvm.lux +++ b/new-luxc/source/luxc/generator/base.jvm.lux diff --git a/new-luxc/source/luxc/generator/common.jvm.lux b/new-luxc/source/luxc/generator/common.jvm.lux new file mode 100644 index 000000000..e5d3552c4 --- /dev/null +++ b/new-luxc/source/luxc/generator/common.jvm.lux @@ -0,0 +1,130 @@ +(;module: + lux + (lux [io] + (concurrency ["A" atom]) + (data ["R" result] + (coll ["d" dict]) + text/format) + [macro #+ Monad<Lux>] + [host #+ jvm-import do-to])) + +## [Host] +(jvm-import org.objectweb.asm.Opcodes + (#static V1_6 int) + (#static CHECKCAST int) + (#static INVOKESTATIC int) + (#static INVOKEVIRTUAL 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.Class a)) + +(jvm-import java.lang.ClassLoader + (loadClass [String] (Class Object))) + +## [Types] +(type: #export Bytecode host;Byte-Array) + +(type: #export Class-Store (A;Atom (d;Dict Text Bytecode))) + +(type: #export Host + {#visitor (Maybe MethodVisitor) + #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] + (let [store (|> (get@ #;host compiler) + (:! Host) + (get@ #store))] + (if (d;contains? name (|> store A;get io;run)) + (#R;Error (format "Cannot store class that already exists: " name)) + (#R;Success [compiler (io;run (A;update (d;put name byte-code) store))]) + )))) + +(def: #export (load-class name) + (-> Text (Lux (Class Object))) + (function [compiler] + (let [host (:! Host (get@ #;host compiler)) + store (|> host (get@ #store) A;get io;run)] + (if (d;contains? name store) + (#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 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 new file mode 100644 index 000000000..5fcf0b288 --- /dev/null +++ b/new-luxc/source/luxc/generator/eval.jvm.lux @@ -0,0 +1,89 @@ +(;module: + lux + (lux (control monad) + (data ["R" result] + text/format) + [macro #+ Monad<Lux> "Lux/" Monad<Lux>] + [host #+ jvm-import do-to]) + (luxc ["&" base] + (lang ["la" analysis] + ["ls" synthesis]) + ["&;" analyser] + ["&;" synthesizer] + (generator ["&;" common]))) + +(jvm-import java.lang.Object) +(jvm-import java.lang.String) + +(jvm-import java.lang.reflect.Field + (get [Object] Object)) + +(jvm-import (java.lang.Class a) + (getField [String] Field)) + +(jvm-import org.objectweb.asm.Opcodes + (#static ACC_PUBLIC int) + (#static ACC_SUPER int) + (#static ACC_FINAL int) + (#static ACC_STATIC int) + (#static PUTSTATIC int) + (#static RETURN int) + (#static V1_6 int) + ) + +(jvm-import org.objectweb.asm.MethodVisitor + (visitCode [] void) + (visitEnd [] void) + (visitLdcInsn [Object] void) + (visitFieldInsn [int String String String] void) + (visitInsn [int] void) + (visitMaxs [int int] void)) + +(jvm-import org.objectweb.asm.FieldVisitor + (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)) + +(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: #export (eval generator) + (-> (Lux Unit) (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 [])) + 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]) + (Field.get (host;null)))))) diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux new file mode 100644 index 000000000..4b038378a --- /dev/null +++ b/new-luxc/source/luxc/generator/expr.jvm.lux @@ -0,0 +1,55 @@ +(;module: + lux + (lux (control monad) + (data text/format) + [macro #+ Monad<Lux> "Lux/" Monad<Lux>] + [host #+ jvm-import]) + (luxc ["&" base] + (lang ["la" analysis] + ["ls" synthesis]) + ["&;" analyser] + ["&;" synthesizer] + (generator ["&;" common] + ["&;" primitive] + ["&;" structure]))) + +(def: #export (generate synthesis) + (-> ls;Synthesis (Lux Unit)) + (case synthesis + #ls;Unit + &primitive;generate-unit + + (^template [<tag> <generator>] + (<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;Real &primitive;generate-real] + [#ls;Char &primitive;generate-char] + [#ls;Text &primitive;generate-text]) + + (#ls;Variant tag tail? member) + (&structure;generate-variant generate tag tail? member) + + (#ls;Tuple members) + (&structure;generate-tuple generate members) + + _ + (macro;fail "Unrecognized synthesis."))) + +## (def: (eval type code) +## &;Eval +## (undefined)) + +## (def: analyse +## &;Analyser +## (&analyser;analyser eval)) + +## (def: #export (generate input) +## (-> Code (Lux Unit)) +## (do Monad<Lux> +## [analysis (analyse input) +## #let [synthesis (&synthesizer;synthesize analysis)]] +## (generate-synthesis synthesis))) diff --git a/new-luxc/source/luxc/generator/primitive.jvm.lux b/new-luxc/source/luxc/generator/primitive.jvm.lux new file mode 100644 index 000000000..2c879dd48 --- /dev/null +++ b/new-luxc/source/luxc/generator/primitive.jvm.lux @@ -0,0 +1,44 @@ +(;module: + lux + (lux (control monad) + (data text/format) + [macro #+ Monad<Lux> "Lux/" Monad<Lux>] + [host #+ jvm-import]) + (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)) + +(def: #export generate-unit + (Lux Unit) + (do Monad<Lux> + [visitor &common;get-visitor + #let [_ (MethodVisitor.visitLdcInsn [(:! java.lang.Object &common;unit)] visitor)]] + (wrap []))) + +(do-template [<name> <type> <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 [])))] + + [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] + ) diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux new file mode 100644 index 000000000..e8831d005 --- /dev/null +++ b/new-luxc/source/luxc/generator/runtime.jvm.lux @@ -0,0 +1,126 @@ +(;module: + lux + (lux (control monad) + (data ["R" result] + text/format) + [macro #+ Monad<Lux> "Lux/" Monad<Lux>] + [host #+ jvm-import do-to]) + (luxc ["&" base] + (lang ["la" analysis] + ["ls" synthesis]) + ["&;" analyser] + ["&;" synthesizer] + (generator ["&;" common]))) + +(jvm-import java.lang.Object) +(jvm-import java.lang.String) + +(jvm-import java.lang.reflect.Field + (get [Object] #try Object)) + +(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)) + +(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: #export generate + (Lux &common;Bytecode) + (do Monad<Lux> + [_ (wrap []) + #let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS) + (ClassWriter.visit [&common;bytecode-version + ($_ i.+ Opcodes.ACC_PUBLIC Opcodes.ACC_FINAL Opcodes.ACC_SUPER) + &common;runtime-class-name (host;null) + "java/lang/Object" (host;null)])) + generate-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/compiler/statement.jvm.lux b/new-luxc/source/luxc/generator/statement.jvm.lux index 96263181f..96263181f 100644 --- a/new-luxc/source/luxc/compiler/statement.jvm.lux +++ b/new-luxc/source/luxc/generator/statement.jvm.lux diff --git a/new-luxc/source/luxc/generator/structure.jvm.lux b/new-luxc/source/luxc/generator/structure.jvm.lux new file mode 100644 index 000000000..1584cb170 --- /dev/null +++ b/new-luxc/source/luxc/generator/structure.jvm.lux @@ -0,0 +1,70 @@ +(;module: + lux + (lux (control monad) + (data text/format + (coll [list])) + [macro #+ Monad<Lux> "Lux/" Monad<Lux>] + [host #+ jvm-import do-to]) + (luxc ["&" base] + (lang ["la" analysis] + ["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)) + +(jvm-import org.objectweb.asm.MethodVisitor + (visitInsn [int] void) + (visitLdcInsn [Object] void) + (visitTypeInsn [int String] void) + (visitMethodInsn [int String String String boolean] void)) + +(def: #export (generate-tuple generate members) + (-> (-> ls;Synthesis (Lux Unit)) (List ls;Synthesis) (Lux Unit)) + (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 []))) + +(def: (generate-variant-flag tail? visitor) + (-> Bool MethodVisitor MethodVisitor) + (if tail? + (do-to visitor (MethodVisitor.visitLdcInsn [(:! java.lang.Object "")])) + (do-to visitor (MethodVisitor.visitInsn [Opcodes.ACONST_NULL])))) + +(def: #export (generate-variant generate tag tail? member) + (-> (-> ls;Synthesis (Lux Unit)) Nat Bool ls;Synthesis (Lux Unit)) + (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 []))) diff --git a/new-luxc/source/luxc/host.jvm.lux b/new-luxc/source/luxc/host.jvm.lux new file mode 100644 index 000000000..c46e1cf1f --- /dev/null +++ b/new-luxc/source/luxc/host.jvm.lux @@ -0,0 +1,86 @@ +(;module: + lux + (lux (control monad) + (concurrency ["A" atom]) + (data ["R" result] + [text] + text/format + (coll ["d" dict] + [array #+ Array])) + [macro #+ Monad<Lux>] + host + [io]) + (luxc ["&" base] + (generator ["&&;" common]) + )) + +(jvm-import java.lang.reflect.AccessibleObject + (setAccessible [boolean] void)) + +(jvm-import java.lang.reflect.Method + (invoke [Object (Array Object)] #try Object)) + +(jvm-import (java.lang.Class a) + (getDeclaredMethod [String (Array (Class Object))] #try Method)) + +(jvm-import java.lang.Object + (getClass [] (Class Object))) + +(jvm-import java.lang.Integer + (#static TYPE (Class Integer))) + +(jvm-import java.lang.ClassLoader) + +(def: ClassLoader::defineClass + Method + (case (Class.getDeclaredMethod ["defineClass" + (|> (array (Class Object) +4) + (array-store +0 (:! (Class Object) (class-for String))) + (array-store +1 (Object.getClass [] (array byte +0))) + (array-store +2 (:! (Class Object) Integer.TYPE)) + (array-store +3 (:! (Class Object) Integer.TYPE)))] + (class-for java.lang.ClassLoader)) + (#R;Success method) + (do-to method + (AccessibleObject.setAccessible [true])) + + (#R;Error error) + (error! error))) + +(def: (define-class class-name byte-code loader) + (-> Text &&common;Bytecode ClassLoader (R;Result Object)) + (Method.invoke [loader + (array;from-list (list (:! Object class-name) + (:! Object byte-code) + (:! Object (l2i 0)) + (:! Object (l2i (nat-to-int (array-length byte-code))))))] + ClassLoader::defineClass)) + +(def: (fetch-byte-code class-name store) + (-> Text &&common;Class-Store &&common;Bytecode) + (|> store A;get io;run (d;get class-name) assume)) + +(def: (assume!! input) + (All [a] (-> (R;Result a) a)) + (case input + (#R;Success output) + output + + (#R;Error error) + (error! error))) + +(def: (memory-class-loader store) + (-> &&common;Class-Store ClassLoader) + (object ClassLoader [] + [] + (ClassLoader (findClass [class-name String]) Class + (:!! (assume!! (define-class class-name (fetch-byte-code class-name store) (:! ClassLoader _jvm_this)))) + ))) + +(def: #export (init-host _) + (-> 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;store store})) |