Optimizing-away unnecessary variable declarations/bindings.

2 files changed, 427 insertions, 10 deletions

diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux
index 33e94f89a..54f299c31 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux
@@ -13,6 +13,7 @@
   ["." / #_
    ["#." function]
    ["#." case]
+   ["#." variable]
    ["/#" // #_
     ["#." extension]
     ["/#" // #_
@@ -42,9 +43,9 @@
      [#///analysis.Int #/.I64]
      [#///analysis.Rev #/.I64])))
 
-(def: #export (phase archive)
+(def: (optimization archive)
   Phase
-  (function (phase' analysis)
+  (function (optimization' analysis)
     (case analysis
       (#///analysis.Primitive analysis')
       (phase@wrap (#/.Primitive (..primitive analysis')))
@@ -54,12 +55,12 @@
         (case structure
           (#///analysis.Variant variant)
           (do phase.monad
-            [valueS (phase' (get@ #///analysis.value variant))]
+            [valueS (optimization' (get@ #///analysis.value variant))]
             (wrap (/.variant (set@ #///analysis.value valueS variant))))
 
           (#///analysis.Tuple tuple)
           (|> tuple
-              (monad.map phase.monad phase')
+              (monad.map phase.monad optimization')
               (phase@map (|>> /.tuple)))))
       
       (#///analysis.Reference reference)
@@ -67,29 +68,35 @@
 
       (#///analysis.Case inputA branchesAB+)
       (/.with-currying? false
-        (/case.synthesize phase branchesAB+ archive inputA))
+        (/case.synthesize optimization branchesAB+ archive inputA))
 
       (^ (///analysis.no-op value))
-      (phase' value)
+      (optimization' value)
 
       (#///analysis.Apply _)
       (/.with-currying? false
-        (/function.apply phase archive analysis))
+        (/function.apply optimization archive analysis))
 
       (#///analysis.Function environmentA bodyA)
-      (/function.abstraction phase environmentA archive bodyA)
+      (/function.abstraction optimization environmentA archive bodyA)
 
       (#///analysis.Extension name args)
       (/.with-currying? false
         (function (_ state)
-          (|> (//extension.apply archive phase [name args])
+          (|> (//extension.apply archive optimization [name args])
               (phase.run' state)
               (case> (#try.Success output)
                      (#try.Success output)
                      
                      (#try.Failure _)
                      (|> args
-                         (monad.map phase.monad phase')
+                         (monad.map phase.monad optimization')
                          (phase@map (|>> [name] #/.Extension))
                          (phase.run' state))))))
       )))
+
+(def: #export (phase archive analysis)
+  Phase
+  (do phase.monad
+    [synthesis (..optimization archive analysis)]
+    (phase.lift (/variable.optimization synthesis))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux
new file mode 100644
index 000000000..dd0d49608
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux
@@ -0,0 +1,410 @@
+(.module:
+  [lux #*
+   [abstract
+    ["." monad (#+ do)]]
+   [control
+    ["." try (#+ Try)]
+    ["." exception (#+ exception:)]]
+   [data
+    ["." product]
+    ["." maybe]
+    [number
+     ["n" nat]]
+    ["." text
+     ["%" format]]
+    [collection
+     ["." dictionary (#+ Dictionary)]
+     ["." list ("#@." functor fold)]
+     ["." set]]]]
+  [////
+   ["/" synthesis (#+ Path Synthesis)]
+   ["." analysis]
+   [///
+    [arity (#+ Arity)]
+    ["." reference
+     ["." variable (#+ Register Variable)]]]])
+
+(def: (prune redundant register)
+  (-> Register Register Register)
+  (if (n.> redundant register)
+    (dec register)
+    register))
+
+(type: (Remover a)
+  (-> Register (-> a a)))
+
+(def: (remove-local-from-path remove-local redundant)
+  (-> (Remover Synthesis) (Remover Path))
+  (function (recur path)
+    (case path
+      (#/.Seq (#/.Bind register)
+              post)
+      (if (n.= redundant register)
+        (recur post)
+        (#/.Seq (#/.Bind (if (n.> redundant register)
+                           (dec register)
+                           register))
+                (recur post)))
+
+      (^or (#/.Seq (#/.Access (#/.Member member))
+                   (#/.Seq (#/.Bind register)
+                           post))
+           ## This alternative form should never occur in practice.
+           ## Yet, it is "technically" possible to construct it.
+           (#/.Seq (#/.Seq (#/.Access (#/.Member member))
+                           (#/.Bind register))
+                   post))
+      (if (n.= redundant register)
+        (recur post)
+        (#/.Seq (#/.Access (#/.Member member))
+                (#/.Seq (#/.Bind (if (n.> redundant register)
+                                   (dec register)
+                                   register))
+                        (recur post))))
+
+      (^template [<tag>]
+        (<tag> left right)
+        (<tag> (recur left) (recur right)))
+      ([#/.Seq]
+       [#/.Alt])
+
+      (^or #/.Pop
+           (#/.Test _)
+           (#/.Access _))
+      path
+
+      (#/.Bind register)
+      (undefined)
+      
+      (#/.Then then)
+      (#/.Then (remove-local redundant then))
+      )))
+
+(def: (remove-local-from-variable redundant variable)
+  (Remover Variable)
+  (case variable
+    (#variable.Local register)
+    (#variable.Local (..prune redundant register))
+    
+    (#variable.Foreign register)
+    variable))
+
+(def: (remove-local redundant)
+  (Remover Synthesis)
+  (function (recur synthesis)
+    (case synthesis
+      (#/.Primitive _)
+      synthesis
+      
+      (#/.Structure structure)
+      (#/.Structure (case structure
+                      (#analysis.Variant [lefts right value])
+                      (#analysis.Variant [lefts right (recur value)])
+                      
+                      (#analysis.Tuple tuple)
+                      (#analysis.Tuple (list@map recur tuple))))
+      
+      (#/.Reference reference)
+      (case reference
+        (#reference.Variable variable)
+        (/.variable (..remove-local-from-variable redundant variable))
+
+        (#reference.Constant constant)
+        synthesis)
+      
+      (#/.Control control)
+      (#/.Control (case control
+                    (#/.Branch branch)
+                    (#/.Branch (case branch
+                                 (#/.Let input register output)
+                                 (#/.Let (recur input)
+                                         (..prune redundant register)
+                                         (recur output))
+                                 
+                                 (#/.If test then else)
+                                 (#/.If (recur test) (recur then) (recur else))
+                                 
+                                 (#/.Get path record)
+                                 (#/.Get path (recur record))
+                                 
+                                 (#/.Case input path)
+                                 (#/.Case (recur input) (remove-local-from-path remove-local redundant path))))
+                    
+                    (#/.Loop loop)
+                    (#/.Loop (case loop
+                               (#/.Scope [start inits iteration])
+                               (#/.Scope [(..prune redundant start)
+                                          (list@map recur inits)
+                                          (recur iteration)])
+                               
+                               (#/.Recur resets)
+                               (#/.Recur (list@map recur resets))))
+
+                    (#/.Function function)
+                    (#/.Function (case function
+                                   (#/.Abstraction [environment arity body])
+                                   (#/.Abstraction [(list@map (..remove-local-from-variable redundant) environment)
+                                                    arity
+                                                    body])
+
+                                   (#/.Apply abstraction inputs)
+                                   (#/.Apply (recur abstraction) (list@map recur inputs))))))
+      
+      (#/.Extension name inputs)
+      (#/.Extension name (list@map recur inputs)))))
+
+(type: Redundancy
+  (Dictionary Register Bit))
+
+(def: initial
+  Redundancy
+  (dictionary.new n.hash))
+
+(def: redundant! true)
+(def: necessary! false)
+
+(def: (extended offset amount redundancy)
+  (-> Register Nat Redundancy [(List Register) Redundancy])
+  (let [extension (|> amount list.indices (list@map (n.+ offset)))]
+    [extension
+     (list@fold (function (_ register redundancy)
+                  (dictionary.put register ..necessary! redundancy))
+                redundancy
+                extension)]))
+
+(def: (default arity)
+  (-> Arity Redundancy)
+  (product.right (..extended 0 (inc arity) ..initial)))
+
+(type: (Optimization a)
+  (-> [Redundancy a] (Try [Redundancy a])))
+
+(def: (list-optimization optimization)
+  (-> (Optimization Synthesis) (Optimization (List Synthesis)))
+  (function (recur [redundancy values])
+    (case values
+      #.Nil
+      (#try.Success [redundancy
+                     values])
+
+      (#.Cons head tail)
+      (do try.monad
+        [[redundancy head] (optimization [redundancy head])
+         [redundancy tail] (recur [redundancy tail])]
+        (wrap [redundancy
+               (#.Cons head tail)])))))
+
+(template [<name>]
+  [(exception: #export (<name> {register Register})
+     (exception.report
+      ["Register" (%.nat register)]))]
+
+  [redundant-declaration]
+  [unknown-register]
+  )
+
+(def: (declare register redundancy)
+  (-> Register Redundancy (Try Redundancy))
+  (case (dictionary.get register redundancy)
+    #.None
+    (#try.Success (dictionary.put register ..redundant! redundancy))
+    
+    (#.Some _)
+    (exception.throw ..redundant-declaration [register])))
+
+(def: (observe register redundancy)
+  (-> Register Redundancy (Try Redundancy))
+  (case (dictionary.get register redundancy)
+    #.None
+    (exception.throw ..unknown-register [register])
+    
+    (#.Some _)
+    (#try.Success (dictionary.put register ..necessary! redundancy))))
+
+(def: (format redundancy)
+  (%.Format Redundancy)
+  (|> redundancy
+      dictionary.entries
+      (list@map (function (_ [register redundant?])
+                  (%.format (%.nat register) ": " (%.bit redundant?))))
+      (text.join-with ", ")))
+
+(def: (path-optimization optimization)
+  (-> (Optimization Synthesis) (Optimization Path))
+  (function (recur [redundancy path])
+    (case path
+      (^or #/.Pop
+           (#/.Test _)
+           (#/.Access _))
+      (#try.Success [redundancy
+                     path])
+      
+      (#/.Bind register)
+      (do try.monad
+        [redundancy (..declare register redundancy)]
+        (wrap [redundancy
+               path]))
+      
+      (#/.Alt left right)
+      (do try.monad
+        [[redundancy left] (recur [redundancy left])
+         [redundancy right] (recur [redundancy right])]
+        (wrap [redundancy (#/.Alt left right)]))
+      
+      (#/.Seq pre post)
+      (do try.monad
+        [#let [baseline (|> redundancy
+                            dictionary.keys
+                            (set.from-list n.hash))]
+         [redundancy pre] (recur [redundancy pre])
+         #let [bindings (|> redundancy
+                            dictionary.keys
+                            (set.from-list n.hash)
+                            (set.difference baseline))]
+         [redundancy post] (recur [redundancy post])
+         #let [redundants (|> redundancy
+                              dictionary.entries
+                              (list.filter (function (_ [register redundant?])
+                                             (and (set.member? bindings register)
+                                                  redundant?)))
+                              (list@map product.left))]]
+        (wrap [(list@fold dictionary.remove redundancy (set.to-list bindings))
+               (|> redundants
+                   (list.sort n.>)
+                   (list@fold (..remove-local-from-path ..remove-local) (#/.Seq pre post)))]))
+
+      (#/.Then then)
+      (do try.monad
+        [[redundancy then] (optimization [redundancy then])]
+        (wrap [redundancy (#/.Then then)]))
+      )))
+
+(def: (variable-optimization variable redundancy)
+  (-> Variable Redundancy (Try Redundancy))
+  (case variable
+    (#variable.Local register)
+    (..observe register redundancy)
+    
+    (#variable.Foreign register)
+    (#try.Success redundancy)))
+
+(def: (optimization' [redundancy synthesis])
+  (Optimization Synthesis)
+  (with-expansions [<no-op> (as-is (#try.Success [redundancy
+                                                  synthesis]))]
+    (case synthesis
+      (#/.Primitive _)
+      <no-op>
+      
+      (#/.Structure structure)
+      (case structure
+        (#analysis.Variant [lefts right value])
+        (do try.monad
+          [[redundancy value] (optimization' [redundancy value])]
+          (wrap [redundancy
+                 (#/.Structure (#analysis.Variant [lefts right value]))]))
+        
+        (#analysis.Tuple tuple)
+        (do try.monad
+          [[redundancy tuple] (..list-optimization optimization' [redundancy tuple])]
+          (wrap [redundancy
+                 (#/.Structure (#analysis.Tuple tuple))])))
+      
+      (#/.Reference reference)
+      (case reference
+        (#reference.Variable variable)
+        (case variable
+          (#variable.Local register)
+          (do try.monad
+            [redundancy (..observe register redundancy)]
+            <no-op>)
+          
+          (#variable.Foreign register)
+          <no-op>)
+
+        (#reference.Constant constant)
+        <no-op>)
+      
+      (#/.Control control)
+      (case control
+        (#/.Branch branch)
+        (case branch
+          (#/.Let input register output)
+          (do try.monad
+            [[redundancy input] (optimization' [redundancy input])
+             redundancy (..declare register redundancy)
+             [redundancy output] (optimization' [redundancy output])
+             #let [redundant? (|> redundancy
+                                  (dictionary.get register)
+                                  (maybe.default ..necessary!))]]
+            (wrap [(dictionary.remove register redundancy)
+                   (#/.Control (if redundant?
+                                 (#/.Branch (#/.Case input
+                                                     (#/.Seq #/.Pop
+                                                             (#/.Then (..remove-local register output)))))
+                                 (#/.Branch (#/.Let input register output))))]))
+          
+          (#/.If test then else)
+          (do try.monad
+            [[redundancy test] (optimization' [redundancy test])
+             [redundancy then] (optimization' [redundancy then])
+             [redundancy else] (optimization' [redundancy else])]
+            (wrap [redundancy
+                   (#/.Control (#/.Branch (#/.If test then else)))]))
+          
+          (#/.Get path record)
+          (do try.monad
+            [[redundancy record] (optimization' [redundancy record])]
+            (wrap [redundancy
+                   (#/.Control (#/.Branch (#/.Get path record)))]))
+          
+          (#/.Case input path)
+          (do try.monad
+            [[redundancy input] (optimization' [redundancy input])
+             [redundancy path] (..path-optimization optimization' [redundancy path])]
+            (wrap [redundancy
+                   (#/.Control (#/.Branch (#/.Case input path)))])))
+        
+        (#/.Loop loop)
+        (case loop
+          (#/.Scope [start inits iteration])
+          (do try.monad
+            [[redundancy inits] (..list-optimization optimization' [redundancy inits])
+             #let [[extension redundancy] (..extended start (list.size inits) redundancy)]
+             [redundancy iteration] (optimization' [redundancy iteration])]
+            (wrap [(list@fold dictionary.remove redundancy extension)
+                   (#/.Control (#/.Loop (#/.Scope [start inits iteration])))]))
+          
+          (#/.Recur resets)
+          (do try.monad
+            [[redundancy resets] (..list-optimization optimization' [redundancy resets])]
+            (wrap [redundancy
+                   (#/.Control (#/.Loop (#/.Recur resets)))])))
+
+        (#/.Function function)
+        (case function
+          (#/.Abstraction [environment arity body])
+          (do {@ try.monad}
+            [redundancy (monad.fold @ ..variable-optimization redundancy environment)
+             [_ body] (optimization' [(..default arity) body])]
+            (wrap [redundancy
+                   (#/.Control (#/.Function (#/.Abstraction [environment arity body])))]))
+          
+          (#/.Apply abstraction inputs)
+          (do try.monad
+            [[redundancy abstraction] (optimization' [redundancy abstraction])
+             [redundancy inputs] (..list-optimization optimization' [redundancy inputs])]
+            (wrap [redundancy
+                   (#/.Control (#/.Function (#/.Apply abstraction inputs)))]))))
+      
+      (#/.Extension name inputs)
+      (do try.monad
+        [[redundancy inputs] (..list-optimization optimization' [redundancy inputs])]
+        (wrap [redundancy
+               (#/.Extension name inputs)])))))
+
+(def: #export optimization
+  (-> Synthesis (Try Synthesis))
+  (|>> [..initial]
+       optimization'
+       (:: try.monad map product.right)))