Automatically handling input/output conversions for methods in new JVM compiler.

1 files changed, 150 insertions, 72 deletions

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 [<object> <primitive>]
-                      [(and (text@= (reflection.reflection (type.reflection <primitive>))
+                      [(and (text\= (reflection.reflection (type.reflection <primitive>))
                                     from)
-                            (text@= <object>
+                            (text\= <object>
                                     to))
                        (wrap (|>> valueI (_.wrap <primitive>)))
 
-                       (and (text@= <object>
+                       (and (text\= <object>
                                     from)
-                            (text@= (reflection.reflection (type.reflection <primitive>))
+                            (text\= (reflection.reflection (type.reflection <primitive>))
                                     to))
                        (wrap (|>> valueI (_.unwrap <primitive>)))]
                       
@@ -731,10 +733,10 @@
   (..custom
    [($_ <>.and ..class <synthesis>.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 [<name> <invoke>]
@@ -743,15 +745,15 @@
      (..custom
       [($_ <>.and ..class <synthesis>.text ..return <synthesis>.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))
                       (<invoke> 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 "<init>" (type.method [(list) (list@map product.left inputsTI) type.void (list)]))))))]))
+                   (_.fuse (list\map product.right inputsTI))
+                   (_.INVOKESPECIAL class "<init>" (type.method [(list) (list\map product.left inputsTI) type.void (list)]))))))]))
 
 (def: member_bundle
   Bundle
@@ -806,6 +808,37 @@
   (Parser Argument)
   (<synthesis>.tuple (<>.and <synthesis>.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)])
   (<synthesis>.tuple
@@ -820,14 +853,16 @@
       arguments (<synthesis>.tuple (<>.some ..argument))
       returnT ..return
       exceptionsT (<synthesis>.tuple (<>.some ..class))
-      [environment _ _ body] (<synthesis>.function 1
-                               (<synthesis>.loop (<>.exactly 0 <synthesis>.any)
-                                 (<synthesis>.tuple <synthesis>.any)))]
+      [environment _ _ body] (<| (<synthesis>.function 1)
+                                 (<synthesis>.loop (<>.exactly 0 <synthesis>.any))
+                                 <synthesis>.tuple
+                                 (<>.after <synthesis>.any)
+                                 <synthesis>.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 [<tag>]
         [(<tag> [[test then] elses])
          (<tag> [[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 "<init>" (anonymous_init_method env)
                  (|>> (_.ALOAD 0)
-                      ((_.fuse (list@map product.right inputsTI)))
-                      (_.INVOKESPECIAL super_class "<init>" (type.method [(list) (list@map product.left inputsTI) type.void (list)]))
+                      ((_.fuse (list\map product.right inputsTI)))
+                      (_.INVOKESPECIAL super_class "<init>" (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 "<init>" (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 <shift> <load> <type>)
+                   [[(n.+ <shift> jvm_register)
+                     (|>> (<load> jvm_register)
+                          (_.wrap <type>)
+                          (_.ASTORE lux_register))]]]
+      (`` (cond (~~ (template [<shift> <load> <type>]
+                      [(\ type.equivalence = <type> argumentT)
+                       (wrap_primitive <shift> <load> <type>)]
+
+                      [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 <return> <type>)
+                     [(|>> (_.unwrap <type>)
+                           <return>)]]
+        (`` (cond (~~ (template [<return> <type>]
+                        [(\ type.equivalence = <type> returnT)
+                         (unwrap_primitive <return> <type>)]
+
+                        [_.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)