From 20392fc6ceac67acfc99c0b09b5eaa4fdf6467f2 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Thu, 13 Oct 2016 17:49:05 -0400
Subject: - Now detecting the conditions for inlining a loop.

---
 src/lux/optimizer.clj | 138 ++++++++++++++++++++++++++++++++++++++++----------
 1 file changed, 110 insertions(+), 28 deletions(-)

diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj
index ad285a2e1..060d16194 100644
--- a/src/lux/optimizer.clj
+++ b/src/lux/optimizer.clj
@@ -590,8 +590,9 @@
 ;; During the folding, inner functions dissapear, since their bodies
 ;; are merged into their outer "parent" functions.
 ;; Their scopes must change accordingy.
-(defn ^:private de-scope [old-scope new-scope scope]
+(defn ^:private de-scope
   "(-> Scope Scope Scope Scope)"
+  [old-scope new-scope scope]
   (if (identical? new-scope scope)
     old-scope
     scope))
@@ -617,8 +618,9 @@
     ))
 
 ;; Shifts the body of a function after a folding is performed.
-(defn shift-function-body [old-scope new-scope own-body? body]
+(defn shift-function-body
   "(-> Scope Scope Bool Optimized Optimized)"
+  [old-scope new-scope own-body? body]
   (|let [[meta body-] body]
     (|case body-
       ($variant idx is-last? value)
@@ -720,8 +722,9 @@
 ;; That is the pattern that is to be expected of record read-access,
 ;; so this function tries to extract the (possibly nested) path
 ;; necessary, ending in the data-node of the wanted member.
-(defn ^:private record-read-path [pms member-idx]
+(defn ^:private record-read-path
   "(-> (List PM) Idx (List Idx))"
+  [pms member-idx]
   (loop [current-idx 0
          pms pms]
     (|case pms
@@ -761,8 +764,9 @@
 ;; This optimization looks for tail-calls in the function body,
 ;; rewriting them as jumps to the beginning of the function, while
 ;; they also updated the necessary local variables for the next iteration.
-(defn ^:private optimize-loop [arity optim]
+(defn ^:private optimize-iter
   "(-> Int Optimized Optimized)"
+  [arity optim]
   (|let [[meta optim-] optim]
     (|case optim-
       ($apply [meta-0 ($var (&/$Local 0))] _args)
@@ -773,24 +777,79 @@
       ($case _value [_pattern _bodies])
       (&/T [meta ($case _value
                         (&/T [_pattern
-                              (&/|map (partial optimize-loop arity)
+                              (&/|map (partial optimize-iter arity)
                                       _bodies)]))])
 
       ($let _value _register _body)
-      (&/T [meta ($let _value _register (optimize-loop arity _body))])
+      (&/T [meta ($let _value _register (optimize-iter arity _body))])
 
       ($if _test _then _else)
       (&/T [meta ($if _test
-                      (optimize-loop arity _then)
-                      (optimize-loop arity _else))])
+                      (optimize-iter arity _then)
+                      (optimize-iter arity _else))])
       
       ($ann _value-expr _type-expr)
-      (&/T [meta ($ann (optimize-loop arity _value-expr) _type-expr)])
+      (&/T [meta ($ann (optimize-iter arity _value-expr) _type-expr)])
 
       _
       optim
       )))
 
+(defn ^:private contains-self-reference?
+  "(-> Optimized Bool)"
+  [body]
+  (|let [[meta body-] body
+         stepwise-test (fn [base arg] (or base (contains-self-reference? arg)))]
+    (|case body-
+      ($variant idx is-last? value)
+      (contains-self-reference? value)
+      
+      ($tuple elems)
+      (&/fold stepwise-test false elems)
+      
+      ($case value [_pm _bodies])
+      (or (contains-self-reference? value)
+          (&/fold stepwise-test false _bodies))
+
+      ($function arity scope captured body*)
+      (->> captured
+           (&/|map (fn [capture]
+                     (|let [[_name [_meta ($captured _scope _idx _source)]] capture]
+                       _source)))
+           (&/fold stepwise-test false))
+
+      ($ann value-expr type-expr)
+      (contains-self-reference? value-expr)
+      
+      ($var (&/$Local 0))
+      true
+
+      ($apply func args)
+      (or (contains-self-reference? func)
+          (&/fold stepwise-test false args))
+      
+      ($proc proc-ident args special-args)
+      (&/fold stepwise-test false args)
+
+      ($iter args)
+      (&/fold stepwise-test false args)
+
+      ($let _value _register _body)
+      (or (contains-self-reference? _value)
+          (contains-self-reference? _body))
+
+      ($record-get _value _path)
+      (contains-self-reference? _value)
+
+      ($if _test _then _else)
+      (or (contains-self-reference? _test)
+          (contains-self-reference? _then)
+          (contains-self-reference? _else))
+      
+      _
+      false
+      )))
+
 ;; [[Initial Optimization]]
 
 ;; Before any big optimization can be done, the incoming Analysis nodes
@@ -802,8 +861,9 @@
                                    (|let [[_name _analysis] capture]
                                      (&/T [_name (optimize _analysis)])))
                                  closure))]
-  (defn ^:private pass-0 [top-level-func? analysis]
+  (defn ^:private pass-0
     "(-> Bool Analysis Optimized)"
+    [top-level-func? analysis]
     (|let [[meta analysis-] analysis]
       (|case analysis-
         (&a/$bool value)
@@ -834,7 +894,18 @@
         (&/T [meta ($tuple (&/|map (partial pass-0 top-level-func?) elems))])
         
         (&a/$apply func args)
-        (&/T [meta ($apply (pass-0 top-level-func? func) (&/|map (partial pass-0 top-level-func?) args))])
+        (|let [=func (pass-0 top-level-func? func)
+               =args (&/|map (partial pass-0 top-level-func?) args)]
+          (|case =func
+            [_ (&a/$ann [_ ($function _arity _scope _captured _body)]
+                        _)]
+            (if (and (= _arity (&/|length =args))
+                     (not (contains-self-reference? _body)))
+              (&/T [meta ($apply =func =args)])
+              (&/T [meta ($apply =func =args)]))
+            
+            _
+            (&/T [meta ($apply =func =args)])))
         
         (&a/$case value branches)
         (let [normal-case-optim (fn []
@@ -872,24 +943,34 @@
             (normal-case-optim)))
         
         (&a/$lambda scope captured body)
-        (|case (pass-0 false body)
-          ;; If the body of a function is another function, that means
-          ;; no work was done in-between and both layers can be folded
-          ;; into one.
-          [_ ($function _arity _scope _captured _body)]
-          (|let [new-arity (inc _arity)
-                 collapsed-body (shift-function-body scope _scope true _body)]
-            (&/T [meta ($function new-arity
-                                  scope
+        (|let [inner-func? (|case body
+                             [_ (&a/$lambda _ _ _)]
+                             true
+
+                             _
+                             false)]
+          (|case (pass-0 (not inner-func?) body)
+            ;; If the body of a function is another function, that means
+            ;; no work was done in-between and both layers can be folded
+            ;; into one.
+            [_ ($function _arity _scope _captured _body)]
+            (|let [new-arity (inc _arity)
+                   collapsed-body (shift-function-body scope _scope true _body)]
+              (&/T [meta ($function new-arity
+                                    scope
+                                    (optimize-closure (partial pass-0 top-level-func?) captured)
+                                    (if top-level-func?
+                                      (optimize-iter new-arity collapsed-body)
+                                      collapsed-body))]))
+
+            ;; Otherwise, they're nothing to be done and we've got a
+            ;; 1-arity function.
+            =body
+            (&/T [meta ($function 1 scope
                                   (optimize-closure (partial pass-0 top-level-func?) captured)
                                   (if top-level-func?
-                                    (optimize-loop new-arity collapsed-body)
-                                    collapsed-body))]))
-
-          ;; Otherwise, they're nothing to be done and we've got a
-          ;; 1-arity function.
-          =body
-          (&/T [meta ($function 1 scope (optimize-closure (partial pass-0 top-level-func?) captured) =body)]))
+                                    (optimize-iter 1 =body)
+                                    =body))])))
 
         (&a/$ann value-expr type-expr)
         (&/T [meta ($ann (pass-0 top-level-func? value-expr) type-expr)])
@@ -908,7 +989,8 @@
         ))))
 
 ;; [Exports]
-(defn optimize [analysis]
+(defn optimize
   "(-> Analysis Optimized)"
+  [analysis]
   (->> analysis
        (pass-0 true)))
-- 
cgit v1.2.3


From 7b8ffed7964dd929e0877269b4870a695c4d173a Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Thu, 13 Oct 2016 20:06:47 -0400
Subject: - Now compiling loop expressions (but having trouble with the
 variable indices inside the loop bodies).

---
 src/lux/analyser/base.clj |   2 +-
 src/lux/analyser/lux.clj  |   5 +-
 src/lux/compiler.clj      |   9 ++-
 src/lux/compiler/lux.clj  |  36 +++++++--
 src/lux/optimizer.clj     | 182 ++++++++++++++++++++++++++++++++++++++++------
 5 files changed, 198 insertions(+), 36 deletions(-)

diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj
index 205e6bd91..560166eb7 100644
--- a/src/lux/analyser/base.clj
+++ b/src/lux/analyser/base.clj
@@ -22,7 +22,7 @@
   ("tuple" 1)
   ("apply" 2)
   ("case" 2)
-  ("lambda" 3)
+  ("lambda" 4)
   ("ann" 2)
   ("var" 1)
   ("captured" 1)
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 8a8f22586..9da884025 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -518,9 +518,10 @@
           (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type*
                                            ?arg ?arg-t
                                            (&&/analyse-1 analyse ?return-t ?body))
-                _cursor &/cursor]
+                _cursor &/cursor
+                register-offset &&env/next-local-idx]
             (return (&&/|meta exo-type* _cursor
-                              (&&/$lambda =scope =captured =body))))
+                              (&&/$lambda register-offset =scope =captured =body))))
 
           _
           (fail "")))
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 6506c867b..584cc88ac 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -86,8 +86,11 @@
         (&o/$apply ?fn ?args)
         (&&lux/compile-apply (partial compile-expression $begin) ?fn ?args)
 
-        (&o/$iter ?args)
-        (&&lux/compile-iter (partial compile-expression $begin) $begin ?args)
+        (&o/$loop _register-offset _inits _body)
+        (&&lux/compile-loop compile-expression _register-offset _inits _body)
+        
+        (&o/$iter _register-offset ?args)
+        (&&lux/compile-iter (partial compile-expression $begin) $begin _register-offset ?args)
 
         (&o/$variant ?tag ?tail ?members)
         (&&lux/compile-variant (partial compile-expression $begin) ?tag ?tail ?members)
@@ -104,7 +107,7 @@
         (&o/$if _test _then _else)
         (&&lux/compile-if (partial compile-expression $begin) _test _then _else)
         
-        (&o/$function ?arity ?scope ?env ?body)
+        (&o/$function _register-offset ?arity ?scope ?env ?body)
         (&&lambda/compile-function compile-expression &/$None ?arity ?scope ?env ?body)
 
         (&o/$ann ?value-ex ?type-ex)
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index 976bdfa15..72326447a 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -152,15 +152,34 @@
       (compile-apply* compile ?args))
     ))
 
-(defn compile-iter [compile $begin ?args]
+(defn compile-loop [compile-expression register-offset inits body]
+  (|do [^MethodVisitor *writer* &/get-writer
+        :let [_ (.println System/out (pr-str 'compile-loop register-offset (&/|length inits)))]
+        :let [idxs+inits (&/zip2 (&/|range* 0 (dec (&/|length inits)))
+                                 inits)]
+        _ (&/map% (fn [idx+_init]
+                    (|do [:let [[idx _init] idx+_init
+                                _ (.println System/out (pr-str 'compile-loop/_init (&/adt->text _init)))
+                                idx+ (+ register-offset idx)]
+                          _ (compile-expression nil _init)
+                          :let [_ (.visitVarInsn *writer* Opcodes/ASTORE idx+)]]
+                      (return nil)))
+                  idxs+inits)
+        :let [$begin (new Label)
+              _ (.visitLabel *writer* $begin)]]
+    (compile-expression $begin body)
+    ))
+
+(defn compile-iter [compile $begin register-offset ?args]
   (|do [^MethodVisitor *writer* &/get-writer
         :let [idxs+args (&/zip2 (&/|range* 1 (&/|length ?args))
                                 ?args)]
         _ (&/map% (fn [idx+?arg]
                     (|do [:let [[idx ?arg] idx+?arg
+                                idx+ (+ register-offset idx)
                                 already-set? (|case ?arg
                                                [_ (&o/$var (&/$Local l-idx))]
-                                               (= idx l-idx)
+                                               (= idx+ l-idx)
 
                                                _
                                                false)]]
@@ -170,14 +189,15 @@
                   idxs+args)
         _ (&/map% (fn [idx+?arg]
                     (|do [:let [[idx ?arg] idx+?arg
+                                idx+ (+ register-offset idx)
                                 already-set? (|case ?arg
                                                [_ (&o/$var (&/$Local l-idx))]
-                                               (= idx l-idx)
+                                               (= idx+ l-idx)
 
                                                _
                                                false)]
                           :let [_ (when (not already-set?)
-                                    (.visitVarInsn *writer* Opcodes/ASTORE idx))]]
+                                    (.visitVarInsn *writer* Opcodes/ASTORE idx+))]]
                       (return nil)))
                   (&/|reverse idxs+args))
         :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $begin)]]
@@ -263,10 +283,10 @@
         
         _
         (|case (de-ann ?body)
-          [_ (&o/$function _ __scope _ _)]
-          (|let [[_ (&o/$function _arity _scope _captured ?body+)] (&o/shift-function-body (&/|tail __scope) __scope
-                                                                                           false
-                                                                                           (de-ann ?body))]
+          [_ (&o/$function _ _ __scope _ _)]
+          (|let [[_ (&o/$function _ _arity _scope _captured ?body+)] (&o/shift-function-body (&/|tail __scope) __scope
+                                                                                             false
+                                                                                             (de-ann ?body))]
             (|do [:let [=value-type (&a/expr-type* ?body)]
                   ;; ^ClassWriter *writer* &/get-writer
                   [file-name _ _] &/cursor
diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj
index 060d16194..755c4aae2 100644
--- a/src/lux/optimizer.clj
+++ b/src/lux/optimizer.clj
@@ -21,7 +21,7 @@
   ("tuple" 1)
   ("apply" 2)
   ("case" 2)
-  ("function" 4)
+  ("function" 5)
   ("ann" 2)
   ("var" 1)
   ("captured" 3)
@@ -35,8 +35,10 @@
   ;; The optimizer looks for those usage patterns and transforms them
   ;; into explicit constructs, which are then subject to specialized optimizations.
 
+  ;; Loop scope, for doing loop inlining
+  ("loop" 3) ;; {register-offset Int, inits (List Optimized), body Optimized}
   ;; This is loop iteration, as expected in imperative programming.
-  ("iter" 1)
+  ("iter" 2) ;; {register-offset Int, vals (List Optimized)}
   ;; This is a simple let-expression, as opposed to the more general pattern-matching.
   ("let" 3)
   ;; This is an access to a record's member. It can be multi-level:
@@ -377,7 +379,11 @@
       ($proc _proc-ident _args _special-args)
       (&/fold find-unused-vars var-table _args)
 
-      ($iter _args)
+      ($loop _register-offset _inits _body)
+      (&/|++ (&/fold find-unused-vars var-table _inits)
+             (find-unused-vars var-table _body))
+      
+      ($iter _ _args)
       (&/fold find-unused-vars var-table _args)
 
       ($let _value _register _body)
@@ -399,7 +405,7 @@
               (find-unused-vars var-table _value)
               _bodies)
 
-      ($function _arity _scope _captured _body)
+      ($function _ _ _ _captured _)
       (->> _captured
            (&/|map &/|second)
            (&/fold find-unused-vars var-table))
@@ -485,8 +491,15 @@
                                 _args)
                         _special-args)])
 
-      ($iter _args)
-      (&/T [meta ($iter (&/|map (partial clean-unused-body-registers var-table)
+      ($loop _register-offset _inits _body)
+      (&/T [meta ($loop _register-offset
+                        (&/|map (partial clean-unused-body-registers var-table)
+                                _inits)
+                        (clean-unused-body-registers var-table _body))])
+      
+      ($iter _iter-register-offset _args)
+      (&/T [meta ($iter _iter-register-offset
+                        (&/|map (partial clean-unused-body-registers var-table)
                                 _args))])
 
       ($let _value _register _body)
@@ -509,8 +522,9 @@
                               (&/|map (partial clean-unused-body-registers var-table)
                                       _bodies)]))])
 
-      ($function _arity _scope _captured _body)
-      (&/T [meta ($function _arity
+      ($function _register-offset _arity _scope _captured _body)
+      (&/T [meta ($function _register-offset
+                            _arity
                             _scope
                             (&/|map (fn [capture]
                                       (|let [[_name __var] capture]
@@ -636,9 +650,10 @@
                                 _pm)
                               (&/|map (partial shift-function-body old-scope new-scope own-body?) _bodies)]))])
       
-      ($function arity scope captured body*)
+      ($function _register-offset arity scope captured body*)
       (|let [scope* (de-scope old-scope new-scope scope)]
-        (&/T [meta ($function arity
+        (&/T [meta ($function _register-offset
+                              arity
                               scope*
                               (&/|map (fn [capture]
                                         (|let [[_name [_meta ($captured _scope _idx _source)]] capture]
@@ -690,8 +705,19 @@
       ($proc proc-ident args special-args)
       (&/T [meta ($proc proc-ident (&/|map (partial shift-function-body old-scope new-scope own-body?) args) special-args)])
 
-      ($iter args)
-      (&/T [meta ($iter (&/|map (partial shift-function-body old-scope new-scope own-body?) args))])
+      ($loop _register-offset _inits _body)
+      (&/T [meta ($loop (if own-body?
+                          (inc _register-offset)
+                          _register-offset)
+                        (&/|map (partial shift-function-body old-scope new-scope own-body?)
+                                _inits)
+                        (shift-function-body old-scope new-scope own-body? _body))])
+      
+      ($iter _iter-register-offset args)
+      (&/T [meta ($iter (if own-body?
+                          (inc _iter-register-offset)
+                          _iter-register-offset)
+                        (&/|map (partial shift-function-body old-scope new-scope own-body?) args))])
 
       ($let _value _register _body)
       (&/T [meta ($let (shift-function-body old-scope new-scope own-body? _value)
@@ -771,7 +797,7 @@
     (|case optim-
       ($apply [meta-0 ($var (&/$Local 0))] _args)
       (if (= arity (&/|length _args))
-        (&/T [meta ($iter _args)])
+        (&/T [meta ($iter 0 _args)])
         optim)
 
       ($case _value [_pattern _bodies])
@@ -811,7 +837,7 @@
       (or (contains-self-reference? value)
           (&/fold stepwise-test false _bodies))
 
-      ($function arity scope captured body*)
+      ($function _ _ _ captured _)
       (->> captured
            (&/|map (fn [capture]
                      (|let [[_name [_meta ($captured _scope _idx _source)]] capture]
@@ -831,7 +857,11 @@
       ($proc proc-ident args special-args)
       (&/fold stepwise-test false args)
 
-      ($iter args)
+      ($loop _register-offset _inits _body)
+      (or (&/fold stepwise-test false _inits)
+          (contains-self-reference? _body))
+      
+      ($iter _ args)
       (&/fold stepwise-test false args)
 
       ($let _value _register _body)
@@ -850,6 +880,112 @@
       false
       )))
 
+(defn ^:private pm-loop-transform [register-offset pattern]
+  (|case pattern
+    ($BindPM _var-id)
+    ($BindPM (+ register-offset _var-id))
+
+    ($SeqPM _left-pm _right-pm)
+    ($SeqPM (pm-loop-transform register-offset _left-pm)
+            (pm-loop-transform register-offset _right-pm))
+
+    ($AltPM _left-pm _right-pm)
+    ($AltPM (pm-loop-transform register-offset _left-pm)
+            (pm-loop-transform register-offset _right-pm))
+
+    _
+    pattern
+    ))
+
+(defn ^:private loop-transform [register-offset body]
+  (|let [[meta body-] body]
+    (|case body-
+      ($variant idx is-last? value)
+      (&/T [meta ($variant idx is-last? (loop-transform register-offset value))])
+      
+      ($tuple elems)
+      (&/T [meta ($tuple (&/|map (partial loop-transform register-offset) elems))])
+      
+      ($case value [_pm _bodies])
+      (&/T [meta ($case (loop-transform register-offset value)
+                        (&/T [(pm-loop-transform register-offset _pm)
+                              (&/|map (partial loop-transform register-offset)
+                                      _bodies)]))])
+      
+      ($function _register-offset arity scope captured body*)
+      (&/T [meta ($function _register-offset
+                            arity
+                            scope
+                            (&/|map (fn [entry]
+                                      (|let [[_name _captured] entry]
+                                        (|case _captured
+                                          ;; [_meta ($captured _scope _idx [_ ($var (&/$Local _l-idx))])]
+                                          ;; (&/T [_meta ($var (&/$Local (+ register-offset (dec _l-idx))))])
+
+                                          [_meta ($captured _scope _idx _source)]
+                                          (&/T [_name _source])
+                                          )))
+                                    captured)
+                            body*)])
+
+      ($ann value-expr type-expr)
+      (&/T [meta ($ann (loop-transform register-offset value-expr)
+                       type-expr)])
+      
+      ($var (&/$Local idx))
+      ;; First, it's decreased because the var index is 1-based (since
+      ;; 0 is reserved for self-reference).
+      ;; Then, I add the offset to ensure the var points to the right register.
+      (&/T [meta ($var (&/$Local (+ register-offset (dec idx))))])
+
+      ($apply func args)
+      (&/T [meta ($apply (loop-transform register-offset func)
+                         (&/|map (partial loop-transform register-offset) args))])
+      
+      ;; ($captured scope idx [_ ($var (&/$Local _l-idx))])
+      ;; (&/T [meta ($var (&/$Local (+ register-offset (dec _l-idx))))])
+
+      ($captured scope idx source)
+      source
+      
+      ($proc proc-ident args special-args)
+      (&/T [meta ($proc proc-ident (&/|map (partial loop-transform register-offset) args) special-args)])
+
+      ($loop _register-offset _inits _body)
+      (&/T [meta ($loop (+ register-offset _register-offset)
+                        (&/|map (partial loop-transform register-offset) _inits)
+                        (loop-transform register-offset _body))])
+      
+      ($iter _iter-register-offset args)
+      (&/T [meta ($iter (+ register-offset _iter-register-offset)
+                        (&/|map (partial loop-transform register-offset) args))])
+
+      ($let _value _register _body)
+      (&/T [meta ($let (loop-transform register-offset _value)
+                       (+ register-offset _register)
+                       (loop-transform register-offset _body))])
+
+      ($record-get _value _path)
+      (&/T [meta ($record-get (loop-transform register-offset _value)
+                              _path)])
+
+      ($if _test _then _else)
+      (&/T [meta ($if (loop-transform register-offset _test)
+                      (loop-transform register-offset _then)
+                      (loop-transform register-offset _else))])
+      
+      _
+      body
+      )))
+
+(defn ^:private inline-loop [meta register-offset scope captured args body]
+  (->> body
+       (shift-function-body scope (&/|tail scope) true)
+       (loop-transform register-offset)
+       ($loop register-offset args)
+       (list meta)
+       (&/T)))
+
 ;; [[Initial Optimization]]
 
 ;; Before any big optimization can be done, the incoming Analysis nodes
@@ -897,11 +1033,11 @@
         (|let [=func (pass-0 top-level-func? func)
                =args (&/|map (partial pass-0 top-level-func?) args)]
           (|case =func
-            [_ (&a/$ann [_ ($function _arity _scope _captured _body)]
+            [_ (&a/$ann [_ ($function _register-offset _arity _scope _captured _body)]
                         _)]
             (if (and (= _arity (&/|length =args))
                      (not (contains-self-reference? _body)))
-              (&/T [meta ($apply =func =args)])
+              (inline-loop meta _register-offset _scope _captured =args _body)
               (&/T [meta ($apply =func =args)]))
             
             _
@@ -942,9 +1078,9 @@
             _
             (normal-case-optim)))
         
-        (&a/$lambda scope captured body)
+        (&a/$lambda _register-offset scope captured body)
         (|let [inner-func? (|case body
-                             [_ (&a/$lambda _ _ _)]
+                             [_ (&a/$lambda _ _ _ _)]
                              true
 
                              _
@@ -953,10 +1089,11 @@
             ;; If the body of a function is another function, that means
             ;; no work was done in-between and both layers can be folded
             ;; into one.
-            [_ ($function _arity _scope _captured _body)]
+            [_ ($function _ _arity _scope _captured _body)]
             (|let [new-arity (inc _arity)
                    collapsed-body (shift-function-body scope _scope true _body)]
-              (&/T [meta ($function new-arity
+              (&/T [meta ($function _register-offset
+                                    new-arity
                                     scope
                                     (optimize-closure (partial pass-0 top-level-func?) captured)
                                     (if top-level-func?
@@ -966,7 +1103,8 @@
             ;; Otherwise, they're nothing to be done and we've got a
             ;; 1-arity function.
             =body
-            (&/T [meta ($function 1 scope
+            (&/T [meta ($function _register-offset
+                                  1 scope
                                   (optimize-closure (partial pass-0 top-level-func?) captured)
                                   (if top-level-func?
                                     (optimize-iter 1 =body)
-- 
cgit v1.2.3


From f9872bc39ca16805bcd777c531f975c1a9ba3cbc Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Wed, 19 Oct 2016 19:15:36 -0400
Subject: - Improved the way iter works (WRT the register offset). - Fixed some
 bugs of how the loop-transform was working.

---
 src/lux/analyser/base.clj |  43 +++++++++++
 src/lux/compiler/lux.clj  |   4 +-
 src/lux/optimizer.clj     | 182 +++++++++++++++++++++++++++++++---------------
 3 files changed, 169 insertions(+), 60 deletions(-)

diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj
index 560166eb7..9bdcdeb11 100644
--- a/src/lux/analyser/base.clj
+++ b/src/lux/analyser/base.clj
@@ -86,3 +86,46 @@
 
 (defn |meta [type cursor analysis]
   (&/T [(&/T [type cursor]) analysis]))
+
+(defn de-meta
+  "(-> Analysis Analysis)"
+  [analysis]
+  (|let [[meta analysis-] analysis]
+    (|case analysis-
+      ($variant idx is-last? value)
+      ($variant idx is-last? (de-meta value))
+      
+      ($tuple elems)
+      ($tuple (&/|map de-meta elems))
+      
+      ($apply func args)
+      ($apply (de-meta func)
+              (&/|map de-meta args))
+      
+      ($case value branches)
+      ($case (de-meta value)
+             (&/|map (fn [branch]
+                       (|let [[_pattern _body] branch]
+                         (&/T [_pattern (de-meta _body)])))
+                     branches))
+      
+      ($lambda _register-offset scope captured body)
+      ($lambda _register-offset scope
+          (&/|map (fn [branch]
+                    (|let [[_name _captured] branch]
+                      (&/T [_name (de-meta _captured)])))
+                  captured)
+          (de-meta body))
+
+      ($ann value-expr type-expr)
+      (de-meta value-expr)
+      
+      ($captured scope idx source)
+      ($captured scope idx (de-meta source))
+
+      ($proc proc-ident args special-args)
+      ($proc proc-ident (&/|map de-meta args) special-args)
+      
+      _
+      analysis-
+      )))
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index 74c6221bb..f44375e97 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -152,12 +152,10 @@
 
 (defn compile-loop [compile-expression register-offset inits body]
   (|do [^MethodVisitor *writer* &/get-writer
-        :let [_ (.println System/out (pr-str 'compile-loop register-offset (&/|length inits)))]
         :let [idxs+inits (&/zip2 (&/|range* 0 (dec (&/|length inits)))
                                  inits)]
         _ (&/map% (fn [idx+_init]
                     (|do [:let [[idx _init] idx+_init
-                                _ (.println System/out (pr-str 'compile-loop/_init (&/adt->text _init)))
                                 idx+ (+ register-offset idx)]
                           _ (compile-expression nil _init)
                           :let [_ (.visitVarInsn *writer* Opcodes/ASTORE idx+)]]
@@ -170,7 +168,7 @@
 
 (defn compile-iter [compile $begin register-offset ?args]
   (|do [^MethodVisitor *writer* &/get-writer
-        :let [idxs+args (&/zip2 (&/|range* 1 (&/|length ?args))
+        :let [idxs+args (&/zip2 (&/|range* 0 (dec (&/|length ?args)))
                                 ?args)]
         _ (&/map% (fn [idx+?arg]
                     (|do [:let [[idx ?arg] idx+?arg
diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj
index 755c4aae2..5c30dc44f 100644
--- a/src/lux/optimizer.clj
+++ b/src/lux/optimizer.clj
@@ -101,6 +101,71 @@
   ;; branch's body.
   ("ExecPM" 1))
 
+(defn de-meta
+  "(-> Optimized Optimized)"
+  [optim]
+  (|let [[meta optim-] optim]
+    (|case optim-
+      ($variant idx is-last? value)
+      ($variant idx is-last? (de-meta value))
+      
+      ($tuple elems)
+      ($tuple (&/|map de-meta elems))
+      
+      ($case value [_pm _bodies])
+      ($case (de-meta value)
+             (&/T [_pm (&/|map de-meta _bodies)]))
+      
+      ($function _register-offset arity scope captured body*)
+      ($function _register-offset
+                 arity
+                 scope
+                 (&/|map (fn [capture]
+                           (|let [[_name [_meta ($captured _scope _idx _source)]] capture]
+                             (&/T [_name ($captured _scope _idx (de-meta _source))])))
+                         captured)
+                 (de-meta body*))
+
+      ($ann value-expr type-expr)
+      (de-meta value-expr)
+      
+      ($apply func args)
+      ($apply (de-meta func)
+              (&/|map de-meta args))
+      
+      ($captured scope idx source)
+      ($captured scope idx (de-meta source))
+      
+      ($proc proc-ident args special-args)
+      ($proc proc-ident (&/|map de-meta args) special-args)
+
+      ($loop _register-offset _inits _body)
+      ($loop _register-offset
+             (&/|map de-meta _inits)
+             (de-meta _body))
+      
+      ($iter _iter-register-offset args)
+      ($iter _iter-register-offset
+             (&/|map de-meta args))
+
+      ($let _value _register _body)
+      ($let (de-meta _value)
+            _register
+            (de-meta _body))
+
+      ($record-get _value _path)
+      ($record-get (de-meta _value)
+                   _path)
+
+      ($if _test _then _else)
+      ($if (de-meta _test)
+           (de-meta _then)
+           (de-meta _else))
+      
+      _
+      optim-
+      )))
+
 ;; This function does a simple transformation from the declarative
 ;; model of PM of the analyser, to the operational model of PM of the
 ;; optimizer.
@@ -797,7 +862,7 @@
     (|case optim-
       ($apply [meta-0 ($var (&/$Local 0))] _args)
       (if (= arity (&/|length _args))
-        (&/T [meta ($iter 0 _args)])
+        (&/T [meta ($iter 1 _args)])
         optim)
 
       ($case _value [_pattern _bodies])
@@ -880,99 +945,102 @@
       false
       )))
 
-(defn ^:private pm-loop-transform [register-offset pattern]
+(defn ^:private pm-loop-transform [register-offset direct? pattern]
   (|case pattern
     ($BindPM _var-id)
-    ($BindPM (+ register-offset _var-id))
+    ($BindPM (+ register-offset (if direct?
+                                  (- _var-id 2)
+                                  (- _var-id 1))))
 
     ($SeqPM _left-pm _right-pm)
-    ($SeqPM (pm-loop-transform register-offset _left-pm)
-            (pm-loop-transform register-offset _right-pm))
+    ($SeqPM (pm-loop-transform register-offset direct? _left-pm)
+            (pm-loop-transform register-offset direct? _right-pm))
 
     ($AltPM _left-pm _right-pm)
-    ($AltPM (pm-loop-transform register-offset _left-pm)
-            (pm-loop-transform register-offset _right-pm))
+    ($AltPM (pm-loop-transform register-offset direct? _left-pm)
+            (pm-loop-transform register-offset direct? _right-pm))
 
     _
     pattern
     ))
 
-(defn ^:private loop-transform [register-offset body]
-  (|let [[meta body-] body]
+;; This function must be run STRICTLY before shift-function body, as
+;; the transformation assumes that SFB will be invoke after it.
+(defn ^:private loop-transform [register-offset direct? body]
+  (|let [adjust-direct (fn [register]
+                         ;; The register must be decreased once, since
+                         ;; it will be re-increased in
+                         ;; shift-function-body.
+                         ;; The decrease is meant to keep things stable.
+                         (if direct?
+                           ;; And, if this adjustment is done
+                           ;; directly during a loop-transform (and
+                           ;; not indirectly if transforming an inner
+                           ;; loop), then it must be decreased again
+                           ;; because the 0/self var will no longer
+                           ;; exist in the loop's context.
+                           (- register 2)
+                           (- register 1)))
+         [meta body-] body]
     (|case body-
       ($variant idx is-last? value)
-      (&/T [meta ($variant idx is-last? (loop-transform register-offset value))])
+      (&/T [meta ($variant idx is-last? (loop-transform register-offset direct? value))])
       
       ($tuple elems)
-      (&/T [meta ($tuple (&/|map (partial loop-transform register-offset) elems))])
+      (&/T [meta ($tuple (&/|map (partial loop-transform register-offset direct?) elems))])
       
       ($case value [_pm _bodies])
-      (&/T [meta ($case (loop-transform register-offset value)
-                        (&/T [(pm-loop-transform register-offset _pm)
-                              (&/|map (partial loop-transform register-offset)
+      (&/T [meta ($case (loop-transform register-offset direct? value)
+                        (&/T [(pm-loop-transform register-offset direct? _pm)
+                              (&/|map (partial loop-transform register-offset direct?)
                                       _bodies)]))])
-      
-      ($function _register-offset arity scope captured body*)
-      (&/T [meta ($function _register-offset
-                            arity
-                            scope
-                            (&/|map (fn [entry]
-                                      (|let [[_name _captured] entry]
-                                        (|case _captured
-                                          ;; [_meta ($captured _scope _idx [_ ($var (&/$Local _l-idx))])]
-                                          ;; (&/T [_meta ($var (&/$Local (+ register-offset (dec _l-idx))))])
-
-                                          [_meta ($captured _scope _idx _source)]
-                                          (&/T [_name _source])
-                                          )))
-                                    captured)
-                            body*)])
 
+      ;; Functions are ignored because they'll be handled properly at shift-function-body
+      
       ($ann value-expr type-expr)
-      (&/T [meta ($ann (loop-transform register-offset value-expr)
+      (&/T [meta ($ann (loop-transform register-offset direct? value-expr)
                        type-expr)])
       
       ($var (&/$Local idx))
-      ;; First, it's decreased because the var index is 1-based (since
-      ;; 0 is reserved for self-reference).
+      ;; The index must be decreased once, because the var index is
+      ;; 1-based (since 0 is reserved for self-reference).
+      ;; Then it must be decreased again, since it will be increased
+      ;; in the shift-function-body call.
       ;; Then, I add the offset to ensure the var points to the right register.
-      (&/T [meta ($var (&/$Local (+ register-offset (dec idx))))])
+      (&/T [meta ($var (&/$Local (-> (adjust-direct idx)
+                                     (+ register-offset))))])
 
       ($apply func args)
-      (&/T [meta ($apply (loop-transform register-offset func)
-                         (&/|map (partial loop-transform register-offset) args))])
+      (&/T [meta ($apply (loop-transform register-offset direct? func)
+                         (&/|map (partial loop-transform register-offset direct?) args))])
       
-      ;; ($captured scope idx [_ ($var (&/$Local _l-idx))])
-      ;; (&/T [meta ($var (&/$Local (+ register-offset (dec _l-idx))))])
-
-      ($captured scope idx source)
-      source
+      ;; Captured-vars are ignored because they'll be handled properly at shift-function-body
       
       ($proc proc-ident args special-args)
-      (&/T [meta ($proc proc-ident (&/|map (partial loop-transform register-offset) args) special-args)])
+      (&/T [meta ($proc proc-ident (&/|map (partial loop-transform register-offset direct?) args) special-args)])
 
       ($loop _register-offset _inits _body)
-      (&/T [meta ($loop (+ register-offset _register-offset)
-                        (&/|map (partial loop-transform register-offset) _inits)
-                        (loop-transform register-offset _body))])
+      (&/T [meta ($loop (+ register-offset (adjust-direct _register-offset))
+                        (&/|map (partial loop-transform register-offset direct?) _inits)
+                        (loop-transform register-offset direct? _body))])
       
       ($iter _iter-register-offset args)
-      (&/T [meta ($iter (+ register-offset _iter-register-offset)
-                        (&/|map (partial loop-transform register-offset) args))])
+      (&/T [meta ($iter (+ register-offset (adjust-direct _iter-register-offset))
+                        (&/|map (partial loop-transform register-offset direct?) args))])
 
       ($let _value _register _body)
-      (&/T [meta ($let (loop-transform register-offset _value)
-                       (+ register-offset _register)
-                       (loop-transform register-offset _body))])
+      (&/T [meta ($let (loop-transform register-offset direct? _value)
+                       (+ register-offset (adjust-direct _register))
+                       (loop-transform register-offset direct? _body))])
 
       ($record-get _value _path)
-      (&/T [meta ($record-get (loop-transform register-offset _value)
+      (&/T [meta ($record-get (loop-transform register-offset direct? _value)
                               _path)])
 
       ($if _test _then _else)
-      (&/T [meta ($if (loop-transform register-offset _test)
-                      (loop-transform register-offset _then)
-                      (loop-transform register-offset _else))])
+      (&/T [meta ($if (loop-transform register-offset direct? _test)
+                      (loop-transform register-offset direct? _then)
+                      (loop-transform register-offset direct? _else))])
       
       _
       body
@@ -980,8 +1048,8 @@
 
 (defn ^:private inline-loop [meta register-offset scope captured args body]
   (->> body
+       (loop-transform register-offset true)
        (shift-function-body scope (&/|tail scope) true)
-       (loop-transform register-offset)
        ($loop register-offset args)
        (list meta)
        (&/T)))
@@ -1033,8 +1101,8 @@
         (|let [=func (pass-0 top-level-func? func)
                =args (&/|map (partial pass-0 top-level-func?) args)]
           (|case =func
-            [_ (&a/$ann [_ ($function _register-offset _arity _scope _captured _body)]
-                        _)]
+            [_ ($ann [_ ($function _register-offset _arity _scope _captured _body)]
+                     _)]
             (if (and (= _arity (&/|length =args))
                      (not (contains-self-reference? _body)))
               (inline-loop meta _register-offset _scope _captured =args _body)
-- 
cgit v1.2.3