diff options
Diffstat (limited to 'new-luxc/source/luxc/generator/function.jvm.lux')
| -rw-r--r-- | new-luxc/source/luxc/generator/function.jvm.lux | 155 |
1 files changed, 74 insertions, 81 deletions
diff --git a/new-luxc/source/luxc/generator/function.jvm.lux b/new-luxc/source/luxc/generator/function.jvm.lux index 135daf47e..e3582e183 100644 --- a/new-luxc/source/luxc/generator/function.jvm.lux +++ b/new-luxc/source/luxc/generator/function.jvm.lux @@ -2,7 +2,7 @@ lux (lux (control [monad #+ do]) (data text/format - (coll [list "L/" Functor<List> Monoid<List>])) + (coll [list "list/" Functor<List> Monoid<List>])) [macro]) (luxc ["&" base] (lang ["la" analysis] @@ -68,7 +68,7 @@ (def: (inputsI start amount) (-> $;Register Nat $;Inst) (|> (list;n.range start (n.+ start (n.dec amount))) - (L/map $i;ALOAD) + (list/map $i;ALOAD) $i;fuse)) (def: (applysI start amount) @@ -96,26 +96,26 @@ (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))) + (list/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))) + (list/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))))) + (list/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)) @@ -136,9 +136,9 @@ 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)))) + (list/map (function [source] + (|>. ($i;ALOAD +0) + ($i;GETFIELD class (captured source) $Object)))) $i;fuse) argsI (|> (nullsI (n.dec arity)) (list ($i;int 0)) @@ -179,18 +179,18 @@ 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)))) + (list/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))))) + (list/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) @@ -200,69 +200,62 @@ 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 [])) + @labels (list/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)) + casesI (|> (list/compose @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) + (list/map (function [[stage @label]] + (let [load-partialsI (if (n.> +0 stage) + (|> (list;n.range +0 (n.dec stage)) + (list/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 [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.< 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))) + (list/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 @@ -286,7 +279,7 @@ (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/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) @@ -332,10 +325,10 @@ [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)))) + (list/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)))) |