All the classes that used to be generated per function have now been folded into one.

2 files changed, 128 insertions, 81 deletions

diff --git a/src/lang.clj b/src/lang.clj
index f12ffc8d5..e602a21a6 100644
--- a/src/lang.clj
+++ b/src/lang.clj
@@ -11,10 +11,6 @@
     (.write stream data)))
 
 (comment
-  ;; TODO: Fold all closure classes into one.
-  ;; TODO: When doing partial application, skip "apply" and just call constructor appropiatedly.
-  ;; TODO: Add extra arities (apply2, apply3, ..., apply16)
-  ;; TODO: Tuple8 and Tuple8X (for arbitrary-size tuples).
   ;; TODO: Allow "lambdas" to be closures.
   ;; TODO: Add Java-interop.
   ;; TODO: Allow loading classes at runtime.
@@ -28,6 +24,9 @@
   ;; TODO: Add records.
   ;; TODO: throw, try, catch, finally
   ;; TODO: Finish implementing pattern matching.
+  ;; TODO: Tuple8 and Tuple8X (for arbitrary-size tuples).
+  ;; TODO: Add extra arities (apply2, apply3, ..., apply16)
+  ;; TODO: When doing partial application, skip "apply" and just call constructor appropiatedly.
   ;; TODO: 
   
   (let [source-code (slurp "test2.lang")
@@ -40,9 +39,5 @@
         class-data (&compiler/compile "test2" ann-syntax)]
     (write-file "test2.class" class-data))
 
-
-  
-  ;; ## (_. (_.. System out) (println "this\tis a\nstring"))
   ;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2
-
   )
diff --git a/src/lang/compiler.clj b/src/lang/compiler.clj
index 48cbe3999..5b14410b3 100644
--- a/src/lang/compiler.clj
+++ b/src/lang/compiler.clj
@@ -143,33 +143,39 @@
 (defcompiler ^:private compile-call
   [::&analyser/call ?fn ?args]
   (do ;; (prn 'compile-call (:form ?fn) ?fn ?args)
-    (match (:form ?fn)
-      [::&analyser/local _]
-      (do (compile-form (assoc *state* :form ?fn))
-        (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"]
-          (doseq [arg ?args]
-            (compile-form (assoc *state* :form arg))
-            (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "test2/Function" "apply" apply-signature))))
-      
-      [::&analyser/lambda _ ?body]
-      (do (compile-form (assoc *state* :form ?fn))
-        (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"]
-          (doseq [arg ?args]
-            (compile-form (assoc *state* :form arg))
-            (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "test2/Function" "apply" apply-signature))))
-      
-      [::&analyser/global ?owner-class ?fn-name]
-      (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"
-            signature "()V"
-            call-class (str (->class ?owner-class) "$" ?fn-name "_0")]
-        (doto *writer*
-          (.visitTypeInsn Opcodes/NEW call-class)
-          (.visitInsn Opcodes/DUP)
-          (.visitMethodInsn Opcodes/INVOKESPECIAL call-class "<init>" signature))
-        (doseq [arg ?args]
-          (compile-form (assoc *state* :form arg))
-          (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "test2/Function" "apply" apply-signature))
-        ))))
+      (match (:form ?fn)
+        [::&analyser/global ?owner-class ?fn-name]
+        (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"
+              clo-field-sig (->type-signature "java.lang.Object")
+              counter-sig "I"
+              num-args (count ?args)
+              signature (if (> (count ?args) 1)
+                          (str "(" (apply str counter-sig (repeat (dec num-args) clo-field-sig)) ")" "V")
+                          (str "()" "V"))
+              call-class (str (->class ?owner-class) "$" ?fn-name)]
+          (doto *writer*
+            (.visitTypeInsn Opcodes/NEW call-class)
+            (.visitInsn Opcodes/DUP)
+            (-> (doto (.visitLdcInsn (-> ?args count dec int))
+                  ;; (.visitInsn Opcodes/ICONST_0)
+                  (-> (do (compile-form (assoc *state* :form arg)))
+                      (->> (doseq [arg (butlast ?args)]))))
+                (->> (when (> (count ?args) 1))))
+            (.visitMethodInsn Opcodes/INVOKESPECIAL call-class "<init>" signature)
+            (do (compile-form (assoc *state* :form (last ?args))))
+            (.visitMethodInsn Opcodes/INVOKEINTERFACE "test2/Function" "apply" apply-signature))
+          ;; (doseq [arg ?args]
+          ;;   (compile-form (assoc *state* :form arg))
+          ;;   (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "test2/Function" "apply" apply-signature))
+          )
+        
+        _
+        (do (compile-form (assoc *state* :form ?fn))
+          (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"]
+            (doseq [arg ?args]
+              (compile-form (assoc *state* :form arg))
+              (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "test2/Function" "apply" apply-signature))))
+        )))
 
 (defcompiler ^:private compile-static-access
   [::&analyser/static-access ?class ?member]
@@ -263,55 +269,101 @@
 (defn ^:private compile-method-function [writer class-name fn-name num-args]
   (let [outer-class (->class class-name)
         clo-field-sig (->type-signature "java.lang.Object")
+        counter-sig "I"
         apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"
-        real-signature (str "(" (apply str (repeat num-args "Ljava/lang/Object;")) ")" "Ljava/lang/Object;")]
-    ;; (.mkdirs (java.io.File. class-name))
-    (doseq [idx (range num-args)
-            :let [has-next? (not= idx (dec num-args))
-                  local-name (str fn-name "_" idx)
-                  current-class (str outer-class "$" local-name)
-                  next-class (str outer-class "$" fn-name "_" (inc idx))
-                  current-signature (str "(" (apply str (repeat idx "Ljava/lang/Object;")) ")" "V")
-                  next-signature (str "(" (apply str (repeat (inc idx) "Ljava/lang/Object;")) ")" "V")]]
-      (.visitInnerClass writer current-class outer-class local-name (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC))
-      (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
-                     (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
-                             current-class nil "java/lang/Object" (into-array ["test2/Function"])))
-            _ (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" current-signature nil nil)
-                (.visitCode)
-                (.visitVarInsn Opcodes/ALOAD 0)
-                (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V")
-                (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
-                      (.visitVarInsn Opcodes/ALOAD (inc clo_idx))
-                      (.visitFieldInsn Opcodes/PUTFIELD current-class field-name clo-field-sig))
-                    (->> (let [field-name (str "_" clo_idx)]
-                           (doto (.visitField =class Opcodes/ACC_PUBLIC field-name clo-field-sig nil nil)
-                             (.visitEnd)))
-                         (dotimes [clo_idx idx])))
-                (.visitInsn Opcodes/RETURN)
-                (.visitMaxs 0 0)
-                (.visitEnd))
-            =method (doto (.visitMethod =class Opcodes/ACC_PUBLIC "apply" apply-signature nil nil)
-                      (.visitCode))
-            _ (do (when has-next?
-                    (doto =method
-                      (.visitTypeInsn Opcodes/NEW next-class)
-                      (.visitInsn Opcodes/DUP)))
-                (doto =method
-                  (-> (doto (.visitVarInsn Opcodes/ALOAD (int 0))
-                        (.visitFieldInsn Opcodes/GETFIELD current-class (str "_" clo_idx) clo-field-sig))
-                      (->> (dotimes [clo_idx idx])))
-                  (.visitVarInsn Opcodes/ALOAD (int 1)))
-                (if has-next?
-                  (.visitMethodInsn =method Opcodes/INVOKESPECIAL next-class "<init>" next-signature)
-                  (.visitMethodInsn =method Opcodes/INVOKESTATIC outer-class fn-name real-signature))
-                (doto =method
-                  (.visitInsn Opcodes/ARETURN)
+        real-signature (str "(" (apply str (repeat num-args clo-field-sig)) ")" "Ljava/lang/Object;")
+        current-class (str outer-class "$" fn-name)
+        num-captured (dec num-args)
+        init-signature (if (not= 0 num-captured)
+                         (str "(" (apply str counter-sig (repeat num-captured clo-field-sig)) ")" "V")
+                         (str "()" "V"))]
+    (.visitInnerClass writer current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC))
+    (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+                   (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
+                           current-class nil "java/lang/Object" (into-array ["test2/Function"]))
+                   (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) "_counter" counter-sig nil nil)
+                         (.visitEnd))
+                       (->> (when (not= 0 num-captured)))))
+          =init (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" init-signature nil nil)
+                  (.visitCode)
+                  (.visitVarInsn Opcodes/ALOAD 0)
+                  (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V")
+                  (-> (doto ;; (.visitFieldInsn Opcodes/GETSTATIC (->class "java.lang.System") "out" (->type-signature "java.io.PrintStream"))
+                          ;; (.visitTypeInsn Opcodes/NEW (->class "java.lang.Integer"))
+                          ;; (.visitInsn Opcodes/DUP)
+                          ;; (.visitVarInsn Opcodes/ALOAD 1)
+                          ;; ;; (.visitVarInsn Opcodes/ALOAD 0)
+                          ;; ;; (.visitFieldInsn Opcodes/GETFIELD current-class "_counter" counter-sig)
+                          ;; (.visitMethodInsn Opcodes/INVOKESPECIAL (->class "java.lang.Integer") "<init>" "(I)V")
+                          ;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.io.PrintStream") "println" "(Ljava/lang/Object;)V")
+
+                          (.visitVarInsn Opcodes/ALOAD 0)
+                          (.visitVarInsn Opcodes/ILOAD 1)
+                        ;; (.visitInsn Opcodes/ICONST_0)
+                        
+                          (.visitFieldInsn Opcodes/PUTFIELD current-class "_counter" counter-sig)
+                        (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
+                              (.visitVarInsn Opcodes/ALOAD (+ clo_idx 2))
+                              (.visitFieldInsn Opcodes/PUTFIELD current-class field-name clo-field-sig))
+                            (->> (let [field-name (str "_" clo_idx)]
+                                   (doto (.visitField =class (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) field-name clo-field-sig nil nil)
+                                     (.visitEnd)))
+                                 (dotimes [clo_idx num-captured]))))
+                      (->> (when (not= 0 num-captured))))
+                  (.visitInsn Opcodes/RETURN)
                   (.visitMaxs 0 0)
                   (.visitEnd))
-                (.visitEnd =class))]
-        ;; (write-file (str class-name "/" current-class ".class") (.toByteArray =class))
-        (write-file (str current-class ".class") (.toByteArray =class))))))
+          =method (let [default-label (new Label)
+                        branch-labels (for [_ (range num-captured)]
+                                        (new Label))
+                        ;; _ (prn 'branch-labels (count branch-labels) branch-labels)
+                        ;; end-label (new Label)
+                        ]
+                    (doto (.visitMethod =class Opcodes/ACC_PUBLIC "apply" apply-signature nil nil)
+                      (.visitCode)
+                      (-> (doto ;; (.visitFieldInsn Opcodes/GETSTATIC (->class "java.lang.System") "out" (->type-signature "java.io.PrintStream"))
+                              ;; (.visitTypeInsn Opcodes/NEW (->class "java.lang.Integer"))
+                              ;; (.visitInsn Opcodes/DUP)
+                              ;; (.visitVarInsn Opcodes/ALOAD 0)
+                              ;; (.visitFieldInsn Opcodes/GETFIELD current-class "_counter" counter-sig)
+                              ;; (.visitMethodInsn Opcodes/INVOKESPECIAL (->class "java.lang.Integer") "<init>" "(I)V")
+                              ;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.io.PrintStream") "println" "(Ljava/lang/Object;)V")
+                              (.visitVarInsn Opcodes/ALOAD 0)
+                            (.visitFieldInsn Opcodes/GETFIELD current-class "_counter" counter-sig)
+                            (.visitTableSwitchInsn 0 (dec num-captured) default-label (into-array Label branch-labels))
+                            (-> (doto (.visitLabel branch-label)
+                                  (.visitTypeInsn Opcodes/NEW current-class)
+                                  (.visitInsn Opcodes/DUP)
+                                  (.visitVarInsn Opcodes/ALOAD 0)
+                                  (.visitFieldInsn Opcodes/GETFIELD current-class "_counter" counter-sig)
+                                  (.visitInsn Opcodes/ICONST_1)
+                                  (.visitInsn Opcodes/IADD)
+                                  (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
+                                        (.visitFieldInsn Opcodes/GETFIELD current-class (str "_" clo_idx) clo-field-sig))
+                                      (->> (dotimes [clo_idx current-captured])))
+                                  (.visitVarInsn Opcodes/ALOAD 1)
+                                  (-> (.visitInsn Opcodes/ACONST_NULL)
+                                      (->> (dotimes [clo_idx (- (dec num-captured) current-captured)])))
+                                  (.visitMethodInsn Opcodes/INVOKESPECIAL current-class "<init>" init-signature)
+                                  ;; (.visitJumpInsn Opcodes/GOTO end-label)
+                                  (.visitInsn Opcodes/ARETURN))
+                                (->> (doseq [[branch-label current-captured] (map vector branch-labels (range (count branch-labels)))
+                                             ;; :let [_ (prn '[branch-label current-captured] [branch-label current-captured])]
+                                             ])))
+                            (.visitLabel default-label)
+                            (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
+                                  (.visitFieldInsn Opcodes/GETFIELD current-class (str "_" clo_idx) clo-field-sig))
+                                (->> (dotimes [clo_idx num-captured]))))
+                          (->> (when (not= 0 num-captured))))
+                      (.visitVarInsn Opcodes/ALOAD 1)
+                      (.visitMethodInsn Opcodes/INVOKESTATIC outer-class fn-name real-signature)
+                      ;; (.visitLabel end-label)
+                      (.visitInsn Opcodes/ARETURN)
+                      (.visitMaxs 0 0)
+                      (.visitEnd)))
+          _ (.visitEnd =class)]
+      (write-file (str current-class ".class") (.toByteArray =class)))
+    ))
 
 (defcompiler ^:private compile-def
   [::&analyser/def ?form ?body]