diff options
Diffstat (limited to 'new-luxc/source/luxc/generator')
| -rw-r--r-- | new-luxc/source/luxc/generator/case.jvm.lux | 18 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/common.jvm.lux | 57 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/eval.jvm.lux | 5 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/expr.jvm.lux | 15 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/function.jvm.lux | 341 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/host/jvm.lux | 8 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/host/jvm/def.lux | 17 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/host/jvm/inst.lux | 2 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/procedure/common.jvm.lux | 38 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/reference.jvm.lux | 26 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/runtime.jvm.lux | 79 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/structure.jvm.lux | 2 |
12 files changed, 546 insertions, 62 deletions
diff --git a/new-luxc/source/luxc/generator/case.jvm.lux b/new-luxc/source/luxc/generator/case.jvm.lux index 1f351325e..88b3dd5d3 100644 --- a/new-luxc/source/luxc/generator/case.jvm.lux +++ b/new-luxc/source/luxc/generator/case.jvm.lux @@ -3,10 +3,10 @@ (lux (control [monad #+ do]) [macro "lux/" Monad<Lux>]) (luxc (lang ["ls" synthesis]) - (generator (host ["$" jvm] + (generator [expr] + (host ["$" jvm] (jvm ["$t" type] - ["$i" inst])) - [expr])) + ["$i" inst])))) [../runtime]) (def: $Object $;Type ($t;class "java.lang.Object" (list))) @@ -24,7 +24,7 @@ (def: peekI $;Inst (|>. $i;DUP - ($i;INVOKESTATIC ../runtime;runtime-name + ($i;INVOKESTATIC ../runtime;runtime-class "pm_peek" ($t;method (list ../runtime;$Stack) (#;Some $Object) @@ -33,7 +33,7 @@ (def: popI $;Inst - (|>. ($i;INVOKESTATIC ../runtime;runtime-name + (|>. ($i;INVOKESTATIC ../runtime;runtime-class "pm_pop" ($t;method (list ../runtime;$Stack) (#;Some ../runtime;$Stack) @@ -42,7 +42,7 @@ (def: pushI $;Inst - (|>. ($i;INVOKESTATIC ../runtime;runtime-name + (|>. ($i;INVOKESTATIC ../runtime;runtime-class "pm_push" ($t;method (list ../runtime;$Stack $Object) (#;Some ../runtime;$Stack) @@ -124,7 +124,7 @@ (|>. peekI ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) ($i;int (nat-to-int idx)) - ($i;INVOKESTATIC ../runtime;runtime-name + ($i;INVOKESTATIC ../runtime;runtime-class (if tail? "pm_right" "pm_left") ($t;method (list ../runtime;$Tuple $t;int) (#;Some $Object) @@ -151,7 +151,7 @@ ($i;CHECKCAST ($t;descriptor ../runtime;$Variant)) ($i;int (nat-to-int idx)) flagI - ($i;INVOKESTATIC ../runtime;runtime-name "pm_variant" + ($i;INVOKESTATIC ../runtime;runtime-class "pm_variant" ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag) (#;Some ../runtime;$Datum) (list)) @@ -193,7 +193,7 @@ (wrap (|>. pathI ($i;label @else) $i;POP - ($i;INVOKESTATIC ../runtime;runtime-name + ($i;INVOKESTATIC ../runtime;runtime-class "pm_fail" ($t;method (list) #;None (list)) false) diff --git a/new-luxc/source/luxc/generator/common.jvm.lux b/new-luxc/source/luxc/generator/common.jvm.lux index 095f41945..1f04f5798 100644 --- a/new-luxc/source/luxc/generator/common.jvm.lux +++ b/new-luxc/source/luxc/generator/common.jvm.lux @@ -1,17 +1,16 @@ (;module: - lux - (lux [io] + [lux #- function] + (lux (control ["ex" exception #+ exception:]) + [io] (concurrency ["A" atom]) (data ["R" result] - (coll ["d" dict]) - text/format) + (coll ["d" dict])) [host]) (luxc (generator (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst]))))) -## [Host] (host;import org.objectweb.asm.Opcodes (#static V1_6 int)) @@ -22,33 +21,69 @@ (host;import java.lang.ClassLoader (loadClass [String] (Class Object))) -## [Types] (type: #export Bytecode host;Byte-Array) (type: #export Class-Store (A;Atom (d;Dict Text Bytecode))) (type: #export Host {#loader ClassLoader - #store Class-Store}) + #store Class-Store + #function-class (Maybe Text)}) + +(exception: Unknown-Class) +(exception: Class-Already-Stored) +(exception: No-Function-Being-Compiled) (def: #export (store-class name byte-code) (-> Text Bytecode (Lux Unit)) - (function [compiler] + (;function [compiler] (let [store (|> (get@ #;host compiler) (:! Host) (get@ #store))] (if (d;contains? name (|> store A;get io;run)) - (#R;Error (format "Cannot store class that already exists: " name)) + (ex;throw Class-Already-Stored name) (#R;Success [compiler (io;run (A;update (d;put name byte-code) store))]) )))) (def: #export (load-class name) (-> Text (Lux (Class Object))) - (function [compiler] + (;function [compiler] (let [host (:! Host (get@ #;host compiler)) store (|> host (get@ #store) A;get io;run)] (if (d;contains? name store) (#R;Success [compiler (ClassLoader.loadClass [name] (get@ #loader host))]) - (#R;Error (format "Unknown class: " name)))))) + (ex;throw Unknown-Class name))))) + +(def: #export (with-function class expr) + (All [a] (-> Text (Lux a) (Lux a))) + (;function [compiler] + (let [host (:! Host (get@ #;host compiler)) + old-function-class (get@ #function-class host)] + (case (expr (set@ #;host + (:! Void (set@ #function-class + (#;Some class) + host)) + compiler)) + (#R;Success [compiler' output]) + (#R;Success [(update@ #;host + (|>. (:! Host) + (set@ #function-class old-function-class) + (:! Void)) + compiler') + output]) + + (#R;Error error) + (#R;Error error))))) + +(def: #export function + (Lux Text) + (;function [compiler] + (let [host (:! Host (get@ #;host compiler))] + (case (get@ #function-class host) + #;None + (ex;throw No-Function-Being-Compiled "") + + (#;Some function-class) + (#R;Success [compiler function-class]))))) (def: #export bytecode-version Int Opcodes.V1_6) diff --git a/new-luxc/source/luxc/generator/eval.jvm.lux b/new-luxc/source/luxc/generator/eval.jvm.lux index e6650953f..818c03b66 100644 --- a/new-luxc/source/luxc/generator/eval.jvm.lux +++ b/new-luxc/source/luxc/generator/eval.jvm.lux @@ -71,10 +71,9 @@ (host;null) "java/lang/Object" (host;null)])) - ($d;field #$;Public {#$;staticF true #$;finalF true #$;transientF false #$;volatileF false} + ($d;field #$;Public $;staticF eval-field $Object) - ($d;method #$;Public - {#$;staticM true #$;finalM false #$;synchronizedM false} + ($d;method #$;Public ($_ $;++M $;staticM $;strictM) "<clinit>" ($t;method (list) #;None (list)) (|>. valueI diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux index 0bdebe555..6b6c68fde 100644 --- a/new-luxc/source/luxc/generator/expr.jvm.lux +++ b/new-luxc/source/luxc/generator/expr.jvm.lux @@ -1,16 +1,20 @@ (;module: lux (lux (control monad) + (data text/format) [macro #+ Monad<Lux> "Lux/" Monad<Lux>]) (luxc ["&" base] (lang ["ls" synthesis]) ["&;" analyser] ["&;" synthesizer] + (synthesizer [";S" function]) (generator ["&;" common] ["&;" primitive] ["&;" structure] ["&;" eval] ["&;" procedure] + ["&;" function] + ["&;" reference] (host ["$" jvm])))) (def: #export (generate synthesis) @@ -35,6 +39,17 @@ (#ls;Tuple members) (&structure;generate-tuple generate members) + (#ls;Variable var) + (if (functionS;captured? var) + (&reference;generate-captured var) + (&reference;generate-variable var)) + + (#ls;Function arity env body) + (&function;generate-function generate env arity body) + + (#ls;Call args function) + (&function;generate-call generate function args) + (#ls;Procedure name args) (&procedure;generate-procedure generate name args) diff --git a/new-luxc/source/luxc/generator/function.jvm.lux b/new-luxc/source/luxc/generator/function.jvm.lux new file mode 100644 index 000000000..135daf47e --- /dev/null +++ b/new-luxc/source/luxc/generator/function.jvm.lux @@ -0,0 +1,341 @@ +(;module: + lux + (lux (control [monad #+ do]) + (data text/format + (coll [list "L/" Functor<List> Monoid<List>])) + [macro]) + (luxc ["&" base] + (lang ["la" analysis] + ["ls" synthesis]) + ["&;" analyser] + ["&;" synthesizer] + (synthesizer [function]) + (generator ["&;" common] + ["&;" runtime] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst]))))) + + +(def: arity-field Text "arity") +(def: $Object $;Type ($t;class "java.lang.Object" (list))) + +(do-template [<name> <prefix>] + [(def: #export (<name> idx) + (-> Nat Text) + (|> idx nat-to-int %i (format <prefix>)))] + + [captured "c"] + [partial "p"] + ) + +(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 ls;Variable) (List $;Type)) + (list;repeat (list;size env) $Object)) + +(def: (init-method env arity) + (-> (List ls;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 &runtime;function-class &runtime;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))) + (L/map $i;ALOAD) + $i;fuse)) + +(def: (applysI start amount) + (-> $;Register Nat $;Inst) + (let [max-args (n.min amount &runtime;num-apply-variants) + later-applysI (if (n.> &runtime;num-apply-variants amount) + (applysI (n.+ &runtime;num-apply-variants start) (n.- &runtime;num-apply-variants amount)) + id)] + (|>. ($i;CHECKCAST &runtime;function-class) + (inputsI start max-args) + ($i;INVOKEVIRTUAL &runtime;function-class &runtime;apply-method (&runtime;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 ls;Variable) $;Def) + (|> (list;enumerate env) + (L/map (function [[env-idx env-source]] + ($d;field #$;Private $;finalF (captured env-idx) $Object))) + $d;fuse)) + +(def: (with-partial arity) + (-> ls;Arity $;Def) + (if (poly-arg? arity) + (|> (list;n.range +0 (n.- +2 arity)) + (L/map (function [idx] + ($d;field #$;Private $;finalF (partial idx) $Object))) + $d;fuse) + id)) + +(def: (instance class arity env) + (-> Text ls;Arity (List ls;Variable) $;Inst) + (let [captureI (|> env + (L/map (function [source] + (if (function;captured? source) + ($i;GETFIELD class (captured (function;captured-idx source)) $Object) + ($i;ALOAD (int-to-nat source))))) + $i;fuse) + argsI (if (poly-arg? arity) + (|> (nullsI (n.dec arity)) + (list ($i;int 0)) + $i;fuse) + id)] + (|>. ($i;NEW class) + $i;DUP + captureI + argsI + ($i;INVOKESPECIAL class "<init>" (init-method env arity) false)))) + +(def: (with-reset class arity env) + (-> Text ls;Arity (List ls;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))) + (L/map (function [source] + (|>. ($i;ALOAD +0) + ($i;GETFIELD class (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>" (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 &runtime;function-class "<init>" function-init-method false)) + (|>. ($i;ILOAD (n.inc env-size)) + ($i;INVOKESPECIAL &runtime;function-class "<init>" function-init-method false)))) + +(def: (with-init class env arity) + (-> Text (List ls;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))) + (L/map (function [register] + (|>. ($i;ALOAD +0) + ($i;ALOAD (n.inc register)) + ($i;PUTFIELD class (captured register) $Object)))) + $i;fuse) + store-partialI (if (poly-arg? arity) + (|> (list;n.range +0 (n.- +2 arity)) + (L/map (function [idx] + (let [register (offset-partial idx)] + (|>. ($i;ALOAD +0) + ($i;ALOAD (n.inc register)) + ($i;PUTFIELD class (partial idx) $Object))))) + $i;fuse) + id)] + ($d;method #$;Public $;noneM "<init>" (init-method env arity) + (|>. ($i;ALOAD +0) + (function-init arity env-size) + store-capturedI + store-partialI + $i;RETURN)))) + +(def: (when test f) + (All [a] (-> Bool (-> a a) (-> a a))) + (function [value] + (if test + (f value) + value))) + +(def: (with-apply class env function-arity @begin bodyI apply-arity) + (-> Text (List ls;Variable) ls;Arity $;Label $;Inst ls;Arity + $;Def) + (let [num-partials (n.dec function-arity) + @default ($;new-label []) + @labels (L/map $;new-label (list;repeat num-partials [])) + arity-over-extent (|> (nat-to-int function-arity) (i.- (nat-to-int apply-arity))) + casesI (|> (L/append @labels (list @default)) + (list;zip2 (list;n.range +0 num-partials)) + (L/map (function [[stage @label]] + (let [load-partialsI (if (n.> +0 stage) + (|> (list;n.range +0 (n.dec stage)) + (L/map (|>. 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))) + (L/map (|>. 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>" (init-method env function-arity) false) + $i;ARETURN)) + )))) + $i;fuse)] + ($d;method #$;Public $;noneM &runtime;apply-method (&runtime;apply-signature apply-arity) + (|>. get-amount-of-partialsI + ($i;TABLESWITCH 0 (|> num-partials n.dec nat-to-int) + @default @labels) + casesI + ($i;INVOKESTATIC &runtime;runtime-class "apply_fail" ($t;method (list) #;None (list)) false) + $i;NULL + $i;ARETURN + )))) + +(def: #export (with-function generate class env arity body) + (-> (-> ls;Synthesis (Lux $;Inst)) + Text (List ls;Variable) ls;Arity ls;Synthesis + (Lux [$;Def $;Inst])) + (do macro;Monad<Lux> + [@begin $i;make-label + bodyI (&common;with-function class (generate body)) + #let [env-size (list;size env) + applyD (: $;Def + (if (poly-arg? arity) + (|> (n.min arity &runtime;num-apply-variants) + (list;n.range +1) + (L/map (with-apply class env arity @begin bodyI)) + (list& (with-implementation arity @begin bodyI)) + $d;fuse) + ($d;method #$;Public $;strictM &runtime;apply-method (&runtime;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 (generate-function generate env arity body) + (-> (-> ls;Synthesis (Lux $;Inst)) + (List ls;Variable) ls;Arity ls;Synthesis + (Lux $;Inst)) + (do macro;Monad<Lux> + [function-class (:: @ map %code (macro;gensym "function")) + [functionD instanceI] (with-function generate function-class env arity body) + _ (&common;store-class function-class + ($d;class #$;V1.6 #$;Public $;finalC + function-class (list) + ($;simple-class &runtime;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 (generate-call generate functionS argsS) + (-> (-> ls;Synthesis (Lux $;Inst)) + ls;Synthesis (List ls;Synthesis) + (Lux $;Inst)) + (do macro;Monad<Lux> + [functionI (generate functionS) + argsI (monad;map @ generate argsS) + #let [applyI (|> (segment &runtime;num-apply-variants argsI) + (L/map (function [chunkI+] + (|>. ($i;CHECKCAST &runtime;function-class) + ($i;fuse chunkI+) + ($i;INVOKEVIRTUAL &runtime;function-class &runtime;apply-method (&runtime;apply-signature (list;size chunkI+)) false)))) + $i;fuse)]] + (wrap (|>. functionI + applyI)))) diff --git a/new-luxc/source/luxc/generator/host/jvm.lux b/new-luxc/source/luxc/generator/host/jvm.lux index 4b4b1d38e..149fbf123 100644 --- a/new-luxc/source/luxc/generator/host/jvm.lux +++ b/new-luxc/source/luxc/generator/host/jvm.lux @@ -117,10 +117,14 @@ ## Configs (config: Class-Config noneC ++C [finalC]) -(config: Method-Config noneM ++M [staticM finalM synchronizedM]) -(config: Field-Config noneF ++F [staticF finalF transientF volatileF]) +(config: Method-Config noneM ++M [finalM staticM synchronizedM strictM]) +(config: Field-Config noneF ++F [finalF staticF transientF volatileF]) ## Labels (def: #export new-label (-> Unit Label) org.objectweb.asm.Label.new) + +(def: #export (simple-class name) + (-> Text Class) + [name (list)]) diff --git a/new-luxc/source/luxc/generator/host/jvm/def.lux b/new-luxc/source/luxc/generator/host/jvm/def.lux index bb1d2cd94..18cd4f945 100644 --- a/new-luxc/source/luxc/generator/host/jvm/def.lux +++ b/new-luxc/source/luxc/generator/host/jvm/def.lux @@ -50,6 +50,7 @@ (host;import org.objectweb.asm.ClassWriter (#static COMPUTE_MAXS int) + (#static COMPUTE_FRAMES int) (new [int]) (visit [int int String String String (Array String)] void) (visitEnd [] void) @@ -100,10 +101,10 @@ (def: (method-flags config) (-> $;Method-Config Int) ($_ i.+ - Opcodes.ACC_STRICT (if (get@ #$;staticM config) Opcodes.ACC_STATIC 0) (if (get@ #$;finalM config) Opcodes.ACC_FINAL 0) - (if (get@ #$;synchronizedM config) Opcodes.ACC_SYNCHRONIZED 0))) + (if (get@ #$;synchronizedM config) Opcodes.ACC_SYNCHRONIZED 0) + (if (get@ #$;strictM config) Opcodes.ACC_STRICT 0))) (def: (field-flags config) (-> $;Field-Config Int) @@ -145,12 +146,18 @@ (L/map (|>. class-to-type $t;signature)) (text;join-with ""))))) +(def: class-computes + Int + ($_ i.+ + ClassWriter.COMPUTE_MAXS + ClassWriter.COMPUTE_FRAMES)) + (do-template [<name> <flag>] [(def: #export (<name> version visibility config name parameters super interfaces definitions) (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) $;Class (List $;Class) $;Def host;Byte-Array) - (let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS) + (let [writer (|> (do-to (ClassWriter.new class-computes) (ClassWriter.visit [(version-flag version) ($_ i.+ Opcodes.ACC_SUPER @@ -177,7 +184,7 @@ definitions) (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) (List $;Class) $;Def host;Byte-Array) - (let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS) + (let [writer (|> (do-to (ClassWriter.new class-computes) (ClassWriter.visit [(version-flag version) ($_ i.+ Opcodes.ACC_SUPER @@ -277,4 +284,4 @@ singleton (#;Cons head tail) - (. head (fuse tail)))) + (. (fuse tail) head))) diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux index 0f947925c..02027294a 100644 --- a/new-luxc/source/luxc/generator/host/jvm/inst.lux +++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux @@ -353,4 +353,4 @@ singleton (#;Cons head tail) - (. head (fuse tail)))) + (. (fuse tail) head))) diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux index d04a91141..9f8afdbb2 100644 --- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux @@ -56,7 +56,7 @@ (def: $Object-Array $;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 &runtime;function-name (list))) +(def: $Function $;Type ($t;class &runtime;function-class (list))) (def: (install name unnamed) (-> Text (-> Text Proc) @@ -135,8 +135,8 @@ (def: (lux//try riskyI) Unary (|>. riskyI - ($i;CHECKCAST &runtime;function-name) - ($i;INVOKESTATIC &runtime;runtime-name "try" try-method false))) + ($i;CHECKCAST &runtime;function-class) + ($i;INVOKESTATIC &runtime;runtime-class "try" try-method false))) ## [[Bits]] (do-template [<name> <op>] @@ -256,9 +256,9 @@ [nat//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] [nat//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL] [nat//div ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC &runtime;runtime-name "div_nat" nat-method false)] + ($i;INVOKESTATIC &runtime;runtime-class "div_nat" nat-method false)] [nat//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC &runtime;runtime-name "rem_nat" nat-method false)] + ($i;INVOKESTATIC &runtime;runtime-class "rem_nat" nat-method false)] [frac//add ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DADD] [frac//sub ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DSUB] @@ -269,9 +269,9 @@ [deg//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD] [deg//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] [deg//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC &runtime;runtime-name "mul_deg" deg-method false)] + ($i;INVOKESTATIC &runtime;runtime-class "mul_deg" deg-method false)] [deg//div ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC &runtime;runtime-name "div_deg" deg-method false)] + ($i;INVOKESTATIC &runtime;runtime-class "div_deg" deg-method false)] [deg//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] [deg//scale ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL] [deg//reciprocal ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LDIV] @@ -289,10 +289,10 @@ [<eq> 0] [<lt> -1])] - [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-name "compare_nat" compare-nat-method false)] + [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;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 &runtime;runtime-name "compare_nat" compare-nat-method false)] + [deg//eq deg//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-class "compare_nat" compare-nat-method false)] ) (do-template [<name> <prepare> <transform>] @@ -310,15 +310,15 @@ [frac//to-int ($i;unwrap #$;Double) (<| ($i;wrap #$;Long) $i;D2L)] [frac//to-deg ($i;unwrap #$;Double) - (<| ($i;wrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-name "frac_to_deg" + (<| ($i;wrap #$;Long) ($i;INVOKESTATIC &runtime;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 &runtime;runtime-name "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)] + ($i;INVOKESTATIC &runtime;runtime-class "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)] [deg//to-frac ($i;unwrap #$;Long) - (<| ($i;wrap #$;Double) ($i;INVOKESTATIC &runtime;runtime-name "deg_to_frac" + (<| ($i;wrap #$;Double) ($i;INVOKESTATIC &runtime;runtime-class "deg_to_frac" ($t;method (list $t;long) (#;Some $t;double) (list)) false))] ) @@ -358,7 +358,7 @@ ($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 &runtime;runtime-name "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false) + ($i;INVOKESTATIC &runtime;runtime-class "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false) lux-intI] ) @@ -371,7 +371,7 @@ <op>))] [text//clip ($i;CHECKCAST "java.lang.String") jvm-intI jvm-intI - ($i;INVOKESTATIC &runtime;runtime-name "text_clip" + ($i;INVOKESTATIC &runtime;runtime-class "text_clip" ($t;method (list $String $t;int $t;int) (#;Some $Object-Array) (list)) false)] [text//replace ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") ($i;INVOKEVIRTUAL "java.lang.String" "replace" ($t;method (list $CharSequence $CharSequence) (#;Some $String) (list)) false)] @@ -508,20 +508,20 @@ ## [[Processes]] (def: (process//concurrency-level []) Nullary - (|>. ($i;GETSTATIC &runtime;runtime-name "concurrency_level" $t;int) + (|>. ($i;GETSTATIC &runtime;runtime-class "concurrency_level" $t;int) lux-intI)) (def: (process//future procedureI) Unary - (|>. procedureI ($i;CHECKCAST &runtime;function-name) - ($i;INVOKESTATIC &runtime;runtime-name "future" + (|>. procedureI ($i;CHECKCAST &runtime;function-class) + ($i;INVOKESTATIC &runtime;runtime-class "future" ($t;method (list $Function) (#;Some $Object) (list)) false))) (def: (process//schedule [millisecondsI procedureI]) Binary (|>. millisecondsI ($i;unwrap #$;Long) - procedureI ($i;CHECKCAST &runtime;function-name) - ($i;INVOKESTATIC &runtime;runtime-name "schedule" + procedureI ($i;CHECKCAST &runtime;function-class) + ($i;INVOKESTATIC &runtime;runtime-class "schedule" ($t;method (list $t;long $Function) (#;Some $Object) (list)) false))) ## [Bundles] diff --git a/new-luxc/source/luxc/generator/reference.jvm.lux b/new-luxc/source/luxc/generator/reference.jvm.lux new file mode 100644 index 000000000..28c936036 --- /dev/null +++ b/new-luxc/source/luxc/generator/reference.jvm.lux @@ -0,0 +1,26 @@ +(;module: + lux + (lux (control [monad #+ do]) + (data text/format) + [macro "lux/" Monad<Lux>]) + (luxc (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 (Lux $;Inst)) + (do macro;Monad<Lux> + [function-class commonG;function] + (wrap (|>. ($i;ALOAD +0) + ($i;GETFIELD function-class + (|> variable i.inc (i.* -1) int-to-nat functionG;captured) + $Object))))) + +(def: #export (generate-variable variable) + (-> ls;Variable (Lux $;Inst)) + (lux/wrap ($i;ALOAD (int-to-nat variable)))) diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux index 68e18deaa..69f90cea0 100644 --- a/new-luxc/source/luxc/generator/runtime.jvm.lux +++ b/new-luxc/source/luxc/generator/runtime.jvm.lux @@ -2,7 +2,8 @@ lux (lux (control monad) (data ["R" result] - text/format) + text/format + (coll [list "L/" Functor<List>])) [math] [macro #+ Monad<Lux> "Lux/" Monad<Lux>] [host #+ do-to]) @@ -40,8 +41,8 @@ (visitEnd [] void) (toByteArray [] Byte-Array)) -(def: #export runtime-name Text "LuxRuntime") -(def: #export function-name Text "LuxFunction") +(def: #export runtime-class Text "LuxRuntime") +(def: #export function-class Text "LuxFunction") (def: #export unit Text "\u0000") (def: $Object $;Type ($t;class "java.lang.Object" (list))) @@ -54,7 +55,7 @@ (def: #export $Flag $;Type $Object) (def: #export $Datum $;Type $Object) -(def: logI +(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))] @@ -67,7 +68,7 @@ (def: variant-makeI $;Inst - ($i;INVOKESTATIC runtime-name "variant_make" variant-method false)) + ($i;INVOKESTATIC runtime-class "variant_make" variant-method false)) (def: #export someI $;Inst @@ -102,11 +103,11 @@ (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 runtime-name "compare_nat" compare-nat-method false) ($i;IFLT @where))) + less-thanI (function [@where] (|>. ($i;INVOKESTATIC 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 runtime-name "_toUnsignedBigInteger" upcast-method false) + upcastI ($i;INVOKESTATIC runtime-class "_toUnsignedBigInteger" upcast-method false) downcastI ($i;INVOKEVIRTUAL "java.math.BigInteger" "longValue" ($t;method (list) (#;Some $t;long) (list)) false)] ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215 (|>. ($d;method #$;Public $;staticM "_toUnsignedBigInteger" upcast-method @@ -279,7 +280,7 @@ (let [subjectI ($i;LLOAD +0) paramI ($i;LLOAD +2) equal?I (function [@where] (|>. $i;LCMP ($i;IFEQ @where))) - count-leading-zerosI ($i;INVOKESTATIC runtime-name "count_leading_zeros" clz-method false) + count-leading-zerosI ($i;INVOKESTATIC 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) @@ -323,6 +324,12 @@ ($i;string "Invalid expression for pattern-matching.") ($i;INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($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" "<init>" ($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") @@ -439,15 +446,65 @@ $i;ARETURN))) ))) -(def: #export generate +(def: generate-runtime (Lux &common;Bytecode) (do Monad<Lux> [_ (wrap []) - #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-name (list) ["java.lang.Object" (list)] (list) + #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-class (list) ["java.lang.Object" (list)] (list) (|>. adt-methods nat-methods frac-methods deg-methods pm-methods))] - _ (&common;store-class runtime-name bytecode)] + _ (&common;store-class runtime-class bytecode)] (wrap bytecode))) + +(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: generate-function + (Lux &common;Bytecode) + (do Monad<Lux> + [_ (wrap []) + #let [applyI (|> (list;n.range +2 num-apply-variants) + (L/map (function [arity] + ($d;method #$;Public $;noneM apply-method (apply-signature arity) + (let [preI (|> (list;n.range +0 (n.dec arity)) + (L/map $i;ALOAD) + $i;fuse)] + (|>. preI + ($i;INVOKEVIRTUAL function-class apply-method (apply-signature (n.dec arity)) false) + ($i;CHECKCAST function-class) + ($i;ALOAD arity) + ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false) + $i;ARETURN))))) + (list& ($d;abstract-method #$;Public $;noneM apply-method (apply-signature +1)) + ## ($d;method #$;Public $;noneM apply-method (apply-signature +1) + ## (|>. $i;NULL + ## $i;ARETURN)) + ) + $d;fuse) + bytecode ($d;abstract #$;V1.6 #$;Public $;noneC function-class (list) ["java.lang.Object" (list)] (list) + (|>. ($d;field #$;Public $;finalF partials-field $t;int) + ($d;method #$;Public $;noneM "<init>" ($t;method (list $t;int) #;None (list)) + (|>. ($i;ALOAD +0) + ($i;INVOKESPECIAL "java.lang.Object" "<init>" ($t;method (list) #;None (list)) false) + ($i;ALOAD +0) + ($i;ILOAD +1) + ($i;PUTFIELD function-class partials-field $t;int) + $i;RETURN)) + applyI))] + _ (&common;store-class function-class bytecode)] + (wrap bytecode))) + +(def: #export generate + (Lux Unit) + (do Monad<Lux> + [_ generate-runtime + _ generate-function] + (wrap []))) diff --git a/new-luxc/source/luxc/generator/structure.jvm.lux b/new-luxc/source/luxc/generator/structure.jvm.lux index 9adff1a55..a89f3083f 100644 --- a/new-luxc/source/luxc/generator/structure.jvm.lux +++ b/new-luxc/source/luxc/generator/structure.jvm.lux @@ -51,7 +51,7 @@ (wrap (|>. ($i;int (nat-to-int tag)) (flagI tail?) memberI - ($i;INVOKESTATIC ../runtime;runtime-name + ($i;INVOKESTATIC ../runtime;runtime-class "variant_make" ($t;method (list $t;int $Object $Object) (#;Some ($t;array +1 $Object)) |