aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/lang')
-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
9 files changed, 135 insertions, 64 deletions
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)