- Added Tail-Recursion Optimization.

5 files changed, 177 insertions, 104 deletions

diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj
index c8fa72b5f..3703b6ec9 100644
--- a/src/lux/analyser/host.clj
+++ b/src/lux/analyser/host.clj
@@ -902,7 +902,7 @@
 (defn ^:private analyse-jvm-interface [analyse compile-interface interface-decl supers =anns =methods]
   (|do [module &/get-module-name
         _ (compile-interface interface-decl supers =anns =methods)
-        :let [_ (println 'DEF (str module "." (&/|first interface-decl)))]
+        :let [_ (println 'INTERFACE (str module "." (&/|first interface-decl)))]
         _cursor &/cursor]
     (return (&/|list (&&/|meta &/$UnitT _cursor
                                (&&/$tuple (&/|list)))))))
@@ -921,7 +921,7 @@
           _ (check-method-completion all-supers =methods)
           _ (compile-class class-decl super-class interfaces =inheritance-modifier =anns =fields =methods &/$Nil &/$None)
           _ &/pop-dummy-name
-          :let [_ (println 'DEF full-name)]
+          :let [_ (println 'CLASS full-name)]
           _cursor &/cursor]
       (return (&/|list (&&/|meta &/$UnitT _cursor
                                  (&&/$tuple (&/|list))))))))
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index b9acff72a..69b3d4345 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -39,7 +39,7 @@
 ;; [Resources]
 (def ^:private !source->last-line (atom nil))
 
-(defn compile-expression [syntax]
+(defn compile-expression [$begin syntax]
   (|let [[[?type [_file-name _line _]] ?form] syntax]
     (|do [^MethodVisitor *writer* &/get-writer
           :let [debug-label (new Label)
@@ -50,50 +50,53 @@
                     (swap! !source->last-line assoc _file-name _line))]]
       (|case ?form
         (&o/$bool ?value)
-        (&&lux/compile-bool compile-expression ?value)
+        (&&lux/compile-bool ?value)
 
         (&o/$int ?value)
-        (&&lux/compile-int compile-expression ?value)
+        (&&lux/compile-int ?value)
 
         (&o/$real ?value)
-        (&&lux/compile-real compile-expression ?value)
+        (&&lux/compile-real ?value)
 
         (&o/$char ?value)
-        (&&lux/compile-char compile-expression ?value)
+        (&&lux/compile-char ?value)
 
         (&o/$text ?value)
-        (&&lux/compile-text compile-expression ?value)
+        (&&lux/compile-text ?value)
 
         (&o/$tuple ?elems)
-        (&&lux/compile-tuple compile-expression ?elems)
+        (&&lux/compile-tuple (partial compile-expression $begin) ?elems)
 
         (&o/$var (&/$Local ?idx))
-        (&&lux/compile-local compile-expression ?idx)
+        (&&lux/compile-local (partial compile-expression $begin) ?idx)
 
         (&o/$captured ?scope ?captured-id ?source)
-        (&&lux/compile-captured compile-expression ?scope ?captured-id ?source)
+        (&&lux/compile-captured (partial compile-expression $begin) ?scope ?captured-id ?source)
 
         (&o/$var (&/$Global ?owner-class ?name))
-        (&&lux/compile-global compile-expression ?owner-class ?name)
+        (&&lux/compile-global (partial compile-expression $begin) ?owner-class ?name)
 
         (&o/$apply ?fn ?args)
-        (&&lux/compile-apply compile-expression ?fn ?args)
+        (&&lux/compile-apply (partial compile-expression $begin) ?fn ?args)
+
+        (&o/$loop ?args)
+        (&&lux/compile-loop (partial compile-expression $begin) $begin ?args)
 
         (&o/$variant ?tag ?tail ?members)
-        (&&lux/compile-variant compile-expression ?tag ?tail ?members)
+        (&&lux/compile-variant (partial compile-expression $begin) ?tag ?tail ?members)
 
         (&o/$case ?value ?match)
-        (&&case/compile-case compile-expression ?value ?match)
+        (&&case/compile-case (partial compile-expression $begin) ?value ?match)
 
         (&o/$function ?arity ?scope ?env ?body)
         (&&lambda/compile-function compile-expression &/$None ?arity ?scope ?env ?body)
 
         ;; Must get rid of this one...
         (&o/$ann ?value-ex ?type-ex ?value-type)
-        (compile-expression ?value-ex)
+        (compile-expression $begin ?value-ex)
 
         (&o/$proc [?proc-category ?proc-name] ?args special-args)
-        (&&host/compile-host compile-expression ?proc-category ?proc-name ?args special-args)
+        (&&host/compile-host (partial compile-expression $begin) ?proc-category ?proc-name ?args special-args)
         
         _
         (assert false (prn-str 'compile-expression (&/adt->text syntax)))
@@ -122,7 +125,7 @@
           _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
               (|do [^MethodVisitor *writer* &/get-writer
                     :let [_ (.visitCode *writer*)]
-                    _ (compile-expression expr)
+                    _ (compile-expression nil expr)
                     :let [_ (doto *writer*
                               (.visitFieldInsn Opcodes/PUTSTATIC class-name &/eval-field "Ljava/lang/Object;")
                               (.visitInsn Opcodes/RETURN)
@@ -139,10 +142,11 @@
           return))))
 
 (def all-compilers
-  (&/T [(partial &&lux/compile-def compile-expression)
-        (partial &&lux/compile-program compile-expression)
-        (partial &&host/compile-jvm-class compile-expression)
-        &&host/compile-jvm-interface]))
+  (let [compile-expression* (partial compile-expression nil)]
+    (&/T [(partial &&lux/compile-def compile-expression)
+          (partial &&lux/compile-program compile-expression*)
+          (partial &&host/compile-jvm-class compile-expression*)
+          &&host/compile-jvm-interface])))
 
 (defn compile-module [source-dirs name]
   (let [file-name (str name ".lux")]
diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj
index d291ebc07..f51edc507 100644
--- a/src/lux/compiler/lambda.clj
+++ b/src/lux/compiler/lambda.clj
@@ -113,15 +113,17 @@
 
 (let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL)]
   (defn ^:private add-lambda-impl [class class-name compile arity impl-body]
-    (&/with-writer (doto (.visitMethod ^ClassWriter class impl-flags "impl" (lambda-impl-signature arity) nil nil)
-                     (.visitCode))
-      (|do [^MethodVisitor *writer* &/get-writer
-            ret (compile impl-body)
-            :let [_ (doto *writer*
-                      (.visitInsn Opcodes/ARETURN)
-                      (.visitMaxs 0 0)
-                      (.visitEnd))]]
-        (return ret)))))
+    (let [$begin (new Label)]
+      (&/with-writer (doto (.visitMethod ^ClassWriter class impl-flags "impl" (lambda-impl-signature arity) nil nil)
+                       (.visitCode)
+                       (.visitLabel $begin))
+        (|do [^MethodVisitor *writer* &/get-writer
+              ret (compile $begin impl-body)
+              :let [_ (doto *writer*
+                        (.visitInsn Opcodes/ARETURN)
+                        (.visitMaxs 0 0)
+                        (.visitEnd))]]
+          (return ret))))))
 
 (defn ^:private instance-closure [compile lambda-class arity closed-over]
   (|do [^MethodVisitor *writer* &/get-writer
@@ -131,7 +133,7 @@
         _ (&/map% (fn [?name+?captured]
                     (|case ?name+?captured
                       [?name [_ (&a/$captured _ _ ?source)]]
-                      (compile ?source)))
+                      (compile nil ?source)))
                   closed-over)
         :let [_ (when (> arity 1)
                   (doto *writer*
@@ -223,15 +225,17 @@
             (.visitMaxs 0 0)
             (.visitEnd))
         (return nil)))
-    (&/with-writer (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 1) nil nil)
-                     (.visitCode))
-      (|do [^MethodVisitor *writer* &/get-writer
-            ret (compile impl-body)
-            :let [_ (doto *writer*
-                      (.visitInsn Opcodes/ARETURN)
-                      (.visitMaxs 0 0)
-                      (.visitEnd))]]
-        (return ret)))
+    (let [$begin (new Label)]
+      (&/with-writer (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 1) nil nil)
+                       (.visitCode)
+                       (.visitLabel $begin))
+        (|do [^MethodVisitor *writer* &/get-writer
+              ret (compile $begin impl-body)
+              :let [_ (doto *writer*
+                        (.visitInsn Opcodes/ARETURN)
+                        (.visitMaxs 0 0)
+                        (.visitEnd))]]
+          (return ret))))
     ))
 
 ;; [Exports]
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index 2cbfcef54..3f069dbfd 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -30,13 +30,13 @@
            java.lang.reflect.Field))
 
 ;; [Exports]
-(defn compile-bool [compile ?value]
+(defn compile-bool [?value]
   (|do [^MethodVisitor *writer* &/get-writer
         :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]]
     (return nil)))
 
 (do-template [<name> <class> <sig> <caster>]
-  (defn <name> [compile value]
+  (defn <name> [value]
     (|do [^MethodVisitor *writer* &/get-writer
           :let [_ (doto *writer*
                     (.visitTypeInsn Opcodes/NEW <class>)
@@ -50,7 +50,7 @@
   compile-char "java/lang/Character" "(C)V" char
   )
 
-(defn compile-text [compile ?value]
+(defn compile-text [?value]
   (|do [^MethodVisitor *writer* &/get-writer
         :let [_ (.visitLdcInsn *writer* ?value)]]
     (return nil)))
@@ -149,6 +149,27 @@
       (compile-apply* compile ?args))
     ))
 
+(defn compile-loop [compile $begin ?args]
+  (|do [^MethodVisitor *writer* &/get-writer
+        _ (&/map% (fn [idx+?arg]
+                    (|do [:let [[idx ?arg] idx+?arg
+                                already-set? (|case ?arg
+                                               [_ (&o/$var (&/$Local l-idx))]
+                                               (= idx l-idx)
+
+                                               _
+                                               false)]
+                          _ (if already-set?
+                              (return nil)
+                              (compile ?arg))
+                          :let [_ (when (not already-set?)
+                                    (.visitVarInsn *writer* Opcodes/ASTORE idx))]]
+                      (return nil)))
+                  (&/zip2 (&/|range* 1 (&/|length ?args))
+                          ?args))
+        :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $begin)]]
+    (return nil)))
+
 (defn ^:private compile-def-type [compile ?body]
   (|do [:let [?def-type (|case ?body
                           [[?def-type ?def-cursor] (&a/$ann ?def-value ?type-expr ?def-value-type)]
@@ -159,11 +180,11 @@
                             (&/T [(&/T [?def-type ?def-cursor])
                                   (&a/$tuple (&/|list))])
                             (&&type/type->analysis ?def-type)))]]
-    (compile ?def-type)))
+    (compile nil ?def-type)))
 
 (defn ^:private compile-def-meta [compile ?meta]
   (|let [analysis (&&type/defmeta->analysis ?meta)]
-    (compile analysis)))
+    (compile nil analysis)))
 
 (defn ^:private de-ann [optim]
   (|case optim
@@ -304,7 +325,7 @@
                           :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/type-field datum-sig)]
                           _ (compile-def-meta compile ?meta)
                           :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)]
-                          _ (compile ?body)
+                          _ (compile nil ?body)
                           :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)]
                           :let [_ (doto **writer**
                                     (.visitInsn Opcodes/RETURN)
diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj
index 9b4dd7548..920fd21bc 100644
--- a/src/lux/optimizer.clj
+++ b/src/lux/optimizer.clj
@@ -2,7 +2,6 @@
 ;;  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
 ;;  If a copy of the MPL was not distributed with this file,
 ;;  You can obtain one at http://mozilla.org/MPL/2.0/.
-
 (ns lux.optimizer
   (:require (lux [base :as & :refer [|let |do return fail return* fail* |case defvariant]]
                  [analyser :as &analyser])
@@ -25,6 +24,9 @@
   ("var" 1)
   ("captured" 3)
   ("proc" 3)
+
+  ;; Purely for optimizations
+  ("loop" 1)
   )
 
 ;; [Utils]
@@ -131,72 +133,114 @@
       ($proc proc-ident args special-args)
       (&/T [meta ($proc proc-ident (&/|map (partial shift-function-body own-body?) args) special-args)])
 
+      ($loop args)
+      (&/T [meta ($loop (&/|map (partial shift-function-body own-body?) args))])
+      
       _
       body
       )))
 
-(defn ^:private optimize-closure [optimize closure]
-  (&/|map (fn [capture]
-            (|let [[_name _analysis] capture]
-              (&/T [_name (optimize _analysis)])))
-          closure))
+(defn ^:private optimize-loop [arity optim]
+  "(-> Int Optimized [Optimized Bool])"
+  (|let [[meta optim-] optim]
+    (|case optim-
+      ($apply [meta-0 ($var (&/$Local 0))] _args)
+      (if (= arity (&/|length _args))
+        (&/T [meta-0 ($loop (&/|map (partial optimize-loop -1) _args))])
+        optim)
 
-;; [Exports]
-(defn optimize [analysis]
-  "(-> Analysis Optimized)"
-  (|let [[meta analysis-] analysis]
-    (|case analysis-
-      (&-base/$bool value)
-      (&/T [meta ($bool value)])
-      
-      (&-base/$int value)
-      (&/T [meta ($int value)])
-      
-      (&-base/$real value)
-      (&/T [meta ($real value)])
-      
-      (&-base/$char value)
-      (&/T [meta ($char value)])
-      
-      (&-base/$text value)
-      (&/T [meta ($text value)])
-      
-      (&-base/$variant idx is-last? value)
-      (&/T [meta ($variant idx is-last? (optimize value))])
-      
-      (&-base/$tuple elems)
-      (&/T [meta ($tuple (&/|map optimize elems))])
-      
-      (&-base/$apply func args)
-      (&/T [meta ($apply (optimize func) (&/|map optimize args))])
-      
-      (&-base/$case value branches)
-      (&/T [meta ($case (optimize value)
+      ($apply func args)
+      (&/T [meta ($apply (optimize-loop -1 func)
+                         (&/|map (partial optimize-loop -1) args))])
+
+      ($case _value _branches)
+      (&/T [meta ($case _value
                         (&/|map (fn [branch]
                                   (|let [[_pattern _body] branch]
-                                    (&/T [_pattern (optimize _body)])))
-                                branches))])
-      
-      (&-base/$lambda scope captured body)
-      (|case (optimize body)
-        [_ ($function _arity _scope _captured _body)]
-        (&/T [meta ($function (inc _arity) scope (optimize-closure optimize captured) (shift-function-body true _body))])
+                                    (&/T [_pattern (optimize-loop arity _body)])))
+                                _branches))])
 
-        =body
-        (&/T [meta ($function 1 scope (optimize-closure optimize captured) =body)]))
+      ($function _arity _scope _captured _body)
+      (&/T [meta ($function _arity _scope _captured (optimize-loop _arity _body))])
       
-      (&-base/$ann value-expr type-expr type-type)
-      (&/T [meta ($ann (optimize value-expr) type-expr type-type)])
-      
-      (&-base/$var var-kind)
-      (&/T [meta ($var var-kind)])
-      
-      (&-base/$captured scope idx source)
-      (&/T [meta ($captured scope idx (optimize source))])
+      ($ann _value-expr _type-expr _type-type)
+      (&/T [meta ($ann (optimize-loop arity _value-expr) _type-expr _type-type)])
+
+      ($variant idx is-last? value)
+      (&/T [meta ($variant idx is-last? (optimize-loop -1 value))])
 
-      (&-base/$proc proc-ident args special-args)
-      (&/T [meta ($proc proc-ident (&/|map optimize args) special-args)])
+      ($tuple elems)
+      (&/T [meta ($tuple (&/|map (partial optimize-loop -1) elems))])
       
       _
-      (assert false (prn-str 'optimize (&/adt->text analysis)))
+      optim
       )))
+
+(let [optimize-closure (fn [optimize closure]
+                         (&/|map (fn [capture]
+                                   (|let [[_name _analysis] capture]
+                                     (&/T [_name (optimize _analysis)])))
+                                 closure))]
+  (defn ^:private pass-0 [analysis]
+    "(-> Analysis Optimized)"
+    (|let [[meta analysis-] analysis]
+      (|case analysis-
+        (&-base/$bool value)
+        (&/T [meta ($bool value)])
+        
+        (&-base/$int value)
+        (&/T [meta ($int value)])
+        
+        (&-base/$real value)
+        (&/T [meta ($real value)])
+        
+        (&-base/$char value)
+        (&/T [meta ($char value)])
+        
+        (&-base/$text value)
+        (&/T [meta ($text value)])
+        
+        (&-base/$variant idx is-last? value)
+        (&/T [meta ($variant idx is-last? (pass-0 value))])
+        
+        (&-base/$tuple elems)
+        (&/T [meta ($tuple (&/|map pass-0 elems))])
+        
+        (&-base/$apply func args)
+        (&/T [meta ($apply (pass-0 func) (&/|map pass-0 args))])
+        
+        (&-base/$case value branches)
+        (&/T [meta ($case (pass-0 value)
+                          (&/|map (fn [branch]
+                                    (|let [[_pattern _body] branch]
+                                      (&/T [_pattern (pass-0 _body)])))
+                                  branches))])
+        
+        (&-base/$lambda scope captured body)
+        (|case (pass-0 body)
+          [_ ($function _arity _scope _captured _body)]
+          (&/T [meta ($function (inc _arity) scope (optimize-closure pass-0 captured) (shift-function-body true _body))])
+
+          =body
+          (&/T [meta ($function 1 scope (optimize-closure pass-0 captured) =body)]))
+        
+        (&-base/$ann value-expr type-expr type-type)
+        (&/T [meta ($ann (pass-0 value-expr) type-expr type-type)])
+        
+        (&-base/$var var-kind)
+        (&/T [meta ($var var-kind)])
+        
+        (&-base/$captured scope idx source)
+        (&/T [meta ($captured scope idx (pass-0 source))])
+
+        (&-base/$proc proc-ident args special-args)
+        (&/T [meta ($proc proc-ident (&/|map pass-0 args) special-args)])
+        
+        _
+        (assert false (prn-str 'pass-0 (&/adt->text analysis)))
+        ))))
+
+;; [Exports]
+(defn optimize [analysis]
+  "(-> Analysis Optimized)"
+  (->> analysis pass-0 (optimize-loop -1)))