diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux')
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux | 330 |
1 files changed, 0 insertions, 330 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux deleted file mode 100644 index db8716697..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux +++ /dev/null @@ -1,330 +0,0 @@ -(.module: - [lux (#- function) - [abstract - ["." monad (#+ do)]] - [control - [pipe (#+ when> new>)] - ["." function]] - [data - ["." text - format] - [collection - ["." list ("#/." functor monoid)]]] - [tool - [compiler - [analysis (#+ Arity)] - [synthesis (#+ Synthesis Abstraction Apply)] - ["_." reference (#+ Register Variable)] - ["." phase - ["." generation]]]]] - [luxc - [lang - [host - ["$" jvm (#+ Label Inst Def Operation Phase) - ["." type] - ["." def] - ["_" inst]]]]] - ["." // - ["." runtime] - ["." reference]]) - - -(def: arity-field Text "arity") -(def: $Object $.Type (type.class "java.lang.Object" (list))) - -(def: (poly-arg? arity) - (-> Arity Bit) - (n/> 1 arity)) - -(def: (reset-method class) - (-> Text $.Method) - (type.method (list) (#.Some (type.class class (list))) (list))) - -(def: (captured-args env) - (-> (List Variable) (List $.Type)) - (list.repeat (list.size env) $Object)) - -(def: (init-method env arity) - (-> (List Variable) Arity $.Method) - (if (poly-arg? arity) - (type.method (list.concat (list (captured-args env) - (list type.int) - (list.repeat (dec arity) $Object))) - #.None - (list)) - (type.method (captured-args env) #.None (list)))) - -(def: (implementation-method arity) - (type.method (list.repeat arity $Object) (#.Some $Object) (list))) - -(def: get-amount-of-partialsI - Inst - (|>> (_.ALOAD 0) - (_.GETFIELD //.function-class runtime.partials-field type.int))) - -(def: (load-fieldI class field) - (-> Text Text Inst) - (|>> (_.ALOAD 0) - (_.GETFIELD class field $Object))) - -(def: (inputsI start amount) - (-> Register Nat Inst) - (|> (list.n/range start (n/+ start (dec amount))) - (list/map _.ALOAD) - _.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)) - function.identity)] - (|>> (_.CHECKCAST //.function-class) - (inputsI start max-args) - (_.INVOKEVIRTUAL //.function-class runtime.apply-method (runtime.apply-signature max-args) #0) - later-applysI))) - -(def: (inc-intI by) - (-> Nat Inst) - (|>> (_.int (.int by)) - _.IADD)) - -(def: (nullsI amount) - (-> Nat Inst) - (|> _.NULL - (list.repeat amount) - _.fuse)) - -(def: (with-captured env) - (-> (List Variable) Def) - (|> (list.enumerate env) - (list/map (.function (_ [env-idx env-source]) - (def.field #$.Private $.finalF (reference.foreign-name env-idx) $Object))) - def.fuse)) - -(def: (with-partial arity) - (-> Arity Def) - (if (poly-arg? arity) - (|> (list.n/range 0 (n/- 2 arity)) - (list/map (.function (_ idx) - (def.field #$.Private $.finalF (reference.partial-name idx) $Object))) - def.fuse) - function.identity)) - -(def: (instance class arity env) - (-> Text Arity (List Variable) (Operation Inst)) - (do phase.monad - [captureI+ (monad.map @ reference.variable env) - #let [argsI (if (poly-arg? arity) - (|> (nullsI (dec arity)) - (list (_.int +0)) - _.fuse) - function.identity)]] - (wrap (|>> (_.NEW class) - _.DUP - (_.fuse captureI+) - argsI - (_.INVOKESPECIAL class "<init>" (init-method env arity) #0))))) - -(def: (with-reset class arity env) - (-> Text Arity (List Variable) Def) - (def.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 (dec env-size))) - (list/map (.function (_ source) - (|>> (_.ALOAD 0) - (_.GETFIELD class (reference.foreign-name source) $Object)))) - _.fuse) - argsI (|> (nullsI (dec arity)) - (list (_.int +0)) - _.fuse)] - (|>> (_.NEW class) - _.DUP - captureI - argsI - (_.INVOKESPECIAL class "<init>" (init-method env arity) #0) - _.ARETURN)) - (|>> (_.ALOAD 0) - _.ARETURN)))) - -(def: (with-implementation arity @begin bodyI) - (-> Nat Label Inst Def) - (def.method #$.Public $.strictM "impl" (implementation-method arity) - (|>> (_.label @begin) - bodyI - _.ARETURN))) - -(def: function-init-method - $.Method - (type.method (list type.int) #.None (list))) - -(def: (function-init arity env-size) - (-> Arity Nat Inst) - (if (n/= 1 arity) - (|>> (_.int +0) - (_.INVOKESPECIAL //.function-class "<init>" function-init-method #0)) - (|>> (_.ILOAD (inc env-size)) - (_.INVOKESPECIAL //.function-class "<init>" function-init-method #0)))) - -(def: (with-init class env arity) - (-> Text (List Variable) Arity Def) - (let [env-size (list.size env) - offset-partial (: (-> Nat Nat) - (|>> inc (n/+ env-size))) - store-capturedI (|> (case env-size - 0 (list) - _ (list.n/range 0 (dec env-size))) - (list/map (.function (_ register) - (|>> (_.ALOAD 0) - (_.ALOAD (inc register)) - (_.PUTFIELD class (reference.foreign-name register) $Object)))) - _.fuse) - store-partialI (if (poly-arg? arity) - (|> (list.n/range 0 (n/- 2 arity)) - (list/map (.function (_ idx) - (let [register (offset-partial idx)] - (|>> (_.ALOAD 0) - (_.ALOAD (inc register)) - (_.PUTFIELD class (reference.partial-name idx) $Object))))) - _.fuse) - function.identity)] - (def.method #$.Public $.noneM "<init>" (init-method env arity) - (|>> (_.ALOAD 0) - (function-init arity env-size) - store-capturedI - store-partialI - _.RETURN)))) - -(def: (with-apply class env function-arity @begin bodyI apply-arity) - (-> Text (List Variable) Arity Label Inst Arity - Def) - (let [num-partials (dec function-arity) - @default ($.new-label []) - @labels (list/map $.new-label (list.repeat num-partials [])) - arity-over-extent (|> (.int function-arity) (i/- (.int apply-arity))) - casesI (|> (list/compose @labels (list @default)) - (list.zip2 (list.n/range 0 num-partials)) - (list/map (.function (_ [stage @label]) - (let [load-partialsI (if (n/> 0 stage) - (|> (list.n/range 0 (dec stage)) - (list/map (|>> reference.partial-name (load-fieldI class))) - _.fuse) - function.identity)] - (cond (i/= arity-over-extent (.int stage)) - (|>> (_.label @label) - (_.ALOAD 0) - (when> [(new> (n/> 0 stage) [])] - [(_.INVOKEVIRTUAL class "reset" (reset-method class) #0)]) - load-partialsI - (inputsI 1 apply-arity) - (_.INVOKEVIRTUAL class "impl" (implementation-method function-arity) #0) - _.ARETURN) - - (i/> arity-over-extent (.int stage)) - (let [args-to-completion (|> function-arity (n/- stage)) - args-left (|> apply-arity (n/- args-to-completion))] - (|>> (_.label @label) - (_.ALOAD 0) - (_.INVOKEVIRTUAL class "reset" (reset-method class) #0) - load-partialsI - (inputsI 1 args-to-completion) - (_.INVOKEVIRTUAL class "impl" (implementation-method function-arity) #0) - (applysI (inc args-to-completion) args-left) - _.ARETURN)) - - ## (i/< arity-over-extent (.int stage)) - (let [env-size (list.size env) - load-capturedI (|> (case env-size - 0 (list) - _ (list.n/range 0 (dec env-size))) - (list/map (|>> reference.foreign-name (load-fieldI class))) - _.fuse)] - (|>> (_.label @label) - (_.NEW class) - _.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))) - (_.INVOKESPECIAL class "<init>" (init-method env function-arity) #0) - _.ARETURN)) - )))) - _.fuse)] - (def.method #$.Public $.noneM runtime.apply-method (runtime.apply-signature apply-arity) - (|>> get-amount-of-partialsI - (_.TABLESWITCH +0 (|> num-partials dec .int) - @default @labels) - casesI - (_.INVOKESTATIC //.runtime-class "apply_fail" (type.method (list) #.None (list)) #0) - _.NULL - _.ARETURN - )))) - -(def: #export (with-function @begin class env arity bodyI) - (-> Label Text (List Variable) Arity Inst - (Operation [Def Inst])) - (let [env-size (list.size env) - applyD (: Def - (if (poly-arg? arity) - (|> (n/min arity runtime.num-apply-variants) - (list.n/range 1) - (list/map (with-apply class env arity @begin bodyI)) - (list& (with-implementation arity @begin bodyI)) - def.fuse) - (def.method #$.Public $.strictM runtime.apply-method (runtime.apply-signature 1) - (|>> (_.label @begin) - bodyI - _.ARETURN)))) - functionD (: Def - (|>> (def.int-field #$.Public ($_ $.++F $.staticF $.finalF) arity-field (.int arity)) - (with-captured env) - (with-partial arity) - (with-init class env arity) - (with-reset class arity env) - applyD - ))] - (do phase.monad - [instanceI (instance class arity env)] - (wrap [functionD instanceI])))) - -(def: #export (function translate [env arity bodyS]) - (-> Phase Abstraction (Operation Inst)) - (do phase.monad - [@begin _.make-label - [function-class bodyI] (generation.with-context - (generation.with-anchor [@begin 1] - (translate bodyS))) - [functionD instanceI] (with-function @begin function-class env arity bodyI) - _ (generation.save! ["" function-class] - [function-class - (def.class #$.V1_6 #$.Public $.finalC - function-class (list) - ($.simple-class //.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 (call translate [functionS argsS]) - (-> Phase Apply (Operation Inst)) - (do phase.monad - [functionI (translate functionS) - argsI (monad.map @ translate argsS) - #let [applyI (|> (segment runtime.num-apply-variants argsI) - (list/map (.function (_ chunkI+) - (|>> (_.CHECKCAST //.function-class) - (_.fuse chunkI+) - (_.INVOKEVIRTUAL //.function-class runtime.apply-method (runtime.apply-signature (list.size chunkI+)) #0)))) - _.fuse)]] - (wrap (|>> functionI - applyI)))) |