PreviousUpNext

15.4.485  src/lib/compiler/back/top/improve-nextcode/inline-nextcode-buckpass-calls.pkg

## inline-nextcode-buckpass-calls.pkg 
#
# A function call like
#
#     fun f x =  g x;
#
# does nothing useful; it simply passes the
# buck to 'g'.  Consequently we can replace
# (f x) by (g x) everywhere in the code
# and save the overhead of one function call.
#
# Doing that (properly!) is our job here.
#
# In the lambda calculus this is called "eta conversion".

# Compiled by:
#     src/lib/compiler/core.sublib



# This file implements one of the nextcode transforms.
# For context, see the comments in
#
#     src/lib/compiler/back/top/highcode/highcode-form.api



#    "Elimination of eta-redexes:  Replaces all expressions of the form
#     \x.fx with f.  Because this tends to undo the work of etasplit and
#     because it is rarely beneficial, this phase is used only at the
#     very beginning to clean up the output of the nextcode conversion,
#     and at the end when eta-redexes are not beneficial any more."
#
#     [...]
#
#    "It seemed easy and harmless to move eta-elimination into
#     'fcontract', and with similar benefits as above.  In retrospect,
#     it took a long time to debug, which, I later learned, was the
#     main reason why it was a separate phase [...]"
#
#
#          -- Principled Compilation and Scavenging
#             Stefan Monnier, 2003 [PhD Thesis, U Montreal]
#             http://www.iro.umontreal.ca/~monnier/master.ps.gz 



# *********************************************************************
#
#   The function eta is an eta reducer for nextcode expressions.  It is
#   guaranteed to reach an eta normal form in at most two passes.  A
#   high-level description of the algorithm follows.
#
#   eta essentially takes two arguments, a nextcode expression and an
#   dictionary mapping variables to values.  (In practice, the
#   dictionary is a global variable.)  The dictionary is used to
#   keep track of the eta reductions performed.  The algorithm can be
#   explained by the two key clauses below (written in pseudo-nextcode
#   notation):
#
#   [MUTUALLY_RECURSIVE_FNS]   eta (dictionary, *let* f[x1, ..., xN] = M1
#                    *in*  M2)
#
#         --> let M1' = eta (dictionary, M1)
#             in  if M1' == g[x1, ..., xN]
#                 then eta (dictionary[f := g], M2)
#                 else *let* f[x1, ..., xN] = M1'
#                      *in*  eta (dictionary, M2)
#             end
#
#   [APPLY]   eta (dictionary, f[v1, ..., vN])
#
#         --> dictionary (f)[dictionary (v1), ..., dictionary (vN)]

#   In the [MUTUALLY_RECURSIVE_FNS] case of function definition, we first eta reduce the
#   body M1 of the function f, then see if f is itself an eta
#   redex f[x1, ..., xN] = g[x1, ..., xN].  If so, we will use g for f
#   elsewhere in the nextcode expression.
#
#   The [APPLY] case shows where we must rename variables.
#
#   This would get all eta redexes in one pass, except for the
#   following problem.  Consider the nextcode code below:
#
#          *let* f[x1, ..., xN] = M1
#          *and* g[y1, ..., yN] = f[x1, ..., xN]
#          *in*  M2
#
#   Suppose M1 does not reduce to an application h[x1, ..., xN].
#   If we naively reduce the expression as above, first reducing
#   the body M1 of f, then the body of g, then M2, we would get:
#
#        let M1' = eta (dictionary, M1)
#        in  *let* f[x1, ..., xN] = M1'
#            *in*  eta (dictionary[g := f], M2)
#        end
#
#   The problem with this is that M1 might have contained occurrences
#   of g.  Thus g may appear in M1'.  There are a number of ways to
#   handle this:

#    1) Once we perform an eta reduction on any function in a
#       MUTUALLY_RECURSIVE_FNS, we  must go back and re-reduce
#       any other functions of the MUTUALLY_RECURSIVE_FNS
#       that we previously reduced;
#    2) We do not go back to other functions in the
#       MUTUALLY_RECURSIVE_FNS, but instead make a second pass over the output of eta.
#
#   As (1) can lead to quadratic behaviour, we implemented (2).
#
#
#   A final note: we recognize more than just
#         f[x1, ..., xN] = g[x1, ..., xN]
#   as an eta reduction.  We regard the function definition
#         f[x1, ..., xN] = SELECT[1, v, g, g[x1, ..., xN]]
#   as an eta redex as well, and so we reduce
#      eta (dictionary,*let* f[x1, ..., xN] = SELECT[i, v, g, g[x1, ..., xN]]
#              *in*  M1)
#      --> SELECT (i, v, g, eta (dictionary[f := g], M1))
#   This is implemented with the selectapp function below.
#
# *********************************************************************

stipulate
    package ncf =  nextcode_form;                       # nextcode_form                 is from   src/lib/compiler/back/top/nextcode/nextcode-form.pkg
herein

    api Inline_Nextcode_Buckpass_Calls {
        #
        inline_nextcode_buckpass_calls
            :
            { function: ncf::Function,
              click:    String -> Void
            }
            ->
            ncf::Function;
    };
end;



stipulate
    package ncf =  nextcode_form;                       # nextcode_form                 is from   src/lib/compiler/back/top/nextcode/nextcode-form.pkg
    package tmp =  highcode_codetemp;                   # highcode_codetemp             is from   src/lib/compiler/back/top/highcode/highcode-codetemp.pkg
    package iht =  int_hashtable;                       # int_hashtable                 is from   src/lib/src/int-hashtable.pkg

    package intset {

        Intset = Ref( int_red_black_set::Set );

        fun new () = REF int_red_black_set::empty;

        fun add set i =  set := int_red_black_set::add (*set, i);
        fun mem set i =  int_red_black_set::member(*set, i);
        fun rmv set i =  set := int_red_black_set::delete(*set, i);
    };
herein


    package  inline_nextcode_buckpass_calls
    : (weak) Inline_Nextcode_Buckpass_Calls                     # Inline_Nextcode_Buckpass_Calls                is from   src/lib/compiler/back/top/improve-nextcode/inline-nextcode-buckpass-calls.pkg
    {

        fun inline_nextcode_buckpass_calls
              {
                function => (fkind, fvar, fargs, ctyl, cexp),
                click
              }
            = 
            {
                debug = *global_controls::compiler::debugnextcode;              # FALSE 

                fun debugprint s  = if  debug    global_controls::print::say s;    fi;
                fun debugflush () = if  debug    global_controls::print::flush();  fi;

                fun map1 f (a, b)
                    =
                    (f a, b); 

                fun member (i:  Int, a ! b) =>   i == a or member (i, b);
                    member (i,[])           =>   FALSE;
                end;

                fun same (v ! vl, (ncf::CODETEMP w) ! wl) =>   v == w and same (vl, wl);
                    same (NIL, NIL)                       =>   TRUE;
                    same _                                =>   FALSE;
                end;

                fun share_name (x, ncf::CODETEMP y) =>  tmp::share_name (x, y); 
                    share_name (x, ncf::LABEL    y) =>  tmp::share_name (x, y); 
                    share_name _                    =>  ();
                end;

                exception M_TWO;

                my m:  iht::Hashtable( ncf::Value )
                    =
                    iht::make_hashtable  { size_hint => 32,  not_found_exception => M_TWO };

                name = iht::get  m;

                fun rename (v0 as ncf::CODETEMP v) =>  (rename (name v) except M_TWO = v0);
                    rename (v0 as ncf::LABEL    v) =>  (rename (name v) except M_TWO = v0);
                    rename x => x;
                end;

                fun newname x
                    =
                    {   share_name x;
                        iht::set m x;
                    };

                stipulate

                    km =  intset::new ():  intset::Intset;

                herein

                    fun addvt (v, ncf::typ::FATE) =>  intset::add  km  v;
                        addvt _                   =>  ();
                    end;

                    fun addft (ncf::NEXT_FN, v, _, _, _) =>   intset::add km v;
                        addft _                          =>   ();
                    end;

                    fun is_cont  v
                        =
                        intset::mem  km  v;
                end;

                id = (fn x = x);

                do_again =  REF FALSE;

                recursive my pass2
                    = 
                    fn  ncf::DEFINE_RECORD { kind, to_temp, fields,                             next               }
                     => ncf::DEFINE_RECORD { kind, to_temp, fields => map (map1 rename) fields, next => pass2 next };
                        #
                        ncf::GET_FIELD_I   { i, record, to_temp, type, next               }
                     => ncf::GET_FIELD_I   { i, record, to_temp, type, next => pass2 next };
                        #
                        ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp,       next               }
                     => ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp,       next => pass2 next };
                        #
                        ncf::MATH   { op, args, to_temp, type, next } =>  ncf::MATH   { op,  args => map rename args,  to_temp, type,  next => pass2 next  };
                        ncf::PURE   { op, args, to_temp, type, next } =>  ncf::PURE   { op,  args => map rename args,  to_temp, type,  next => pass2 next  };
                        #
                        ncf::FETCH_FROM_RAM { op, args, to_temp, type, next } =>  ncf::FETCH_FROM_RAM { op, args => map rename args, to_temp, type, next => pass2 next };
                        ncf::STORE_TO_RAM   { op, args,                next } =>  ncf::STORE_TO_RAM   { op, args => map rename args,                next => pass2 next };
                        #       
                        ncf::TAIL_CALL { func, args }         =>  ncf::TAIL_CALL {  func => rename func,   args => map rename args };
                        ncf::JUMPTABLE { i, xvar, nexts }     =>  ncf::JUMPTABLE { i, xvar, nexts =>  map pass2 nexts };
                        #
                        ncf::IF_THEN_ELSE { op, args,                    xvar, then_next,                   else_next                   }
                     => ncf::IF_THEN_ELSE { op, args => map rename args, xvar, then_next => pass2 then_next, else_next => pass2 else_next };
                        #
                        ncf::RAW_C_CALL { kind, cfun_name, cfun_type,  args,                     to_ttemps,  next               }
                     => ncf::RAW_C_CALL { kind, cfun_name, cfun_type,  args => map rename args,  to_ttemps,  next => pass2 next };
                        #
                        ncf::DEFINE_FUNS { funs, next }
                            =>
                            ncf::DEFINE_FUNS  { funs =>  map   (fn (fk, f, vl, cl, body) = (fk, f, vl, cl, pass2 body))   funs,
                                                next =>  pass2 next
                                              };
                     end;

                recursive my reduce
                    = 
                    fn  ncf::DEFINE_RECORD { kind, to_temp,  fields,                              next                }
                     => ncf::DEFINE_RECORD { kind, to_temp,  fields => map (map1 rename) fields,  next => reduce next };
                        #
                        ncf::GET_FIELD_I   { i, record, to_temp, type, next } => { addvt (to_temp, type);   ncf::GET_FIELD_I { i, record, to_temp, type, next => reduce next };};
                        #
                        ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next                }
                     => ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next => reduce next };
                        #
                        ncf::MATH   { op, args, to_temp, type, next } => { addvt (to_temp, type);  ncf::MATH   { op,  args => map rename args,  to_temp, type,  next => reduce next  }; };
                        ncf::PURE   { op, args, to_temp, type, next } => { addvt (to_temp, type);  ncf::PURE   { op,  args => map rename args,  to_temp, type,  next => reduce next  }; };
                        #
                        ncf::FETCH_FROM_RAM { op, args, to_temp, type, next } => { addvt (to_temp, type);  ncf::FETCH_FROM_RAM { op, args => map rename args, to_temp, type, next => reduce next }; };
                        ncf::STORE_TO_RAM   { op, args,                next } =>                           ncf::STORE_TO_RAM   { op, args => map rename args,                next => reduce next };
                        #
                        ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next }
                            => 
                            {   apply  addvt  to_ttemps;
                                #
                                ncf::RAW_C_CALL { kind, cfun_name, cfun_type,  args => map rename args,  to_ttemps,  next => reduce next  };
                            };
                        #
                        ncf::TAIL_CALL { func, args }     =>  ncf::TAIL_CALL { func => rename func,  args => map rename args };
                        ncf::JUMPTABLE { i, xvar, nexts } =>  ncf::JUMPTABLE { i, xvar, nexts => map reduce nexts };
                        #
                        ncf::IF_THEN_ELSE { op, args, xvar, then_next, else_next }
                            =>
                            ncf::IF_THEN_ELSE
                              { op,
                                args => map rename args,
                                xvar,
                                then_next => reduce then_next,
                                else_next => reduce else_next
                              };
                        #
                        ncf::DEFINE_FUNS { funs, next }
                            =>
                            case (eta_elim  funs) 
                                #
                                ([],   h, _) => h  (reduce next);
                                (funs, h, _) => h  (ncf::DEFINE_FUNS { funs, next => reduce next });
                            esac
                            where

                                apply addft  funs;

                                fun eta_elim  NIL
                                        =>
                                        (NIL, id, FALSE);

                                    eta_elim((fk as ncf::NO_INLINE_INTO, f, vl, cl, body) ! r)
                                        => 
                                        {   my (r', h, leftover) = eta_elim r;
                                            body' = reduce body;
                                            ((fk, f, vl, cl, body') ! r', h, TRUE);
                                        };

                                    eta_elim((fk, f, vl, cl, body) ! r)
                                        =>
                                        {   my (r', h, leftover) = eta_elim r;

                                            fun right_kind (ncf::CODETEMP v | ncf::LABEL v)
                                                    => 
                                                    ((fk == ncf::NEXT_FN) == (is_cont v));

                                                right_kind _
                                                     =>
                                                     FALSE;
                                            end;

                                            fun selectapp (ncf::GET_FIELD_I { i, record => ncf::CODETEMP w, to_temp => v, type => t, next => e })
                                                    =>
                                                    case (selectapp e )
                                                        #
                                                        NULL => NULL;

                                                        THE (h', u)
                                                            =>
                                                            if (not (member (w, f ! vl)))    THE (fn ce = ncf::GET_FIELD_I { i, record => ncf::CODETEMP w, to_temp => v, type => t, next => h' ce }, u);
                                                            else                             NULL;
                                                            fi;
                                                    esac;

                                                selectapp (ncf::TAIL_CALL { func => g, args => wl })
                                                    =>
                                                    {   g' = rename g;

                                                        z  =  case g'   ncf::CODETEMP x =>  member (x, f ! vl);
                                                                        ncf::LABEL    x =>  member (x, f ! vl);
                                                                        _               =>  FALSE;
                                                              esac;

                                                        if (((not z) and (same (vl, wl)))
                                                                    and (right_kind g'))     

                                                             THE  (fn ce = ce,  g');
                                                        else NULL;
                                                        fi;
                                                    };

                                                selectapp _ => NULL;
                                            end;

                                            paired_lists::apply addvt (vl, cl);
                                            body' = reduce body;

                                            case (selectapp  body')
                                                #
                                                NULL => ((fk, f, vl, cl, body') ! r', h, TRUE);

                                                THE (h', u)
                                                    =>
                                                    {   if leftover  do_again := TRUE;   fi;

                                                        click "e";
                                                        newname (f, u);
                                                        (r', h' o h, leftover);
                                                    };
                                            esac;
                                        };
                                end;                                    # fun eta_elim
                            end;
                    end;

                    # Body of eta:
                    #   
                    debugprint "Eta: ";
                    debugflush();
                    cexp' = reduce cexp;
                    debugprint "\n";

                    debugflush ();

                    if (not *do_again)
                        #
                        (fkind, fvar, fargs, ctyl, cexp');
                    else
                        debugprint "Eta: needed second pass\n";
                        debugflush ();
                        (fkind, fvar, fargs, ctyl, pass2 cexp');
                    fi;

            };                  # fun     inline_nextcode_buckpass_calls
    };                          # package inline_nextcode_buckpass_calls
end;                            # toplevel stipulate 



Comments and suggestions to: bugs@mythryl.org

PreviousUpNext