diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/source/luxc/generator/base.jvm.lux | 29 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/common.jvm.lux | 87 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/eval.jvm.lux | 55 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/expr.jvm.lux | 30 | ||||
| -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 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/primitive.jvm.lux | 45 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/runtime.jvm.lux | 103 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/structure.jvm.lux | 80 | ||||
| -rw-r--r-- | new-luxc/source/luxc/host.jvm.lux | 3 |
12 files changed, 661 insertions, 307 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})) |