From 8b4f0ded7bddaa42cf432f74523bfd6aa1e76fed Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 18 Jul 2018 23:44:29 -0400 Subject: WIP: Fix new-luxc's JVM back-end. --- new-luxc/source/luxc/lang/host.jvm.lux | 188 ------------ new-luxc/source/luxc/lang/host/jvm.lux | 51 +++- new-luxc/source/luxc/lang/host/jvm/def.lux | 26 +- new-luxc/source/luxc/lang/host/jvm/inst.lux | 110 +++---- new-luxc/source/luxc/lang/host/jvm/type.lux | 14 +- new-luxc/source/luxc/lang/translation/jvm.lux | 202 +++++++++++++ .../source/luxc/lang/translation/jvm/case.jvm.lux | 336 +++++++++++---------- .../luxc/lang/translation/jvm/common.jvm.lux | 207 +++++-------- .../luxc/lang/translation/jvm/expression.jvm.lux | 115 +++---- .../luxc/lang/translation/jvm/primitive.jvm.lux | 46 +-- .../luxc/lang/translation/jvm/reference.jvm.lux | 78 ++--- .../luxc/lang/translation/jvm/runtime.jvm.lux | 227 +++++++------- .../luxc/lang/translation/jvm/structure.jvm.lux | 62 ++-- 13 files changed, 819 insertions(+), 843 deletions(-) delete mode 100644 new-luxc/source/luxc/lang/host.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm.lux (limited to 'new-luxc/source/luxc') diff --git a/new-luxc/source/luxc/lang/host.jvm.lux b/new-luxc/source/luxc/lang/host.jvm.lux deleted file mode 100644 index b207fdad7..000000000 --- a/new-luxc/source/luxc/lang/host.jvm.lux +++ /dev/null @@ -1,188 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - pipe) - (concurrency [atom #+ Atom atom]) - (data ["e" error] - [text] - text/format - (coll (dictionary ["dict" unordered]) - [array])) - [macro] - [host #+ do-to object] - [io] - ["//" lang] - (lang ["//." reference #+ Register])) - (luxc [lang] - (lang (translation (jvm [".T" common]))))) - -(host.import: org/objectweb/asm/Label) - -(host.import: java/lang/reflect/AccessibleObject - (setAccessible [boolean] void)) - -(host.import: java/lang/reflect/Method - (invoke [Object (Array Object)] #try Object)) - -(host.import: (java/lang/Class a) - (getDeclaredMethod [String (Array (Class Object))] #try Method)) - -(host.import: java/lang/Object - (getClass [] (Class Object))) - -(host.import: java/lang/Integer - (#static TYPE (Class Integer))) - -(host.import: java/lang/ClassLoader) - -(def: ClassLoader::defineClass - Method - (case (Class::getDeclaredMethod ["defineClass" - (|> (host.array (Class Object) +4) - (host.array-write +0 (:coerce (Class Object) (host.class-for String))) - (host.array-write +1 (Object::getClass [] (host.array byte +0))) - (host.array-write +2 (:coerce (Class Object) Integer::TYPE)) - (host.array-write +3 (:coerce (Class Object) Integer::TYPE)))] - (host.class-for java/lang/ClassLoader)) - (#e.Success method) - (do-to method - (AccessibleObject::setAccessible [#1])) - - (#e.Error error) - (error! error))) - -(def: (define-class class-name byte-code loader) - (-> Text commonT.Bytecode ClassLoader (e.Error Object)) - (Method::invoke [loader - (array.from-list (list (:coerce Object class-name) - (:coerce Object byte-code) - (:coerce Object (host.long-to-int 0)) - (:coerce Object (host.long-to-int (.int (host.array-length byte-code))))))] - ClassLoader::defineClass)) - -(def: (fetch-byte-code class-name store) - (-> Text commonT.Class-Store (Maybe commonT.Bytecode)) - (|> store atom.read io.run (dict.get class-name))) - -(def: (memory-class-loader store) - (-> commonT.Class-Store ClassLoader) - (object [] ClassLoader [] - [] - (ClassLoader (findClass [class-name String]) Class - (case (fetch-byte-code class-name store) - (#.Some bytecode) - (case (define-class class-name bytecode (:coerce ClassLoader _jvm_this)) - (#e.Success class) - (:assume class) - - (#e.Error error) - (error! (format "Class definition error: " class-name "\n" - error))) - - #.None - (error! (format "Class not found: " class-name)))))) - -(def: #export init-host - (io.IO commonT.Host) - (io.io (let [store (: commonT.Class-Store - (atom (dict.new text.Hash)))] - {#commonT.loader (memory-class-loader store) - #commonT.store store - #commonT.artifacts (dict.new text.Hash) - #commonT.context ["" +0] - #commonT.anchor #.None}))) - -(def: #export (with-anchor anchor expr) - (All [a] (-> [Label Register] (Meta a) (Meta a))) - (.function (_ compiler) - (let [old (:coerce commonT.Host (get@ #.host compiler))] - (case (expr (set@ #.host - (:coerce Nothing (set@ #commonT.anchor (#.Some anchor) old)) - compiler)) - (#e.Success [compiler' output]) - (#e.Success [(update@ #.host - (|>> (:coerce commonT.Host) - (set@ #commonT.anchor (get@ #commonT.anchor old)) - (:coerce Nothing)) - compiler') - output]) - - (#e.Error error) - (#e.Error error))))) - -(exception: #export (No-Anchor {message Text}) - message) - -(def: #export anchor - (Meta [Label Register]) - (.function (_ compiler) - (case (|> compiler (get@ #.host) (:coerce commonT.Host) (get@ #commonT.anchor)) - (#.Some anchor) - (#e.Success [compiler - anchor]) - - #.None - ((//.throw No-Anchor "") compiler)))) - -(def: #export (with-context name expr) - (All [a] (-> Text (Meta a) (Meta a))) - (.function (_ compiler) - (let [old (:coerce commonT.Host (get@ #.host compiler))] - (case (expr (set@ #.host - (:coerce Nothing (set@ #commonT.context [(lang.normalize-name name) +0] old)) - compiler)) - (#e.Success [compiler' output]) - (#e.Success [(update@ #.host - (|>> (:coerce commonT.Host) - (set@ #commonT.context (get@ #commonT.context old)) - (:coerce Nothing)) - compiler') - output]) - - (#e.Error error) - (#e.Error error))))) - -(def: #export (with-sub-context expr) - (All [a] (-> (Meta a) (Meta [Text a]))) - (.function (_ compiler) - (let [old (:coerce commonT.Host (get@ #.host compiler)) - [old-name old-sub] (get@ #commonT.context old) - new-name (format old-name "$" (%i (.int old-sub)))] - (case (expr (set@ #.host - (:coerce Nothing (set@ #commonT.context [new-name +0] old)) - compiler)) - (#e.Success [compiler' output]) - (#e.Success [(update@ #.host - (|>> (:coerce commonT.Host) - (set@ #commonT.context [old-name (inc old-sub)]) - (:coerce Nothing)) - compiler') - [new-name output]]) - - (#e.Error error) - (#e.Error error))))) - -(def: #export context - (Meta Text) - (.function (_ compiler) - (#e.Success [compiler - (|> (get@ #.host compiler) - (:coerce commonT.Host) - (get@ #commonT.context) - (let> [name sub] - name))]))) - -(def: #export class-loader - (Meta ClassLoader) - (function (_ compiler) - (#e.Success [compiler - (|> compiler - (get@ #.host) - (:coerce commonT.Host) - (get@ #commonT.loader))]))) - -(def: #export runtime-class Text "LuxRuntime") -(def: #export function-class Text "LuxFunction") -(def: #export runnable-class Text "LuxRunnable") -(def: #export unit Text "") diff --git a/new-luxc/source/luxc/lang/host/jvm.lux b/new-luxc/source/luxc/lang/host/jvm.lux index adb24b8c0..bbfc5e136 100644 --- a/new-luxc/source/luxc/lang/host/jvm.lux +++ b/new-luxc/source/luxc/lang/host/jvm.lux @@ -1,19 +1,28 @@ (.module: - [lux #- Type] - (lux (control monad - ["p" parser]) - (data (coll [list "list/" Functor])) - [macro] - (macro [code] - ["s" syntax #+ syntax:]) - [host])) + [lux (#- Type Definition) + [control + monad + ["p" parser]] + [data + [collection + [list ("list/" Functor)]]] + [macro + [code] + ["s" syntax (#+ syntax:)]] + [host (#+ import:)] + [world + [blob (#+ Blob)]] + [language + [reference (#+ Register)] + [compiler + ["." translation]]]]) ## [Host] -(host.import: org/objectweb/asm/MethodVisitor) +(import: org/objectweb/asm/MethodVisitor) -(host.import: org/objectweb/asm/ClassWriter) +(import: org/objectweb/asm/ClassWriter) -(host.import: #long org/objectweb/asm/Label +(import: #long org/objectweb/asm/Label (new [])) ## [Type] @@ -61,8 +70,6 @@ (type: #export Label org/objectweb/asm/Label) -(type: #export Register Nat) - (type: #export Visibility #Public #Protected @@ -79,6 +86,24 @@ #V1_7 #V1_8) +(type: #export ByteCode Blob) + +(type: #export Definition [Text ByteCode]) + +(type: #export Anchor [Label Register]) + +(type: #export Host + (translation.Host Inst Definition)) + +(type: #export State + (translation.State ..Anchor Inst Definition)) + +(type: #export Operation + (translation.Operation ..Anchor Inst Definition)) + +(type: #export Compiler + (translation.Compiler ..Anchor Inst Definition)) + ## [Values] (syntax: (config: {type s.local-symbol} {none s.local-symbol} diff --git a/new-luxc/source/luxc/lang/host/jvm/def.lux b/new-luxc/source/luxc/lang/host/jvm/def.lux index 4c19f38f6..3d3f8d80d 100644 --- a/new-luxc/source/luxc/lang/host/jvm/def.lux +++ b/new-luxc/source/luxc/lang/host/jvm/def.lux @@ -1,16 +1,17 @@ (.module: - lux - (lux (data [text] - text/format - [product] - (coll ["a" array] - [list "list/" Functor])) - [host #+ do-to] - [function]) - ["$" //] - (// ["$t" type])) - -## [Host] + [lux #* + [data + ["." text + format] + ["." product] + [collection + ["a" array] + [list ("list/" Functor)]]] + [host (#+ do-to)] + [function]] + ["$" // + ["$t" type]]) + (host.import: #long java/lang/Object) (host.import: #long java/lang/String) @@ -59,7 +60,6 @@ (visitMethod [int String String String (Array String)] MethodVisitor) (toByteArray [] (Array byte))) -## [Defs] (def: (string-array values) (-> (List Text) (Array Text)) (let [output (host.array String (list.size values))] diff --git a/new-luxc/source/luxc/lang/host/jvm/inst.lux b/new-luxc/source/luxc/lang/host/jvm/inst.lux index 393200a28..9426fabe3 100644 --- a/new-luxc/source/luxc/lang/host/jvm/inst.lux +++ b/new-luxc/source/luxc/lang/host/jvm/inst.lux @@ -1,29 +1,35 @@ (.module: - [lux #- int char] - (lux (control monad - ["p" parser]) - (data [maybe] - ["e" error] - text/format - (coll [list "list/" Functor])) - [host #+ do-to] - [macro] - (macro [code] - ["s" syntax #+ syntax:]) - [function]) - [//] - [//type]) + [lux (#- int char) + [control + [monad (#+ do)] + ["p" parser]] + [data + ["." maybe] + ["." error] + [text + format] + [collection + ["." list ("list/" Functor)]]] + [host (#+ import: do-to)] + [macro + ["." code] + ["s" syntax (#+ syntax:)]] + [function] + [language + [compiler (#+ Operation)]]] + ["." // (#+ Primitive Inst) + ["." type]]) ## [Host] -(host.import: #long java/lang/Object) -(host.import: #long java/lang/String) +(import: #long java/lang/Object) +(import: #long java/lang/String) (syntax: (declare {codes (p.many s.local-symbol)}) (|> codes (list/map (function (_ code) (` ((~' #static) (~ (code.local-symbol code)) (~' int))))) wrap)) -(`` (host.import: org/objectweb/asm/Opcodes +(`` (import: org/objectweb/asm/Opcodes (#static NOP int) ## Conversion @@ -90,10 +96,10 @@ (~~ (declare RETURN IRETURN LRETURN DRETURN ARETURN)) )) -(host.import: org/objectweb/asm/Label +(import: org/objectweb/asm/Label (new [])) -(host.import: org/objectweb/asm/MethodVisitor +(import: org/objectweb/asm/MethodVisitor (visitCode [] void) (visitMaxs [int int] void) (visitEnd [] void) @@ -112,17 +118,17 @@ ## [Insts] (def: #export make-label - (Meta Label) - (function (_ compiler) - (#e.Success [compiler (Label::new [])]))) + (All [s] (Operation s Label)) + (function (_ state) + (#error.Success [state (Label::new [])]))) (def: #export (with-label action) - (-> (-> Label //.Inst) //.Inst) + (-> (-> Label Inst) Inst) (action (Label::new []))) (do-template [ ] [(def: #export ( value) - (-> //.Inst) + (-> Inst) (function (_ visitor) (do-to visitor (MethodVisitor::visitLdcInsn [( value)]))))] @@ -139,14 +145,14 @@ (wrap (list (code.local-symbol (format "Opcodes::" base))))) (def: #export NULL - //.Inst + Inst (function (_ visitor) (do-to visitor (MethodVisitor::visitInsn [(prefix ACONST_NULL)])))) (do-template [] [(def: #export - //.Inst + Inst (function (_ visitor) (do-to visitor (MethodVisitor::visitInsn [(prefix )]))))] @@ -207,7 +213,7 @@ (do-template [] [(def: #export ( register) - (-> Nat //.Inst) + (-> Nat Inst) (function (_ visitor) (do-to visitor (MethodVisitor::visitVarInsn [(prefix ) (.int register)]))))] @@ -218,10 +224,10 @@ (do-template [ ] [(def: #export ( class field type) - (-> Text Text //.Type //.Inst) + (-> Text Text //.Type Inst) (function (_ visitor) (do-to visitor - (MethodVisitor::visitFieldInsn [ (//type.binary-name class) field (//type.descriptor type)]))))] + (MethodVisitor::visitFieldInsn [ (type.binary-name class) field (type.descriptor type)]))))] [GETSTATIC Opcodes::GETSTATIC] [PUTSTATIC Opcodes::PUTSTATIC] @@ -232,10 +238,10 @@ (do-template [ ] [(def: #export ( class) - (-> Text //.Inst) + (-> Text Inst) (function (_ visitor) (do-to visitor - (MethodVisitor::visitTypeInsn [ (//type.binary-name class)]))))] + (MethodVisitor::visitTypeInsn [ (type.binary-name class)]))))] [CHECKCAST Opcodes::CHECKCAST] [NEW Opcodes::NEW] @@ -244,7 +250,7 @@ ) (def: #export (NEWARRAY type) - (-> //.Primitive //.Inst) + (-> Primitive Inst) (function (_ visitor) (do-to visitor (MethodVisitor::visitIntInsn [Opcodes::NEWARRAY (case type @@ -259,10 +265,10 @@ (do-template [ ] [(def: #export ( class method-name method-signature interface?) - (-> Text Text //.Method Bit //.Inst) + (-> Text Text //.Method Bit Inst) (function (_ visitor) (do-to visitor - (MethodVisitor::visitMethodInsn [ (//type.binary-name class) method-name (//type.method-descriptor method-signature) interface?]))))] + (MethodVisitor::visitMethodInsn [ (type.binary-name class) method-name (type.method-descriptor method-signature) interface?]))))] [INVOKESTATIC Opcodes::INVOKESTATIC] [INVOKEVIRTUAL Opcodes::INVOKEVIRTUAL] @@ -272,7 +278,7 @@ (do-template [] [(def: #export ( @where) - (-> //.Label //.Inst) + (-> //.Label Inst) (function (_ visitor) (do-to visitor (MethodVisitor::visitJumpInsn [(prefix ) @where]))))] @@ -283,7 +289,7 @@ ) (def: #export (TABLESWITCH min max default labels) - (-> Int Int //.Label (List //.Label) //.Inst) + (-> Int Int //.Label (List //.Label) Inst) (function (_ visitor) (let [num-labels (list.size labels) labels-array (host.array Label num-labels) @@ -298,19 +304,19 @@ (MethodVisitor::visitTableSwitchInsn [min max default labels-array]))))) (def: #export (try @from @to @handler exception) - (-> //.Label //.Label //.Label Text //.Inst) + (-> //.Label //.Label //.Label Text Inst) (function (_ visitor) (do-to visitor - (MethodVisitor::visitTryCatchBlock [@from @to @handler (//type.binary-name exception)])))) + (MethodVisitor::visitTryCatchBlock [@from @to @handler (type.binary-name exception)])))) (def: #export (label @label) - (-> //.Label //.Inst) + (-> //.Label Inst) (function (_ visitor) (do-to visitor (MethodVisitor::visitLabel [@label])))) (def: #export (array type) - (-> //.Type //.Inst) + (-> //.Type Inst) (case type (#//.Primitive prim) (NEWARRAY prim) @@ -318,17 +324,17 @@ (#//.Generic generic) (let [elem-class (case generic (#//.Class class params) - (//type.binary-name class) + (type.binary-name class) _ - (//type.binary-name "java.lang.Object"))] + (type.binary-name "java.lang.Object"))] (ANEWARRAY elem-class)) _ - (ANEWARRAY (//type.descriptor type)))) + (ANEWARRAY (type.descriptor type)))) (def: (primitive-wrapper type) - (-> //.Primitive Text) + (-> Primitive Text) (case type #//.Boolean "java.lang.Boolean" #//.Byte "java.lang.Byte" @@ -340,7 +346,7 @@ #//.Char "java.lang.Character")) (def: (primitive-unwrap type) - (-> //.Primitive Text) + (-> Primitive Text) (case type #//.Boolean "booleanValue" #//.Byte "byteValue" @@ -352,24 +358,24 @@ #//.Char "charValue")) (def: #export (wrap type) - (-> //.Primitive //.Inst) + (-> Primitive Inst) (let [class (primitive-wrapper type)] (|>> (INVOKESTATIC class "valueOf" - (//type.method (list (#//.Primitive type)) - (#.Some (//type.class class (list))) - (list)) + (type.method (list (#//.Primitive type)) + (#.Some (type.class class (list))) + (list)) #0)))) (def: #export (unwrap type) - (-> //.Primitive //.Inst) + (-> Primitive Inst) (let [class (primitive-wrapper type)] (|>> (CHECKCAST class) (INVOKEVIRTUAL class (primitive-unwrap type) - (//type.method (list) (#.Some (#//.Primitive type)) (list)) + (type.method (list) (#.Some (#//.Primitive type)) (list)) #0)))) (def: #export (fuse insts) - (-> (List //.Inst) //.Inst) + (-> (List Inst) Inst) (case insts #.Nil id diff --git a/new-luxc/source/luxc/lang/host/jvm/type.lux b/new-luxc/source/luxc/lang/host/jvm/type.lux index 0c36e6799..f9a956b86 100644 --- a/new-luxc/source/luxc/lang/host/jvm/type.lux +++ b/new-luxc/source/luxc/lang/host/jvm/type.lux @@ -1,8 +1,10 @@ (.module: - [lux #- int char] - (lux (data [text] - text/format - (coll [list "list/" Functor]))) + [lux (#- int char) + [data + ["." text + format] + [collection + [list ("list/" Functor)]]]] [//]) ## Types @@ -37,9 +39,9 @@ +0 elemT _ (#//.Array (array (dec depth) elemT)))) -(def: #export (binary-name class) +(def: #export binary-name (-> Text Text) - (text.replace-all "." "/" class)) + (text.replace-all "." "/")) (def: #export (descriptor type) (-> //.Type Text) diff --git a/new-luxc/source/luxc/lang/translation/jvm.lux b/new-luxc/source/luxc/lang/translation/jvm.lux new file mode 100644 index 000000000..152def2f5 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm.lux @@ -0,0 +1,202 @@ +(.module: + [lux (#- Definition) + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)] + pipe] + [concurrency + ["." atom (#+ Atom atom)]] + [data + ["." error (#+ Error)] + ["." text + format] + [collection + ["." array] + ["." dictionary (#+ Dictionary)]]] + [host (#+ import: do-to object)] + ["." io (#+ IO io)] + [world + [blob (#+ Blob)]] + [language + ["." name] + [compiler + ["." translation]]]] + [/// + [host + ["." jvm (#+ Inst Definition Host State) + ["." type] + ["." def] + ["." inst]]]] + ) + +(import: org/objectweb/asm/Label) + +(import: java/lang/reflect/AccessibleObject + (setAccessible [boolean] void)) + +(import: java/lang/reflect/Field + (get [#? Object] #try #? Object)) + +(import: java/lang/reflect/Method + (invoke [Object (Array Object)] #try Object)) + +(import: (java/lang/Class a) + (getField [String] #try Field) + (getDeclaredMethod [String (Array (Class Object))] #try Method)) + +(import: java/lang/Object + (getClass [] (Class Object))) + +(import: java/lang/Integer + (#static TYPE (Class Integer))) + +(import: java/lang/ClassLoader + (loadClass [String] #try (Class Object))) + +(def: ClassLoader::defineClass + Method + (case (Class::getDeclaredMethod ["defineClass" + (|> (host.array (Class Object) +4) + (host.array-write +0 (:coerce (Class Object) (host.class-for String))) + (host.array-write +1 (Object::getClass [] (host.array byte +0))) + (host.array-write +2 (:coerce (Class Object) Integer::TYPE)) + (host.array-write +3 (:coerce (Class Object) Integer::TYPE)))] + (host.class-for java/lang/ClassLoader)) + (#error.Success method) + (do-to method + (AccessibleObject::setAccessible [#1])) + + (#error.Error error) + (error! error))) + +(type: #export ByteCode Blob) + +(def: (define-class class-name bytecode loader) + (-> Text ByteCode ClassLoader (Error Object)) + (Method::invoke [loader + (array.from-list (list (:coerce Object class-name) + (:coerce Object bytecode) + (:coerce Object (host.long-to-int 0)) + (:coerce Object (host.long-to-int (.int (host.array-length bytecode))))))] + ClassLoader::defineClass)) + +(type: Store (Atom (Dictionary Text ByteCode))) + +(def: (fetch-bytecode class-name store) + (-> Text Store (Maybe ByteCode)) + (|> store atom.read io.run (dictionary.get class-name))) + +(do-template [] + [(exception: #export ( {class Text}) + (ex.report ["Class" class]))] + + [unknown-class] + [class-already-stored] + ) + +(exception: #export (cannot-define-class {class Text} {error Text}) + (ex.report ["Class" class] + ["Error" error])) + +(def: (memory-class-loader store) + (-> Store ClassLoader) + (object [] ClassLoader [] + [] + (ClassLoader (findClass [class-name String]) Class + (case (fetch-bytecode class-name store) + (#.Some bytecode) + (case (define-class class-name bytecode (:coerce ClassLoader _jvm_this)) + (#error.Success class) + (:assume class) + + (#error.Error error) + (error! (ex.construct cannot-define-class [class-name error]))) + + #.None + (error! (ex.construct unknown-class class-name)))))) + +(def: (store! name bytecode store) + (-> Text ByteCode Store (Error Any)) + (if (dictionary.contains? name (|> store atom.read io.run)) + (ex.throw class-already-stored name) + (exec (io.run (atom.update (dictionary.put name bytecode) store)) + (#error.Success [])))) + +(def: (load! name loader) + (-> Text ClassLoader (Error (Class Object))) + (ClassLoader::loadClass [name] loader)) + +(def: #export value-field Text "_value") +(def: #export $Object jvm.Type (type.class "java.lang.Object" (list))) + +(exception: #export (cannot-load {class Text} {error Text}) + (ex.report ["Class" class] + ["Error" error])) + +(exception: #export (invalid-field {class Text} {field Text}) + (ex.report ["Class" class] + ["Field" field])) + +(exception: #export (invalid-value {class Text}) + (ex.report ["Class" class])) + +(def: (class-value class-name class) + (-> Text (Class Object) (Error Any)) + (case (Class::getField [..value-field] class) + (#error.Success field) + (case (Field::get [#.None] field) + (#error.Success ?value) + (case ?value + (#.Some value) + (#error.Success value) + + #.None + (ex.throw invalid-value class-name)) + + (#error.Error error) + (ex.throw cannot-load [class-name error])) + + (#error.Error error) + (ex.throw invalid-field [class-name ..value-field]))) + +(def: (eval store loader valueI) + (-> Store ClassLoader Inst (Error Any)) + (do error.Monad + [#let [eval-class "eval" + bytecode (def.class #jvm.V1_6 + #jvm.Public jvm.noneC + eval-class + (list) ["java.lang.Object" (list)] + (list) + (|>> (def.field #jvm.Public ($_ jvm.++F jvm.finalF jvm.staticF) + ..value-field ..$Object) + (def.method #jvm.Public ($_ jvm.++M jvm.staticM jvm.strictM) + "" + (type.method (list) #.None (list)) + (|>> valueI + (inst.PUTSTATIC eval-class ..value-field ..$Object) + inst.RETURN))))] + _ (..store! eval-class bytecode store) + class (..load! eval-class loader)] + (class-value eval-class class))) + +(def: (define store loader [class-name class-bytecode]) + (-> Store ClassLoader Definition (Error Any)) + (do error.Monad + [_ (..store! class-name class-bytecode store) + class (..load! class-name loader)] + (class-value class-name class))) + +(def: #export init + (IO State) + (io (let [store (: Store (atom (dictionary.new text.Hash))) + loader (memory-class-loader store)] + (translation.init (: Host + (structure + (def: evaluate! (..eval store loader)) + (def: execute! (..define store loader)))))))) + +(def: #export runtime-class "LuxRuntime") +(def: #export function-class "LuxFunction") +(def: #export runnable-class "LuxRunnable") +(def: #export unit "") diff --git a/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux index e47e123ad..2aa0586ab 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux @@ -1,22 +1,26 @@ (.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data text/format) - [macro "macro/" Monad]) - (luxc ["_" lang] - (lang [".L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$i" inst])) - ["ls" synthesis])) - [//runtime]) - -(def: $Object $.Type ($t.class "java.lang.Object" (list))) + [lux (#- if let case) + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + [text + format]] + [language + ["." compiler ("operation/" Monad) + ["." synthesis (#+ Path Synthesis)]]]] + [luxc + [lang + [host + ["$" jvm (#+ Label Inst Operation Compiler) + ["$t" type] + ["$i" inst]]]]] + ["." // (#+ $Object) + [runtime]]) (def: (pop-altI stack-depth) - (-> Nat $.Inst) - (case stack-depth + (-> Nat Inst) + (.case stack-depth +0 id +1 $i.POP +2 $i.POP2 @@ -25,203 +29,201 @@ (pop-altI (n/- +2 stack-depth))))) (def: peekI - $.Inst + Inst (|>> $i.DUP - ($i.INVOKESTATIC hostL.runtime-class + ($i.INVOKESTATIC //.runtime-class "pm_peek" - ($t.method (list //runtime.$Stack) + ($t.method (list runtime.$Stack) (#.Some $Object) (list)) #0))) (def: popI - $.Inst - (|>> ($i.INVOKESTATIC hostL.runtime-class + Inst + (|>> ($i.INVOKESTATIC //.runtime-class "pm_pop" - ($t.method (list //runtime.$Stack) - (#.Some //runtime.$Stack) + ($t.method (list runtime.$Stack) + (#.Some runtime.$Stack) (list)) #0))) (def: pushI - $.Inst - (|>> ($i.INVOKESTATIC hostL.runtime-class + Inst + (|>> ($i.INVOKESTATIC //.runtime-class "pm_push" - ($t.method (list //runtime.$Stack $Object) - (#.Some //runtime.$Stack) + ($t.method (list runtime.$Stack $Object) + (#.Some runtime.$Stack) (list)) #0))) -(exception: #export (Unrecognized-Path {message Text}) - message) +(def: (path' translate stack-depth @else @end path) + (-> (-> Synthesis (Operation Inst)) + Nat Label Label Path (Operation Inst)) + (.case path + #synthesis.Pop + (operation/wrap popI) + + (#synthesis.Bind register) + (operation/wrap (|>> peekI + ($i.ASTORE register))) -(def: (translate-path' translate stack-depth @else @end path) - (-> (-> ls.Synthesis (Meta $.Inst)) - Nat $.Label $.Label ls.Path (Meta $.Inst)) - (case path - (^ [_ (#.Form (list [_ (#.Text "lux case exec")] bodyS))]) - (do macro.Monad + (^ (synthesis.path/bit value)) + (operation/wrap (.let [jumpI (.if value $i.IFEQ $i.IFNE)] + (|>> peekI + ($i.unwrap #$.Boolean) + (jumpI @else)))) + + (^ (synthesis.path/i64 value)) + (operation/wrap (|>> peekI + ($i.unwrap #$.Long) + ($i.long value) + $i.LCMP + ($i.IFNE @else))) + + (^ (synthesis.path/f64 value)) + (operation/wrap (|>> peekI + ($i.unwrap #$.Double) + ($i.double value) + $i.DCMPL + ($i.IFNE @else))) + + (^ (synthesis.path/text value)) + (operation/wrap (|>> peekI + ($i.string value) + ($i.INVOKEVIRTUAL "java.lang.Object" + "equals" + ($t.method (list $Object) + (#.Some $t.boolean) + (list)) + #0) + ($i.IFEQ @else))) + + (#synthesis.Then bodyS) + (do compiler.Monad [bodyI (translate bodyS)] (wrap (|>> (pop-altI stack-depth) bodyI ($i.GOTO @end)))) - - (^ [_ (#.Form (list [_ (#.Text "lux case pop")]))]) - (macro/wrap popI) - - (^ [_ (#.Form (list [_ (#.Text "lux case bind")] [_ (#.Nat register)]))]) - (macro/wrap (|>> peekI - ($i.ASTORE register))) - - [_ (#.Bit value)] - (macro/wrap (let [jumpI (if value $i.IFEQ $i.IFNE)] - (|>> peekI - ($i.unwrap #$.Boolean) - (jumpI @else)))) - - [_ (#.Int value)] - (macro/wrap (|>> peekI - ($i.unwrap #$.Long) - ($i.long value) - $i.LCMP - ($i.IFNE @else))) - - [_ (#.Frac value)] - (macro/wrap (|>> peekI - ($i.unwrap #$.Double) - ($i.double value) - $i.DCMPL - ($i.IFNE @else))) - [_ (#.Text value)] - (macro/wrap (|>> peekI - ($i.string value) - ($i.INVOKEVIRTUAL "java.lang.Object" - "equals" - ($t.method (list $Object) - (#.Some $t.boolean) - (list)) - #0) - ($i.IFEQ @else))) - - (^template [ ] - (^ [_ (#.Form (list [_ (#.Text )] [_ (#.Nat idx)]))]) - (macro/wrap (case idx - +0 - (|>> peekI - ($i.CHECKCAST ($t.descriptor //runtime.$Tuple)) - ($i.int 0) - $i.AALOAD - pushI) - - _ - (|>> peekI - ($i.CHECKCAST ($t.descriptor //runtime.$Tuple)) - ($i.int (.int idx)) - ($i.INVOKESTATIC hostL.runtime-class - - ($t.method (list //runtime.$Tuple $t.int) - (#.Some $Object) - (list)) - #0) - pushI)))) - (["lux case tuple left" "pm_left"] - ["lux case tuple right" "pm_right"]) - - (^template [ ] - (^ [_ (#.Form (list [_ (#.Text )] [_ (#.Nat idx)]))]) - (macro/wrap (<| $i.with-label (function (_ @success)) - $i.with-label (function (_ @fail)) - (|>> peekI - ($i.CHECKCAST ($t.descriptor //runtime.$Variant)) - ($i.int (.int idx)) - - ($i.INVOKESTATIC hostL.runtime-class "pm_variant" - ($t.method (list //runtime.$Variant //runtime.$Tag //runtime.$Flag) - (#.Some //runtime.$Datum) - (list)) - #0) - $i.DUP - ($i.IFNULL @fail) - ($i.GOTO @success) - ($i.label @fail) - $i.POP - ($i.GOTO @else) - ($i.label @success) - pushI)))) - (["lux case variant left" $i.NULL] - ["lux case variant right" ($i.string "")]) - (^ [_ (#.Form (list [_ (#.Text "lux case seq")] leftP rightP))]) - (do macro.Monad - [leftI (translate-path' translate stack-depth @else @end leftP) - rightI (translate-path' translate stack-depth @else @end rightP)] - (wrap (|>> leftI - rightI))) - - (^ [_ (#.Form (list [_ (#.Text "lux case alt")] leftP rightP))]) - (do macro.Monad + (^template [ ] + (^ ( idx)) + (operation/wrap (.case ( idx) + +0 + (|>> peekI + ($i.CHECKCAST ($t.descriptor runtime.$Tuple)) + ($i.int 0) + $i.AALOAD + pushI) + + idx + (|>> peekI + ($i.CHECKCAST ($t.descriptor runtime.$Tuple)) + ($i.int (.int idx)) + ($i.INVOKESTATIC //.runtime-class + + ($t.method (list runtime.$Tuple $t.int) + (#.Some $Object) + (list)) + #0) + pushI)))) + ([synthesis.member/left "pm_left" .id] + [synthesis.member/right "pm_right" .inc]) + + (^template [ ] + (^ ( idx)) + (.let [idx ( idx)] + (operation/wrap (<| $i.with-label (function (_ @success)) + $i.with-label (function (_ @fail)) + (|>> peekI + ($i.CHECKCAST ($t.descriptor runtime.$Variant)) + ($i.int (.int idx)) + + ($i.INVOKESTATIC //.runtime-class "pm_variant" + ($t.method (list runtime.$Variant runtime.$Tag runtime.$Flag) + (#.Some runtime.$Datum) + (list)) + #0) + $i.DUP + ($i.IFNULL @fail) + ($i.GOTO @success) + ($i.label @fail) + $i.POP + ($i.GOTO @else) + ($i.label @success) + pushI))))) + ([synthesis.side/left $i.NULL .id] + [synthesis.side/right ($i.string "") .inc]) + + (#synthesis.Alt leftP rightP) + (do compiler.Monad [@alt-else $i.make-label - leftI (translate-path' translate (inc stack-depth) @alt-else @end leftP) - rightI (translate-path' translate stack-depth @else @end rightP)] + leftI (path' translate (inc stack-depth) @alt-else @end leftP) + rightI (path' translate stack-depth @else @end rightP)] (wrap (|>> $i.DUP leftI ($i.label @alt-else) $i.POP rightI))) + + (#synthesis.Seq leftP rightP) + (do compiler.Monad + [leftI (path' translate stack-depth @else @end leftP) + rightI (path' translate stack-depth @else @end rightP)] + (wrap (|>> leftI + rightI))) + )) - _ - (_.throw Unrecognized-Path (%code path)))) - -(def: (translate-path translate path @end) - (-> (-> ls.Synthesis (Meta $.Inst)) - ls.Path $.Label (Meta $.Inst)) - (do macro.Monad +(def: (path translate path @end) + (-> Compiler Path Label (Operation Inst)) + (do compiler.Monad [@else $i.make-label - pathI (translate-path' translate +1 @else @end path)] + pathI (..path' translate +1 @else @end path)] (wrap (|>> pathI ($i.label @else) $i.POP - ($i.INVOKESTATIC hostL.runtime-class + ($i.INVOKESTATIC //.runtime-class "pm_fail" ($t.method (list) #.None (list)) #0) $i.NULL ($i.GOTO @end))))) -(def: #export (translate-if testI thenI elseI) - (-> $.Inst $.Inst $.Inst $.Inst) - (<| $i.with-label (function (_ @else)) - $i.with-label (function (_ @end)) - (|>> testI - ($i.unwrap #$.Boolean) - ($i.IFEQ @else) - thenI - ($i.GOTO @end) - ($i.label @else) - elseI - ($i.label @end)))) +(def: #export (if translate testS thenS elseS) + (-> Compiler Synthesis Synthesis Synthesis (Operation Inst)) + (do compiler.Monad + [testI (translate testS) + thenI (translate thenS) + elseI (translate elseS)] + (wrap (<| $i.with-label (function (_ @else)) + $i.with-label (function (_ @end)) + (|>> testI + ($i.unwrap #$.Boolean) + ($i.IFEQ @else) + thenI + ($i.GOTO @end) + ($i.label @else) + elseI + ($i.label @end)))))) + +(def: #export (let translate inputS register exprS) + (-> Compiler Synthesis Nat Synthesis (Operation Inst)) + (do compiler.Monad + [inputI (translate inputS) + exprI (translate exprS)] + (wrap (|>> inputI + ($i.ASTORE register) + exprI)))) -(def: #export (translate-case translate valueS path) - (-> (-> ls.Synthesis (Meta $.Inst)) - ls.Synthesis ls.Path (Meta $.Inst)) - (do macro.Monad +(def: #export (case translate valueS path) + (-> Compiler Synthesis Path (Operation Inst)) + (do compiler.Monad [@end $i.make-label valueI (translate valueS) - pathI (translate-path translate path @end)] + pathI (..path translate path @end)] (wrap (|>> valueI $i.NULL $i.SWAP pushI pathI ($i.label @end))))) - -(def: #export (translate-let translate register inputS exprS) - (-> (-> ls.Synthesis (Meta $.Inst)) - Nat ls.Synthesis ls.Synthesis (Meta $.Inst)) - (do macro.Monad - [inputI (translate inputS) - exprI (translate exprS)] - (wrap (|>> inputI - ($i.ASTORE register) - exprI)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux index 2dab7b6ac..b01a68c3d 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux @@ -1,141 +1,72 @@ (.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - [io] - (concurrency [atom #+ Atom atom]) - (data ["e" error #+ Error] - [text "text/" Hash] - text/format - (coll (dictionary ["dict" unordered #+ Dict]))) - [macro] - [host] - (world [blob #+ Blob] - [file #+ File]) - ["//" lang] - (lang ["//." reference #+ Register])) - (luxc [lang] - (lang (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst]))))) - -(host.import: org/objectweb/asm/Opcodes - (#static V1_6 int)) - -(host.import: org/objectweb/asm/Label) - -(host.import: java/lang/Object) - -(host.import: java/lang/reflect/Field - (get [#? Object] #try #? Object)) - -(host.import: (java/lang/Class c) - (getField [String] #try Field)) - -(host.import: java/lang/ClassLoader - (loadClass [String] (Class Object))) - -(type: #export Bytecode Blob) - -(type: #export Class-Store (Atom (Dict Text Bytecode))) - -(type: #export Artifacts (Dict File Blob)) - -(type: #export Host - {#context [Text Nat] - #anchor (Maybe [Label Register]) - #loader ClassLoader - #store Class-Store - #artifacts Artifacts}) - -(do-template [] - [(exception: #export ( {message Text}) - message)] - - [Unknown-Class] - [Class-Already-Stored] - [No-Function-Being-Compiled] - [Cannot-Overwrite-Artifact] - [Cannot-Load-Definition] - [Invalid-Definition-Value] + [lux #* + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [io] + [concurrency + [atom (#+ Atom atom)]] + [data + [error (#+ Error)] + [text ("text/" Hash) + format] + [collection + [dictionary (#+ Dictionary)]]] + [macro] + [host (#+ import:)] + [world + [blob (#+ Blob)]] + [language + [name] + [reference (#+ Register)] + ["." compiler]]] + ## [luxc + ## [lang + ## [host + ## ["." jvm + ## [type]]]]] ) -(def: #export (with-artifacts action) - (All [a] (-> (Meta a) (Meta [Artifacts a]))) - (function (_ compiler) - (case (action (update@ #.host - (|>> (:coerce Host) - (set@ #artifacts (dict.new text.Hash)) - (:coerce Nothing)) - compiler)) - (#e.Success [compiler' output]) - (#e.Success [(update@ #.host - (|>> (:coerce Host) - (set@ #artifacts (|> (get@ #.host compiler) (:coerce Host) (get@ #artifacts))) - (:coerce Nothing)) - compiler') - [(|> compiler' (get@ #.host) (:coerce Host) (get@ #artifacts)) - output]]) - - (#e.Error error) - (#e.Error error)))) - -(def: #export (record-artifact name content) - (-> Text Blob (Meta Any)) - (function (_ compiler) - (if (|> compiler (get@ #.host) (:coerce Host) (get@ #artifacts) (dict.contains? name)) - (ex.throw Cannot-Overwrite-Artifact name) - (#e.Success [(update@ #.host - (|>> (:coerce Host) - (update@ #artifacts (dict.put name content)) - (:coerce Nothing)) - compiler) - []])))) - -(def: #export (store-class name byte-code) - (-> Text Bytecode (Meta Any)) - (function (_ compiler) - (let [store (|> (get@ #.host compiler) - (:coerce Host) - (get@ #store))] - (if (dict.contains? name (|> store atom.read io.run)) - (ex.throw Class-Already-Stored name) - (exec (io.run (atom.update (dict.put name byte-code) store)) - (#e.Success [compiler []])))))) - -(def: #export (load-class name) - (-> Text (Meta (Class Object))) - (function (_ compiler) - (let [host (:coerce Host (get@ #.host compiler)) - store (|> host (get@ #store) atom.read io.run)] - (if (dict.contains? name store) - (#e.Success [compiler (ClassLoader::loadClass [name] (get@ #loader host))]) - (ex.throw Unknown-Class name))))) - -(def: #export value-field Text "_value") -(def: #export $Object $.Type ($t.class "java.lang.Object" (list))) - -(def: #export (load-definition compiler) - (-> Lux (-> Ident Blob (Error Any))) - (function (_ (^@ def-ident [def-module def-name]) def-bytecode) - (let [normal-name (format (lang.normalize-name def-name) (%n (text/hash def-name))) - class-name (format (text.replace-all "/" "." def-module) "." normal-name)] - (<| (macro.run compiler) - (do macro.Monad - [_ (..store-class class-name def-bytecode) - class (..load-class class-name)] - (case (do e.Monad - [field (Class::getField [..value-field] class)] - (Field::get [#.None] field)) - (#e.Success (#.Some def-value)) - (wrap def-value) - - (#e.Success #.None) - (//.throw Invalid-Definition-Value (%ident def-ident)) - - (#e.Error error) - (//.throw Cannot-Load-Definition - (format "Definition: " (%ident def-ident) "\n" - "Error:\n" - error)))))))) +## (def: #export (with-artifacts action) +## (All [a] (-> (Meta a) (Meta [Artifacts a]))) +## (function (_ compiler) +## (case (action (update@ #.host +## (|>> (:coerce Host) +## (set@ #artifacts (dictionary.new text.Hash)) +## (:coerce Nothing)) +## compiler)) +## (#error.Success [compiler' output]) +## (#error.Success [(update@ #.host +## (|>> (:coerce Host) +## (set@ #artifacts (|> (get@ #.host compiler) (:coerce Host) (get@ #artifacts))) +## (:coerce Nothing)) +## compiler') +## [(|> compiler' (get@ #.host) (:coerce Host) (get@ #artifacts)) +## output]]) + +## (#error.Error error) +## (#error.Error error)))) + +## (def: #export (load-definition compiler) +## (-> Lux (-> Ident Blob (Error Any))) +## (function (_ (^@ def-ident [def-module def-name]) def-bytecode) +## (let [normal-name (format (name.normalize def-name) (%n (text/hash def-name))) +## class-name (format (text.replace-all "/" "." def-module) "." normal-name)] +## (<| (macro.run compiler) +## (do macro.Monad +## [_ (..store-class class-name def-bytecode) +## class (..load-class class-name)] +## (case (do error.Monad +## [field (Class::getField [..value-field] class)] +## (Field::get [#.None] field)) +## (#error.Success (#.Some def-value)) +## (wrap def-value) + +## (#error.Success #.None) +## (compiler.throw invalid-definition-value (%ident def-ident)) + +## (#error.Error error) +## (compiler.throw cannot-load-definition +## (format "Definition: " (%ident def-ident) "\n" +## "Error:\n" +## error)))))))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux index b6fed434e..ed2023476 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux @@ -1,86 +1,67 @@ (.module: - lux - (lux (control monad - ["ex" exception #+ exception:] - ["p" parser]) - (data ["e" error] - text/format) - [macro] - (macro ["s" syntax]) - ["//" lang] - (lang ["//." reference #+ Register] - ["//." synthesis #+ Synthesis] - ["//." extension])) - (luxc (lang (host ["$" jvm]))) - (// [".T" common] - [".T" primitive] - [".T" structure] - [".T" eval] - [".T" function] - [".T" reference] - [".T" case] - [".T" procedure])) - -(do-template [] - [(exception: #export ( {message Text}) - message)] - - [Invalid-Function-Syntax] - [Unrecognized-Synthesis] - ) + [lux #* + [language + [compiler + [synthesis (#+ Synthesis)] + [extension]]]] + [luxc + [lang + [host + ["_" jvm (#+ Compiler)]]]] + [// + ["." common] + ["." primitive] + ["." structure] + ["." reference] + ["." case] + ## ["." function] + ## ["." procedure] + ]) (def: #export (translate synthesis) - (-> Synthesis (Meta $.Inst)) + Compiler (case synthesis - (^ (//synthesis.bit value)) - (primitiveT.translate-bit value) + (^ (synthesis.bit value)) + (primitive.bit value) - (^ (//synthesis.i64 value)) - (primitiveT.translate-i64 value) + (^ (synthesis.i64 value)) + (primitive.i64 value) - (^ (//synthesis.f64 value)) - (primitiveT.translate-f64 value) + (^ (synthesis.f64 value)) + (primitive.f64 value) - (^ (//synthesis.text value)) - (primitiveT.translate-text value) + (^ (synthesis.text value)) + (primitive.text value) - (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bit last?)]) (~ valueS))) - (structureT.translate-variant translate tag last? valueS) + (^ (synthesis.variant [lefts right? value])) + (structure.variant translate lefts right? value) - (^code [(~+ members)]) - (structureT.translate-tuple translate members) + (^ (synthesis.tuple members)) + (structure.tuple translate members) - (^ [_ (#.Form (list [_ (#.Int var)]))]) - (if (variableL.captured? var) - (referenceT.translate-captured var) - (referenceT.translate-local var)) + (^ (synthesis.variable variable)) + (reference.variable variable) - [_ (#.Symbol definition)] - (referenceT.translate-definition definition) + (^ (synthesis.constant constant)) + (reference.constant constant) - (^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ exprS))) - (caseT.translate-let translate register inputS exprS) + (^ (synthesis.branch/let [input register expr])) + (case.let translate input register expr) - (^code ("lux case" (~ inputS) (~ pathPS))) - (caseT.translate-case translate inputS pathPS) + (^ (synthesis.branch/if [test then else])) + (case.if translate test then else) - (^code ("lux function" (~ [_ (#.Nat arity)]) [(~+ environment)] (~ bodyS))) - (case (s.run environment (p.some s.int)) - (#e.Success environment) - (functionT.translate-function translate environment arity bodyS) + (^ (synthesis.branch/case [input path])) + (case.case translate input path) - _ - (//.throw Invalid-Function-Syntax (%code synthesis))) + ## (^code ("lux function" (~ [_ (#.Nat arity)]) [(~+ environment)] (~ bodyS))) + ## (function.translate-function translate environment arity bodyS) - (^code ("lux call" (~ functionS) (~+ argsS))) - (functionT.translate-call translate functionS argsS) + ## (^code ("lux call" (~ functionS) (~+ argsS))) + ## (function.translate-call translate functionS argsS) - (^code ((~ [_ (#.Text procedure)]) (~+ argsS))) - (procedureT.translate-procedure translate procedure argsS) - ## (do macro.Monad - ## [translation (extensionL.find-translation procedure)] - ## (translation argsS)) + ## (^code ((~ [_ (#.Text extension)]) (~+ args))) + ## (extension.apply [extension args]) _ - (//.throw Unrecognized-Synthesis (%code synthesis)) - )) + (undefined))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux index 250b0db52..f1d639b72 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux @@ -1,29 +1,31 @@ (.module: - lux - (lux (control monad) - (data text/format) - [macro "macro/" Monad]) - (luxc ["&" lang] - (lang [".L" host] - (host ["$" jvm] - (jvm ["$i" inst] - ["$t" type])) - ["la" analysis] - ["ls" synthesis])) - (// [".T" common])) + [lux (#- i64) + [control + monad] + [data + [text + format]] + [language + [compiler ("operation/" Monad)]]] + [luxc + [lang + [host + [jvm (#+ Inst Operation) + ["$i" inst] + ["$t" type]]]]]) -(def: #export (translate-bit value) - (-> Bit (Meta $.Inst)) - (macro/wrap ($i.GETSTATIC "java.lang.Boolean" - (if value "TRUE" "FALSE") - ($t.class "java.lang.Boolean" (list))))) +(def: #export (bit value) + (-> Bit (Operation Inst)) + (operation/wrap ($i.GETSTATIC "java.lang.Boolean" + (if value "TRUE" "FALSE") + ($t.class "java.lang.Boolean" (list))))) (do-template [ ] [(def: #export ( value) - (-> (Meta $.Inst)) - (macro/wrap (|>> ( value) )))] + (-> (Operation Inst)) + (operation/wrap (|>> ( value) )))] - [translate-i64 Int $i.long ($i.wrap #$.Long)] - [translate-f64 Frac $i.double ($i.wrap #$.Double)] - [translate-text Text $i.string id] + [i64 Int $i.long ($i.wrap #jvm.Long)] + [f64 Frac $i.double ($i.wrap #jvm.Double)] + [text Text $i.string (<|)] ) diff --git a/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux index 9271efe8f..f82a674e3 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux @@ -1,49 +1,55 @@ (.module: - lux - (lux (control [monad #+ do]) - (data [text "text/" Hash] - text/format) - [macro "macro/" Monad]) - (luxc ["&" lang] - (lang [".L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$i" inst])) - ["ls" synthesis] - [".L" variable #+ Variable])) - (// [".T" common])) + [lux #* + [control + [monad (#+ do)]] + [data + [text ("text/" Hash) + format]] + [language + ["." name] + ["." reference (#+ Register Variable)] + ["." compiler ("operation/" Monad) + ["." translation]]]] + [luxc + [lang + [host + [jvm (#+ Inst Operation) + ["$t" type] + ["$i" inst]]]]] + ["." //]) (do-template [ ] - [(def: #export ( idx) + [(def: ( idx) (-> Nat Text) (|> idx .int %i (format )))] - [captured "c"] - [partial "p"] + [foreign-name "f"] + [partial-name "p"] ) -(def: #export (translate-captured variable) - (-> Variable (Meta $.Inst)) - (do macro.Monad - [this-module macro.current-module-name - function-class hostL.context - #let [function-class (format (text.replace-all "/" "." this-module) "." function-class)]] +(def: (foreign variable) + (-> Register (Operation Inst)) + (do compiler.Monad + [function-class translation.context] (wrap (|>> ($i.ALOAD +0) ($i.GETFIELD function-class - (|> variable inc (i/* -1) .nat captured) - commonT.$Object))))) + (|> variable .nat foreign-name) + //.$Object))))) -(def: #export (translate-local variable) - (-> Variable (Meta $.Inst)) - (macro/wrap ($i.ALOAD (.nat variable)))) +(def: local + (-> Register (Operation Inst)) + (|>> $i.ALOAD operation/wrap)) -(def: #export (translate-variable variable) - (-> Variable (Meta $.Inst)) - (if (variableL.captured? variable) - (translate-captured variable) - (translate-local variable))) +(def: #export (variable variable) + (-> Variable (Operation Inst)) + (case variable + (#reference.Local variable) + (local variable) + + (#reference.Foreign variable) + (foreign variable))) -(def: #export (translate-definition [def-module def-name]) - (-> Ident (Meta $.Inst)) - (let [bytecode-name (format def-module "/" (&.normalize-name def-name) (%n (text/hash def-name)))] - (macro/wrap ($i.GETSTATIC bytecode-name commonT.value-field commonT.$Object)))) +(def: #export (constant [def-module def-name]) + (-> Ident (Operation Inst)) + (let [bytecode-name (format def-module "/" (name.normalize def-name) (%n (text/hash def-name)))] + (operation/wrap ($i.GETSTATIC bytecode-name //.value-field //.$Object)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux index 0d37031e0..86fe53d1e 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux @@ -1,19 +1,25 @@ (.module: - lux - (lux (control monad) - (data text/format - (coll [list "list/" Functor])) - [math] - [macro]) - (luxc ["&" lang] - (lang [".L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - ["la" analysis] - ["ls" synthesis])) - (// [".T" common])) + [lux #* + [control + [monad (#+ do)]] + [data + [text + format] + [collection + [list ("list/" Functor)]]] + ["." math] + [language + ["." compiler + [analysis (#+ Arity)] + ["." translation]]]] + [luxc + [lang + [host + ["$" jvm (#+ Inst Method Def Operation) + ["$t" type] + ["$d" def] + ["$i" inst]]]]] + ["." // (#+ ByteCode)]) (def: $Object $.Type ($t.class "java.lang.Object" (list))) (def: $Object-Array $.Type ($t.array +1 $Object)) @@ -24,28 +30,28 @@ (def: #export $Tag $.Type $t.int) (def: #export $Flag $.Type $Object) (def: #export $Datum $.Type $Object) -(def: #export $Function $.Type ($t.class hostL.function-class (list))) +(def: #export $Function $.Type ($t.class //.function-class (list))) (def: $Throwable $.Type ($t.class "java.lang.Throwable" (list))) (def: $Runtime $.Type ($t.class "java.lang.Runtime" (list))) (def: $Runnable $.Type ($t.class "java.lang.Runnable" (list))) (def: #export logI - $.Inst + Inst (let [outI ($i.GETSTATIC "java.lang.System" "out" ($t.class "java.io.PrintStream" (list))) printI (function (_ method) ($i.INVOKEVIRTUAL "java.io.PrintStream" method ($t.method (list $Object) #.None (list)) #0))] (|>> outI ($i.string "LOG: ") (printI "print") outI $i.SWAP (printI "println")))) (def: variant-method - $.Method + Method ($t.method (list $t.int $Object $Object) (#.Some $Object-Array) (list))) (def: #export variantI - $.Inst - ($i.INVOKESTATIC hostL.runtime-class "variant_make" variant-method #0)) + Inst + ($i.INVOKESTATIC //.runtime-class "variant_make" variant-method #0)) (def: #export leftI - $.Inst + Inst (|>> ($i.int 0) $i.NULL $i.DUP2_X1 @@ -53,24 +59,24 @@ variantI)) (def: #export rightI - $.Inst + Inst (|>> ($i.int 1) ($i.string "") $i.DUP2_X1 $i.POP2 variantI)) -(def: #export someI $.Inst rightI) +(def: #export someI Inst rightI) (def: #export noneI - $.Inst + Inst (|>> ($i.int 0) $i.NULL - ($i.string hostL.unit) + ($i.string //.unit) variantI)) (def: (try-methodI unsafeI) - (-> $.Inst $.Inst) + (-> Inst Inst) (<| $i.with-label (function (_ @from)) $i.with-label (function (_ @to)) $i.with-label (function (_ @handler)) @@ -85,7 +91,7 @@ $i.ARETURN))) (def: #export string-concatI - $.Inst + Inst ($i.INVOKEVIRTUAL "java.lang.String" "concat" ($t.method (list $String) (#.Some $String) (list)) #0)) (def: #export partials-field Text "partials") @@ -93,11 +99,11 @@ (def: #export num-apply-variants Nat +8) (def: #export (apply-signature arity) - (-> ls.Arity $.Method) + (-> Arity Method) ($t.method (list.repeat arity $Object) (#.Some $Object) (list))) (def: adt-methods - $.Def + Def (let [store-tagI (|>> $i.DUP ($i.int 0) ($i.ILOAD +0) ($i.wrap #$.Int) $i.AASTORE) store-flagI (|>> $i.DUP ($i.int 1) ($i.ALOAD +1) $i.AASTORE) store-valueI (|>> $i.DUP ($i.int 2) ($i.ALOAD +2) $i.AASTORE) @@ -115,7 +121,7 @@ on-null-objectI ($i.string "NULL") arrayI (|>> ($i.ALOAD +0) ($i.CHECKCAST ($t.descriptor $Object-Array))) - recurseI ($i.INVOKESTATIC hostL.runtime-class "force_text" force-textMT #0) + recurseI ($i.INVOKESTATIC //.runtime-class "force_text" force-textMT #0) force-elemI (|>> $i.DUP arrayI $i.SWAP $i.AALOAD recurseI) swap2 (|>> $i.DUP2_X2 ## X,Y => Y,X,Y $i.POP2 ## Y,X,Y => Y,X @@ -164,13 +170,13 @@ $i.ARETURN))))) (def: #export force-textI - $.Inst - ($i.INVOKESTATIC hostL.runtime-class "force_text" ($t.method (list $Object) (#.Some $String) (list)) #0)) + Inst + ($i.INVOKESTATIC //.runtime-class "force_text" ($t.method (list $Object) (#.Some $String) (list)) #0)) -(def: frac-shiftI $.Inst ($i.double (math.pow 32.0 2.0))) +(def: frac-shiftI Inst ($i.double (math.pow 32.0 2.0))) (def: frac-methods - $.Def + Def (|>> ($d.method #$.Public $.staticM "decode_frac" ($t.method (list $String) (#.Some $Object-Array) (list)) (try-methodI (|>> ($i.ALOAD +0) @@ -178,10 +184,10 @@ ($i.wrap #$.Double)))) )) -(def: clz-method $.Method ($t.method (list $t.long) (#.Some $t.int) (list))) +(def: clz-method Method ($t.method (list $t.long) (#.Some $t.int) (list))) (def: text-methods - $.Def + Def (|>> ($d.method #$.Public $.staticM "text_clip" ($t.method (list $String $t.int $t.int) (#.Some $Variant) (list)) (try-methodI (|>> ($i.ALOAD +0) @@ -198,7 +204,7 @@ )) (def: pm-methods - $.Def + Def (let [tuple-sizeI (|>> ($i.ALOAD +0) $i.ARRAYLENGTH) tuple-elemI (|>> ($i.ALOAD +0) ($i.ILOAD +1) $i.AALOAD) expected-last-sizeI (|>> ($i.ILOAD +1) ($i.int 1) $i.IADD) @@ -245,10 +251,10 @@ $i.with-label (function (_ @further)) $i.with-label (function (_ @shorten)) $i.with-label (function (_ @wrong)) - (let [variant-partI (: (-> Nat $.Inst) + (let [variant-partI (: (-> Nat Inst) (function (_ idx) (|>> ($i.int (.int idx)) $i.AALOAD))) - tagI (: $.Inst + tagI (: Inst (|>> (variant-partI +0) ($i.unwrap #$.Int))) flagI (variant-partI +1) datumI (variant-partI +2) @@ -332,7 +338,7 @@ ))) (def: io-methods - $.Def + Def (let [string-writerI (|>> ($i.NEW "java.io.StringWriter") $i.DUP ($i.INVOKESPECIAL "java.io.StringWriter" "" ($t.method (list) #.None (list)) #0)) @@ -352,7 +358,7 @@ ($i.label @from) ($i.ALOAD +0) $i.NULL - ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature +1) #0) + ($i.INVOKEVIRTUAL //.function-class apply-method (apply-signature +1) #0) rightI $i.ARETURN ($i.label @to) @@ -367,19 +373,19 @@ ))) (def: process-methods - $.Def + Def (let [executor-class "java.util.concurrent.ScheduledThreadPoolExecutor" executorT ($t.class executor-class (list)) executor-field "executor" - endI (|>> ($i.string hostL.unit) + endI (|>> ($i.string //.unit) $i.ARETURN) - runnableI (: (-> $.Inst $.Inst) + runnableI (: (-> Inst Inst) (function (_ functionI) - (|>> ($i.NEW hostL.runnable-class) + (|>> ($i.NEW //.runnable-class) $i.DUP functionI - ($i.INVOKESPECIAL hostL.runnable-class "" ($t.method (list $Function) #.None (list)) #0)))) - threadI (: (-> $.Inst $.Inst) + ($i.INVOKESPECIAL //.runnable-class "" ($t.method (list $Function) #.None (list)) #0)))) + threadI (: (-> Inst Inst) (function (_ runnableI) (|>> ($i.NEW "java.lang.Thread") $i.DUP @@ -394,7 +400,7 @@ parallelism-levelI ($i.INVOKESPECIAL executor-class "" ($t.method (list $t.int) #.None (list)) #0))] (|>> executorI - ($i.PUTSTATIC hostL.runtime-class executor-field executorT) + ($i.PUTSTATIC //.runtime-class executor-field executorT) $i.RETURN))) ($d.method #$.Public $.staticM "schedule" ($t.method (list $t.long $Function) (#.Some $Object) (list)) @@ -405,7 +411,7 @@ time-unit-class "java.util.concurrent.TimeUnit" time-unitT ($t.class time-unit-class (list)) futureT ($t.class "java.util.concurrent.ScheduledFuture" (list)) - executorI ($i.GETSTATIC hostL.runtime-class executor-field executorT) + executorI ($i.GETSTATIC //.runtime-class executor-field executorT) schedule-laterI (|>> executorI (runnableI ($i.ALOAD +2)) delayI @@ -425,77 +431,74 @@ ))) (def: translate-runtime - (Meta commonT.Bytecode) - (do macro.Monad - [_ (wrap []) - #let [bytecode ($d.class #$.V1_6 #$.Public $.finalC hostL.runtime-class (list) ["java.lang.Object" (list)] (list) - (|>> adt-methods - frac-methods - text-methods - pm-methods - io-methods - process-methods))] - _ (commonT.store-class hostL.runtime-class bytecode)] - (wrap bytecode))) + (Operation ByteCode) + (let [bytecode ($d.class #$.V1_6 #$.Public $.finalC //.runtime-class (list) ["java.lang.Object" (list)] (list) + (|>> adt-methods + frac-methods + text-methods + pm-methods + io-methods + process-methods))] + (do compiler.Monad + [_ (translation.execute! [//.runtime-class bytecode])] + (wrap bytecode)))) (def: translate-function - (Meta commonT.Bytecode) - (do macro.Monad - [_ (wrap []) - #let [applyI (|> (list.n/range +2 num-apply-variants) - (list/map (function (_ arity) - ($d.method #$.Public $.noneM apply-method (apply-signature arity) - (let [preI (|> (list.n/range +0 (dec arity)) - (list/map $i.ALOAD) - $i.fuse)] - (|>> preI - ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature (dec arity)) #0) - ($i.CHECKCAST hostL.function-class) - ($i.ALOAD arity) - ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature +1) #0) - $i.ARETURN))))) - (list& ($d.abstract-method #$.Public $.noneM apply-method (apply-signature +1))) - $d.fuse) - bytecode ($d.abstract #$.V1_6 #$.Public $.noneC hostL.function-class (list) ["java.lang.Object" (list)] (list) - (|>> ($d.field #$.Public $.finalF partials-field $t.int) - ($d.method #$.Public $.noneM "" ($t.method (list $t.int) #.None (list)) - (|>> ($i.ALOAD +0) - ($i.INVOKESPECIAL "java.lang.Object" "" ($t.method (list) #.None (list)) #0) - ($i.ALOAD +0) - ($i.ILOAD +1) - ($i.PUTFIELD hostL.function-class partials-field $t.int) - $i.RETURN)) - applyI))] - _ (commonT.store-class hostL.function-class bytecode)] - (wrap bytecode))) - -(def: translate-runnable - (Meta commonT.Bytecode) - (do macro.Monad - [_ (wrap []) - #let [procedure-field "procedure" - bytecode ($d.class #$.V1_6 #$.Public $.finalC hostL.runnable-class (list) ["java.lang.Object" (list)] (list ["java.lang.Runnable" (list)]) - (|>> ($d.field #$.Public $.finalF procedure-field $Function) - ($d.method #$.Public $.noneM "" ($t.method (list $Function) #.None (list)) + (Operation ByteCode) + (let [applyI (|> (list.n/range +2 num-apply-variants) + (list/map (function (_ arity) + ($d.method #$.Public $.noneM apply-method (apply-signature arity) + (let [preI (|> (list.n/range +0 (dec arity)) + (list/map $i.ALOAD) + $i.fuse)] + (|>> preI + ($i.INVOKEVIRTUAL //.function-class apply-method (apply-signature (dec arity)) #0) + ($i.CHECKCAST //.function-class) + ($i.ALOAD arity) + ($i.INVOKEVIRTUAL //.function-class apply-method (apply-signature +1) #0) + $i.ARETURN))))) + (list& ($d.abstract-method #$.Public $.noneM apply-method (apply-signature +1))) + $d.fuse) + bytecode ($d.abstract #$.V1_6 #$.Public $.noneC //.function-class (list) ["java.lang.Object" (list)] (list) + (|>> ($d.field #$.Public $.finalF partials-field $t.int) + ($d.method #$.Public $.noneM "" ($t.method (list $t.int) #.None (list)) (|>> ($i.ALOAD +0) ($i.INVOKESPECIAL "java.lang.Object" "" ($t.method (list) #.None (list)) #0) ($i.ALOAD +0) - ($i.ALOAD +1) - ($i.PUTFIELD hostL.runnable-class procedure-field $Function) - $i.RETURN)) - ($d.method #$.Public $.noneM "run" ($t.method (list) #.None (list)) - (|>> ($i.ALOAD +0) - ($i.GETFIELD hostL.runnable-class procedure-field $Function) - $i.NULL - ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature +1) #0) + ($i.ILOAD +1) + ($i.PUTFIELD //.function-class partials-field $t.int) $i.RETURN)) - ))] - _ (commonT.store-class hostL.runnable-class bytecode)] - (wrap bytecode))) + applyI))] + (do compiler.Monad + [_ (translation.execute! [//.function-class bytecode])] + (wrap bytecode)))) + +(def: translate-runnable + (Operation ByteCode) + (let [procedure-field "procedure" + bytecode ($d.class #$.V1_6 #$.Public $.finalC //.runnable-class (list) ["java.lang.Object" (list)] (list ["java.lang.Runnable" (list)]) + (|>> ($d.field #$.Public $.finalF procedure-field $Function) + ($d.method #$.Public $.noneM "" ($t.method (list $Function) #.None (list)) + (|>> ($i.ALOAD +0) + ($i.INVOKESPECIAL "java.lang.Object" "" ($t.method (list) #.None (list)) #0) + ($i.ALOAD +0) + ($i.ALOAD +1) + ($i.PUTFIELD //.runnable-class procedure-field $Function) + $i.RETURN)) + ($d.method #$.Public $.noneM "run" ($t.method (list) #.None (list)) + (|>> ($i.ALOAD +0) + ($i.GETFIELD //.runnable-class procedure-field $Function) + $i.NULL + ($i.INVOKEVIRTUAL //.function-class apply-method (apply-signature +1) #0) + $i.RETURN)) + ))] + (do compiler.Monad + [_ (translation.execute! [//.runnable-class bytecode])] + (wrap bytecode)))) (def: #export translate - (Meta [commonT.Bytecode commonT.Bytecode commonT.Bytecode]) - (do macro.Monad + (Operation [ByteCode ByteCode ByteCode]) + (do compiler.Monad [runtime-bc translate-runtime function-bc translate-function runnable-bc translate-runnable] diff --git a/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux index 8b636b1cf..bc4a3cb95 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux @@ -1,32 +1,36 @@ (.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data text/format - (coll [list])) - [macro] - [host #+ do-to]) - (luxc ["&" lang] - (lang [".L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - ["la" analysis] - ["ls" synthesis])) - (// [".T" common])) + [lux #* + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + [text + format] + [collection + ["." list]]] + [language + ["." compiler + [synthesis (#+ Synthesis)]]]] + [luxc + [lang + [host + ["." jvm (#+ Inst Operation Compiler) + ["$t" type] + ["$i" inst]]]]] + [//]) -(exception: #export (Not-A-Tuple {message Text}) - message) +(exception: #export (not-a-tuple {size Nat}) + (ex.report ["Expected size" ">= 2"] + ["Actual size" (%n size)])) -(def: $Object $.Type ($t.class "java.lang.Object" (list))) +(def: $Object jvm.Type ($t.class "java.lang.Object" (list))) -(def: #export (translate-tuple translate members) - (-> (-> ls.Synthesis (Meta $.Inst)) (List ls.Synthesis) (Meta $.Inst)) - (do macro.Monad +(def: #export (tuple translate members) + (-> Compiler (List Synthesis) (Operation Inst)) + (do compiler.Monad [#let [size (list.size members)] - _ (&.assert Not-A-Tuple (%code (` [(~+ members)])) - (n/>= +2 size)) + _ (compiler.assert not-a-tuple size + (n/>= +2 size)) membersI (|> members list.enumerate (monad.map @ (function (_ [idx member]) @@ -42,19 +46,19 @@ membersI)))) (def: (flagI tail?) - (-> Bit $.Inst) + (-> Bit Inst) (if tail? ($i.string "") $i.NULL)) -(def: #export (translate-variant translate tag tail? member) - (-> (-> ls.Synthesis (Meta $.Inst)) Nat Bit ls.Synthesis (Meta $.Inst)) - (do macro.Monad +(def: #export (variant translate tag tail? member) + (-> Compiler Nat Bit Synthesis (Operation Inst)) + (do compiler.Monad [memberI (translate member)] (wrap (|>> ($i.int (.int tag)) (flagI tail?) memberI - ($i.INVOKESTATIC hostL.runtime-class + ($i.INVOKESTATIC //.runtime-class "variant_make" ($t.method (list $t.int $Object $Object) (#.Some ($t.array +1 $Object)) -- cgit v1.2.3