From 9eaaaf953ba7ce1eeb805603f4e113aa15f5178f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 8 Jan 2018 21:40:06 -0400 Subject: - Moved all translation code under the JVM path (in preparation for porting the JS back-end). --- .../luxc/lang/translation/jvm/function.jvm.lux | 325 +++++++++++++++++++++ 1 file changed, 325 insertions(+) create mode 100644 new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux (limited to 'new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux') diff --git a/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux new file mode 100644 index 000000000..6fb446bc4 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux @@ -0,0 +1,325 @@ +(.module: + lux + (lux (control [monad #+ do]) + (data [text] + text/format + (coll [list "list/" Functor Monoid])) + [macro]) + (luxc ["&" lang] + (lang [".L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["la" analysis] + ["ls" synthesis] + [".L" variable #+ Variable])) + (// [".T" common] + [".T" runtime] + [".T" reference])) + + +(def: arity-field Text "arity") +(def: $Object $.Type ($t.class "java.lang.Object" (list))) + +(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 Variable) (List $.Type)) + (list.repeat (list.size env) $Object)) + +(def: (init-method env arity) + (-> (List 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 hostL.function-class runtimeT.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))) + (list/map $i.ALOAD) + $i.fuse)) + +(def: (applysI start amount) + (-> $.Register Nat $.Inst) + (let [max-args (n/min amount runtimeT.num-apply-variants) + later-applysI (if (n/> runtimeT.num-apply-variants amount) + (applysI (n/+ runtimeT.num-apply-variants start) (n/- runtimeT.num-apply-variants amount)) + id)] + (|>> ($i.CHECKCAST hostL.function-class) + (inputsI start max-args) + ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.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 Variable) $.Def) + (|> (list.enumerate env) + (list/map (function [[env-idx env-source]] + ($d.field #$.Private $.finalF (referenceT.captured env-idx) $Object))) + $d.fuse)) + +(def: (with-partial arity) + (-> ls.Arity $.Def) + (if (poly-arg? arity) + (|> (list.n/range +0 (n/- +2 arity)) + (list/map (function [idx] + ($d.field #$.Private $.finalF (referenceT.partial idx) $Object))) + $d.fuse) + id)) + +(def: (instance class arity env) + (-> Text ls.Arity (List Variable) (Meta $.Inst)) + (do macro.Monad + [captureI+ (monad.map @ referenceT.translate-variable env) + #let [argsI (if (poly-arg? arity) + (|> (nullsI (n/dec arity)) + (list ($i.int 0)) + $i.fuse) + id)]] + (wrap (|>> ($i.NEW class) + $i.DUP + ($i.fuse captureI+) + argsI + ($i.INVOKESPECIAL class "" (init-method env arity) false))))) + +(def: (with-reset class arity env) + (-> Text ls.Arity (List 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))) + (list/map (function [source] + (|>> ($i.ALOAD +0) + ($i.GETFIELD class (referenceT.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-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 hostL.function-class "" function-init-method false)) + (|>> ($i.ILOAD (n/inc env-size)) + ($i.INVOKESPECIAL hostL.function-class "" function-init-method false)))) + +(def: (with-init class env arity) + (-> Text (List 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))) + (list/map (function [register] + (|>> ($i.ALOAD +0) + ($i.ALOAD (n/inc register)) + ($i.PUTFIELD class (referenceT.captured register) $Object)))) + $i.fuse) + store-partialI (if (poly-arg? arity) + (|> (list.n/range +0 (n/- +2 arity)) + (list/map (function [idx] + (let [register (offset-partial idx)] + (|>> ($i.ALOAD +0) + ($i.ALOAD (n/inc register)) + ($i.PUTFIELD class (referenceT.partial idx) $Object))))) + $i.fuse) + id)] + ($d.method #$.Public $.noneM "" (init-method env arity) + (|>> ($i.ALOAD +0) + (function-init arity env-size) + store-capturedI + store-partialI + $i.RETURN)))) + +(def: (with-apply class env function-arity @begin bodyI apply-arity) + (-> Text (List Variable) ls.Arity $.Label $.Inst ls.Arity + $.Def) + (let [num-partials (n/dec function-arity) + @default ($.new-label []) + @labels (list/map $.new-label (list.repeat num-partials [])) + arity-over-extent (|> (nat-to-int function-arity) (i/- (nat-to-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 (n/dec stage)) + (list/map (|>> referenceT.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))) + (list/map (|>> referenceT.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-method env function-arity) false) + $i.ARETURN)) + )))) + $i.fuse)] + ($d.method #$.Public $.noneM runtimeT.apply-method (runtimeT.apply-signature apply-arity) + (|>> get-amount-of-partialsI + ($i.TABLESWITCH 0 (|> num-partials n/dec nat-to-int) + @default @labels) + casesI + ($i.INVOKESTATIC hostL.runtime-class "apply_fail" ($t.method (list) #.None (list)) false) + $i.NULL + $i.ARETURN + )))) + +(def: #export (with-function @begin class env arity bodyI) + (-> $.Label Text (List Variable) ls.Arity $.Inst + (Meta [$.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 + ))] + (do macro.Monad + [instanceI (instance class arity env)] + (wrap [functionD instanceI])))) + +(def: #export (translate-function translate env arity bodyS) + (-> (-> ls.Synthesis (Meta $.Inst)) + (List Variable) ls.Arity ls.Synthesis + (Meta $.Inst)) + (do macro.Monad + [@begin $i.make-label + [function-class bodyI] (hostL.with-sub-context + (hostL.with-anchor [@begin +1] + (translate bodyS))) + this-module macro.current-module-name + #let [function-class (format (text.replace-all "/" "." this-module) "." function-class)] + [functionD instanceI] (with-function @begin function-class env arity bodyI) + _ (commonT.store-class function-class + ($d.class #$.V1_6 #$.Public $.finalC + function-class (list) + ($.simple-class hostL.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 (translate-call translate functionS argsS) + (-> (-> ls.Synthesis (Meta $.Inst)) + ls.Synthesis (List ls.Synthesis) + (Meta $.Inst)) + (do macro.Monad + [functionI (translate functionS) + argsI (monad.map @ translate argsS) + #let [applyI (|> (segment runtimeT.num-apply-variants argsI) + (list/map (function [chunkI+] + (|>> ($i.CHECKCAST hostL.function-class) + ($i.fuse chunkI+) + ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.apply-signature (list.size chunkI+)) false)))) + $i.fuse)]] + (wrap (|>> functionI + applyI)))) -- cgit v1.2.3