diff options
Diffstat (limited to 'stdlib/source/lux/tool/compiler/phase')
5 files changed, 726 insertions, 7 deletions
diff --git a/stdlib/source/lux/tool/compiler/phase/extension/directive/jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/directive/jvm.lux new file mode 100644 index 000000000..4db15e8e6 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/directive/jvm.lux @@ -0,0 +1,303 @@ +(.module: + [lux (#- Type Definition) + ["." host] + [abstract + ["." monad (#+ do)]] + [control + [pipe (#+ case>)] + ["<>" parser ("#@." monad) + ["<c>" code (#+ Parser)] + ["<t>" text]]] + [data + ["." product] + [number + ["." i32]] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#@." functor fold)] + ["." dictionary] + ["." row]]] + [type + ["." check (#+ Check)]] + [macro + ["." template]] + [target + [jvm + ["_" bytecode (#+ Bytecode)] + ["." modifier (#+ Modifier) ("#@." monoid)] + ["." attribute] + ["." field] + ["." version] + ["." class] + ["." constant + ["." pool (#+ Resource)]] + [encoding + ["." name]] + ["." type (#+ Type Constraint Argument Typed) + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] + [".T" lux (#+ Mapping)] + ["." signature] + ["." descriptor (#+ Descriptor)] + ["." parser]]]] + [tool + [compiler + ["." analysis] + ["." synthesis] + ["." directive (#+ Handler Bundle)] + ["." phase + [analysis + [".A" type]] + ["." generation + [jvm + [runtime (#+ Anchor Definition)]]] + ["." extension + ["." bundle] + [analysis + ["." jvm]] + [directive + ["/" lux]]]]]]]) + +(type: Operation + (directive.Operation Anchor (Bytecode Any) Definition)) + +(def: signature (|>> type.signature signature.signature)) + +(type: Declaration + [Text (List (Type Var))]) + +(def: declaration + (Parser Declaration) + (<c>.form (<>.and <c>.text (<>.some jvm.var)))) + +(def: visibility + (Parser (Modifier field.Field)) + (`` ($_ <>.either + (~~ (template [<label> <modifier>] + [(<>.after (<c>.text! <label>) (<>@wrap <modifier>))] + + ["public" field.public] + ["private" field.private] + ["protected" field.protected] + ["default" modifier.empty]))))) + +(def: inheritance + (Parser (Modifier class.Class)) + (`` ($_ <>.either + (~~ (template [<label> <modifier>] + [(<>.after (<c>.text! <label>) (<>@wrap <modifier>))] + + ["final" class.final] + ["abstract" class.abstract] + ["default" modifier.empty]))))) + +(def: state + (Parser (Modifier field.Field)) + (`` ($_ <>.either + (~~ (template [<label> <modifier>] + [(<>.after (<c>.text! <label>) (<>@wrap <modifier>))] + + ["volatile" field.volatile] + ["final" field.final] + ["default" modifier.empty]))))) + +(type: Annotation Any) + +(def: annotation + (Parser Annotation) + <c>.any) + +(def: field-type + (Parser (Type Value)) + (<t>.embed parser.value <c>.text)) + +(type: Constant + [Text (List Annotation) (Type Value) Code]) + +(def: constant + (Parser Constant) + (<| <c>.form + (<>.after (<c>.text! "constant")) + ($_ <>.and + <c>.text + (<c>.tuple (<>.some ..annotation)) + ..field-type + <c>.any + ))) + +(type: Variable + [Text (Modifier field.Field) (Modifier field.Field) (List Annotation) (Type Value)]) + +(def: variable + (Parser Variable) + (<| <c>.form + (<>.after (<c>.text! "variable")) + ($_ <>.and + <c>.text + ..visibility + ..state + (<c>.tuple (<>.some ..annotation)) + ..field-type + ))) + +(type: Field + (#Constant Constant) + (#Variable Variable)) + +(def: field + (Parser Field) + ($_ <>.or + ..constant + ..variable + )) + +(type: Method-Definition + (#Constructor (jvm.Constructor Code)) + (#Virtual-Method (jvm.Virtual-Method Code)) + (#Static-Method (jvm.Static-Method Code)) + (#Overriden-Method (jvm.Overriden-Method Code))) + +(def: method + (Parser Method-Definition) + ($_ <>.or + jvm.constructor-definition + jvm.virtual-method-definition + jvm.static-method-definition + jvm.overriden-method-definition + )) + +(def: (constraint name) + (-> Text Constraint) + {#type.name name + #type.super-class (type.class "java.lang.Object" (list)) + #type.super-interfaces (list)}) + +(def: constant::modifier + (Modifier field.Field) + ($_ modifier@compose + field.public + field.static + field.final)) + +(def: (field-definition field) + (-> Field (Resource field.Field)) + (case field + ## TODO: Handle annotations. + (#Constant [name annotations type value]) + (case value + (^template [<tag> <type> <constant>] + [_ (<tag> value)] + (do pool.monad + [constant (`` (|> value (~~ (template.splice <constant>)))) + attribute (attribute.constant constant)] + (field.field ..constant::modifier name <type> (row.row attribute)))) + ([#.Bit type.boolean [(case> #0 +0 #1 +1) .i64 i32.i32 constant.integer pool.integer]] + [#.Int type.byte [.i64 i32.i32 constant.integer pool.integer]] + [#.Int type.short [.i64 i32.i32 constant.integer pool.integer]] + [#.Int type.int [.i64 i32.i32 constant.integer pool.integer]] + [#.Int type.long [constant.long pool.long]] + [#.Frac type.float [host.double-to-float constant.float pool.float]] + [#.Frac type.double [constant.double pool.double]] + [#.Nat type.char [.i64 i32.i32 constant.integer pool.integer]] + [#.Text (type.class "java.lang.String" (list)) [pool.string]] + ) + + ## TODO: Tighten this pattern-matching so this catch-all clause isn't necessary. + _ + (undefined)) + + ## TODO: Handle annotations. + (#Variable [name visibility state annotations type]) + (field.field (modifier@compose visibility state) + name type (row.row)))) + +(def: (method-definition [mapping selfT] [analyse synthesize generate]) + (-> [Mapping .Type] + [analysis.Phase + synthesis.Phase + (generation.Phase Anchor (Bytecode Any) Definition)] + (-> Method-Definition (Operation synthesis.Synthesis))) + (function (_ methodC) + (do phase.monad + [methodA (: (Operation analysis.Analysis) + (directive.lift-analysis + (case methodC + (#Constructor method) + (jvm.analyse-constructor-method analyse selfT mapping method) + + (#Virtual-Method method) + (jvm.analyse-virtual-method analyse selfT mapping method) + + (#Static-Method method) + (jvm.analyse-static-method analyse mapping method) + + (#Overriden-Method method) + (jvm.analyse-overriden-method analyse selfT mapping method))))] + (directive.lift-synthesis + (synthesize methodA))))) + +(def: jvm::class + (Handler Anchor (Bytecode Any) Definition) + (/.custom + [($_ <>.and + ..declaration + jvm.class + (<c>.tuple (<>.some jvm.class)) + ..inheritance + (<c>.tuple (<>.some ..annotation)) + (<c>.tuple (<>.some ..field)) + (<c>.tuple (<>.some ..method))) + (function (_ extension phase + [[name parameters] + super-class + super-interfaces + inheritance + ## TODO: Handle annotations. + annotations + fields + methods]) + (do phase.monad + [parameters (directive.lift-analysis + (typeA.with-env + (jvm.parameter-types parameters))) + #let [mapping (list@fold (function (_ [parameterJ parameterT] mapping) + (dictionary.put (parser.name parameterJ) parameterT mapping)) + luxT.fresh + parameters)] + super-classT (directive.lift-analysis + (typeA.with-env + (luxT.check (luxT.class mapping) (..signature super-class)))) + super-interfaceT+ (directive.lift-analysis + (typeA.with-env + (monad.map check.monad + (|>> ..signature (luxT.check (luxT.class mapping))) + super-interfaces))) + #let [selfT (jvm.inheritance-relationship-type (#.Primitive name (list@map product.right parameters)) + super-classT + super-interfaceT+)] + state (extension.lift phase.get-state) + #let [analyse (get@ [#directive.analysis #directive.phase] state) + synthesize (get@ [#directive.synthesis #directive.phase] state) + generate (get@ [#directive.generation #directive.phase] state)] + methods (monad.map @ (..method-definition [mapping selfT] [analyse synthesize generate]) + methods) + ## _ (directive.lift-generation + ## (generation.save! true ["" name] + ## [name + ## (class.class version.v6_0 + ## (modifier@compose class.public inheritance) + ## (name.internal name) (list@map (|>> product.left parser.name ..constraint) parameters) + ## super-class super-interfaces + ## (list@map ..field-definition fields) + ## (list) ## TODO: Add methods + ## (row.row))])) + #let [_ (log! (format "Class " name))]] + (wrap directive.no-requirements)))])) + +(def: #export bundle + (Bundle Anchor (Bytecode Any) Definition) + (<| (bundle.prefix "jvm") + (|> bundle.empty + ## TODO: Finish handling methods and un-comment. + ## (dictionary.put "class" jvm::class) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/host.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/host.lux new file mode 100644 index 000000000..2892ac045 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/host.lux @@ -0,0 +1,159 @@ +(.module: + [lux (#- Definition) + ["." host (#+ import: do-to object)] + [abstract + [monad (#+ do)]] + [control + pipe + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["." io (#+ IO io)] + [concurrency + ["." atom (#+ Atom atom)]]] + [data + [binary (#+ Binary)] + ["." product] + ["." text ("#@." hash) + ["%" format (#+ format)]] + [collection + ["." array] + ["." dictionary (#+ Dictionary)] + ["." row]] + ["." format #_ + ["#" binary]]] + [target + [jvm + ["." loader (#+ Library)] + ["_" bytecode (#+ Bytecode)] + ["." modifier (#+ Modifier) ("#@." monoid)] + ["." field (#+ Field)] + ["." method (#+ Method)] + ["." version] + ["." class (#+ Class)] + ["." encoding #_ + ["#/." name]] + ["." type + ["." descriptor]]]] + [tool + [compiler + ["." name]]]] + ["." // #_ + ["#." runtime (#+ Definition)]] + ) + +(import: #long java/lang/reflect/Field + (get [#? java/lang/Object] #try #? java/lang/Object)) + +(import: #long (java/lang/Class a) + (getField [java/lang/String] #try java/lang/reflect/Field)) + +(import: #long java/lang/Object + (getClass [] (java/lang/Class java/lang/Object))) + +(import: #long java/lang/ClassLoader) + +(def: value::field "_value") +(def: value::type (type.class "java.lang.Object" (list))) +(def: value::modifier ($_ modifier@compose field.public field.final field.static)) + +(def: init::type (type.method [(list) type.void (list)])) +(def: init::modifier ($_ modifier@compose method.public method.static method.strict)) + +(exception: #export (cannot-load {class Text} {error Text}) + (exception.report + ["Class" class] + ["Error" error])) + +(exception: #export (invalid-field {class Text} {field Text} {error Text}) + (exception.report + ["Class" class] + ["Field" field] + ["Error" error])) + +(exception: #export (invalid-value {class Text}) + (exception.report + ["Class" class])) + +(def: (class-value class-name class) + (-> Text (java/lang/Class java/lang/Object) (Try Any)) + (case (java/lang/Class::getField ..value::field class) + (#try.Success field) + (case (java/lang/reflect/Field::get #.None field) + (#try.Success ?value) + (case ?value + (#.Some value) + (#try.Success value) + + #.None + (exception.throw ..invalid-value [class-name])) + + (#try.Failure error) + (exception.throw ..cannot-load [class-name error])) + + (#try.Failure error) + (exception.throw ..invalid-field [class-name ..value::field error]))) + +(def: class-path-separator ".") + +(def: (evaluate! library loader eval-class valueG) + (-> Library java/lang/ClassLoader Text (Bytecode Any) (Try [Any Definition])) + (let [bytecode-name (text.replace-all class-path-separator .module-separator eval-class) + bytecode (class.class version.v6_0 + class.public + (encoding/name.internal bytecode-name) + (encoding/name.internal "java.lang.Object") (list) + (list (field.field ..value::modifier ..value::field ..value::type (row.row))) + (list (method.method ..init::modifier "<clinit>" ..init::type + (list) + (#.Some + ($_ _.compose + valueG + (_.putstatic (type.class bytecode-name (list)) ..value::field ..value::type) + _.return)))) + (row.row))] + (io.run (do (try.with io.monad) + [bytecode (:: @ map (format.run class.writer) + (io.io bytecode)) + _ (loader.store eval-class bytecode library) + class (loader.load eval-class loader) + value (:: io.monad wrap (class-value eval-class class))] + (wrap [value + [eval-class bytecode]]))))) + +(def: (execute! library loader temp-label [class-name class-bytecode]) + (-> Library java/lang/ClassLoader Text Definition (Try Any)) + (io.run (do (try.with io.monad) + [existing-class? (|> (atom.read library) + (:: io.monad map (dictionary.contains? class-name)) + (try.lift io.monad) + (: (IO (Try Bit)))) + _ (if existing-class? + (wrap []) + (loader.store class-name class-bytecode library))] + (loader.load class-name loader)))) + +(def: (define! library loader [module name] valueG) + (-> Library java/lang/ClassLoader Name (Bytecode Any) (Try [Text Any Definition])) + (let [class-name (format (text.replace-all .module-separator class-path-separator module) + class-path-separator (name.normalize name) + "___" (%.nat (text@hash name)))] + (do try.monad + [[value definition] (evaluate! library loader class-name valueG)] + (wrap [class-name value definition])))) + +(def: #export host + (IO //runtime.Host) + (io (let [library (loader.new-library []) + loader (loader.memory library)] + (: //runtime.Host + (structure + (def: (evaluate! temp-label valueG) + (let [eval-class (|> temp-label name.normalize (text.replace-all " " "$"))] + (:: try.monad map product.left + (..evaluate! library loader eval-class valueG)))) + + (def: execute! + (..execute! library loader)) + + (def: define! + (..define! library loader))))))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/packager.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/packager.lux new file mode 100644 index 000000000..9400adf1a --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/packager.lux @@ -0,0 +1,111 @@ +(.module: + [lux (#- Module Definition) + ["." host (#+ import: do-to)] + [data + ["." binary (#+ Binary)] + ["." text] + [number + ["n" nat]] + [collection + ["." row] + ["." list ("#@." fold)]]] + [target + [jvm + [encoding + ["." name (#+ External)]]]] + [tool + [compiler + [phase + [generation (#+ Buffer Output) + [jvm + [runtime (#+ Definition)]]]] + [meta + [archive + [descriptor (#+ Module)]]]]]]) + +(import: #long java/lang/Object) + +(import: #long java/lang/String) + +(import: #long java/util/jar/Attributes + (put [java/lang/Object java/lang/Object] #? java/lang/Object)) + +(import: #long java/util/jar/Attributes$Name + (#static MAIN_CLASS java/util/jar/Attributes$Name) + (#static MANIFEST_VERSION java/util/jar/Attributes$Name)) + +(import: #long java/util/jar/Manifest + (new []) + (getMainAttributes [] java/util/jar/Attributes)) + +(import: #long java/io/Flushable + (flush [] void)) + +(import: #long java/io/Closeable + (close [] void)) + +(import: #long java/io/OutputStream) + +(import: #long java/io/ByteArrayOutputStream + (new [int]) + (toByteArray [] [byte])) + +(import: #long java/util/zip/ZipEntry) + +(import: #long java/util/zip/ZipOutputStream + (write [[byte] int int] void) + (closeEntry [] void)) + +(import: #long java/util/jar/JarEntry + (new [java/lang/String])) + +(import: #long java/util/jar/JarOutputStream + (new [java/io/OutputStream java/util/jar/Manifest]) + (putNextEntry [java/util/zip/ZipEntry] void)) + +(def: byte 1) +## https://en.wikipedia.org/wiki/Kibibyte +(def: kibi-byte (n.* 1,024 byte)) +## https://en.wikipedia.org/wiki/Mebibyte +(def: mebi-byte (n.* 1,024 kibi-byte)) + +(def: manifest-version "1.0") + +(def: class-name + (-> Text Text) + (text.suffix ".class")) + +(def: (manifest program-class) + (-> External java/util/jar/Manifest) + (let [manifest (java/util/jar/Manifest::new)] + (exec (do-to (java/util/jar/Manifest::getMainAttributes manifest) + (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MAIN_CLASS) program-class) + (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MANIFEST_VERSION) ..manifest-version)) + manifest))) + +(def: (write-class [def-name [class-name bytecode]] sink) + (-> [Name Definition] java/util/jar/JarOutputStream java/util/jar/JarOutputStream) + (let [class-name (|> class-name name.internal name.read ..class-name)] + (do-to sink + (java/util/jar/JarOutputStream::putNextEntry (java/util/jar/JarEntry::new class-name)) + (java/util/zip/ZipOutputStream::write bytecode +0 (.int (binary.size bytecode))) + (java/io/Flushable::flush) + (java/util/zip/ZipOutputStream::closeEntry)))) + +(def: (write-module [module classes] sink) + (-> [Module (Buffer Definition)] java/util/jar/JarOutputStream java/util/jar/JarOutputStream) + (|> classes + row.to-list + (list@fold ..write-class sink))) + +(def: #export (package program-class outputs) + (-> External (Output Definition) Binary) + (let [buffer (java/io/ByteArrayOutputStream::new (.int ..mebi-byte)) + sink (java/util/jar/JarOutputStream::new buffer (manifest program-class))] + (exec (|> outputs + row.to-list + (list@fold ..write-module sink)) + (do-to sink + (java/io/Flushable::flush) + (java/io/Closeable::close)) + (java/io/ByteArrayOutputStream::toByteArray buffer)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/program.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/program.lux new file mode 100644 index 000000000..c5f10a9a6 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/program.lux @@ -0,0 +1,143 @@ +(.module: + [lux (#- Definition) + [abstract + [monad (#+ do)]] + [control + ["." try]] + [data + [collection + ["." row]] + ["." format #_ + ["#" binary]]] + [target + [jvm + ["_" bytecode (#+ Bytecode)] + ["." modifier (#+ Modifier) ("#@." monoid)] + ["." method (#+ Method)] + ["." version] + ["." class (#+ Class)] + [encoding + ["." name]] + ["." type + ["." reflection]]]]] + ["." // + ["#." runtime (#+ Definition)] + ["#." function/abstract]]) + +(def: #export class "LuxProgram") + +(def: ^Object (type.class "java.lang.Object" (list))) +(def: ^String (type.class "java.lang.String" (list))) +(def: ^Args (type.array ^String)) + +(def: main::type (type.method [(list ..^Args) type.void (list)])) + +(def: main::modifier + (Modifier Method) + ($_ modifier@compose + method.public + method.static + method.strict + )) + +(def: program::modifier + (Modifier Class) + ($_ modifier@compose + class.public + class.final + )) + +(def: nil //runtime.none-injection) + +(def: amount-of-inputs + (Bytecode Any) + ($_ _.compose + _.aload-0 + _.arraylength)) + +(def: decrease + (Bytecode Any) + ($_ _.compose + _.iconst-1 + _.isub)) + +(def: head + (Bytecode Any) + ($_ _.compose + _.dup + _.aload-0 + _.swap + _.aaload + _.swap + _.dup-x2 + _.pop)) + +(def: pair + (Bytecode Any) + ($_ _.compose + _.iconst-2 + (_.anewarray ^Object) + _.dup-x1 + _.swap + _.iconst-0 + _.swap + _.aastore + _.dup-x1 + _.swap + _.iconst-1 + _.swap + _.aastore)) + +(def: cons //runtime.right-injection) + +(def: input-list + (Bytecode Any) + (do _.monad + [@loop _.new-label + @end _.new-label] + ($_ _.compose + ..nil + ..amount-of-inputs + (_.set-label @loop) + ..decrease + _.dup + (_.iflt @end) + ..head + ..pair + ..cons + _.swap + (_.goto @loop) + (_.set-label @end) + _.pop))) + +(def: feed-inputs //runtime.apply) + +(def: run-io + (Bytecode Any) + ($_ _.compose + (_.checkcast //function/abstract.class) + _.aconst-null + //runtime.apply)) + +(def: #export (program program) + (-> (Bytecode Any) Definition) + (let [super-class (|> ..^Object type.reflection reflection.reflection name.internal) + main (method.method ..main::modifier "main" ..main::type + (list) + (#.Some ($_ _.compose + program + ..input-list + ..feed-inputs + ..run-io + _.return)))] + [..class + (<| (format.run class.writer) + try.assume + (class.class version.v6_0 + ..program::modifier + (name.internal ..class) + super-class + (list) + (list) + (list main) + (row.row)))])) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux index f2349ff41..3ed3ecb52 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux @@ -67,6 +67,9 @@ (type: #export (Generator i) (-> Phase i (Operation (Bytecode Any)))) +(type: #export Host + (///.Host (Bytecode Any) Definition)) + (def: #export class (type.class "LuxRuntime" (list))) (def: procedure @@ -180,7 +183,7 @@ (def: #export decode-frac (..procedure ..decode-frac::name ..decode-frac::type)) (def: decode-frac::method - (method.method ..modifier ..variant::name + (method.method ..modifier ..decode-frac::name ..variant::type (list) (#.Some @@ -492,7 +495,7 @@ (def: ^Object (type.class "java.lang.Object" (list))) -(def: translate-runtime +(def: generate-runtime (Operation Any) (let [class (..reflection ..class) modifier (: (Modifier Class) @@ -524,7 +527,7 @@ [_ (///.execute! class [class bytecode])] (///.save! .false ["" class] [class bytecode])))) -(def: translate-function +(def: generate-function (Operation Any) (let [apply::method+ (|> (list.n/range (inc //function/arity.minimum) //function/arity.maximum) @@ -542,7 +545,7 @@ (_.aload arity) (_.invokevirtual //function.class ..apply::name (..apply::type //function/arity.minimum)) _.areturn)))))) - (list& (method.method (modifier@compose method.public method.abstract) + (list& (method.method method.public ..apply::name (..apply::type //function/arity.minimum) (list) ## TODO: It shouldn't be necessary to set the code for this method, since it's abstract. @@ -586,11 +589,11 @@ [_ (///.execute! class [class bytecode])] (///.save! .false ["" class] [class bytecode])))) -(def: #export translate +(def: #export generate (Operation Any) (do ////.monad - [_ ..translate-runtime] - ..translate-function)) + [_ ..generate-runtime] + ..generate-function)) (def: #export forge-label (Operation Label) |