aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/generator
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/generator.lux181
-rw-r--r--new-luxc/source/luxc/generator/common.jvm.lux56
-rw-r--r--new-luxc/source/luxc/generator/eval.jvm.lux11
-rw-r--r--new-luxc/source/luxc/generator/expr.jvm.lux6
-rw-r--r--new-luxc/source/luxc/generator/host/jvm.lux4
-rw-r--r--new-luxc/source/luxc/generator/reference.jvm.lux12
-rw-r--r--new-luxc/source/luxc/generator/runtime.jvm.lux8
-rw-r--r--new-luxc/source/luxc/generator/statement.jvm.lux97
8 files changed, 254 insertions, 121 deletions
diff --git a/new-luxc/source/luxc/generator.lux b/new-luxc/source/luxc/generator.lux
index 107b2f3f9..f64ca333e 100644
--- a/new-luxc/source/luxc/generator.lux
+++ b/new-luxc/source/luxc/generator.lux
@@ -1,52 +1,83 @@
(;module:
lux
- (lux (control monad)
- (concurrency ["A" atom]
- ["P" promise])
+ (lux (control [monad #+ do])
+ (concurrency ["T" task])
(data ["e" error]
- [text "T/" Hash<Text>]
+ [text "text/" Hash<Text>]
text/format
- (coll ["D" dict]
- [array]))
- [meta #+ Monad<Meta>]
+ (coll [dict]))
+ [meta]
[host]
- [io])
+ [io]
+ (world [file #+ File]))
(luxc ["&" base]
["&;" io]
["&;" module]
["&;" parser]
["&;" host]
- (compiler ["&&;" runtime]
- ["&&;" statement]
- ["&&;" common])
+ ["&;" analyser]
+ ["&;" analyser/common]
+ ["&;" synthesizer]
+ ["&;" eval]
+ (generator ["&&;" runtime]
+ ["&&;" statement]
+ ["&&;" common]
+ ["&&;" expr]
+ ["&&;" eval])
))
-(def: (compile ast)
+(def: analyse
+ (&;Analyser)
+ (&analyser;analyser &eval;eval))
+
+(def: (generate code)
(-> Code (Meta Unit))
- (case ast
- (^ [_ (#;Form (list [_ (#;Symbol ["" "_lux_def"])]
+ (case code
+ (^ [_ (#;Form (list [_ (#;Text "lux def")]
[_ (#;Symbol ["" def-name])]
- def-value
- def-meta))])
- (&&statement;compile-def def-name def-value def-meta)
-
- (^ [_ (#;Form (list [_ (#;Symbol ["" "_lux_program"])]
- [_ (#;Symbol ["" prog-args])]
- prog-body))])
- (&&statement;compile-program prog-args prog-body)
+ valueC
+ metaC))])
+ (do meta;Monad<Meta>
+ [[_ metaA] (&;with-scope
+ (&;with-expected-type Code
+ (analyse metaC)))
+ metaI (&&expr;generate (&synthesizer;synthesize metaA))
+ metaV (&&eval;eval metaI)
+ [_ valueT valueA] (&;with-scope
+ (if (meta;type? (:! Code metaV))
+ (&;with-expected-type Type
+ (do @
+ [valueA (analyse valueC)]
+ (wrap [Type valueA])))
+ (&analyser/common;with-unknown-type
+ (analyse valueC))))
+ valueI (&&expr;generate (&synthesizer;synthesize valueA))
+ _ (&;with-scope
+ (&&statement;generate-def def-name valueT valueI metaI (:! Code metaV)))]
+ (wrap []))
+
+ (^ [_ (#;Form (list [_ (#;Text "lux program")]
+ [_ (#;Symbol ["" program-args])]
+ programC))])
+ (do meta;Monad<Meta>
+ [[_ programA] (&;with-scope
+ (&;with-expected-type (type (io;IO Unit))
+ (analyse programC)))
+ programI (&&expr;generate (&synthesizer;synthesize programA))]
+ (&&statement;generate-program program-args programI))
_
- (&;fail (format "Unrecognized statement: " (%code ast)))))
+ (&;fail (format "Unrecognized statement: " (%code code)))))
(def: (exhaust action)
(All [a] (-> (Meta a) (Meta Unit)))
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[result action]
(exhaust action)))
(def: (ensure-new-module! file-hash module-name)
(-> Nat Text (Meta Unit))
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[module-exists? (meta;module-exists? module-name)
_ (: (Meta Unit)
(if module-exists?
@@ -59,10 +90,10 @@
(def: (with-active-compilation [module-name file-name source-code] action)
(All [a] (-> [Text Text Text] (Meta a) (Meta a)))
- (do Monad<Meta>
- [_ (ensure-new-module! (T/hash source-code) module-name)
+ (do meta;Monad<Meta>
+ [_ (ensure-new-module! (text/hash source-code) module-name)
#let [init-cursor [file-name +0 +0]]
- output (&;with-source-code [init-cursor source-code]
+ output (&;with-source-code [init-cursor +0 source-code]
action)
_ (&module;flag-compiled! module-name)]
(wrap output)))
@@ -78,37 +109,35 @@
(#e;Success [(set@ #;source source' compiler)
output]))))
-(def: (compile-module source-dirs module-name compiler)
- (-> (List &;Path) Text Compiler (P;Promise (e;Error Compiler)))
- (do P;Monad<Promise>
- [?input (&io;read-module source-dirs module-name)]
- (case ?input
- (#e;Success [file-name file-content])
- (let [compilation (do Monad<Meta>
- [_ (with-active-compilation [module-name
- file-name
- file-content]
- (exhaust
- (do @
- [ast parse]
- (compile ast))))]
- (wrap [])
- ## (&module;generate-descriptor module-name)
- )]
- (case (meta;run' compiler compilation)
- (#e;Success [compiler module-descriptor])
- (do @
- [## _ (&io;write-module module-name module-descriptor)
- ]
- (wrap (#e;Success compiler)))
-
- (#e;Error error)
- (wrap (#e;Error error))))
-
+(def: (generate-module source-dirs module-name target-dir compiler)
+ (-> (List File) Text File Compiler (T;Task Compiler))
+ (do T;Monad<Task>
+ [_ (&io;prepare-module target-dir module-name)
+ [file-name file-content] (&io;read-module source-dirs module-name)]
+ (case (meta;run' compiler
+ (do meta;Monad<Meta>
+ [[artifacts _] (&&common;with-artifacts
+ (with-active-compilation [module-name
+ file-name
+ file-content]
+ (exhaust
+ (do @
+ [code parse]
+ (generate code)))))]
+ (wrap artifacts)
+ ## (&module;generate-descriptor module-name)
+ ))
+ (#e;Success [compiler artifacts ## module-descriptor
+ ])
+ (do @
+ [## _ (&io;write-module module-name module-descriptor)
+ _ (monad;map @ (function [[class-name class-bytecode]]
+ (&io;write-file target-dir class-name class-bytecode))
+ (dict;entries artifacts))]
+ (wrap compiler))
+
(#e;Error error)
- (wrap (#e;Error error)))))
-
-(host;import org.objectweb.asm.MethodVisitor)
+ (T;fail error))))
(def: init-cursor Cursor ["" +0 +0])
@@ -127,7 +156,7 @@
(def: #export (init-compiler host)
(-> &&common;Host Compiler)
{#;info init-info
- #;source [init-cursor ""]
+ #;source [init-cursor +0 ""]
#;cursor init-cursor
#;modules (list)
#;scopes (list)
@@ -137,23 +166,21 @@
#;scope-type-vars (list)
#;host (:! Void host)})
-(def: (or-crash! action)
- (All [a] (-> (P;Promise (e;Error a)) (P;Promise a)))
- (do P;Monad<Promise>
- [?output action]
- (case ?output
- (#e;Error error)
- (error! error)
-
- (#e;Success output)
- (wrap output))))
-
-(def: #export (compile-program program target sources)
- (-> &;Path &;Path (List &;Path) (P;Promise Unit))
- (do P;Monad<Promise>
- [#let [compiler (init-compiler (&host;init-host []))]
- compiler (or-crash! (&&runtime;compile-runtime compiler))
- compiler (or-crash! (compile-module sources prelude compiler))
- compiler (or-crash! (compile-module sources program compiler))
+(def: #export (generate-program program target sources)
+ (-> Text File (List File) (T;Task Unit))
+ (do T;Monad<Task>
+ [compiler (|> (case (&&runtime;generate (init-compiler (io;run &host;init-host)))
+ (#e;Error error)
+ (T;fail error)
+
+ (#e;Success [compiler [runtime-bc function-bc]])
+ (do @
+ [_ (&io;prepare-target target)
+ _ (&io;write-file target &&runtime;runtime-class runtime-bc)
+ _ (&io;write-file target &&runtime;function-class function-bc)]
+ (wrap compiler)))
+ (: (T;Task Compiler))
+ (:: @ map (generate-module sources prelude target)) (:: @ join)
+ (:: @ map (generate-module sources program target)) (:: @ join))
#let [_ (log! "Compilation complete!")]]
(wrap [])))
diff --git a/new-luxc/source/luxc/generator/common.jvm.lux b/new-luxc/source/luxc/generator/common.jvm.lux
index 150e68e4f..4439ae51d 100644
--- a/new-luxc/source/luxc/generator/common.jvm.lux
+++ b/new-luxc/source/luxc/generator/common.jvm.lux
@@ -4,8 +4,11 @@
[io]
(concurrency ["A" atom])
(data ["e" error]
- (coll ["d" dict]))
- [host])
+ [text]
+ text/format
+ (coll [dict #+ Dict]))
+ [host]
+ (world [blob #+ Blob]))
(luxc (generator (host ["$" jvm]
(jvm ["$t" type]
["$d" def]
@@ -23,16 +26,52 @@
(type: #export Bytecode (host;type (Array byte)))
-(type: #export Class-Store (A;Atom (d;Dict Text Bytecode)))
+(type: #export Class-Store (A;Atom (Dict Text Bytecode)))
+
+(type: #export Artifacts (Dict Text Blob))
(type: #export Host
{#loader ClassLoader
#store Class-Store
- #function-class (Maybe Text)})
+ #function-class (Maybe Text)
+ #artifacts Artifacts})
(exception: Unknown-Class)
(exception: Class-Already-Stored)
(exception: No-Function-Being-Compiled)
+(exception: Cannot-Overwrite-Artifact)
+
+(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<Text>))
+ (:! 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))
@@ -40,9 +79,9 @@
(let [store (|> (get@ #;host compiler)
(:! Host)
(get@ #store))]
- (if (d;contains? name (|> store A;get io;run))
+ (if (dict;contains? name (|> store A;get io;run))
(ex;throw Class-Already-Stored name)
- (#e;Success [compiler (io;run (A;update (d;put name byte-code) store))])
+ (#e;Success [compiler (io;run (A;update (dict;put name byte-code) store))])
))))
(def: #export (load-class name)
@@ -50,7 +89,7 @@
(;function [compiler]
(let [host (:! Host (get@ #;host compiler))
store (|> host (get@ #store) A;get io;run)]
- (if (d;contains? name store)
+ (if (dict;contains? name store)
(#e;Success [compiler (ClassLoader.loadClass [name] (get@ #loader host))])
(ex;throw Unknown-Class name)))))
@@ -87,3 +126,6 @@
(#e;Success [compiler function-class])))))
(def: #export bytecode-version Int Opcodes.V1_6)
+
+(def: #export value-field Text "_value")
+(def: #export $Object $;Type ($t;class "java.lang.Object" (list)))
diff --git a/new-luxc/source/luxc/generator/eval.jvm.lux b/new-luxc/source/luxc/generator/eval.jvm.lux
index 20c02af4c..842199a47 100644
--- a/new-luxc/source/luxc/generator/eval.jvm.lux
+++ b/new-luxc/source/luxc/generator/eval.jvm.lux
@@ -56,9 +56,6 @@
(visitMethod [int String String String (Array String)] MethodVisitor)
(toByteArray [] (Array byte)))
-(def: eval-field Text "_value")
-(def: $Object $;Type ($t;class "java.lang.Object" (list)))
-
(def: #export (eval valueI)
(-> $;Inst (Meta Top))
(do Monad<Meta>
@@ -70,17 +67,17 @@
(host;null)
"java/lang/Object"
(host;null)]))
- ($d;field #$;Public $;staticF
- eval-field $Object)
+ ($d;field #$;Public ($_ $;++F $;finalF $;staticF)
+ &common;value-field &common;$Object)
($d;method #$;Public ($_ $;++M $;staticM $;strictM)
"<clinit>"
($t;method (list) #;None (list))
(|>. valueI
- ($i;PUTSTATIC class-name eval-field $Object)
+ ($i;PUTSTATIC class-name &common;value-field &common;$Object)
$i;RETURN)))
bytecode (ClassWriter.toByteArray [] (do-to writer (ClassWriter.visitEnd [])))]
_ (&common;store-class class-name bytecode)
class (&common;load-class class-name)]
(wrap (|> class
- (Class.getField [eval-field])
+ (Class.getField [&common;value-field])
(Field.get (host;null))))))
diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux
index c7fdcf2af..116c29fb5 100644
--- a/new-luxc/source/luxc/generator/expr.jvm.lux
+++ b/new-luxc/source/luxc/generator/expr.jvm.lux
@@ -44,6 +44,9 @@
(&reference;generate-captured var)
(&reference;generate-variable var))
+ (#ls;Definition definition)
+ (&reference;generate-definition definition)
+
(#ls;Function arity env body)
(&function;generate-function generate env arity body)
@@ -54,7 +57,8 @@
(&procedure;generate-procedure generate name args)
_
- (meta;fail "Unrecognized synthesis.")))
+ (meta;fail "Unrecognized synthesis.")
+ ))
## (def: #export (eval type code)
## (-> Type Code (Meta Top))
diff --git a/new-luxc/source/luxc/generator/host/jvm.lux b/new-luxc/source/luxc/generator/host/jvm.lux
index c985efc9a..24d4a9ea9 100644
--- a/new-luxc/source/luxc/generator/host/jvm.lux
+++ b/new-luxc/source/luxc/generator/host/jvm.lux
@@ -109,8 +109,8 @@
(` (def: (~' #export) ((~ (code;local-symbol ++)) (~ g!_left) (~ g!_right))
(-> (~ g!type) (~ g!type) (~ g!type))
(~ (code;record (list/map (function [tag]
- [tag (` (and (get@ (~ tag) (~ g!_left))
- (get@ (~ tag) (~ g!_right))))])
+ [tag (` (or (get@ (~ tag) (~ g!_left))
+ (get@ (~ tag) (~ g!_right))))])
g!tags+)))))
g!options+))))
diff --git a/new-luxc/source/luxc/generator/reference.jvm.lux b/new-luxc/source/luxc/generator/reference.jvm.lux
index 063994bac..0e77b1819 100644
--- a/new-luxc/source/luxc/generator/reference.jvm.lux
+++ b/new-luxc/source/luxc/generator/reference.jvm.lux
@@ -3,15 +3,14 @@
(lux (control [monad #+ do])
(data text/format)
[meta "meta/" Monad<Meta>])
- (luxc (lang ["ls" synthesis])
+ (luxc ["&" base]
+ (lang ["ls" synthesis])
(generator [";G" common]
[";G" function]
(host ["$" jvm]
(jvm ["$t" type]
["$i" inst])))))
-(def: $Object $;Type ($t;class "java.lang.Object" (list)))
-
(def: #export (generate-captured variable)
(-> ls;Variable (Meta $;Inst))
(do meta;Monad<Meta>
@@ -19,8 +18,13 @@
(wrap (|>. ($i;ALOAD +0)
($i;GETFIELD function-class
(|> variable i.inc (i.* -1) int-to-nat functionG;captured)
- $Object)))))
+ commonG;$Object)))))
(def: #export (generate-variable variable)
(-> ls;Variable (Meta $;Inst))
(meta/wrap ($i;ALOAD (int-to-nat variable))))
+
+(def: #export (generate-definition [def-module def-name])
+ (-> Ident (Meta $;Inst))
+ (let [bytecode-name (format def-module "/" (&;normalize-name def-name))]
+ (meta/wrap ($i;GETSTATIC bytecode-name commonG;value-field commonG;$Object))))
diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux
index 32e792638..66dd43019 100644
--- a/new-luxc/source/luxc/generator/runtime.jvm.lux
+++ b/new-luxc/source/luxc/generator/runtime.jvm.lux
@@ -504,8 +504,8 @@
(wrap bytecode)))
(def: #export generate
- (Meta Unit)
+ (Meta [&common;Bytecode &common;Bytecode])
(do Monad<Meta>
- [_ generate-runtime
- _ generate-function]
- (wrap [])))
+ [runtime-bc generate-runtime
+ function-bc generate-function]
+ (wrap [runtime-bc function-bc])))
diff --git a/new-luxc/source/luxc/generator/statement.jvm.lux b/new-luxc/source/luxc/generator/statement.jvm.lux
index ed66f3ecb..830935dda 100644
--- a/new-luxc/source/luxc/generator/statement.jvm.lux
+++ b/new-luxc/source/luxc/generator/statement.jvm.lux
@@ -1,25 +1,84 @@
(;module:
lux
- (lux (control monad)
- [io #- run]
- (data [text "T/" Eq<Text>]
- text/format)
- [meta #+ Monad<Meta>])
+ (lux (control monad
+ ["ex" exception #+ exception:])
+ (concurrency ["T" task])
+ (data ["e" error]
+ [maybe]
+ [text "text/" Monoid<Text>]
+ text/format
+ (coll [list "list/" Functor<List> Fold<List>]))
+ [meta]
+ [host])
(luxc ["&" base]
- ["&;" module]
["&;" scope]
- (compiler ["&;" expr])))
+ ["&;" module]
+ ["&;" io]
+ (generator ["&;" expr]
+ ["&;" eval]
+ ["&;" common]
+ (host ["$" jvm]
+ (jvm ["$t" type]
+ ["$d" def]
+ ["$i" inst])))))
+
+(exception: #export Invalid-Definition-Value)
+
+(host;import java.lang.Object
+ (toString [] String))
+
+(host;import java.lang.reflect.Field
+ (get [#? Object] #try #? Object))
+
+(host;import (java.lang.Class c)
+ (getField [String] #try Field))
+
+(def: #export (generate-def def-name valueT valueI metaI metaV)
+ (-> Text Type $;Inst $;Inst Code (Meta Unit))
+ (do meta;Monad<Meta>
+ [current-module meta;current-module-name
+ #let [def-ident [current-module def-name]
+ normal-name (&;normalize-name def-name)
+ bytecode-name (format current-module "/" normal-name)
+ class-name (format 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) &common;value-field &common;$Object)
+ ($d;method #$;Public $;staticM "<clinit>" ($t;method (list) #;None (list))
+ (|>. valueI
+ ($i;PUTSTATIC bytecode-name &common;value-field &common;$Object)
+ $i;RETURN))))]
+ _ (&common;store-class class-name bytecode)
+ class (&common;load-class class-name)
+ valueV (: (Meta Top)
+ (case (do e;Monad<Error>
+ [field (Class.getField [&common;value-field] class)]
+ (Field.get [#;None] field))
+ (#e;Success #;None)
+ (&;throw Invalid-Definition-Value (format current-module ";" def-name))
+
+ (#e;Success (#;Some valueV))
+ (wrap valueV)
+
+ (#e;Error error)
+ (&;fail error)))
+ _ (&module;define [current-module def-name] [valueT metaV valueV])
+ _ (if (meta;type? metaV)
+ (case (meta;declared-tags metaV)
+ #;Nil
+ (wrap [])
-(def: #export (compile-def def-name def-value def-meta)
- (-> Text Code Code (Meta Unit))
- (do Monad<Meta>
- [=def-value (&expr;compile def-value)
- =def-meta (&expr;compile def-meta)]
- (undefined)))
+ tags
+ (&module;declare-tags tags (meta;export? metaV) (:! Type valueV)))
+ (wrap []))
+ #let [_ (log! (format "DEF " current-module ";" def-name))]]
+ (&common;record-artifact bytecode-name bytecode)))
-(def: #export (compile-program prog-args prog-body)
- (-> Text Code (Meta Unit))
- (do Monad<Meta>
- [=prog-body (&scope;with-local [prog-args (type (List Text))]
- (&expr;compile prog-body))]
- (undefined)))
+(def: #export (generate-program program-args programI)
+ (-> Text $;Inst (Meta Unit))
+ (do meta;Monad<Meta>
+ []
+ (&;fail "'lux program' is unimplemented.")))
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-02 19:18:40 +0000