Falling back to using the old method of JVM generation while I properly debug and optimize the new one.

4 files changed, 257 insertions, 24 deletions

diff --git a/new-luxc/source/luxc/lang/translation/jvm.lux b/new-luxc/source/luxc/lang/translation/jvm.lux
new file mode 100644
index 000000000..fccbd14bf
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm.lux
@@ -0,0 +1,154 @@
+(.module:
+  [lux (#- Definition)
+   ["." host (#+ import: do-to object)]
+   [abstract
+    [monad (#+ do)]]
+   [control
+    pipe
+    ["." try (#+ Try)]
+    ["." exception (#+ exception:)]
+    ["." io (#+ IO io)]
+    [concurrency
+     ["." atom (#+ Atom atom)]]]
+   [data
+    [binary (#+ Binary)]
+    ["." product]
+    ["." text ("#@." hash)
+     ["%" format (#+ format)]]
+    [collection
+     ["." array]
+     ["." dictionary (#+ Dictionary)]]]
+   [target
+    [jvm
+     ["." loader (#+ Library)]
+     ["." type
+      ["." descriptor]]]]
+   [tool
+    [compiler
+     ["." name]]]]
+  [///
+   [host
+    ["." jvm (#+ Inst Definition Host State)
+     ["." def]
+     ["." inst]]]]
+  )
+
+(import: org/objectweb/asm/Label)
+
+(import: java/lang/reflect/Field
+  (get [#? Object] #try #? Object))
+
+(import: (java/lang/Class a)
+  (getField [String] #try Field))
+
+(import: java/lang/Object
+  (getClass [] (Class Object)))
+
+(import: java/lang/ClassLoader)
+
+(type: #export ByteCode Binary)
+
+(def: #export value-field Text "_value")
+(def: #export $Value (type.class "java.lang.Object" (list)))
+
+(exception: #export (cannot-load {class Text} {error Text})
+  (exception.report
+   ["Class" class]
+   ["Error" error]))
+
+(exception: #export (invalid-field {class Text} {field Text} {error Text})
+  (exception.report
+   ["Class" class]
+   ["Field" field]
+   ["Error" error]))
+
+(exception: #export (invalid-value {class Text})
+  (exception.report
+   ["Class" class]))
+
+(def: (class-value class-name class)
+  (-> Text (Class Object) (Try Any))
+  (case (Class::getField ..value-field class)
+    (#try.Success field)
+    (case (Field::get #.None field)
+      (#try.Success ?value)
+      (case ?value
+        (#.Some value)
+        (#try.Success value)
+        
+        #.None
+        (exception.throw invalid-value class-name))
+      
+      (#try.Failure error)
+      (exception.throw cannot-load [class-name error]))
+    
+    (#try.Failure error)
+    (exception.throw invalid-field [class-name ..value-field error])))
+
+(def: class-path-separator ".")
+
+(def: (evaluate! library loader eval-class valueI)
+  (-> Library ClassLoader Text Inst (Try [Any Definition]))
+  (let [bytecode-name (text.replace-all class-path-separator .module-separator eval-class)
+        bytecode (def.class #jvm.V1_6
+                            #jvm.Public jvm.noneC
+                            bytecode-name
+                            (list) $Value
+                            (list)
+                            (|>> (def.field #jvm.Public ($_ jvm.++F jvm.finalF jvm.staticF)
+                                            ..value-field ..$Value)
+                                 (def.method #jvm.Public ($_ jvm.++M jvm.staticM jvm.strictM)
+                                             "<clinit>"
+                                             (type.method [(list) type.void (list)])
+                                             (|>> valueI
+                                                  (inst.PUTSTATIC (type.class bytecode-name (list)) ..value-field ..$Value)
+                                                  inst.RETURN))))]
+    (io.run (do (try.with io.monad)
+              [_ (loader.store eval-class bytecode library)
+               class (loader.load eval-class loader)
+               value (:: io.monad wrap (class-value eval-class class))]
+              (wrap [value
+                     [eval-class bytecode]])))))
+
+(def: (execute! library loader temp-label [class-name class-bytecode])
+  (-> Library ClassLoader Text Definition (Try Any))
+  (io.run (do (try.with io.monad)
+            [existing-class? (|> (atom.read library)
+                                 (:: io.monad map (dictionary.contains? class-name))
+                                 (try.lift io.monad)
+                                 (: (IO (Try Bit))))
+             _ (if existing-class?
+                 (wrap [])
+                 (loader.store class-name class-bytecode library))]
+            (loader.load class-name loader))))
+
+(def: (define! library loader [module name] valueI)
+  (-> Library ClassLoader Name Inst (Try [Text Any Definition]))
+  (let [class-name (format (text.replace-all .module-separator class-path-separator module)
+                           class-path-separator (name.normalize name)
+                           "___" (%.nat (text@hash name)))]
+    (do try.monad
+      [[value definition] (evaluate! library loader class-name valueI)]
+      (wrap [class-name value definition]))))
+
+(def: #export host
+  (IO Host)
+  (io (let [library (loader.new-library [])
+            loader (loader.memory library)]
+        (: Host
+           (structure
+            (def: (evaluate! temp-label valueI)
+              (let [eval-class (|> temp-label name.normalize (text.replace-all " " "$"))]
+                (:: try.monad map product.left
+                    (..evaluate! library loader eval-class valueI))))
+            
+            (def: execute!
+              (..execute! library loader))
+            
+            (def: define!
+              (..define! library loader)))))))
+
+(def: #export $Variant (type.array ..$Value))
+(def: #export $Tuple (type.array ..$Value))
+(def: #export $Function (type.class "LuxFunction" (list)))
+(def: #export $Runtime (type.class "LuxRuntime" (list)))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/common.lux b/new-luxc/source/luxc/lang/translation/jvm/common.lux
index 8b2a83526..6cd7f4f2f 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/common.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/common.lux
@@ -1,24 +1,25 @@
 (.module:
   [lux #*
-   [abstract
-    [monad (#+ do)]]
-   [control
-    ["." try (#+ Try)]
-    ["ex" exception (#+ exception:)]
-    ["." io]]
-   [data
-    [binary (#+ Binary)]
-    ["." text ("#/." hash)
-     format]
-    [collection
-     ["." dictionary (#+ Dictionary)]]]
-   ["." macro]
-   [host (#+ import:)]
-   [tool
-    [compiler
-     [reference (#+ Register)]
-     ["." name]
-     ["." phase]]]]
+   ## [abstract
+   ##  [monad (#+ do)]]
+   ## [control
+   ##  ["." try (#+ Try)]
+   ##  ["ex" exception (#+ exception:)]
+   ##  ["." io]]
+   ## [data
+   ##  [binary (#+ Binary)]
+   ##  ["." text ("#/." hash)
+   ##   format]
+   ##  [collection
+   ##   ["." dictionary (#+ Dictionary)]]]
+   ## ["." macro]
+   ## [host (#+ import:)]
+   ## [tool
+   ##  [compiler
+   ##   [reference (#+ Register)]
+   ##   ["." name]
+   ##   ["." phase]]]
+   ]
   ## [luxc
   ##  [lang
   ##   [host
diff --git a/new-luxc/source/luxc/lang/translation/jvm/function.lux b/new-luxc/source/luxc/lang/translation/jvm/function.lux
index 34a4c890e..7a4bbef4e 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/function.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/function.lux
@@ -240,16 +240,12 @@
                                               (_.INVOKESPECIAL class "<init>" (init-method env function-arity))
                                               _.ARETURN))
                                        ))))
-                   _.fuse)
-        failureI (|>> (_.INVOKESTATIC //.$Runtime "apply_fail" (type.method [(list) type.void (list)]))
-                      _.NULL
-                      _.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
-                     failureI
                      ))))
 
 (def: #export with-environment
diff --git a/new-luxc/source/luxc/lang/translation/jvm/program.lux b/new-luxc/source/luxc/lang/translation/jvm/program.lux
new file mode 100644
index 000000000..7ac897009
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm/program.lux
@@ -0,0 +1,82 @@
+(.module:
+  [lux #*
+   [target
+    [jvm
+     ["$t" type]]]]
+  [luxc
+   [lang
+    [host
+     ["_" jvm
+      ["$d" def]
+      ["$i" inst]]]
+    [translation
+     ["." jvm
+      ["." runtime]]]]])
+
+(def: #export class "LuxProgram")
+
+(def: ^Object ($t.class "java.lang.Object" (list)))
+
+(def: #export (program programI)
+  (-> _.Inst _.Definition)
+  (let [nilI runtime.noneI
+        num-inputsI (|>> ($i.ALOAD 0) $i.ARRAYLENGTH)
+        decI (|>> ($i.int +1) $i.ISUB)
+        headI (|>> $i.DUP
+                   ($i.ALOAD 0)
+                   $i.SWAP
+                   $i.AALOAD
+                   $i.SWAP
+                   $i.DUP_X2
+                   $i.POP)
+        pairI (|>> ($i.int +2)
+                   ($i.ANEWARRAY ..^Object)
+                   $i.DUP_X1
+                   $i.SWAP
+                   ($i.int +0)
+                   $i.SWAP
+                   $i.AASTORE
+                   $i.DUP_X1
+                   $i.SWAP
+                   ($i.int +1)
+                   $i.SWAP
+                   $i.AASTORE)
+        consI (|>> ($i.int +1)
+                   ($i.string "")
+                   $i.DUP2_X1
+                   $i.POP2
+                   runtime.variantI)
+        prepare-input-listI (<| $i.with-label (function (_ @loop))
+                                $i.with-label (function (_ @end))
+                                (|>> nilI
+                                     num-inputsI
+                                     ($i.label @loop)
+                                     decI
+                                     $i.DUP
+                                     ($i.IFLT @end)
+                                     headI
+                                     pairI
+                                     consI
+                                     $i.SWAP
+                                     ($i.GOTO @loop)
+                                     ($i.label @end)
+                                     $i.POP))
+        feed-inputsI ($i.INVOKEVIRTUAL jvm.$Function runtime.apply-method (runtime.apply-signature 1))
+        run-ioI (|>> ($i.CHECKCAST jvm.$Function)
+                     $i.NULL
+                     ($i.INVOKEVIRTUAL jvm.$Function runtime.apply-method (runtime.apply-signature 1)))
+        main-type ($t.method [(list ($t.array ($t.class "java.lang.String" (list))))
+                              $t.void
+                              (list)])]
+    [..class
+     ($d.class #_.V1_6
+               #_.Public _.finalC
+               ..class
+               (list) ..^Object
+               (list)
+               (|>> ($d.method #_.Public _.staticM "main" main-type
+                               (|>> programI
+                                    prepare-input-listI
+                                    feed-inputsI
+                                    run-ioI
+                                    $i.RETURN))))]))