diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/source/luxc/base.lux | 2 | ||||
| -rw-r--r-- | new-luxc/source/luxc/host.jvm.lux | 44 | ||||
| -rw-r--r-- | new-luxc/source/luxc/host/jvm/def.lux | 3 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/procedure/common.lux | 2 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/synthesis/case.lux | 22 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/synthesis/expression.lux | 44 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/case.jvm.lux | 1 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/common.jvm.lux | 8 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/function.jvm.lux | 89 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux | 27 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/reference.jvm.lux | 2 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/variable.lux | 4 |
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) |