aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/base.lux2
-rw-r--r--new-luxc/source/luxc/host.jvm.lux44
-rw-r--r--new-luxc/source/luxc/host/jvm/def.lux3
-rw-r--r--new-luxc/source/luxc/lang/analysis/procedure/common.lux2
-rw-r--r--new-luxc/source/luxc/lang/synthesis/case.lux22
-rw-r--r--new-luxc/source/luxc/lang/synthesis/expression.lux44
-rw-r--r--new-luxc/source/luxc/lang/translation/case.jvm.lux1
-rw-r--r--new-luxc/source/luxc/lang/translation/common.jvm.lux8
-rw-r--r--new-luxc/source/luxc/lang/translation/function.jvm.lux89
-rw-r--r--new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux27
-rw-r--r--new-luxc/source/luxc/lang/translation/reference.jvm.lux2
-rw-r--r--new-luxc/source/luxc/lang/variable.lux4
12 files changed, 178 insertions, 70 deletions
diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux
index 7418f8124..580f5593f 100644
--- a/new-luxc/source/luxc/base.lux
+++ b/new-luxc/source/luxc/base.lux
@@ -229,5 +229,5 @@
(loop [idx (n.dec (text;size name))
output ""]
(if (n.= underflow idx)
- (text;replace-all "/+" "$" output)
+ output
(recur (n.dec idx) (format (|> (text;nth idx name) maybe;assume normalize-char) output)))))
diff --git a/new-luxc/source/luxc/host.jvm.lux b/new-luxc/source/luxc/host.jvm.lux
index b2bf07d32..e8dc4e17a 100644
--- a/new-luxc/source/luxc/host.jvm.lux
+++ b/new-luxc/source/luxc/host.jvm.lux
@@ -1,6 +1,7 @@
(;module:
lux
(lux (control [monad #+ do]
+ ["ex" exception #+ exception:]
pipe)
(concurrency ["A" atom])
(data ["e" error]
@@ -12,7 +13,10 @@
[host #+ do-to object]
[io])
(luxc ["&" base]
- (lang (translation [";T" common]))))
+ (lang [";L" variable #+ Register]
+ (translation [";T" common]))))
+
+(host;import org.objectweb.asm.Label)
(host;import java.lang.reflect.AccessibleObject
(setAccessible [boolean] void))
@@ -85,14 +89,46 @@
{#commonT;loader (memory-class-loader store)
#commonT;store store
#commonT;artifacts (dict;new text;Hash<Text>)
- #commonT;context ["" +0]})))
+ #commonT;context ["" +0]
+ #commonT;anchor #;None})))
+
+(def: #export (with-anchor anchor expr)
+ (All [a] (-> [Label Register] (Meta a) (Meta a)))
+ (;function [compiler]
+ (let [old (:! commonT;Host (get@ #;host compiler))]
+ (case (expr (set@ #;host
+ (:! Void (set@ #commonT;anchor (#;Some anchor) old))
+ compiler))
+ (#e;Success [compiler' output])
+ (#e;Success [(update@ #;host
+ (|>. (:! commonT;Host)
+ (set@ #commonT;anchor (get@ #commonT;anchor old))
+ (:! Void))
+ compiler')
+ output])
+
+ (#e;Error error)
+ (#e;Error error)))))
+
+(exception: #export No-Anchor)
+
+(def: #export anchor
+ (Meta [Label Register])
+ (;function [compiler]
+ (case (|> compiler (get@ #;host) (:! commonT;Host) (get@ #commonT;anchor))
+ (#;Some anchor)
+ (#e;Success [compiler
+ anchor])
+
+ #;None
+ ((&;throw No-Anchor "") compiler))))
(def: #export (with-context name expr)
(All [a] (-> Text (Meta a) (Meta a)))
(;function [compiler]
(let [old (:! commonT;Host (get@ #;host compiler))]
(case (expr (set@ #;host
- (:! Void (set@ #commonT;context [name +0] old))
+ (:! Void (set@ #commonT;context [(&;normalize-name name) +0] old))
compiler))
(#e;Success [compiler' output])
(#e;Success [(update@ #;host
@@ -110,7 +146,7 @@
(;function [compiler]
(let [old (:! commonT;Host (get@ #;host compiler))
[old-name old-sub] (get@ #commonT;context old)
- new-name (format old-name "/" (%n old-sub))]
+ new-name (format old-name "$" (%i (nat-to-int old-sub)))]
(case (expr (set@ #;host
(:! Void (set@ #commonT;context [new-name +0] old))
compiler))
diff --git a/new-luxc/source/luxc/host/jvm/def.lux b/new-luxc/source/luxc/host/jvm/def.lux
index 1d50ba9f6..60009fb5c 100644
--- a/new-luxc/source/luxc/host/jvm/def.lux
+++ b/new-luxc/source/luxc/host/jvm/def.lux
@@ -150,7 +150,8 @@
Int
($_ i.+
ClassWriter.COMPUTE_MAXS
- ClassWriter.COMPUTE_FRAMES))
+ ## ClassWriter.COMPUTE_FRAMES
+ ))
(do-template [<name> <flag>]
[(def: #export (<name> version visibility config name parameters super interfaces
diff --git a/new-luxc/source/luxc/lang/analysis/procedure/common.lux b/new-luxc/source/luxc/lang/analysis/procedure/common.lux
index f3c296b2b..c8e3e3b38 100644
--- a/new-luxc/source/luxc/lang/analysis/procedure/common.lux
+++ b/new-luxc/source/luxc/lang/analysis/procedure/common.lux
@@ -277,7 +277,7 @@
(|> (dict;new text;Hash<Text>)
(install "=" (binary Text Text Bool))
(install "<" (binary Text Text Bool))
- (install "prepend" (binary Text Text Text))
+ (install "concat" (binary Text Text Text))
(install "index" (trinary Text Text Nat (type (Maybe Nat))))
(install "size" (unary Text Nat))
(install "hash" (unary Text Nat))
diff --git a/new-luxc/source/luxc/lang/synthesis/case.lux b/new-luxc/source/luxc/lang/synthesis/case.lux
index 8bc1e43f9..e230e2799 100644
--- a/new-luxc/source/luxc/lang/synthesis/case.lux
+++ b/new-luxc/source/luxc/lang/synthesis/case.lux
@@ -6,8 +6,10 @@
[number]
(coll [list "list/" Fold<List>]))
(meta [code "code/" Eq<Code>]))
- (luxc (lang ["la" analysis]
- ["ls" synthesis])))
+ (luxc (lang [";L" variable #+ Variable]
+ ["la" analysis]
+ ["ls" synthesis]
+ (synthesis [";S" function]))))
(def: #export (path outer-arity pattern)
(-> ls;Arity la;Pattern ls;Path)
@@ -44,8 +46,8 @@
(^code ("lux case bind" (~ [_ (#;Nat register)])))
(` ("lux case seq"
- ("lux case bind" (~ (if (n.> +1 outer-arity)
- (code;nat (n.+ (n.dec outer-arity) register))
+ ("lux case bind" (~ (if (functionS;nested? outer-arity)
+ (code;nat (|> register variableL;local (functionS;adjust-var outer-arity) variableL;local-register))
(code;nat register))))
("lux case pop")))
@@ -69,16 +71,16 @@
["lux case variant left"]
["lux case variant right"])
- (^ [[_ (#;Form (list [_ (#;Text "lux case seq")] left-pre left-post))]
- [_ (#;Form (list [_ (#;Text "lux case seq")] right-pre right-post))]])
- (case (weave left-pre right-pre)
- (^ [_ (#;Form (list [_ (#;Text "lux case alt")] _ _))])
+ (^ [(^code ("lux case seq" (~ preL) (~ postL)))
+ (^code ("lux case seq" (~ preR) (~ postR)))])
+ (case (weave preL preR)
+ (^code ("lux case alt" (~ thenP) (~ elseP)))
<default>
weavedP
- (` ("lux case seq" (~ weavedP) (~ (weave left-post right-post)))))
+ (` ("lux case seq" (~ weavedP) (~ (weave postL postR)))))
_
(if (code/= leftP rightP)
- leftP
+ rightP
<default>))))
diff --git a/new-luxc/source/luxc/lang/synthesis/expression.lux b/new-luxc/source/luxc/lang/synthesis/expression.lux
index 9ea397576..f761fb57c 100644
--- a/new-luxc/source/luxc/lang/synthesis/expression.lux
+++ b/new-luxc/source/luxc/lang/synthesis/expression.lux
@@ -23,7 +23,7 @@
(def: init-resolver (Dict Int Int) (dict;new number;Hash<Int>))
(def: (prepare-body inner-arity arity body)
- (-> Nat Nat ls;Synthesis ls;Synthesis)
+ (-> ls;Arity ls;Arity ls;Synthesis ls;Synthesis)
(if (functionS;nested? inner-arity)
body
(loopS;reify-recursion arity body)))
@@ -73,7 +73,11 @@
inputS
(^ (list [(^code ("lux case bind" (~ [_ (#;Nat register)]))) bodyA]))
- (let$ register inputS (synthesize bodyA))
+ (let$ (if (functionS;nested? outer-arity)
+ (|> register variableL;local (functionS;adjust-var outer-arity) variableL;local-register)
+ register)
+ inputS
+ (synthesize bodyA))
(^or (^ (list [(^code true) thenA] [(^code false) elseA]))
(^ (list [(^code false) elseA] [(^code true) thenA])))
@@ -121,16 +125,17 @@
(-> la;Analysis ls;Synthesis)
(loop [outer-arity +0
resolver init-resolver
+ direct? false
num-locals +0
expressionA expressionA]
(case expressionA
(^code [(~ _left) (~ _right)])
- (` [(~@ (list/map (recur outer-arity resolver num-locals) (la;unfold-tuple expressionA)))])
+ (` [(~@ (list/map (recur outer-arity resolver false num-locals) (la;unfold-tuple expressionA)))])
(^or (^code ("lux sum left" (~ _)))
(^code ("lux sum right" (~ _))))
(let [[tag last? value] (maybe;assume (la;unfold-variant expressionA))]
- (variant$ tag last? (recur outer-arity resolver num-locals value)))
+ (variant$ tag last? (recur outer-arity resolver false num-locals value)))
(^code ((~ [_ (#;Int var)])))
(if (variableL;local? var)
@@ -143,17 +148,34 @@
(var$ (maybe;default var (dict;get var resolver))))
(^code ("lux case" (~ inputA) (~ [_ (#;Record branchesA)])))
- (synthesize-case (recur outer-arity resolver num-locals) outer-arity inputA branchesA)
+ (synthesize-case (recur outer-arity resolver false num-locals) outer-arity inputA branchesA)
(^multi (^code ("lux function" [(~@ scope)] (~ bodyA)))
[(s;run scope (p;some s;int)) (#e;Success raw-env)])
- (let [inner-arity (n.inc outer-arity)
- env (list/map (function [var] (maybe;default var (dict;get var resolver))) raw-env)
+ (let [inner-arity (if direct?
+ (n.inc outer-arity)
+ +1)
+ env (list/map (function [closure]
+ (case (dict;get closure resolver)
+ (#;Some resolved)
+ (if (and (variableL;local? resolved)
+ (functionS;nested? outer-arity)
+ (|> resolved variableL;local-register (n.>= outer-arity)))
+ (functionS;adjust-var outer-arity resolved)
+ resolved)
+
+ #;None
+ (if (and (variableL;local? closure)
+ (functionS;nested? outer-arity))
+ (functionS;adjust-var outer-arity closure)
+ closure)))
+ raw-env)
env-vars (: (List Variable)
(case raw-env
#;Nil (list)
_ (|> (list;size raw-env) n.dec (list;n.range +0) (list/map variableL;captured))))
- resolver' (if (functionS;nested? inner-arity)
+ resolver' (if (and (functionS;nested? inner-arity)
+ direct?)
(list/fold (function [[from to] resolver']
(dict;put from to resolver'))
init-resolver
@@ -162,7 +184,7 @@
(dict;put var var resolver'))
init-resolver
env-vars))]
- (case (recur inner-arity resolver' num-locals bodyA)
+ (case (recur inner-arity resolver' true num-locals bodyA)
(^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat arity')] env' bodyS'))])
(let [arity (n.inc arity')]
(function$ arity env (prepare-body inner-arity arity bodyS')))
@@ -171,10 +193,10 @@
(function$ +1 env (prepare-body inner-arity +1 bodyS))))
(^code ("lux apply" (~@ _)))
- (synthesize-apply (recur outer-arity resolver num-locals) outer-arity num-locals expressionA)
+ (synthesize-apply (recur outer-arity resolver false num-locals) outer-arity num-locals expressionA)
(^code ((~ [_ (#;Text name)]) (~@ args)))
- (procedure$ name (list/map (recur outer-arity resolver num-locals) args))
+ (procedure$ name (list/map (recur outer-arity resolver false num-locals) args))
_
expressionA)))
diff --git a/new-luxc/source/luxc/lang/translation/case.jvm.lux b/new-luxc/source/luxc/lang/translation/case.jvm.lux
index 3e05ba334..7821db70d 100644
--- a/new-luxc/source/luxc/lang/translation/case.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/case.jvm.lux
@@ -204,6 +204,7 @@
(<| $i;with-label (function [@else])
$i;with-label (function [@end])
(|>. testI
+ ($i;unwrap #$;Boolean)
($i;IFEQ @else)
thenI
($i;GOTO @end)
diff --git a/new-luxc/source/luxc/lang/translation/common.jvm.lux b/new-luxc/source/luxc/lang/translation/common.jvm.lux
index f9825614a..baafc233a 100644
--- a/new-luxc/source/luxc/lang/translation/common.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/common.jvm.lux
@@ -9,7 +9,8 @@
(coll [dict #+ Dict]))
[host]
(world [blob #+ Blob]))
- (luxc (host ["$" jvm]
+ (luxc (lang [";L" variable #+ Register])
+ (host ["$" jvm]
(jvm ["$t" type]
["$d" def]
["$i" inst]))))
@@ -17,6 +18,8 @@
(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.Class a))
@@ -34,7 +37,8 @@
{#loader ClassLoader
#store Class-Store
#artifacts Artifacts
- #context [Text Nat]})
+ #context [Text Nat]
+ #anchor (Maybe [Label Register])})
(exception: Unknown-Class)
(exception: Class-Already-Stored)
diff --git a/new-luxc/source/luxc/lang/translation/function.jvm.lux b/new-luxc/source/luxc/lang/translation/function.jvm.lux
index eceaecd9d..bbf295d18 100644
--- a/new-luxc/source/luxc/lang/translation/function.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/function.jvm.lux
@@ -267,42 +267,42 @@
$i;ARETURN
))))
-(def: #export (with-function class env arity bodyI)
- (-> Text (List Variable) ls;Arity $;Inst
- (Meta [$;Def $;Inst]))
- (do meta;Monad<Meta>
- [@begin $i;make-label
- #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))
- instanceI (instance class arity env)]]
- (wrap [functionD instanceI])))
-
-(def: #export (translate-function translate env arity body)
+(def: #export (with-function @begin class env arity bodyI)
+ (-> $;Label Text (List Variable) ls;Arity $;Inst
+ [$;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
+ ))
+ instanceI (instance class arity env)]
+ [functionD instanceI]))
+
+(def: #export (translate-function translate env arity bodyS)
(-> (-> ls;Synthesis (Meta $;Inst))
(List Variable) ls;Arity ls;Synthesis
(Meta $;Inst))
(do meta;Monad<Meta>
- [[context bodyI] (hostL;with-sub-context
- (translate body))
- #let [function-class (&;normalize-name context)]
- [functionD instanceI] (with-function function-class env arity bodyI)
+ [@begin $i;make-label
+ [function-class bodyI] (hostL;with-sub-context
+ (hostL;with-anchor [@begin +1]
+ (translate bodyS)))
+ #let [[functionD instanceI] (with-function @begin function-class env arity bodyI)]
_ (commonT;store-class function-class
($d;class #$;V1.6 #$;Public $;finalC
function-class (list)
@@ -332,3 +332,28 @@
$i;fuse)]]
(wrap (|>. functionI
applyI))))
+
+(def: #export (translate-recur translate argsS)
+ (-> (-> ls;Synthesis (Meta $;Inst))
+ (List ls;Synthesis)
+ (Meta $;Inst))
+ (do meta;Monad<Meta>
+ [[@begin offset] hostL;anchor
+ argsI (monad;map @ (function [[register argS]]
+ (let [register' (n.+ offset register)]
+ (: (Meta $;Inst)
+ (case argS
+ (^multi (^code ((~ [_ (#;Int var)])))
+ (i.= (variableL;local register')
+ var))
+ (wrap id)
+
+ _
+ (do @
+ [argI (translate argS)]
+ (wrap (|>. argI
+ ($i;ASTORE register'))))))))
+ (list;zip2 (list;n.range +0 (n.dec (list;size argsS)))
+ argsS))]
+ (wrap (|>. ($i;fuse argsI)
+ ($i;GOTO @begin)))))
diff --git a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux
index 7c049a99f..77ce7f6fa 100644
--- a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux
@@ -18,7 +18,8 @@
(lang ["la" analysis]
["ls" synthesis]
(translation [";T" runtime]
- [";T" case]))))
+ [";T" case]
+ [";T" function]))))
(host;import java.lang.Long
(#static MIN_VALUE Long)
@@ -32,11 +33,11 @@
(#static NEGATIVE_INFINITY Double))
## [Types]
-(type: #export Generator
+(type: #export Translator
(-> ls;Synthesis (Meta $;Inst)))
(type: #export Proc
- (-> Generator (List ls;Synthesis) (Meta $;Inst)))
+ (-> Translator (List ls;Synthesis) (Meta $;Inst)))
(type: #export Bundle
(Dict Text Proc))
@@ -48,6 +49,7 @@
(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)))
@@ -100,6 +102,14 @@
(arity: binary +2)
(arity: trinary +3)
+(def: #export (variadic proc)
+ (-> Variadic (-> Text Proc))
+ (function [proc-name]
+ (function [translate inputsS]
+ (do meta;Monad<Meta>
+ [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))
@@ -150,6 +160,12 @@
Unary
valueI)
+(def: lux//recur
+ (-> Text Proc)
+ (function [proc-name]
+ (function [translate inputsS]
+ (functionT;translate-recur translate inputsS))))
+
## [[Bits]]
(do-template [<name> <op>]
[(def: (<name> [inputI maskI])
@@ -363,7 +379,7 @@
[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)]
- [text//append ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String")
+ [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")
@@ -544,6 +560,7 @@
(install "is" (binary lux//is))
(install "try" (unary lux//try))
(install "if" (trinary lux//if))
+ (install "recur" lux//recur)
))
(def: bit-procs
@@ -630,7 +647,7 @@
(|> (dict;new text;Hash<Text>)
(install "text =" (binary text//eq))
(install "text <" (binary text//lt))
- (install "text append" (binary text//append))
+ (install "text concat" (binary text//concat))
(install "text index" (trinary text//index))
(install "text size" (unary text//size))
(install "text hash" (unary text//hash))
diff --git a/new-luxc/source/luxc/lang/translation/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/reference.jvm.lux
index c9243cae3..3e835f8e1 100644
--- a/new-luxc/source/luxc/lang/translation/reference.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/reference.jvm.lux
@@ -19,7 +19,7 @@
(do meta;Monad<Meta>
[function-class hostL;context]
(wrap (|>. ($i;ALOAD +0)
- ($i;GETFIELD (&;normalize-name function-class)
+ ($i;GETFIELD function-class
(|> variable i.inc (i.* -1) int-to-nat functionT;captured)
commonT;$Object)))))
diff --git a/new-luxc/source/luxc/lang/variable.lux b/new-luxc/source/luxc/lang/variable.lux
index c04269e63..f766ffdcf 100644
--- a/new-luxc/source/luxc/lang/variable.lux
+++ b/new-luxc/source/luxc/lang/variable.lux
@@ -6,11 +6,11 @@
(def: #export Register Nat)
(def: #export (captured register)
- (-> Nat Variable)
+ (-> Register Variable)
(|> register n.inc nat-to-int (i.* -1)))
(def: #export (local register)
- (-> Nat Variable)
+ (-> Register Variable)
(nat-to-int register))
(def: #export (local-register variable)