From 9eaaaf953ba7ce1eeb805603f4e113aa15f5178f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 8 Jan 2018 21:40:06 -0400 Subject: - Moved all translation code under the JVM path (in preparation for porting the JS back-end). --- new-luxc/source/luxc/lang/analysis/expression.lux | 2 +- new-luxc/source/luxc/lang/eval.lux | 4 +- new-luxc/source/luxc/lang/extension/statement.lux | 6 +- new-luxc/source/luxc/lang/host.jvm.lux | 2 +- new-luxc/source/luxc/lang/macro.lux | 2 +- new-luxc/source/luxc/lang/translation.lux | 15 +- new-luxc/source/luxc/lang/translation/case.jvm.lux | 230 ------ .../source/luxc/lang/translation/common.jvm.lux | 136 ---- new-luxc/source/luxc/lang/translation/eval.jvm.lux | 47 -- .../luxc/lang/translation/expression.jvm.lux | 76 -- .../source/luxc/lang/translation/function.jvm.lux | 325 --------- .../source/luxc/lang/translation/imports.jvm.lux | 149 ---- .../source/luxc/lang/translation/jvm/case.jvm.lux | 230 ++++++ .../luxc/lang/translation/jvm/common.jvm.lux | 136 ++++ .../source/luxc/lang/translation/jvm/eval.jvm.lux | 46 ++ .../luxc/lang/translation/jvm/expression.jvm.lux | 80 ++ .../luxc/lang/translation/jvm/function.jvm.lux | 325 +++++++++ .../luxc/lang/translation/jvm/imports.jvm.lux | 149 ++++ .../source/luxc/lang/translation/jvm/loop.jvm.lux | 80 ++ .../luxc/lang/translation/jvm/primitive.jvm.lux | 35 + .../luxc/lang/translation/jvm/procedure.jvm.lux | 27 + .../lang/translation/jvm/procedure/common.jvm.lux | 809 +++++++++++++++++++++ .../lang/translation/jvm/procedure/host.jvm.lux | 761 +++++++++++++++++++ .../luxc/lang/translation/jvm/reference.jvm.lux | 49 ++ .../luxc/lang/translation/jvm/runtime.jvm.lux | 603 +++++++++++++++ .../luxc/lang/translation/jvm/statement.jvm.lux | 159 ++++ .../luxc/lang/translation/jvm/structure.jvm.lux | 61 ++ new-luxc/source/luxc/lang/translation/loop.jvm.lux | 80 -- .../source/luxc/lang/translation/primitive.jvm.lux | 35 - .../source/luxc/lang/translation/procedure.jvm.lux | 27 - .../luxc/lang/translation/procedure/common.jvm.lux | 809 --------------------- .../luxc/lang/translation/procedure/host.jvm.lux | 761 ------------------- .../source/luxc/lang/translation/reference.jvm.lux | 49 -- .../source/luxc/lang/translation/runtime.jvm.lux | 603 --------------- .../source/luxc/lang/translation/statement.jvm.lux | 159 ---- .../source/luxc/lang/translation/structure.jvm.lux | 61 -- new-luxc/source/luxc/repl.lux | 2 +- 37 files changed, 3566 insertions(+), 3564 deletions(-) delete mode 100644 new-luxc/source/luxc/lang/translation/case.jvm.lux delete mode 100644 new-luxc/source/luxc/lang/translation/common.jvm.lux delete mode 100644 new-luxc/source/luxc/lang/translation/eval.jvm.lux delete mode 100644 new-luxc/source/luxc/lang/translation/expression.jvm.lux delete mode 100644 new-luxc/source/luxc/lang/translation/function.jvm.lux delete mode 100644 new-luxc/source/luxc/lang/translation/imports.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/eval.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/imports.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/procedure.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/statement.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux delete mode 100644 new-luxc/source/luxc/lang/translation/loop.jvm.lux delete mode 100644 new-luxc/source/luxc/lang/translation/primitive.jvm.lux delete mode 100644 new-luxc/source/luxc/lang/translation/procedure.jvm.lux delete mode 100644 new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux delete mode 100644 new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux delete mode 100644 new-luxc/source/luxc/lang/translation/reference.jvm.lux delete mode 100644 new-luxc/source/luxc/lang/translation/runtime.jvm.lux delete mode 100644 new-luxc/source/luxc/lang/translation/statement.jvm.lux delete mode 100644 new-luxc/source/luxc/lang/translation/structure.jvm.lux diff --git a/new-luxc/source/luxc/lang/analysis/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux index d19e98bd8..8907ba665 100644 --- a/new-luxc/source/luxc/lang/analysis/expression.lux +++ b/new-luxc/source/luxc/lang/analysis/expression.lux @@ -15,7 +15,7 @@ [".L" macro] [".L" extension] ["la" analysis] - (translation [".T" common]))) + (translation (jvm [".T" common])))) (// [".A" common] [".A" function] [".A" primitive] diff --git a/new-luxc/source/luxc/lang/eval.lux b/new-luxc/source/luxc/lang/eval.lux index 87cbadfa0..eb16cc433 100644 --- a/new-luxc/source/luxc/lang/eval.lux +++ b/new-luxc/source/luxc/lang/eval.lux @@ -6,8 +6,8 @@ (lang [".L" extension] (analysis [".A" expression]) (synthesis [".S" expression]) - (translation [".T" expression] - [".T" eval])))) + (translation (jvm [".T" expression] + [".T" eval]))))) (def: #export (eval type exprC) &.Eval diff --git a/new-luxc/source/luxc/lang/extension/statement.lux b/new-luxc/source/luxc/lang/extension/statement.lux index 7eb2b36bf..31e1759a0 100644 --- a/new-luxc/source/luxc/lang/extension/statement.lux +++ b/new-luxc/source/luxc/lang/extension/statement.lux @@ -17,9 +17,9 @@ (analysis [".A" common] [".A" expression]) (synthesis [".S" expression]) - (translation [".T" expression] - [".T" statement] - [".T" eval]) + (translation (jvm [".T" expression] + [".T" statement] + [".T" eval])) [".L" eval]))) (exception: #export Invalid-Statement) diff --git a/new-luxc/source/luxc/lang/host.jvm.lux b/new-luxc/source/luxc/lang/host.jvm.lux index 6eb8aacbc..7ec0df535 100644 --- a/new-luxc/source/luxc/lang/host.jvm.lux +++ b/new-luxc/source/luxc/lang/host.jvm.lux @@ -14,7 +14,7 @@ [io]) (luxc ["&" lang] (lang [".L" variable #+ Register] - (translation [".T" common])))) + (translation (jvm [".T" common]))))) (host.import org/objectweb/asm/Label) diff --git a/new-luxc/source/luxc/lang/macro.lux b/new-luxc/source/luxc/lang/macro.lux index 71b140c6e..deebba0bf 100644 --- a/new-luxc/source/luxc/lang/macro.lux +++ b/new-luxc/source/luxc/lang/macro.lux @@ -5,7 +5,7 @@ [macro] [host]) (luxc (lang [".L" host] - (translation [".T" common])))) + (translation (jvm [".T" common]))))) (for {"JVM" (as-is (host.import java/lang/reflect/Method (invoke [Object (Array Object)] #try Object)) diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux index 9a2b27122..cbd63b998 100644 --- a/new-luxc/source/luxc/lang/translation.lux +++ b/new-luxc/source/luxc/lang/translation.lux @@ -34,14 +34,13 @@ (analysis [".A" expression] [".A" common]) (synthesis [".S" expression]) - (translation [".T" runtime] - [".T" statement] - [".T" common #+ Artifacts] - [".T" expression] - [".T" eval] - [".T" imports]) - ["&." eval]) - )) + ["&." eval])) + (/ (jvm [".T" runtime] + [".T" statement] + [".T" common #+ Artifacts] + [".T" expression] + [".T" eval] + [".T" imports]))) (def: analyse (&.Analyser) diff --git a/new-luxc/source/luxc/lang/translation/case.jvm.lux b/new-luxc/source/luxc/lang/translation/case.jvm.lux deleted file mode 100644 index b693f50b8..000000000 --- a/new-luxc/source/luxc/lang/translation/case.jvm.lux +++ /dev/null @@ -1,230 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data text/format) - [macro "macro/" Monad]) - (luxc ["_" lang] - (lang [".L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$i" inst])) - ["ls" synthesis])) - [//runtime]) - -(def: $Object $.Type ($t.class "java.lang.Object" (list))) - -(def: (pop-altI stack-depth) - (-> Nat $.Inst) - (case stack-depth - +0 id - +1 $i.POP - +2 $i.POP2 - _ ## (n/> +2) - (|>> $i.POP2 - (pop-altI (n/- +2 stack-depth))))) - -(def: peekI - $.Inst - (|>> $i.DUP - ($i.INVOKESTATIC hostL.runtime-class - "pm_peek" - ($t.method (list //runtime.$Stack) - (#.Some $Object) - (list)) - false))) - -(def: popI - $.Inst - (|>> ($i.INVOKESTATIC hostL.runtime-class - "pm_pop" - ($t.method (list //runtime.$Stack) - (#.Some //runtime.$Stack) - (list)) - false))) - -(def: pushI - $.Inst - (|>> ($i.INVOKESTATIC hostL.runtime-class - "pm_push" - ($t.method (list //runtime.$Stack $Object) - (#.Some //runtime.$Stack) - (list)) - false))) - -(exception: #export Unrecognized-Path) - -(def: (translate-path' translate stack-depth @else @end path) - (-> (-> ls.Synthesis (Meta $.Inst)) - Nat $.Label $.Label ls.Path (Meta $.Inst)) - (case path - (^ [_ (#.Form (list [_ (#.Text "lux case exec")] bodyS))]) - (do macro.Monad - [bodyI (translate bodyS)] - (wrap (|>> (pop-altI stack-depth) - bodyI - ($i.GOTO @end)))) - - (^ [_ (#.Form (list [_ (#.Text "lux case pop")]))]) - (macro/wrap popI) - - (^ [_ (#.Form (list [_ (#.Text "lux case bind")] [_ (#.Nat register)]))]) - (macro/wrap (|>> peekI - ($i.ASTORE register))) - - [_ (#.Bool value)] - (macro/wrap (let [jumpI (if value $i.IFEQ $i.IFNE)] - (|>> peekI - ($i.unwrap #$.Boolean) - (jumpI @else)))) - - (^template [ ] - [_ ( value)] - (macro/wrap (|>> peekI - ($i.unwrap #$.Long) - ($i.long (|> value )) - $i.LCMP - ($i.IFNE @else)))) - ([#.Nat (:! Int)] - [#.Int (: Int)] - [#.Deg (:! Int)]) - - [_ (#.Frac value)] - (macro/wrap (|>> peekI - ($i.unwrap #$.Double) - ($i.double value) - $i.DCMPL - ($i.IFNE @else))) - - [_ (#.Text value)] - (macro/wrap (|>> peekI - ($i.string value) - ($i.INVOKEVIRTUAL "java.lang.Object" - "equals" - ($t.method (list $Object) - (#.Some $t.boolean) - (list)) - false) - ($i.IFEQ @else))) - - (^template [ ] - (^ [_ (#.Form (list [_ (#.Text )] [_ (#.Nat idx)]))]) - (macro/wrap (case idx - +0 - (|>> peekI - ($i.CHECKCAST ($t.descriptor //runtime.$Tuple)) - ($i.int 0) - $i.AALOAD - pushI) - - _ - (|>> peekI - ($i.CHECKCAST ($t.descriptor //runtime.$Tuple)) - ($i.int (nat-to-int idx)) - ($i.INVOKESTATIC hostL.runtime-class - - ($t.method (list //runtime.$Tuple $t.int) - (#.Some $Object) - (list)) - false) - pushI)))) - (["lux case tuple left" "pm_left"] - ["lux case tuple right" "pm_right"]) - - (^template [ ] - (^ [_ (#.Form (list [_ (#.Text )] [_ (#.Nat idx)]))]) - (macro/wrap (<| $i.with-label (function [@success]) - $i.with-label (function [@fail]) - (|>> peekI - ($i.CHECKCAST ($t.descriptor //runtime.$Variant)) - ($i.int (nat-to-int idx)) - - ($i.INVOKESTATIC hostL.runtime-class "pm_variant" - ($t.method (list //runtime.$Variant //runtime.$Tag //runtime.$Flag) - (#.Some //runtime.$Datum) - (list)) - false) - $i.DUP - ($i.IFNULL @fail) - ($i.GOTO @success) - ($i.label @fail) - $i.POP - ($i.GOTO @else) - ($i.label @success) - pushI)))) - (["lux case variant left" $i.NULL] - ["lux case variant right" ($i.string "")]) - - (^ [_ (#.Form (list [_ (#.Text "lux case seq")] leftP rightP))]) - (do macro.Monad - [leftI (translate-path' translate stack-depth @else @end leftP) - rightI (translate-path' translate stack-depth @else @end rightP)] - (wrap (|>> leftI - rightI))) - - (^ [_ (#.Form (list [_ (#.Text "lux case alt")] leftP rightP))]) - (do macro.Monad - [@alt-else $i.make-label - leftI (translate-path' translate (n/inc stack-depth) @alt-else @end leftP) - rightI (translate-path' translate stack-depth @else @end rightP)] - (wrap (|>> $i.DUP - leftI - ($i.label @alt-else) - $i.POP - rightI))) - - _ - (_.throw Unrecognized-Path (%code path)))) - -(def: (translate-path translate path @end) - (-> (-> ls.Synthesis (Meta $.Inst)) - ls.Path $.Label (Meta $.Inst)) - (do macro.Monad - [@else $i.make-label - pathI (translate-path' translate +1 @else @end path)] - (wrap (|>> pathI - ($i.label @else) - $i.POP - ($i.INVOKESTATIC hostL.runtime-class - "pm_fail" - ($t.method (list) #.None (list)) - false) - $i.NULL - ($i.GOTO @end))))) - -(def: #export (translate-if testI thenI elseI) - (-> $.Inst $.Inst $.Inst $.Inst) - (<| $i.with-label (function [@else]) - $i.with-label (function [@end]) - (|>> testI - ($i.unwrap #$.Boolean) - ($i.IFEQ @else) - thenI - ($i.GOTO @end) - ($i.label @else) - elseI - ($i.label @end)))) - -(def: #export (translate-case translate valueS path) - (-> (-> ls.Synthesis (Meta $.Inst)) - ls.Synthesis ls.Path (Meta $.Inst)) - (do macro.Monad - [@end $i.make-label - valueI (translate valueS) - pathI (translate-path translate path @end)] - (wrap (|>> valueI - $i.NULL - $i.SWAP - pushI - pathI - ($i.label @end))))) - -(def: #export (translate-let translate register inputS exprS) - (-> (-> ls.Synthesis (Meta $.Inst)) - Nat ls.Synthesis ls.Synthesis (Meta $.Inst)) - (do macro.Monad - [inputI (translate inputS) - exprI (translate exprS)] - (wrap (|>> inputI - ($i.ASTORE register) - exprI)))) diff --git a/new-luxc/source/luxc/lang/translation/common.jvm.lux b/new-luxc/source/luxc/lang/translation/common.jvm.lux deleted file mode 100644 index a4eb5b93b..000000000 --- a/new-luxc/source/luxc/lang/translation/common.jvm.lux +++ /dev/null @@ -1,136 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - [io] - (concurrency [atom #+ Atom atom]) - (data ["e" error #+ Error] - [text "text/" Hash] - text/format - (coll [dict #+ Dict])) - [macro] - [host] - (world [blob #+ Blob] - [file #+ File])) - (luxc [lang] - (lang [".L" variable #+ Register] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst]))))) - -(host.import org/objectweb/asm/Opcodes - (#static V1_6 int)) - -(host.import org/objectweb/asm/Label) - -(host.import java/lang/Object) - -(host.import java/lang/reflect/Field - (get [#? Object] #try #? Object)) - -(host.import (java/lang/Class c) - (getField [String] #try Field)) - -(host.import java/lang/ClassLoader - (loadClass [String] (Class Object))) - -(type: #export Bytecode Blob) - -(type: #export Class-Store (Atom (Dict Text Bytecode))) - -(type: #export Artifacts (Dict File Blob)) - -(type: #export Host - {#loader ClassLoader - #store Class-Store - #artifacts Artifacts - #context [Text Nat] - #anchor (Maybe [Label Register])}) - -(exception: #export Unknown-Class) -(exception: #export Class-Already-Stored) -(exception: #export No-Function-Being-Compiled) -(exception: #export Cannot-Overwrite-Artifact) -(exception: #export Cannot-Load-Definition) -(exception: #export Invalid-Definition-Value) - -(def: #export (with-artifacts action) - (All [a] (-> (Meta a) (Meta [Artifacts a]))) - (function [compiler] - (case (action (update@ #.host - (|>> (:! Host) - (set@ #artifacts (dict.new text.Hash)) - (:! Void)) - compiler)) - (#e.Success [compiler' output]) - (#e.Success [(update@ #.host - (|>> (:! Host) - (set@ #artifacts (|> (get@ #.host compiler) (:! Host) (get@ #artifacts))) - (:! Void)) - compiler') - [(|> compiler' (get@ #.host) (:! Host) (get@ #artifacts)) - output]]) - - (#e.Error error) - (#e.Error error)))) - -(def: #export (record-artifact name content) - (-> Text Blob (Meta Unit)) - (function [compiler] - (if (|> compiler (get@ #.host) (:! Host) (get@ #artifacts) (dict.contains? name)) - (ex.throw Cannot-Overwrite-Artifact name) - (#e.Success [(update@ #.host - (|>> (:! Host) - (update@ #artifacts (dict.put name content)) - (:! Void)) - compiler) - []])))) - -(def: #export (store-class name byte-code) - (-> Text Bytecode (Meta Unit)) - (function [compiler] - (let [store (|> (get@ #.host compiler) - (:! Host) - (get@ #store))] - (if (dict.contains? name (|> store atom.read io.run)) - (ex.throw Class-Already-Stored name) - (#e.Success [compiler (io.run (atom.update (dict.put name byte-code) store))]) - )))) - -(def: #export (load-class name) - (-> Text (Meta (Class Object))) - (function [compiler] - (let [host (:! Host (get@ #.host compiler)) - store (|> host (get@ #store) atom.read io.run)] - (if (dict.contains? name store) - (#e.Success [compiler (ClassLoader::loadClass [name] (get@ #loader host))]) - (ex.throw Unknown-Class name))))) - -(def: #export value-field Text "_value") -(def: #export $Object $.Type ($t.class "java.lang.Object" (list))) - -(def: #export (load-definition compiler) - (-> Compiler - (-> Ident Blob (Error Top))) - (function [(^@ def-ident [def-module def-name]) def-bytecode] - (let [normal-name (format (lang.normalize-name def-name) (%n (text/hash def-name))) - class-name (format (text.replace-all "/" "." def-module) "." normal-name)] - (<| (macro.run compiler) - (do macro.Monad - [_ (..store-class class-name def-bytecode) - class (..load-class class-name)] - (case (do e.Monad - [field (Class::getField [..value-field] class)] - (Field::get [#.None] field)) - (#e.Success (#.Some def-value)) - (wrap def-value) - - (#e.Success #.None) - (lang.throw Invalid-Definition-Value (%ident def-ident)) - - (#e.Error error) - (lang.throw Cannot-Load-Definition - (format "Definition: " (%ident def-ident) "\n" - "Error:\n" - error)))))))) diff --git a/new-luxc/source/luxc/lang/translation/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/eval.jvm.lux deleted file mode 100644 index 9cce16a49..000000000 --- a/new-luxc/source/luxc/lang/translation/eval.jvm.lux +++ /dev/null @@ -1,47 +0,0 @@ -(.module: - lux - (lux (control monad) - (data [text] - text/format) - [macro] - [host #+ do-to]) - (luxc ["&" lang] - (lang (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - ["la" analysis] - ["ls" synthesis] - (translation [".T" common])) - )) - -(host.import java/lang/reflect/Field - (get [Object] Object)) - -(host.import (java/lang/Class a) - (getField [String] Field)) - -(def: #export (eval valueI) - (-> $.Inst (Meta Top)) - (do macro.Monad - [current-module macro.current-module-name - class-name (:: @ map %code (macro.gensym (format current-module "/eval"))) - #let [store-name (text.replace-all "/" "." class-name) - bytecode ($d.class #$.V1_6 - #$.Public $.noneC - class-name - (list) ["java.lang.Object" (list)] - (list) - (|>> ($d.field #$.Public ($_ $.++F $.finalF $.staticF) - commonT.value-field commonT.$Object) - ($d.method #$.Public ($_ $.++M $.staticM $.strictM) - "" - ($t.method (list) #.None (list)) - (|>> valueI - ($i.PUTSTATIC store-name commonT.value-field commonT.$Object) - $i.RETURN))))] - _ (commonT.store-class store-name bytecode) - class (commonT.load-class store-name)] - (wrap (|> class - (Class::getField [commonT.value-field]) - (Field::get (host.null)))))) diff --git a/new-luxc/source/luxc/lang/translation/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/expression.jvm.lux deleted file mode 100644 index 4496de784..000000000 --- a/new-luxc/source/luxc/lang/translation/expression.jvm.lux +++ /dev/null @@ -1,76 +0,0 @@ -(.module: - lux - (lux (control monad - ["ex" exception #+ exception:] - ["p" parser]) - (data ["e" error] - text/format) - [macro] - (macro ["s" syntax])) - (luxc ["&" lang] - (lang [".L" variable #+ Variable Register] - (host ["$" jvm]) - ["ls" synthesis] - (translation [".T" common] - [".T" primitive] - [".T" structure] - [".T" eval] - [".T" procedure] - [".T" function] - [".T" reference] - [".T" case])))) - -(exception: #export Unrecognized-Synthesis) - -(def: #export (translate synthesis) - (-> ls.Synthesis (Meta $.Inst)) - (case synthesis - (^code []) - primitiveT.translate-unit - - (^code [(~ singleton)]) - (translate singleton) - - (^template [ ] - [_ ( value)] - ( value)) - ([#.Bool primitiveT.translate-bool] - [#.Nat primitiveT.translate-nat] - [#.Int primitiveT.translate-int] - [#.Deg primitiveT.translate-deg] - [#.Frac primitiveT.translate-frac] - [#.Text primitiveT.translate-text]) - - (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bool last?)]) (~ valueS))) - (structureT.translate-variant translate tag last? valueS) - - (^code [(~+ members)]) - (structureT.translate-tuple translate members) - - (^ [_ (#.Form (list [_ (#.Int var)]))]) - (if (variableL.captured? var) - (referenceT.translate-captured var) - (referenceT.translate-local var)) - - [_ (#.Symbol definition)] - (referenceT.translate-definition definition) - - (^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ exprS))) - (caseT.translate-let translate register inputS exprS) - - (^code ("lux case" (~ inputS) (~ pathPS))) - (caseT.translate-case translate inputS pathPS) - - (^multi (^code ("lux function" (~ [_ (#.Nat arity)]) [(~+ environment)] (~ bodyS))) - [(s.run environment (p.some s.int)) (#e.Success environment)]) - (functionT.translate-function translate environment arity bodyS) - - (^code ("lux call" (~ functionS) (~+ argsS))) - (functionT.translate-call translate functionS argsS) - - (^code ((~ [_ (#.Text procedure)]) (~+ argsS))) - (procedureT.translate-procedure translate procedure argsS) - - _ - (&.throw Unrecognized-Synthesis (%code synthesis)) - )) diff --git a/new-luxc/source/luxc/lang/translation/function.jvm.lux b/new-luxc/source/luxc/lang/translation/function.jvm.lux deleted file mode 100644 index 3070800fe..000000000 --- a/new-luxc/source/luxc/lang/translation/function.jvm.lux +++ /dev/null @@ -1,325 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format - (coll [list "list/" Functor Monoid])) - [macro]) - (luxc ["&" lang] - (lang [".L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - ["la" analysis] - ["ls" synthesis] - (translation [".T" common] - [".T" runtime] - [".T" reference]) - [".L" variable #+ Variable]))) - - -(def: arity-field Text "arity") -(def: $Object $.Type ($t.class "java.lang.Object" (list))) - -(def: (poly-arg? arity) - (-> ls.Arity Bool) - (n/> +1 arity)) - -(def: (reset-method class) - (-> Text $.Method) - ($t.method (list) (#.Some ($t.class class (list))) (list))) - -(def: (captured-args env) - (-> (List Variable) (List $.Type)) - (list.repeat (list.size env) $Object)) - -(def: (init-method env arity) - (-> (List Variable) ls.Arity $.Method) - (if (poly-arg? arity) - ($t.method (list.concat (list (captured-args env) - (list $t.int) - (list.repeat (n/dec arity) $Object))) - #.None - (list)) - ($t.method (captured-args env) #.None (list)))) - -(def: (implementation-method arity) - ($t.method (list.repeat arity $Object) (#.Some $Object) (list))) - -(def: get-amount-of-partialsI - $.Inst - (|>> ($i.ALOAD +0) - ($i.GETFIELD hostL.function-class runtimeT.partials-field $t.int))) - -(def: (load-fieldI class field) - (-> Text Text $.Inst) - (|>> ($i.ALOAD +0) - ($i.GETFIELD class field $Object))) - -(def: (inputsI start amount) - (-> $.Register Nat $.Inst) - (|> (list.n/range start (n/+ start (n/dec amount))) - (list/map $i.ALOAD) - $i.fuse)) - -(def: (applysI start amount) - (-> $.Register Nat $.Inst) - (let [max-args (n/min amount runtimeT.num-apply-variants) - later-applysI (if (n/> runtimeT.num-apply-variants amount) - (applysI (n/+ runtimeT.num-apply-variants start) (n/- runtimeT.num-apply-variants amount)) - id)] - (|>> ($i.CHECKCAST hostL.function-class) - (inputsI start max-args) - ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.apply-signature max-args) false) - later-applysI))) - -(def: (inc-intI by) - (-> Nat $.Inst) - (|>> ($i.int (nat-to-int by)) - $i.IADD)) - -(def: (nullsI amount) - (-> Nat $.Inst) - (|> $i.NULL - (list.repeat amount) - $i.fuse)) - -(def: (with-captured env) - (-> (List Variable) $.Def) - (|> (list.enumerate env) - (list/map (function [[env-idx env-source]] - ($d.field #$.Private $.finalF (referenceT.captured env-idx) $Object))) - $d.fuse)) - -(def: (with-partial arity) - (-> ls.Arity $.Def) - (if (poly-arg? arity) - (|> (list.n/range +0 (n/- +2 arity)) - (list/map (function [idx] - ($d.field #$.Private $.finalF (referenceT.partial idx) $Object))) - $d.fuse) - id)) - -(def: (instance class arity env) - (-> Text ls.Arity (List Variable) (Meta $.Inst)) - (do macro.Monad - [captureI+ (monad.map @ referenceT.translate-variable env) - #let [argsI (if (poly-arg? arity) - (|> (nullsI (n/dec arity)) - (list ($i.int 0)) - $i.fuse) - id)]] - (wrap (|>> ($i.NEW class) - $i.DUP - ($i.fuse captureI+) - argsI - ($i.INVOKESPECIAL class "" (init-method env arity) false))))) - -(def: (with-reset class arity env) - (-> Text ls.Arity (List Variable) $.Def) - ($d.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 (n/dec env-size))) - (list/map (function [source] - (|>> ($i.ALOAD +0) - ($i.GETFIELD class (referenceT.captured source) $Object)))) - $i.fuse) - argsI (|> (nullsI (n/dec arity)) - (list ($i.int 0)) - $i.fuse)] - (|>> ($i.NEW class) - $i.DUP - captureI - argsI - ($i.INVOKESPECIAL class "" (init-method env arity) false) - $i.ARETURN)) - (|>> ($i.ALOAD +0) - $i.ARETURN)))) - -(def: (with-implementation arity @begin bodyI) - (-> Nat $.Label $.Inst $.Def) - ($d.method #$.Public $.strictM "impl" (implementation-method arity) - (|>> ($i.label @begin) - bodyI - $i.ARETURN))) - -(def: function-init-method - $.Method - ($t.method (list $t.int) #.None (list))) - -(def: (function-init arity env-size) - (-> ls.Arity Nat $.Inst) - (if (n/= +1 arity) - (|>> ($i.int 0) - ($i.INVOKESPECIAL hostL.function-class "" function-init-method false)) - (|>> ($i.ILOAD (n/inc env-size)) - ($i.INVOKESPECIAL hostL.function-class "" function-init-method false)))) - -(def: (with-init class env arity) - (-> Text (List Variable) ls.Arity $.Def) - (let [env-size (list.size env) - offset-partial (: (-> Nat Nat) - (|>> n/inc (n/+ env-size))) - store-capturedI (|> (case env-size - +0 (list) - _ (list.n/range +0 (n/dec env-size))) - (list/map (function [register] - (|>> ($i.ALOAD +0) - ($i.ALOAD (n/inc register)) - ($i.PUTFIELD class (referenceT.captured register) $Object)))) - $i.fuse) - store-partialI (if (poly-arg? arity) - (|> (list.n/range +0 (n/- +2 arity)) - (list/map (function [idx] - (let [register (offset-partial idx)] - (|>> ($i.ALOAD +0) - ($i.ALOAD (n/inc register)) - ($i.PUTFIELD class (referenceT.partial idx) $Object))))) - $i.fuse) - id)] - ($d.method #$.Public $.noneM "" (init-method env arity) - (|>> ($i.ALOAD +0) - (function-init arity env-size) - store-capturedI - store-partialI - $i.RETURN)))) - -(def: (with-apply class env function-arity @begin bodyI apply-arity) - (-> Text (List Variable) ls.Arity $.Label $.Inst ls.Arity - $.Def) - (let [num-partials (n/dec function-arity) - @default ($.new-label []) - @labels (list/map $.new-label (list.repeat num-partials [])) - arity-over-extent (|> (nat-to-int function-arity) (i/- (nat-to-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 (n/dec stage)) - (list/map (|>> referenceT.partial (load-fieldI class))) - $i.fuse) - id)] - (cond (i/= arity-over-extent (nat-to-int stage)) - (|>> ($i.label @label) - ($i.ALOAD +0) - (when (n/> +0 stage) - ($i.INVOKEVIRTUAL class "reset" (reset-method class) false)) - load-partialsI - (inputsI +1 apply-arity) - ($i.INVOKEVIRTUAL class "impl" (implementation-method function-arity) false) - $i.ARETURN) - - (i/> arity-over-extent (nat-to-int stage)) - (let [args-to-completion (|> function-arity (n/- stage)) - args-left (|> apply-arity (n/- args-to-completion))] - (|>> ($i.label @label) - ($i.ALOAD +0) - ($i.INVOKEVIRTUAL class "reset" (reset-method class) false) - load-partialsI - (inputsI +1 args-to-completion) - ($i.INVOKEVIRTUAL class "impl" (implementation-method function-arity) false) - (applysI (n/inc args-to-completion) args-left) - $i.ARETURN)) - - ## (i/< arity-over-extent (nat-to-int stage)) - (let [env-size (list.size env) - load-capturedI (|> (case env-size - +0 (list) - _ (list.n/range +0 (n/dec env-size))) - (list/map (|>> referenceT.captured (load-fieldI class))) - $i.fuse)] - (|>> ($i.label @label) - ($i.NEW class) - $i.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))) - ($i.INVOKESPECIAL class "" (init-method env function-arity) false) - $i.ARETURN)) - )))) - $i.fuse)] - ($d.method #$.Public $.noneM runtimeT.apply-method (runtimeT.apply-signature apply-arity) - (|>> get-amount-of-partialsI - ($i.TABLESWITCH 0 (|> num-partials n/dec nat-to-int) - @default @labels) - casesI - ($i.INVOKESTATIC hostL.runtime-class "apply_fail" ($t.method (list) #.None (list)) false) - $i.NULL - $i.ARETURN - )))) - -(def: #export (with-function @begin class env arity bodyI) - (-> $.Label Text (List Variable) ls.Arity $.Inst - (Meta [$.Def $.Inst])) - (let [env-size (list.size env) - applyD (: $.Def - (if (poly-arg? arity) - (|> (n/min arity runtimeT.num-apply-variants) - (list.n/range +1) - (list/map (with-apply class env arity @begin bodyI)) - (list& (with-implementation arity @begin bodyI)) - $d.fuse) - ($d.method #$.Public $.strictM runtimeT.apply-method (runtimeT.apply-signature +1) - (|>> ($i.label @begin) - bodyI - $i.ARETURN)))) - functionD (: $.Def - (|>> ($d.int-field #$.Public ($_ $.++F $.staticF $.finalF) arity-field (nat-to-int arity)) - (with-captured env) - (with-partial arity) - (with-init class env arity) - (with-reset class arity env) - applyD - ))] - (do macro.Monad - [instanceI (instance class arity env)] - (wrap [functionD instanceI])))) - -(def: #export (translate-function translate env arity bodyS) - (-> (-> ls.Synthesis (Meta $.Inst)) - (List Variable) ls.Arity ls.Synthesis - (Meta $.Inst)) - (do macro.Monad - [@begin $i.make-label - [function-class bodyI] (hostL.with-sub-context - (hostL.with-anchor [@begin +1] - (translate bodyS))) - this-module macro.current-module-name - #let [function-class (format (text.replace-all "/" "." this-module) "." function-class)] - [functionD instanceI] (with-function @begin function-class env arity bodyI) - _ (commonT.store-class function-class - ($d.class #$.V1_6 #$.Public $.finalC - function-class (list) - ($.simple-class hostL.function-class) (list) - functionD))] - (wrap instanceI))) - -(def: (segment size elems) - (All [a] (-> Nat (List a) (List (List a)))) - (let [[pre post] (list.split size elems)] - (if (list.empty? post) - (list pre) - (list& pre (segment size post))))) - -(def: #export (translate-call translate functionS argsS) - (-> (-> ls.Synthesis (Meta $.Inst)) - ls.Synthesis (List ls.Synthesis) - (Meta $.Inst)) - (do macro.Monad - [functionI (translate functionS) - argsI (monad.map @ translate argsS) - #let [applyI (|> (segment runtimeT.num-apply-variants argsI) - (list/map (function [chunkI+] - (|>> ($i.CHECKCAST hostL.function-class) - ($i.fuse chunkI+) - ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.apply-signature (list.size chunkI+)) false)))) - $i.fuse)]] - (wrap (|>> functionI - applyI)))) diff --git a/new-luxc/source/luxc/lang/translation/imports.jvm.lux b/new-luxc/source/luxc/lang/translation/imports.jvm.lux deleted file mode 100644 index 892dd869f..000000000 --- a/new-luxc/source/luxc/lang/translation/imports.jvm.lux +++ /dev/null @@ -1,149 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["p" parser] - ["ex" exception #+ exception:] - pipe) - (concurrency [promise #+ Promise] - [stm #+ Var STM]) - (data ["e" error #+ Error] - [maybe] - [product] - [text "text/" Eq] - text/format - (coll [list "list/" Functor Fold] - [dict #+ Dict])) - [macro] - (macro [code] - ["s" syntax]) - [io #+ IO Process io] - [host]) - (luxc ["&" lang] - (lang [".L" module]))) - -(exception: #export Invalid-Imports) -(exception: #export Module-Cannot-Import-Itself) -(exception: #export Circular-Dependency) - -(host.import (java/util/concurrent/Future a) - (get [] #io a)) - -(host.import (java/util/concurrent/CompletableFuture a) - (new []) - (complete [a] boolean) - (#static [a] completedFuture [a] (CompletableFuture a))) - -(type: Import - {#module Text - #alias Text}) - -(def: import (s.Syntax Import) (s.tuple (p.seq s.text s.text))) - -(def: compilations - (Var (Dict Text (CompletableFuture (Error Compiler)))) - (stm.var (dict.new text.Hash))) - -(def: (promise-to-future promise) - (All [a] (-> (Promise a) (Future a))) - (let [future (CompletableFuture::new [])] - (exec (:: promise.Functor map - (function [value] (CompletableFuture::complete [value] future)) - promise) - future))) - -(def: from-io - (All [a] (-> (IO a) (Process a))) - (:: io.Monad map (|>> #e.Success))) - -(def: (translate-dependency translate-module dependency compiler) - (-> (-> Text Compiler (Process Compiler)) - (-> Text Compiler (IO (Future (Error Compiler))))) - (<| (Future::get []) - promise-to-future - (do promise.Monad - [[new? future] (stm.commit (: (STM [Bool (CompletableFuture (Error Compiler))]) - (do stm.Monad - [current-compilations (stm.read compilations)] - (case (dict.get dependency current-compilations) - (#.Some ongoing) - (wrap [false ongoing]) - - #.None - (do @ - [#let [pending (: (CompletableFuture (Error Compiler)) - (CompletableFuture::new []))] - _ (stm.write (dict.put dependency pending current-compilations) - compilations)] - (wrap [true pending]))))))] - (if new? - (exec (promise.future (io (CompletableFuture::complete [(io.run (translate-module dependency compiler))] - future))) - (wrap future)) - (wrap future))))) - -(def: compiled? - (-> Module Bool) - (|>> (get@ #.module-state) - (case> - (^or #.Cached #.Compiled) - true - - _ - false))) - -(def: (merge-modules current-module from-dependency from-current) - (-> Text (List [Text Module]) (List [Text Module]) (List [Text Module])) - (|> from-dependency - (list.filter (|>> product.right compiled?)) - (list/fold (function [[dep-name dep-module] total] (&.pl-put dep-name dep-module total)) - from-current))) - -(def: (merge-compilers current-module dependency total) - (-> Text Compiler Compiler Compiler) - (|> total - (update@ #.modules (merge-modules current-module (get@ #.modules dependency))) - (set@ #.seed (get@ #.seed dependency)))) - -(def: #export (translate-imports translate-module annotations) - (-> (-> Text Compiler (Process Compiler)) - Code - (Meta (Process Compiler))) - (do macro.Monad - [_ (moduleL.set-annotations annotations) - current-module macro.current-module-name - imports (let [imports (|> (macro.get-tuple-ann (ident-for #.imports) annotations) - (maybe.default (list)))] - (case (s.run imports (p.some import)) - (#e.Success imports) - (wrap imports) - - (#e.Error error) - (&.throw Invalid-Imports (%code (code.tuple imports))))) - dependencies (monad.map @ (: (-> [Text Text] (Meta (IO (Future (Error Compiler))))) - (function [[dependency alias]] - (do @ - [_ (&.assert Module-Cannot-Import-Itself current-module - (not (text/= current-module dependency))) - already-seen? (moduleL.exists? dependency) - circular-dependency? (if already-seen? - (moduleL.active? dependency) - (wrap false)) - _ (&.assert Circular-Dependency (format "From: " current-module "\n" - " To: " dependency) - (not circular-dependency?)) - _ (moduleL.import dependency) - _ (if (text/= "" alias) - (wrap []) - (moduleL.alias alias dependency)) - compiler macro.get-compiler] - (if already-seen? - (wrap (io (CompletableFuture::completedFuture [(#e.Success compiler)]))) - (wrap (translate-dependency translate-module dependency compiler)))))) - imports) - compiler macro.get-compiler] - (wrap (do io.Monad - [dependencies (monad.seq io.Monad (list/map from-io dependencies)) - dependencies (|> dependencies - (list/map (Future::get [])) - (monad.seq io.Monad))] - (wrap (list/fold (merge-compilers current-module) compiler dependencies)))))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux new file mode 100644 index 000000000..b693f50b8 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux @@ -0,0 +1,230 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data text/format) + [macro "macro/" Monad]) + (luxc ["_" lang] + (lang [".L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$i" inst])) + ["ls" synthesis])) + [//runtime]) + +(def: $Object $.Type ($t.class "java.lang.Object" (list))) + +(def: (pop-altI stack-depth) + (-> Nat $.Inst) + (case stack-depth + +0 id + +1 $i.POP + +2 $i.POP2 + _ ## (n/> +2) + (|>> $i.POP2 + (pop-altI (n/- +2 stack-depth))))) + +(def: peekI + $.Inst + (|>> $i.DUP + ($i.INVOKESTATIC hostL.runtime-class + "pm_peek" + ($t.method (list //runtime.$Stack) + (#.Some $Object) + (list)) + false))) + +(def: popI + $.Inst + (|>> ($i.INVOKESTATIC hostL.runtime-class + "pm_pop" + ($t.method (list //runtime.$Stack) + (#.Some //runtime.$Stack) + (list)) + false))) + +(def: pushI + $.Inst + (|>> ($i.INVOKESTATIC hostL.runtime-class + "pm_push" + ($t.method (list //runtime.$Stack $Object) + (#.Some //runtime.$Stack) + (list)) + false))) + +(exception: #export Unrecognized-Path) + +(def: (translate-path' translate stack-depth @else @end path) + (-> (-> ls.Synthesis (Meta $.Inst)) + Nat $.Label $.Label ls.Path (Meta $.Inst)) + (case path + (^ [_ (#.Form (list [_ (#.Text "lux case exec")] bodyS))]) + (do macro.Monad + [bodyI (translate bodyS)] + (wrap (|>> (pop-altI stack-depth) + bodyI + ($i.GOTO @end)))) + + (^ [_ (#.Form (list [_ (#.Text "lux case pop")]))]) + (macro/wrap popI) + + (^ [_ (#.Form (list [_ (#.Text "lux case bind")] [_ (#.Nat register)]))]) + (macro/wrap (|>> peekI + ($i.ASTORE register))) + + [_ (#.Bool value)] + (macro/wrap (let [jumpI (if value $i.IFEQ $i.IFNE)] + (|>> peekI + ($i.unwrap #$.Boolean) + (jumpI @else)))) + + (^template [ ] + [_ ( value)] + (macro/wrap (|>> peekI + ($i.unwrap #$.Long) + ($i.long (|> value )) + $i.LCMP + ($i.IFNE @else)))) + ([#.Nat (:! Int)] + [#.Int (: Int)] + [#.Deg (:! Int)]) + + [_ (#.Frac value)] + (macro/wrap (|>> peekI + ($i.unwrap #$.Double) + ($i.double value) + $i.DCMPL + ($i.IFNE @else))) + + [_ (#.Text value)] + (macro/wrap (|>> peekI + ($i.string value) + ($i.INVOKEVIRTUAL "java.lang.Object" + "equals" + ($t.method (list $Object) + (#.Some $t.boolean) + (list)) + false) + ($i.IFEQ @else))) + + (^template [ ] + (^ [_ (#.Form (list [_ (#.Text )] [_ (#.Nat idx)]))]) + (macro/wrap (case idx + +0 + (|>> peekI + ($i.CHECKCAST ($t.descriptor //runtime.$Tuple)) + ($i.int 0) + $i.AALOAD + pushI) + + _ + (|>> peekI + ($i.CHECKCAST ($t.descriptor //runtime.$Tuple)) + ($i.int (nat-to-int idx)) + ($i.INVOKESTATIC hostL.runtime-class + + ($t.method (list //runtime.$Tuple $t.int) + (#.Some $Object) + (list)) + false) + pushI)))) + (["lux case tuple left" "pm_left"] + ["lux case tuple right" "pm_right"]) + + (^template [ ] + (^ [_ (#.Form (list [_ (#.Text )] [_ (#.Nat idx)]))]) + (macro/wrap (<| $i.with-label (function [@success]) + $i.with-label (function [@fail]) + (|>> peekI + ($i.CHECKCAST ($t.descriptor //runtime.$Variant)) + ($i.int (nat-to-int idx)) + + ($i.INVOKESTATIC hostL.runtime-class "pm_variant" + ($t.method (list //runtime.$Variant //runtime.$Tag //runtime.$Flag) + (#.Some //runtime.$Datum) + (list)) + false) + $i.DUP + ($i.IFNULL @fail) + ($i.GOTO @success) + ($i.label @fail) + $i.POP + ($i.GOTO @else) + ($i.label @success) + pushI)))) + (["lux case variant left" $i.NULL] + ["lux case variant right" ($i.string "")]) + + (^ [_ (#.Form (list [_ (#.Text "lux case seq")] leftP rightP))]) + (do macro.Monad + [leftI (translate-path' translate stack-depth @else @end leftP) + rightI (translate-path' translate stack-depth @else @end rightP)] + (wrap (|>> leftI + rightI))) + + (^ [_ (#.Form (list [_ (#.Text "lux case alt")] leftP rightP))]) + (do macro.Monad + [@alt-else $i.make-label + leftI (translate-path' translate (n/inc stack-depth) @alt-else @end leftP) + rightI (translate-path' translate stack-depth @else @end rightP)] + (wrap (|>> $i.DUP + leftI + ($i.label @alt-else) + $i.POP + rightI))) + + _ + (_.throw Unrecognized-Path (%code path)))) + +(def: (translate-path translate path @end) + (-> (-> ls.Synthesis (Meta $.Inst)) + ls.Path $.Label (Meta $.Inst)) + (do macro.Monad + [@else $i.make-label + pathI (translate-path' translate +1 @else @end path)] + (wrap (|>> pathI + ($i.label @else) + $i.POP + ($i.INVOKESTATIC hostL.runtime-class + "pm_fail" + ($t.method (list) #.None (list)) + false) + $i.NULL + ($i.GOTO @end))))) + +(def: #export (translate-if testI thenI elseI) + (-> $.Inst $.Inst $.Inst $.Inst) + (<| $i.with-label (function [@else]) + $i.with-label (function [@end]) + (|>> testI + ($i.unwrap #$.Boolean) + ($i.IFEQ @else) + thenI + ($i.GOTO @end) + ($i.label @else) + elseI + ($i.label @end)))) + +(def: #export (translate-case translate valueS path) + (-> (-> ls.Synthesis (Meta $.Inst)) + ls.Synthesis ls.Path (Meta $.Inst)) + (do macro.Monad + [@end $i.make-label + valueI (translate valueS) + pathI (translate-path translate path @end)] + (wrap (|>> valueI + $i.NULL + $i.SWAP + pushI + pathI + ($i.label @end))))) + +(def: #export (translate-let translate register inputS exprS) + (-> (-> ls.Synthesis (Meta $.Inst)) + Nat ls.Synthesis ls.Synthesis (Meta $.Inst)) + (do macro.Monad + [inputI (translate inputS) + exprI (translate exprS)] + (wrap (|>> inputI + ($i.ASTORE register) + exprI)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux new file mode 100644 index 000000000..a4eb5b93b --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux @@ -0,0 +1,136 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + [io] + (concurrency [atom #+ Atom atom]) + (data ["e" error #+ Error] + [text "text/" Hash] + text/format + (coll [dict #+ Dict])) + [macro] + [host] + (world [blob #+ Blob] + [file #+ File])) + (luxc [lang] + (lang [".L" variable #+ Register] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst]))))) + +(host.import org/objectweb/asm/Opcodes + (#static V1_6 int)) + +(host.import org/objectweb/asm/Label) + +(host.import java/lang/Object) + +(host.import java/lang/reflect/Field + (get [#? Object] #try #? Object)) + +(host.import (java/lang/Class c) + (getField [String] #try Field)) + +(host.import java/lang/ClassLoader + (loadClass [String] (Class Object))) + +(type: #export Bytecode Blob) + +(type: #export Class-Store (Atom (Dict Text Bytecode))) + +(type: #export Artifacts (Dict File Blob)) + +(type: #export Host + {#loader ClassLoader + #store Class-Store + #artifacts Artifacts + #context [Text Nat] + #anchor (Maybe [Label Register])}) + +(exception: #export Unknown-Class) +(exception: #export Class-Already-Stored) +(exception: #export No-Function-Being-Compiled) +(exception: #export Cannot-Overwrite-Artifact) +(exception: #export Cannot-Load-Definition) +(exception: #export Invalid-Definition-Value) + +(def: #export (with-artifacts action) + (All [a] (-> (Meta a) (Meta [Artifacts a]))) + (function [compiler] + (case (action (update@ #.host + (|>> (:! Host) + (set@ #artifacts (dict.new text.Hash)) + (:! Void)) + compiler)) + (#e.Success [compiler' output]) + (#e.Success [(update@ #.host + (|>> (:! Host) + (set@ #artifacts (|> (get@ #.host compiler) (:! Host) (get@ #artifacts))) + (:! Void)) + compiler') + [(|> compiler' (get@ #.host) (:! Host) (get@ #artifacts)) + output]]) + + (#e.Error error) + (#e.Error error)))) + +(def: #export (record-artifact name content) + (-> Text Blob (Meta Unit)) + (function [compiler] + (if (|> compiler (get@ #.host) (:! Host) (get@ #artifacts) (dict.contains? name)) + (ex.throw Cannot-Overwrite-Artifact name) + (#e.Success [(update@ #.host + (|>> (:! Host) + (update@ #artifacts (dict.put name content)) + (:! Void)) + compiler) + []])))) + +(def: #export (store-class name byte-code) + (-> Text Bytecode (Meta Unit)) + (function [compiler] + (let [store (|> (get@ #.host compiler) + (:! Host) + (get@ #store))] + (if (dict.contains? name (|> store atom.read io.run)) + (ex.throw Class-Already-Stored name) + (#e.Success [compiler (io.run (atom.update (dict.put name byte-code) store))]) + )))) + +(def: #export (load-class name) + (-> Text (Meta (Class Object))) + (function [compiler] + (let [host (:! Host (get@ #.host compiler)) + store (|> host (get@ #store) atom.read io.run)] + (if (dict.contains? name store) + (#e.Success [compiler (ClassLoader::loadClass [name] (get@ #loader host))]) + (ex.throw Unknown-Class name))))) + +(def: #export value-field Text "_value") +(def: #export $Object $.Type ($t.class "java.lang.Object" (list))) + +(def: #export (load-definition compiler) + (-> Compiler + (-> Ident Blob (Error Top))) + (function [(^@ def-ident [def-module def-name]) def-bytecode] + (let [normal-name (format (lang.normalize-name def-name) (%n (text/hash def-name))) + class-name (format (text.replace-all "/" "." def-module) "." normal-name)] + (<| (macro.run compiler) + (do macro.Monad + [_ (..store-class class-name def-bytecode) + class (..load-class class-name)] + (case (do e.Monad + [field (Class::getField [..value-field] class)] + (Field::get [#.None] field)) + (#e.Success (#.Some def-value)) + (wrap def-value) + + (#e.Success #.None) + (lang.throw Invalid-Definition-Value (%ident def-ident)) + + (#e.Error error) + (lang.throw Cannot-Load-Definition + (format "Definition: " (%ident def-ident) "\n" + "Error:\n" + error)))))))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/eval.jvm.lux new file mode 100644 index 000000000..c326895a2 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/eval.jvm.lux @@ -0,0 +1,46 @@ +(.module: + lux + (lux (control monad) + (data [text] + text/format) + [macro] + [host #+ do-to]) + (luxc ["&" lang] + (lang (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["la" analysis] + ["ls" synthesis])) + (// [".T" common])) + +(host.import java/lang/reflect/Field + (get [Object] Object)) + +(host.import (java/lang/Class a) + (getField [String] Field)) + +(def: #export (eval valueI) + (-> $.Inst (Meta Top)) + (do macro.Monad + [current-module macro.current-module-name + class-name (:: @ map %code (macro.gensym (format current-module "/eval"))) + #let [store-name (text.replace-all "/" "." class-name) + bytecode ($d.class #$.V1_6 + #$.Public $.noneC + class-name + (list) ["java.lang.Object" (list)] + (list) + (|>> ($d.field #$.Public ($_ $.++F $.finalF $.staticF) + commonT.value-field commonT.$Object) + ($d.method #$.Public ($_ $.++M $.staticM $.strictM) + "" + ($t.method (list) #.None (list)) + (|>> valueI + ($i.PUTSTATIC store-name commonT.value-field commonT.$Object) + $i.RETURN))))] + _ (commonT.store-class store-name bytecode) + class (commonT.load-class store-name)] + (wrap (|> class + (Class::getField [commonT.value-field]) + (Field::get (host.null)))))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux new file mode 100644 index 000000000..82c8c0ec0 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux @@ -0,0 +1,80 @@ +(.module: + lux + (lux (control monad + ["ex" exception #+ exception:] + ["p" parser]) + (data ["e" error] + text/format) + [macro] + (macro ["s" syntax])) + (luxc ["&" lang] + (lang [".L" variable #+ Variable Register] + [".L" extension] + (host ["$" jvm]) + ["ls" synthesis])) + (// [".T" common] + [".T" primitive] + [".T" structure] + [".T" eval] + [".T" function] + [".T" reference] + [".T" case] + [".T" procedure])) + +(exception: #export Unrecognized-Synthesis) + +(def: #export (translate synthesis) + (-> ls.Synthesis (Meta $.Inst)) + (case synthesis + (^code []) + primitiveT.translate-unit + + (^code [(~ singleton)]) + (translate singleton) + + (^template [ ] + [_ ( value)] + ( value)) + ([#.Bool primitiveT.translate-bool] + [#.Nat primitiveT.translate-nat] + [#.Int primitiveT.translate-int] + [#.Deg primitiveT.translate-deg] + [#.Frac primitiveT.translate-frac] + [#.Text primitiveT.translate-text]) + + (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bool last?)]) (~ valueS))) + (structureT.translate-variant translate tag last? valueS) + + (^code [(~+ members)]) + (structureT.translate-tuple translate members) + + (^ [_ (#.Form (list [_ (#.Int var)]))]) + (if (variableL.captured? var) + (referenceT.translate-captured var) + (referenceT.translate-local var)) + + [_ (#.Symbol definition)] + (referenceT.translate-definition definition) + + (^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ exprS))) + (caseT.translate-let translate register inputS exprS) + + (^code ("lux case" (~ inputS) (~ pathPS))) + (caseT.translate-case translate inputS pathPS) + + (^multi (^code ("lux function" (~ [_ (#.Nat arity)]) [(~+ environment)] (~ bodyS))) + [(s.run environment (p.some s.int)) (#e.Success environment)]) + (functionT.translate-function translate environment arity bodyS) + + (^code ("lux call" (~ functionS) (~+ argsS))) + (functionT.translate-call translate functionS argsS) + + (^code ((~ [_ (#.Text procedure)]) (~+ argsS))) + (procedureT.translate-procedure translate procedure argsS) + ## (do macro.Monad + ## [translation (extensionL.find-translation procedure)] + ## (translation argsS)) + + _ + (&.throw Unrecognized-Synthesis (%code synthesis)) + )) diff --git a/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux new file mode 100644 index 000000000..6fb446bc4 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux @@ -0,0 +1,325 @@ +(.module: + lux + (lux (control [monad #+ do]) + (data [text] + text/format + (coll [list "list/" Functor Monoid])) + [macro]) + (luxc ["&" lang] + (lang [".L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["la" analysis] + ["ls" synthesis] + [".L" variable #+ Variable])) + (// [".T" common] + [".T" runtime] + [".T" reference])) + + +(def: arity-field Text "arity") +(def: $Object $.Type ($t.class "java.lang.Object" (list))) + +(def: (poly-arg? arity) + (-> ls.Arity Bool) + (n/> +1 arity)) + +(def: (reset-method class) + (-> Text $.Method) + ($t.method (list) (#.Some ($t.class class (list))) (list))) + +(def: (captured-args env) + (-> (List Variable) (List $.Type)) + (list.repeat (list.size env) $Object)) + +(def: (init-method env arity) + (-> (List Variable) ls.Arity $.Method) + (if (poly-arg? arity) + ($t.method (list.concat (list (captured-args env) + (list $t.int) + (list.repeat (n/dec arity) $Object))) + #.None + (list)) + ($t.method (captured-args env) #.None (list)))) + +(def: (implementation-method arity) + ($t.method (list.repeat arity $Object) (#.Some $Object) (list))) + +(def: get-amount-of-partialsI + $.Inst + (|>> ($i.ALOAD +0) + ($i.GETFIELD hostL.function-class runtimeT.partials-field $t.int))) + +(def: (load-fieldI class field) + (-> Text Text $.Inst) + (|>> ($i.ALOAD +0) + ($i.GETFIELD class field $Object))) + +(def: (inputsI start amount) + (-> $.Register Nat $.Inst) + (|> (list.n/range start (n/+ start (n/dec amount))) + (list/map $i.ALOAD) + $i.fuse)) + +(def: (applysI start amount) + (-> $.Register Nat $.Inst) + (let [max-args (n/min amount runtimeT.num-apply-variants) + later-applysI (if (n/> runtimeT.num-apply-variants amount) + (applysI (n/+ runtimeT.num-apply-variants start) (n/- runtimeT.num-apply-variants amount)) + id)] + (|>> ($i.CHECKCAST hostL.function-class) + (inputsI start max-args) + ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.apply-signature max-args) false) + later-applysI))) + +(def: (inc-intI by) + (-> Nat $.Inst) + (|>> ($i.int (nat-to-int by)) + $i.IADD)) + +(def: (nullsI amount) + (-> Nat $.Inst) + (|> $i.NULL + (list.repeat amount) + $i.fuse)) + +(def: (with-captured env) + (-> (List Variable) $.Def) + (|> (list.enumerate env) + (list/map (function [[env-idx env-source]] + ($d.field #$.Private $.finalF (referenceT.captured env-idx) $Object))) + $d.fuse)) + +(def: (with-partial arity) + (-> ls.Arity $.Def) + (if (poly-arg? arity) + (|> (list.n/range +0 (n/- +2 arity)) + (list/map (function [idx] + ($d.field #$.Private $.finalF (referenceT.partial idx) $Object))) + $d.fuse) + id)) + +(def: (instance class arity env) + (-> Text ls.Arity (List Variable) (Meta $.Inst)) + (do macro.Monad + [captureI+ (monad.map @ referenceT.translate-variable env) + #let [argsI (if (poly-arg? arity) + (|> (nullsI (n/dec arity)) + (list ($i.int 0)) + $i.fuse) + id)]] + (wrap (|>> ($i.NEW class) + $i.DUP + ($i.fuse captureI+) + argsI + ($i.INVOKESPECIAL class "" (init-method env arity) false))))) + +(def: (with-reset class arity env) + (-> Text ls.Arity (List Variable) $.Def) + ($d.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 (n/dec env-size))) + (list/map (function [source] + (|>> ($i.ALOAD +0) + ($i.GETFIELD class (referenceT.captured source) $Object)))) + $i.fuse) + argsI (|> (nullsI (n/dec arity)) + (list ($i.int 0)) + $i.fuse)] + (|>> ($i.NEW class) + $i.DUP + captureI + argsI + ($i.INVOKESPECIAL class "" (init-method env arity) false) + $i.ARETURN)) + (|>> ($i.ALOAD +0) + $i.ARETURN)))) + +(def: (with-implementation arity @begin bodyI) + (-> Nat $.Label $.Inst $.Def) + ($d.method #$.Public $.strictM "impl" (implementation-method arity) + (|>> ($i.label @begin) + bodyI + $i.ARETURN))) + +(def: function-init-method + $.Method + ($t.method (list $t.int) #.None (list))) + +(def: (function-init arity env-size) + (-> ls.Arity Nat $.Inst) + (if (n/= +1 arity) + (|>> ($i.int 0) + ($i.INVOKESPECIAL hostL.function-class "" function-init-method false)) + (|>> ($i.ILOAD (n/inc env-size)) + ($i.INVOKESPECIAL hostL.function-class "" function-init-method false)))) + +(def: (with-init class env arity) + (-> Text (List Variable) ls.Arity $.Def) + (let [env-size (list.size env) + offset-partial (: (-> Nat Nat) + (|>> n/inc (n/+ env-size))) + store-capturedI (|> (case env-size + +0 (list) + _ (list.n/range +0 (n/dec env-size))) + (list/map (function [register] + (|>> ($i.ALOAD +0) + ($i.ALOAD (n/inc register)) + ($i.PUTFIELD class (referenceT.captured register) $Object)))) + $i.fuse) + store-partialI (if (poly-arg? arity) + (|> (list.n/range +0 (n/- +2 arity)) + (list/map (function [idx] + (let [register (offset-partial idx)] + (|>> ($i.ALOAD +0) + ($i.ALOAD (n/inc register)) + ($i.PUTFIELD class (referenceT.partial idx) $Object))))) + $i.fuse) + id)] + ($d.method #$.Public $.noneM "" (init-method env arity) + (|>> ($i.ALOAD +0) + (function-init arity env-size) + store-capturedI + store-partialI + $i.RETURN)))) + +(def: (with-apply class env function-arity @begin bodyI apply-arity) + (-> Text (List Variable) ls.Arity $.Label $.Inst ls.Arity + $.Def) + (let [num-partials (n/dec function-arity) + @default ($.new-label []) + @labels (list/map $.new-label (list.repeat num-partials [])) + arity-over-extent (|> (nat-to-int function-arity) (i/- (nat-to-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 (n/dec stage)) + (list/map (|>> referenceT.partial (load-fieldI class))) + $i.fuse) + id)] + (cond (i/= arity-over-extent (nat-to-int stage)) + (|>> ($i.label @label) + ($i.ALOAD +0) + (when (n/> +0 stage) + ($i.INVOKEVIRTUAL class "reset" (reset-method class) false)) + load-partialsI + (inputsI +1 apply-arity) + ($i.INVOKEVIRTUAL class "impl" (implementation-method function-arity) false) + $i.ARETURN) + + (i/> arity-over-extent (nat-to-int stage)) + (let [args-to-completion (|> function-arity (n/- stage)) + args-left (|> apply-arity (n/- args-to-completion))] + (|>> ($i.label @label) + ($i.ALOAD +0) + ($i.INVOKEVIRTUAL class "reset" (reset-method class) false) + load-partialsI + (inputsI +1 args-to-completion) + ($i.INVOKEVIRTUAL class "impl" (implementation-method function-arity) false) + (applysI (n/inc args-to-completion) args-left) + $i.ARETURN)) + + ## (i/< arity-over-extent (nat-to-int stage)) + (let [env-size (list.size env) + load-capturedI (|> (case env-size + +0 (list) + _ (list.n/range +0 (n/dec env-size))) + (list/map (|>> referenceT.captured (load-fieldI class))) + $i.fuse)] + (|>> ($i.label @label) + ($i.NEW class) + $i.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))) + ($i.INVOKESPECIAL class "" (init-method env function-arity) false) + $i.ARETURN)) + )))) + $i.fuse)] + ($d.method #$.Public $.noneM runtimeT.apply-method (runtimeT.apply-signature apply-arity) + (|>> get-amount-of-partialsI + ($i.TABLESWITCH 0 (|> num-partials n/dec nat-to-int) + @default @labels) + casesI + ($i.INVOKESTATIC hostL.runtime-class "apply_fail" ($t.method (list) #.None (list)) false) + $i.NULL + $i.ARETURN + )))) + +(def: #export (with-function @begin class env arity bodyI) + (-> $.Label Text (List Variable) ls.Arity $.Inst + (Meta [$.Def $.Inst])) + (let [env-size (list.size env) + applyD (: $.Def + (if (poly-arg? arity) + (|> (n/min arity runtimeT.num-apply-variants) + (list.n/range +1) + (list/map (with-apply class env arity @begin bodyI)) + (list& (with-implementation arity @begin bodyI)) + $d.fuse) + ($d.method #$.Public $.strictM runtimeT.apply-method (runtimeT.apply-signature +1) + (|>> ($i.label @begin) + bodyI + $i.ARETURN)))) + functionD (: $.Def + (|>> ($d.int-field #$.Public ($_ $.++F $.staticF $.finalF) arity-field (nat-to-int arity)) + (with-captured env) + (with-partial arity) + (with-init class env arity) + (with-reset class arity env) + applyD + ))] + (do macro.Monad + [instanceI (instance class arity env)] + (wrap [functionD instanceI])))) + +(def: #export (translate-function translate env arity bodyS) + (-> (-> ls.Synthesis (Meta $.Inst)) + (List Variable) ls.Arity ls.Synthesis + (Meta $.Inst)) + (do macro.Monad + [@begin $i.make-label + [function-class bodyI] (hostL.with-sub-context + (hostL.with-anchor [@begin +1] + (translate bodyS))) + this-module macro.current-module-name + #let [function-class (format (text.replace-all "/" "." this-module) "." function-class)] + [functionD instanceI] (with-function @begin function-class env arity bodyI) + _ (commonT.store-class function-class + ($d.class #$.V1_6 #$.Public $.finalC + function-class (list) + ($.simple-class hostL.function-class) (list) + functionD))] + (wrap instanceI))) + +(def: (segment size elems) + (All [a] (-> Nat (List a) (List (List a)))) + (let [[pre post] (list.split size elems)] + (if (list.empty? post) + (list pre) + (list& pre (segment size post))))) + +(def: #export (translate-call translate functionS argsS) + (-> (-> ls.Synthesis (Meta $.Inst)) + ls.Synthesis (List ls.Synthesis) + (Meta $.Inst)) + (do macro.Monad + [functionI (translate functionS) + argsI (monad.map @ translate argsS) + #let [applyI (|> (segment runtimeT.num-apply-variants argsI) + (list/map (function [chunkI+] + (|>> ($i.CHECKCAST hostL.function-class) + ($i.fuse chunkI+) + ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.apply-signature (list.size chunkI+)) false)))) + $i.fuse)]] + (wrap (|>> functionI + applyI)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/imports.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/imports.jvm.lux new file mode 100644 index 000000000..892dd869f --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/imports.jvm.lux @@ -0,0 +1,149 @@ +(.module: + lux + (lux (control [monad #+ do] + ["p" parser] + ["ex" exception #+ exception:] + pipe) + (concurrency [promise #+ Promise] + [stm #+ Var STM]) + (data ["e" error #+ Error] + [maybe] + [product] + [text "text/" Eq] + text/format + (coll [list "list/" Functor Fold] + [dict #+ Dict])) + [macro] + (macro [code] + ["s" syntax]) + [io #+ IO Process io] + [host]) + (luxc ["&" lang] + (lang [".L" module]))) + +(exception: #export Invalid-Imports) +(exception: #export Module-Cannot-Import-Itself) +(exception: #export Circular-Dependency) + +(host.import (java/util/concurrent/Future a) + (get [] #io a)) + +(host.import (java/util/concurrent/CompletableFuture a) + (new []) + (complete [a] boolean) + (#static [a] completedFuture [a] (CompletableFuture a))) + +(type: Import + {#module Text + #alias Text}) + +(def: import (s.Syntax Import) (s.tuple (p.seq s.text s.text))) + +(def: compilations + (Var (Dict Text (CompletableFuture (Error Compiler)))) + (stm.var (dict.new text.Hash))) + +(def: (promise-to-future promise) + (All [a] (-> (Promise a) (Future a))) + (let [future (CompletableFuture::new [])] + (exec (:: promise.Functor map + (function [value] (CompletableFuture::complete [value] future)) + promise) + future))) + +(def: from-io + (All [a] (-> (IO a) (Process a))) + (:: io.Monad map (|>> #e.Success))) + +(def: (translate-dependency translate-module dependency compiler) + (-> (-> Text Compiler (Process Compiler)) + (-> Text Compiler (IO (Future (Error Compiler))))) + (<| (Future::get []) + promise-to-future + (do promise.Monad + [[new? future] (stm.commit (: (STM [Bool (CompletableFuture (Error Compiler))]) + (do stm.Monad + [current-compilations (stm.read compilations)] + (case (dict.get dependency current-compilations) + (#.Some ongoing) + (wrap [false ongoing]) + + #.None + (do @ + [#let [pending (: (CompletableFuture (Error Compiler)) + (CompletableFuture::new []))] + _ (stm.write (dict.put dependency pending current-compilations) + compilations)] + (wrap [true pending]))))))] + (if new? + (exec (promise.future (io (CompletableFuture::complete [(io.run (translate-module dependency compiler))] + future))) + (wrap future)) + (wrap future))))) + +(def: compiled? + (-> Module Bool) + (|>> (get@ #.module-state) + (case> + (^or #.Cached #.Compiled) + true + + _ + false))) + +(def: (merge-modules current-module from-dependency from-current) + (-> Text (List [Text Module]) (List [Text Module]) (List [Text Module])) + (|> from-dependency + (list.filter (|>> product.right compiled?)) + (list/fold (function [[dep-name dep-module] total] (&.pl-put dep-name dep-module total)) + from-current))) + +(def: (merge-compilers current-module dependency total) + (-> Text Compiler Compiler Compiler) + (|> total + (update@ #.modules (merge-modules current-module (get@ #.modules dependency))) + (set@ #.seed (get@ #.seed dependency)))) + +(def: #export (translate-imports translate-module annotations) + (-> (-> Text Compiler (Process Compiler)) + Code + (Meta (Process Compiler))) + (do macro.Monad + [_ (moduleL.set-annotations annotations) + current-module macro.current-module-name + imports (let [imports (|> (macro.get-tuple-ann (ident-for #.imports) annotations) + (maybe.default (list)))] + (case (s.run imports (p.some import)) + (#e.Success imports) + (wrap imports) + + (#e.Error error) + (&.throw Invalid-Imports (%code (code.tuple imports))))) + dependencies (monad.map @ (: (-> [Text Text] (Meta (IO (Future (Error Compiler))))) + (function [[dependency alias]] + (do @ + [_ (&.assert Module-Cannot-Import-Itself current-module + (not (text/= current-module dependency))) + already-seen? (moduleL.exists? dependency) + circular-dependency? (if already-seen? + (moduleL.active? dependency) + (wrap false)) + _ (&.assert Circular-Dependency (format "From: " current-module "\n" + " To: " dependency) + (not circular-dependency?)) + _ (moduleL.import dependency) + _ (if (text/= "" alias) + (wrap []) + (moduleL.alias alias dependency)) + compiler macro.get-compiler] + (if already-seen? + (wrap (io (CompletableFuture::completedFuture [(#e.Success compiler)]))) + (wrap (translate-dependency translate-module dependency compiler)))))) + imports) + compiler macro.get-compiler] + (wrap (do io.Monad + [dependencies (monad.seq io.Monad (list/map from-io dependencies)) + dependencies (|> dependencies + (list/map (Future::get [])) + (monad.seq io.Monad))] + (wrap (list/fold (merge-compilers current-module) compiler dependencies)))))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux new file mode 100644 index 000000000..2e585fb11 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux @@ -0,0 +1,80 @@ +(.module: + lux + (lux (control [monad #+ do]) + (data [text] + text/format + (coll [list "list/" Functor Monoid])) + [macro]) + (luxc ["&" lang] + (lang [".L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["la" analysis] + ["ls" synthesis] + [".L" variable #+ Variable Register])) + (// [".T" common] + [".T" runtime] + [".T" reference])) + +(def: (constant? register changeS) + (-> Register ls.Synthesis Bool) + (case changeS + (^multi (^code ((~ [_ (#.Int var)]))) + (i/= (variableL.local register) + var)) + true + + _ + false)) + +(def: #export (translate-recur translate argsS) + (-> (-> ls.Synthesis (Meta $.Inst)) + (List ls.Synthesis) + (Meta $.Inst)) + (do macro.Monad + [[@begin offset] hostL.anchor + #let [pairs (list.zip2 (list.n/range offset (|> (list.size argsS) n/dec (n/+ offset))) + 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 + ## must be the case. + valuesI+ (monad.map @ (function [[register argS]] + (: (Meta $.Inst) + (if (constant? register argS) + (wrap id) + (translate argS)))) + pairs) + #let [storesI+ (list/map (function [[register argS]] + (: $.Inst + (if (constant? register argS) + id + ($i.ASTORE register)))) + (list.reverse pairs))]] + (wrap (|>> ($i.fuse valuesI+) + ($i.fuse storesI+) + ($i.GOTO @begin))))) + +(def: #export (translate-loop translate offset initsS+ bodyS) + (-> (-> ls.Synthesis (Meta $.Inst)) + Nat (List ls.Synthesis) ls.Synthesis + (Meta $.Inst)) + (do macro.Monad + [@begin $i.make-label + initsI+ (monad.map @ translate initsS+) + bodyI (hostL.with-anchor [@begin offset] + (translate bodyS)) + #let [initializationI (|> (list.enumerate initsI+) + (list/map (function [[register initI]] + (|>> initI + ($i.ASTORE (n/+ offset register))))) + $i.fuse)]] + (wrap (|>> initializationI + ($i.label @begin) + bodyI)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux new file mode 100644 index 000000000..f92c7025a --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux @@ -0,0 +1,35 @@ +(.module: + lux + (lux (control monad) + (data text/format) + [macro "macro/" Monad]) + (luxc ["&" lang] + (lang [".L" host] + (host ["$" jvm] + (jvm ["$i" inst] + ["$t" type])) + ["la" analysis] + ["ls" synthesis])) + (// [".T" common])) + +(def: #export translate-unit + (Meta $.Inst) + (macro/wrap ($i.string hostL.unit))) + +(def: #export (translate-bool value) + (-> Bool (Meta $.Inst)) + (macro/wrap ($i.GETSTATIC "java.lang.Boolean" + (if value "TRUE" "FALSE") + ($t.class "java.lang.Boolean" (list))))) + +(do-template [ ] + [(def: #export ( value) + (-> (Meta $.Inst)) + (macro/wrap (|>> ( value) )))] + + [translate-nat Nat (|>> (:! Int) $i.long) ($i.wrap #$.Long)] + [translate-int Int $i.long ($i.wrap #$.Long)] + [translate-deg Deg (|>> (:! Int) $i.long) ($i.wrap #$.Long)] + [translate-frac Frac $i.double ($i.wrap #$.Double)] + [translate-text Text $i.string id] + ) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure.jvm.lux new file mode 100644 index 000000000..e4f8b9908 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure.jvm.lux @@ -0,0 +1,27 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [maybe] + text/format + (coll [dict]))) + (luxc ["&" lang] + (lang (host ["$" jvm]) + ["ls" synthesis])) + (/ ["/." common] + ["/." host])) + +(exception: #export Unknown-Procedure) + +(def: procedures + /common.Bundle + (|> /common.procedures + (dict.merge /host.procedures))) + +(def: #export (translate-procedure translate name args) + (-> (-> ls.Synthesis (Meta $.Inst)) Text (List ls.Synthesis) + (Meta $.Inst)) + (<| (maybe.default (&.throw Unknown-Procedure (%t name))) + (do maybe.Monad + [proc (dict.get name procedures)] + (wrap (proc translate args))))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux new file mode 100644 index 000000000..c7513fd6e --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux @@ -0,0 +1,809 @@ +(.module: + lux + (lux (control [monad #+ do] + ["p" parser] + ["ex" exception #+ exception:]) + (data ["e" error] + [text] + text/format + (coll [list "list/" Functor] + [dict #+ Dict])) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax:]) + [host]) + (luxc ["&" lang] + (lang [".L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["la" analysis] + ["ls" synthesis])) + (/// [".T" runtime] + [".T" case] + [".T" function] + [".T" loop])) + +(host.import java/lang/Long + (#static MIN_VALUE Long) + (#static MAX_VALUE Long)) + +(host.import java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double) + (#static NaN Double) + (#static POSITIVE_INFINITY Double) + (#static NEGATIVE_INFINITY Double)) + +## [Types] +(type: #export Translator + (-> ls.Synthesis (Meta $.Inst))) + +(type: #export Proc + (-> Translator (List ls.Synthesis) (Meta $.Inst))) + +(type: #export Bundle + (Dict Text Proc)) + +(syntax: (Vector [size s.nat] elemT) + (wrap (list (` [(~+ (list.repeat size elemT))])))) + +(type: #export Nullary (-> (Vector +0 $.Inst) $.Inst)) +(type: #export Unary (-> (Vector +1 $.Inst) $.Inst)) +(type: #export Binary (-> (Vector +2 $.Inst) $.Inst)) +(type: #export Trinary (-> (Vector +3 $.Inst) $.Inst)) +(type: #export Variadic (-> (List $.Inst) $.Inst)) + +## [Utils] +(def: $Object $.Type ($t.class "java.lang.Object" (list))) +(def: $Object-Array $.Type ($t.array +1 $Object)) +(def: $Variant $.Type ($t.array +1 $Object)) +(def: $String $.Type ($t.class "java.lang.String" (list))) +(def: $CharSequence $.Type ($t.class "java.lang.CharSequence" (list))) +(def: $Function $.Type ($t.class hostL.function-class (list))) + +(def: #export (install name unnamed) + (-> Text (-> Text Proc) + (-> Bundle Bundle)) + (dict.put name (unnamed name))) + +(def: #export (prefix prefix bundle) + (-> Text Bundle Bundle) + (|> bundle + dict.entries + (list/map (function [[key val]] [(format prefix " " key) val])) + (dict.from-list text.Hash))) + +(def: (wrong-arity proc expected actual) + (-> Text Nat Nat Text) + (format "Wrong number of arguments for " (%t proc) "\n" + "Expected: " (|> expected nat-to-int %i) "\n" + " Actual: " (|> actual nat-to-int %i))) + +(syntax: (arity: [name s.local-symbol] [arity s.nat]) + (with-gensyms [g!proc g!name g!translate g!inputs] + (do @ + [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] + (wrap (list (` (def: #export ((~ (code.local-symbol name)) (~ g!proc)) + (-> (-> (..Vector (~ (code.nat arity)) $.Inst) $.Inst) + (-> Text ..Proc)) + (function [(~ g!name)] + (function [(~ g!translate) (~ g!inputs)] + (case (~ g!inputs) + (^ (list (~+ g!input+))) + (do macro.Monad + [(~+ (|> g!input+ + (list/map (function [g!input] + (list g!input (` ((~ g!translate) (~ g!input)))))) + list.concat))] + ((~' wrap) ((~ g!proc) [(~+ g!input+)]))) + + (~' _) + (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs)))))))))))))) + +(arity: nullary +0) +(arity: unary +1) +(arity: binary +2) +(arity: trinary +3) + +(def: #export (variadic proc) + (-> Variadic (-> Text Proc)) + (function [proc-name] + (function [translate inputsS] + (do macro.Monad + [inputsI (monad.map @ translate inputsS)] + (wrap (proc inputsI)))))) + +## [Instructions] +(def: lux-intI $.Inst (|>> $i.I2L ($i.wrap #$.Long))) +(def: jvm-intI $.Inst (|>> ($i.unwrap #$.Long) $i.L2I)) + +(def: (array-writeI arrayI idxI elemI) + (-> $.Inst $.Inst $.Inst + $.Inst) + (|>> arrayI ($i.CHECKCAST ($t.descriptor $Object-Array)) + $i.DUP + idxI jvm-intI + elemI + $i.AASTORE)) + +(def: (predicateI tester) + (-> (-> $.Label $.Inst) + $.Inst) + (<| $i.with-label (function [@then]) + $i.with-label (function [@end]) + (|>> (tester @then) + ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list))) + ($i.GOTO @end) + ($i.label @then) + ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list))) + ($i.label @end) + ))) + +(def: unitI $.Inst ($i.string hostL.unit)) + +## [Procedures] +## [[Lux]] +(def: (lux//is [leftI rightI]) + Binary + (|>> leftI + rightI + (predicateI $i.IF_ACMPEQ))) + +(def: (lux//if [testI thenI elseI]) + Trinary + (caseT.translate-if testI thenI elseI)) + +(def: (lux//try riskyI) + Unary + (|>> riskyI + ($i.CHECKCAST hostL.function-class) + ($i.INVOKESTATIC hostL.runtime-class "try" + ($t.method (list $Function) (#.Some $Object-Array) (list)) + false))) + +(def: (lux//noop valueI) + Unary + valueI) + +(exception: #export Wrong-Syntax) +(def: #export (wrong-syntax procedure args) + (-> Text (List ls.Synthesis) Text) + (format "Procedure: " procedure "\n" + "Arguments: " (%code (code.tuple args)))) + +(def: lux//loop + (-> Text Proc) + (function [proc-name] + (function [translate inputsS] + (case (s.run inputsS ($_ p.seq s.nat (s.tuple (p.many s.any)) s.any)) + (#e.Success [offset initsS+ bodyS]) + (loopT.translate-loop translate offset initsS+ bodyS) + + (#e.Error error) + (&.throw Wrong-Syntax (wrong-syntax proc-name inputsS))) + ))) + +(def: lux//recur + (-> Text Proc) + (function [proc-name] + (function [translate inputsS] + (loopT.translate-recur translate inputsS)))) + +## [[Bits]] +(do-template [ ] + [(def: ( [inputI maskI]) + Binary + (|>> inputI ($i.unwrap #$.Long) + maskI ($i.unwrap #$.Long) + ($i.wrap #$.Long)))] + + [bit//and $i.LAND] + [bit//or $i.LOR] + [bit//xor $i.LXOR] + ) + +(def: (bit//count inputI) + Unary + (|>> inputI ($i.unwrap #$.Long) + ($i.INVOKESTATIC "java.lang.Long" "bitCount" ($t.method (list $t.long) (#.Some $t.int) (list)) false) + lux-intI)) + +(do-template [ ] + [(def: ( [inputI shiftI]) + Binary + (|>> inputI ($i.unwrap #$.Long) + shiftI jvm-intI + + ($i.wrap #$.Long)))] + + [bit//shift-left $i.LSHL] + [bit//shift-right $i.LSHR] + [bit//unsigned-shift-right $i.LUSHR] + ) + +## [[Arrays]] +(def: (array//new lengthI) + Unary + (|>> lengthI jvm-intI ($i.ANEWARRAY ($t.binary-name "java.lang.Object")))) + +(def: (array//get [arrayI idxI]) + Binary + (<| $i.with-label (function [@is-null]) + $i.with-label (function [@end]) + (|>> arrayI ($i.CHECKCAST ($t.descriptor $Object-Array)) + idxI jvm-intI + $i.AALOAD + $i.DUP + ($i.IFNULL @is-null) + runtimeT.someI + ($i.GOTO @end) + ($i.label @is-null) + $i.POP + runtimeT.noneI + ($i.label @end)))) + +(def: (array//put [arrayI idxI elemI]) + Trinary + (array-writeI arrayI idxI elemI)) + +(def: (array//remove [arrayI idxI]) + Binary + (array-writeI arrayI idxI $i.NULL)) + +(def: (array//size arrayI) + Unary + (|>> arrayI ($i.CHECKCAST ($t.descriptor $Object-Array)) + $i.ARRAYLENGTH + lux-intI)) + +## [[Numbers]] +(def: nat-method + $.Method + ($t.method (list $t.long $t.long) (#.Some $t.long) (list))) + +(def: deg-method $.Method nat-method) + +(def: compare-nat-method + $.Method + ($t.method (list $t.long $t.long) (#.Some $t.int) (list))) + +(do-template [ ] + [(def: ( _) + Nullary + (|>> ($i.wrap )))] + + [nat//min ($i.long 0) #$.Long] + [nat//max ($i.long -1) #$.Long] + + [int//min ($i.long Long::MIN_VALUE) #$.Long] + [int//max ($i.long Long::MAX_VALUE) #$.Long] + + [frac//smallest ($i.double Double::MIN_VALUE) #$.Double] + [frac//min ($i.double (f/* -1.0 Double::MAX_VALUE)) #$.Double] + [frac//max ($i.double Double::MAX_VALUE) #$.Double] + [frac//not-a-number ($i.double Double::NaN) #$.Double] + [frac//positive-infinity ($i.double Double::POSITIVE_INFINITY) #$.Double] + [frac//negative-infinity ($i.double Double::NEGATIVE_INFINITY) #$.Double] + + [deg//min ($i.long 0) #$.Long] + [deg//max ($i.long -1) #$.Long] + ) + +(do-template [ ] + [(def: ( [subjectI paramI]) + Binary + (|>> subjectI ($i.unwrap ) + paramI ($i.unwrap ) + + ($i.wrap )))] + + [int//add #$.Long $i.LADD] + [int//sub #$.Long $i.LSUB] + [int//mul #$.Long $i.LMUL] + [int//div #$.Long $i.LDIV] + [int//rem #$.Long $i.LREM] + + [nat//add #$.Long $i.LADD] + [nat//sub #$.Long $i.LSUB] + [nat//mul #$.Long $i.LMUL] + [nat//div #$.Long ($i.INVOKESTATIC hostL.runtime-class "div_nat" nat-method false)] + [nat//rem #$.Long ($i.INVOKESTATIC hostL.runtime-class "rem_nat" nat-method false)] + + [frac//add #$.Double $i.DADD] + [frac//sub #$.Double $i.DSUB] + [frac//mul #$.Double $i.DMUL] + [frac//div #$.Double $i.DDIV] + [frac//rem #$.Double $i.DREM] + + [deg//add #$.Long $i.LADD] + [deg//sub #$.Long $i.LSUB] + [deg//mul #$.Long ($i.INVOKESTATIC hostL.runtime-class "mul_deg" deg-method false)] + [deg//div #$.Long ($i.INVOKESTATIC hostL.runtime-class "div_deg" deg-method false)] + [deg//rem #$.Long $i.LSUB] + [deg//scale #$.Long $i.LMUL] + [deg//reciprocal #$.Long $i.LDIV] + ) + +(do-template [ ] + [(do-template [ ] + [(def: ( [subjectI paramI]) + Binary + (|>> subjectI + paramI + + ($i.int ) + (predicateI $i.IF_ICMPEQ)))] + [ 0] + [ -1])] + + [nat//eq nat//lt ($i.unwrap #$.Long) ($i.INVOKESTATIC hostL.runtime-class "compare_nat" compare-nat-method false)] + [int//eq int//lt ($i.unwrap #$.Long) $i.LCMP] + [frac//eq frac//lt ($i.unwrap #$.Double) $i.DCMPG] + [deg//eq deg//lt ($i.unwrap #$.Long) ($i.INVOKESTATIC hostL.runtime-class "compare_nat" compare-nat-method false)] + ) + +(do-template [ ] + [(def: ( inputI) + Unary + (|>> inputI ))] + + [nat//to-int id id] + [nat//char ($i.unwrap #$.Long) + ((|>> $i.L2I $i.I2C ($i.INVOKESTATIC "java.lang.Character" "toString" ($t.method (list $t.char) (#.Some $String) (list)) false)))] + + [int//to-nat id id] + [int//to-frac ($i.unwrap #$.Long) (<| ($i.wrap #$.Double) $i.L2D)] + + [frac//to-int ($i.unwrap #$.Double) (<| ($i.wrap #$.Long) $i.D2L)] + [frac//to-deg ($i.unwrap #$.Double) + (<| ($i.wrap #$.Long) ($i.INVOKESTATIC hostL.runtime-class "frac_to_deg" + ($t.method (list $t.double) (#.Some $t.long) (list)) false))] + [frac//encode ($i.unwrap #$.Double) + ($i.INVOKESTATIC "java.lang.Double" "toString" ($t.method (list $t.double) (#.Some $String) (list)) false)] + [frac//decode ($i.CHECKCAST "java.lang.String") + ($i.INVOKESTATIC hostL.runtime-class "decode_frac" ($t.method (list $String) (#.Some $Object-Array) (list)) false)] + + [deg//to-frac ($i.unwrap #$.Long) + (<| ($i.wrap #$.Double) ($i.INVOKESTATIC hostL.runtime-class "deg_to_frac" + ($t.method (list $t.long) (#.Some $t.double) (list)) false))] + ) + +## [[Text]] +(do-template [ ] + [(def: ( inputI) + Unary + (|>> inputI + ($i.CHECKCAST "java.lang.String") + ($i.INVOKEVIRTUAL ($t.method (list) (#.Some ) (list)) false) + ))] + + [text//size "java.lang.String" "length" lux-intI $t.int] + [text//hash "java.lang.Object" "hashCode" lux-intI $t.int] + [text//trim "java.lang.String" "trim" id $String] + [text//upper "java.lang.String" "toUpperCase" id $String] + [text//lower "java.lang.String" "toLowerCase" id $String] + ) + +(do-template [ ] + [(def: ( [subjectI paramI]) + Binary + (|>> subjectI + paramI + ))] + + [text//eq id id + ($i.INVOKEVIRTUAL "java.lang.Object" "equals" ($t.method (list $Object) (#.Some $t.boolean) (list)) false) + ($i.wrap #$.Boolean)] + [text//lt ($i.CHECKCAST "java.lang.String") ($i.CHECKCAST "java.lang.String") + ($i.INVOKEVIRTUAL "java.lang.String" "compareTo" ($t.method (list $String) (#.Some $t.int) (list)) false) + (<| (predicateI $i.IF_ICMPEQ) ($i.int -1))] + [text//concat ($i.CHECKCAST "java.lang.String") ($i.CHECKCAST "java.lang.String") + ($i.INVOKEVIRTUAL "java.lang.String" "concat" ($t.method (list $String) (#.Some $String) (list)) false) + id] + [text//contains? ($i.CHECKCAST "java.lang.String") ($i.CHECKCAST "java.lang.String") + ($i.INVOKEVIRTUAL "java.lang.String" "contains" ($t.method (list $CharSequence) (#.Some $t.boolean) (list)) false) + ($i.wrap #$.Boolean)] + [text//char ($i.CHECKCAST "java.lang.String") jvm-intI + ($i.INVOKESTATIC hostL.runtime-class "text_char" ($t.method (list $String $t.int) (#.Some $Variant) (list)) false) + id] + ) + +(do-template [ ] + [(def: ( [subjectI paramI extraI]) + Trinary + (|>> subjectI + paramI + extraI + ))] + + [text//clip ($i.CHECKCAST "java.lang.String") jvm-intI jvm-intI + ($i.INVOKESTATIC hostL.runtime-class "text_clip" + ($t.method (list $String $t.int $t.int) (#.Some $Variant) (list)) false)] + [text//replace-once ($i.CHECKCAST "java.lang.String") + (<| ($i.INVOKESTATIC "java.util.regex.Pattern" "quote" ($t.method (list $String) (#.Some $String) (list)) false) + ($i.CHECKCAST "java.lang.String")) + ($i.CHECKCAST "java.lang.String") + ($i.INVOKEVIRTUAL "java.lang.String" "replaceFirst" ($t.method (list $String $String) (#.Some $String) (list)) false)] + [text//replace-all ($i.CHECKCAST "java.lang.String") + (<| ($i.INVOKESTATIC "java.util.regex.Pattern" "quote" ($t.method (list $String) (#.Some $String) (list)) false) + ($i.CHECKCAST "java.lang.String")) + ($i.CHECKCAST "java.lang.String") + ($i.INVOKEVIRTUAL "java.lang.String" "replaceAll" ($t.method (list $String $String) (#.Some $String) (list)) false)] + ) + +(def: index-method $.Method ($t.method (list $String $t.int) (#.Some $t.int) (list))) +(do-template [ ] + [(def: ( [textI partI startI]) + Trinary + (<| $i.with-label (function [@not-found]) + $i.with-label (function [@end]) + (|>> textI ($i.CHECKCAST "java.lang.String") + partI ($i.CHECKCAST "java.lang.String") + startI jvm-intI + ($i.INVOKEVIRTUAL "java.lang.String" index-method false) + $i.DUP + ($i.int -1) + ($i.IF_ICMPEQ @not-found) + lux-intI + runtimeT.someI + ($i.GOTO @end) + ($i.label @not-found) + $i.POP + runtimeT.noneI + ($i.label @end))))] + + [text//index "indexOf"] + [text//last-index "lastIndexOf"] + ) + +## [[Math]] +(def: math-unary-method ($t.method (list $t.double) (#.Some $t.double) (list))) +(def: math-binary-method ($t.method (list $t.double $t.double) (#.Some $t.double) (list))) + +(do-template [ ] + [(def: ( inputI) + Unary + (|>> inputI + ($i.unwrap #$.Double) + ($i.INVOKESTATIC "java.lang.Math" math-unary-method false) + ($i.wrap #$.Double)))] + + [math//cos "cos"] + [math//sin "sin"] + [math//tan "tan"] + [math//acos "acos"] + [math//asin "asin"] + [math//atan "atan"] + [math//cosh "cosh"] + [math//sinh "sinh"] + [math//tanh "tanh"] + [math//exp "exp"] + [math//log "log"] + [math//root2 "sqrt"] + [math//root3 "cbrt"] + [math//ceil "ceil"] + [math//floor "floor"] + ) + +(do-template [ ] + [(def: ( [inputI paramI]) + Binary + (|>> inputI ($i.unwrap #$.Double) + paramI ($i.unwrap #$.Double) + ($i.INVOKESTATIC "java.lang.Math" math-binary-method false) + ($i.wrap #$.Double)))] + + [math//atan2 "atan2"] + [math//pow "pow"] + ) + +(def: (math//round inputI) + Unary + (|>> inputI + ($i.unwrap #$.Double) + ($i.INVOKESTATIC "java.lang.Math" "round" ($t.method (list $t.double) (#.Some $t.long) (list)) false) + $i.L2D + ($i.wrap #$.Double))) + +## [[IO]] +(def: string-method $.Method ($t.method (list $String) #.None (list))) +(def: (io//log messageI) + Unary + (|>> ($i.GETSTATIC "java.lang.System" "out" ($t.class "java.io.PrintStream" (list))) + messageI + ($i.CHECKCAST "java.lang.String") + ($i.INVOKEVIRTUAL "java.io.PrintStream" "println" string-method false) + unitI)) + +(def: (io//error messageI) + Unary + (|>> ($i.NEW "java.lang.Error") + $i.DUP + messageI + ($i.CHECKCAST "java.lang.String") + ($i.INVOKESPECIAL "java.lang.Error" "" string-method false) + $i.ATHROW)) + +(def: (io//exit codeI) + Unary + (|>> codeI jvm-intI + ($i.INVOKESTATIC "java.lang.System" "exit" ($t.method (list $t.int) #.None (list)) false) + $i.NULL)) + +(def: (io//current-time []) + Nullary + (|>> ($i.INVOKESTATIC "java.lang.System" "currentTimeMillis" ($t.method (list) (#.Some $t.long) (list)) false) + ($i.wrap #$.Long))) + +## [[Atoms]] +(def: atom-class Text "java.util.concurrent.atomic.AtomicReference") +(def: (atom//new initI) + Unary + (|>> ($i.NEW atom-class) + $i.DUP + initI + ($i.INVOKESPECIAL atom-class "" ($t.method (list $Object) #.None (list)) false))) + +(def: (atom//read atomI) + Unary + (|>> atomI + ($i.CHECKCAST atom-class) + ($i.INVOKEVIRTUAL atom-class "get" ($t.method (list) (#.Some $Object) (list)) false))) + +(def: (atom//compare-and-swap [atomI oldI newI]) + Trinary + (|>> atomI + ($i.CHECKCAST atom-class) + oldI + newI + ($i.INVOKEVIRTUAL atom-class "compareAndSet" ($t.method (list $Object $Object) (#.Some $t.boolean) (list)) false) + ($i.wrap #$.Boolean))) + +## [[Box]] +(def: empty-boxI + $.Inst + (|>> ($i.int 1) ($i.ANEWARRAY ($t.binary-name "java.lang.Object")))) + +(def: check-boxI + $.Inst + ($i.CHECKCAST ($t.descriptor $Object-Array))) + +(def: (box//new initI) + Unary + (|>> empty-boxI + $i.DUP ($i.int 0) initI $i.AASTORE)) + +(def: (box//read boxI) + Unary + (|>> boxI check-boxI + ($i.int 0) $i.AALOAD)) + +(def: (box//write [valueI boxI]) + Binary + (|>> boxI check-boxI + ($i.int 0) valueI $i.AASTORE + unitI)) + +## [[Processes]] +(def: (process//concurrency-level []) + Nullary + (|>> ($i.INVOKESTATIC "java.lang.Runtime" "getRuntime" ($t.method (list) (#.Some ($t.class "java.lang.Runtime" (list))) (list)) false) + ($i.INVOKEVIRTUAL "java.lang.Runtime" "availableProcessors" ($t.method (list) (#.Some $t.int) (list)) false) + lux-intI)) + +(def: (process//future procedureI) + Unary + (|>> procedureI ($i.CHECKCAST hostL.function-class) + ($i.INVOKESTATIC hostL.runtime-class "future" + ($t.method (list $Function) (#.Some $Object) (list)) false))) + +(def: (process//schedule [millisecondsI procedureI]) + Binary + (|>> millisecondsI ($i.unwrap #$.Long) + procedureI ($i.CHECKCAST hostL.function-class) + ($i.INVOKESTATIC hostL.runtime-class "schedule" + ($t.method (list $t.long $Function) (#.Some $Object) (list)) false))) + +## [Bundles] +(def: lux-procs + Bundle + (|> (dict.new text.Hash) + (install "noop" (unary lux//noop)) + (install "is" (binary lux//is)) + (install "try" (unary lux//try)) + (install "if" (trinary lux//if)) + (install "loop" lux//loop) + (install "recur" lux//recur) + )) + +(def: bit-procs + Bundle + (<| (prefix "bit") + (|> (dict.new text.Hash) + (install "count" (unary bit//count)) + (install "and" (binary bit//and)) + (install "or" (binary bit//or)) + (install "xor" (binary bit//xor)) + (install "shift-left" (binary bit//shift-left)) + (install "unsigned-shift-right" (binary bit//unsigned-shift-right)) + (install "shift-right" (binary bit//shift-right)) + ))) + +(def: nat-procs + Bundle + (<| (prefix "nat") + (|> (dict.new text.Hash) + (install "+" (binary nat//add)) + (install "-" (binary nat//sub)) + (install "*" (binary nat//mul)) + (install "/" (binary nat//div)) + (install "%" (binary nat//rem)) + (install "=" (binary nat//eq)) + (install "<" (binary nat//lt)) + (install "min" (nullary nat//min)) + (install "max" (nullary nat//max)) + (install "to-int" (unary nat//to-int)) + (install "char" (unary nat//char))))) + +(def: int-procs + Bundle + (<| (prefix "int") + (|> (dict.new text.Hash) + (install "+" (binary int//add)) + (install "-" (binary int//sub)) + (install "*" (binary int//mul)) + (install "/" (binary int//div)) + (install "%" (binary int//rem)) + (install "=" (binary int//eq)) + (install "<" (binary int//lt)) + (install "min" (nullary int//min)) + (install "max" (nullary int//max)) + (install "to-nat" (unary int//to-nat)) + (install "to-frac" (unary int//to-frac))))) + +(def: deg-procs + Bundle + (<| (prefix "deg") + (|> (dict.new text.Hash) + (install "+" (binary deg//add)) + (install "-" (binary deg//sub)) + (install "*" (binary deg//mul)) + (install "/" (binary deg//div)) + (install "%" (binary deg//rem)) + (install "=" (binary deg//eq)) + (install "<" (binary deg//lt)) + (install "scale" (binary deg//scale)) + (install "reciprocal" (binary deg//reciprocal)) + (install "min" (nullary deg//min)) + (install "max" (nullary deg//max)) + (install "to-frac" (unary deg//to-frac))))) + +(def: frac-procs + Bundle + (<| (prefix "frac") + (|> (dict.new text.Hash) + (install "+" (binary frac//add)) + (install "-" (binary frac//sub)) + (install "*" (binary frac//mul)) + (install "/" (binary frac//div)) + (install "%" (binary frac//rem)) + (install "=" (binary frac//eq)) + (install "<" (binary frac//lt)) + (install "smallest" (nullary frac//smallest)) + (install "min" (nullary frac//min)) + (install "max" (nullary frac//max)) + (install "not-a-number" (nullary frac//not-a-number)) + (install "positive-infinity" (nullary frac//positive-infinity)) + (install "negative-infinity" (nullary frac//negative-infinity)) + (install "to-deg" (unary frac//to-deg)) + (install "to-int" (unary frac//to-int)) + (install "encode" (unary frac//encode)) + (install "decode" (unary frac//decode))))) + +(def: text-procs + Bundle + (<| (prefix "text") + (|> (dict.new text.Hash) + (install "=" (binary text//eq)) + (install "<" (binary text//lt)) + (install "concat" (binary text//concat)) + (install "index" (trinary text//index)) + (install "size" (unary text//size)) + (install "hash" (unary text//hash)) + (install "replace-once" (trinary text//replace-once)) + (install "replace-all" (trinary text//replace-all)) + (install "char" (binary text//char)) + (install "clip" (trinary text//clip)) + (install "upper" (unary text//upper)) + (install "lower" (unary text//lower)) + ))) + +(def: array-procs + Bundle + (<| (prefix "array") + (|> (dict.new text.Hash) + (install "new" (unary array//new)) + (install "get" (binary array//get)) + (install "put" (trinary array//put)) + (install "remove" (binary array//remove)) + (install "size" (unary array//size)) + ))) + +(def: math-procs + Bundle + (<| (prefix "math") + (|> (dict.new text.Hash) + (install "cos" (unary math//cos)) + (install "sin" (unary math//sin)) + (install "tan" (unary math//tan)) + (install "acos" (unary math//acos)) + (install "asin" (unary math//asin)) + (install "atan" (unary math//atan)) + (install "cosh" (unary math//cosh)) + (install "sinh" (unary math//sinh)) + (install "tanh" (unary math//tanh)) + (install "exp" (unary math//exp)) + (install "log" (unary math//log)) + (install "root2" (unary math//root2)) + (install "root3" (unary math//root3)) + (install "ceil" (unary math//ceil)) + (install "floor" (unary math//floor)) + (install "round" (unary math//round)) + (install "atan2" (binary math//atan2)) + (install "pow" (binary math//pow)) + ))) + +(def: io-procs + Bundle + (<| (prefix "io") + (|> (dict.new text.Hash) + (install "log" (unary io//log)) + (install "error" (unary io//error)) + (install "exit" (unary io//exit)) + (install "current-time" (nullary io//current-time))))) + +(def: atom-procs + Bundle + (<| (prefix "atom") + (|> (dict.new text.Hash) + (install "new" (unary atom//new)) + (install "read" (unary atom//read)) + (install "compare-and-swap" (trinary atom//compare-and-swap))))) + +(def: box-procs + Bundle + (<| (prefix "box") + (|> (dict.new text.Hash) + (install "new" (unary box//new)) + (install "read" (unary box//read)) + (install "write" (binary box//write))))) + +(def: process-procs + Bundle + (<| (prefix "process") + (|> (dict.new text.Hash) + (install "concurrency-level" (nullary process//concurrency-level)) + (install "future" (unary process//future)) + (install "schedule" (binary process//schedule)) + ))) + +(def: #export procedures + Bundle + (<| (prefix "lux") + (|> (dict.new text.Hash) + (dict.merge lux-procs) + (dict.merge bit-procs) + (dict.merge nat-procs) + (dict.merge int-procs) + (dict.merge deg-procs) + (dict.merge frac-procs) + (dict.merge text-procs) + (dict.merge array-procs) + (dict.merge math-procs) + (dict.merge io-procs) + (dict.merge atom-procs) + (dict.merge box-procs) + (dict.merge process-procs) + ))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux new file mode 100644 index 000000000..30d17cac3 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux @@ -0,0 +1,761 @@ +(.module: + lux + (lux (control [monad #+ do] + ["p" parser "parser/" Monad] + ["ex" exception #+ exception:]) + (data [product] + ["e" error] + [text "text/" Eq] + (text format + ["l" lexer]) + (coll [list "list/" Functor] + [dict #+ Dict])) + [macro "macro/" Monad] + (macro [code] + ["s" syntax #+ syntax:]) + [host]) + (luxc ["&" lang] + (lang [".L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["la" analysis] + (extension (analysis ["&." host])) + ["ls" synthesis])) + (// ["@" common])) + +(exception: #export Invalid-Syntax-For-JVM-Type) +(exception: #export Invalid-Syntax-For-Argument-Generation) + +(do-template [ ] + [(def: + $.Inst + )] + + [L2S (|>> $i.L2I $i.I2S)] + [L2B (|>> $i.L2I $i.I2B)] + [L2C (|>> $i.L2I $i.I2C)] + ) + +(do-template [ ] + [(def: ( inputI) + @.Unary + (if (is $i.NOP ) + (|>> inputI + ($i.unwrap ) + ($i.wrap )) + (|>> inputI + ($i.unwrap ) + + ($i.wrap ))))] + + [convert//double-to-float #$.Double $i.D2F #$.Float] + [convert//double-to-int #$.Double $i.D2I #$.Int] + [convert//double-to-long #$.Double $i.D2L #$.Long] + [convert//float-to-double #$.Float $i.F2D #$.Double] + [convert//float-to-int #$.Float $i.F2I #$.Int] + [convert//float-to-long #$.Float $i.F2L #$.Long] + [convert//int-to-byte #$.Int $i.I2B #$.Byte] + [convert//int-to-char #$.Int $i.I2C #$.Char] + [convert//int-to-double #$.Int $i.I2D #$.Double] + [convert//int-to-float #$.Int $i.I2F #$.Float] + [convert//int-to-long #$.Int $i.I2L #$.Long] + [convert//int-to-short #$.Int $i.I2S #$.Short] + [convert//long-to-double #$.Long $i.L2D #$.Double] + [convert//long-to-float #$.Long $i.L2F #$.Float] + [convert//long-to-int #$.Long $i.L2I #$.Int] + [convert//long-to-short #$.Long L2S #$.Short] + [convert//long-to-byte #$.Long L2B #$.Byte] + [convert//long-to-char #$.Long L2C #$.Char] + [convert//char-to-byte #$.Char $i.I2B #$.Byte] + [convert//char-to-short #$.Char $i.I2S #$.Short] + [convert//char-to-int #$.Char $i.NOP #$.Int] + [convert//char-to-long #$.Char $i.I2L #$.Long] + [convert//byte-to-long #$.Byte $i.I2L #$.Long] + [convert//short-to-long #$.Short $i.I2L #$.Long] + ) + +(def: conversion-procs + @.Bundle + (<| (@.prefix "convert") + (|> (dict.new text.Hash) + (@.install "double-to-float" (@.unary convert//double-to-float)) + (@.install "double-to-int" (@.unary convert//double-to-int)) + (@.install "double-to-long" (@.unary convert//double-to-long)) + (@.install "float-to-double" (@.unary convert//float-to-double)) + (@.install "float-to-int" (@.unary convert//float-to-int)) + (@.install "float-to-long" (@.unary convert//float-to-long)) + (@.install "int-to-byte" (@.unary convert//int-to-byte)) + (@.install "int-to-char" (@.unary convert//int-to-char)) + (@.install "int-to-double" (@.unary convert//int-to-double)) + (@.install "int-to-float" (@.unary convert//int-to-float)) + (@.install "int-to-long" (@.unary convert//int-to-long)) + (@.install "int-to-short" (@.unary convert//int-to-short)) + (@.install "long-to-double" (@.unary convert//long-to-double)) + (@.install "long-to-float" (@.unary convert//long-to-float)) + (@.install "long-to-int" (@.unary convert//long-to-int)) + (@.install "long-to-short" (@.unary convert//long-to-short)) + (@.install "long-to-byte" (@.unary convert//long-to-byte)) + (@.install "long-to-char" (@.unary convert//long-to-char)) + (@.install "char-to-byte" (@.unary convert//char-to-byte)) + (@.install "char-to-short" (@.unary convert//char-to-short)) + (@.install "char-to-int" (@.unary convert//char-to-int)) + (@.install "char-to-long" (@.unary convert//char-to-long)) + (@.install "byte-to-long" (@.unary convert//byte-to-long)) + (@.install "short-to-long" (@.unary convert//short-to-long)) + ))) + +(do-template [ ] + [(def: ( [xI yI]) + @.Binary + (|>> xI ($i.unwrap ) + yI ($i.unwrap ) + ($i.wrap )))] + + [int//+ $i.IADD #$.Int #$.Int #$.Int] + [int//- $i.ISUB #$.Int #$.Int #$.Int] + [int//* $i.IMUL #$.Int #$.Int #$.Int] + [int/// $i.IDIV #$.Int #$.Int #$.Int] + [int//% $i.IREM #$.Int #$.Int #$.Int] + [int//and $i.IAND #$.Int #$.Int #$.Int] + [int//or $i.IOR #$.Int #$.Int #$.Int] + [int//xor $i.IXOR #$.Int #$.Int #$.Int] + [int//shl $i.ISHL #$.Int #$.Int #$.Int] + [int//shr $i.ISHR #$.Int #$.Int #$.Int] + [int//ushr $i.IUSHR #$.Int #$.Int #$.Int] + + [long//+ $i.LADD #$.Long #$.Long #$.Long] + [long//- $i.LSUB #$.Long #$.Long #$.Long] + [long//* $i.LMUL #$.Long #$.Long #$.Long] + [long/// $i.LDIV #$.Long #$.Long #$.Long] + [long//% $i.LREM #$.Long #$.Long #$.Long] + [long//and $i.LAND #$.Long #$.Long #$.Long] + [long//or $i.LOR #$.Long #$.Long #$.Long] + [long//xor $i.LXOR #$.Long #$.Long #$.Long] + [long//shl $i.LSHL #$.Long #$.Int #$.Long] + [long//shr $i.LSHR #$.Long #$.Int #$.Long] + [long//ushr $i.LUSHR #$.Long #$.Int #$.Long] + + [float//+ $i.FADD #$.Float #$.Float #$.Float] + [float//- $i.FSUB #$.Float #$.Float #$.Float] + [float//* $i.FMUL #$.Float #$.Float #$.Float] + [float/// $i.FDIV #$.Float #$.Float #$.Float] + [float//% $i.FREM #$.Float #$.Float #$.Float] + + [double//+ $i.DADD #$.Double #$.Double #$.Double] + [double//- $i.DSUB #$.Double #$.Double #$.Double] + [double//* $i.DMUL #$.Double #$.Double #$.Double] + [double/// $i.DDIV #$.Double #$.Double #$.Double] + [double//% $i.DREM #$.Double #$.Double #$.Double] + ) + +(do-template [ ] + [(def: ( [xI yI]) + @.Binary + (<| $i.with-label (function [@then]) + $i.with-label (function [@end]) + (|>> xI ($i.unwrap ) + yI ($i.unwrap ) + ( @then) + ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list))) + ($i.GOTO @end) + ($i.label @then) + ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list))) + ($i.label @end))))] + + [int//= $i.IF_ICMPEQ #$.Int #$.Int #$.Boolean] + [int//< $i.IF_ICMPLT #$.Int #$.Int #$.Boolean] + + [char//= $i.IF_ICMPEQ #$.Char #$.Char #$.Boolean] + [char//< $i.IF_ICMPLT #$.Char #$.Char #$.Boolean] + ) + +(do-template [ ] + [(def: ( [xI yI]) + @.Binary + (<| $i.with-label (function [@then]) + $i.with-label (function [@end]) + (|>> xI ($i.unwrap ) + yI ($i.unwrap ) + + ($i.int ) + ($i.IF_ICMPEQ @then) + ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list))) + ($i.GOTO @end) + ($i.label @then) + ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list))) + ($i.label @end))))] + + [long//= $i.LCMP 0 #$.Long #$.Long #$.Boolean] + [long//< $i.LCMP -1 #$.Long #$.Long #$.Boolean] + + [float//= $i.FCMPG 0 #$.Float #$.Float #$.Boolean] + [float//< $i.FCMPG -1 #$.Float #$.Float #$.Boolean] + + [double//= $i.DCMPG 0 #$.Double #$.Double #$.Boolean] + [double//< $i.DCMPG -1 #$.Double #$.Double #$.Boolean] + ) + +(def: int-procs + @.Bundle + (<| (@.prefix "int") + (|> (dict.new text.Hash) + (@.install "+" (@.binary int//+)) + (@.install "-" (@.binary int//-)) + (@.install "*" (@.binary int//*)) + (@.install "/" (@.binary int///)) + (@.install "%" (@.binary int//%)) + (@.install "=" (@.binary int//=)) + (@.install "<" (@.binary int//<)) + (@.install "and" (@.binary int//and)) + (@.install "or" (@.binary int//or)) + (@.install "xor" (@.binary int//xor)) + (@.install "shl" (@.binary int//shl)) + (@.install "shr" (@.binary int//shr)) + (@.install "ushr" (@.binary int//ushr)) + ))) + +(def: long-procs + @.Bundle + (<| (@.prefix "long") + (|> (dict.new text.Hash) + (@.install "+" (@.binary long//+)) + (@.install "-" (@.binary long//-)) + (@.install "*" (@.binary long//*)) + (@.install "/" (@.binary long///)) + (@.install "%" (@.binary long//%)) + (@.install "=" (@.binary long//=)) + (@.install "<" (@.binary long//<)) + (@.install "and" (@.binary long//and)) + (@.install "or" (@.binary long//or)) + (@.install "xor" (@.binary long//xor)) + (@.install "shl" (@.binary long//shl)) + (@.install "shr" (@.binary long//shr)) + (@.install "ushr" (@.binary long//ushr)) + ))) + +(def: float-procs + @.Bundle + (<| (@.prefix "float") + (|> (dict.new text.Hash) + (@.install "+" (@.binary float//+)) + (@.install "-" (@.binary float//-)) + (@.install "*" (@.binary float//*)) + (@.install "/" (@.binary float///)) + (@.install "%" (@.binary float//%)) + (@.install "=" (@.binary float//=)) + (@.install "<" (@.binary float//<)) + ))) + +(def: double-procs + @.Bundle + (<| (@.prefix "double") + (|> (dict.new text.Hash) + (@.install "+" (@.binary double//+)) + (@.install "-" (@.binary double//-)) + (@.install "*" (@.binary double//*)) + (@.install "/" (@.binary double///)) + (@.install "%" (@.binary double//%)) + (@.install "=" (@.binary double//=)) + (@.install "<" (@.binary double//<)) + ))) + +(def: char-procs + @.Bundle + (<| (@.prefix "char") + (|> (dict.new text.Hash) + (@.install "=" (@.binary char//=)) + (@.install "<" (@.binary char//<)) + ))) + +(def: (array//length arrayI) + @.Unary + (|>> arrayI + $i.ARRAYLENGTH + $i.I2L + ($i.wrap #$.Long))) + +(def: (array//new proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Nat level)] [_ (#.Text class)] lengthS)) + (do macro.Monad + [lengthI (translate lengthS) + #let [arrayJT ($t.array level (case class + "boolean" $t.boolean + "byte" $t.byte + "short" $t.short + "int" $t.int + "long" $t.long + "float" $t.float + "double" $t.double + "char" $t.char + _ ($t.class class (list))))]] + (wrap (|>> lengthI + ($i.unwrap #$.Long) + $i.L2I + ($i.array arrayJT)))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: (array//read proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Text class)] idxS arrayS)) + (do macro.Monad + [arrayI (translate arrayS) + idxI (translate idxS) + #let [loadI (case class + "boolean" (|>> $i.BALOAD ($i.wrap #$.Boolean)) + "byte" (|>> $i.BALOAD ($i.wrap #$.Byte)) + "short" (|>> $i.SALOAD ($i.wrap #$.Short)) + "int" (|>> $i.IALOAD ($i.wrap #$.Int)) + "long" (|>> $i.LALOAD ($i.wrap #$.Long)) + "float" (|>> $i.FALOAD ($i.wrap #$.Float)) + "double" (|>> $i.DALOAD ($i.wrap #$.Double)) + "char" (|>> $i.CALOAD ($i.wrap #$.Char)) + _ $i.AALOAD)]] + (wrap (|>> arrayI + idxI + ($i.unwrap #$.Long) + $i.L2I + loadI))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: (array//write proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Text class)] idxS valueS arrayS)) + (do macro.Monad + [arrayI (translate arrayS) + idxI (translate idxS) + valueI (translate valueS) + #let [storeI (case class + "boolean" (|>> ($i.unwrap #$.Boolean) $i.BASTORE) + "byte" (|>> ($i.unwrap #$.Byte) $i.BASTORE) + "short" (|>> ($i.unwrap #$.Short) $i.SASTORE) + "int" (|>> ($i.unwrap #$.Int) $i.IASTORE) + "long" (|>> ($i.unwrap #$.Long) $i.LASTORE) + "float" (|>> ($i.unwrap #$.Float) $i.FASTORE) + "double" (|>> ($i.unwrap #$.Double) $i.DASTORE) + "char" (|>> ($i.unwrap #$.Char) $i.CASTORE) + _ $i.AASTORE)]] + (wrap (|>> arrayI + $i.DUP + idxI + ($i.unwrap #$.Long) + $i.L2I + valueI + storeI))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: array-procs + @.Bundle + (<| (@.prefix "array") + (|> (dict.new text.Hash) + (@.install "length" (@.unary array//length)) + (@.install "new" array//new) + (@.install "read" array//read) + (@.install "write" array//write) + ))) + +(def: (object//null _) + @.Nullary + $i.NULL) + +(def: (object//null? objectI) + @.Unary + (<| $i.with-label (function [@then]) + $i.with-label (function [@end]) + (|>> objectI + ($i.IFNULL @then) + ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list))) + ($i.GOTO @end) + ($i.label @then) + ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list))) + ($i.label @end)))) + +(def: (object//synchronized [monitorI exprI]) + @.Binary + (|>> monitorI + $i.DUP + $i.MONITORENTER + exprI + $i.SWAP + $i.MONITOREXIT)) + +(def: (object//throw exceptionI) + @.Unary + (|>> exceptionI + $i.ATHROW)) + +(def: (object//class proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Text class)])) + (do macro.Monad + [] + (wrap (|>> ($i.string class) + ($i.INVOKESTATIC "java.lang.Class" "forName" + ($t.method (list ($t.class "java.lang.String" (list))) + (#.Some ($t.class "java.lang.Class" (list))) + (list)) + false)))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: (object//instance? proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Text class)] objectS)) + (do macro.Monad + [objectI (translate objectS)] + (wrap (|>> objectI + ($i.INSTANCEOF class) + ($i.wrap #$.Boolean)))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: object-procs + @.Bundle + (<| (@.prefix "object") + (|> (dict.new text.Hash) + (@.install "null" (@.nullary object//null)) + (@.install "null?" (@.unary object//null?)) + (@.install "synchronized" (@.binary object//synchronized)) + (@.install "throw" (@.unary object//throw)) + (@.install "class" object//class) + (@.install "instance?" object//instance?) + ))) + +(def: primitives + (Dict Text $.Primitive) + (|> (list ["boolean" #$.Boolean] + ["byte" #$.Byte] + ["short" #$.Short] + ["int" #$.Int] + ["long" #$.Long] + ["float" #$.Float] + ["double" #$.Double] + ["char" #$.Char]) + (dict.from-list text.Hash))) + +(def: (static//get proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)])) + (do macro.Monad + [] + (case (dict.get unboxed primitives) + (#.Some primitive) + (let [primitive (case unboxed + "boolean" #$.Boolean + "byte" #$.Byte + "short" #$.Short + "int" #$.Int + "long" #$.Long + "float" #$.Float + "double" #$.Double + "char" #$.Char + _ (undefined))] + (wrap (|>> ($i.GETSTATIC class field (#$.Primitive primitive)) + ($i.wrap primitive)))) + + #.None + (wrap ($i.GETSTATIC class field ($t.class unboxed (list)))))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: (static//put proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS)) + (do macro.Monad + [valueI (translate valueS)] + (case (dict.get unboxed primitives) + (#.Some primitive) + (let [primitive (case unboxed + "boolean" #$.Boolean + "byte" #$.Byte + "short" #$.Short + "int" #$.Int + "long" #$.Long + "float" #$.Float + "double" #$.Double + "char" #$.Char + _ (undefined))] + (wrap (|>> valueI + ($i.unwrap primitive) + ($i.PUTSTATIC class field (#$.Primitive primitive)) + ($i.string hostL.unit)))) + + #.None + (wrap (|>> valueI + ($i.CHECKCAST class) + ($i.PUTSTATIC class field ($t.class class (list))) + ($i.string hostL.unit))))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: (virtual//get proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] objectS)) + (do macro.Monad + [objectI (translate objectS)] + (case (dict.get unboxed primitives) + (#.Some primitive) + (let [primitive (case unboxed + "boolean" #$.Boolean + "byte" #$.Byte + "short" #$.Short + "int" #$.Int + "long" #$.Long + "float" #$.Float + "double" #$.Double + "char" #$.Char + _ (undefined))] + (wrap (|>> objectI + ($i.CHECKCAST class) + ($i.GETFIELD class field (#$.Primitive primitive)) + ($i.wrap primitive)))) + + #.None + (wrap (|>> objectI + ($i.CHECKCAST class) + ($i.GETFIELD class field ($t.class unboxed (list))))))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: (virtual//put proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS objectS)) + (do macro.Monad + [valueI (translate valueS) + objectI (translate objectS)] + (case (dict.get unboxed primitives) + (#.Some primitive) + (let [primitive (case unboxed + "boolean" #$.Boolean + "byte" #$.Byte + "short" #$.Short + "int" #$.Int + "long" #$.Long + "float" #$.Float + "double" #$.Double + "char" #$.Char + _ (undefined))] + (wrap (|>> objectI + ($i.CHECKCAST class) + $i.DUP + valueI + ($i.unwrap primitive) + ($i.PUTFIELD class field (#$.Primitive primitive))))) + + #.None + (wrap (|>> objectI + ($i.CHECKCAST class) + $i.DUP + valueI + ($i.CHECKCAST unboxed) + ($i.PUTFIELD class field ($t.class unboxed (list))))))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: base-type + (l.Lexer $.Type) + ($_ p.either + (p.after (l.this "boolean") (parser/wrap $t.boolean)) + (p.after (l.this "byte") (parser/wrap $t.byte)) + (p.after (l.this "short") (parser/wrap $t.short)) + (p.after (l.this "int") (parser/wrap $t.int)) + (p.after (l.this "long") (parser/wrap $t.long)) + (p.after (l.this "float") (parser/wrap $t.float)) + (p.after (l.this "double") (parser/wrap $t.double)) + (p.after (l.this "char") (parser/wrap $t.char)) + (parser/map (function [name] + ($t.class name (list))) + (l.many (l.none-of "["))) + )) + +(def: java-type + (l.Lexer $.Type) + (do p.Monad + [raw base-type + nesting (p.some (l.this "[]"))] + (wrap ($t.array (list.size nesting) raw)))) + +(def: (translate-type argD) + (-> Text (Meta $.Type)) + (case (l.run argD java-type) + (#e.Error error) + (&.throw Invalid-Syntax-For-JVM-Type argD) + + (#e.Success type) + (macro/wrap type))) + +(def: (prepare-input inputT inputI) + (-> $.Type $.Inst $.Inst) + (case inputT + (#$.Primitive primitive) + (|>> inputI ($i.unwrap primitive)) + + (#$.Generic generic) + (case generic + (^or (#$.Var _) (#$.Wildcard _)) + (|>> inputI ($i.CHECKCAST "java.lang.Object")) + + (#$.Class class-name _) + (|>> inputI ($i.CHECKCAST class-name))) + + _ + (|>> inputI ($i.CHECKCAST ($t.descriptor inputT))))) + +(def: (translate-args translate argsS) + (-> (-> ls.Synthesis (Meta $.Inst)) (List ls.Synthesis) + (Meta (List [$.Type $.Inst]))) + (case argsS + #.Nil + (macro/wrap #.Nil) + + (^ (list& [_ (#.Tuple (list [_ (#.Text argD)] argS))] tail)) + (do macro.Monad + [argT (translate-type argD) + argI (:: @ map (prepare-input argT) (translate argS)) + =tail (translate-args translate tail)] + (wrap (list& [argT argI] =tail))) + + _ + (&.throw Invalid-Syntax-For-Argument-Generation ""))) + +(def: (method-return-type description) + (-> Text (Meta (Maybe $.Type))) + (case description + "void" + (macro/wrap #.None) + + _ + (macro/map (|>> #.Some) (translate-type description)))) + +(def: (prepare-return returnT returnI) + (-> (Maybe $.Type) $.Inst $.Inst) + (case returnT + #.None + (|>> returnI + ($i.string hostL.unit)) + + (#.Some type) + (case type + (#$.Primitive primitive) + (|>> returnI ($i.wrap primitive)) + + _ + returnI))) + +(def: (invoke//static proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list& [_ (#.Text class)] [_ (#.Text method)] + [_ (#.Text unboxed)] argsS)) + (do macro.Monad + [argsTI (translate-args translate argsS) + returnT (method-return-type unboxed) + #let [callI (|>> ($i.fuse (list/map product.right argsTI)) + ($i.INVOKESTATIC class method + ($t.method (list/map product.left argsTI) returnT (list)) + false))]] + (wrap (prepare-return returnT callI))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(do-template [ ] + [(def: ( proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list& [_ (#.Text class)] [_ (#.Text method)] + [_ (#.Text unboxed)] objectS argsS)) + (do macro.Monad + [objectI (translate objectS) + argsTI (translate-args translate argsS) + returnT (method-return-type unboxed) + #let [callI (|>> objectI + ($i.CHECKCAST class) + ($i.fuse (list/map product.right argsTI)) + ( class method + ($t.method (list/map product.left argsTI) returnT (list)) + ))]] + (wrap (prepare-return returnT callI))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))] + + [invoke//virtual $i.INVOKEVIRTUAL false] + [invoke//special $i.INVOKESPECIAL false] + [invoke//interface $i.INVOKEINTERFACE true] + ) + +(def: (invoke//constructor proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list& [_ (#.Text class)] argsS)) + (do macro.Monad + [argsTI (translate-args translate argsS)] + (wrap (|>> ($i.NEW class) + $i.DUP + ($i.fuse (list/map product.right argsTI)) + ($i.INVOKESPECIAL class "" + ($t.method (list/map product.left argsTI) #.None (list)) + false)))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: member-procs + @.Bundle + (<| (@.prefix "member") + (|> (dict.new text.Hash) + (dict.merge (<| (@.prefix "static") + (|> (dict.new text.Hash) + (@.install "get" static//get) + (@.install "put" static//put)))) + (dict.merge (<| (@.prefix "virtual") + (|> (dict.new text.Hash) + (@.install "get" virtual//get) + (@.install "put" virtual//put)))) + (dict.merge (<| (@.prefix "invoke") + (|> (dict.new text.Hash) + (@.install "static" invoke//static) + (@.install "virtual" invoke//virtual) + (@.install "special" invoke//special) + (@.install "interface" invoke//interface) + (@.install "constructor" invoke//constructor)))) + ))) + +(def: #export procedures + @.Bundle + (<| (@.prefix "jvm") + (|> (dict.new text.Hash) + (dict.merge conversion-procs) + (dict.merge int-procs) + (dict.merge long-procs) + (dict.merge float-procs) + (dict.merge double-procs) + (dict.merge char-procs) + (dict.merge array-procs) + (dict.merge object-procs) + (dict.merge member-procs) + ))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux new file mode 100644 index 000000000..6776092c9 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux @@ -0,0 +1,49 @@ +(.module: + lux + (lux (control [monad #+ do]) + (data [text "text/" Hash] + text/format) + [macro "macro/" Monad]) + (luxc ["&" lang] + (lang [".L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$i" inst])) + ["ls" synthesis] + [".L" variable #+ Variable])) + (// [".T" common])) + +(do-template [ ] + [(def: #export ( idx) + (-> Nat Text) + (|> idx nat-to-int %i (format )))] + + [captured "c"] + [partial "p"] + ) + +(def: #export (translate-captured variable) + (-> Variable (Meta $.Inst)) + (do macro.Monad + [this-module macro.current-module-name + function-class hostL.context + #let [function-class (format (text.replace-all "/" "." this-module) "." function-class)]] + (wrap (|>> ($i.ALOAD +0) + ($i.GETFIELD function-class + (|> variable i/inc (i/* -1) int-to-nat captured) + commonT.$Object))))) + +(def: #export (translate-local variable) + (-> Variable (Meta $.Inst)) + (macro/wrap ($i.ALOAD (int-to-nat variable)))) + +(def: #export (translate-variable variable) + (-> Variable (Meta $.Inst)) + (if (variableL.captured? variable) + (translate-captured variable) + (translate-local variable))) + +(def: #export (translate-definition [def-module def-name]) + (-> Ident (Meta $.Inst)) + (let [bytecode-name (format def-module "/" (&.normalize-name def-name) (%n (text/hash def-name)))] + (macro/wrap ($i.GETSTATIC bytecode-name commonT.value-field commonT.$Object)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux new file mode 100644 index 000000000..87a47f338 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux @@ -0,0 +1,603 @@ +(.module: + lux + (lux (control monad) + (data text/format + (coll [list "list/" Functor])) + [math] + [macro]) + (luxc ["&" lang] + (lang [".L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["la" analysis] + ["ls" synthesis])) + (// [".T" common])) + +(def: $Object $.Type ($t.class "java.lang.Object" (list))) +(def: $Object-Array $.Type ($t.array +1 $Object)) +(def: $String $.Type ($t.class "java.lang.String" (list))) +(def: #export $Stack $.Type ($t.array +1 $Object)) +(def: #export $Tuple $.Type $Object-Array) +(def: #export $Variant $.Type $Object-Array) +(def: #export $Tag $.Type $t.int) +(def: #export $Flag $.Type $Object) +(def: #export $Datum $.Type $Object) +(def: #export $Function $.Type ($t.class hostL.function-class (list))) +(def: $Throwable $.Type ($t.class "java.lang.Throwable" (list))) + +(def: #export logI + $.Inst + (let [outI ($i.GETSTATIC "java.lang.System" "out" ($t.class "java.io.PrintStream" (list))) + printI (function [method] ($i.INVOKEVIRTUAL "java.io.PrintStream" method ($t.method (list $Object) #.None (list)) false))] + (|>> outI ($i.string "LOG: ") (printI "print") + outI $i.SWAP (printI "println")))) + +(def: variant-method + $.Method + ($t.method (list $t.int $Object $Object) (#.Some $Object-Array) (list))) + +(def: #export variantI + $.Inst + ($i.INVOKESTATIC hostL.runtime-class "variant_make" variant-method false)) + +(def: #export leftI + $.Inst + (|>> ($i.int 0) + $i.NULL + $i.DUP2_X1 + $i.POP2 + variantI)) + +(def: #export rightI + $.Inst + (|>> ($i.int 1) + ($i.string "") + $i.DUP2_X1 + $i.POP2 + variantI)) + +(def: #export someI $.Inst rightI) + +(def: #export noneI + $.Inst + (|>> ($i.int 0) + $i.NULL + ($i.string hostL.unit) + variantI)) + +(def: (try-methodI unsafeI) + (-> $.Inst $.Inst) + (<| $i.with-label (function [@from]) + $i.with-label (function [@to]) + $i.with-label (function [@handler]) + (|>> ($i.try @from @to @handler "java.lang.Exception") + ($i.label @from) + unsafeI + someI + $i.ARETURN + ($i.label @to) + ($i.label @handler) + noneI + $i.ARETURN))) + +(def: #export string-concatI + $.Inst + ($i.INVOKEVIRTUAL "java.lang.String" "concat" ($t.method (list $String) (#.Some $String) (list)) false)) + +(def: #export partials-field Text "partials") +(def: #export apply-method Text "apply") +(def: #export num-apply-variants Nat +8) + +(def: #export (apply-signature arity) + (-> ls.Arity $.Method) + ($t.method (list.repeat arity $Object) (#.Some $Object) (list))) + +(def: adt-methods + $.Def + (let [store-tagI (|>> $i.DUP ($i.int 0) ($i.ILOAD +0) ($i.wrap #$.Int) $i.AASTORE) + store-flagI (|>> $i.DUP ($i.int 1) ($i.ALOAD +1) $i.AASTORE) + store-valueI (|>> $i.DUP ($i.int 2) ($i.ALOAD +2) $i.AASTORE) + force-textMT ($t.method (list $Object) (#.Some $String) (list))] + (|>> ($d.method #$.Public $.staticM "force_text" force-textMT + (<| $i.with-label (function [@is-null]) + $i.with-label (function [@normal-object]) + $i.with-label (function [@array-loop]) + $i.with-label (function [@within-bounds]) + $i.with-label (function [@is-first]) + $i.with-label (function [@elem-end]) + $i.with-label (function [@fold-end]) + (let [on-normal-objectI (|>> ($i.ALOAD +0) + ($i.INVOKEVIRTUAL "java.lang.Object" "toString" ($t.method (list) (#.Some $String) (list)) false)) + on-null-objectI ($i.string "NULL") + arrayI (|>> ($i.ALOAD +0) + ($i.CHECKCAST ($t.descriptor $Object-Array))) + recurseI ($i.INVOKESTATIC hostL.runtime-class "force_text" force-textMT false) + force-elemI (|>> $i.DUP arrayI $i.SWAP $i.AALOAD recurseI) + swap2 (|>> $i.DUP2_X2 ## X,Y => Y,X,Y + $i.POP2 ## Y,X,Y => Y,X + ) + add-spacingI (|>> ($i.string ", ") $i.SWAP string-concatI) + merge-with-totalI (|>> $i.DUP_X2 $i.POP ## TSIP => TPSI + swap2 ## TPSI => SITP + string-concatI ## SITP => SIT + $i.DUP_X2 $i.POP ## SIT => TSI + ) + foldI (|>> $i.DUP ## TSI => TSII + ($i.IFEQ @is-first) ## TSI + force-elemI add-spacingI merge-with-totalI ($i.GOTO @elem-end) + ($i.label @is-first) ## TSI + force-elemI merge-with-totalI + ($i.label @elem-end) ## TSI + ) + inc-idxI (|>> ($i.int 1) $i.IADD) + on-array-objectI (|>> ($i.string "[") ## T + arrayI $i.ARRAYLENGTH ## TS + ($i.int 0) ## TSI + ($i.label @array-loop) ## TSI + $i.DUP2 + ($i.IF_ICMPGT @within-bounds) ## TSI + $i.POP2 ($i.string "]") string-concatI ($i.GOTO @fold-end) + ($i.label @within-bounds) + foldI inc-idxI ($i.GOTO @array-loop) + ($i.label @fold-end))]) + (|>> ($i.ALOAD +0) + ($i.IFNULL @is-null) + ($i.ALOAD +0) + ($i.INSTANCEOF ($t.descriptor $Object-Array)) + ($i.IFEQ @normal-object) + on-array-objectI $i.ARETURN + ($i.label @normal-object) on-normal-objectI $i.ARETURN + ($i.label @is-null) on-null-objectI $i.ARETURN))) + ($d.method #$.Public $.staticM "variant_make" + ($t.method (list $t.int $Object $Object) + (#.Some $Variant) + (list)) + (|>> ($i.int 3) + ($i.array $Object) + store-tagI + store-flagI + store-valueI + $i.ARETURN))))) + +(def: #export force-textI + $.Inst + ($i.INVOKESTATIC hostL.runtime-class "force_text" ($t.method (list $Object) (#.Some $String) (list)) false)) + +(def: nat-methods + $.Def + (let [compare-nat-method ($t.method (list $t.long $t.long) (#.Some $t.int) (list)) + less-thanI (function [@where] (|>> ($i.INVOKESTATIC hostL.runtime-class "compare_nat" compare-nat-method false) ($i.IFLT @where))) + $BigInteger ($t.class "java.math.BigInteger" (list)) + upcast-method ($t.method (list $t.long) (#.Some $BigInteger) (list)) + div-method ($t.method (list $t.long $t.long) (#.Some $t.long) (list)) + upcastI ($i.INVOKESTATIC hostL.runtime-class "_toUnsignedBigInteger" upcast-method false) + downcastI ($i.INVOKEVIRTUAL "java.math.BigInteger" "longValue" ($t.method (list) (#.Some $t.long) (list)) false)] + (|>> ($d.method #$.Public $.staticM "_toUnsignedBigInteger" upcast-method + (let [upcastI ($i.INVOKESTATIC "java.math.BigInteger" "valueOf" upcast-method false) + discernI (function [@where] (|>> ($i.LLOAD +0) ($i.long 0) $i.LCMP ($i.IFGE @where))) + prepare-upperI (|>> ($i.LLOAD +0) ($i.int 32) $i.LUSHR + upcastI + ($i.int 32) ($i.INVOKEVIRTUAL "java.math.BigInteger" "shiftLeft" ($t.method (list $t.int) (#.Some $BigInteger) (list)) false)) + prepare-lowerI (|>> ($i.LLOAD +0) ($i.int 32) $i.LSHL + ($i.int 32) $i.LUSHR + upcastI)] + (<| $i.with-label (function [@simple]) + (|>> (discernI @simple) + ## else + prepare-upperI + prepare-lowerI + ($i.INVOKEVIRTUAL "java.math.BigInteger" "add" ($t.method (list $BigInteger) (#.Some $BigInteger) (list)) false) + $i.ARETURN + ## then + ($i.label @simple) + ($i.LLOAD +0) + upcastI + $i.ARETURN)))) + ($d.method #$.Public $.staticM "compare_nat" compare-nat-method + (let [shiftI (|>> ($i.GETSTATIC "java.lang.Long" "MIN_VALUE" $t.long) $i.LADD)] + (|>> ($i.LLOAD +0) shiftI + ($i.LLOAD +2) shiftI + $i.LCMP + $i.IRETURN))) + ($d.method #$.Public $.staticM "div_nat" div-method + (let [is-param-largeI (function [@where] (|>> ($i.LLOAD +2) ($i.long 0) $i.LCMP ($i.IFLT @where))) + is-subject-smallI (function [@where] (|>> ($i.LLOAD +0) ($i.long 0) $i.LCMP ($i.IFGT @where))) + small-division (|>> ($i.LLOAD +0) ($i.LLOAD +2) $i.LDIV $i.LRETURN) + big-divisionI ($i.INVOKEVIRTUAL "java.math.BigInteger" "divide" ($t.method (list $BigInteger) (#.Some $BigInteger) (list)) false)] + (<| $i.with-label (function [@is-zero]) + $i.with-label (function [@param-is-large]) + $i.with-label (function [@subject-is-small]) + (|>> (is-param-largeI @param-is-large) + ## Param is not too large + (is-subject-smallI @subject-is-small) + ## Param is small, but subject is large + ($i.LLOAD +0) upcastI + ($i.LLOAD +2) upcastI + big-divisionI downcastI $i.LRETURN + ## Both param and subject are small, + ## and can thus be divided normally. + ($i.label @subject-is-small) + small-division + ## Param is too large. Cannot simply divide. + ## Depending on the result of the + ## comparison, a result will be determined. + ($i.label @param-is-large) + ($i.LLOAD +0) ($i.LLOAD +2) (less-thanI @is-zero) + ## Greater-than or equals + ($i.long 1) $i.LRETURN + ## Less than + ($i.label @is-zero) + ($i.long 0) $i.LRETURN)))) + ($d.method #$.Public $.staticM "rem_nat" div-method + (let [is-subject-largeI (function [@where] (|>> ($i.LLOAD +0) ($i.long 0) $i.LCMP ($i.IFLE @where))) + is-param-largeI (function [@where] (|>> ($i.LLOAD +2) ($i.long 0) $i.LCMP ($i.IFLE @where))) + small-remainderI (|>> ($i.LLOAD +0) ($i.LLOAD +2) $i.LREM $i.LRETURN) + big-remainderI ($i.INVOKEVIRTUAL "java.math.BigInteger" "remainder" ($t.method (list $BigInteger) (#.Some $BigInteger) (list)) false)] + (<| $i.with-label (function [@large-number]) + $i.with-label (function [@subject-is-smaller-than-param]) + (|>> (is-subject-largeI @large-number) + (is-param-largeI @large-number) + small-remainderI + + ($i.label @large-number) + ($i.LLOAD +0) ($i.LLOAD +2) (less-thanI @subject-is-smaller-than-param) + + ($i.LLOAD +0) upcastI + ($i.LLOAD +2) upcastI + big-remainderI downcastI $i.LRETURN + + ($i.label @subject-is-smaller-than-param) + ($i.LLOAD +0) + $i.LRETURN)))) + ))) + +(def: frac-shiftI $.Inst ($i.double (math.pow 32.0 2.0))) + +(def: frac-methods + $.Def + (|>> ($d.method #$.Public $.staticM "decode_frac" ($t.method (list $String) (#.Some $Object-Array) (list)) + (try-methodI + (|>> ($i.ALOAD +0) + ($i.INVOKESTATIC "java.lang.Double" "parseDouble" ($t.method (list $String) (#.Some $t.double) (list)) false) + ($i.wrap #$.Double)))) + ($d.method #$.Public $.staticM "frac_to_deg" ($t.method (list $t.double) (#.Some $t.long) (list)) + (let [swap2 (|>> $i.DUP2_X2 $i.POP2) + drop-excessI (|>> ($i.double 1.0) $i.DREM) + shiftI (|>> frac-shiftI $i.DMUL)] + (|>> ($i.DLOAD +0) + ## Get upper half + drop-excessI + shiftI + ## Make a copy, so the lower half can be extracted + $i.DUP2 + ## Get lower half + drop-excessI + shiftI + ## Turn it into a deg + $i.D2L + ## Turn the upper half into deg too + swap2 + $i.D2L + ## Combine both pieces + $i.LADD + ## FINISH + $i.LRETURN + ))) + )) + +(def: deg-bits Nat +64) +(def: deg-method $.Method ($t.method (list $t.long $t.long) (#.Some $t.long) (list))) +(def: clz-method $.Method ($t.method (list $t.long) (#.Some $t.int) (list))) + +(def: deg-methods + $.Def + (let [## "And" mask corresponding to -1 (FFFF...), on the low 32 bits. + low-half (|>> ($i.int -1) $i.I2L $i.LAND) + high-half (|>> ($i.int 32) $i.LUSHR)] + (|>> ($d.method #$.Public $.staticM "mul_deg" deg-method + ## Based on: http://stackoverflow.com/a/31629280/6823464 + (let [shift-downI (|>> ($i.int 32) $i.LUSHR) + low-leftI (|>> ($i.LLOAD +0) low-half) + high-leftI (|>> ($i.LLOAD +0) high-half) + low-rightI (|>> ($i.LLOAD +2) low-half) + high-rightI (|>> ($i.LLOAD +2) high-half) + bottomI (|>> low-leftI low-rightI $i.LMUL) + middleLI (|>> high-leftI low-rightI $i.LMUL) + middleRI (|>> low-leftI high-rightI $i.LMUL) + middleI (|>> middleLI middleRI $i.LADD) + topI (|>> high-leftI high-rightI $i.LMUL)] + (|>> bottomI shift-downI + middleI $i.LADD shift-downI + topI $i.LADD + $i.LRETURN))) + ($d.method #$.Public $.staticM "count_leading_zeros" clz-method + (let [when-zeroI (function [@where] (|>> ($i.long 0) $i.LCMP ($i.IFEQ @where))) + shift-rightI (function [amount] (|>> ($i.int amount) $i.LUSHR)) + decI (|>> ($i.int 1) $i.ISUB)] + (<| $i.with-label (function [@start]) + $i.with-label (function [@done]) + (|>> ($i.int 64) + ($i.label @start) + ($i.LLOAD +0) (when-zeroI @done) + ($i.LLOAD +0) (shift-rightI 1) ($i.LSTORE +0) + decI + ($i.GOTO @start) + ($i.label @done) + $i.IRETURN)))) + ($d.method #$.Public $.staticM "div_deg" deg-method + (<| $i.with-label (function [@same]) + (let [subjectI ($i.LLOAD +0) + paramI ($i.LLOAD +2) + equal?I (function [@where] (|>> $i.LCMP ($i.IFEQ @where))) + count-leading-zerosI ($i.INVOKESTATIC hostL.runtime-class "count_leading_zeros" clz-method false) + calc-max-shiftI (|>> subjectI count-leading-zerosI + paramI count-leading-zerosI + ($i.INVOKESTATIC "java.lang.Math" "min" ($t.method (list $t.int $t.int) (#.Some $t.int) (list)) false) + ($i.ISTORE +4)) + shiftI (|>> ($i.ILOAD +4) $i.LSHL) + imprecise-divisionI (|>> subjectI shiftI + paramI shiftI high-half + $i.LDIV) + scale-downI (|>> ($i.int 32) $i.LSHL)] + (|>> subjectI paramI + (equal?I @same) + ## Based on: http://stackoverflow.com/a/8510587/6823464 + ## Shifting the operands as much as possible can help + ## avoid some loss of precision later. + calc-max-shiftI + imprecise-divisionI + scale-downI + $i.LRETURN + ($i.label @same) + ($i.long -1) ## ~= 1.0 Degrees + $i.LRETURN)))) + ($d.method #$.Public $.staticM "deg_to_frac" ($t.method (list $t.long) (#.Some $t.double) (list)) + (let [highI (|>> ($i.LLOAD +0) high-half $i.L2D) + lowI (|>> ($i.LLOAD +0) low-half $i.L2D) + scaleI (|>> frac-shiftI $i.DDIV)] + (|>> highI scaleI + lowI scaleI scaleI + $i.DADD + $i.DRETURN))) + ))) + +(def: text-methods + $.Def + (|>> ($d.method #$.Public $.staticM "text_clip" ($t.method (list $String $t.int $t.int) (#.Some $Variant) (list)) + (try-methodI + (|>> ($i.ALOAD +0) + ($i.ILOAD +1) + ($i.ILOAD +2) + ($i.INVOKEVIRTUAL "java.lang.String" "substring" ($t.method (list $t.int $t.int) (#.Some $String) (list)) false)))) + ($d.method #$.Public $.staticM "text_char" ($t.method (list $String $t.int) (#.Some $Variant) (list)) + (try-methodI + (|>> ($i.ALOAD +0) + ($i.ILOAD +1) + ($i.INVOKEVIRTUAL "java.lang.String" "codePointAt" ($t.method (list $t.int) (#.Some $t.int) (list)) false) + $i.I2L + ($i.wrap #$.Long)))) + )) + +(def: pm-methods + $.Def + (let [tuple-sizeI (|>> ($i.ALOAD +0) $i.ARRAYLENGTH) + tuple-elemI (|>> ($i.ALOAD +0) ($i.ILOAD +1) $i.AALOAD) + expected-last-sizeI (|>> ($i.ILOAD +1) ($i.int 1) $i.IADD) + tuple-tailI (|>> ($i.ALOAD +0) tuple-sizeI ($i.int 1) $i.ISUB $i.AALOAD ($i.CHECKCAST ($t.descriptor $Tuple)))] + (|>> ($d.method #$.Public $.staticM "pm_fail" ($t.method (list) #.None (list)) + (|>> ($i.NEW "java.lang.IllegalStateException") + $i.DUP + ($i.string "Invalid expression for pattern-matching.") + ($i.INVOKESPECIAL "java.lang.IllegalStateException" "" ($t.method (list $String) #.None (list)) false) + $i.ATHROW)) + ($d.method #$.Public $.staticM "apply_fail" ($t.method (list) #.None (list)) + (|>> ($i.NEW "java.lang.IllegalStateException") + $i.DUP + ($i.string "Error while applying function.") + ($i.INVOKESPECIAL "java.lang.IllegalStateException" "" ($t.method (list $String) #.None (list)) false) + $i.ATHROW)) + ($d.method #$.Public $.staticM "pm_push" ($t.method (list $Stack $Object) (#.Some $Stack) (list)) + (|>> ($i.int 2) + ($i.ANEWARRAY "java.lang.Object") + $i.DUP + ($i.int 0) + ($i.ALOAD +0) + $i.AASTORE + $i.DUP + ($i.int 1) + ($i.ALOAD +1) + $i.AASTORE + $i.ARETURN)) + ($d.method #$.Public $.staticM "pm_pop" ($t.method (list $Stack) (#.Some $Stack) (list)) + (|>> ($i.ALOAD +0) + ($i.int 0) + $i.AALOAD + ($i.CHECKCAST ($t.descriptor $Stack)) + $i.ARETURN)) + ($d.method #$.Public $.staticM "pm_peek" ($t.method (list $Stack) (#.Some $Object) (list)) + (|>> ($i.ALOAD +0) + ($i.int 1) + $i.AALOAD + $i.ARETURN)) + ($d.method #$.Public $.staticM "pm_variant" ($t.method (list $Variant $Tag $Flag) (#.Some $Object) (list)) + (<| $i.with-label (function [@begin]) + $i.with-label (function [@just-return]) + $i.with-label (function [@then]) + $i.with-label (function [@further]) + $i.with-label (function [@shorten]) + $i.with-label (function [@wrong]) + (let [variant-partI (: (-> Nat $.Inst) + (function [idx] + (|>> ($i.int (nat-to-int idx)) $i.AALOAD))) + tagI (: $.Inst + (|>> (variant-partI +0) ($i.unwrap #$.Int))) + flagI (variant-partI +1) + datumI (variant-partI +2) + shortenI (|>> ($i.ALOAD +0) tagI ## Get tag + ($i.ILOAD +1) $i.ISUB ## Shorten tag + ($i.ALOAD +0) flagI ## Get flag + ($i.ALOAD +0) datumI ## Get value + variantI ## Build sum + $i.ARETURN) + update-tagI (|>> $i.ISUB ($i.ISTORE +1)) + update-variantI (|>> ($i.ALOAD +0) datumI ($i.CHECKCAST ($t.descriptor $Variant)) ($i.ASTORE +0)) + failureI (|>> $i.NULL $i.ARETURN) + return-datumI (|>> ($i.ALOAD +0) datumI $i.ARETURN)]) + (|>> ($i.label @begin) + ($i.ILOAD +1) ## tag + ($i.ALOAD +0) tagI ## tag, sumT + $i.DUP2 ($i.IF_ICMPEQ @then) + $i.DUP2 ($i.IF_ICMPGT @further) + $i.DUP2 ($i.IF_ICMPLT @shorten) + ## $i.POP2 + failureI + ($i.label @then) ## tag, sumT + ($i.ALOAD +2) ## tag, sumT, wants-last? + ($i.ALOAD +0) flagI ## tag, sumT, wants-last?, is-last? + ($i.IF_ACMPEQ @just-return) ## tag, sumT + ($i.label @further) ## tag, sumT + ($i.ALOAD +0) flagI ## tag, sumT, last? + ($i.IFNULL @wrong) ## tag, sumT + update-tagI + update-variantI + ($i.GOTO @begin) + ($i.label @just-return) ## tag, sumT + ## $i.POP2 + return-datumI + ($i.label @shorten) ## tag, sumT + ($i.ALOAD +2) ($i.IFNULL @wrong) + ## $i.POP2 + shortenI + ($i.label @wrong) ## tag, sumT + ## $i.POP2 + failureI))) + ($d.method #$.Public $.staticM "pm_left" ($t.method (list $Tuple $t.int) (#.Some $Object) (list)) + (<| $i.with-label (function [@begin]) + $i.with-label (function [@not-recursive]) + (let [updated-idxI (|>> $i.SWAP $i.ISUB)]) + (|>> ($i.label @begin) + tuple-sizeI + expected-last-sizeI + $i.DUP2 ($i.IF_ICMPGT @not-recursive) + ## Recursive + updated-idxI ($i.ISTORE +1) + tuple-tailI ($i.ASTORE +0) + ($i.GOTO @begin) + ($i.label @not-recursive) + ## $i.POP2 + tuple-elemI + $i.ARETURN))) + ($d.method #$.Public $.staticM "pm_right" ($t.method (list $Tuple $t.int) (#.Some $Object) (list)) + (<| $i.with-label (function [@begin]) + $i.with-label (function [@tail]) + $i.with-label (function [@slice]) + (let [updated-idxI (|>> ($i.ILOAD +1) ($i.int 1) $i.IADD tuple-sizeI $i.ISUB) + sliceI (|>> ($i.ALOAD +0) ($i.ILOAD +1) tuple-sizeI + ($i.INVOKESTATIC "java.util.Arrays" "copyOfRange" ($t.method (list $Object-Array $t.int $t.int) (#.Some $Object-Array) (list)) false))]) + (|>> ($i.label @begin) + tuple-sizeI + expected-last-sizeI + $i.DUP2 ($i.IF_ICMPEQ @tail) + ($i.IF_ICMPGT @slice) + ## Must recurse + tuple-tailI ($i.ASTORE +0) + updated-idxI ($i.ISTORE +1) + ($i.GOTO @begin) + ($i.label @slice) + sliceI + $i.ARETURN + ($i.label @tail) + ## $i.POP2 + tuple-elemI + $i.ARETURN))) + ))) + +(def: io-methods + $.Def + (let [string-writerI (|>> ($i.NEW "java.io.StringWriter") + $i.DUP + ($i.INVOKESPECIAL "java.io.StringWriter" "" ($t.method (list) #.None (list)) false)) + print-writerI (|>> ($i.NEW "java.io.PrintWriter") + $i.SWAP + $i.DUP2 + $i.POP + $i.SWAP + ($i.boolean true) + ($i.INVOKESPECIAL "java.io.PrintWriter" "" ($t.method (list ($t.class "java.io.Writer" (list)) $t.boolean) #.None (list)) false) + )] + (|>> ($d.method #$.Public $.staticM "try" ($t.method (list $Function) (#.Some $Variant) (list)) + (<| $i.with-label (function [@from]) + $i.with-label (function [@to]) + $i.with-label (function [@handler]) + (|>> ($i.try @from @to @handler "java.lang.Throwable") + ($i.label @from) + ($i.ALOAD +0) + $i.NULL + ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature +1) false) + rightI + $i.ARETURN + ($i.label @to) + ($i.label @handler) + string-writerI ## TW + $i.DUP2 ## TWTW + print-writerI ## TWTP + ($i.INVOKEVIRTUAL "java.lang.Throwable" "printStackTrace" ($t.method (list ($t.class "java.io.PrintWriter" (list))) #.None (list)) false) ## TW + ($i.INVOKEVIRTUAL "java.io.StringWriter" "toString" ($t.method (list) (#.Some $String) (list)) false) ## TS + $i.SWAP $i.POP leftI + $i.ARETURN))) + ))) + +(def: translate-runtime + (Meta commonT.Bytecode) + (do macro.Monad + [_ (wrap []) + #let [bytecode ($d.class #$.V1_6 #$.Public $.finalC hostL.runtime-class (list) ["java.lang.Object" (list)] (list) + (|>> adt-methods + nat-methods + frac-methods + deg-methods + text-methods + pm-methods + io-methods))] + _ (commonT.store-class hostL.runtime-class bytecode)] + (wrap bytecode))) + +(def: translate-function + (Meta commonT.Bytecode) + (do macro.Monad + [_ (wrap []) + #let [applyI (|> (list.n/range +2 num-apply-variants) + (list/map (function [arity] + ($d.method #$.Public $.noneM apply-method (apply-signature arity) + (let [preI (|> (list.n/range +0 (n/dec arity)) + (list/map $i.ALOAD) + $i.fuse)] + (|>> preI + ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature (n/dec arity)) false) + ($i.CHECKCAST hostL.function-class) + ($i.ALOAD arity) + ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature +1) false) + $i.ARETURN))))) + (list& ($d.abstract-method #$.Public $.noneM apply-method (apply-signature +1))) + $d.fuse) + bytecode ($d.abstract #$.V1_6 #$.Public $.noneC hostL.function-class (list) ["java.lang.Object" (list)] (list) + (|>> ($d.field #$.Public $.finalF partials-field $t.int) + ($d.method #$.Public $.noneM "" ($t.method (list $t.int) #.None (list)) + (|>> ($i.ALOAD +0) + ($i.INVOKESPECIAL "java.lang.Object" "" ($t.method (list) #.None (list)) false) + ($i.ALOAD +0) + ($i.ILOAD +1) + ($i.PUTFIELD hostL.function-class partials-field $t.int) + $i.RETURN)) + applyI))] + _ (commonT.store-class hostL.function-class bytecode)] + (wrap bytecode))) + +(def: #export translate + (Meta [commonT.Bytecode commonT.Bytecode]) + (do macro.Monad + [runtime-bc translate-runtime + function-bc translate-function] + (wrap [runtime-bc function-bc]))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/statement.jvm.lux new file mode 100644 index 000000000..1b828535f --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/statement.jvm.lux @@ -0,0 +1,159 @@ +(.module: + lux + (lux (control monad + ["ex" exception #+ exception:]) + (data ["e" error] + [maybe] + [text "text/" Monoid Hash] + text/format + (coll [list "list/" Functor Fold])) + [macro] + [host]) + (luxc ["&" lang] + ["&." io] + (lang (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["&." scope] + ["&." module] + [".L" host])) + (// [".T" eval] + [".T" common] + [".T" runtime])) + +(exception: #export Invalid-Definition-Value) +(exception: #export Cannot-Evaluate-Definition) + +(host.import java/lang/reflect/Field + (get [#? Object] #try #? Object)) + +(host.import (java/lang/Class c) + (getField [String] #try Field)) + +(def: #export (translate-def def-name valueT valueI metaI metaV) + (-> Text Type $.Inst $.Inst Code (Meta Unit)) + (do macro.Monad + [current-module macro.current-module-name + #let [def-ident [current-module def-name]]] + (case (macro.get-symbol-ann (ident-for #.alias) metaV) + (#.Some real-def) + (do @ + [[realT realA realV] (macro.find-def real-def) + _ (&module.define def-ident [realT metaV realV])] + (wrap [])) + + _ + (do @ + [#let [normal-name (format (&.normalize-name def-name) (%n (text/hash def-name))) + bytecode-name (format current-module "/" normal-name) + class-name (format (text.replace-all "/" "." current-module) "." normal-name) + bytecode ($d.class #$.V1_6 + #$.Public $.finalC + bytecode-name + (list) ["java.lang.Object" (list)] + (list) + (|>> ($d.field #$.Public ($.++F $.finalF $.staticF) commonT.value-field commonT.$Object) + ($d.method #$.Public $.staticM "" ($t.method (list) #.None (list)) + (|>> valueI + ($i.PUTSTATIC bytecode-name commonT.value-field commonT.$Object) + $i.RETURN))))] + _ (commonT.store-class class-name bytecode) + class (commonT.load-class class-name) + valueV (: (Meta Top) + (case (do e.Monad + [field (Class::getField [commonT.value-field] class)] + (Field::get [#.None] field)) + (#e.Success #.None) + (&.throw Invalid-Definition-Value (%ident def-ident)) + + (#e.Success (#.Some valueV)) + (wrap valueV) + + (#e.Error error) + (&.throw Cannot-Evaluate-Definition + (format "Definition: " (%ident def-ident) "\n" + "Error:\n" + error)))) + _ (&module.define def-ident [valueT metaV valueV]) + _ (if (macro.type? metaV) + (case (macro.declared-tags metaV) + #.Nil + (wrap []) + + tags + (&module.declare-tags tags (macro.export? metaV) (:! Type valueV))) + (wrap [])) + #let [_ (log! (format "DEF " (%ident def-ident)))]] + (commonT.record-artifact (format bytecode-name ".class") bytecode))))) + +(def: #export (translate-program programI) + (-> $.Inst (Meta Unit)) + (let [nilI runtimeT.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 "java.lang.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 + runtimeT.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 + ($i.ASTORE +0))) + run-ioI (|>> ($i.CHECKCAST hostL.function-class) + $i.NULL + ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.apply-signature +1) false)) + main-type ($t.method (list ($t.array +1 ($t.class "java.lang.String" (list)))) + #.None + (list))] + (do macro.Monad + [current-module macro.current-module-name + #let [normal-name "_" + bytecode-name (format current-module "/" normal-name) + class-name (text.replace-all "/" "." bytecode-name) + bytecode ($d.class #$.V1_6 + #$.Public $.finalC + bytecode-name + (list) ["java.lang.Object" (list)] + (list) + (|>> ($d.method #$.Public $.staticM "main" main-type + (|>> prepare-input-listI + programI + run-ioI + $i.POP + $i.RETURN))))] + #let [_ (log! (format "PROGRAM " current-module))] + _ (commonT.store-class class-name bytecode)] + (commonT.record-artifact (format bytecode-name ".class") bytecode)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux new file mode 100644 index 000000000..ddb6541cf --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux @@ -0,0 +1,61 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data text/format + (coll [list])) + [macro] + [host #+ do-to]) + (luxc ["&" lang] + (lang [".L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["la" analysis] + ["ls" synthesis])) + (// [".T" common])) + +(exception: #export Not-A-Tuple) + +(def: $Object $.Type ($t.class "java.lang.Object" (list))) + +(def: #export (translate-tuple translate members) + (-> (-> ls.Synthesis (Meta $.Inst)) (List ls.Synthesis) (Meta $.Inst)) + (do macro.Monad + [#let [size (list.size members)] + _ (&.assert Not-A-Tuple (%code (` [(~+ members)])) + (n/>= +2 size)) + membersI (|> members + list.enumerate + (monad.map @ (function [[idx member]] + (do @ + [memberI (translate member)] + (wrap (|>> $i.DUP + ($i.int (nat-to-int idx)) + memberI + $i.AASTORE))))) + (:: @ map $i.fuse))] + (wrap (|>> ($i.int (nat-to-int size)) + ($i.array $Object) + membersI)))) + +(def: (flagI tail?) + (-> Bool $.Inst) + (if tail? + ($i.string "") + $i.NULL)) + +(def: #export (translate-variant translate tag tail? member) + (-> (-> ls.Synthesis (Meta $.Inst)) Nat Bool ls.Synthesis (Meta $.Inst)) + (do macro.Monad + [memberI (translate member)] + (wrap (|>> ($i.int (nat-to-int tag)) + (flagI tail?) + memberI + ($i.INVOKESTATIC hostL.runtime-class + "variant_make" + ($t.method (list $t.int $Object $Object) + (#.Some ($t.array +1 $Object)) + (list)) + false))))) diff --git a/new-luxc/source/luxc/lang/translation/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/loop.jvm.lux deleted file mode 100644 index 8920dc936..000000000 --- a/new-luxc/source/luxc/lang/translation/loop.jvm.lux +++ /dev/null @@ -1,80 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format - (coll [list "list/" Functor Monoid])) - [macro]) - (luxc ["&" lang] - (lang [".L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - ["la" analysis] - ["ls" synthesis] - (translation [".T" common] - [".T" runtime] - [".T" reference]) - [".L" variable #+ Variable Register]))) - -(def: (constant? register changeS) - (-> Register ls.Synthesis Bool) - (case changeS - (^multi (^code ((~ [_ (#.Int var)]))) - (i/= (variableL.local register) - var)) - true - - _ - false)) - -(def: #export (translate-recur translate argsS) - (-> (-> ls.Synthesis (Meta $.Inst)) - (List ls.Synthesis) - (Meta $.Inst)) - (do macro.Monad - [[@begin offset] hostL.anchor - #let [pairs (list.zip2 (list.n/range offset (|> (list.size argsS) n/dec (n/+ offset))) - 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 - ## must be the case. - valuesI+ (monad.map @ (function [[register argS]] - (: (Meta $.Inst) - (if (constant? register argS) - (wrap id) - (translate argS)))) - pairs) - #let [storesI+ (list/map (function [[register argS]] - (: $.Inst - (if (constant? register argS) - id - ($i.ASTORE register)))) - (list.reverse pairs))]] - (wrap (|>> ($i.fuse valuesI+) - ($i.fuse storesI+) - ($i.GOTO @begin))))) - -(def: #export (translate-loop translate offset initsS+ bodyS) - (-> (-> ls.Synthesis (Meta $.Inst)) - Nat (List ls.Synthesis) ls.Synthesis - (Meta $.Inst)) - (do macro.Monad - [@begin $i.make-label - initsI+ (monad.map @ translate initsS+) - bodyI (hostL.with-anchor [@begin offset] - (translate bodyS)) - #let [initializationI (|> (list.enumerate initsI+) - (list/map (function [[register initI]] - (|>> initI - ($i.ASTORE (n/+ offset register))))) - $i.fuse)]] - (wrap (|>> initializationI - ($i.label @begin) - bodyI)))) diff --git a/new-luxc/source/luxc/lang/translation/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/primitive.jvm.lux deleted file mode 100644 index 8fed1de18..000000000 --- a/new-luxc/source/luxc/lang/translation/primitive.jvm.lux +++ /dev/null @@ -1,35 +0,0 @@ -(.module: - lux - (lux (control monad) - (data text/format) - [macro "macro/" Monad]) - (luxc ["&" lang] - (lang [".L" host] - (host ["$" jvm] - (jvm ["$i" inst] - ["$t" type])) - ["la" analysis] - ["ls" synthesis] - (translation [".T" common])))) - -(def: #export translate-unit - (Meta $.Inst) - (macro/wrap ($i.string hostL.unit))) - -(def: #export (translate-bool value) - (-> Bool (Meta $.Inst)) - (macro/wrap ($i.GETSTATIC "java.lang.Boolean" - (if value "TRUE" "FALSE") - ($t.class "java.lang.Boolean" (list))))) - -(do-template [ ] - [(def: #export ( value) - (-> (Meta $.Inst)) - (macro/wrap (|>> ( value) )))] - - [translate-nat Nat (|>> (:! Int) $i.long) ($i.wrap #$.Long)] - [translate-int Int $i.long ($i.wrap #$.Long)] - [translate-deg Deg (|>> (:! Int) $i.long) ($i.wrap #$.Long)] - [translate-frac Frac $i.double ($i.wrap #$.Double)] - [translate-text Text $i.string id] - ) diff --git a/new-luxc/source/luxc/lang/translation/procedure.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure.jvm.lux deleted file mode 100644 index e4f8b9908..000000000 --- a/new-luxc/source/luxc/lang/translation/procedure.jvm.lux +++ /dev/null @@ -1,27 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [maybe] - text/format - (coll [dict]))) - (luxc ["&" lang] - (lang (host ["$" jvm]) - ["ls" synthesis])) - (/ ["/." common] - ["/." host])) - -(exception: #export Unknown-Procedure) - -(def: procedures - /common.Bundle - (|> /common.procedures - (dict.merge /host.procedures))) - -(def: #export (translate-procedure translate name args) - (-> (-> ls.Synthesis (Meta $.Inst)) Text (List ls.Synthesis) - (Meta $.Inst)) - (<| (maybe.default (&.throw Unknown-Procedure (%t name))) - (do maybe.Monad - [proc (dict.get name procedures)] - (wrap (proc translate args))))) diff --git a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux deleted file mode 100644 index 84c42244e..000000000 --- a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux +++ /dev/null @@ -1,809 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["p" parser] - ["ex" exception #+ exception:]) - (data ["e" error] - [text] - text/format - (coll [list "list/" Functor] - [dict #+ Dict])) - [macro #+ with-gensyms] - (macro [code] - ["s" syntax #+ syntax:]) - [host]) - (luxc ["&" lang] - (lang [".L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - ["la" analysis] - ["ls" synthesis] - (translation [".T" runtime] - [".T" case] - [".T" function] - [".T" loop])))) - -(host.import java/lang/Long - (#static MIN_VALUE Long) - (#static MAX_VALUE Long)) - -(host.import java/lang/Double - (#static MIN_VALUE Double) - (#static MAX_VALUE Double) - (#static NaN Double) - (#static POSITIVE_INFINITY Double) - (#static NEGATIVE_INFINITY Double)) - -## [Types] -(type: #export Translator - (-> ls.Synthesis (Meta $.Inst))) - -(type: #export Proc - (-> Translator (List ls.Synthesis) (Meta $.Inst))) - -(type: #export Bundle - (Dict Text Proc)) - -(syntax: (Vector [size s.nat] elemT) - (wrap (list (` [(~+ (list.repeat size elemT))])))) - -(type: #export Nullary (-> (Vector +0 $.Inst) $.Inst)) -(type: #export Unary (-> (Vector +1 $.Inst) $.Inst)) -(type: #export Binary (-> (Vector +2 $.Inst) $.Inst)) -(type: #export Trinary (-> (Vector +3 $.Inst) $.Inst)) -(type: #export Variadic (-> (List $.Inst) $.Inst)) - -## [Utils] -(def: $Object $.Type ($t.class "java.lang.Object" (list))) -(def: $Object-Array $.Type ($t.array +1 $Object)) -(def: $Variant $.Type ($t.array +1 $Object)) -(def: $String $.Type ($t.class "java.lang.String" (list))) -(def: $CharSequence $.Type ($t.class "java.lang.CharSequence" (list))) -(def: $Function $.Type ($t.class hostL.function-class (list))) - -(def: #export (install name unnamed) - (-> Text (-> Text Proc) - (-> Bundle Bundle)) - (dict.put name (unnamed name))) - -(def: #export (prefix prefix bundle) - (-> Text Bundle Bundle) - (|> bundle - dict.entries - (list/map (function [[key val]] [(format prefix " " key) val])) - (dict.from-list text.Hash))) - -(def: (wrong-arity proc expected actual) - (-> Text Nat Nat Text) - (format "Wrong number of arguments for " (%t proc) "\n" - "Expected: " (|> expected nat-to-int %i) "\n" - " Actual: " (|> actual nat-to-int %i))) - -(syntax: (arity: [name s.local-symbol] [arity s.nat]) - (with-gensyms [g!proc g!name g!translate g!inputs] - (do @ - [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] - (wrap (list (` (def: #export ((~ (code.local-symbol name)) (~ g!proc)) - (-> (-> (..Vector (~ (code.nat arity)) $.Inst) $.Inst) - (-> Text ..Proc)) - (function [(~ g!name)] - (function [(~ g!translate) (~ g!inputs)] - (case (~ g!inputs) - (^ (list (~+ g!input+))) - (do macro.Monad - [(~+ (|> g!input+ - (list/map (function [g!input] - (list g!input (` ((~ g!translate) (~ g!input)))))) - list.concat))] - ((~' wrap) ((~ g!proc) [(~+ g!input+)]))) - - (~' _) - (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs)))))))))))))) - -(arity: nullary +0) -(arity: unary +1) -(arity: binary +2) -(arity: trinary +3) - -(def: #export (variadic proc) - (-> Variadic (-> Text Proc)) - (function [proc-name] - (function [translate inputsS] - (do macro.Monad - [inputsI (monad.map @ translate inputsS)] - (wrap (proc inputsI)))))) - -## [Instructions] -(def: lux-intI $.Inst (|>> $i.I2L ($i.wrap #$.Long))) -(def: jvm-intI $.Inst (|>> ($i.unwrap #$.Long) $i.L2I)) - -(def: (array-writeI arrayI idxI elemI) - (-> $.Inst $.Inst $.Inst - $.Inst) - (|>> arrayI ($i.CHECKCAST ($t.descriptor $Object-Array)) - $i.DUP - idxI jvm-intI - elemI - $i.AASTORE)) - -(def: (predicateI tester) - (-> (-> $.Label $.Inst) - $.Inst) - (<| $i.with-label (function [@then]) - $i.with-label (function [@end]) - (|>> (tester @then) - ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list))) - ($i.GOTO @end) - ($i.label @then) - ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list))) - ($i.label @end) - ))) - -(def: unitI $.Inst ($i.string hostL.unit)) - -## [Procedures] -## [[Lux]] -(def: (lux//is [leftI rightI]) - Binary - (|>> leftI - rightI - (predicateI $i.IF_ACMPEQ))) - -(def: (lux//if [testI thenI elseI]) - Trinary - (caseT.translate-if testI thenI elseI)) - -(def: (lux//try riskyI) - Unary - (|>> riskyI - ($i.CHECKCAST hostL.function-class) - ($i.INVOKESTATIC hostL.runtime-class "try" - ($t.method (list $Function) (#.Some $Object-Array) (list)) - false))) - -(def: (lux//noop valueI) - Unary - valueI) - -(exception: #export Wrong-Syntax) -(def: #export (wrong-syntax procedure args) - (-> Text (List ls.Synthesis) Text) - (format "Procedure: " procedure "\n" - "Arguments: " (%code (code.tuple args)))) - -(def: lux//loop - (-> Text Proc) - (function [proc-name] - (function [translate inputsS] - (case (s.run inputsS ($_ p.seq s.nat (s.tuple (p.many s.any)) s.any)) - (#e.Success [offset initsS+ bodyS]) - (loopT.translate-loop translate offset initsS+ bodyS) - - (#e.Error error) - (&.throw Wrong-Syntax (wrong-syntax proc-name inputsS))) - ))) - -(def: lux//recur - (-> Text Proc) - (function [proc-name] - (function [translate inputsS] - (loopT.translate-recur translate inputsS)))) - -## [[Bits]] -(do-template [ ] - [(def: ( [inputI maskI]) - Binary - (|>> inputI ($i.unwrap #$.Long) - maskI ($i.unwrap #$.Long) - ($i.wrap #$.Long)))] - - [bit//and $i.LAND] - [bit//or $i.LOR] - [bit//xor $i.LXOR] - ) - -(def: (bit//count inputI) - Unary - (|>> inputI ($i.unwrap #$.Long) - ($i.INVOKESTATIC "java.lang.Long" "bitCount" ($t.method (list $t.long) (#.Some $t.int) (list)) false) - lux-intI)) - -(do-template [ ] - [(def: ( [inputI shiftI]) - Binary - (|>> inputI ($i.unwrap #$.Long) - shiftI jvm-intI - - ($i.wrap #$.Long)))] - - [bit//shift-left $i.LSHL] - [bit//shift-right $i.LSHR] - [bit//unsigned-shift-right $i.LUSHR] - ) - -## [[Arrays]] -(def: (array//new lengthI) - Unary - (|>> lengthI jvm-intI ($i.ANEWARRAY ($t.binary-name "java.lang.Object")))) - -(def: (array//get [arrayI idxI]) - Binary - (<| $i.with-label (function [@is-null]) - $i.with-label (function [@end]) - (|>> arrayI ($i.CHECKCAST ($t.descriptor $Object-Array)) - idxI jvm-intI - $i.AALOAD - $i.DUP - ($i.IFNULL @is-null) - runtimeT.someI - ($i.GOTO @end) - ($i.label @is-null) - $i.POP - runtimeT.noneI - ($i.label @end)))) - -(def: (array//put [arrayI idxI elemI]) - Trinary - (array-writeI arrayI idxI elemI)) - -(def: (array//remove [arrayI idxI]) - Binary - (array-writeI arrayI idxI $i.NULL)) - -(def: (array//size arrayI) - Unary - (|>> arrayI ($i.CHECKCAST ($t.descriptor $Object-Array)) - $i.ARRAYLENGTH - lux-intI)) - -## [[Numbers]] -(def: nat-method - $.Method - ($t.method (list $t.long $t.long) (#.Some $t.long) (list))) - -(def: deg-method $.Method nat-method) - -(def: compare-nat-method - $.Method - ($t.method (list $t.long $t.long) (#.Some $t.int) (list))) - -(do-template [ ] - [(def: ( _) - Nullary - (|>> ($i.wrap )))] - - [nat//min ($i.long 0) #$.Long] - [nat//max ($i.long -1) #$.Long] - - [int//min ($i.long Long::MIN_VALUE) #$.Long] - [int//max ($i.long Long::MAX_VALUE) #$.Long] - - [frac//smallest ($i.double Double::MIN_VALUE) #$.Double] - [frac//min ($i.double (f/* -1.0 Double::MAX_VALUE)) #$.Double] - [frac//max ($i.double Double::MAX_VALUE) #$.Double] - [frac//not-a-number ($i.double Double::NaN) #$.Double] - [frac//positive-infinity ($i.double Double::POSITIVE_INFINITY) #$.Double] - [frac//negative-infinity ($i.double Double::NEGATIVE_INFINITY) #$.Double] - - [deg//min ($i.long 0) #$.Long] - [deg//max ($i.long -1) #$.Long] - ) - -(do-template [ ] - [(def: ( [subjectI paramI]) - Binary - (|>> subjectI ($i.unwrap ) - paramI ($i.unwrap ) - - ($i.wrap )))] - - [int//add #$.Long $i.LADD] - [int//sub #$.Long $i.LSUB] - [int//mul #$.Long $i.LMUL] - [int//div #$.Long $i.LDIV] - [int//rem #$.Long $i.LREM] - - [nat//add #$.Long $i.LADD] - [nat//sub #$.Long $i.LSUB] - [nat//mul #$.Long $i.LMUL] - [nat//div #$.Long ($i.INVOKESTATIC hostL.runtime-class "div_nat" nat-method false)] - [nat//rem #$.Long ($i.INVOKESTATIC hostL.runtime-class "rem_nat" nat-method false)] - - [frac//add #$.Double $i.DADD] - [frac//sub #$.Double $i.DSUB] - [frac//mul #$.Double $i.DMUL] - [frac//div #$.Double $i.DDIV] - [frac//rem #$.Double $i.DREM] - - [deg//add #$.Long $i.LADD] - [deg//sub #$.Long $i.LSUB] - [deg//mul #$.Long ($i.INVOKESTATIC hostL.runtime-class "mul_deg" deg-method false)] - [deg//div #$.Long ($i.INVOKESTATIC hostL.runtime-class "div_deg" deg-method false)] - [deg//rem #$.Long $i.LSUB] - [deg//scale #$.Long $i.LMUL] - [deg//reciprocal #$.Long $i.LDIV] - ) - -(do-template [ ] - [(do-template [ ] - [(def: ( [subjectI paramI]) - Binary - (|>> subjectI - paramI - - ($i.int ) - (predicateI $i.IF_ICMPEQ)))] - [ 0] - [ -1])] - - [nat//eq nat//lt ($i.unwrap #$.Long) ($i.INVOKESTATIC hostL.runtime-class "compare_nat" compare-nat-method false)] - [int//eq int//lt ($i.unwrap #$.Long) $i.LCMP] - [frac//eq frac//lt ($i.unwrap #$.Double) $i.DCMPG] - [deg//eq deg//lt ($i.unwrap #$.Long) ($i.INVOKESTATIC hostL.runtime-class "compare_nat" compare-nat-method false)] - ) - -(do-template [ ] - [(def: ( inputI) - Unary - (|>> inputI ))] - - [nat//to-int id id] - [nat//char ($i.unwrap #$.Long) - ((|>> $i.L2I $i.I2C ($i.INVOKESTATIC "java.lang.Character" "toString" ($t.method (list $t.char) (#.Some $String) (list)) false)))] - - [int//to-nat id id] - [int//to-frac ($i.unwrap #$.Long) (<| ($i.wrap #$.Double) $i.L2D)] - - [frac//to-int ($i.unwrap #$.Double) (<| ($i.wrap #$.Long) $i.D2L)] - [frac//to-deg ($i.unwrap #$.Double) - (<| ($i.wrap #$.Long) ($i.INVOKESTATIC hostL.runtime-class "frac_to_deg" - ($t.method (list $t.double) (#.Some $t.long) (list)) false))] - [frac//encode ($i.unwrap #$.Double) - ($i.INVOKESTATIC "java.lang.Double" "toString" ($t.method (list $t.double) (#.Some $String) (list)) false)] - [frac//decode ($i.CHECKCAST "java.lang.String") - ($i.INVOKESTATIC hostL.runtime-class "decode_frac" ($t.method (list $String) (#.Some $Object-Array) (list)) false)] - - [deg//to-frac ($i.unwrap #$.Long) - (<| ($i.wrap #$.Double) ($i.INVOKESTATIC hostL.runtime-class "deg_to_frac" - ($t.method (list $t.long) (#.Some $t.double) (list)) false))] - ) - -## [[Text]] -(do-template [ ] - [(def: ( inputI) - Unary - (|>> inputI - ($i.CHECKCAST "java.lang.String") - ($i.INVOKEVIRTUAL ($t.method (list) (#.Some ) (list)) false) - ))] - - [text//size "java.lang.String" "length" lux-intI $t.int] - [text//hash "java.lang.Object" "hashCode" lux-intI $t.int] - [text//trim "java.lang.String" "trim" id $String] - [text//upper "java.lang.String" "toUpperCase" id $String] - [text//lower "java.lang.String" "toLowerCase" id $String] - ) - -(do-template [ ] - [(def: ( [subjectI paramI]) - Binary - (|>> subjectI - paramI - ))] - - [text//eq id id - ($i.INVOKEVIRTUAL "java.lang.Object" "equals" ($t.method (list $Object) (#.Some $t.boolean) (list)) false) - ($i.wrap #$.Boolean)] - [text//lt ($i.CHECKCAST "java.lang.String") ($i.CHECKCAST "java.lang.String") - ($i.INVOKEVIRTUAL "java.lang.String" "compareTo" ($t.method (list $String) (#.Some $t.int) (list)) false) - (<| (predicateI $i.IF_ICMPEQ) ($i.int -1))] - [text//concat ($i.CHECKCAST "java.lang.String") ($i.CHECKCAST "java.lang.String") - ($i.INVOKEVIRTUAL "java.lang.String" "concat" ($t.method (list $String) (#.Some $String) (list)) false) - id] - [text//contains? ($i.CHECKCAST "java.lang.String") ($i.CHECKCAST "java.lang.String") - ($i.INVOKEVIRTUAL "java.lang.String" "contains" ($t.method (list $CharSequence) (#.Some $t.boolean) (list)) false) - ($i.wrap #$.Boolean)] - [text//char ($i.CHECKCAST "java.lang.String") jvm-intI - ($i.INVOKESTATIC hostL.runtime-class "text_char" ($t.method (list $String $t.int) (#.Some $Variant) (list)) false) - id] - ) - -(do-template [ ] - [(def: ( [subjectI paramI extraI]) - Trinary - (|>> subjectI - paramI - extraI - ))] - - [text//clip ($i.CHECKCAST "java.lang.String") jvm-intI jvm-intI - ($i.INVOKESTATIC hostL.runtime-class "text_clip" - ($t.method (list $String $t.int $t.int) (#.Some $Variant) (list)) false)] - [text//replace-once ($i.CHECKCAST "java.lang.String") - (<| ($i.INVOKESTATIC "java.util.regex.Pattern" "quote" ($t.method (list $String) (#.Some $String) (list)) false) - ($i.CHECKCAST "java.lang.String")) - ($i.CHECKCAST "java.lang.String") - ($i.INVOKEVIRTUAL "java.lang.String" "replaceFirst" ($t.method (list $String $String) (#.Some $String) (list)) false)] - [text//replace-all ($i.CHECKCAST "java.lang.String") - (<| ($i.INVOKESTATIC "java.util.regex.Pattern" "quote" ($t.method (list $String) (#.Some $String) (list)) false) - ($i.CHECKCAST "java.lang.String")) - ($i.CHECKCAST "java.lang.String") - ($i.INVOKEVIRTUAL "java.lang.String" "replaceAll" ($t.method (list $String $String) (#.Some $String) (list)) false)] - ) - -(def: index-method $.Method ($t.method (list $String $t.int) (#.Some $t.int) (list))) -(do-template [ ] - [(def: ( [textI partI startI]) - Trinary - (<| $i.with-label (function [@not-found]) - $i.with-label (function [@end]) - (|>> textI ($i.CHECKCAST "java.lang.String") - partI ($i.CHECKCAST "java.lang.String") - startI jvm-intI - ($i.INVOKEVIRTUAL "java.lang.String" index-method false) - $i.DUP - ($i.int -1) - ($i.IF_ICMPEQ @not-found) - lux-intI - runtimeT.someI - ($i.GOTO @end) - ($i.label @not-found) - $i.POP - runtimeT.noneI - ($i.label @end))))] - - [text//index "indexOf"] - [text//last-index "lastIndexOf"] - ) - -## [[Math]] -(def: math-unary-method ($t.method (list $t.double) (#.Some $t.double) (list))) -(def: math-binary-method ($t.method (list $t.double $t.double) (#.Some $t.double) (list))) - -(do-template [ ] - [(def: ( inputI) - Unary - (|>> inputI - ($i.unwrap #$.Double) - ($i.INVOKESTATIC "java.lang.Math" math-unary-method false) - ($i.wrap #$.Double)))] - - [math//cos "cos"] - [math//sin "sin"] - [math//tan "tan"] - [math//acos "acos"] - [math//asin "asin"] - [math//atan "atan"] - [math//cosh "cosh"] - [math//sinh "sinh"] - [math//tanh "tanh"] - [math//exp "exp"] - [math//log "log"] - [math//root2 "sqrt"] - [math//root3 "cbrt"] - [math//ceil "ceil"] - [math//floor "floor"] - ) - -(do-template [ ] - [(def: ( [inputI paramI]) - Binary - (|>> inputI ($i.unwrap #$.Double) - paramI ($i.unwrap #$.Double) - ($i.INVOKESTATIC "java.lang.Math" math-binary-method false) - ($i.wrap #$.Double)))] - - [math//atan2 "atan2"] - [math//pow "pow"] - ) - -(def: (math//round inputI) - Unary - (|>> inputI - ($i.unwrap #$.Double) - ($i.INVOKESTATIC "java.lang.Math" "round" ($t.method (list $t.double) (#.Some $t.long) (list)) false) - $i.L2D - ($i.wrap #$.Double))) - -## [[IO]] -(def: string-method $.Method ($t.method (list $String) #.None (list))) -(def: (io//log messageI) - Unary - (|>> ($i.GETSTATIC "java.lang.System" "out" ($t.class "java.io.PrintStream" (list))) - messageI - ($i.CHECKCAST "java.lang.String") - ($i.INVOKEVIRTUAL "java.io.PrintStream" "println" string-method false) - unitI)) - -(def: (io//error messageI) - Unary - (|>> ($i.NEW "java.lang.Error") - $i.DUP - messageI - ($i.CHECKCAST "java.lang.String") - ($i.INVOKESPECIAL "java.lang.Error" "" string-method false) - $i.ATHROW)) - -(def: (io//exit codeI) - Unary - (|>> codeI jvm-intI - ($i.INVOKESTATIC "java.lang.System" "exit" ($t.method (list $t.int) #.None (list)) false) - $i.NULL)) - -(def: (io//current-time []) - Nullary - (|>> ($i.INVOKESTATIC "java.lang.System" "currentTimeMillis" ($t.method (list) (#.Some $t.long) (list)) false) - ($i.wrap #$.Long))) - -## [[Atoms]] -(def: atom-class Text "java.util.concurrent.atomic.AtomicReference") -(def: (atom//new initI) - Unary - (|>> ($i.NEW atom-class) - $i.DUP - initI - ($i.INVOKESPECIAL atom-class "" ($t.method (list $Object) #.None (list)) false))) - -(def: (atom//read atomI) - Unary - (|>> atomI - ($i.CHECKCAST atom-class) - ($i.INVOKEVIRTUAL atom-class "get" ($t.method (list) (#.Some $Object) (list)) false))) - -(def: (atom//compare-and-swap [atomI oldI newI]) - Trinary - (|>> atomI - ($i.CHECKCAST atom-class) - oldI - newI - ($i.INVOKEVIRTUAL atom-class "compareAndSet" ($t.method (list $Object $Object) (#.Some $t.boolean) (list)) false) - ($i.wrap #$.Boolean))) - -## [[Box]] -(def: empty-boxI - $.Inst - (|>> ($i.int 1) ($i.ANEWARRAY ($t.binary-name "java.lang.Object")))) - -(def: check-boxI - $.Inst - ($i.CHECKCAST ($t.descriptor $Object-Array))) - -(def: (box//new initI) - Unary - (|>> empty-boxI - $i.DUP ($i.int 0) initI $i.AASTORE)) - -(def: (box//read boxI) - Unary - (|>> boxI check-boxI - ($i.int 0) $i.AALOAD)) - -(def: (box//write [valueI boxI]) - Binary - (|>> boxI check-boxI - ($i.int 0) valueI $i.AASTORE - unitI)) - -## [[Processes]] -(def: (process//concurrency-level []) - Nullary - (|>> ($i.INVOKESTATIC "java.lang.Runtime" "getRuntime" ($t.method (list) (#.Some ($t.class "java.lang.Runtime" (list))) (list)) false) - ($i.INVOKEVIRTUAL "java.lang.Runtime" "availableProcessors" ($t.method (list) (#.Some $t.int) (list)) false) - lux-intI)) - -(def: (process//future procedureI) - Unary - (|>> procedureI ($i.CHECKCAST hostL.function-class) - ($i.INVOKESTATIC hostL.runtime-class "future" - ($t.method (list $Function) (#.Some $Object) (list)) false))) - -(def: (process//schedule [millisecondsI procedureI]) - Binary - (|>> millisecondsI ($i.unwrap #$.Long) - procedureI ($i.CHECKCAST hostL.function-class) - ($i.INVOKESTATIC hostL.runtime-class "schedule" - ($t.method (list $t.long $Function) (#.Some $Object) (list)) false))) - -## [Bundles] -(def: lux-procs - Bundle - (|> (dict.new text.Hash) - (install "noop" (unary lux//noop)) - (install "is" (binary lux//is)) - (install "try" (unary lux//try)) - (install "if" (trinary lux//if)) - (install "loop" lux//loop) - (install "recur" lux//recur) - )) - -(def: bit-procs - Bundle - (<| (prefix "bit") - (|> (dict.new text.Hash) - (install "count" (unary bit//count)) - (install "and" (binary bit//and)) - (install "or" (binary bit//or)) - (install "xor" (binary bit//xor)) - (install "shift-left" (binary bit//shift-left)) - (install "unsigned-shift-right" (binary bit//unsigned-shift-right)) - (install "shift-right" (binary bit//shift-right)) - ))) - -(def: nat-procs - Bundle - (<| (prefix "nat") - (|> (dict.new text.Hash) - (install "+" (binary nat//add)) - (install "-" (binary nat//sub)) - (install "*" (binary nat//mul)) - (install "/" (binary nat//div)) - (install "%" (binary nat//rem)) - (install "=" (binary nat//eq)) - (install "<" (binary nat//lt)) - (install "min" (nullary nat//min)) - (install "max" (nullary nat//max)) - (install "to-int" (unary nat//to-int)) - (install "char" (unary nat//char))))) - -(def: int-procs - Bundle - (<| (prefix "int") - (|> (dict.new text.Hash) - (install "+" (binary int//add)) - (install "-" (binary int//sub)) - (install "*" (binary int//mul)) - (install "/" (binary int//div)) - (install "%" (binary int//rem)) - (install "=" (binary int//eq)) - (install "<" (binary int//lt)) - (install "min" (nullary int//min)) - (install "max" (nullary int//max)) - (install "to-nat" (unary int//to-nat)) - (install "to-frac" (unary int//to-frac))))) - -(def: deg-procs - Bundle - (<| (prefix "deg") - (|> (dict.new text.Hash) - (install "+" (binary deg//add)) - (install "-" (binary deg//sub)) - (install "*" (binary deg//mul)) - (install "/" (binary deg//div)) - (install "%" (binary deg//rem)) - (install "=" (binary deg//eq)) - (install "<" (binary deg//lt)) - (install "scale" (binary deg//scale)) - (install "reciprocal" (binary deg//reciprocal)) - (install "min" (nullary deg//min)) - (install "max" (nullary deg//max)) - (install "to-frac" (unary deg//to-frac))))) - -(def: frac-procs - Bundle - (<| (prefix "frac") - (|> (dict.new text.Hash) - (install "+" (binary frac//add)) - (install "-" (binary frac//sub)) - (install "*" (binary frac//mul)) - (install "/" (binary frac//div)) - (install "%" (binary frac//rem)) - (install "=" (binary frac//eq)) - (install "<" (binary frac//lt)) - (install "smallest" (nullary frac//smallest)) - (install "min" (nullary frac//min)) - (install "max" (nullary frac//max)) - (install "not-a-number" (nullary frac//not-a-number)) - (install "positive-infinity" (nullary frac//positive-infinity)) - (install "negative-infinity" (nullary frac//negative-infinity)) - (install "to-deg" (unary frac//to-deg)) - (install "to-int" (unary frac//to-int)) - (install "encode" (unary frac//encode)) - (install "decode" (unary frac//decode))))) - -(def: text-procs - Bundle - (<| (prefix "text") - (|> (dict.new text.Hash) - (install "=" (binary text//eq)) - (install "<" (binary text//lt)) - (install "concat" (binary text//concat)) - (install "index" (trinary text//index)) - (install "size" (unary text//size)) - (install "hash" (unary text//hash)) - (install "replace-once" (trinary text//replace-once)) - (install "replace-all" (trinary text//replace-all)) - (install "char" (binary text//char)) - (install "clip" (trinary text//clip)) - (install "upper" (unary text//upper)) - (install "lower" (unary text//lower)) - ))) - -(def: array-procs - Bundle - (<| (prefix "array") - (|> (dict.new text.Hash) - (install "new" (unary array//new)) - (install "get" (binary array//get)) - (install "put" (trinary array//put)) - (install "remove" (binary array//remove)) - (install "size" (unary array//size)) - ))) - -(def: math-procs - Bundle - (<| (prefix "math") - (|> (dict.new text.Hash) - (install "cos" (unary math//cos)) - (install "sin" (unary math//sin)) - (install "tan" (unary math//tan)) - (install "acos" (unary math//acos)) - (install "asin" (unary math//asin)) - (install "atan" (unary math//atan)) - (install "cosh" (unary math//cosh)) - (install "sinh" (unary math//sinh)) - (install "tanh" (unary math//tanh)) - (install "exp" (unary math//exp)) - (install "log" (unary math//log)) - (install "root2" (unary math//root2)) - (install "root3" (unary math//root3)) - (install "ceil" (unary math//ceil)) - (install "floor" (unary math//floor)) - (install "round" (unary math//round)) - (install "atan2" (binary math//atan2)) - (install "pow" (binary math//pow)) - ))) - -(def: io-procs - Bundle - (<| (prefix "io") - (|> (dict.new text.Hash) - (install "log" (unary io//log)) - (install "error" (unary io//error)) - (install "exit" (unary io//exit)) - (install "current-time" (nullary io//current-time))))) - -(def: atom-procs - Bundle - (<| (prefix "atom") - (|> (dict.new text.Hash) - (install "new" (unary atom//new)) - (install "read" (unary atom//read)) - (install "compare-and-swap" (trinary atom//compare-and-swap))))) - -(def: box-procs - Bundle - (<| (prefix "box") - (|> (dict.new text.Hash) - (install "new" (unary box//new)) - (install "read" (unary box//read)) - (install "write" (binary box//write))))) - -(def: process-procs - Bundle - (<| (prefix "process") - (|> (dict.new text.Hash) - (install "concurrency-level" (nullary process//concurrency-level)) - (install "future" (unary process//future)) - (install "schedule" (binary process//schedule)) - ))) - -(def: #export procedures - Bundle - (<| (prefix "lux") - (|> (dict.new text.Hash) - (dict.merge lux-procs) - (dict.merge bit-procs) - (dict.merge nat-procs) - (dict.merge int-procs) - (dict.merge deg-procs) - (dict.merge frac-procs) - (dict.merge text-procs) - (dict.merge array-procs) - (dict.merge math-procs) - (dict.merge io-procs) - (dict.merge atom-procs) - (dict.merge box-procs) - (dict.merge process-procs) - ))) diff --git a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux deleted file mode 100644 index f737e81fc..000000000 --- a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux +++ /dev/null @@ -1,761 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["p" parser "parser/" Monad] - ["ex" exception #+ exception:]) - (data [product] - ["e" error] - [text "text/" Eq] - (text format - ["l" lexer]) - (coll [list "list/" Functor] - [dict #+ Dict])) - [macro "macro/" Monad] - (macro [code] - ["s" syntax #+ syntax:]) - [host]) - (luxc ["&" lang] - (lang [".L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - ["la" analysis] - (extension (analysis ["&." host])) - ["ls" synthesis])) - ["@" //common]) - -(exception: #export Invalid-Syntax-For-JVM-Type) -(exception: #export Invalid-Syntax-For-Argument-Generation) - -(do-template [ ] - [(def: - $.Inst - )] - - [L2S (|>> $i.L2I $i.I2S)] - [L2B (|>> $i.L2I $i.I2B)] - [L2C (|>> $i.L2I $i.I2C)] - ) - -(do-template [ ] - [(def: ( inputI) - @.Unary - (if (is $i.NOP ) - (|>> inputI - ($i.unwrap ) - ($i.wrap )) - (|>> inputI - ($i.unwrap ) - - ($i.wrap ))))] - - [convert//double-to-float #$.Double $i.D2F #$.Float] - [convert//double-to-int #$.Double $i.D2I #$.Int] - [convert//double-to-long #$.Double $i.D2L #$.Long] - [convert//float-to-double #$.Float $i.F2D #$.Double] - [convert//float-to-int #$.Float $i.F2I #$.Int] - [convert//float-to-long #$.Float $i.F2L #$.Long] - [convert//int-to-byte #$.Int $i.I2B #$.Byte] - [convert//int-to-char #$.Int $i.I2C #$.Char] - [convert//int-to-double #$.Int $i.I2D #$.Double] - [convert//int-to-float #$.Int $i.I2F #$.Float] - [convert//int-to-long #$.Int $i.I2L #$.Long] - [convert//int-to-short #$.Int $i.I2S #$.Short] - [convert//long-to-double #$.Long $i.L2D #$.Double] - [convert//long-to-float #$.Long $i.L2F #$.Float] - [convert//long-to-int #$.Long $i.L2I #$.Int] - [convert//long-to-short #$.Long L2S #$.Short] - [convert//long-to-byte #$.Long L2B #$.Byte] - [convert//long-to-char #$.Long L2C #$.Char] - [convert//char-to-byte #$.Char $i.I2B #$.Byte] - [convert//char-to-short #$.Char $i.I2S #$.Short] - [convert//char-to-int #$.Char $i.NOP #$.Int] - [convert//char-to-long #$.Char $i.I2L #$.Long] - [convert//byte-to-long #$.Byte $i.I2L #$.Long] - [convert//short-to-long #$.Short $i.I2L #$.Long] - ) - -(def: conversion-procs - @.Bundle - (<| (@.prefix "convert") - (|> (dict.new text.Hash) - (@.install "double-to-float" (@.unary convert//double-to-float)) - (@.install "double-to-int" (@.unary convert//double-to-int)) - (@.install "double-to-long" (@.unary convert//double-to-long)) - (@.install "float-to-double" (@.unary convert//float-to-double)) - (@.install "float-to-int" (@.unary convert//float-to-int)) - (@.install "float-to-long" (@.unary convert//float-to-long)) - (@.install "int-to-byte" (@.unary convert//int-to-byte)) - (@.install "int-to-char" (@.unary convert//int-to-char)) - (@.install "int-to-double" (@.unary convert//int-to-double)) - (@.install "int-to-float" (@.unary convert//int-to-float)) - (@.install "int-to-long" (@.unary convert//int-to-long)) - (@.install "int-to-short" (@.unary convert//int-to-short)) - (@.install "long-to-double" (@.unary convert//long-to-double)) - (@.install "long-to-float" (@.unary convert//long-to-float)) - (@.install "long-to-int" (@.unary convert//long-to-int)) - (@.install "long-to-short" (@.unary convert//long-to-short)) - (@.install "long-to-byte" (@.unary convert//long-to-byte)) - (@.install "long-to-char" (@.unary convert//long-to-char)) - (@.install "char-to-byte" (@.unary convert//char-to-byte)) - (@.install "char-to-short" (@.unary convert//char-to-short)) - (@.install "char-to-int" (@.unary convert//char-to-int)) - (@.install "char-to-long" (@.unary convert//char-to-long)) - (@.install "byte-to-long" (@.unary convert//byte-to-long)) - (@.install "short-to-long" (@.unary convert//short-to-long)) - ))) - -(do-template [ ] - [(def: ( [xI yI]) - @.Binary - (|>> xI ($i.unwrap ) - yI ($i.unwrap ) - ($i.wrap )))] - - [int//+ $i.IADD #$.Int #$.Int #$.Int] - [int//- $i.ISUB #$.Int #$.Int #$.Int] - [int//* $i.IMUL #$.Int #$.Int #$.Int] - [int/// $i.IDIV #$.Int #$.Int #$.Int] - [int//% $i.IREM #$.Int #$.Int #$.Int] - [int//and $i.IAND #$.Int #$.Int #$.Int] - [int//or $i.IOR #$.Int #$.Int #$.Int] - [int//xor $i.IXOR #$.Int #$.Int #$.Int] - [int//shl $i.ISHL #$.Int #$.Int #$.Int] - [int//shr $i.ISHR #$.Int #$.Int #$.Int] - [int//ushr $i.IUSHR #$.Int #$.Int #$.Int] - - [long//+ $i.LADD #$.Long #$.Long #$.Long] - [long//- $i.LSUB #$.Long #$.Long #$.Long] - [long//* $i.LMUL #$.Long #$.Long #$.Long] - [long/// $i.LDIV #$.Long #$.Long #$.Long] - [long//% $i.LREM #$.Long #$.Long #$.Long] - [long//and $i.LAND #$.Long #$.Long #$.Long] - [long//or $i.LOR #$.Long #$.Long #$.Long] - [long//xor $i.LXOR #$.Long #$.Long #$.Long] - [long//shl $i.LSHL #$.Long #$.Int #$.Long] - [long//shr $i.LSHR #$.Long #$.Int #$.Long] - [long//ushr $i.LUSHR #$.Long #$.Int #$.Long] - - [float//+ $i.FADD #$.Float #$.Float #$.Float] - [float//- $i.FSUB #$.Float #$.Float #$.Float] - [float//* $i.FMUL #$.Float #$.Float #$.Float] - [float/// $i.FDIV #$.Float #$.Float #$.Float] - [float//% $i.FREM #$.Float #$.Float #$.Float] - - [double//+ $i.DADD #$.Double #$.Double #$.Double] - [double//- $i.DSUB #$.Double #$.Double #$.Double] - [double//* $i.DMUL #$.Double #$.Double #$.Double] - [double/// $i.DDIV #$.Double #$.Double #$.Double] - [double//% $i.DREM #$.Double #$.Double #$.Double] - ) - -(do-template [ ] - [(def: ( [xI yI]) - @.Binary - (<| $i.with-label (function [@then]) - $i.with-label (function [@end]) - (|>> xI ($i.unwrap ) - yI ($i.unwrap ) - ( @then) - ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list))) - ($i.GOTO @end) - ($i.label @then) - ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list))) - ($i.label @end))))] - - [int//= $i.IF_ICMPEQ #$.Int #$.Int #$.Boolean] - [int//< $i.IF_ICMPLT #$.Int #$.Int #$.Boolean] - - [char//= $i.IF_ICMPEQ #$.Char #$.Char #$.Boolean] - [char//< $i.IF_ICMPLT #$.Char #$.Char #$.Boolean] - ) - -(do-template [ ] - [(def: ( [xI yI]) - @.Binary - (<| $i.with-label (function [@then]) - $i.with-label (function [@end]) - (|>> xI ($i.unwrap ) - yI ($i.unwrap ) - - ($i.int ) - ($i.IF_ICMPEQ @then) - ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list))) - ($i.GOTO @end) - ($i.label @then) - ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list))) - ($i.label @end))))] - - [long//= $i.LCMP 0 #$.Long #$.Long #$.Boolean] - [long//< $i.LCMP -1 #$.Long #$.Long #$.Boolean] - - [float//= $i.FCMPG 0 #$.Float #$.Float #$.Boolean] - [float//< $i.FCMPG -1 #$.Float #$.Float #$.Boolean] - - [double//= $i.DCMPG 0 #$.Double #$.Double #$.Boolean] - [double//< $i.DCMPG -1 #$.Double #$.Double #$.Boolean] - ) - -(def: int-procs - @.Bundle - (<| (@.prefix "int") - (|> (dict.new text.Hash) - (@.install "+" (@.binary int//+)) - (@.install "-" (@.binary int//-)) - (@.install "*" (@.binary int//*)) - (@.install "/" (@.binary int///)) - (@.install "%" (@.binary int//%)) - (@.install "=" (@.binary int//=)) - (@.install "<" (@.binary int//<)) - (@.install "and" (@.binary int//and)) - (@.install "or" (@.binary int//or)) - (@.install "xor" (@.binary int//xor)) - (@.install "shl" (@.binary int//shl)) - (@.install "shr" (@.binary int//shr)) - (@.install "ushr" (@.binary int//ushr)) - ))) - -(def: long-procs - @.Bundle - (<| (@.prefix "long") - (|> (dict.new text.Hash) - (@.install "+" (@.binary long//+)) - (@.install "-" (@.binary long//-)) - (@.install "*" (@.binary long//*)) - (@.install "/" (@.binary long///)) - (@.install "%" (@.binary long//%)) - (@.install "=" (@.binary long//=)) - (@.install "<" (@.binary long//<)) - (@.install "and" (@.binary long//and)) - (@.install "or" (@.binary long//or)) - (@.install "xor" (@.binary long//xor)) - (@.install "shl" (@.binary long//shl)) - (@.install "shr" (@.binary long//shr)) - (@.install "ushr" (@.binary long//ushr)) - ))) - -(def: float-procs - @.Bundle - (<| (@.prefix "float") - (|> (dict.new text.Hash) - (@.install "+" (@.binary float//+)) - (@.install "-" (@.binary float//-)) - (@.install "*" (@.binary float//*)) - (@.install "/" (@.binary float///)) - (@.install "%" (@.binary float//%)) - (@.install "=" (@.binary float//=)) - (@.install "<" (@.binary float//<)) - ))) - -(def: double-procs - @.Bundle - (<| (@.prefix "double") - (|> (dict.new text.Hash) - (@.install "+" (@.binary double//+)) - (@.install "-" (@.binary double//-)) - (@.install "*" (@.binary double//*)) - (@.install "/" (@.binary double///)) - (@.install "%" (@.binary double//%)) - (@.install "=" (@.binary double//=)) - (@.install "<" (@.binary double//<)) - ))) - -(def: char-procs - @.Bundle - (<| (@.prefix "char") - (|> (dict.new text.Hash) - (@.install "=" (@.binary char//=)) - (@.install "<" (@.binary char//<)) - ))) - -(def: (array//length arrayI) - @.Unary - (|>> arrayI - $i.ARRAYLENGTH - $i.I2L - ($i.wrap #$.Long))) - -(def: (array//new proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Nat level)] [_ (#.Text class)] lengthS)) - (do macro.Monad - [lengthI (translate lengthS) - #let [arrayJT ($t.array level (case class - "boolean" $t.boolean - "byte" $t.byte - "short" $t.short - "int" $t.int - "long" $t.long - "float" $t.float - "double" $t.double - "char" $t.char - _ ($t.class class (list))))]] - (wrap (|>> lengthI - ($i.unwrap #$.Long) - $i.L2I - ($i.array arrayJT)))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (array//read proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] idxS arrayS)) - (do macro.Monad - [arrayI (translate arrayS) - idxI (translate idxS) - #let [loadI (case class - "boolean" (|>> $i.BALOAD ($i.wrap #$.Boolean)) - "byte" (|>> $i.BALOAD ($i.wrap #$.Byte)) - "short" (|>> $i.SALOAD ($i.wrap #$.Short)) - "int" (|>> $i.IALOAD ($i.wrap #$.Int)) - "long" (|>> $i.LALOAD ($i.wrap #$.Long)) - "float" (|>> $i.FALOAD ($i.wrap #$.Float)) - "double" (|>> $i.DALOAD ($i.wrap #$.Double)) - "char" (|>> $i.CALOAD ($i.wrap #$.Char)) - _ $i.AALOAD)]] - (wrap (|>> arrayI - idxI - ($i.unwrap #$.Long) - $i.L2I - loadI))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (array//write proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] idxS valueS arrayS)) - (do macro.Monad - [arrayI (translate arrayS) - idxI (translate idxS) - valueI (translate valueS) - #let [storeI (case class - "boolean" (|>> ($i.unwrap #$.Boolean) $i.BASTORE) - "byte" (|>> ($i.unwrap #$.Byte) $i.BASTORE) - "short" (|>> ($i.unwrap #$.Short) $i.SASTORE) - "int" (|>> ($i.unwrap #$.Int) $i.IASTORE) - "long" (|>> ($i.unwrap #$.Long) $i.LASTORE) - "float" (|>> ($i.unwrap #$.Float) $i.FASTORE) - "double" (|>> ($i.unwrap #$.Double) $i.DASTORE) - "char" (|>> ($i.unwrap #$.Char) $i.CASTORE) - _ $i.AASTORE)]] - (wrap (|>> arrayI - $i.DUP - idxI - ($i.unwrap #$.Long) - $i.L2I - valueI - storeI))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: array-procs - @.Bundle - (<| (@.prefix "array") - (|> (dict.new text.Hash) - (@.install "length" (@.unary array//length)) - (@.install "new" array//new) - (@.install "read" array//read) - (@.install "write" array//write) - ))) - -(def: (object//null _) - @.Nullary - $i.NULL) - -(def: (object//null? objectI) - @.Unary - (<| $i.with-label (function [@then]) - $i.with-label (function [@end]) - (|>> objectI - ($i.IFNULL @then) - ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list))) - ($i.GOTO @end) - ($i.label @then) - ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list))) - ($i.label @end)))) - -(def: (object//synchronized [monitorI exprI]) - @.Binary - (|>> monitorI - $i.DUP - $i.MONITORENTER - exprI - $i.SWAP - $i.MONITOREXIT)) - -(def: (object//throw exceptionI) - @.Unary - (|>> exceptionI - $i.ATHROW)) - -(def: (object//class proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)])) - (do macro.Monad - [] - (wrap (|>> ($i.string class) - ($i.INVOKESTATIC "java.lang.Class" "forName" - ($t.method (list ($t.class "java.lang.String" (list))) - (#.Some ($t.class "java.lang.Class" (list))) - (list)) - false)))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (object//instance? proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] objectS)) - (do macro.Monad - [objectI (translate objectS)] - (wrap (|>> objectI - ($i.INSTANCEOF class) - ($i.wrap #$.Boolean)))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: object-procs - @.Bundle - (<| (@.prefix "object") - (|> (dict.new text.Hash) - (@.install "null" (@.nullary object//null)) - (@.install "null?" (@.unary object//null?)) - (@.install "synchronized" (@.binary object//synchronized)) - (@.install "throw" (@.unary object//throw)) - (@.install "class" object//class) - (@.install "instance?" object//instance?) - ))) - -(def: primitives - (Dict Text $.Primitive) - (|> (list ["boolean" #$.Boolean] - ["byte" #$.Byte] - ["short" #$.Short] - ["int" #$.Int] - ["long" #$.Long] - ["float" #$.Float] - ["double" #$.Double] - ["char" #$.Char]) - (dict.from-list text.Hash))) - -(def: (static//get proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)])) - (do macro.Monad - [] - (case (dict.get unboxed primitives) - (#.Some primitive) - (let [primitive (case unboxed - "boolean" #$.Boolean - "byte" #$.Byte - "short" #$.Short - "int" #$.Int - "long" #$.Long - "float" #$.Float - "double" #$.Double - "char" #$.Char - _ (undefined))] - (wrap (|>> ($i.GETSTATIC class field (#$.Primitive primitive)) - ($i.wrap primitive)))) - - #.None - (wrap ($i.GETSTATIC class field ($t.class unboxed (list)))))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (static//put proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS)) - (do macro.Monad - [valueI (translate valueS)] - (case (dict.get unboxed primitives) - (#.Some primitive) - (let [primitive (case unboxed - "boolean" #$.Boolean - "byte" #$.Byte - "short" #$.Short - "int" #$.Int - "long" #$.Long - "float" #$.Float - "double" #$.Double - "char" #$.Char - _ (undefined))] - (wrap (|>> valueI - ($i.unwrap primitive) - ($i.PUTSTATIC class field (#$.Primitive primitive)) - ($i.string hostL.unit)))) - - #.None - (wrap (|>> valueI - ($i.CHECKCAST class) - ($i.PUTSTATIC class field ($t.class class (list))) - ($i.string hostL.unit))))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (virtual//get proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] objectS)) - (do macro.Monad - [objectI (translate objectS)] - (case (dict.get unboxed primitives) - (#.Some primitive) - (let [primitive (case unboxed - "boolean" #$.Boolean - "byte" #$.Byte - "short" #$.Short - "int" #$.Int - "long" #$.Long - "float" #$.Float - "double" #$.Double - "char" #$.Char - _ (undefined))] - (wrap (|>> objectI - ($i.CHECKCAST class) - ($i.GETFIELD class field (#$.Primitive primitive)) - ($i.wrap primitive)))) - - #.None - (wrap (|>> objectI - ($i.CHECKCAST class) - ($i.GETFIELD class field ($t.class unboxed (list))))))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (virtual//put proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS objectS)) - (do macro.Monad - [valueI (translate valueS) - objectI (translate objectS)] - (case (dict.get unboxed primitives) - (#.Some primitive) - (let [primitive (case unboxed - "boolean" #$.Boolean - "byte" #$.Byte - "short" #$.Short - "int" #$.Int - "long" #$.Long - "float" #$.Float - "double" #$.Double - "char" #$.Char - _ (undefined))] - (wrap (|>> objectI - ($i.CHECKCAST class) - $i.DUP - valueI - ($i.unwrap primitive) - ($i.PUTFIELD class field (#$.Primitive primitive))))) - - #.None - (wrap (|>> objectI - ($i.CHECKCAST class) - $i.DUP - valueI - ($i.CHECKCAST unboxed) - ($i.PUTFIELD class field ($t.class unboxed (list))))))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: base-type - (l.Lexer $.Type) - ($_ p.either - (p.after (l.this "boolean") (parser/wrap $t.boolean)) - (p.after (l.this "byte") (parser/wrap $t.byte)) - (p.after (l.this "short") (parser/wrap $t.short)) - (p.after (l.this "int") (parser/wrap $t.int)) - (p.after (l.this "long") (parser/wrap $t.long)) - (p.after (l.this "float") (parser/wrap $t.float)) - (p.after (l.this "double") (parser/wrap $t.double)) - (p.after (l.this "char") (parser/wrap $t.char)) - (parser/map (function [name] - ($t.class name (list))) - (l.many (l.none-of "["))) - )) - -(def: java-type - (l.Lexer $.Type) - (do p.Monad - [raw base-type - nesting (p.some (l.this "[]"))] - (wrap ($t.array (list.size nesting) raw)))) - -(def: (translate-type argD) - (-> Text (Meta $.Type)) - (case (l.run argD java-type) - (#e.Error error) - (&.throw Invalid-Syntax-For-JVM-Type argD) - - (#e.Success type) - (macro/wrap type))) - -(def: (prepare-input inputT inputI) - (-> $.Type $.Inst $.Inst) - (case inputT - (#$.Primitive primitive) - (|>> inputI ($i.unwrap primitive)) - - (#$.Generic generic) - (case generic - (^or (#$.Var _) (#$.Wildcard _)) - (|>> inputI ($i.CHECKCAST "java.lang.Object")) - - (#$.Class class-name _) - (|>> inputI ($i.CHECKCAST class-name))) - - _ - (|>> inputI ($i.CHECKCAST ($t.descriptor inputT))))) - -(def: (translate-args translate argsS) - (-> (-> ls.Synthesis (Meta $.Inst)) (List ls.Synthesis) - (Meta (List [$.Type $.Inst]))) - (case argsS - #.Nil - (macro/wrap #.Nil) - - (^ (list& [_ (#.Tuple (list [_ (#.Text argD)] argS))] tail)) - (do macro.Monad - [argT (translate-type argD) - argI (:: @ map (prepare-input argT) (translate argS)) - =tail (translate-args translate tail)] - (wrap (list& [argT argI] =tail))) - - _ - (&.throw Invalid-Syntax-For-Argument-Generation ""))) - -(def: (method-return-type description) - (-> Text (Meta (Maybe $.Type))) - (case description - "void" - (macro/wrap #.None) - - _ - (macro/map (|>> #.Some) (translate-type description)))) - -(def: (prepare-return returnT returnI) - (-> (Maybe $.Type) $.Inst $.Inst) - (case returnT - #.None - (|>> returnI - ($i.string hostL.unit)) - - (#.Some type) - (case type - (#$.Primitive primitive) - (|>> returnI ($i.wrap primitive)) - - _ - returnI))) - -(def: (invoke//static proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list& [_ (#.Text class)] [_ (#.Text method)] - [_ (#.Text unboxed)] argsS)) - (do macro.Monad - [argsTI (translate-args translate argsS) - returnT (method-return-type unboxed) - #let [callI (|>> ($i.fuse (list/map product.right argsTI)) - ($i.INVOKESTATIC class method - ($t.method (list/map product.left argsTI) returnT (list)) - false))]] - (wrap (prepare-return returnT callI))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(do-template [ ] - [(def: ( proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list& [_ (#.Text class)] [_ (#.Text method)] - [_ (#.Text unboxed)] objectS argsS)) - (do macro.Monad - [objectI (translate objectS) - argsTI (translate-args translate argsS) - returnT (method-return-type unboxed) - #let [callI (|>> objectI - ($i.CHECKCAST class) - ($i.fuse (list/map product.right argsTI)) - ( class method - ($t.method (list/map product.left argsTI) returnT (list)) - ))]] - (wrap (prepare-return returnT callI))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))] - - [invoke//virtual $i.INVOKEVIRTUAL false] - [invoke//special $i.INVOKESPECIAL false] - [invoke//interface $i.INVOKEINTERFACE true] - ) - -(def: (invoke//constructor proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list& [_ (#.Text class)] argsS)) - (do macro.Monad - [argsTI (translate-args translate argsS)] - (wrap (|>> ($i.NEW class) - $i.DUP - ($i.fuse (list/map product.right argsTI)) - ($i.INVOKESPECIAL class "" - ($t.method (list/map product.left argsTI) #.None (list)) - false)))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: member-procs - @.Bundle - (<| (@.prefix "member") - (|> (dict.new text.Hash) - (dict.merge (<| (@.prefix "static") - (|> (dict.new text.Hash) - (@.install "get" static//get) - (@.install "put" static//put)))) - (dict.merge (<| (@.prefix "virtual") - (|> (dict.new text.Hash) - (@.install "get" virtual//get) - (@.install "put" virtual//put)))) - (dict.merge (<| (@.prefix "invoke") - (|> (dict.new text.Hash) - (@.install "static" invoke//static) - (@.install "virtual" invoke//virtual) - (@.install "special" invoke//special) - (@.install "interface" invoke//interface) - (@.install "constructor" invoke//constructor)))) - ))) - -(def: #export procedures - @.Bundle - (<| (@.prefix "jvm") - (|> (dict.new text.Hash) - (dict.merge conversion-procs) - (dict.merge int-procs) - (dict.merge long-procs) - (dict.merge float-procs) - (dict.merge double-procs) - (dict.merge char-procs) - (dict.merge array-procs) - (dict.merge object-procs) - (dict.merge member-procs) - ))) diff --git a/new-luxc/source/luxc/lang/translation/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/reference.jvm.lux deleted file mode 100644 index bfb5856d4..000000000 --- a/new-luxc/source/luxc/lang/translation/reference.jvm.lux +++ /dev/null @@ -1,49 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text "text/" Hash] - text/format) - [macro "macro/" Monad]) - (luxc ["&" lang] - (lang [".L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$i" inst])) - ["ls" synthesis] - [".L" variable #+ Variable] - (translation [".T" common])))) - -(do-template [ ] - [(def: #export ( idx) - (-> Nat Text) - (|> idx nat-to-int %i (format )))] - - [captured "c"] - [partial "p"] - ) - -(def: #export (translate-captured variable) - (-> Variable (Meta $.Inst)) - (do macro.Monad - [this-module macro.current-module-name - function-class hostL.context - #let [function-class (format (text.replace-all "/" "." this-module) "." function-class)]] - (wrap (|>> ($i.ALOAD +0) - ($i.GETFIELD function-class - (|> variable i/inc (i/* -1) int-to-nat captured) - commonT.$Object))))) - -(def: #export (translate-local variable) - (-> Variable (Meta $.Inst)) - (macro/wrap ($i.ALOAD (int-to-nat variable)))) - -(def: #export (translate-variable variable) - (-> Variable (Meta $.Inst)) - (if (variableL.captured? variable) - (translate-captured variable) - (translate-local variable))) - -(def: #export (translate-definition [def-module def-name]) - (-> Ident (Meta $.Inst)) - (let [bytecode-name (format def-module "/" (&.normalize-name def-name) (%n (text/hash def-name)))] - (macro/wrap ($i.GETSTATIC bytecode-name commonT.value-field commonT.$Object)))) diff --git a/new-luxc/source/luxc/lang/translation/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/runtime.jvm.lux deleted file mode 100644 index df494a904..000000000 --- a/new-luxc/source/luxc/lang/translation/runtime.jvm.lux +++ /dev/null @@ -1,603 +0,0 @@ -(.module: - lux - (lux (control monad) - (data text/format - (coll [list "list/" Functor])) - [math] - [macro]) - (luxc ["&" lang] - (lang [".L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - ["la" analysis] - ["ls" synthesis] - (translation [".T" common])))) - -(def: $Object $.Type ($t.class "java.lang.Object" (list))) -(def: $Object-Array $.Type ($t.array +1 $Object)) -(def: $String $.Type ($t.class "java.lang.String" (list))) -(def: #export $Stack $.Type ($t.array +1 $Object)) -(def: #export $Tuple $.Type $Object-Array) -(def: #export $Variant $.Type $Object-Array) -(def: #export $Tag $.Type $t.int) -(def: #export $Flag $.Type $Object) -(def: #export $Datum $.Type $Object) -(def: #export $Function $.Type ($t.class hostL.function-class (list))) -(def: $Throwable $.Type ($t.class "java.lang.Throwable" (list))) - -(def: #export logI - $.Inst - (let [outI ($i.GETSTATIC "java.lang.System" "out" ($t.class "java.io.PrintStream" (list))) - printI (function [method] ($i.INVOKEVIRTUAL "java.io.PrintStream" method ($t.method (list $Object) #.None (list)) false))] - (|>> outI ($i.string "LOG: ") (printI "print") - outI $i.SWAP (printI "println")))) - -(def: variant-method - $.Method - ($t.method (list $t.int $Object $Object) (#.Some $Object-Array) (list))) - -(def: #export variantI - $.Inst - ($i.INVOKESTATIC hostL.runtime-class "variant_make" variant-method false)) - -(def: #export leftI - $.Inst - (|>> ($i.int 0) - $i.NULL - $i.DUP2_X1 - $i.POP2 - variantI)) - -(def: #export rightI - $.Inst - (|>> ($i.int 1) - ($i.string "") - $i.DUP2_X1 - $i.POP2 - variantI)) - -(def: #export someI $.Inst rightI) - -(def: #export noneI - $.Inst - (|>> ($i.int 0) - $i.NULL - ($i.string hostL.unit) - variantI)) - -(def: (try-methodI unsafeI) - (-> $.Inst $.Inst) - (<| $i.with-label (function [@from]) - $i.with-label (function [@to]) - $i.with-label (function [@handler]) - (|>> ($i.try @from @to @handler "java.lang.Exception") - ($i.label @from) - unsafeI - someI - $i.ARETURN - ($i.label @to) - ($i.label @handler) - noneI - $i.ARETURN))) - -(def: #export string-concatI - $.Inst - ($i.INVOKEVIRTUAL "java.lang.String" "concat" ($t.method (list $String) (#.Some $String) (list)) false)) - -(def: #export partials-field Text "partials") -(def: #export apply-method Text "apply") -(def: #export num-apply-variants Nat +8) - -(def: #export (apply-signature arity) - (-> ls.Arity $.Method) - ($t.method (list.repeat arity $Object) (#.Some $Object) (list))) - -(def: adt-methods - $.Def - (let [store-tagI (|>> $i.DUP ($i.int 0) ($i.ILOAD +0) ($i.wrap #$.Int) $i.AASTORE) - store-flagI (|>> $i.DUP ($i.int 1) ($i.ALOAD +1) $i.AASTORE) - store-valueI (|>> $i.DUP ($i.int 2) ($i.ALOAD +2) $i.AASTORE) - force-textMT ($t.method (list $Object) (#.Some $String) (list))] - (|>> ($d.method #$.Public $.staticM "force_text" force-textMT - (<| $i.with-label (function [@is-null]) - $i.with-label (function [@normal-object]) - $i.with-label (function [@array-loop]) - $i.with-label (function [@within-bounds]) - $i.with-label (function [@is-first]) - $i.with-label (function [@elem-end]) - $i.with-label (function [@fold-end]) - (let [on-normal-objectI (|>> ($i.ALOAD +0) - ($i.INVOKEVIRTUAL "java.lang.Object" "toString" ($t.method (list) (#.Some $String) (list)) false)) - on-null-objectI ($i.string "NULL") - arrayI (|>> ($i.ALOAD +0) - ($i.CHECKCAST ($t.descriptor $Object-Array))) - recurseI ($i.INVOKESTATIC hostL.runtime-class "force_text" force-textMT false) - force-elemI (|>> $i.DUP arrayI $i.SWAP $i.AALOAD recurseI) - swap2 (|>> $i.DUP2_X2 ## X,Y => Y,X,Y - $i.POP2 ## Y,X,Y => Y,X - ) - add-spacingI (|>> ($i.string ", ") $i.SWAP string-concatI) - merge-with-totalI (|>> $i.DUP_X2 $i.POP ## TSIP => TPSI - swap2 ## TPSI => SITP - string-concatI ## SITP => SIT - $i.DUP_X2 $i.POP ## SIT => TSI - ) - foldI (|>> $i.DUP ## TSI => TSII - ($i.IFEQ @is-first) ## TSI - force-elemI add-spacingI merge-with-totalI ($i.GOTO @elem-end) - ($i.label @is-first) ## TSI - force-elemI merge-with-totalI - ($i.label @elem-end) ## TSI - ) - inc-idxI (|>> ($i.int 1) $i.IADD) - on-array-objectI (|>> ($i.string "[") ## T - arrayI $i.ARRAYLENGTH ## TS - ($i.int 0) ## TSI - ($i.label @array-loop) ## TSI - $i.DUP2 - ($i.IF_ICMPGT @within-bounds) ## TSI - $i.POP2 ($i.string "]") string-concatI ($i.GOTO @fold-end) - ($i.label @within-bounds) - foldI inc-idxI ($i.GOTO @array-loop) - ($i.label @fold-end))]) - (|>> ($i.ALOAD +0) - ($i.IFNULL @is-null) - ($i.ALOAD +0) - ($i.INSTANCEOF ($t.descriptor $Object-Array)) - ($i.IFEQ @normal-object) - on-array-objectI $i.ARETURN - ($i.label @normal-object) on-normal-objectI $i.ARETURN - ($i.label @is-null) on-null-objectI $i.ARETURN))) - ($d.method #$.Public $.staticM "variant_make" - ($t.method (list $t.int $Object $Object) - (#.Some $Variant) - (list)) - (|>> ($i.int 3) - ($i.array $Object) - store-tagI - store-flagI - store-valueI - $i.ARETURN))))) - -(def: #export force-textI - $.Inst - ($i.INVOKESTATIC hostL.runtime-class "force_text" ($t.method (list $Object) (#.Some $String) (list)) false)) - -(def: nat-methods - $.Def - (let [compare-nat-method ($t.method (list $t.long $t.long) (#.Some $t.int) (list)) - less-thanI (function [@where] (|>> ($i.INVOKESTATIC hostL.runtime-class "compare_nat" compare-nat-method false) ($i.IFLT @where))) - $BigInteger ($t.class "java.math.BigInteger" (list)) - upcast-method ($t.method (list $t.long) (#.Some $BigInteger) (list)) - div-method ($t.method (list $t.long $t.long) (#.Some $t.long) (list)) - upcastI ($i.INVOKESTATIC hostL.runtime-class "_toUnsignedBigInteger" upcast-method false) - downcastI ($i.INVOKEVIRTUAL "java.math.BigInteger" "longValue" ($t.method (list) (#.Some $t.long) (list)) false)] - (|>> ($d.method #$.Public $.staticM "_toUnsignedBigInteger" upcast-method - (let [upcastI ($i.INVOKESTATIC "java.math.BigInteger" "valueOf" upcast-method false) - discernI (function [@where] (|>> ($i.LLOAD +0) ($i.long 0) $i.LCMP ($i.IFGE @where))) - prepare-upperI (|>> ($i.LLOAD +0) ($i.int 32) $i.LUSHR - upcastI - ($i.int 32) ($i.INVOKEVIRTUAL "java.math.BigInteger" "shiftLeft" ($t.method (list $t.int) (#.Some $BigInteger) (list)) false)) - prepare-lowerI (|>> ($i.LLOAD +0) ($i.int 32) $i.LSHL - ($i.int 32) $i.LUSHR - upcastI)] - (<| $i.with-label (function [@simple]) - (|>> (discernI @simple) - ## else - prepare-upperI - prepare-lowerI - ($i.INVOKEVIRTUAL "java.math.BigInteger" "add" ($t.method (list $BigInteger) (#.Some $BigInteger) (list)) false) - $i.ARETURN - ## then - ($i.label @simple) - ($i.LLOAD +0) - upcastI - $i.ARETURN)))) - ($d.method #$.Public $.staticM "compare_nat" compare-nat-method - (let [shiftI (|>> ($i.GETSTATIC "java.lang.Long" "MIN_VALUE" $t.long) $i.LADD)] - (|>> ($i.LLOAD +0) shiftI - ($i.LLOAD +2) shiftI - $i.LCMP - $i.IRETURN))) - ($d.method #$.Public $.staticM "div_nat" div-method - (let [is-param-largeI (function [@where] (|>> ($i.LLOAD +2) ($i.long 0) $i.LCMP ($i.IFLT @where))) - is-subject-smallI (function [@where] (|>> ($i.LLOAD +0) ($i.long 0) $i.LCMP ($i.IFGT @where))) - small-division (|>> ($i.LLOAD +0) ($i.LLOAD +2) $i.LDIV $i.LRETURN) - big-divisionI ($i.INVOKEVIRTUAL "java.math.BigInteger" "divide" ($t.method (list $BigInteger) (#.Some $BigInteger) (list)) false)] - (<| $i.with-label (function [@is-zero]) - $i.with-label (function [@param-is-large]) - $i.with-label (function [@subject-is-small]) - (|>> (is-param-largeI @param-is-large) - ## Param is not too large - (is-subject-smallI @subject-is-small) - ## Param is small, but subject is large - ($i.LLOAD +0) upcastI - ($i.LLOAD +2) upcastI - big-divisionI downcastI $i.LRETURN - ## Both param and subject are small, - ## and can thus be divided normally. - ($i.label @subject-is-small) - small-division - ## Param is too large. Cannot simply divide. - ## Depending on the result of the - ## comparison, a result will be determined. - ($i.label @param-is-large) - ($i.LLOAD +0) ($i.LLOAD +2) (less-thanI @is-zero) - ## Greater-than or equals - ($i.long 1) $i.LRETURN - ## Less than - ($i.label @is-zero) - ($i.long 0) $i.LRETURN)))) - ($d.method #$.Public $.staticM "rem_nat" div-method - (let [is-subject-largeI (function [@where] (|>> ($i.LLOAD +0) ($i.long 0) $i.LCMP ($i.IFLE @where))) - is-param-largeI (function [@where] (|>> ($i.LLOAD +2) ($i.long 0) $i.LCMP ($i.IFLE @where))) - small-remainderI (|>> ($i.LLOAD +0) ($i.LLOAD +2) $i.LREM $i.LRETURN) - big-remainderI ($i.INVOKEVIRTUAL "java.math.BigInteger" "remainder" ($t.method (list $BigInteger) (#.Some $BigInteger) (list)) false)] - (<| $i.with-label (function [@large-number]) - $i.with-label (function [@subject-is-smaller-than-param]) - (|>> (is-subject-largeI @large-number) - (is-param-largeI @large-number) - small-remainderI - - ($i.label @large-number) - ($i.LLOAD +0) ($i.LLOAD +2) (less-thanI @subject-is-smaller-than-param) - - ($i.LLOAD +0) upcastI - ($i.LLOAD +2) upcastI - big-remainderI downcastI $i.LRETURN - - ($i.label @subject-is-smaller-than-param) - ($i.LLOAD +0) - $i.LRETURN)))) - ))) - -(def: frac-shiftI $.Inst ($i.double (math.pow 32.0 2.0))) - -(def: frac-methods - $.Def - (|>> ($d.method #$.Public $.staticM "decode_frac" ($t.method (list $String) (#.Some $Object-Array) (list)) - (try-methodI - (|>> ($i.ALOAD +0) - ($i.INVOKESTATIC "java.lang.Double" "parseDouble" ($t.method (list $String) (#.Some $t.double) (list)) false) - ($i.wrap #$.Double)))) - ($d.method #$.Public $.staticM "frac_to_deg" ($t.method (list $t.double) (#.Some $t.long) (list)) - (let [swap2 (|>> $i.DUP2_X2 $i.POP2) - drop-excessI (|>> ($i.double 1.0) $i.DREM) - shiftI (|>> frac-shiftI $i.DMUL)] - (|>> ($i.DLOAD +0) - ## Get upper half - drop-excessI - shiftI - ## Make a copy, so the lower half can be extracted - $i.DUP2 - ## Get lower half - drop-excessI - shiftI - ## Turn it into a deg - $i.D2L - ## Turn the upper half into deg too - swap2 - $i.D2L - ## Combine both pieces - $i.LADD - ## FINISH - $i.LRETURN - ))) - )) - -(def: deg-bits Nat +64) -(def: deg-method $.Method ($t.method (list $t.long $t.long) (#.Some $t.long) (list))) -(def: clz-method $.Method ($t.method (list $t.long) (#.Some $t.int) (list))) - -(def: deg-methods - $.Def - (let [## "And" mask corresponding to -1 (FFFF...), on the low 32 bits. - low-half (|>> ($i.int -1) $i.I2L $i.LAND) - high-half (|>> ($i.int 32) $i.LUSHR)] - (|>> ($d.method #$.Public $.staticM "mul_deg" deg-method - ## Based on: http://stackoverflow.com/a/31629280/6823464 - (let [shift-downI (|>> ($i.int 32) $i.LUSHR) - low-leftI (|>> ($i.LLOAD +0) low-half) - high-leftI (|>> ($i.LLOAD +0) high-half) - low-rightI (|>> ($i.LLOAD +2) low-half) - high-rightI (|>> ($i.LLOAD +2) high-half) - bottomI (|>> low-leftI low-rightI $i.LMUL) - middleLI (|>> high-leftI low-rightI $i.LMUL) - middleRI (|>> low-leftI high-rightI $i.LMUL) - middleI (|>> middleLI middleRI $i.LADD) - topI (|>> high-leftI high-rightI $i.LMUL)] - (|>> bottomI shift-downI - middleI $i.LADD shift-downI - topI $i.LADD - $i.LRETURN))) - ($d.method #$.Public $.staticM "count_leading_zeros" clz-method - (let [when-zeroI (function [@where] (|>> ($i.long 0) $i.LCMP ($i.IFEQ @where))) - shift-rightI (function [amount] (|>> ($i.int amount) $i.LUSHR)) - decI (|>> ($i.int 1) $i.ISUB)] - (<| $i.with-label (function [@start]) - $i.with-label (function [@done]) - (|>> ($i.int 64) - ($i.label @start) - ($i.LLOAD +0) (when-zeroI @done) - ($i.LLOAD +0) (shift-rightI 1) ($i.LSTORE +0) - decI - ($i.GOTO @start) - ($i.label @done) - $i.IRETURN)))) - ($d.method #$.Public $.staticM "div_deg" deg-method - (<| $i.with-label (function [@same]) - (let [subjectI ($i.LLOAD +0) - paramI ($i.LLOAD +2) - equal?I (function [@where] (|>> $i.LCMP ($i.IFEQ @where))) - count-leading-zerosI ($i.INVOKESTATIC hostL.runtime-class "count_leading_zeros" clz-method false) - calc-max-shiftI (|>> subjectI count-leading-zerosI - paramI count-leading-zerosI - ($i.INVOKESTATIC "java.lang.Math" "min" ($t.method (list $t.int $t.int) (#.Some $t.int) (list)) false) - ($i.ISTORE +4)) - shiftI (|>> ($i.ILOAD +4) $i.LSHL) - imprecise-divisionI (|>> subjectI shiftI - paramI shiftI high-half - $i.LDIV) - scale-downI (|>> ($i.int 32) $i.LSHL)] - (|>> subjectI paramI - (equal?I @same) - ## Based on: http://stackoverflow.com/a/8510587/6823464 - ## Shifting the operands as much as possible can help - ## avoid some loss of precision later. - calc-max-shiftI - imprecise-divisionI - scale-downI - $i.LRETURN - ($i.label @same) - ($i.long -1) ## ~= 1.0 Degrees - $i.LRETURN)))) - ($d.method #$.Public $.staticM "deg_to_frac" ($t.method (list $t.long) (#.Some $t.double) (list)) - (let [highI (|>> ($i.LLOAD +0) high-half $i.L2D) - lowI (|>> ($i.LLOAD +0) low-half $i.L2D) - scaleI (|>> frac-shiftI $i.DDIV)] - (|>> highI scaleI - lowI scaleI scaleI - $i.DADD - $i.DRETURN))) - ))) - -(def: text-methods - $.Def - (|>> ($d.method #$.Public $.staticM "text_clip" ($t.method (list $String $t.int $t.int) (#.Some $Variant) (list)) - (try-methodI - (|>> ($i.ALOAD +0) - ($i.ILOAD +1) - ($i.ILOAD +2) - ($i.INVOKEVIRTUAL "java.lang.String" "substring" ($t.method (list $t.int $t.int) (#.Some $String) (list)) false)))) - ($d.method #$.Public $.staticM "text_char" ($t.method (list $String $t.int) (#.Some $Variant) (list)) - (try-methodI - (|>> ($i.ALOAD +0) - ($i.ILOAD +1) - ($i.INVOKEVIRTUAL "java.lang.String" "codePointAt" ($t.method (list $t.int) (#.Some $t.int) (list)) false) - $i.I2L - ($i.wrap #$.Long)))) - )) - -(def: pm-methods - $.Def - (let [tuple-sizeI (|>> ($i.ALOAD +0) $i.ARRAYLENGTH) - tuple-elemI (|>> ($i.ALOAD +0) ($i.ILOAD +1) $i.AALOAD) - expected-last-sizeI (|>> ($i.ILOAD +1) ($i.int 1) $i.IADD) - tuple-tailI (|>> ($i.ALOAD +0) tuple-sizeI ($i.int 1) $i.ISUB $i.AALOAD ($i.CHECKCAST ($t.descriptor $Tuple)))] - (|>> ($d.method #$.Public $.staticM "pm_fail" ($t.method (list) #.None (list)) - (|>> ($i.NEW "java.lang.IllegalStateException") - $i.DUP - ($i.string "Invalid expression for pattern-matching.") - ($i.INVOKESPECIAL "java.lang.IllegalStateException" "" ($t.method (list $String) #.None (list)) false) - $i.ATHROW)) - ($d.method #$.Public $.staticM "apply_fail" ($t.method (list) #.None (list)) - (|>> ($i.NEW "java.lang.IllegalStateException") - $i.DUP - ($i.string "Error while applying function.") - ($i.INVOKESPECIAL "java.lang.IllegalStateException" "" ($t.method (list $String) #.None (list)) false) - $i.ATHROW)) - ($d.method #$.Public $.staticM "pm_push" ($t.method (list $Stack $Object) (#.Some $Stack) (list)) - (|>> ($i.int 2) - ($i.ANEWARRAY "java.lang.Object") - $i.DUP - ($i.int 0) - ($i.ALOAD +0) - $i.AASTORE - $i.DUP - ($i.int 1) - ($i.ALOAD +1) - $i.AASTORE - $i.ARETURN)) - ($d.method #$.Public $.staticM "pm_pop" ($t.method (list $Stack) (#.Some $Stack) (list)) - (|>> ($i.ALOAD +0) - ($i.int 0) - $i.AALOAD - ($i.CHECKCAST ($t.descriptor $Stack)) - $i.ARETURN)) - ($d.method #$.Public $.staticM "pm_peek" ($t.method (list $Stack) (#.Some $Object) (list)) - (|>> ($i.ALOAD +0) - ($i.int 1) - $i.AALOAD - $i.ARETURN)) - ($d.method #$.Public $.staticM "pm_variant" ($t.method (list $Variant $Tag $Flag) (#.Some $Object) (list)) - (<| $i.with-label (function [@begin]) - $i.with-label (function [@just-return]) - $i.with-label (function [@then]) - $i.with-label (function [@further]) - $i.with-label (function [@shorten]) - $i.with-label (function [@wrong]) - (let [variant-partI (: (-> Nat $.Inst) - (function [idx] - (|>> ($i.int (nat-to-int idx)) $i.AALOAD))) - tagI (: $.Inst - (|>> (variant-partI +0) ($i.unwrap #$.Int))) - flagI (variant-partI +1) - datumI (variant-partI +2) - shortenI (|>> ($i.ALOAD +0) tagI ## Get tag - ($i.ILOAD +1) $i.ISUB ## Shorten tag - ($i.ALOAD +0) flagI ## Get flag - ($i.ALOAD +0) datumI ## Get value - variantI ## Build sum - $i.ARETURN) - update-tagI (|>> $i.ISUB ($i.ISTORE +1)) - update-variantI (|>> ($i.ALOAD +0) datumI ($i.CHECKCAST ($t.descriptor $Variant)) ($i.ASTORE +0)) - failureI (|>> $i.NULL $i.ARETURN) - return-datumI (|>> ($i.ALOAD +0) datumI $i.ARETURN)]) - (|>> ($i.label @begin) - ($i.ILOAD +1) ## tag - ($i.ALOAD +0) tagI ## tag, sumT - $i.DUP2 ($i.IF_ICMPEQ @then) - $i.DUP2 ($i.IF_ICMPGT @further) - $i.DUP2 ($i.IF_ICMPLT @shorten) - ## $i.POP2 - failureI - ($i.label @then) ## tag, sumT - ($i.ALOAD +2) ## tag, sumT, wants-last? - ($i.ALOAD +0) flagI ## tag, sumT, wants-last?, is-last? - ($i.IF_ACMPEQ @just-return) ## tag, sumT - ($i.label @further) ## tag, sumT - ($i.ALOAD +0) flagI ## tag, sumT, last? - ($i.IFNULL @wrong) ## tag, sumT - update-tagI - update-variantI - ($i.GOTO @begin) - ($i.label @just-return) ## tag, sumT - ## $i.POP2 - return-datumI - ($i.label @shorten) ## tag, sumT - ($i.ALOAD +2) ($i.IFNULL @wrong) - ## $i.POP2 - shortenI - ($i.label @wrong) ## tag, sumT - ## $i.POP2 - failureI))) - ($d.method #$.Public $.staticM "pm_left" ($t.method (list $Tuple $t.int) (#.Some $Object) (list)) - (<| $i.with-label (function [@begin]) - $i.with-label (function [@not-recursive]) - (let [updated-idxI (|>> $i.SWAP $i.ISUB)]) - (|>> ($i.label @begin) - tuple-sizeI - expected-last-sizeI - $i.DUP2 ($i.IF_ICMPGT @not-recursive) - ## Recursive - updated-idxI ($i.ISTORE +1) - tuple-tailI ($i.ASTORE +0) - ($i.GOTO @begin) - ($i.label @not-recursive) - ## $i.POP2 - tuple-elemI - $i.ARETURN))) - ($d.method #$.Public $.staticM "pm_right" ($t.method (list $Tuple $t.int) (#.Some $Object) (list)) - (<| $i.with-label (function [@begin]) - $i.with-label (function [@tail]) - $i.with-label (function [@slice]) - (let [updated-idxI (|>> ($i.ILOAD +1) ($i.int 1) $i.IADD tuple-sizeI $i.ISUB) - sliceI (|>> ($i.ALOAD +0) ($i.ILOAD +1) tuple-sizeI - ($i.INVOKESTATIC "java.util.Arrays" "copyOfRange" ($t.method (list $Object-Array $t.int $t.int) (#.Some $Object-Array) (list)) false))]) - (|>> ($i.label @begin) - tuple-sizeI - expected-last-sizeI - $i.DUP2 ($i.IF_ICMPEQ @tail) - ($i.IF_ICMPGT @slice) - ## Must recurse - tuple-tailI ($i.ASTORE +0) - updated-idxI ($i.ISTORE +1) - ($i.GOTO @begin) - ($i.label @slice) - sliceI - $i.ARETURN - ($i.label @tail) - ## $i.POP2 - tuple-elemI - $i.ARETURN))) - ))) - -(def: io-methods - $.Def - (let [string-writerI (|>> ($i.NEW "java.io.StringWriter") - $i.DUP - ($i.INVOKESPECIAL "java.io.StringWriter" "" ($t.method (list) #.None (list)) false)) - print-writerI (|>> ($i.NEW "java.io.PrintWriter") - $i.SWAP - $i.DUP2 - $i.POP - $i.SWAP - ($i.boolean true) - ($i.INVOKESPECIAL "java.io.PrintWriter" "" ($t.method (list ($t.class "java.io.Writer" (list)) $t.boolean) #.None (list)) false) - )] - (|>> ($d.method #$.Public $.staticM "try" ($t.method (list $Function) (#.Some $Variant) (list)) - (<| $i.with-label (function [@from]) - $i.with-label (function [@to]) - $i.with-label (function [@handler]) - (|>> ($i.try @from @to @handler "java.lang.Throwable") - ($i.label @from) - ($i.ALOAD +0) - $i.NULL - ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature +1) false) - rightI - $i.ARETURN - ($i.label @to) - ($i.label @handler) - string-writerI ## TW - $i.DUP2 ## TWTW - print-writerI ## TWTP - ($i.INVOKEVIRTUAL "java.lang.Throwable" "printStackTrace" ($t.method (list ($t.class "java.io.PrintWriter" (list))) #.None (list)) false) ## TW - ($i.INVOKEVIRTUAL "java.io.StringWriter" "toString" ($t.method (list) (#.Some $String) (list)) false) ## TS - $i.SWAP $i.POP leftI - $i.ARETURN))) - ))) - -(def: translate-runtime - (Meta commonT.Bytecode) - (do macro.Monad - [_ (wrap []) - #let [bytecode ($d.class #$.V1_6 #$.Public $.finalC hostL.runtime-class (list) ["java.lang.Object" (list)] (list) - (|>> adt-methods - nat-methods - frac-methods - deg-methods - text-methods - pm-methods - io-methods))] - _ (commonT.store-class hostL.runtime-class bytecode)] - (wrap bytecode))) - -(def: translate-function - (Meta commonT.Bytecode) - (do macro.Monad - [_ (wrap []) - #let [applyI (|> (list.n/range +2 num-apply-variants) - (list/map (function [arity] - ($d.method #$.Public $.noneM apply-method (apply-signature arity) - (let [preI (|> (list.n/range +0 (n/dec arity)) - (list/map $i.ALOAD) - $i.fuse)] - (|>> preI - ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature (n/dec arity)) false) - ($i.CHECKCAST hostL.function-class) - ($i.ALOAD arity) - ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature +1) false) - $i.ARETURN))))) - (list& ($d.abstract-method #$.Public $.noneM apply-method (apply-signature +1))) - $d.fuse) - bytecode ($d.abstract #$.V1_6 #$.Public $.noneC hostL.function-class (list) ["java.lang.Object" (list)] (list) - (|>> ($d.field #$.Public $.finalF partials-field $t.int) - ($d.method #$.Public $.noneM "" ($t.method (list $t.int) #.None (list)) - (|>> ($i.ALOAD +0) - ($i.INVOKESPECIAL "java.lang.Object" "" ($t.method (list) #.None (list)) false) - ($i.ALOAD +0) - ($i.ILOAD +1) - ($i.PUTFIELD hostL.function-class partials-field $t.int) - $i.RETURN)) - applyI))] - _ (commonT.store-class hostL.function-class bytecode)] - (wrap bytecode))) - -(def: #export translate - (Meta [commonT.Bytecode commonT.Bytecode]) - (do macro.Monad - [runtime-bc translate-runtime - function-bc translate-function] - (wrap [runtime-bc function-bc]))) diff --git a/new-luxc/source/luxc/lang/translation/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/statement.jvm.lux deleted file mode 100644 index b2e302e1b..000000000 --- a/new-luxc/source/luxc/lang/translation/statement.jvm.lux +++ /dev/null @@ -1,159 +0,0 @@ -(.module: - lux - (lux (control monad - ["ex" exception #+ exception:]) - (data ["e" error] - [maybe] - [text "text/" Monoid Hash] - text/format - (coll [list "list/" Functor Fold])) - [macro] - [host]) - (luxc ["&" lang] - ["&." io] - (lang (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - ["&." scope] - ["&." module] - [".L" host] - (translation [".T" eval] - [".T" common] - [".T" runtime])))) - -(exception: #export Invalid-Definition-Value) -(exception: #export Cannot-Evaluate-Definition) - -(host.import java/lang/reflect/Field - (get [#? Object] #try #? Object)) - -(host.import (java/lang/Class c) - (getField [String] #try Field)) - -(def: #export (translate-def def-name valueT valueI metaI metaV) - (-> Text Type $.Inst $.Inst Code (Meta Unit)) - (do macro.Monad - [current-module macro.current-module-name - #let [def-ident [current-module def-name]]] - (case (macro.get-symbol-ann (ident-for #.alias) metaV) - (#.Some real-def) - (do @ - [[realT realA realV] (macro.find-def real-def) - _ (&module.define def-ident [realT metaV realV])] - (wrap [])) - - _ - (do @ - [#let [normal-name (format (&.normalize-name def-name) (%n (text/hash def-name))) - bytecode-name (format current-module "/" normal-name) - class-name (format (text.replace-all "/" "." current-module) "." normal-name) - bytecode ($d.class #$.V1_6 - #$.Public $.finalC - bytecode-name - (list) ["java.lang.Object" (list)] - (list) - (|>> ($d.field #$.Public ($.++F $.finalF $.staticF) commonT.value-field commonT.$Object) - ($d.method #$.Public $.staticM "" ($t.method (list) #.None (list)) - (|>> valueI - ($i.PUTSTATIC bytecode-name commonT.value-field commonT.$Object) - $i.RETURN))))] - _ (commonT.store-class class-name bytecode) - class (commonT.load-class class-name) - valueV (: (Meta Top) - (case (do e.Monad - [field (Class::getField [commonT.value-field] class)] - (Field::get [#.None] field)) - (#e.Success #.None) - (&.throw Invalid-Definition-Value (%ident def-ident)) - - (#e.Success (#.Some valueV)) - (wrap valueV) - - (#e.Error error) - (&.throw Cannot-Evaluate-Definition - (format "Definition: " (%ident def-ident) "\n" - "Error:\n" - error)))) - _ (&module.define def-ident [valueT metaV valueV]) - _ (if (macro.type? metaV) - (case (macro.declared-tags metaV) - #.Nil - (wrap []) - - tags - (&module.declare-tags tags (macro.export? metaV) (:! Type valueV))) - (wrap [])) - #let [_ (log! (format "DEF " (%ident def-ident)))]] - (commonT.record-artifact (format bytecode-name ".class") bytecode))))) - -(def: #export (translate-program programI) - (-> $.Inst (Meta Unit)) - (let [nilI runtimeT.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 "java.lang.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 - runtimeT.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 - ($i.ASTORE +0))) - run-ioI (|>> ($i.CHECKCAST hostL.function-class) - $i.NULL - ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.apply-signature +1) false)) - main-type ($t.method (list ($t.array +1 ($t.class "java.lang.String" (list)))) - #.None - (list))] - (do macro.Monad - [current-module macro.current-module-name - #let [normal-name "_" - bytecode-name (format current-module "/" normal-name) - class-name (text.replace-all "/" "." bytecode-name) - bytecode ($d.class #$.V1_6 - #$.Public $.finalC - bytecode-name - (list) ["java.lang.Object" (list)] - (list) - (|>> ($d.method #$.Public $.staticM "main" main-type - (|>> prepare-input-listI - programI - run-ioI - $i.POP - $i.RETURN))))] - #let [_ (log! (format "PROGRAM " current-module))] - _ (commonT.store-class class-name bytecode)] - (commonT.record-artifact (format bytecode-name ".class") bytecode)))) diff --git a/new-luxc/source/luxc/lang/translation/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/structure.jvm.lux deleted file mode 100644 index f7cdb524f..000000000 --- a/new-luxc/source/luxc/lang/translation/structure.jvm.lux +++ /dev/null @@ -1,61 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data text/format - (coll [list])) - [macro] - [host #+ do-to]) - (luxc ["&" lang] - (lang [".L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - ["la" analysis] - ["ls" synthesis] - (translation [".T" common])))) - -(exception: #export Not-A-Tuple) - -(def: $Object $.Type ($t.class "java.lang.Object" (list))) - -(def: #export (translate-tuple translate members) - (-> (-> ls.Synthesis (Meta $.Inst)) (List ls.Synthesis) (Meta $.Inst)) - (do macro.Monad - [#let [size (list.size members)] - _ (&.assert Not-A-Tuple (%code (` [(~+ members)])) - (n/>= +2 size)) - membersI (|> members - list.enumerate - (monad.map @ (function [[idx member]] - (do @ - [memberI (translate member)] - (wrap (|>> $i.DUP - ($i.int (nat-to-int idx)) - memberI - $i.AASTORE))))) - (:: @ map $i.fuse))] - (wrap (|>> ($i.int (nat-to-int size)) - ($i.array $Object) - membersI)))) - -(def: (flagI tail?) - (-> Bool $.Inst) - (if tail? - ($i.string "") - $i.NULL)) - -(def: #export (translate-variant translate tag tail? member) - (-> (-> ls.Synthesis (Meta $.Inst)) Nat Bool ls.Synthesis (Meta $.Inst)) - (do macro.Monad - [memberI (translate member)] - (wrap (|>> ($i.int (nat-to-int tag)) - (flagI tail?) - memberI - ($i.INVOKESTATIC hostL.runtime-class - "variant_make" - ($t.method (list $t.int $Object $Object) - (#.Some ($t.array +1 $Object)) - (list)) - false))))) diff --git a/new-luxc/source/luxc/repl.lux b/new-luxc/source/luxc/repl.lux index 717462f22..16f4de5db 100644 --- a/new-luxc/source/luxc/repl.lux +++ b/new-luxc/source/luxc/repl.lux @@ -34,7 +34,7 @@ [".L" host] [".L" translation] [".L" eval] - (translation [".T" runtime]) + (translation (jvm [".T" runtime])) [".L" extension] (extension [".E" analysis] [".E" synthesis] -- cgit v1.2.3