diff options
Diffstat (limited to 'stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method')
5 files changed, 260 insertions, 117 deletions
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux index e298ab187..0d4e1f2b3 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux @@ -1,37 +1,56 @@ (.module: - [lux (#- type) + [lux (#- Type type) [abstract - ["." monad]] + ["." monad (#+ do)]] + [control + [state (#+ State)]] [data [number ["n" nat] + ["i" int] ["." i32]] [collection - ["." list]]] + ["." list ("#@." monoid functor)]]] [target [jvm - ["_" instruction (#+ Instruction) ("#@." monad)] - ["." constant] + ["_" instruction (#+ Label Instruction) ("#@." monad)] + ["." method (#+ Method)] + ["." constant + [pool (#+ Pool)]] [encoding - ["." unsigned]] - [type - ["." category (#+ Value Return)] - ["." descriptor (#+ Descriptor)]]]]] - ["." /// #_ - ["#." abstract] - ["#." arity] + ["." unsigned] + ["." signed]] + ["." type (#+ Type) + ["." category (#+ Class)]]]]] + ["." // + ["#." reset] + ["#." implementation] + ["#." init] ["/#" // #_ - ["#." value] - [//// - [reference (#+ Register)] - [arity (#+ Arity)]]]]) + ["#." abstract] + [field + [constant + ["#." arity]] + [variable + ["#." partial + ["#/." count]] + ["#." foreign]]] + ["/#" // #_ + ["#." runtime] + ["#." value] + ["#." reference] + [//// + [analysis (#+ Environment)] + [arity (#+ Arity)] + ["." reference (#+ Register)]]]]]) (def: #export name "apply") (def: #export (type arity) - (-> Arity [(List (Descriptor Value)) (Descriptor Return)]) - [(list.repeat arity ////value.type) - ////value.type]) + (-> Arity (Type category.Method)) + (type.method [(list.repeat arity ////value.type) + ////value.type + (list)])) (def: (increment by) (-> Nat (Instruction Any)) @@ -48,7 +67,7 @@ (_@wrap []) )) -(def: #export (instruction offset amount) +(def: (apply offset amount) (-> Register Nat (Instruction Any)) (let [arity (n.min amount ///arity.maximum)] ($_ _.compose @@ -56,7 +75,86 @@ (..inputs offset arity) (_.invokevirtual ///abstract.class ..name (..type arity)) (if (n.> ///arity.maximum amount) - (instruction (n.+ ///arity.maximum offset) - (n.- ///arity.maximum amount)) + (apply (n.+ ///arity.maximum offset) + (n.- ///arity.maximum amount)) (_@wrap [])) ))) + +(def: this-offset 1) + +(def: #export (method class environment function-arity @begin body apply-arity) + (-> (Type Class) Environment Arity Label (Instruction Any) Arity (State Pool Method)) + (let [num-partials (dec function-arity) + over-extent (i.- (.int apply-arity) + (.int function-arity)) + failure ($_ _.compose + ////runtime.apply-failure + _.aconst-null + _.areturn)] + (method.method //.modifier ..name + (..type apply-arity) + (list) + (do _.monad + [@default _.new-label + @labels (|> _.new-label + (list.repeat num-partials) + (monad.seq _.monad)) + #let [cases (|> (list@compose @labels (list @default)) + list.enumerate + (list@map (function (_ [stage @case]) + (let [current-partials (|> (list.indices stage) + (list@map (///partial.get class)) + (monad.seq _.monad)) + already-partial? (n.> 0 stage) + exact-match? (i.= over-extent (.int stage)) + has-more-than-necessary? (i.> over-extent (.int stage))] + (cond exact-match? + ($_ _.compose + (_.set-label @case) + ////reference.this + (if already-partial? + (_.invokevirtual class //reset.name (//reset.type class)) + (_@wrap [])) + current-partials + (inputs ..this-offset apply-arity) + (_.invokevirtual class //implementation.name (//implementation.type function-arity)) + _.areturn) + + has-more-than-necessary? + (let [inputs-to-completion (|> function-arity (n.- stage)) + inputs-left (|> apply-arity (n.- inputs-to-completion))] + ($_ _.compose + (_.set-label @case) + ////reference.this + (_.invokevirtual class //reset.name (//reset.type class)) + current-partials + (inputs ..this-offset inputs-to-completion) + (_.invokevirtual class //implementation.name (//implementation.type function-arity)) + (apply (n.+ ..this-offset inputs-to-completion) inputs-left) + _.areturn)) + + ## (i.< over-extent (.int stage)) + (let [current-environment (|> (list.indices (list.size environment)) + (list@map (///foreign.get class)) + (monad.seq _.monad)) + missing-partials (|> _.aconst-null + (list.repeat (|> num-partials (n.- apply-arity) (n.- stage))) + (monad.seq _.monad))] + ($_ _.compose + (_.set-label @case) + (_.new class) + _.dup + current-environment + ///partial/count.value + (..increment apply-arity) + current-partials + (inputs ..this-offset apply-arity) + missing-partials + (_.invokevirtual class //init.name (//init.type environment function-arity)) + _.areturn)))))) + (monad.seq _.monad))]] + ($_ _.compose + ///partial/count.value + (_.tableswitch (signed.s4 +0) @default @labels) + cases + failure))))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux index 18df43d9d..8643dc916 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux @@ -1,5 +1,5 @@ (.module: - [lux (#- type) + [lux (#- Type type) [control [state (#+ State)]] [data @@ -11,9 +11,8 @@ ["_" instruction (#+ Label Instruction)] [constant [pool (#+ Pool)]] - [type - ["." category] - ["." descriptor (#+ Descriptor)]]]]] + ["." type (#+ Type) + ["." category]]]]] ["." // ["//#" /// #_ ["#." value] @@ -23,13 +22,14 @@ (def: #export name "impl") (def: #export (type arity) - (-> Arity (Descriptor category.Method)) - (descriptor.method [(list.repeat arity ////value.type) - ////value.type])) + (-> Arity (Type category.Method)) + (type.method [(list.repeat arity ////value.type) + ////value.type + (list)])) -(def: #export (method arity @begin body) - (-> Arity Label (Instruction Any) (State Pool Method)) - (method.method //.modifier ..name +(def: #export (method' name arity @begin body) + (-> Text Arity Label (Instruction Any) (State Pool Method)) + (method.method //.modifier name (..type arity) (list) ($_ _.compose @@ -37,3 +37,7 @@ body _.areturn ))) + +(def: #export method + (-> Arity Label (Instruction Any) (State Pool Method)) + (method' ..name)) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux index 5f771abcd..5eddafb8a 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux @@ -1,30 +1,96 @@ (.module: - [lux (#- type) + [lux (#- Type type) + [abstract + ["." monad]] + [control + [state (#+ State)]] + [data + [number + ["n" nat]] + [collection + ["." list ("#@." monoid functor)]]] [target [jvm ["_" instruction (#+ Instruction)] + ["." method (#+ Method)] [encoding ["." unsigned]] - [type - ["." category (#+ Value Return)] - ["." descriptor (#+ Descriptor)]]]]] - ["." /// #_ - ["#." abstract] - ["#." arity] + [constant + [pool (#+ Pool)]] + ["." type (#+ Type) + ["." category (#+ Class Value)]]]]] + ["." // + ["#." implementation] ["/#" // #_ - [//// - ["." arity (#+ Arity)]]]]) + ["#." abstract] + [field + [constant + ["#." arity]] + [variable + ["#." foreign] + ["#." partial]]] + ["/#" // #_ + ["#." value] + ["#." reference] + [//// + [reference (#+ Register)] + [analysis (#+ Environment)] + ["." arity (#+ Arity)]]]]]) -(def: #export type - [(List (Descriptor Value)) - (Descriptor Return)] - [(list ///arity.type) descriptor.void]) +(def: #export name "<init>") -(def: #export (instruction environment-size arity) +(def: (partials arity) + (-> Arity (List (Type Value))) + (list.repeat arity ////value.type)) + +(def: #export (type environment arity) + (-> Environment Arity (Type category.Method)) + (type.method [(list@compose (///foreign.closure environment) + (if (arity.multiary? arity) + (list& ///arity.type (..partials arity)) + (list))) + type.void + (list)])) + +(def: super-type + (Type category.Method) + (type.method [(list ///arity.type) type.void (list)])) + +(def: #export (super environment-size arity) (-> Nat Arity (Instruction Any)) (let [arity-register (inc environment-size)] ($_ _.compose (if (arity.unary? arity) (_.bipush (unsigned.u1 0)) (_.iload (unsigned.u1 arity-register))) - (_.invokespecial ///abstract.class "<init>" ..type)))) + (_.invokespecial ///abstract.class ..name ..super-type)))) + +(def: (store-all amount put offset) + (-> Nat + (-> Register (Instruction Any) (Instruction Any)) + (-> Register Register) + (Instruction Any)) + (|> (list.indices amount) + (list@map (function (_ register) + (put register + (_.aload (unsigned.u1 (offset register)))))) + (monad.seq _.monad))) + +(def: #export (method class environment arity) + (-> (Type Class) Environment Arity (State Pool Method)) + (let [environment-size (list.size environment) + offset-foreign (: (-> Register Register) + (n.+ 1)) + offset-arity (: (-> Register Register) + (|>> offset-foreign (n.+ environment-size))) + offset-partial (: (-> Register Register) + (|>> offset-arity (n.+ 1)))] + (method.method //.modifier ..name + (..type environment arity) + (list) + ($_ _.compose + ////reference.this + (..super environment-size arity) + (store-all environment-size (///foreign.put class) offset-foreign) + (store-all (dec arity) (///partial.put class) offset-partial) + _.return)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/new.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/new.lux index f03d333b2..241ec2676 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/new.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/new.lux @@ -1,5 +1,5 @@ (.module: - [lux (#- type) + [lux (#- Type type) [abstract ["." monad (#+ do)]] [control @@ -18,18 +18,19 @@ ["." constant [pool (#+ Pool)]] [encoding - [name (#+ External)] ["." unsigned]] - [type - ["." category (#+ Value Return)] - ["." descriptor (#+ Descriptor)]]]]] + [type (#+ Type) + ["." category (#+ Class Value Return)]]]]] ["." // ["#." init] + ["#." implementation] ["/#" // #_ - ["#." arity] - ["#." field - ["#/." foreign] - ["#/." partial]] + [field + [constant + ["#." arity]] + [variable + ["#." foreign] + ["#." partial]]] ["/#" // #_ [runtime (#+ Operation)] ["#." value] @@ -39,32 +40,23 @@ ["." arity (#+ Arity)] ["." phase]]]]]) -(def: (arguments arity) - (-> Arity (List (Descriptor Value))) - (list.repeat (dec arity) ////value.type)) - -(def: #export (type environment arity) - (-> Environment Arity [(List (Descriptor Value)) - (Descriptor Return)]) - [(list@compose (///field/foreign.closure environment) - (if (arity.multiary? arity) - (list& ///arity.type (arguments arity)) - (list))) - descriptor.void]) +(def: #export (instance' foreign-setup class environment arity) + (-> (List (Instruction Any)) (Type Class) Environment Arity (Instruction Any)) + ($_ _.compose + (_.new class) + _.dup + (monad.seq _.monad foreign-setup) + (///partial.new arity) + (_.invokespecial class //init.name (//init.type environment arity)))) (def: #export (instance class environment arity) - (-> External Environment Arity (Operation (Instruction Any))) + (-> (Type Class) Environment Arity (Operation (Instruction Any))) (do phase.monad [foreign* (monad.map @ ////reference.variable environment)] - (wrap ($_ _.compose - (_.new class) - _.dup - (monad.seq _.monad foreign*) - (///field/partial.new arity) - (_.invokespecial class "<init>" (..type environment arity)))))) + (wrap (instance' foreign* class environment arity)))) (def: #export (method class environment arity) - (-> External Environment Arity (State Pool Method)) + (-> (Type Class) Environment Arity (State Pool Method)) (let [after-this (: (-> Nat Nat) (n.+ 1)) environment-size (list.size environment) @@ -72,22 +64,16 @@ (|>> after-this (n.+ environment-size))) after-arity (: (-> Nat Nat) (|>> after-environment (n.+ 1)))] - (method.method //.modifier "<init>" - (descriptor.method (..type environment arity)) + (method.method //.modifier //init.name + (//init.type environment arity) (list) ($_ _.compose ////reference.this - (//init.instruction environment-size arity) + (//init.super environment-size arity) (monad.map _.monad (function (_ register) - ($_ _.compose - ////reference.this - (_.aload (unsigned.u1 (after-this register))) - (_.putfield class (////reference.foreign-name register) ////value.type))) + (///foreign.put class register (_.aload (unsigned.u1 (after-this register))))) (list.indices environment-size)) (monad.map _.monad (function (_ register) - ($_ _.compose - ////reference.this - (_.aload (unsigned.u1 (after-arity register))) - (_.putfield class (////reference.partial-name register) ////value.type))) + (///partial.put class register (_.aload (unsigned.u1 (after-arity register))))) (list.indices (n.- ///arity.minimum arity))) _.areturn)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/reset.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/reset.lux index e43fd1b9b..2eab6933b 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/reset.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/reset.lux @@ -1,60 +1,49 @@ (.module: - [lux (#- type) - [abstract - ["." monad]] + [lux (#- Type type) [control [state (#+ State)]] [data [collection - ["." list]]] + ["." list ("#@." functor)]]] [target [jvm - [modifier (#+ Modifier)] ["." method (#+ Method)] - ["_" instruction] + ["_" instruction (#+ Instruction)] [constant [pool (#+ Pool)]] - [encoding - [name (#+ External)]] - [type - ["." category] - ["." descriptor (#+ Descriptor)]]]]] + ["." type (#+ Type) + ["." category (#+ Class)]]]]] ["." // ["#." new] ["/#" // #_ - ["#." arity] - ["#." field - ["#/." partial]] + [field + [variable + ["#." foreign]]] ["/#" // #_ - ["#." value] ["#." reference] [//// [analysis (#+ Environment)] - [reference (#+ Register)] ["." arity (#+ Arity)]]]]]) (def: #export name "reset") -(def: #export type - (-> External (Descriptor category.Method)) - (|>> descriptor.class [(list)] descriptor.method)) +(def: #export (type class) + (-> (Type Class) (Type category.Method)) + (type.method [(list) class (list)])) + +(def: (current-environment class) + (-> (Type Class) Environment (List (Instruction Any))) + (|>> list.size + list.indices + (list@map (///foreign.get class)))) (def: #export (method class environment arity) - (-> External Environment Arity (State Pool Method)) + (-> (Type Class) Environment Arity (State Pool Method)) (method.method //.modifier ..name (..type class) (list) ($_ _.compose (if (arity.multiary? arity) - ($_ _.compose - (_.new class) - _.dup - (monad.map _.monad (function (_ source) - ($_ _.compose - ////reference.this - (_.getfield class (////reference.foreign-name source) ////value.type))) - (list.indices (list.size environment))) - (///field/partial.new arity) - (_.invokespecial class "<init>" (//new.type environment arity))) + (//new.instance' (..current-environment class environment) class environment arity) ////reference.this) _.areturn))) |