PreviousUpNext

15.4.497  src/lib/compiler/back/top/improve/loopify-anormcode.pkg

## loopify-anormcode.pkg
## monnier@cs.yale.edu 

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



# This is one of the A-Normal Form compiler passes --
# for context see the comments in
#
#     src/lib/compiler/back/top/anormcode/anormcode-form.api
#



#    "Look for functions that call themselves, wrap them
#     up in a pre-header, eliminate arguments that stay
#     constant through the loop, and check whether all the
#     recursive calls are in tail position, in which case
#     the loop is marked as being a 'while' loop.  The
#     corresponding optimization in the old optimizer
#     was done in 'expand'."
#
#     [...]
#
#    "'loopify_anormcode' was moved out of
#     'improve_mutually_recursive_anormcode_functions' because it
#     does not need to be run as often, but it requires two
#     passes (a first pass that collects information and
#     a second that does the code transformation) whereas
#     'improve_mutually_recursive_anormcode_functions' is implemented
#     in a single pass."
#
#          -- Principled Compilation and Scavenging
#             Stefan Monnier, 2003 [PhD Thesis, U Montreal]
#             http://www.iro.umontreal.ca/~monnier/master.ps.gz 
#
# See also:
#
#     Loop Headers in \-calculus or FPS
#     Andrew W Appel
#     1994, 6p
#     http://citeseer.ist.psu.edu/appel94loop.html
#         One reference for src/lib/compiler/back/top/improve-nextcode/do-nextcode-inlining-g.pkg



###                  "There is no monument dedicated
###                   to the memory of a committee."
###
###                          -- Lester J. Pourciau



stipulate
    package acf =  anormcode_form;                      # anormcode_form        is from   src/lib/compiler/back/top/anormcode/anormcode-form.pkg
herein

    api Loopify_Anormcode {
        #
        loopify_anormcode:  acf::Function -> acf::Function;
    };
end;

stipulate
    package acf =  anormcode_form;                      # anormcode_form                is from   src/lib/compiler/back/top/anormcode/anormcode-form.pkg
    package asc =  anormcode_sequencer_controls;        # anormcode_sequencer_controls  is from   src/lib/compiler/back/top/main/anormcode-sequencer-controls.pkg
    package hut =  highcode_uniq_types;                 # highcode_uniq_types           is from   src/lib/compiler/back/top/highcode/highcode-uniq-types.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 im  =  int_red_black_map;                   # int_red_black_map             is from   src/lib/src/int-red-black-map.pkg
    package is  =  int_red_black_set;                   # int_red_black_set             is from   src/lib/src/int-red-black-set.pkg
    package no  =  null_or;                             # null_or                       is from   src/lib/std/src/null-or.pkg
    package ou  =  opt_utils;                           # opt_utils                     is from   src/lib/compiler/back/top/improve/optutils.pkg
herein

    package   loopify_anormcode
    :         Loopify_Anormcode                         # Loopify_Anormcode             is from   src/lib/compiler/back/top/improve/loopify-anormcode.pkg
    {
        say = control_print::say;

        fun bug msg = error_message::impossible ("Loopify_Anormcode: " + msg);

        cplv = tmp::clone_highcode_codetemp;

        Al = List( List( acf::Value ) );

        Info = INFO  { tails:  Ref( Al ),
                       calls:  Ref( Al ),
                       icalls: Ref( Al ),
                       tcp:    Ref( Bool ),
                       parent: tmp::Codetemp
                     };

        exception NOT_FOUND;

        fun loopify_anormcode (program as (progkind, progname, progargs, progbody))
            =
            {   my  m: iht::Hashtable( Info )
                    =
                    iht::make_hashtable  { size_hint => 128,  not_found_exception => NOT_FOUND };

                # tails: number of tail-recursive calls
                # calls: number of other calls
                # icalls: non-tail self-recursive subset of `calls'
                # tcp: always called in tail-position
                # parent: enclosing function
                #
                fun new (f, known, parent)
                    =
                    info
                    where
                        info = INFO { tails=>REF [],
                                   calls=>REF [],
                                   icalls=>REF [],
                                   tcp=>REF known,
                                   parent
                                 };

                        iht::set m (f, info);
                    end;

                fun get f
                    =
                    iht::get  m  f;

            # collect tries to determine what calls are tail recursive.
            # If a function f is always called in tail position in a function g,
            # then all tail calls to g from f are indeed tail recursive.

            # tfs:  we are currently in tail position relative to those functions
            # p:  englobing function

            fun collect p tfs le
                =
                {
                    loop = collect p tfs;

                    case le

                          acf::RET _ => ();

                          acf::LET(_, body, le)
                              =>
                              {   collect p is::empty body;
                                  loop le;
                              };

                          acf::MUTUALLY_RECURSIVE_FNS([( { loop_info=>(NULL | THE(_, acf::TAIL_RECURSIVE_LOOP)), private, ... }, f, _, body)], le)
                              =>
                              {   my INFO { tcp, calls, icalls, ... } = new (f, private, p);
                                  loop le;
                                  necalls = length *calls;
                                  collect f (if *tcp  is::add (tfs, f); else is::singleton f;fi) body;
                                  icalls := list::take_n (*calls, length *calls - necalls);
                              };

                          acf::MUTUALLY_RECURSIVE_FNS (fdecs, le)
                              =>
                              {   # Create the new entries in the map 
                                  #     
                                  fs = map (fn (fk as { private, ... }, f, _, body)
                                               =
                                               (fk, f, body, new (f, FALSE, p))
                                           )
                                           fdecs;

                                  fun cfun ( { loop_info, ... }:  acf::Function_Notes,   f, body, INFO { calls, icalls, ... } )
                                      =
                                      {   necalls = length *calls;
                                          collect f (is::singleton f) body;
                                          icalls := list::take_n (*calls, length *calls - necalls);
                                      };

                                  loop le;

                                  apply cfun fs;
                              };

                          acf::APPLY (acf::VAR f, vs)
                              =>
                              {   my INFO { tails, calls, tcp, parent, ... } = get f;

                                  if (is::member (tfs, f) )
                                       tails := vs ! *tails;
                                  else
                                       calls := vs ! *calls;
                                       if (not (is::member (tfs, parent)))  tcp := FALSE;   fi;
                                  fi;
                              }
                              except
                                  NOT_FOUND = ();

                          acf::TYPEFUN((_, _, _, body), le)
                              =>
                              {   collect p is::empty body;
                                  loop le;
                              };

                          acf::APPLY_TYPEFUN _
                              =>
                              ();

                          acf::SWITCH (v, ac, arms, def)
                              =>
                              {   fun carm (_, body)
                                      =
                                      loop body;

                                  apply carm arms;

                                  case def
                                      THE le =>  loop le;
                                      _      =>  ();
                                  esac;
                              };

                          ( acf::CONSTRUCTOR(_, _, _, _, le)
                          | acf::RECORD     (_, _, _,    le)
                          | acf::GET_FIELD     (_, _, _,    le)
                          | acf::BASEOP     (_, _, _,    le)
                          )
                              =>
                              loop le;

                          acf::RAISE _ => ();
                          acf::EXCEPT (le, v) => collect p is::empty le;
                          acf::BRANCH(_, _, le1, le2) => { loop le1; loop le2;};

                          acf::APPLY _ => bug "weird acf::APPLY in collect";
                    esac;
                };

            # (intended as a `fold_backward' argument).
            # `filt' is the bool list indicating if the arg is kept
            # `func' is the list of arguments for the MUTUALLY_RECURSIVE_FNS
            # `call' is the list of arguments for the APPLY
            # `free' is the list of resulting free variables
            #
            fun drop_invariant ((v, t), actuals, (filt, func, call, free))
                =
                if (*asc::dropinvariant and list::all (fn a => acf::VAR v == a; end ) actuals )
                    #
                    (FALSE ! filt, func, call, (v, t) ! free);          #  Drop the argument: the free list is unchanged. 
                else
                    # Keep the argument:
                    # Create a new var (used in the call)
                    # which will replace the old
                    # in the free vars:
                    #
                    nv = cplv v;
                    (TRUE ! filt, (v, t) ! func, (acf::VAR nv) ! call, (nv, t) ! free);
                fi;

            # m:  intmap( Int ) renaming for function calls
            # tf: List( Int, Int )      the current functions (if any) and their tail version
            # le:                       you get the idea
            #
            fun lambda_expression m tfs le
                =
                {
                    loop = lambda_expression m tfs;

                    case le

                         acf::RET _
                             =>
                             le;

                         acf::LET (lvs, body, le)
                             =>
                             acf::LET (lvs, lambda_expression m [] body, loop le);

                         acf::MUTUALLY_RECURSIVE_FNS (fdecs, le)
                             =>
                             acf::MUTUALLY_RECURSIVE_FNS (map cfun fdecs, loop le)
                             where

                                 fun cfun
                                     ( fk: acf::Function_Notes as { loop_info=>THE (ltys, acf::OTHER_LOOP), call_as, ... },
                                       f,
                                       args,
                                       body
                                     )
                                     =>
                                     {   (get f) ->   INFO { tcp=>REF tcp, icalls=>REF icalls, tails=>REF tails, ... };

                                         tfs =   if tcp  tfs;
                                                 else    [];
                                                 fi;

                                         # optional_nextcode_improvers uses the following condition:
                                         # escape = 0 and *unroll_call > 0
                                         #          and (*call - *unroll_call > 1 
                                         #                   or list::exists (fn t=t) inv)
                                         # `escape = 0': I don't quite see the need for it, though it
                                         #    probably won't change much since split_known_escaping_functions should have
                                         #    made "everything" known already.
                                         # `!call - *unroll_call > 1 or list::exists (fn t=t) inv)':
                                         #    loopification is only useful if there is more than one
                                         #    external call or if there are loop invariants.
                                         #    Note that we deal with invariants elsewhere, so it's
                                         #    not a good reason to loopify here.

                                         # *** rationale behind the restrictions: ***
                                         # `icallnb = 0': loopification is pointless and will be
                                         #     undone by fcontract.
                                         # `c::callnb fi <= icallnb + 1': if there's only one external
                                         #     call, loopification will probably (?) not be of much use
                                         #     and the same benefit would be had by just moving f.
                                         #
                                         if (null icalls and null tails)
                                             #
                                             (fk, f, args, lambda_expression m tfs body);
                                         else
                                             call_as'
                                                  =
                                                  case call_as
                                                      #
                                                      ( acf::CALL_AS_GENERIC_PACKAGE
                                                      | acf::CALL_AS_FUNCTION  hut::FIXED_CALLING_CONVENTION
                                                      )
                                                           =>
                                                           call_as;

                                                       acf::CALL_AS_FUNCTION (hut::VARIABLE_CALLING_CONVENTION { arg_is_raw => f1,   body_is_raw => f2 }) =>
                                                       acf::CALL_AS_FUNCTION (hut::VARIABLE_CALLING_CONVENTION { arg_is_raw => TRUE, body_is_raw => f2 });
                                                  esac;

                                             # Figure out which arguments of the tail loop
                                             # are invariants and create the corresponding
                                             # function args, call args, filter
                                             # function for the actual calls, ...
                                             #
                                             my (tfs', atfun, atcall, args, ft)
                                                 =
                                                 if (null tails )

                                                     (tfs,[],[], args, f);
                                                 else
                                                     ft = cplv f;
                                                     actuals = ou::transpose tails;
                                                     my (fcall, afun, acall, afree) =
                                                         paired_lists::fold_backward drop_invariant
                                                                        ([],[],[],[])
                                                                        (args, actuals);
                                                     ( (f, ft, fcall) ! tfs,
                                                       afun, acall, afree, ft);
                                                 fi;

                                             # Do the same for the non-tail loop.  
                                             #
                                             my (nm, alfun, alcall, args, fl)
                                                 =
                                                 if (null icalls )

                                                     (m,[],[], args, f);

                                                 else

                                                     fl = cplv f;

                                                     actuals = ou::transpose icalls;

                                                     my (fcall, afun, acall, afree)
                                                         =
                                                         paired_lists::fold_backward drop_invariant
                                                                        ([],[],[],[])
                                                                        (args, actuals);

                                                     (im::set (m, f, (fl, fcall)),
                                                       afun, acall, afree, fl);
                                                 fi;

                                             # Make the new body:
                                             #
                                             nbody = lambda_expression nm tfs' body;

                                             # Wrap into a tail loop if necessary:
                                             #
                                             nbody
                                                 =
                                                 if (null tails)

                                                     nbody;
                                                 else
                                                     acf::MUTUALLY_RECURSIVE_FNS([( { loop_info=>THE (ltys, acf::TAIL_RECURSIVE_LOOP),
                                                              private=>TRUE, inlining_hint=>acf::INLINE_IF_SIZE_SAFE,
                                                              call_as=>call_as'}, ft, atfun,
                                                             nbody)],

                                                     acf::APPLY (acf::VAR ft, atcall));
                                                 fi;

                                             # Wrap into a non-tail
                                             # loop if necessary.
                                             #
                                             nbody
                                                 =
                                                 if (null icalls)

                                                     nbody;

                                                 else
                                                     acf::MUTUALLY_RECURSIVE_FNS([( { loop_info=>THE (ltys, acf::PREHEADER_WRAPPED_LOOP),
                                                              private=>TRUE, inlining_hint=>acf::INLINE_IF_SIZE_SAFE,
                                                              call_as=>call_as'}, fl, alfun,
                                                             nbody)],

                                                     acf::APPLY (acf::VAR fl, alcall));
                                                 fi;

                                             (fk, f, args, nbody);
                                         fi;
                                     };

                                     cfun (fk as { inlining_hint=>acf::INLINE_ONCE_WITHIN_ITSELF, loop_info=>THE _, ... }, f, args, body)
                                         =>
                                         {   (get f) ->   INFO { tcp=>REF tcp, ... };
                                             #
                                             (fk, f, args, lambda_expression m (if tcp  tfs; else [];fi) body);
                                         };

                                     cfun (fk, f, args, body)
                                         =>
                                         {   (get f) ->   INFO { tcp=>REF tcp, ... };
                                             #
                                             (fk, f, args, lambda_expression m (if tcp  tfs; else [];fi) body);
                                         };
                                  end;                  # fun cfun
                             end;

                         acf::APPLY (acf::VAR f, vs)
                             =>
                             case (list::find (fn (ft, ft', filt) => ft == f; end ) tfs)

                                  THE (ft, ft', filt)
                                      =>
                                      acf::APPLY (acf::VAR ft', ou::filter filt vs);

                                  NULL
                                      => 
                                      case (im::get (m, f) )

                                           THE (fl, filt)
                                               =>
                                               acf::APPLY (acf::VAR fl, ou::filter filt vs);

                                           NULL => le;
                                      esac;

                             esac;

                         acf::TYPEFUN((tfk, f, args, body), le)
                             =>
                             acf::TYPEFUN((tfk, f, args, loop body), loop le);

                         acf::APPLY_TYPEFUN (f, typs)
                             =>
                             le;

                         acf::SWITCH (v, ac, arms, def)
                             =>
                             acf::SWITCH (v, ac, map carm arms, no::map loop def)
                             where
                                 fun carm (con, le)
                                     =
                                     (con, loop le);
                             end;

                         acf::CONSTRUCTOR (dc, typs, v, lv, le) =>  acf::CONSTRUCTOR (dc, typs, v, lv, loop le);
                         acf::RECORD (rk, vs, lv, le)           =>  acf::RECORD (rk, vs, lv, loop le);
                         acf::GET_FIELD (v, i, lv, le)          =>  acf::GET_FIELD (v, i, lv, loop le);

                         acf::RAISE (v, ltys) => le;

                         acf::EXCEPT (le, v)            => acf::EXCEPT (lambda_expression m [] le, v);
                         acf::BRANCH (po, vs, le1, le2) => acf::BRANCH (po, vs, loop le1, loop le2);
                         acf::BASEOP (po, vs, lv, le)   => acf::BASEOP (po, vs, lv, loop le);

                         acf::APPLY _ => bug "unexpected APPLY";
                    esac;
            };                                  # fun lambda_expression


            collect  progname  is::empty  progbody;

            ( progkind,
              progname,
              progargs,
              lambda_expression im::empty [] progbody
            );
        };
    };
end;




Comments and suggestions to: bugs@mythryl.org

PreviousUpNext