diff options
Diffstat (limited to 'new-luxc/source')
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/function.lux | 85 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux | 239 |
2 files changed, 166 insertions, 158 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm/function.lux b/new-luxc/source/luxc/lang/translation/jvm/function.lux index ae876c3fc..d0764796f 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/function.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/function.lux @@ -9,13 +9,13 @@ ["." text format] [collection - ["." list ("#/." functor monoid)]]] + ["." list ("#@." functor monoid)]]] [target - [jvm - ["." type (#+ Type Method)]]] + ["." jvm #_ + ["#" type (#+ Type Method)]]] [tool [compiler - [analysis (#+ Arity)] + [analysis (#+ Arity Environment)] [synthesis (#+ Synthesis Abstraction Apply)] ["_." reference (#+ Register Variable)] ["." phase @@ -30,9 +30,8 @@ ["." runtime] ["." reference]]) - (def: arity-field Text "arity") -(def: $Object Type (type.class "java.lang.Object" (list))) +(def: $Object Type (jvm.class "java.lang.Object" (list))) (def: (poly-arg? arity) (-> Arity Bit) @@ -40,29 +39,29 @@ (def: (reset-method class) (-> Text Method) - (type.method (list) (#.Some (type.class class (list))) (list))) + (jvm.method (list) (#.Some (jvm.class class (list))) (list))) (def: (captured-args env) - (-> (List Variable) (List Type)) + (-> Environment (List Type)) (list.repeat (list.size env) $Object)) (def: (init-method env arity) - (-> (List Variable) Arity Method) + (-> Environment 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)))) + (jvm.method (list.concat (list (captured-args env) + (list jvm.int) + (list.repeat (dec arity) $Object))) + #.None + (list)) + (jvm.method (captured-args env) #.None (list)))) (def: (implementation-method arity) - (type.method (list.repeat arity $Object) (#.Some $Object) (list))) + (jvm.method (list.repeat arity $Object) (#.Some $Object) (list))) (def: get-amount-of-partialsI Inst (|>> (_.ALOAD 0) - (_.GETFIELD //.function-class runtime.partials-field type.int))) + (_.GETFIELD //.function-class runtime.partials-field jvm.int))) (def: (load-fieldI class field) (-> Text Text Inst) @@ -72,7 +71,7 @@ (def: (inputsI start amount) (-> Register Nat Inst) (|> (list.n/range start (n/+ start (dec amount))) - (list/map _.ALOAD) + (list@map _.ALOAD) _.fuse)) (def: (applysI start amount) @@ -97,24 +96,24 @@ (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: #export with-environment + (-> Environment Def) + (|>> list.enumerate + (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) + (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)) + (-> Text Arity Environment (Operation Inst)) (do phase.monad [captureI+ (monad.map @ reference.variable env) #let [argsI (if (poly-arg? arity) @@ -129,14 +128,14 @@ (_.INVOKESPECIAL class "<init>" (init-method env arity) #0))))) (def: (with-reset class arity env) - (-> Text Arity (List Variable) Def) + (-> Text Arity Environment 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) + (list@map (.function (_ source) (|>> (_.ALOAD 0) (_.GETFIELD class (reference.foreign-name source) $Object)))) _.fuse) @@ -161,7 +160,7 @@ (def: function-init-method Method - (type.method (list type.int) #.None (list))) + (jvm.method (list jvm.int) #.None (list))) (def: (function-init arity env-size) (-> Arity Nat Inst) @@ -172,21 +171,21 @@ (_.INVOKESPECIAL //.function-class "<init>" function-init-method #0)))) (def: (with-init class env arity) - (-> Text (List Variable) Arity Def) + (-> Text Environment 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) + (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) + (list@map (.function (_ idx) (let [register (offset-partial idx)] (|>> (_.ALOAD 0) (_.ALOAD (inc register)) @@ -201,18 +200,18 @@ _.RETURN)))) (def: (with-apply class env function-arity @begin bodyI apply-arity) - (-> Text (List Variable) Arity Label Inst Arity + (-> Text Environment Arity Label Inst Arity Def) (let [num-partials (dec function-arity) @default ($.new-label []) - @labels (list/map $.new-label (list.repeat num-partials [])) + @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)) + casesI (|> (list@compose @labels (list @default)) (list.zip2 (list.n/range 0 num-partials)) - (list/map (.function (_ [stage @label]) + (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))) + (list@map (|>> reference.partial-name (load-fieldI class))) _.fuse) function.identity)] (cond (i/= arity-over-extent (.int stage)) @@ -242,7 +241,7 @@ load-capturedI (|> (case env-size 0 (list) _ (list.n/range 0 (dec env-size))) - (list/map (|>> reference.foreign-name (load-fieldI class))) + (list@map (|>> reference.foreign-name (load-fieldI class))) _.fuse)] (|>> (_.label @label) (_.NEW class) @@ -262,20 +261,20 @@ (_.TABLESWITCH +0 (|> num-partials dec .int) @default @labels) casesI - (_.INVOKESTATIC //.runtime-class "apply_fail" (type.method (list) #.None (list)) #0) + (_.INVOKESTATIC //.runtime-class "apply_fail" (jvm.method (list) #.None (list)) #0) _.NULL _.ARETURN )))) (def: #export (with-function @begin class env arity bodyI) - (-> Label Text (List Variable) Arity Inst + (-> Label Text Environment 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@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) @@ -284,7 +283,7 @@ _.ARETURN)))) functionD (: Def (|>> (def.int-field #$.Public ($_ $.++F $.staticF $.finalF) arity-field (.int arity)) - (with-captured env) + (with-environment env) (with-partial arity) (with-init class env arity) (with-reset class arity env) @@ -323,7 +322,7 @@ [functionI (translate functionS) argsI (monad.map @ translate argsS) #let [applyI (|> (segment runtime.num-apply-variants argsI) - (list/map (.function (_ chunkI+) + (list@map (.function (_ chunkI+) (|>> (_.CHECKCAST //.function-class) (_.fuse chunkI+) (_.INVOKEVIRTUAL //.function-class runtime.apply-method (runtime.apply-signature (list.size chunkI+)) #0)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux index 55798c806..be2a0bace 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux @@ -31,6 +31,8 @@ ["." generation [extension (#+ Nullary Unary Binary nullary unary binary)]] + [analysis + [".A" reference]] ["." extension ["." bundle] [analysis @@ -39,17 +41,27 @@ [luxc [lang [host - ["$" jvm (#+ Label Inst Handler Bundle Operation Phase) + ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase) ["_" inst] - ["_." def]]]]]) + ["_." def]]]]] + ["." /// #_ + ["#." reference] + ["#." function]]) -(template [<name>] - [(exception: #export (<name> {message Text}) - message)] +(exception: #export invalid-syntax-for-argument-generation) - [invalid-syntax-for-jvm-type] - [invalid-syntax-for-argument-generation] - ) +(def: (custom [parser handler]) + (All [s] + (-> [(<s>.Parser s) + (-> Text Phase s (Operation Inst))] + Handler)) + (function (_ extension-name phase input) + (case (<s>.run input parser) + (#error.Success input') + (handler extension-name phase input') + + (#error.Failure error) + (phase.throw extension.invalid-syntax [extension-name %synthesis input])))) (template [<name> <inst>] [(def: <name> @@ -306,7 +318,17 @@ "char" jvm.char _ (jvm.class elem-class (list))))) -(def: (array::length extension-name generate inputs) +(def: (primitive-array-length-handler jvm-primitive) + (-> Type Handler) + (..custom [<s>.any + (function (_ extension-name generate arrayS) + (do phase.monad + [arrayI (generate arrayS)] + (wrap (|>> arrayI + (_.CHECKCAST (jvm.descriptor (jvm.array 1 jvm-primitive))) + _.ARRAYLENGTH))))])) + +(def: (array::length::object extension-name generate inputs) Handler (case inputs (^ (list (synthesis.i64 nesting) @@ -427,7 +449,17 @@ Bundle (<| (bundle.prefix "array") (|> bundle.empty - (bundle.install "length" array::length) + (dictionary.merge (<| (bundle.prefix "length") + (|> bundle.empty + (bundle.install "boolean" (primitive-array-length-handler jvm.boolean)) + (bundle.install "byte" (primitive-array-length-handler jvm.byte)) + (bundle.install "short" (primitive-array-length-handler jvm.short)) + (bundle.install "int" (primitive-array-length-handler jvm.int)) + (bundle.install "long" (primitive-array-length-handler jvm.long)) + (bundle.install "float" (primitive-array-length-handler jvm.float)) + (bundle.install "double" (primitive-array-length-handler jvm.double)) + (bundle.install "char" (primitive-array-length-handler jvm.char)) + (bundle.install "object" array::length::object)))) (dictionary.merge (<| (bundle.prefix "new") (|> bundle.empty (bundle.install "boolean" (new-primitive-array-handler jvm.boolean)) @@ -671,62 +703,30 @@ _ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) -(def: base-type - (<t>.Parser Type) - ($_ <>.either - (<>.after (<t>.this "boolean") (<>@wrap jvm.boolean)) - (<>.after (<t>.this "byte") (<>@wrap jvm.byte)) - (<>.after (<t>.this "short") (<>@wrap jvm.short)) - (<>.after (<t>.this "int") (<>@wrap jvm.int)) - (<>.after (<t>.this "long") (<>@wrap jvm.long)) - (<>.after (<t>.this "float") (<>@wrap jvm.float)) - (<>.after (<t>.this "double") (<>@wrap jvm.double)) - (<>.after (<t>.this "char") (<>@wrap jvm.char)) - (<>@map (function (_ name) - (jvm.class name (list))) - (<t>.many (<t>.none-of "["))) - )) - -(def: java-type - (<t>.Parser Type) - (do <>.monad - [raw base-type - nesting (<>.some (<t>.this "[]"))] - (wrap (jvm.array (list.size nesting) raw)))) - -(def: (generate-type argD) - (-> Text (Operation Type)) - (case (<t>.run java-type argD) - (#error.Failure error) - (phase.throw invalid-syntax-for-jvm-type argD) - - (#error.Success type) - (phase@wrap type))) - (def: (generate-arg generate argS) (-> (-> Synthesis (Operation Inst)) Synthesis (Operation [Type Inst])) (case argS (^ (synthesis.tuple (list (synthesis.text argD) argS))) (do phase.monad - [argD (phase.lift (:: error.monad map - jvm.reflection-class - (jvm.parse-signature argD))) - argT (generate-type argD) + [argT (phase.lift (<t>.run jvm.parse-signature argD)) argI (generate argS)] (wrap [argT argI])) _ - (phase.throw invalid-syntax-for-argument-generation ""))) + (phase.throw invalid-syntax-for-argument-generation []))) (def: (method-return-type description) (-> Text (Operation (Maybe Type))) (case description - "void" + (^ (static jvm.void-descriptor)) (phase@wrap #.None) _ - (phase@map (|>> #.Some) (generate-type description)))) + (|> description + (<t>.run jvm.parse-signature) + phase.lift + (phase@map (|>> #.Some))))) (def: (prepare-argI [type argI]) (-> [Type Inst] Inst) @@ -738,46 +738,35 @@ #.None argI)) -(def: (invoke::static extension-name generate inputs) +(def: invoke::static Handler - (case inputs - (^ (list& (synthesis.text class) - (synthesis.text method) - (synthesis.text unboxed) - argsS)) - (do phase.monad - [argsTI (monad.map @ (generate-arg generate) argsS) - returnT (method-return-type unboxed)] - (wrap (|>> (_.fuse (list@map ..prepare-argI argsTI)) - (_.INVOKESTATIC class method - (jvm.method (list@map product.left argsTI) returnT (list)) - false)))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) + (..custom + [($_ <>.and <s>.text <s>.text <s>.text (<>.some <s>.any)) + (function (_ extension-name generate [class method unboxed argsS]) + (do phase.monad + [argsTI (monad.map @ (generate-arg generate) argsS) + returnT (method-return-type unboxed)] + (wrap (|>> (_.fuse (list@map ..prepare-argI argsTI)) + (_.INVOKESTATIC class method + (jvm.method (list@map product.left argsTI) returnT (list)) + false)))))])) (template [<name> <invoke> <interface?>] - [(def: (<name> extension-name generate inputs) + [(def: <name> Handler - (case inputs - (^ (list& (synthesis.text class) - (synthesis.text method) - (synthesis.text unboxed) - objectS - argsS)) - (do phase.monad - [objectI (generate objectS) - argsTI (monad.map @ (generate-arg generate) argsS) - returnT (method-return-type unboxed)] - (wrap (|>> objectI - (_.CHECKCAST class) - (_.fuse (list@map ..prepare-argI argsTI)) - (<invoke> class method - (jvm.method (list@map product.left argsTI) returnT (list)) - <interface?>)))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))] + (..custom + [($_ <>.and <s>.text <s>.text <s>.text <s>.any (<>.some <s>.any)) + (function (_ extension-name generate [class method unboxed objectS argsS]) + (do phase.monad + [objectI (generate objectS) + argsTI (monad.map @ (generate-arg generate) argsS) + returnT (method-return-type unboxed)] + (wrap (|>> objectI + (_.CHECKCAST class) + (_.fuse (list@map ..prepare-argI argsTI)) + (<invoke> class method + (jvm.method (list@map product.left argsTI) returnT (list)) + <interface?>)))))]))] [invoke::virtual _.INVOKEVIRTUAL false] [invoke::special _.INVOKESPECIAL false] @@ -821,19 +810,6 @@ (bundle.install "constructor" invoke::constructor)))) ))) -(def: (custom [parser handler]) - (All [s] - (-> [(<s>.Parser s) - (-> Text Phase s (Operation Inst))] - Handler)) - (function (_ extension-name phase input) - (case (<s>.run input parser) - (#error.Success input') - (handler extension-name phase input') - - (#error.Failure error) - (phase.throw extension.invalid-syntax [extension-name %synthesis input])))) - (def: var (<s>.Parser Var) <s>.text) @@ -902,7 +878,7 @@ (def: return (<s>.Parser Return) - (<>.or (<s>.constant! ["" "void"]) + (<>.or (<s>.constant! ["" jvm.void-descriptor]) ..jvm-type)) (def: overriden-method-definition @@ -998,6 +974,39 @@ (#synthesis.Extension [name inputsS+]) (#synthesis.Extension [name (list@map recur inputsS+)])))) +(def: $Object (jvm.class jvm.object-class (list))) + +(def: (anonymous-init-method env) + (-> Environment Method) + (jvm.method (list.repeat (list.size env) $Object) + #.None + (list))) + +(def: (with-anonymous-init class env) + (-> Text Environment Def) + (let [store-capturedI (|> env + list.size + list.indices + (list@map (.function (_ register) + (|>> (_.ALOAD 0) + (_.ALOAD (inc register)) + (_.PUTFIELD class (///reference.foreign-name register) $Object)))) + _.fuse)] + (_def.method #$.Public $.noneM "<init>" (anonymous-init-method env) + (|>> (_.ALOAD 0) + (_.INVOKESPECIAL jvm.object-class "<init>" (jvm.method (list) #.None (list)) #0) + store-capturedI + _.RETURN)))) + +(def: (anonymous-instance class env) + (-> Text Environment (Operation Inst)) + (do phase.monad + [captureI+ (monad.map @ ///reference.variable env)] + (wrap (|>> (_.NEW class) + _.DUP + (_.fuse captureI+) + (_.INVOKESPECIAL class "<init>" (anonymous-init-method env) #0))))) + (def: class::anonymous Handler (..custom @@ -1012,14 +1021,15 @@ constructor-args overriden-methods]) (do phase.monad - [#let [global-mapping (|> overriden-methods - ## Get all the environments. - (list@map product.left) - ## Combine them. - list@join - ## Remove duplicates. - (set.from-list reference.hash) - set.to-list + [#let [total-environment (|> overriden-methods + ## Get all the environments. + (list@map product.left) + ## Combine them. + list@join + ## Remove duplicates. + (set.from-list reference.hash) + set.to-list) + global-mapping (|> total-environment ## Give them names as "foreign" variables. list.enumerate (list@map (function (_ [id capture]) @@ -1043,14 +1053,13 @@ self-name arguments returnT exceptionsT (normalize-method-body local-mapping body)])) overriden-methods)] - ## _ (generation.save! true ["" function-class] - ## [function-class - ## (def.class #$.V1_6 #$.Public $.finalC - ## function-class (list) - ## ($.simple-class //.function-class) (list) - ## functionD)]) - _ (phase.throw extension.invalid-syntax ["YOLO-TRON" %synthesis (list)])] - (wrap _.DUP)))])) + _ (generation.save! true ["" class-name] + [class-name + (_def.class #$.V1_6 #$.Public $.finalC + class-name (list) + super-class super-interfaces + (|>> (///function.with-environment total-environment)))])] + (anonymous-instance class-name total-environment)))])) (def: bundle::class Bundle |