path: root/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis/variable.lux

... 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 https://mozilla.org/MPL/2.0/.

(.require
 [library
  [lux (.except)
   [abstract
    ["[0]" monad (.only do)]]
   [control
    ["[0]" maybe (.use "[1]#[0]" functor)]
    ["[0]" try (.only Try)]
    ["[0]" exception (.only Exception)]]
   [data
    ["[0]" product]
    ["[0]" text (.only)
     ["%" \\format]]
    [collection
     ["[0]" dictionary (.only Dictionary)]
     ["[0]" list (.use "[1]#[0]" functor mix)]
     ["[0]" set]]]
   [math
    [number
     ["n" nat]]]
   [meta
    [macro
     ["^" pattern]]]]]
 [////
  ["[0]" analysis (.only)
   ["[1]/[0]" complex]]
  ["/" synthesis (.only Path)
   ["[1][0]" access]]
  [///
   [arity (.only Arity)]
   ["[0]" reference (.only)
    ["[0]" variable (.only Register Variable)]]]])

(def (prune redundant register)
  (-> Register Register
      Register)
  (if (n.> redundant register)
    (-- register)
    register))

(type (Remover a)
  (-> Register
      (-> a a)))

(def (remove_local_from_path remove_local redundant)
  (-> (Remover /.Term)
      (Remover Path))
  (function (again path)
    (when path
      {/.#Seq {/.#Bind register}
              post}
      (if (n.= redundant register)
        (again post)
        {/.#Seq {/.#Bind (if (n.> redundant register)
                           (-- register)
                           register)}
                (again post)})

      (^.or {/.#Seq {/.#Access {/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 {/access.#Member member}}
                            {/.#Bind register}}
                    post})
      (if (n.= redundant register)
        (again post)
        {/.#Seq {/.#Access {/access.#Member member}}
                {/.#Seq {/.#Bind (if (n.> redundant register)
                                   (-- register)
                                   register)}
                        (again post)}})

      (^.with_template [<tag>]
        [{<tag> left right}
         {<tag> (again left) (again right)}])
      ([/.#Seq]
       [/.#Alt])

      {/.#Bit_Fork when then else}
      {/.#Bit_Fork when (again then) (maybe#each again else)}

      (^.with_template [<tag>]
        [{<tag> [[test then] tail]}
         {<tag> [[test (again then)]
                 (list#each (function (_ [test' then'])
                              [test' (again then')])
                            tail)]}])
      ([/.#I64_Fork]
       [/.#F64_Fork]
       [/.#Text_Fork])
      
      (^.or {/.#Pop}
            {/.#Access _})
      path

      {/.#Bind register}
      (undefined)
      
      {/.#Then then}
      {/.#Then (remove_local redundant then)}
      )))

(def (remove_local_from_variable redundant variable)
  (Remover Variable)
  (when variable
    {variable.#Local register}
    {variable.#Local (..prune redundant register)}
    
    {variable.#Foreign register}
    variable))

(def (remove_local redundant)
  (Remover /.Term)
  (function (again synthesis)
    (when synthesis
      [@ {/.#Simple _}]
      synthesis
      
      [@ {/.#Structure structure}]
      [@ {/.#Structure (when structure
                         {analysis/complex.#Variant [lefts right value]}
                         {analysis/complex.#Variant [lefts right (again value)]}
                         
                         {analysis/complex.#Tuple tuple}
                         {analysis/complex.#Tuple (list#each again tuple)})}]
      
      [@ {/.#Reference reference}]
      (when reference
        {reference.#Variable variable}
        (/.variable @ (..remove_local_from_variable redundant variable))

        {reference.#Constant constant}
        synthesis)
      
      [@ {/.#Control control}]
      [@ {/.#Control (when control
                       {/.#Branch branch}
                       {/.#Branch (when branch
                                    {/.#Exec this that}
                                    {/.#Exec (again this)
                                             (again that)}
                                    
                                    {/.#Let [register input] output}
                                    {/.#Let [(..prune redundant register)
                                             (again input)]
                                            (again output)}
                                    
                                    {/.#If test then else}
                                    {/.#If (again test) (again then) (again else)}
                                    
                                    {/.#Get path record}
                                    {/.#Get path (again record)}
                                    
                                    {/.#When input path}
                                    {/.#When (again input) (remove_local_from_path remove_local redundant path)})}
                       
                       {/.#Loop loop}
                       {/.#Loop (when loop
                                  {/.#Scope [start inits iteration]}
                                  {/.#Scope [(..prune redundant start)
                                             (list#each again inits)
                                             (again iteration)]}
                                  
                                  {/.#Again resets}
                                  {/.#Again (list#each again resets)})}

                       {/.#Function function}
                       {/.#Function (when function
                                      {/.#Abstraction [environment arity body]}
                                      {/.#Abstraction [(list#each again environment)
                                                       arity
                                                       body]}

                                      {/.#Apply abstraction inputs}
                                      {/.#Apply (again abstraction) (list#each again inputs)})})}]
      
      [@ {/.#Extension name inputs}]
      [@ {/.#Extension name (list#each again inputs)}])))

(type Redundancy
  (Dictionary Register Bit))

(def initial
  Redundancy
  (dictionary.empty 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#each (n.+ offset)))]
    [extension
     (list#mix (function (_ register redundancy)
                 (dictionary.has register ..necessary! redundancy))
               redundancy
               extension)]))

(def (default arity)
  (-> Arity
      Redundancy)
  (product.right (..extended 0 (++ arity) ..initial)))

(type (Optimization of)
  (-> [Redundancy of]
      (Try [Redundancy of])))

(def (list_optimization optimization)
  (All (_ of)
    (-> (Optimization of)
        (Optimization (List of))))
  (function (again [redundancy values])
    (when values
      {.#End}
      {try.#Success [redundancy
                     values]}

      {.#Item head tail}
      (do try.monad
        [[redundancy head] (optimization [redundancy head])
         [redundancy tail] (again [redundancy tail])]
        (in [redundancy
             {.#Item head tail}])))))

(with_template [<name>]
  [(exception.def .public (<name> register)
     (Exception Register)
     (exception.report
      (list ["Register" (%.nat register)])))]

  [redundant_declaration]
  [unknown_register]
  )

(def (declare register redundancy)
  (-> Register Redundancy
      (Try Redundancy))
  (when (dictionary.value register redundancy)
    {.#None}
    {try.#Success (dictionary.has register ..redundant! redundancy)}
    
    {.#Some _}
    (exception.except ..redundant_declaration [register])))

(def (observe register redundancy)
  (-> Register Redundancy
      (Try Redundancy))
  (when (dictionary.value register redundancy)
    {.#None}
    (exception.except ..unknown_register [register])
    
    {.#Some _}
    {try.#Success (dictionary.has register ..necessary! redundancy)}))

(def (format redundancy)
  (%.Format Redundancy)
  (|> redundancy
      dictionary.entries
      (list#each (function (_ [register redundant?])
                   (%.format (%.nat register) ": " (%.bit redundant?))))
      (text.interposed ", ")))

(def (path_optimization optimization)
  (-> (Optimization /.Term)
      (Optimization Path))
  (function (again [redundancy path])
    (when path
      (^.or {/.#Pop}
            {/.#Access _})
      {try.#Success [redundancy
                     path]}

      {/.#Bit_Fork test then else}
      (do [! try.monad]
        [[redundancy then] (again [redundancy then])
         [redundancy else] (when else
                             {.#Some else}
                             (of ! each
                                 (function (_ [redundancy else])
                                   [redundancy {.#Some else}])
                                 (again [redundancy else]))

                             {.#None}
                             (in [redundancy {.#None}]))]
        (in [redundancy {/.#Bit_Fork test then else}]))
      
      (^.with_template [<tag> <type>]
        [{<tag> [[test then] elses]}
         (do [! try.monad]
           [[redundancy then] (again [redundancy then])
            [redundancy elses] (..list_optimization (is (Optimization [<type> Path])
                                                        (function (_ [redundancy [else_test else_then]])
                                                          (do !
                                                            [[redundancy else_then] (again [redundancy else_then])]
                                                            (in [redundancy [else_test else_then]]))))
                                                    [redundancy elses])]
           (in [redundancy {<tag> [[test then] elses]}]))])
      ([/.#I64_Fork I64]
       [/.#F64_Fork Frac]
       [/.#Text_Fork Text])
      
      {/.#Bind register}
      (do try.monad
        [redundancy (..declare register redundancy)]
        (in [redundancy
             path]))
      
      {/.#Alt left right}
      (do try.monad
        [[redundancy left] (again [redundancy left])
         [redundancy right] (again [redundancy right])]
        (in [redundancy {/.#Alt left right}]))
      
      {/.#Seq pre post}
      (do try.monad
        [.let [baseline (|> redundancy
                            dictionary.keys
                            (set.of_list n.hash))]
         [redundancy pre] (again [redundancy pre])
         .let [bindings (|> redundancy
                            dictionary.keys
                            (set.of_list n.hash)
                            (set.difference baseline))]
         [redundancy post] (again [redundancy post])
         .let [redundants (|> redundancy
                              dictionary.entries
                              (list.only (function (_ [register redundant?])
                                           (and (set.member? bindings register)
                                                redundant?)))
                              (list#each product.left))]]
        (in [(list#mix dictionary.lacks redundancy (set.list bindings))
             (|> redundants
                 (list.sorted n.>)
                 (list#mix (..remove_local_from_path ..remove_local) {/.#Seq pre post}))]))

      {/.#Then then}
      (do try.monad
        [[redundancy then] (optimization [redundancy then])]
        (in [redundancy {/.#Then then}]))
      )))

(def (optimization' [redundancy synthesis])
  (Optimization /.Term)
  (with_expansions [<no_op> (these {try.#Success [redundancy
                                                  synthesis]})]
    (when synthesis
      [@ {/.#Simple _}]
      <no_op>
      
      [@ {/.#Structure structure}]
      (when structure
        {analysis/complex.#Variant [lefts right value]}
        (do try.monad
          [[redundancy value] (optimization' [redundancy value])]
          (in [redundancy
               [@ {/.#Structure {analysis/complex.#Variant [lefts right value]}}]]))
        
        {analysis/complex.#Tuple tuple}
        (do try.monad
          [[redundancy tuple] (..list_optimization optimization' [redundancy tuple])]
          (in [redundancy
               [@ {/.#Structure {analysis/complex.#Tuple tuple}}]])))
      
      [@ {/.#Reference reference}]
      (when reference
        {reference.#Variable variable}
        (when 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}]
      (when control
        {/.#Branch branch}
        (when branch
          {/.#Exec this that}
          (do try.monad
            [[redundancy this] (optimization' [redundancy this])
             [redundancy that] (optimization' [redundancy that])]
            (in [redundancy
                 (/.branch/exec @ [this that])]))
          
          {/.#Let [register input] output}
          (do try.monad
            [[redundancy input] (optimization' [redundancy input])
             redundancy (..declare register redundancy)
             [redundancy output] (optimization' [redundancy output])
             .let [redundant? (|> redundancy
                                  (dictionary.value register)
                                  (maybe.else ..necessary!))]]
            (in [(dictionary.lacks register redundancy)
                 [@ {/.#Control {/.#Branch (if redundant?
                                             {/.#Exec input (..remove_local register output)}
                                             {/.#Let [register input] output})}}]]))
          
          {/.#If test then else}
          (do try.monad
            [[redundancy test] (optimization' [redundancy test])
             [redundancy then] (optimization' [redundancy then])
             [redundancy else] (optimization' [redundancy else])]
            (in [redundancy
                 [@ {/.#Control {/.#Branch {/.#If test then else}}}]]))
          
          {/.#Get path record}
          (do try.monad
            [[redundancy record] (optimization' [redundancy record])]
            (in [redundancy
                 [@ {/.#Control {/.#Branch {/.#Get path record}}}]]))
          
          {/.#When input path}
          (do try.monad
            [[redundancy input] (optimization' [redundancy input])
             [redundancy path] (..path_optimization optimization' [redundancy path])]
            (in [redundancy
                 [@ {/.#Control {/.#Branch {/.#When input path}}}]])))
        
        {/.#Loop loop}
        (when 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])]
            (in [(list#mix dictionary.lacks redundancy extension)
                 [@ {/.#Control {/.#Loop {/.#Scope [start inits iteration]}}}]]))
          
          {/.#Again resets}
          (do try.monad
            [[redundancy resets] (..list_optimization optimization' [redundancy resets])]
            (in [redundancy
                 [@ {/.#Control {/.#Loop {/.#Again resets}}}]])))

        {/.#Function function}
        (when function
          {/.#Abstraction [environment arity body]}
          (do [! try.monad]
            [[redundancy environment] (..list_optimization optimization' [redundancy environment])
             [_ body] (optimization' [(..default arity) body])]
            (in [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])]
            (in [redundancy
                 [@ {/.#Control {/.#Function {/.#Apply abstraction inputs}}}]]))))
      
      [@ {/.#Extension name inputs}]
      (do try.monad
        [[redundancy inputs] (..list_optimization optimization' [redundancy inputs])]
        (in [redundancy
             [@ {/.#Extension name inputs}]])))))

(def .public optimization
  (-> /.Term
      (Try /.Term))
  (|>> [..initial]
       optimization'
       (of try.monad each product.right)))