From 4248cc22881a7eaa8f74bc426f2b0ba284b23153 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 23 Jul 2021 01:05:41 -0400 Subject: Automatically handling input/output conversions for methods in new JVM compiler. --- .../luxc/lang/translation/jvm/extension/host.lux | 222 ++++++++++++++------- 1 file changed, 150 insertions(+), 72 deletions(-) (limited to 'lux-jvm/source/luxc/lang/translation/jvm/extension') diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux index e647bf71b..89c7053f9 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux @@ -7,21 +7,23 @@ [control ["." exception (#+ exception:)] ["." function] - ["<>" parser ("#@." monad) + ["<>" parser ("#\." monad) ["<.>" text] ["<.>" synthesis (#+ Parser)]]] [data ["." product] - ["." maybe ("#@." functor)] - ["." text ("#@." equivalence) + ["." maybe ("#\." functor)] + ["." text ("#\." equivalence) ["%" format (#+ format)]] [collection - ["." list ("#@." monad)] + ["." list ("#\." monad fold)] ["." dictionary (#+ Dictionary)] ["." set]]] + [macro + ["." template]] [math [number - ["." nat]]] + ["n" nat]]] [target [jvm ["." type (#+ Type Typed Argument) @@ -33,9 +35,9 @@ ["." parser]]]] [tool [compiler - ["." phase ("#@." monad)] + ["." phase ("#\." monad)] [reference (#+) - ["." variable (#+ Variable)]] + ["." variable (#+ Variable Register)]] [meta [archive (#+ Archive)]] [language @@ -568,15 +570,15 @@ (do phase.monad [valueI (generate archive valueS)] (`` (cond (~~ (template [ ] - [(and (text@= (reflection.reflection (type.reflection )) + [(and (text\= (reflection.reflection (type.reflection )) from) - (text@= + (text\= to)) (wrap (|>> valueI (_.wrap ))) - (and (text@= + (and (text\= from) - (text@= (reflection.reflection (type.reflection )) + (text\= (reflection.reflection (type.reflection )) to)) (wrap (|>> valueI (_.unwrap )))] @@ -731,10 +733,10 @@ (..custom [($_ <>.and ..class .text ..return (<>.some ..input)) (function (_ extension_name generate archive [class method outputT inputsTS]) - (do {@ phase.monad} - [inputsTI (monad.map @ (generate_input generate archive) inputsTS)] - (wrap (|>> (_.fuse (list@map product.right inputsTI)) - (_.INVOKESTATIC class method (type.method [(list) (list@map product.left inputsTI) outputT (list)])) + (do {! phase.monad} + [inputsTI (monad.map ! (generate_input generate archive) inputsTS)] + (wrap (|>> (_.fuse (list\map product.right inputsTI)) + (_.INVOKESTATIC class method (type.method [(list) (list\map product.left inputsTI) outputT (list)])) (prepare_output outputT)))))])) (template [ ] @@ -743,15 +745,15 @@ (..custom [($_ <>.and ..class .text ..return .any (<>.some ..input)) (function (_ extension_name generate archive [class method outputT objectS inputsTS]) - (do {@ phase.monad} + (do {! phase.monad} [objectI (generate archive objectS) - inputsTI (monad.map @ (generate_input generate archive) inputsTS)] + inputsTI (monad.map ! (generate_input generate archive) inputsTS)] (wrap (|>> objectI (_.CHECKCAST class) - (_.fuse (list@map product.right inputsTI)) + (_.fuse (list\map product.right inputsTI)) ( class method (type.method [(list) - (list@map product.left inputsTI) + (list\map product.left inputsTI) outputT (list)])) (prepare_output outputT)))))]))] @@ -766,12 +768,12 @@ (..custom [($_ <>.and ..class (<>.some ..input)) (function (_ extension_name generate archive [class inputsTS]) - (do {@ phase.monad} - [inputsTI (monad.map @ (generate_input generate archive) inputsTS)] + (do {! phase.monad} + [inputsTI (monad.map ! (generate_input generate archive) inputsTS)] (wrap (|>> (_.NEW class) _.DUP - (_.fuse (list@map product.right inputsTI)) - (_.INVOKESPECIAL class "" (type.method [(list) (list@map product.left inputsTI) type.void (list)]))))))])) + (_.fuse (list\map product.right inputsTI)) + (_.INVOKESPECIAL class "" (type.method [(list) (list\map product.left inputsTI) type.void (list)]))))))])) (def: member_bundle Bundle @@ -806,6 +808,37 @@ (Parser Argument) (.tuple (<>.and .text ..value))) +(def: #export (hidden_method_body arity body) + (-> Nat Synthesis Synthesis) + (case [arity body] + [0 _] body + [1 _] body + + [2 (#synthesis.Control (#synthesis.Branch (#synthesis.Let _ 2 hidden)))] + hidden + + [_ (#synthesis.Control (#synthesis.Branch (#synthesis.Case _ path)))] + (loop [path path] + (case path + (^or #synthesis.Pop + (#synthesis.Access _) + (#synthesis.Bind _) + (#synthesis.Bit_Fork _) + (#synthesis.I64_Fork _) + (#synthesis.F64_Fork _) + (#synthesis.Text_Fork _) + (#synthesis.Alt _)) + body + + (#synthesis.Seq _ next) + (recur next) + + (#synthesis.Then hidden) + hidden)) + + _ + body)) + (def: overriden_method_definition (Parser [(Environment Synthesis) (/.Overriden_Method Synthesis)]) (.tuple @@ -820,14 +853,16 @@ arguments (.tuple (<>.some ..argument)) returnT ..return exceptionsT (.tuple (<>.some ..class)) - [environment _ _ body] (.function 1 - (.loop (<>.exactly 0 .any) - (.tuple .any)))] + [environment _ _ body] (<| (.function 1) + (.loop (<>.exactly 0 .any)) + .tuple + (<>.after .any) + .any)] (wrap [environment [ownerT name strict_fp? annotations vars self_name arguments returnT exceptionsT - body]])))) + (..hidden_method_body (list.size arguments) body)]])))) (def: (normalize_path normalize) (-> (-> Synthesis Synthesis) @@ -851,12 +886,12 @@ [#synthesis.Access]) (#synthesis.Bit_Fork when then else) - (#synthesis.Bit_Fork when (recur then) (maybe@map recur else)) + (#synthesis.Bit_Fork when (recur then) (maybe\map recur else)) (^template [] [( [[test then] elses]) ( [[test (recur then)] - (list@map (function (_ [else_test else_then]) + (list\map (function (_ [else_test else_then]) [else_test (recur else_then)]) elses)])]) ([#synthesis.I64_Fork] @@ -878,7 +913,7 @@ (synthesis.variant [lefts right? (recur sub)]) (^ (synthesis.tuple members)) - (synthesis.tuple (list@map recur members)) + (synthesis.tuple (list\map recur members)) (^ (synthesis.variable var)) (|> mapping @@ -899,13 +934,13 @@ (synthesis.branch/get [path (recur recordS)]) (^ (synthesis.loop/scope [offset initsS+ bodyS])) - (synthesis.loop/scope [offset (list@map recur initsS+) (recur bodyS)]) + (synthesis.loop/scope [offset (list\map recur initsS+) (recur bodyS)]) (^ (synthesis.loop/recur updatesS+)) - (synthesis.loop/recur (list@map recur updatesS+)) + (synthesis.loop/recur (list\map recur updatesS+)) (^ (synthesis.function/abstraction [environment arity bodyS])) - (synthesis.function/abstraction [(list@map (function (_ captured) + (synthesis.function/abstraction [(list\map (function (_ captured) (case captured (^ (synthesis.variable var)) (|> mapping @@ -920,10 +955,10 @@ bodyS]) (^ (synthesis.function/apply [functionS inputsS+])) - (synthesis.function/apply [(recur functionS) (list@map recur inputsS+)]) + (synthesis.function/apply [(recur functionS) (list\map recur inputsS+)]) (#synthesis.Extension [name inputsS+]) - (#synthesis.Extension [name (list@map recur inputsS+)])))) + (#synthesis.Extension [name (list\map recur inputsS+)])))) (def: $Object (type.class "java.lang.Object" (list))) @@ -940,27 +975,68 @@ (let [store_capturedI (|> env list.size list.indices - (list@map (.function (_ register) + (list\map (.function (_ register) (|>> (_.ALOAD 0) (_.ALOAD (inc register)) (_.PUTFIELD class (///reference.foreign_name register) $Object)))) _.fuse)] (_def.method #$.Public $.noneM "" (anonymous_init_method env) (|>> (_.ALOAD 0) - ((_.fuse (list@map product.right inputsTI))) - (_.INVOKESPECIAL super_class "" (type.method [(list) (list@map product.left inputsTI) type.void (list)])) + ((_.fuse (list\map product.right inputsTI))) + (_.INVOKESPECIAL super_class "" (type.method [(list) (list\map product.left inputsTI) type.void (list)])) store_capturedI _.RETURN)))) (def: (anonymous_instance generate archive class env) (-> Phase Archive (Type Class) (Environment Synthesis) (Operation Inst)) - (do {@ phase.monad} - [captureI+ (monad.map @ (generate archive) env)] + (do {! phase.monad} + [captureI+ (monad.map ! (generate archive) env)] (wrap (|>> (_.NEW class) _.DUP (_.fuse captureI+) (_.INVOKESPECIAL class "" (anonymous_init_method env)))))) +(def: (prepare_argument lux_register argumentT jvm_register) + (-> Register (Type Value) Register [Register Inst]) + (case (type.primitive? argumentT) + (#.Left argumentT) + [(n.+ 1 jvm_register) + (if (n.= lux_register jvm_register) + (|>>) + (|>> (_.ALOAD jvm_register) + (_.ASTORE lux_register)))] + + (#.Right argumentT) + (template.let [(wrap_primitive ) + [[(n.+ jvm_register) + (|>> ( jvm_register) + (_.wrap ) + (_.ASTORE lux_register))]]] + (`` (cond (~~ (template [ ] + [(\ type.equivalence = argumentT) + (wrap_primitive )] + + [1 _.ILOAD type.boolean] + [1 _.ILOAD type.byte] + [1 _.ILOAD type.short] + [1 _.ILOAD type.int] + [1 _.ILOAD type.char] + [1 _.FLOAD type.float] + [2 _.LLOAD type.long])) + + ## (\ type.equivalence = type.double argumentT) + (wrap_primitive 2 _.DLOAD type.double)))))) + +(def: #export (prepare_arguments offset types) + (-> Nat (List (Type Value)) Inst) + (|> types + list.enumeration + (list\fold (function (_ [lux_register type] [jvm_register before]) + (let [[jvm_register' after] (prepare_argument (n.+ offset lux_register) type jvm_register)] + [jvm_register' (|>> before after)])) + (: [Register Inst] [offset (|>>)])) + product.right)) + (def: #export (returnI returnT) (-> (Type Return) Inst) (case (type.void? returnT) @@ -979,21 +1055,23 @@ _.ARETURN) (#.Right returnT) - (cond (or (\ type.equivalence = type.boolean returnT) - (\ type.equivalence = type.byte returnT) - (\ type.equivalence = type.short returnT) - (\ type.equivalence = type.int returnT) - (\ type.equivalence = type.char returnT)) - _.IRETURN - - (\ type.equivalence = type.long returnT) - _.LRETURN - - (\ type.equivalence = type.float returnT) - _.FRETURN - - ## (\ type.equivalence = type.double returnT) - _.DRETURN)))) + (template.let [(unwrap_primitive ) + [(|>> (_.unwrap ) + )]] + (`` (cond (~~ (template [ ] + [(\ type.equivalence = returnT) + (unwrap_primitive )] + + [_.IRETURN type.boolean] + [_.IRETURN type.byte] + [_.IRETURN type.short] + [_.IRETURN type.int] + [_.IRETURN type.char] + [_.FRETURN type.float] + [_.LRETURN type.long])) + + ## (\ type.equivalence = type.double returnT) + (unwrap_primitive _.DRETURN type.double))))))) (def: class::anonymous Handler @@ -1007,33 +1085,33 @@ super_interfaces inputsTS overriden_methods]) - (do {@ phase.monad} + (do {! phase.monad} [[context _] (generation.with_new_context archive (wrap [])) #let [[module_id artifact_id] context anonymous_class_name (///.class_name context) class (type.class anonymous_class_name (list)) total_environment (|> overriden_methods ## Get all the environments. - (list@map product.left) + (list\map product.left) ## Combine them. - list@join + list\join ## Remove duplicates. (set.from_list synthesis.hash) set.to_list) global_mapping (|> total_environment ## Give them names as "foreign" variables. list.enumeration - (list@map (function (_ [id capture]) + (list\map (function (_ [id capture]) [capture (#variable.Foreign id)])) (dictionary.from_list synthesis.hash)) - normalized_methods (list@map (function (_ [environment + normalized_methods (list\map (function (_ [environment [ownerT name strict_fp? annotations vars self_name arguments returnT exceptionsT body]]) (let [local_mapping (|> environment list.enumeration - (list@map (function (_ [foreign_id capture]) + (list\map (function (_ [foreign_id capture]) [(synthesis.variable/foreign foreign_id) (|> global_mapping (dictionary.get capture) @@ -1044,26 +1122,26 @@ self_name arguments returnT exceptionsT (normalize_method_body local_mapping body)])) overriden_methods)] - inputsTI (monad.map @ (generate_input generate archive) inputsTS) + inputsTI (monad.map ! (generate_input generate archive) inputsTS) method_definitions (|> normalized_methods - (monad.map @ (function (_ [ownerT name - strict_fp? annotations vars + (monad.map ! (function (_ [ownerT name + strict_fp? annotations varsT self_name arguments returnT exceptionsT bodyS]) - (do @ + (do ! [bodyG (generation.with_context artifact_id - (generate archive bodyS))] + (generate archive bodyS)) + #let [argumentsT (list\map product.right arguments)]] (wrap (_def.method #$.Public (if strict_fp? ($_ $.++M $.finalM $.strictM) $.finalM) name - (type.method [vars - (list@map product.right arguments) - returnT - exceptionsT]) - (|>> bodyG (returnI returnT))))))) - (\ @ map _def.fuse)) + (type.method [varsT argumentsT returnT exceptionsT]) + (|>> (prepare_arguments 1 argumentsT) + bodyG + (returnI returnT))))))) + (\ ! map _def.fuse)) #let [directive [anonymous_class_name (_def.class #$.V1_6 #$.Public $.finalC anonymous_class_name (list) -- cgit v1.2.3