diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/jvm')
13 files changed, 0 insertions, 2889 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm/case.lux b/new-luxc/source/luxc/lang/translation/jvm/case.lux deleted file mode 100644 index 0d8aaa91e..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/case.lux +++ /dev/null @@ -1,239 +0,0 @@ -(.module: - [lux (#- Type if let case) - [abstract - [monad (#+ do)]] - [control - ["." function] - ["ex" exception (#+ exception:)]] - [data - [number - ["n" nat]]] - [target - [jvm - ["." type (#+ Type) - ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] - ["." descriptor (#+ Descriptor)] - ["." signature (#+ Signature)]]]] - [tool - [compiler - ["." phase ("operation@." monad)] - [meta - [archive (#+ Archive)]] - [language - [lux - ["." synthesis (#+ Path Synthesis)]]]]]] - [luxc - [lang - [host - ["$" jvm (#+ Label Inst Operation Phase Generator) - ["_" inst]]]]] - ["." // - ["." runtime]]) - -(def: (pop-altI stack-depth) - (-> Nat Inst) - (.case stack-depth - 0 function.identity - 1 _.POP - 2 _.POP2 - _ ## (n.> 2) - (|>> _.POP2 - (pop-altI (n.- 2 stack-depth))))) - -(def: peekI - Inst - (|>> _.DUP - (_.int +0) - _.AALOAD)) - -(def: pushI - Inst - (_.INVOKESTATIC //.$Runtime "pm_push" (type.method [(list runtime.$Stack //.$Value) runtime.$Stack (list)]))) - -(def: popI - (|>> (_.int +1) - _.AALOAD - (_.CHECKCAST runtime.$Stack))) - -(def: (path' stack-depth @else @end phase archive path) - (-> Nat Label Label Phase Archive Path (Operation Inst)) - (.case path - #synthesis.Pop - (operation@wrap ..popI) - - (#synthesis.Bind register) - (operation@wrap (|>> peekI - (_.ASTORE register))) - - (^ (synthesis.path/bit value)) - (operation@wrap (.let [jumpI (.if value _.IFEQ _.IFNE)] - (|>> peekI - (_.unwrap type.boolean) - (jumpI @else)))) - - (^ (synthesis.path/i64 value)) - (operation@wrap (|>> peekI - (_.unwrap type.long) - (_.long (.int value)) - _.LCMP - (_.IFNE @else))) - - (^ (synthesis.path/f64 value)) - (operation@wrap (|>> peekI - (_.unwrap type.double) - (_.double value) - _.DCMPL - (_.IFNE @else))) - - (^ (synthesis.path/text value)) - (operation@wrap (|>> peekI - (_.string value) - (_.INVOKEVIRTUAL (type.class "java.lang.Object" (list)) - "equals" - (type.method [(list //.$Value) type.boolean (list)])) - (_.IFEQ @else))) - - (#synthesis.Then bodyS) - (do phase.monad - [bodyI (phase archive bodyS)] - (wrap (|>> (pop-altI stack-depth) - bodyI - (_.GOTO @end)))) - - (^template [<pattern> <flag> <prepare>] - (^ (<pattern> idx)) - (operation@wrap (<| _.with-label (function (_ @success)) - _.with-label (function (_ @fail)) - (|>> peekI - (_.CHECKCAST //.$Variant) - (_.int (.int (<prepare> idx))) - <flag> - (_.INVOKESTATIC //.$Runtime "pm_variant" (type.method [(list //.$Variant runtime.$Tag runtime.$Flag) runtime.$Value (list)])) - _.DUP - (_.IFNULL @fail) - (_.GOTO @success) - (_.label @fail) - _.POP - (_.GOTO @else) - (_.label @success) - pushI)))) - ([synthesis.side/left _.NULL function.identity] - [synthesis.side/right (_.string "") .inc]) - - (^ (synthesis.member/left lefts)) - (operation@wrap (.let [accessI (.case lefts - 0 - _.AALOAD - - lefts - (_.INVOKESTATIC //.$Runtime "tuple_left" (type.method [(list //.$Tuple runtime.$Index) //.$Value (list)])))] - (|>> peekI - (_.CHECKCAST //.$Tuple) - (_.int (.int lefts)) - accessI - pushI))) - - (^ (synthesis.member/right lefts)) - (operation@wrap (|>> peekI - (_.CHECKCAST //.$Tuple) - (_.int (.int lefts)) - (_.INVOKESTATIC //.$Runtime "tuple_right" (type.method [(list //.$Tuple runtime.$Index) //.$Value (list)])) - pushI)) - - ## Extra optimization - (^ (synthesis.path/seq - (synthesis.member/left 0) - (synthesis.!bind-top register thenP))) - (do phase.monad - [then! (path' stack-depth @else @end phase archive thenP)] - (wrap (|>> peekI - (_.CHECKCAST //.$Tuple) - (_.int +0) - _.AALOAD - (_.ASTORE register) - then!))) - - ## Extra optimization - (^template [<pm> <getter>] - (^ (synthesis.path/seq - (<pm> lefts) - (synthesis.!bind-top register thenP))) - (do phase.monad - [then! (path' stack-depth @else @end phase archive thenP)] - (wrap (|>> peekI - (_.CHECKCAST //.$Tuple) - (_.int (.int lefts)) - (_.INVOKESTATIC //.$Runtime <getter> (type.method [(list //.$Tuple runtime.$Index) //.$Value (list)])) - (_.ASTORE register) - then!)))) - ([synthesis.member/left "tuple_left"] - [synthesis.member/right "tuple_right"]) - - (#synthesis.Alt leftP rightP) - (do phase.monad - [@alt-else _.make-label - leftI (path' (inc stack-depth) @alt-else @end phase archive leftP) - rightI (path' stack-depth @else @end phase archive rightP)] - (wrap (|>> _.DUP - leftI - (_.label @alt-else) - _.POP - rightI))) - - (#synthesis.Seq leftP rightP) - (do phase.monad - [leftI (path' stack-depth @else @end phase archive leftP) - rightI (path' stack-depth @else @end phase archive rightP)] - (wrap (|>> leftI - rightI))) - )) - -(def: (path @end phase archive path) - (-> Label Phase Archive Path (Operation Inst)) - (do phase.monad - [@else _.make-label - pathI (..path' 1 @else @end phase archive path)] - (wrap (|>> pathI - (_.label @else) - _.POP - (_.INVOKESTATIC //.$Runtime "pm_fail" (type.method [(list) type.void (list)])) - _.NULL - (_.GOTO @end))))) - -(def: #export (if phase archive [testS thenS elseS]) - (Generator [Synthesis Synthesis Synthesis]) - (do phase.monad - [testI (phase archive testS) - thenI (phase archive thenS) - elseI (phase archive elseS)] - (wrap (<| _.with-label (function (_ @else)) - _.with-label (function (_ @end)) - (|>> testI - (_.unwrap type.boolean) - (_.IFEQ @else) - thenI - (_.GOTO @end) - (_.label @else) - elseI - (_.label @end)))))) - -(def: #export (let phase archive [inputS register exprS]) - (Generator [Synthesis Nat Synthesis]) - (do phase.monad - [inputI (phase archive inputS) - exprI (phase archive exprS)] - (wrap (|>> inputI - (_.ASTORE register) - exprI)))) - -(def: #export (case phase archive [valueS path]) - (Generator [Synthesis Path]) - (do phase.monad - [@end _.make-label - valueI (phase archive valueS) - pathI (..path @end phase archive path)] - (wrap (|>> _.NULL - valueI - pushI - pathI - (_.label @end))))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/common.lux b/new-luxc/source/luxc/lang/translation/jvm/common.lux deleted file mode 100644 index 6cd7f4f2f..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/common.lux +++ /dev/null @@ -1,72 +0,0 @@ -(.module: - [lux #* - ## [abstract - ## [monad (#+ do)]] - ## [control - ## ["." try (#+ Try)] - ## ["ex" exception (#+ exception:)] - ## ["." io]] - ## [data - ## [binary (#+ Binary)] - ## ["." text ("#/." hash) - ## format] - ## [collection - ## ["." dictionary (#+ Dictionary)]]] - ## ["." macro] - ## [host (#+ import:)] - ## [tool - ## [compiler - ## [reference (#+ Register)] - ## ["." name] - ## ["." phase]]] - ] - ## [luxc - ## [lang - ## [host - ## ["." jvm - ## [type]]]]] - ) - -## (def: #export (with-artifacts action) -## (All [a] (-> (Meta a) (Meta [Artifacts a]))) -## (function (_ state) -## (case (action (update@ #.host -## (|>> (:coerce Host) -## (set@ #artifacts (dictionary.new text.hash)) -## (:coerce Nothing)) -## state)) -## (#try.Success [state' output]) -## (#try.Success [(update@ #.host -## (|>> (:coerce Host) -## (set@ #artifacts (|> (get@ #.host state) (:coerce Host) (get@ #artifacts))) -## (:coerce Nothing)) -## state') -## [(|> state' (get@ #.host) (:coerce Host) (get@ #artifacts)) -## output]]) - -## (#try.Failure error) -## (#try.Failure error)))) - -## (def: #export (load-definition state) -## (-> Lux (-> Name Binary (Try Any))) -## (function (_ (^@ def-name [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 state) -## (do macro.monad -## [_ (..store-class class-name def-bytecode) -## class (..load-class class-name)] -## (case (do try.monad -## [field (Class::getField [..value-field] class)] -## (Field::get [#.None] field)) -## (#try.Success (#.Some def-value)) -## (wrap def-value) - -## (#try.Success #.None) -## (phase.throw invalid-definition-value (%name def-name)) - -## (#try.Failure error) -## (phase.throw cannot-load-definition -## (format "Definition: " (%name def-name) "\n" -## "Error:\n" -## error)))))))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/expression.lux b/new-luxc/source/luxc/lang/translation/jvm/expression.lux deleted file mode 100644 index 144e35f9b..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/expression.lux +++ /dev/null @@ -1,72 +0,0 @@ -(.module: - [lux #* - [tool - [compiler - [language - [lux - ["." synthesis] - [phase - ["." extension]]]]]]] - [luxc - [lang - [host - [jvm (#+ Phase)]]]] - [// - ["." common] - ["." primitive] - ["." structure] - ["." reference] - ["." case] - ["." loop] - ["." function]]) - -(def: #export (translate archive synthesis) - Phase - (case synthesis - (^ (synthesis.bit value)) - (primitive.bit value) - - (^ (synthesis.i64 value)) - (primitive.i64 value) - - (^ (synthesis.f64 value)) - (primitive.f64 value) - - (^ (synthesis.text value)) - (primitive.text value) - - (^ (synthesis.variant data)) - (structure.variant translate archive data) - - (^ (synthesis.tuple members)) - (structure.tuple translate archive members) - - (^ (synthesis.variable variable)) - (reference.variable archive variable) - - (^ (synthesis.constant constant)) - (reference.constant archive constant) - - (^ (synthesis.branch/let data)) - (case.let translate archive data) - - (^ (synthesis.branch/if data)) - (case.if translate archive data) - - (^ (synthesis.branch/case data)) - (case.case translate archive data) - - (^ (synthesis.loop/recur data)) - (loop.recur translate archive data) - - (^ (synthesis.loop/scope data)) - (loop.scope translate archive data) - - (^ (synthesis.function/apply data)) - (function.call translate archive data) - - (^ (synthesis.function/abstraction data)) - (function.function translate archive data) - - (#synthesis.Extension extension) - (extension.apply archive translate extension))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/extension.lux b/new-luxc/source/luxc/lang/translation/jvm/extension.lux deleted file mode 100644 index 9066dd156..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/extension.lux +++ /dev/null @@ -1,16 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - [//// - [host - [jvm (#+ Bundle)]]] - ["." / #_ - ["#." common] - ["#." host]]) - -(def: #export bundle - Bundle - (dictionary.merge /common.bundle - /host.bundle)) diff --git a/new-luxc/source/luxc/lang/translation/jvm/extension/common.lux b/new-luxc/source/luxc/lang/translation/jvm/extension/common.lux deleted file mode 100644 index 383415c0a..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/extension/common.lux +++ /dev/null @@ -1,388 +0,0 @@ -(.module: - [lux (#- Type) - [abstract - ["." monad (#+ do)]] - [control - ["." try] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - [number - ["f" frac]] - [collection - ["." list ("#@." monad)] - ["." dictionary]]] - [target - [jvm - ["." type]]] - [tool - [compiler - ["." phase] - [meta - [archive (#+ Archive)]] - [language - [lux - ["." synthesis (#+ Synthesis %synthesis)] - [phase - [generation - [extension (#+ Nullary Unary Binary Trinary Variadic - nullary unary binary trinary variadic)]] - ["." extension - ["." bundle]]]]]]] - [host (#+ import:)]] - [luxc - [lang - [host - ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase) - ["_" inst]]]]] - ["." /// - ["." runtime]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text Phase Archive s (Operation Inst))] - Handler)) - (function (_ extension-name phase archive input) - (case (<s>.run parser input) - (#try.Success input') - (handler extension-name phase archive input') - - (#try.Failure error) - (phase.throw extension.invalid-syntax [extension-name %synthesis input])))) - -(import: java/lang/Double - (#static MIN_VALUE Double) - (#static MAX_VALUE Double)) - -(def: $String (type.class "java.lang.String" (list))) -(def: $CharSequence (type.class "java.lang.CharSequence" (list))) -(def: $System (type.class "java.lang.System" (list))) -(def: $Object (type.class "java.lang.Object" (list))) - -(def: lux-intI Inst (|>> _.I2L (_.wrap type.long))) -(def: jvm-intI Inst (|>> (_.unwrap type.long) _.L2I)) -(def: check-stringI Inst (_.CHECKCAST $String)) - -(def: (predicateI tester) - (-> (-> Label Inst) - Inst) - (let [$Boolean (type.class "java.lang.Boolean" (list))] - (<| _.with-label (function (_ @then)) - _.with-label (function (_ @end)) - (|>> (tester @then) - (_.GETSTATIC $Boolean "FALSE" $Boolean) - (_.GOTO @end) - (_.label @then) - (_.GETSTATIC $Boolean "TRUE" $Boolean) - (_.label @end) - )))) - -(def: unitI Inst (_.string synthesis.unit)) - -## TODO: Get rid of this ASAP -(def: lux::syntax-char-case! - (..custom [($_ <>.and - <s>.any - <s>.any - (<>.some (<s>.tuple ($_ <>.and - (<s>.tuple (<>.many <s>.i64)) - <s>.any)))) - (function (_ extension-name phase archive [input else conditionals]) - (<| _.with-label (function (_ @end)) - _.with-label (function (_ @else)) - (do {@ phase.monad} - [inputG (phase archive input) - elseG (phase archive else) - conditionalsG+ (: (Operation (List [(List [Int Label]) - Inst])) - (monad.map @ (function (_ [chars branch]) - (do @ - [branchG (phase archive branch)] - (wrap (<| _.with-label (function (_ @branch)) - [(list@map (function (_ char) - [(.int char) @branch]) - chars) - (|>> (_.label @branch) - branchG - (_.GOTO @end))])))) - conditionals)) - #let [table (|> conditionalsG+ - (list@map product.left) - list@join) - conditionalsG (|> conditionalsG+ - (list@map product.right) - _.fuse)]] - (wrap (|>> inputG (_.unwrap type.long) _.L2I - (_.LOOKUPSWITCH @else table) - conditionalsG - (_.label @else) - elseG - (_.label @end) - )))))])) - -(def: (lux::is [referenceI sampleI]) - (Binary Inst) - (|>> referenceI - sampleI - (predicateI _.IF_ACMPEQ))) - -(def: (lux::try riskyI) - (Unary Inst) - (|>> riskyI - (_.CHECKCAST ///.$Function) - (_.INVOKESTATIC ///.$Runtime "try" runtime.try))) - -(template [<name> <op>] - [(def: (<name> [maskI inputI]) - (Binary Inst) - (|>> inputI (_.unwrap type.long) - maskI (_.unwrap type.long) - <op> (_.wrap type.long)))] - - [i64::and _.LAND] - [i64::or _.LOR] - [i64::xor _.LXOR] - ) - -(template [<name> <op>] - [(def: (<name> [shiftI inputI]) - (Binary Inst) - (|>> inputI (_.unwrap type.long) - shiftI jvm-intI - <op> - (_.wrap type.long)))] - - [i64::left-shift _.LSHL] - [i64::arithmetic-right-shift _.LSHR] - [i64::logical-right-shift _.LUSHR] - ) - -(template [<name> <const> <type>] - [(def: (<name> _) - (Nullary Inst) - (|>> <const> (_.wrap <type>)))] - - [f64::smallest (_.double (Double::MIN_VALUE)) type.double] - [f64::min (_.double (f.* -1.0 (Double::MAX_VALUE))) type.double] - [f64::max (_.double (Double::MAX_VALUE)) type.double] - ) - -(template [<name> <type> <op>] - [(def: (<name> [paramI subjectI]) - (Binary Inst) - (|>> subjectI (_.unwrap <type>) - paramI (_.unwrap <type>) - <op> - (_.wrap <type>)))] - - [i64::+ type.long _.LADD] - [i64::- type.long _.LSUB] - [i64::* type.long _.LMUL] - [i64::/ type.long _.LDIV] - [i64::% type.long _.LREM] - - [f64::+ type.double _.DADD] - [f64::- type.double _.DSUB] - [f64::* type.double _.DMUL] - [f64::/ type.double _.DDIV] - [f64::% type.double _.DREM] - ) - -(template [<eq> <lt> <type> <cmp>] - [(template [<name> <reference>] - [(def: (<name> [paramI subjectI]) - (Binary Inst) - (|>> subjectI (_.unwrap <type>) - paramI (_.unwrap <type>) - <cmp> - (_.int <reference>) - (predicateI _.IF_ICMPEQ)))] - - [<eq> +0] - [<lt> -1])] - - [i64::= i64::< type.long _.LCMP] - [f64::= f64::< type.double _.DCMPG] - ) - -(template [<name> <prepare> <transform>] - [(def: (<name> inputI) - (Unary Inst) - (|>> inputI <prepare> <transform>))] - - [i64::f64 (_.unwrap type.long) (<| (_.wrap type.double) _.L2D)] - [i64::char (_.unwrap type.long) - ((|>> _.L2I _.I2C (_.INVOKESTATIC (type.class "java.lang.Character" (list)) "toString" (type.method [(list type.char) $String (list)]))))] - - [f64::i64 (_.unwrap type.double) (<| (_.wrap type.long) _.D2L)] - [f64::encode (_.unwrap type.double) - (_.INVOKESTATIC (type.class "java.lang.Double" (list)) "toString" (type.method [(list type.double) $String (list)]))] - [f64::decode ..check-stringI - (_.INVOKESTATIC ///.$Runtime "decode_frac" (type.method [(list $String) ///.$Variant (list)]))] - ) - -(def: (text::size inputI) - (Unary Inst) - (|>> inputI - ..check-stringI - (_.INVOKEVIRTUAL $String "length" (type.method [(list) type.int (list)])) - lux-intI)) - -(template [<name> <pre-subject> <pre-param> <op> <post>] - [(def: (<name> [paramI subjectI]) - (Binary Inst) - (|>> subjectI <pre-subject> - paramI <pre-param> - <op> <post>))] - - [text::= (<|) (<|) - (_.INVOKEVIRTUAL $Object "equals" (type.method [(list $Object) type.boolean (list)])) - (_.wrap type.boolean)] - [text::< ..check-stringI ..check-stringI - (_.INVOKEVIRTUAL $String "compareTo" (type.method [(list $String) type.int (list)])) - (predicateI _.IFLT)] - [text::char ..check-stringI jvm-intI - (_.INVOKEVIRTUAL $String "charAt" (type.method [(list type.int) type.char (list)])) - lux-intI] - ) - -(def: (text::concat [leftI rightI]) - (Binary Inst) - (|>> leftI ..check-stringI - rightI ..check-stringI - (_.INVOKEVIRTUAL $String "concat" (type.method [(list $String) $String (list)])))) - -(def: (text::clip [startI endI subjectI]) - (Trinary Inst) - (|>> subjectI ..check-stringI - startI jvm-intI - endI jvm-intI - (_.INVOKEVIRTUAL $String "substring" (type.method [(list type.int type.int) $String (list)])))) - -(def: index-method (type.method [(list $String type.int) type.int (list)])) -(def: (text::index [startI partI textI]) - (Trinary Inst) - (<| _.with-label (function (_ @not-found)) - _.with-label (function (_ @end)) - (|>> textI ..check-stringI - partI ..check-stringI - startI jvm-intI - (_.INVOKEVIRTUAL $String "indexOf" index-method) - _.DUP - (_.int -1) - (_.IF_ICMPEQ @not-found) - lux-intI - runtime.someI - (_.GOTO @end) - (_.label @not-found) - _.POP - runtime.noneI - (_.label @end)))) - -(def: string-method (type.method [(list $String) type.void (list)])) -(def: (io::log messageI) - (Unary Inst) - (let [$PrintStream (type.class "java.io.PrintStream" (list))] - (|>> (_.GETSTATIC $System "out" $PrintStream) - messageI - ..check-stringI - (_.INVOKEVIRTUAL $PrintStream "println" string-method) - unitI))) - -(def: (io::error messageI) - (Unary Inst) - (let [$Error (type.class "java.lang.Error" (list))] - (|>> (_.NEW $Error) - _.DUP - messageI - ..check-stringI - (_.INVOKESPECIAL $Error "<init>" string-method) - _.ATHROW))) - -(def: (io::exit codeI) - (Unary Inst) - (|>> codeI jvm-intI - (_.INVOKESTATIC $System "exit" (type.method [(list type.int) type.void (list)])) - _.NULL)) - -(def: (io::current-time _) - (Nullary Inst) - (|>> (_.INVOKESTATIC $System "currentTimeMillis" (type.method [(list) type.long (list)])) - (_.wrap type.long))) - -(def: bundle::lux - Bundle - (|> (: Bundle bundle.empty) - (bundle.install "syntax char case!" lux::syntax-char-case!) - (bundle.install "is" (binary lux::is)) - (bundle.install "try" (unary lux::try)))) - -(def: bundle::i64 - Bundle - (<| (bundle.prefix "i64") - (|> (: Bundle bundle.empty) - (bundle.install "and" (binary i64::and)) - (bundle.install "or" (binary i64::or)) - (bundle.install "xor" (binary i64::xor)) - (bundle.install "left-shift" (binary i64::left-shift)) - (bundle.install "logical-right-shift" (binary i64::logical-right-shift)) - (bundle.install "arithmetic-right-shift" (binary i64::arithmetic-right-shift)) - (bundle.install "=" (binary i64::=)) - (bundle.install "<" (binary i64::<)) - (bundle.install "+" (binary i64::+)) - (bundle.install "-" (binary i64::-)) - (bundle.install "*" (binary i64::*)) - (bundle.install "/" (binary i64::/)) - (bundle.install "%" (binary i64::%)) - (bundle.install "f64" (unary i64::f64)) - (bundle.install "char" (unary i64::char))))) - -(def: bundle::f64 - Bundle - (<| (bundle.prefix "f64") - (|> (: Bundle bundle.empty) - (bundle.install "+" (binary f64::+)) - (bundle.install "-" (binary f64::-)) - (bundle.install "*" (binary f64::*)) - (bundle.install "/" (binary f64::/)) - (bundle.install "%" (binary f64::%)) - (bundle.install "=" (binary f64::=)) - (bundle.install "<" (binary f64::<)) - (bundle.install "smallest" (nullary f64::smallest)) - (bundle.install "min" (nullary f64::min)) - (bundle.install "max" (nullary f64::max)) - (bundle.install "i64" (unary f64::i64)) - (bundle.install "encode" (unary f64::encode)) - (bundle.install "decode" (unary f64::decode))))) - -(def: bundle::text - Bundle - (<| (bundle.prefix "text") - (|> (: Bundle bundle.empty) - (bundle.install "=" (binary text::=)) - (bundle.install "<" (binary text::<)) - (bundle.install "concat" (binary text::concat)) - (bundle.install "index" (trinary text::index)) - (bundle.install "size" (unary text::size)) - (bundle.install "char" (binary text::char)) - (bundle.install "clip" (trinary text::clip))))) - -(def: bundle::io - Bundle - (<| (bundle.prefix "io") - (|> (: Bundle bundle.empty) - (bundle.install "log" (unary io::log)) - (bundle.install "error" (unary io::error)) - (bundle.install "exit" (unary io::exit)) - (bundle.install "current-time" (nullary io::current-time))))) - -(def: #export bundle - Bundle - (<| (bundle.prefix "lux") - (|> bundle::lux - (dictionary.merge bundle::i64) - (dictionary.merge bundle::f64) - (dictionary.merge bundle::text) - (dictionary.merge bundle::io)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/extension/host.lux b/new-luxc/source/luxc/lang/translation/jvm/extension/host.lux deleted file mode 100644 index 7b90a8e4f..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/extension/host.lux +++ /dev/null @@ -1,1047 +0,0 @@ -(.module: - [lux (#- Type primitive int char type) - [host (#+ import:)] - [abstract - ["." monad (#+ do)]] - [control - ["." exception (#+ exception:)] - ["." function] - ["<>" parser ("#@." monad) - ["<t>" text] - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - ["." maybe] - ["." text ("#@." equivalence) - ["%" format (#+ format)]] - [number - ["." nat]] - [collection - ["." list ("#@." monad)] - ["." dictionary (#+ Dictionary)] - ["." set]]] - [target - [jvm - ["." type (#+ Type Typed Argument) - ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] - ["." box] - ["." reflection] - ["." signature] - ["." parser]]]] - [tool - [compiler - ["." reference (#+ Variable)] - ["." phase ("#@." monad)] - [meta - [archive (#+ Archive)]] - [language - [lux - [analysis (#+ Environment)] - ["." synthesis (#+ Synthesis Path %synthesis)] - ["." generation] - [phase - [generation - [extension (#+ Nullary Unary Binary - nullary unary binary)]] - [analysis - [".A" reference]] - ["." extension - ["." bundle] - [analysis - ["/" jvm]]]]]]]]] - [luxc - [lang - [host - ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase) - ["_" inst] - ["_." def]]]]] - ["." // #_ - [common (#+ custom)] - ["/#" // - ["#." reference] - ["#." function]]]) - -(template [<name> <category> <parser>] - [(def: #export <name> - (Parser (Type <category>)) - (<t>.embed <parser> <s>.text))] - - [var Var parser.var] - [class Class parser.class] - [object Object parser.object] - [value Value parser.value] - [return Return parser.return] - ) - -(exception: #export (not-an-object-array {arrayJT (Type Array)}) - (exception.report - ["JVM Type" (|> arrayJT type.signature signature.signature)])) - -(def: #export object-array - (Parser (Type Object)) - (do <>.monad - [arrayJT (<t>.embed parser.array <s>.text)] - (case (parser.array? arrayJT) - (#.Some elementJT) - (case (parser.object? elementJT) - (#.Some elementJT) - (wrap elementJT) - - #.None - (<>.fail (exception.construct ..not-an-object-array arrayJT))) - - #.None - (undefined)))) - -(template [<name> <inst>] - [(def: <name> - Inst - <inst>)] - - [L2S (|>> _.L2I _.I2S)] - [L2B (|>> _.L2I _.I2B)] - [L2C (|>> _.L2I _.I2C)] - ) - -(template [<conversion> <name>] - [(def: (<name> inputI) - (Unary Inst) - (if (is? _.NOP <conversion>) - inputI - (|>> inputI - <conversion>)))] - - [_.D2F conversion::double-to-float] - [_.D2I conversion::double-to-int] - [_.D2L conversion::double-to-long] - [_.F2D conversion::float-to-double] - [_.F2I conversion::float-to-int] - [_.F2L conversion::float-to-long] - [_.I2B conversion::int-to-byte] - [_.I2C conversion::int-to-char] - [_.I2D conversion::int-to-double] - [_.I2F conversion::int-to-float] - [_.I2L conversion::int-to-long] - [_.I2S conversion::int-to-short] - [_.L2D conversion::long-to-double] - [_.L2F conversion::long-to-float] - [_.L2I conversion::long-to-int] - [..L2S conversion::long-to-short] - [..L2B conversion::long-to-byte] - [..L2C conversion::long-to-char] - [_.I2B conversion::char-to-byte] - [_.I2S conversion::char-to-short] - [_.NOP conversion::char-to-int] - [_.I2L conversion::char-to-long] - [_.I2L conversion::byte-to-long] - [_.I2L conversion::short-to-long] - ) - -(def: conversion - Bundle - (<| (bundle.prefix "conversion") - (|> (: Bundle bundle.empty) - (bundle.install "double-to-float" (unary conversion::double-to-float)) - (bundle.install "double-to-int" (unary conversion::double-to-int)) - (bundle.install "double-to-long" (unary conversion::double-to-long)) - (bundle.install "float-to-double" (unary conversion::float-to-double)) - (bundle.install "float-to-int" (unary conversion::float-to-int)) - (bundle.install "float-to-long" (unary conversion::float-to-long)) - (bundle.install "int-to-byte" (unary conversion::int-to-byte)) - (bundle.install "int-to-char" (unary conversion::int-to-char)) - (bundle.install "int-to-double" (unary conversion::int-to-double)) - (bundle.install "int-to-float" (unary conversion::int-to-float)) - (bundle.install "int-to-long" (unary conversion::int-to-long)) - (bundle.install "int-to-short" (unary conversion::int-to-short)) - (bundle.install "long-to-double" (unary conversion::long-to-double)) - (bundle.install "long-to-float" (unary conversion::long-to-float)) - (bundle.install "long-to-int" (unary conversion::long-to-int)) - (bundle.install "long-to-short" (unary conversion::long-to-short)) - (bundle.install "long-to-byte" (unary conversion::long-to-byte)) - (bundle.install "long-to-char" (unary conversion::long-to-char)) - (bundle.install "char-to-byte" (unary conversion::char-to-byte)) - (bundle.install "char-to-short" (unary conversion::char-to-short)) - (bundle.install "char-to-int" (unary conversion::char-to-int)) - (bundle.install "char-to-long" (unary conversion::char-to-long)) - (bundle.install "byte-to-long" (unary conversion::byte-to-long)) - (bundle.install "short-to-long" (unary conversion::short-to-long)) - ))) - -(template [<name> <op>] - [(def: (<name> [xI yI]) - (Binary Inst) - (|>> xI - yI - <op>))] - - [int::+ _.IADD] - [int::- _.ISUB] - [int::* _.IMUL] - [int::/ _.IDIV] - [int::% _.IREM] - [int::and _.IAND] - [int::or _.IOR] - [int::xor _.IXOR] - [int::shl _.ISHL] - [int::shr _.ISHR] - [int::ushr _.IUSHR] - - [long::+ _.LADD] - [long::- _.LSUB] - [long::* _.LMUL] - [long::/ _.LDIV] - [long::% _.LREM] - [long::and _.LAND] - [long::or _.LOR] - [long::xor _.LXOR] - [long::shl _.LSHL] - [long::shr _.LSHR] - [long::ushr _.LUSHR] - - [float::+ _.FADD] - [float::- _.FSUB] - [float::* _.FMUL] - [float::/ _.FDIV] - [float::% _.FREM] - - [double::+ _.DADD] - [double::- _.DSUB] - [double::* _.DMUL] - [double::/ _.DDIV] - [double::% _.DREM] - ) - -(def: $Boolean (type.class box.boolean (list))) -(def: falseI (_.GETSTATIC $Boolean "FALSE" $Boolean)) -(def: trueI (_.GETSTATIC $Boolean "TRUE" $Boolean)) - -(template [<name> <op>] - [(def: (<name> [xI yI]) - (Binary Inst) - (<| _.with-label (function (_ @then)) - _.with-label (function (_ @end)) - (|>> xI - yI - (<op> @then) - falseI - (_.GOTO @end) - (_.label @then) - trueI - (_.label @end))))] - - [int::= _.IF_ICMPEQ] - [int::< _.IF_ICMPLT] - - [char::= _.IF_ICMPEQ] - [char::< _.IF_ICMPLT] - ) - -(template [<name> <op> <reference>] - [(def: (<name> [xI yI]) - (Binary Inst) - (<| _.with-label (function (_ @then)) - _.with-label (function (_ @end)) - (|>> xI - yI - <op> - (_.int <reference>) - (_.IF_ICMPEQ @then) - falseI - (_.GOTO @end) - (_.label @then) - trueI - (_.label @end))))] - - [long::= _.LCMP +0] - [long::< _.LCMP -1] - - [float::= _.FCMPG +0] - [float::< _.FCMPG -1] - - [double::= _.DCMPG +0] - [double::< _.DCMPG -1] - ) - -(def: int - Bundle - (<| (bundle.prefix (reflection.reflection reflection.int)) - (|> (: Bundle bundle.empty) - (bundle.install "+" (binary int::+)) - (bundle.install "-" (binary int::-)) - (bundle.install "*" (binary int::*)) - (bundle.install "/" (binary int::/)) - (bundle.install "%" (binary int::%)) - (bundle.install "=" (binary int::=)) - (bundle.install "<" (binary int::<)) - (bundle.install "and" (binary int::and)) - (bundle.install "or" (binary int::or)) - (bundle.install "xor" (binary int::xor)) - (bundle.install "shl" (binary int::shl)) - (bundle.install "shr" (binary int::shr)) - (bundle.install "ushr" (binary int::ushr)) - ))) - -(def: long - Bundle - (<| (bundle.prefix (reflection.reflection reflection.long)) - (|> (: Bundle bundle.empty) - (bundle.install "+" (binary long::+)) - (bundle.install "-" (binary long::-)) - (bundle.install "*" (binary long::*)) - (bundle.install "/" (binary long::/)) - (bundle.install "%" (binary long::%)) - (bundle.install "=" (binary long::=)) - (bundle.install "<" (binary long::<)) - (bundle.install "and" (binary long::and)) - (bundle.install "or" (binary long::or)) - (bundle.install "xor" (binary long::xor)) - (bundle.install "shl" (binary long::shl)) - (bundle.install "shr" (binary long::shr)) - (bundle.install "ushr" (binary long::ushr)) - ))) - -(def: float - Bundle - (<| (bundle.prefix (reflection.reflection reflection.float)) - (|> (: Bundle bundle.empty) - (bundle.install "+" (binary float::+)) - (bundle.install "-" (binary float::-)) - (bundle.install "*" (binary float::*)) - (bundle.install "/" (binary float::/)) - (bundle.install "%" (binary float::%)) - (bundle.install "=" (binary float::=)) - (bundle.install "<" (binary float::<)) - ))) - -(def: double - Bundle - (<| (bundle.prefix (reflection.reflection reflection.double)) - (|> (: Bundle bundle.empty) - (bundle.install "+" (binary double::+)) - (bundle.install "-" (binary double::-)) - (bundle.install "*" (binary double::*)) - (bundle.install "/" (binary double::/)) - (bundle.install "%" (binary double::%)) - (bundle.install "=" (binary double::=)) - (bundle.install "<" (binary double::<)) - ))) - -(def: char - Bundle - (<| (bundle.prefix (reflection.reflection reflection.char)) - (|> (: Bundle bundle.empty) - (bundle.install "=" (binary char::=)) - (bundle.install "<" (binary char::<)) - ))) - -(def: (primitive-array-length-handler jvm-primitive) - (-> (Type Primitive) Handler) - (..custom - [<s>.any - (function (_ extension-name generate archive arrayS) - (do phase.monad - [arrayI (generate archive arrayS)] - (wrap (|>> arrayI - (_.CHECKCAST (type.array jvm-primitive)) - _.ARRAYLENGTH))))])) - -(def: array::length::object - Handler - (..custom - [($_ <>.and ..object-array <s>.any) - (function (_ extension-name generate archive [elementJT arrayS]) - (do phase.monad - [arrayI (generate archive arrayS)] - (wrap (|>> arrayI - (_.CHECKCAST (type.array elementJT)) - _.ARRAYLENGTH))))])) - -(def: (new-primitive-array-handler jvm-primitive) - (-> (Type Primitive) Handler) - (function (_ extension-name generate archive inputs) - (case inputs - (^ (list lengthS)) - (do phase.monad - [lengthI (generate archive lengthS)] - (wrap (|>> lengthI - (_.array jvm-primitive)))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))) - -(def: array::new::object - Handler - (..custom - [($_ <>.and ..object <s>.any) - (function (_ extension-name generate archive [objectJT lengthS]) - (do phase.monad - [lengthI (generate archive lengthS)] - (wrap (|>> lengthI - (_.ANEWARRAY objectJT)))))])) - -(def: (read-primitive-array-handler jvm-primitive loadI) - (-> (Type Primitive) Inst Handler) - (function (_ extension-name generate archive inputs) - (case inputs - (^ (list idxS arrayS)) - (do phase.monad - [arrayI (generate archive arrayS) - idxI (generate archive idxS)] - (wrap (|>> arrayI - (_.CHECKCAST (type.array jvm-primitive)) - idxI - loadI))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))) - -(def: array::read::object - Handler - (..custom - [($_ <>.and ..object-array <s>.any <s>.any) - (function (_ extension-name generate archive [elementJT idxS arrayS]) - (do phase.monad - [arrayI (generate archive arrayS) - idxI (generate archive idxS)] - (wrap (|>> arrayI - (_.CHECKCAST (type.array elementJT)) - idxI - _.AALOAD))))])) - -(def: (write-primitive-array-handler jvm-primitive storeI) - (-> (Type Primitive) Inst Handler) - (function (_ extension-name generate archive inputs) - (case inputs - (^ (list idxS valueS arrayS)) - (do phase.monad - [arrayI (generate archive arrayS) - idxI (generate archive idxS) - valueI (generate archive valueS)] - (wrap (|>> arrayI - (_.CHECKCAST (type.array jvm-primitive)) - _.DUP - idxI - valueI - storeI))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))) - -(def: array::write::object - Handler - (..custom - [($_ <>.and ..object-array <s>.any <s>.any <s>.any) - (function (_ extension-name generate archive [elementJT idxS valueS arrayS]) - (do phase.monad - [arrayI (generate archive arrayS) - idxI (generate archive idxS) - valueI (generate archive valueS)] - (wrap (|>> arrayI - (_.CHECKCAST (type.array elementJT)) - _.DUP - idxI - valueI - _.AASTORE))))])) - -(def: array - Bundle - (<| (bundle.prefix "array") - (|> bundle.empty - (dictionary.merge (<| (bundle.prefix "length") - (|> bundle.empty - (bundle.install (reflection.reflection reflection.boolean) (primitive-array-length-handler type.boolean)) - (bundle.install (reflection.reflection reflection.byte) (primitive-array-length-handler type.byte)) - (bundle.install (reflection.reflection reflection.short) (primitive-array-length-handler type.short)) - (bundle.install (reflection.reflection reflection.int) (primitive-array-length-handler type.int)) - (bundle.install (reflection.reflection reflection.long) (primitive-array-length-handler type.long)) - (bundle.install (reflection.reflection reflection.float) (primitive-array-length-handler type.float)) - (bundle.install (reflection.reflection reflection.double) (primitive-array-length-handler type.double)) - (bundle.install (reflection.reflection reflection.char) (primitive-array-length-handler type.char)) - (bundle.install "object" array::length::object)))) - (dictionary.merge (<| (bundle.prefix "new") - (|> bundle.empty - (bundle.install (reflection.reflection reflection.boolean) (new-primitive-array-handler type.boolean)) - (bundle.install (reflection.reflection reflection.byte) (new-primitive-array-handler type.byte)) - (bundle.install (reflection.reflection reflection.short) (new-primitive-array-handler type.short)) - (bundle.install (reflection.reflection reflection.int) (new-primitive-array-handler type.int)) - (bundle.install (reflection.reflection reflection.long) (new-primitive-array-handler type.long)) - (bundle.install (reflection.reflection reflection.float) (new-primitive-array-handler type.float)) - (bundle.install (reflection.reflection reflection.double) (new-primitive-array-handler type.double)) - (bundle.install (reflection.reflection reflection.char) (new-primitive-array-handler type.char)) - (bundle.install "object" array::new::object)))) - (dictionary.merge (<| (bundle.prefix "read") - (|> bundle.empty - (bundle.install (reflection.reflection reflection.boolean) (read-primitive-array-handler type.boolean _.BALOAD)) - (bundle.install (reflection.reflection reflection.byte) (read-primitive-array-handler type.byte _.BALOAD)) - (bundle.install (reflection.reflection reflection.short) (read-primitive-array-handler type.short _.SALOAD)) - (bundle.install (reflection.reflection reflection.int) (read-primitive-array-handler type.int _.IALOAD)) - (bundle.install (reflection.reflection reflection.long) (read-primitive-array-handler type.long _.LALOAD)) - (bundle.install (reflection.reflection reflection.float) (read-primitive-array-handler type.float _.FALOAD)) - (bundle.install (reflection.reflection reflection.double) (read-primitive-array-handler type.double _.DALOAD)) - (bundle.install (reflection.reflection reflection.char) (read-primitive-array-handler type.char _.CALOAD)) - (bundle.install "object" array::read::object)))) - (dictionary.merge (<| (bundle.prefix "write") - (|> bundle.empty - (bundle.install (reflection.reflection reflection.boolean) (write-primitive-array-handler type.boolean _.BASTORE)) - (bundle.install (reflection.reflection reflection.byte) (write-primitive-array-handler type.byte _.BASTORE)) - (bundle.install (reflection.reflection reflection.short) (write-primitive-array-handler type.short _.SASTORE)) - (bundle.install (reflection.reflection reflection.int) (write-primitive-array-handler type.int _.IASTORE)) - (bundle.install (reflection.reflection reflection.long) (write-primitive-array-handler type.long _.LASTORE)) - (bundle.install (reflection.reflection reflection.float) (write-primitive-array-handler type.float _.FASTORE)) - (bundle.install (reflection.reflection reflection.double) (write-primitive-array-handler type.double _.DASTORE)) - (bundle.install (reflection.reflection reflection.char) (write-primitive-array-handler type.char _.CASTORE)) - (bundle.install "object" array::write::object)))) - ))) - -(def: (object::null _) - (Nullary Inst) - _.NULL) - -(def: (object::null? objectI) - (Unary Inst) - (<| _.with-label (function (_ @then)) - _.with-label (function (_ @end)) - (|>> objectI - (_.IFNULL @then) - falseI - (_.GOTO @end) - (_.label @then) - trueI - (_.label @end)))) - -(def: (object::synchronized [monitorI exprI]) - (Binary Inst) - (|>> monitorI - _.DUP - _.MONITORENTER - exprI - _.SWAP - _.MONITOREXIT)) - -(def: (object::throw exceptionI) - (Unary Inst) - (|>> exceptionI - _.ATHROW)) - -(def: $Class (type.class "java.lang.Class" (list))) - -(def: (object::class extension-name generate archive inputs) - Handler - (case inputs - (^ (list (synthesis.text class))) - (do phase.monad - [] - (wrap (|>> (_.string class) - (_.INVOKESTATIC $Class "forName" (type.method [(list (type.class "java.lang.String" (list))) $Class (list)]))))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) - -(def: object::instance? - Handler - (..custom - [($_ <>.and <s>.text <s>.any) - (function (_ extension-name generate archive [class objectS]) - (do phase.monad - [objectI (generate archive objectS)] - (wrap (|>> objectI - (_.INSTANCEOF (type.class class (list))) - (_.wrap type.boolean)))))])) - -(def: (object::cast extension-name generate archive inputs) - Handler - (case inputs - (^ (list (synthesis.text from) (synthesis.text to) valueS)) - (do phase.monad - [valueI (generate archive valueS)] - (`` (cond (~~ (template [<object> <type>] - [(and (text@= (reflection.reflection (type.reflection <type>)) - from) - (text@= <object> - to)) - (wrap (|>> valueI (_.wrap <type>))) - - (and (text@= <object> - from) - (text@= (reflection.reflection (type.reflection <type>)) - to)) - (wrap (|>> valueI (_.unwrap <type>)))] - - [box.boolean type.boolean] - [box.byte type.byte] - [box.short type.short] - [box.int type.int] - [box.long type.long] - [box.float type.float] - [box.double type.double] - [box.char type.char])) - ## else - (wrap valueI)))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) - -(def: object-bundle - Bundle - (<| (bundle.prefix "object") - (|> (: Bundle bundle.empty) - (bundle.install "null" (nullary object::null)) - (bundle.install "null?" (unary object::null?)) - (bundle.install "synchronized" (binary object::synchronized)) - (bundle.install "throw" (unary object::throw)) - (bundle.install "class" object::class) - (bundle.install "instance?" object::instance?) - (bundle.install "cast" object::cast) - ))) - -(def: primitives - (Dictionary Text (Type Primitive)) - (|> (list [(reflection.reflection reflection.boolean) type.boolean] - [(reflection.reflection reflection.byte) type.byte] - [(reflection.reflection reflection.short) type.short] - [(reflection.reflection reflection.int) type.int] - [(reflection.reflection reflection.long) type.long] - [(reflection.reflection reflection.float) type.float] - [(reflection.reflection reflection.double) type.double] - [(reflection.reflection reflection.char) type.char]) - (dictionary.from-list text.hash))) - -(def: get::static - Handler - (..custom - [($_ <>.and <s>.text <s>.text <s>.text) - (function (_ extension-name generate archive [class field unboxed]) - (do phase.monad - [] - (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (wrap (_.GETSTATIC (type.class class (list)) field primitive)) - - #.None - (wrap (_.GETSTATIC (type.class class (list)) field (type.class unboxed (list)))))))])) - -(def: put::static - Handler - (..custom - [($_ <>.and <s>.text <s>.text <s>.text <s>.any) - (function (_ extension-name generate archive [class field unboxed valueS]) - (do phase.monad - [valueI (generate archive valueS) - #let [$class (type.class class (list))]] - (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (wrap (|>> valueI - (_.PUTSTATIC $class field primitive) - (_.string synthesis.unit))) - - #.None - (wrap (|>> valueI - (_.CHECKCAST $class) - (_.PUTSTATIC $class field $class) - (_.string synthesis.unit))))))])) - -(def: get::virtual - Handler - (..custom - [($_ <>.and <s>.text <s>.text <s>.text <s>.any) - (function (_ extension-name generate archive [class field unboxed objectS]) - (do phase.monad - [objectI (generate archive objectS) - #let [$class (type.class class (list)) - getI (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (_.GETFIELD $class field primitive) - - #.None - (_.GETFIELD $class field (type.class unboxed (list))))]] - (wrap (|>> objectI - (_.CHECKCAST $class) - getI))))])) - -(def: put::virtual - Handler - (..custom - [($_ <>.and <s>.text <s>.text <s>.text <s>.any <s>.any) - (function (_ extension-name generate archive [class field unboxed valueS objectS]) - (do phase.monad - [valueI (generate archive valueS) - objectI (generate archive objectS) - #let [$class (type.class class (list)) - putI (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (_.PUTFIELD $class field primitive) - - #.None - (let [$unboxed (type.class unboxed (list))] - (|>> (_.CHECKCAST $unboxed) - (_.PUTFIELD $class field $unboxed))))]] - (wrap (|>> objectI - (_.CHECKCAST $class) - _.DUP - valueI - putI))))])) - -(type: Input (Typed Synthesis)) - -(def: input - (Parser Input) - (<s>.tuple (<>.and ..value <s>.any))) - -(def: (generate-input generate archive [valueT valueS]) - (-> Phase Archive Input - (Operation (Typed Inst))) - (do phase.monad - [valueI (generate archive valueS)] - (case (type.primitive? valueT) - (#.Right valueT) - (wrap [valueT valueI]) - - (#.Left valueT) - (wrap [valueT (|>> valueI - (_.CHECKCAST valueT))])))) - -(def: voidI (_.string synthesis.unit)) - -(def: (prepare-output outputT) - (-> (Type Return) Inst) - (case (type.void? outputT) - (#.Right outputT) - ..voidI - - (#.Left outputT) - function.identity)) - -(def: invoke::static - Handler - (..custom - [($_ <>.and ..class <s>.text ..return (<>.some ..input)) - (function (_ extension-name generate archive [class method outputT inputsTS]) - (do {@ phase.monad} - [inputsTI (monad.map @ (generate-input generate archive) inputsTS)] - (wrap (|>> (_.fuse (list@map product.right inputsTI)) - (_.INVOKESTATIC class method (type.method [(list@map product.left inputsTI) outputT (list)])) - (prepare-output outputT)))))])) - -(template [<name> <invoke>] - [(def: <name> - Handler - (..custom - [($_ <>.and ..class <s>.text ..return <s>.any (<>.some ..input)) - (function (_ extension-name generate archive [class method outputT objectS inputsTS]) - (do {@ phase.monad} - [objectI (generate archive objectS) - inputsTI (monad.map @ (generate-input generate archive) inputsTS)] - (wrap (|>> objectI - (_.CHECKCAST class) - (_.fuse (list@map product.right inputsTI)) - (<invoke> class method - (type.method [(list@map product.left inputsTI) - outputT - (list)])) - (prepare-output outputT)))))]))] - - [invoke::virtual _.INVOKEVIRTUAL] - [invoke::special _.INVOKESPECIAL] - [invoke::interface _.INVOKEINTERFACE] - ) - -(def: invoke::constructor - Handler - (..custom - [($_ <>.and ..class (<>.some ..input)) - (function (_ extension-name generate archive [class inputsTS]) - (do {@ phase.monad} - [inputsTI (monad.map @ (generate-input generate archive) inputsTS)] - (wrap (|>> (_.NEW class) - _.DUP - (_.fuse (list@map product.right inputsTI)) - (_.INVOKESPECIAL class "<init>" (type.method [(list@map product.left inputsTI) type.void (list)]))))))])) - -(def: member - Bundle - (<| (bundle.prefix "member") - (|> (: Bundle bundle.empty) - (dictionary.merge (<| (bundle.prefix "get") - (|> (: Bundle bundle.empty) - (bundle.install "static" get::static) - (bundle.install "virtual" get::virtual)))) - (dictionary.merge (<| (bundle.prefix "put") - (|> (: Bundle bundle.empty) - (bundle.install "static" put::static) - (bundle.install "virtual" put::virtual)))) - (dictionary.merge (<| (bundle.prefix "invoke") - (|> (: Bundle bundle.empty) - (bundle.install "static" invoke::static) - (bundle.install "virtual" invoke::virtual) - (bundle.install "special" invoke::special) - (bundle.install "interface" invoke::interface) - (bundle.install "constructor" invoke::constructor)))) - ))) - -(def: annotation-parameter - (Parser (/.Annotation-Parameter Synthesis)) - (<s>.tuple (<>.and <s>.text <s>.any))) - -(def: annotation - (Parser (/.Annotation Synthesis)) - (<s>.tuple (<>.and <s>.text (<>.some ..annotation-parameter)))) - -(def: argument - (Parser Argument) - (<s>.tuple (<>.and <s>.text ..value))) - -(def: overriden-method-definition - (Parser [Environment (/.Overriden-Method Synthesis)]) - (<s>.tuple (do <>.monad - [_ (<s>.text! /.overriden-tag) - ownerT ..class - name <s>.text - strict-fp? <s>.bit - annotations (<s>.tuple (<>.some ..annotation)) - vars (<s>.tuple (<>.some ..var)) - self-name <s>.text - arguments (<s>.tuple (<>.some ..argument)) - returnT ..return - exceptionsT (<s>.tuple (<>.some ..class)) - [environment body] (<s>.function 1 - (<s>.tuple <s>.any))] - (wrap [environment - [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - body]])))) - -(def: (normalize-path normalize) - (-> (-> Synthesis Synthesis) - (-> Path Path)) - (function (recur path) - (case path - (^ (synthesis.path/then bodyS)) - (synthesis.path/then (normalize bodyS)) - - (^template [<tag>] - (^ (<tag> leftP rightP)) - (<tag> (recur leftP) (recur rightP))) - ([#synthesis.Alt] - [#synthesis.Seq]) - - (^template [<tag>] - (^ (<tag> value)) - path) - ([#synthesis.Pop] - [#synthesis.Test] - [#synthesis.Bind] - [#synthesis.Access])))) - -(def: (normalize-method-body mapping) - (-> (Dictionary Variable Variable) Synthesis Synthesis) - (function (recur body) - (case body - (^template [<tag>] - (^ (<tag> value)) - body) - ([#synthesis.Primitive] - [synthesis.constant]) - - (^ (synthesis.variant [lefts right? sub])) - (synthesis.variant [lefts right? (recur sub)]) - - (^ (synthesis.tuple members)) - (synthesis.tuple (list@map recur members)) - - (^ (synthesis.variable var)) - (|> mapping - (dictionary.get var) - (maybe.default var) - synthesis.variable) - - (^ (synthesis.branch/case [inputS pathS])) - (synthesis.branch/case [(recur inputS) (normalize-path recur pathS)]) - - (^ (synthesis.branch/let [inputS register outputS])) - (synthesis.branch/let [(recur inputS) register (recur outputS)]) - - (^ (synthesis.branch/if [testS thenS elseS])) - (synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)]) - - (^ (synthesis.loop/scope [offset initsS+ bodyS])) - (synthesis.loop/scope [offset (list@map recur initsS+) (recur bodyS)]) - - (^ (synthesis.loop/recur updatesS+)) - (synthesis.loop/recur (list@map recur updatesS+)) - - (^ (synthesis.function/abstraction [environment arity bodyS])) - (synthesis.function/abstraction [(|> environment (list@map (function (_ local) - (|> mapping - (dictionary.get local) - (maybe.default local))))) - arity - bodyS]) - - (^ (synthesis.function/apply [functionS inputsS+])) - (synthesis.function/apply [(recur functionS) (list@map recur inputsS+)]) - - (#synthesis.Extension [name inputsS+]) - (#synthesis.Extension [name (list@map recur inputsS+)])))) - -(def: $Object (type.class "java.lang.Object" (list))) - -(def: (anonymous-init-method env) - (-> Environment (Type Method)) - (type.method [(list.repeat (list.size env) $Object) - type.void - (list)])) - -(def: (with-anonymous-init class env super-class inputsTI) - (-> (Type Class) Environment (Type Class) (List (Typed Inst)) Def) - (let [store-capturedI (|> env - list.size - list.indices - (list@map (.function (_ register) - (|>> (_.ALOAD 0) - (_.ALOAD (inc register)) - (_.PUTFIELD class (///reference.foreign-name register) $Object)))) - _.fuse)] - (_def.method #$.Public $.noneM "<init>" (anonymous-init-method env) - (|>> (_.ALOAD 0) - ((_.fuse (list@map product.right inputsTI))) - (_.INVOKESPECIAL super-class "<init>" (type.method [(list@map product.left inputsTI) type.void (list)])) - store-capturedI - _.RETURN)))) - -(def: (anonymous-instance archive class env) - (-> Archive (Type Class) Environment (Operation Inst)) - (do {@ phase.monad} - [captureI+ (monad.map @ (///reference.variable archive) env)] - (wrap (|>> (_.NEW class) - _.DUP - (_.fuse captureI+) - (_.INVOKESPECIAL class "<init>" (anonymous-init-method env)))))) - -(def: (returnI returnT) - (-> (Type Return) Inst) - (case (type.void? returnT) - (#.Right returnT) - _.RETURN - - (#.Left returnT) - (case (type.primitive? returnT) - (#.Left returnT) - (|>> (_.CHECKCAST returnT) - _.ARETURN) - - (#.Right returnT) - (cond (or (:: type.equivalence = type.boolean returnT) - (:: type.equivalence = type.byte returnT) - (:: type.equivalence = type.short returnT) - (:: type.equivalence = type.int returnT) - (:: type.equivalence = type.char returnT)) - _.IRETURN - - (:: type.equivalence = type.long returnT) - _.LRETURN - - (:: type.equivalence = type.float returnT) - _.FRETURN - - ## (:: type.equivalence = type.double returnT) - _.DRETURN)))) - -(def: class::anonymous - Handler - (..custom - [($_ <>.and - ..class - (<s>.tuple (<>.some ..class)) - (<s>.tuple (<>.some ..input)) - (<s>.tuple (<>.some ..overriden-method-definition))) - (function (_ extension-name generate archive [super-class super-interfaces - inputsTS - overriden-methods]) - (do {@ phase.monad} - [[context _] (generation.with-new-context archive (wrap [])) - #let [[module-id artifact-id] context - anonymous-class-name (///.class-name context) - class (type.class anonymous-class-name (list)) - total-environment (|> overriden-methods - ## Get all the environments. - (list@map product.left) - ## Combine them. - list@join - ## Remove duplicates. - (set.from-list reference.hash) - set.to-list) - global-mapping (|> total-environment - ## Give them names as "foreign" variables. - list.enumerate - (list@map (function (_ [id capture]) - [capture (#reference.Foreign id)])) - (dictionary.from-list reference.hash)) - normalized-methods (list@map (function (_ [environment - [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - body]]) - (let [local-mapping (|> environment - list.enumerate - (list@map (function (_ [foreign-id capture]) - [(#reference.Foreign foreign-id) - (|> global-mapping - (dictionary.get capture) - maybe.assume)])) - (dictionary.from-list reference.hash))] - [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - (normalize-method-body local-mapping body)])) - overriden-methods)] - inputsTI (monad.map @ (generate-input generate archive) inputsTS) - method-definitions (|> normalized-methods - (monad.map @ (function (_ [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - bodyS]) - (do @ - [bodyG (generation.with-context artifact-id - (generate archive bodyS))] - (wrap (_def.method #$.Public - (if strict-fp? - ($_ $.++M $.finalM $.strictM) - $.finalM) - name - (type.method [(list@map product.right arguments) - returnT - exceptionsT]) - (|>> bodyG (returnI returnT))))))) - (:: @ map _def.fuse)) - _ (generation.save! true ["" (%.nat artifact-id)] - [anonymous-class-name - (_def.class #$.V1_6 #$.Public $.finalC - anonymous-class-name (list) - super-class super-interfaces - (|>> (///function.with-environment total-environment) - (..with-anonymous-init class total-environment super-class inputsTI) - method-definitions))])] - (anonymous-instance archive class total-environment)))])) - -(def: bundle::class - Bundle - (<| (bundle.prefix "class") - (|> (: Bundle bundle.empty) - (bundle.install "anonymous" class::anonymous) - ))) - -(def: #export bundle - Bundle - (<| (bundle.prefix "jvm") - (|> ..conversion - (dictionary.merge ..int) - (dictionary.merge ..long) - (dictionary.merge ..float) - (dictionary.merge ..double) - (dictionary.merge ..char) - (dictionary.merge ..array) - (dictionary.merge ..object-bundle) - (dictionary.merge ..member) - (dictionary.merge ..bundle::class) - ))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/function.lux b/new-luxc/source/luxc/lang/translation/jvm/function.lux deleted file mode 100644 index 888ad9545..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/function.lux +++ /dev/null @@ -1,331 +0,0 @@ -(.module: - [lux (#- Type function) - [abstract - ["." monad (#+ do)]] - [control - [pipe (#+ when> new>)] - ["." function]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [number - ["n" nat] - ["i" int]] - [collection - ["." list ("#@." functor monoid)]]] - [target - [jvm - ["." type (#+ Type) - ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)]]]] - [tool - [compiler - [arity (#+ Arity)] - [reference (#+ Register)] - ["." phase] - [language - [lux - [analysis (#+ Environment)] - [synthesis (#+ Synthesis Abstraction Apply)] - ["." generation]]] - [meta - [archive (#+ Archive)]]]]] - [luxc - [lang - [host - ["$" jvm (#+ Label Inst Def Operation Phase Generator) - ["." def] - ["_" inst]]]]] - ["." // - ["#." runtime] - ["." reference]]) - -(def: arity-field Text "arity") - -(def: (poly-arg? arity) - (-> Arity Bit) - (n.> 1 arity)) - -(def: (captured-args env) - (-> Environment (List (Type Value))) - (list.repeat (list.size env) //.$Value)) - -(def: (init-method env arity) - (-> Environment Arity (Type Method)) - (if (poly-arg? arity) - (type.method [(list.concat (list (captured-args env) - (list type.int) - (list.repeat (dec arity) //.$Value))) - type.void - (list)]) - (type.method [(captured-args env) type.void (list)]))) - -(def: (implementation-method arity) - (type.method [(list.repeat arity //.$Value) //.$Value (list)])) - -(def: get-amount-of-partialsI - Inst - (|>> (_.ALOAD 0) - (_.GETFIELD //.$Function //runtime.partials-field type.int))) - -(def: (load-fieldI class field) - (-> (Type Class) Text Inst) - (|>> (_.ALOAD 0) - (_.GETFIELD class field //.$Value))) - -(def: (inputsI start amount) - (-> Register Nat Inst) - (|> (list.n/range start (n.+ start (dec amount))) - (list@map _.ALOAD) - _.fuse)) - -(def: (applysI start amount) - (-> Register Nat Inst) - (let [max-args (n.min amount //runtime.num-apply-variants) - later-applysI (if (n.> //runtime.num-apply-variants amount) - (applysI (n.+ //runtime.num-apply-variants start) (n.- //runtime.num-apply-variants amount)) - function.identity)] - (|>> (_.CHECKCAST //.$Function) - (inputsI start max-args) - (_.INVOKEVIRTUAL //.$Function //runtime.apply-method (//runtime.apply-signature max-args)) - later-applysI))) - -(def: (inc-intI by) - (-> Nat Inst) - (|>> (_.int (.int by)) - _.IADD)) - -(def: (nullsI amount) - (-> Nat Inst) - (|> _.NULL - (list.repeat amount) - _.fuse)) - -(def: (instance archive class arity env) - (-> Archive (Type Class) Arity Environment (Operation Inst)) - (do {@ phase.monad} - [captureI+ (monad.map @ (reference.variable archive) env) - #let [argsI (if (poly-arg? arity) - (|> (nullsI (dec arity)) - (list (_.int +0)) - _.fuse) - function.identity)]] - (wrap (|>> (_.NEW class) - _.DUP - (_.fuse captureI+) - argsI - (_.INVOKESPECIAL class "<init>" (init-method env arity)))))) - -(def: (reset-method return) - (-> (Type Class) (Type Method)) - (type.method [(list) return (list)])) - -(def: (with-reset class arity env) - (-> (Type Class) Arity Environment Def) - (def.method #$.Public $.noneM "reset" (reset-method class) - (if (poly-arg? arity) - (let [env-size (list.size env) - captureI (|> (case env-size - 0 (list) - _ (list.n/range 0 (dec env-size))) - (list@map (.function (_ source) - (|>> (_.ALOAD 0) - (_.GETFIELD class (reference.foreign-name source) //.$Value)))) - _.fuse) - argsI (|> (nullsI (dec arity)) - (list (_.int +0)) - _.fuse)] - (|>> (_.NEW class) - _.DUP - captureI - argsI - (_.INVOKESPECIAL class "<init>" (init-method env arity)) - _.ARETURN)) - (|>> (_.ALOAD 0) - _.ARETURN)))) - -(def: (with-implementation arity @begin bodyI) - (-> Nat Label Inst Def) - (def.method #$.Public $.strictM "impl" (implementation-method arity) - (|>> (_.label @begin) - bodyI - _.ARETURN))) - -(def: function-init-method - (type.method [(list type.int) type.void (list)])) - -(def: (function-init arity env-size) - (-> Arity Nat Inst) - (if (n.= 1 arity) - (|>> (_.int +0) - (_.INVOKESPECIAL //.$Function "<init>" function-init-method)) - (|>> (_.ILOAD (inc env-size)) - (_.INVOKESPECIAL //.$Function "<init>" function-init-method)))) - -(def: (with-init class env arity) - (-> (Type Class) Environment Arity Def) - (let [env-size (list.size env) - offset-partial (: (-> Nat Nat) - (|>> inc (n.+ env-size))) - store-capturedI (|> (case env-size - 0 (list) - _ (list.n/range 0 (dec env-size))) - (list@map (.function (_ register) - (|>> (_.ALOAD 0) - (_.ALOAD (inc register)) - (_.PUTFIELD class (reference.foreign-name register) //.$Value)))) - _.fuse) - store-partialI (if (poly-arg? arity) - (|> (list.n/range 0 (n.- 2 arity)) - (list@map (.function (_ idx) - (let [register (offset-partial idx)] - (|>> (_.ALOAD 0) - (_.ALOAD (inc register)) - (_.PUTFIELD class (reference.partial-name idx) //.$Value))))) - _.fuse) - function.identity)] - (def.method #$.Public $.noneM "<init>" (init-method env arity) - (|>> (_.ALOAD 0) - (function-init arity env-size) - store-capturedI - store-partialI - _.RETURN)))) - -(def: (with-apply class env function-arity @begin bodyI apply-arity) - (-> (Type Class) Environment Arity Label Inst Arity - Def) - (let [num-partials (dec function-arity) - @default ($.new-label []) - @labels (list@map $.new-label (list.repeat num-partials [])) - over-extent (|> (.int function-arity) (i.- (.int apply-arity))) - casesI (|> (list@compose @labels (list @default)) - (list.zip2 (list.n/range 0 num-partials)) - (list@map (.function (_ [stage @label]) - (let [load-partialsI (if (n.> 0 stage) - (|> (list.n/range 0 (dec stage)) - (list@map (|>> reference.partial-name (load-fieldI class))) - _.fuse) - function.identity)] - (cond (i.= over-extent (.int stage)) - (|>> (_.label @label) - (_.ALOAD 0) - (when> [(new> (n.> 0 stage) [])] - [(_.INVOKEVIRTUAL class "reset" (reset-method class))]) - load-partialsI - (inputsI 1 apply-arity) - (_.INVOKEVIRTUAL class "impl" (implementation-method function-arity)) - _.ARETURN) - - (i.> over-extent (.int stage)) - (let [args-to-completion (|> function-arity (n.- stage)) - args-left (|> apply-arity (n.- args-to-completion))] - (|>> (_.label @label) - (_.ALOAD 0) - (_.INVOKEVIRTUAL class "reset" (reset-method class)) - load-partialsI - (inputsI 1 args-to-completion) - (_.INVOKEVIRTUAL class "impl" (implementation-method function-arity)) - (applysI (inc args-to-completion) args-left) - _.ARETURN)) - - ## (i.< over-extent (.int stage)) - (let [env-size (list.size env) - load-capturedI (|> (case env-size - 0 (list) - _ (list.n/range 0 (dec env-size))) - (list@map (|>> reference.foreign-name (load-fieldI class))) - _.fuse)] - (|>> (_.label @label) - (_.NEW class) - _.DUP - load-capturedI - get-amount-of-partialsI - (inc-intI apply-arity) - load-partialsI - (inputsI 1 apply-arity) - (nullsI (|> num-partials (n.- apply-arity) (n.- stage))) - (_.INVOKESPECIAL class "<init>" (init-method env function-arity)) - _.ARETURN)) - )))) - _.fuse)] - (def.method #$.Public $.noneM //runtime.apply-method (//runtime.apply-signature apply-arity) - (|>> get-amount-of-partialsI - (_.TABLESWITCH +0 (|> num-partials dec .int) - @default @labels) - casesI - )))) - -(def: #export with-environment - (-> Environment Def) - (|>> list.enumerate - (list@map (.function (_ [env-idx env-source]) - (def.field #$.Private $.finalF (reference.foreign-name env-idx) //.$Value))) - def.fuse)) - -(def: (with-partial arity) - (-> Arity Def) - (if (poly-arg? arity) - (|> (list.n/range 0 (n.- 2 arity)) - (list@map (.function (_ idx) - (def.field #$.Private $.finalF (reference.partial-name idx) //.$Value))) - def.fuse) - function.identity)) - -(def: #export (with-function archive @begin class env arity bodyI) - (-> Archive Label Text Environment Arity Inst - (Operation [Def Inst])) - (let [classD (type.class class (list)) - applyD (: Def - (if (poly-arg? arity) - (|> (n.min arity //runtime.num-apply-variants) - (list.n/range 1) - (list@map (with-apply classD env arity @begin bodyI)) - (list& (with-implementation arity @begin bodyI)) - def.fuse) - (def.method #$.Public $.strictM //runtime.apply-method (//runtime.apply-signature 1) - (|>> (_.label @begin) - bodyI - _.ARETURN)))) - functionD (: Def - (|>> (def.int-field #$.Public ($_ $.++F $.staticF $.finalF) arity-field (.int arity)) - (with-environment env) - (with-partial arity) - (with-init classD env arity) - (with-reset classD arity env) - applyD - ))] - (do phase.monad - [instanceI (instance archive classD arity env)] - (wrap [functionD instanceI])))) - -(def: #export (function generate archive [env arity bodyS]) - (Generator Abstraction) - (do phase.monad - [@begin _.make-label - [function-context bodyI] (generation.with-new-context archive - (generation.with-anchor [@begin 1] - (generate archive bodyS))) - #let [function-class (//.class-name function-context)] - [functionD instanceI] (with-function archive @begin function-class env arity bodyI) - _ (generation.save! true ["" (%.nat (product.right function-context))] - [function-class - (def.class #$.V1_6 #$.Public $.finalC - function-class (list) - //.$Function (list) - functionD)])] - (wrap instanceI))) - -(def: #export (call generate archive [functionS argsS]) - (Generator Apply) - (do {@ phase.monad} - [functionI (generate archive functionS) - argsI (monad.map @ (generate archive) argsS) - #let [applyI (|> argsI - (list.split-all //runtime.num-apply-variants) - (list@map (.function (_ chunkI+) - (|>> (_.CHECKCAST //.$Function) - (_.fuse chunkI+) - (_.INVOKEVIRTUAL //.$Function //runtime.apply-method (//runtime.apply-signature (list.size chunkI+)))))) - _.fuse)]] - (wrap (|>> functionI - applyI)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/loop.lux b/new-luxc/source/luxc/lang/translation/jvm/loop.lux deleted file mode 100644 index 1f2168fed..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/loop.lux +++ /dev/null @@ -1,81 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function]] - [data - [number - ["n" nat]] - [collection - ["." list ("#/." functor monoid)]]] - [tool - [compiler - [reference (#+ Register)] - ["." phase] - [language - [lux - ["." synthesis (#+ Synthesis)] - ["." generation]]]]]] - [luxc - [lang - [host - [jvm (#+ Inst Operation Phase Generator) - ["_" inst]]]]] - ["." //]) - -(def: (invariant? register changeS) - (-> Register Synthesis Bit) - (case changeS - (^ (synthesis.variable/local var)) - (n.= register var) - - _ - false)) - -(def: #export (recur translate archive argsS) - (Generator (List Synthesis)) - (do {@ phase.monad} - [[@begin start] generation.anchor - #let [end (|> argsS list.size dec (n.+ start)) - pairs (list.zip2 (list.n/range start end) - argsS)] - ## It may look weird that first I compile the values separately, - ## and then I compile the stores/allocations. - ## It must be done that way in order to avoid a potential bug. - ## Let's say that you'll recur with 2 expressions: X and Y. - ## If Y depends on the value of X, and you don't compile values - ## and stores separately, then by the time Y is evaluated, it - ## will refer to the new value of X, instead of the old value, as - ## should be the case. - valuesI+ (monad.map @ (function (_ [register argS]) - (: (Operation Inst) - (if (invariant? register argS) - (wrap function.identity) - (translate archive argS)))) - pairs) - #let [storesI+ (list/map (function (_ [register argS]) - (: Inst - (if (invariant? register argS) - function.identity - (_.ASTORE register)))) - (list.reverse pairs))]] - (wrap (|>> (_.fuse valuesI+) - (_.fuse storesI+) - (_.GOTO @begin))))) - -(def: #export (scope translate archive [start initsS+ iterationS]) - (Generator [Nat (List Synthesis) Synthesis]) - (do {@ phase.monad} - [@begin _.make-label - initsI+ (monad.map @ (translate archive) initsS+) - iterationI (generation.with-anchor [@begin start] - (translate archive iterationS)) - #let [initializationI (|> (list.enumerate initsI+) - (list/map (function (_ [register initI]) - (|>> initI - (_.ASTORE (n.+ start register))))) - _.fuse)]] - (wrap (|>> initializationI - (_.label @begin) - iterationI)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/primitive.lux b/new-luxc/source/luxc/lang/translation/jvm/primitive.lux deleted file mode 100644 index 873c363bd..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/primitive.lux +++ /dev/null @@ -1,30 +0,0 @@ -(.module: - [lux (#- i64) - [target - [jvm - ["." type]]] - [tool - [compiler - [phase ("operation@." monad)]]]] - [luxc - [lang - [host - ["." jvm (#+ Inst Operation) - ["_" inst]]]]]) - -(def: #export bit - (-> Bit (Operation Inst)) - (let [Boolean (type.class "java.lang.Boolean" (list))] - (function (_ value) - (operation@wrap (_.GETSTATIC Boolean (if value "TRUE" "FALSE") Boolean))))) - -(template [<name> <type> <load> <wrap>] - [(def: #export (<name> value) - (-> <type> (Operation Inst)) - (let [loadI (|> value <load>)] - (operation@wrap (|>> loadI <wrap>))))] - - [i64 (I64 Any) (<| _.long .int) (_.wrap type.long)] - [f64 Frac _.double (_.wrap type.double)] - [text Text _.string (<|)] - ) diff --git a/new-luxc/source/luxc/lang/translation/jvm/program.lux b/new-luxc/source/luxc/lang/translation/jvm/program.lux deleted file mode 100644 index 7ac897009..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/program.lux +++ /dev/null @@ -1,82 +0,0 @@ -(.module: - [lux #* - [target - [jvm - ["$t" type]]]] - [luxc - [lang - [host - ["_" jvm - ["$d" def] - ["$i" inst]]] - [translation - ["." jvm - ["." runtime]]]]]) - -(def: #export class "LuxProgram") - -(def: ^Object ($t.class "java.lang.Object" (list))) - -(def: #export (program programI) - (-> _.Inst _.Definition) - (let [nilI runtime.noneI - num-inputsI (|>> ($i.ALOAD 0) $i.ARRAYLENGTH) - decI (|>> ($i.int +1) $i.ISUB) - headI (|>> $i.DUP - ($i.ALOAD 0) - $i.SWAP - $i.AALOAD - $i.SWAP - $i.DUP_X2 - $i.POP) - pairI (|>> ($i.int +2) - ($i.ANEWARRAY ..^Object) - $i.DUP_X1 - $i.SWAP - ($i.int +0) - $i.SWAP - $i.AASTORE - $i.DUP_X1 - $i.SWAP - ($i.int +1) - $i.SWAP - $i.AASTORE) - consI (|>> ($i.int +1) - ($i.string "") - $i.DUP2_X1 - $i.POP2 - runtime.variantI) - prepare-input-listI (<| $i.with-label (function (_ @loop)) - $i.with-label (function (_ @end)) - (|>> nilI - num-inputsI - ($i.label @loop) - decI - $i.DUP - ($i.IFLT @end) - headI - pairI - consI - $i.SWAP - ($i.GOTO @loop) - ($i.label @end) - $i.POP)) - feed-inputsI ($i.INVOKEVIRTUAL jvm.$Function runtime.apply-method (runtime.apply-signature 1)) - run-ioI (|>> ($i.CHECKCAST jvm.$Function) - $i.NULL - ($i.INVOKEVIRTUAL jvm.$Function runtime.apply-method (runtime.apply-signature 1))) - main-type ($t.method [(list ($t.array ($t.class "java.lang.String" (list)))) - $t.void - (list)])] - [..class - ($d.class #_.V1_6 - #_.Public _.finalC - ..class - (list) ..^Object - (list) - (|>> ($d.method #_.Public _.staticM "main" main-type - (|>> programI - prepare-input-listI - feed-inputsI - run-ioI - $i.RETURN))))])) diff --git a/new-luxc/source/luxc/lang/translation/jvm/reference.lux b/new-luxc/source/luxc/lang/translation/jvm/reference.lux deleted file mode 100644 index 6bcf4a2e5..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/reference.lux +++ /dev/null @@ -1,65 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [data - [text - ["%" format (#+ format)]]] - [target - [jvm - ["." type]]] - [tool - [compiler - ["." reference (#+ Register Variable)] - ["." phase ("operation@." monad)] - [meta - [archive (#+ Archive)]] - [language - [lux - ["." generation]]]]]] - [luxc - [lang - [host - [jvm (#+ Inst Operation) - ["_" inst]]]]] - ["." // - ["#." runtime]]) - -(template [<name> <prefix>] - [(def: #export <name> - (-> Nat Text) - (|>> %.nat (format <prefix>)))] - - [foreign-name "f"] - [partial-name "p"] - ) - -(def: (foreign archive variable) - (-> Archive Register (Operation Inst)) - (do {@ phase.monad} - [class-name (:: @ map //.class-name - (generation.context archive))] - (wrap (|>> (_.ALOAD 0) - (_.GETFIELD (type.class class-name (list)) - (|> variable .nat foreign-name) - //.$Value))))) - -(def: local - (-> Register Inst) - (|>> _.ALOAD)) - -(def: #export (variable archive variable) - (-> Archive Variable (Operation Inst)) - (case variable - (#reference.Local variable) - (operation@wrap (local variable)) - - (#reference.Foreign variable) - (foreign archive variable))) - -(def: #export (constant archive name) - (-> Archive Name (Operation Inst)) - (do {@ phase.monad} - [class-name (:: @ map //.class-name - (generation.remember archive name))] - (wrap (_.GETSTATIC (type.class class-name (list)) //.value-field //.$Value)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.lux deleted file mode 100644 index a657a7a38..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/runtime.lux +++ /dev/null @@ -1,387 +0,0 @@ -(.module: - [lux (#- Type) - [abstract - [monad (#+ do)]] - [data - [binary (#+ Binary)] - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#@." functor)] - ["." row]]] - ["." math] - [target - [jvm - ["." type (#+ Type) - ["." category (#+ Void Value' Value Return' Return Primitive Object Class Array Var Parameter Method)] - ["." reflection]]]] - [tool - [compiler (#+ Output) - [arity (#+ Arity)] - ["." phase] - [language - [lux - ["." synthesis] - ["." generation]]] - [meta - [archive - ["." artifact (#+ Registry)]]]]]] - [luxc - [lang - [host - ["$" jvm (#+ Label Inst Def Operation) - ["$d" def] - ["_" inst]]]]] - ["." // (#+ ByteCode)]) - -(def: $Text (type.class "java.lang.String" (list))) -(def: #export $Tag type.int) -(def: #export $Flag (type.class "java.lang.Object" (list))) -(def: #export $Value (type.class "java.lang.Object" (list))) -(def: #export $Index type.int) -(def: #export $Stack (type.array $Value)) -(def: $Throwable (type.class "java.lang.Throwable" (list))) - -(def: nullary-init-methodT - (type.method [(list) type.void (list)])) - -(def: throw-methodT - (type.method [(list) type.void (list)])) - -(def: #export logI - Inst - (let [PrintStream (type.class "java.io.PrintStream" (list)) - outI (_.GETSTATIC (type.class "java.lang.System" (list)) "out" PrintStream) - printI (function (_ method) - (_.INVOKEVIRTUAL PrintStream method (type.method [(list $Value) type.void (list)])))] - (|>> outI (_.string "LOG: ") (printI "print") - outI _.SWAP (printI "println")))) - -(def: variant-method - (type.method [(list $Tag $Flag $Value) //.$Variant (list)])) - -(def: #export variantI - Inst - (_.INVOKESTATIC //.$Runtime "variant_make" variant-method)) - -(def: #export leftI - Inst - (|>> (_.int +0) - _.NULL - _.DUP2_X1 - _.POP2 - variantI)) - -(def: #export rightI - Inst - (|>> (_.int +1) - (_.string "") - _.DUP2_X1 - _.POP2 - variantI)) - -(def: #export someI Inst rightI) - -(def: #export noneI - Inst - (|>> (_.int +0) - _.NULL - (_.string synthesis.unit) - variantI)) - -(def: (tryI unsafeI) - (-> Inst Inst) - (<| _.with-label (function (_ @from)) - _.with-label (function (_ @to)) - _.with-label (function (_ @handler)) - (|>> (_.try @from @to @handler (type.class "java.lang.Exception" (list))) - (_.label @from) - unsafeI - someI - _.ARETURN - (_.label @to) - (_.label @handler) - noneI - _.ARETURN))) - -(def: #export partials-field Text "partials") -(def: #export apply-method Text "apply") -(def: #export num-apply-variants Nat 8) - -(def: #export (apply-signature arity) - (-> Arity (Type Method)) - (type.method [(list.repeat arity $Value) $Value (list)])) - -(def: adt-methods - Def - (let [store-tagI (|>> _.DUP (_.int +0) (_.ILOAD 0) (_.wrap type.int) _.AASTORE) - store-flagI (|>> _.DUP (_.int +1) (_.ALOAD 1) _.AASTORE) - store-valueI (|>> _.DUP (_.int +2) (_.ALOAD 2) _.AASTORE)] - (|>> ($d.method #$.Public $.staticM "variant_make" - (type.method [(list $Tag $Flag $Value) //.$Variant (list)]) - (|>> (_.int +3) - (_.ANEWARRAY $Value) - store-tagI - store-flagI - store-valueI - _.ARETURN))))) - -(def: frac-methods - Def - (|>> ($d.method #$.Public $.staticM "decode_frac" (type.method [(list $Text) //.$Variant (list)]) - (tryI - (|>> (_.ALOAD 0) - (_.INVOKESTATIC (type.class "java.lang.Double" (list)) "parseDouble" (type.method [(list $Text) type.double (list)])) - (_.wrap type.double)))) - )) - -(def: (illegal-state-exception message) - (-> Text Inst) - (let [IllegalStateException (type.class "java.lang.IllegalStateException" (list))] - (|>> (_.NEW IllegalStateException) - _.DUP - (_.string message) - (_.INVOKESPECIAL IllegalStateException "<init>" (type.method [(list $Text) type.void (list)]))))) - -(def: pm-methods - Def - (let [tuple-sizeI (|>> (_.ALOAD 0) _.ARRAYLENGTH) - last-rightI (|>> tuple-sizeI (_.int +1) _.ISUB) - leftsI (_.ILOAD 1) - left-indexI leftsI - sub-leftsI (|>> leftsI - last-rightI - _.ISUB) - sub-tupleI (|>> (_.ALOAD 0) last-rightI _.AALOAD (_.CHECKCAST //.$Tuple)) - recurI (: (-> Label Inst) - (function (_ @loop) - (|>> sub-leftsI (_.ISTORE 1) - sub-tupleI (_.ASTORE 0) - (_.GOTO @loop))))] - (|>> ($d.method #$.Public $.staticM "pm_fail" throw-methodT - (|>> (illegal-state-exception "Invalid expression for pattern-matching.") - _.ATHROW)) - ($d.method #$.Public $.staticM "apply_fail" throw-methodT - (|>> (illegal-state-exception "Error while applying function.") - _.ATHROW)) - ($d.method #$.Public $.staticM "pm_push" (type.method [(list $Stack $Value) $Stack (list)]) - (|>> (_.int +2) - (_.ANEWARRAY $Value) - _.DUP - (_.int +1) - (_.ALOAD 0) - _.AASTORE - _.DUP - (_.int +0) - (_.ALOAD 1) - _.AASTORE - _.ARETURN)) - ($d.method #$.Public $.staticM "pm_variant" (type.method [(list //.$Variant $Tag $Flag) $Value (list)]) - (<| _.with-label (function (_ @loop)) - _.with-label (function (_ @perfect-match!)) - _.with-label (function (_ @tags-match!)) - _.with-label (function (_ @maybe-nested)) - _.with-label (function (_ @mismatch!)) - (let [$variant (_.ALOAD 0) - $tag (_.ILOAD 1) - $last? (_.ALOAD 2) - - variant-partI (: (-> Nat Inst) - (function (_ idx) - (|>> (_.int (.int idx)) _.AALOAD))) - ::tag (: Inst - (|>> (variant-partI 0) (_.unwrap type.int))) - ::last? (variant-partI 1) - ::value (variant-partI 2) - - super-nested-tag (|>> _.SWAP ## variant::tag, tag - _.ISUB) - super-nested (|>> super-nested-tag ## super-tag - $variant ::last? ## super-tag, super-last - $variant ::value ## super-tag, super-last, super-value - ..variantI) - - update-$tag _.ISUB - update-$variant (|>> $variant ::value - (_.CHECKCAST //.$Variant) - (_.ASTORE 0)) - iterate! (: (-> Label Inst) - (function (_ @loop) - (|>> update-$variant - update-$tag - (_.GOTO @loop)))) - - not-found _.NULL]) - (|>> $tag ## tag - (_.label @loop) - $variant ::tag ## tag, variant::tag - _.DUP2 (_.IF_ICMPEQ @tags-match!) ## tag, variant::tag - _.DUP2 (_.IF_ICMPGT @maybe-nested) ## tag, variant::tag - $last? (_.IFNULL @mismatch!) ## tag, variant::tag - super-nested ## super-variant - _.ARETURN - (_.label @tags-match!) ## tag, variant::tag - $last? ## tag, variant::tag, last? - $variant ::last? ## tag, variant::tag, last?, variant::last? - (_.IF_ACMPEQ @perfect-match!) ## tag, variant::tag - (_.label @maybe-nested) ## tag, variant::tag - $variant ::last? ## tag, variant::tag, variant::last? - (_.IFNULL @mismatch!) ## tag, variant::tag - (iterate! @loop) - (_.label @perfect-match!) ## tag, variant::tag - ## _.POP2 - $variant ::value - _.ARETURN - (_.label @mismatch!) ## tag, variant::tag - ## _.POP2 - not-found - _.ARETURN))) - ($d.method #$.Public $.staticM "tuple_left" (type.method [(list //.$Tuple $Index) $Value (list)]) - (<| _.with-label (function (_ @loop)) - _.with-label (function (_ @recursive)) - (let [left-accessI (|>> (_.ALOAD 0) left-indexI _.AALOAD)]) - (|>> (_.label @loop) - leftsI last-rightI (_.IF_ICMPGE @recursive) - left-accessI - _.ARETURN - (_.label @recursive) - ## Recursive - (recurI @loop)))) - ($d.method #$.Public $.staticM "tuple_right" (type.method [(list //.$Tuple $Index) $Value (list)]) - (<| _.with-label (function (_ @loop)) - _.with-label (function (_ @not-tail)) - _.with-label (function (_ @slice)) - (let [right-indexI (|>> leftsI - (_.int +1) - _.IADD) - right-accessI (|>> (_.ALOAD 0) - _.SWAP - _.AALOAD) - sub-rightI (|>> (_.ALOAD 0) - right-indexI - tuple-sizeI - (_.INVOKESTATIC (type.class "java.util.Arrays" (list)) "copyOfRange" - (type.method [(list //.$Tuple $Index $Index) - //.$Tuple - (list)])))]) - (|>> (_.label @loop) - last-rightI right-indexI - _.DUP2 (_.IF_ICMPNE @not-tail) - ## _.POP - right-accessI - _.ARETURN - (_.label @not-tail) - (_.IF_ICMPGT @slice) - ## Must recurse - (recurI @loop) - (_.label @slice) - sub-rightI - _.ARETURN - ))) - ))) - -(def: #export try (type.method [(list //.$Function) //.$Variant (list)])) - -(def: io-methods - Def - (let [StringWriter (type.class "java.io.StringWriter" (list)) - PrintWriter (type.class "java.io.PrintWriter" (list)) - string-writerI (|>> (_.NEW StringWriter) - _.DUP - (_.INVOKESPECIAL StringWriter "<init>" nullary-init-methodT)) - print-writerI (|>> (_.NEW PrintWriter) - _.SWAP - _.DUP2 - _.POP - _.SWAP - (_.boolean true) - (_.INVOKESPECIAL PrintWriter "<init>" (type.method [(list (type.class "java.io.Writer" (list)) type.boolean) type.void (list)])) - )] - (|>> ($d.method #$.Public $.staticM "try" ..try - (<| _.with-label (function (_ @from)) - _.with-label (function (_ @to)) - _.with-label (function (_ @handler)) - (|>> (_.try @from @to @handler $Throwable) - (_.label @from) - (_.ALOAD 0) - _.NULL - (_.INVOKEVIRTUAL //.$Function apply-method (apply-signature 1)) - rightI - _.ARETURN - (_.label @to) - (_.label @handler) - string-writerI ## TW - _.DUP2 ## TWTW - print-writerI ## TWTP - (_.INVOKEVIRTUAL $Throwable "printStackTrace" (type.method [(list (type.class "java.io.PrintWriter" (list))) type.void (list)])) ## TW - (_.INVOKEVIRTUAL StringWriter "toString" (type.method [(list) $Text (list)])) ## TS - _.SWAP _.POP leftI - _.ARETURN))) - ))) - -(def: reflection - (All [category] - (-> (Type (<| Return' Value' category)) Text)) - (|>> type.reflection reflection.reflection)) - -(def: translate-runtime - (Operation [Text Binary]) - (let [runtime-class (..reflection //.$Runtime) - bytecode ($d.class #$.V1_6 #$.Public $.finalC runtime-class (list) (type.class "java.lang.Object" (list)) (list) - (|>> adt-methods - frac-methods - pm-methods - io-methods)) - payload ["0" bytecode]] - (do phase.monad - [_ (generation.execute! runtime-class [runtime-class bytecode]) - _ (generation.save! false ["" "0"] payload)] - (wrap payload)))) - -(def: translate-function - (Operation [Text Binary]) - (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 _.ALOAD) - _.fuse)] - (|>> preI - (_.INVOKEVIRTUAL //.$Function apply-method (apply-signature (dec arity))) - (_.CHECKCAST //.$Function) - (_.ALOAD arity) - (_.INVOKEVIRTUAL //.$Function apply-method (apply-signature 1)) - _.ARETURN))))) - (list& ($d.abstract-method #$.Public $.noneM apply-method (apply-signature 1))) - $d.fuse) - $Object (type.class "java.lang.Object" (list)) - function-class (..reflection //.$Function) - bytecode ($d.abstract #$.V1_6 #$.Public $.noneC function-class (list) $Object (list) - (|>> ($d.field #$.Public $.finalF partials-field type.int) - ($d.method #$.Public $.noneM "<init>" (type.method [(list type.int) type.void (list)]) - (|>> (_.ALOAD 0) - (_.INVOKESPECIAL $Object "<init>" nullary-init-methodT) - (_.ALOAD 0) - (_.ILOAD 1) - (_.PUTFIELD //.$Function partials-field type.int) - _.RETURN)) - applyI)) - payload ["1" bytecode]] - (do phase.monad - [_ (generation.execute! function-class [function-class bytecode]) - _ (generation.save! false ["" "1"] payload)] - (wrap payload)))) - -(def: #export translate - (Operation [Registry Output]) - (do phase.monad - [runtime-payload ..translate-runtime - function-payload ..translate-function] - (wrap [(|> artifact.empty - artifact.resource - product.right - artifact.resource - product.right) - (row.row runtime-payload - function-payload)]))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/structure.lux b/new-luxc/source/luxc/lang/translation/jvm/structure.lux deleted file mode 100644 index 46f87142a..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/structure.lux +++ /dev/null @@ -1,79 +0,0 @@ -(.module: - [lux (#- Type) - [abstract - ["." monad (#+ do)]] - [control - ["ex" exception (#+ exception:)]] - [data - [number - ["n" nat]] - [text - ["%" format (#+ format)]] - [collection - ["." list]]] - [target - [jvm - ["." type (#+ Type) - ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] - ["." descriptor (#+ Descriptor)] - ["." signature (#+ Signature)]]]] - [tool - [compiler - ["." phase] - [meta - [archive (#+ Archive)]] - [language - [lux - [synthesis (#+ Synthesis)]]]]]] - [luxc - [lang - [host - [jvm (#+ Inst Operation Phase Generator) - ["_" inst]]]]] - ["." // - ["#." runtime]]) - -(exception: #export (not-a-tuple {size Nat}) - (ex.report ["Expected size" ">= 2"] - ["Actual size" (%.nat size)])) - -(def: #export (tuple generate archive members) - (Generator (List Synthesis)) - (do {@ phase.monad} - [#let [size (list.size members)] - _ (phase.assert not-a-tuple size - (n.>= 2 size)) - membersI (|> members - list.enumerate - (monad.map @ (function (_ [idx member]) - (do @ - [memberI (generate archive member)] - (wrap (|>> _.DUP - (_.int (.int idx)) - memberI - _.AASTORE))))) - (:: @ map _.fuse))] - (wrap (|>> (_.int (.int size)) - (_.array //runtime.$Value) - membersI)))) - -(def: (flagI right?) - (-> Bit Inst) - (if right? - (_.string "") - _.NULL)) - -(def: #export (variant generate archive [lefts right? member]) - (Generator [Nat Bit Synthesis]) - (do phase.monad - [memberI (generate archive member)] - (wrap (|>> (_.int (.int (if right? - (.inc lefts) - lefts))) - (flagI right?) - memberI - (_.INVOKESTATIC //.$Runtime - "variant_make" - (type.method [(list //runtime.$Tag //runtime.$Flag //runtime.$Value) - //.$Variant - (list)])))))) |