PreviousUpNext

15.4.496  src/lib/compiler/back/top/improve/improve-mutually-recursive-anormcode-functions.pkg

## improve-mutually-recursive-anormcode-functions.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
#



#    "Decide which functions are candidates for inlining,
#     rewrite curried functions like 'uncurry' did in the
#     old optimizer, and break up groups of apparently
#     mutually-recursive functions into smaller subgroups.
#
#    "Other than introducing loop pre-headers, done in
#     'loopify_anormcode', and deciding which function calls to
#     inline and to perform the inlining itself, done in
#     'fcontract', this phase corresponds to the 'expand'
#     phase of the old optimizer."
#
#     [...]
#
#    "The reason to move the actual inlining out of
#    'improve_mutually_recursive_anormcode_functions' and
#     into 'fcontract' was so that cascading inlining
#     could take place.  It also simplified
#     'improve_mutually_recursive_anormcode_functions' slightly.
#     Another reason was that 'split' requires that the choice
#     of inlining candidates be separate from the inlining itself."
#
#          -- Principled Compilation and Scavenging
#             Stefan Monnier, 2003 [PhD Thesis, U Montreal]
#             http://www.iro.umontreal.ca/~monnier/master.ps.gz 



# This module does various MUTUALLY_RECURSIVE_FNS-related transformations:
# - MUTUALLY_RECURSIVE_FNSes are split into their strongly-connected components
# - small non-recursive functions are marked inlinable
# - curried functions are uncurried



###          "Good engineering doesn't consist
###           of random acts of heroism."
###
###                     -- Harry Robinson


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

    api Improve_Mutually_Recursive_Anormcode_Functions {
        #
        improve_mutually_recursive_anormcode_functions
            :
            acf::Function -> acf::Function;
    };
end;


# Maybe later:
# - hoisting of inner functions out of their englobing function
#   so that the outer function becomes smaller, giving more opportunity
#   for inlining.
# - eta expand escaping functions
# - loop-preheader introduction


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 is  =  int_red_black_set;                   # int_red_black_set             is from   src/lib/src/int-red-black-set.pkg
    package im  =  int_red_black_map;                   # int_red_black_map             is from   src/lib/src/int-red-black-map.pkg
    package pp  =  prettyprint_anormcode;               # prettyprint_anormcode         is from   src/lib/compiler/back/top/anormcode/prettyprint-anormcode.pkg
    package hcf =  highcode_form;                       # highcode_form                 is from   src/lib/compiler/back/top/highcode/highcode-form.pkg
    package hut =  highcode_uniq_types;                 # highcode_uniq_types           is from   src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg
    package ou  =  opt_utils;                           # opt_utils                     is from   src/lib/compiler/back/top/improve/optutils.pkg
    package tmp =  highcode_codetemp;                   # highcode_codetemp             is from   src/lib/compiler/back/top/highcode/highcode-codetemp.pkg
herein

                                                 #     Improve_Mutually_Recursive_Anormcode_Functions   is from   src/lib/compiler/back/top/improve/improve-mutually-recursive-anormcode-functions.pkg

    package improve_mutually_recursive_anormcode_functions:   Improve_Mutually_Recursive_Anormcode_Functions {
        #

        say = control_print::say;
        #
        fun bug msg
            =
            error_message::impossible ("improve_mutually_recursive_anormcode_functions: " + msg);
        #
        fun buglexp (msg, le) = { say "\n"; pp::print_lexp le; say " "; bug msg;};
        fun bugval  (msg,  v) = { say "\n"; pp::print_sval  v; say " "; bug msg;};
        #
        fun assert p
            =
            if (not p)
                bug ("assertion failed");
            fi;
        #
        fun bugsay s
            =
            say ("!*!*! improve_mutually_recursive_anormcode_functions: " + s + " !*!*!\n");

        cplv = tmp::clone_highcode_codetemp;

        # To limit the amount of uncurrying:
        #
        maxargs = asc::maxargs;

        package scc_node
            =
            package {
                Key = tmp::Codetemp;                            # In practice Codetemp == Int.
                compare = int::compare;
            };

        package scc
            =
            digraph_strongly_connected_components_g(
                scc_node
            );

        Info = FUN  Ref( Int )
             | ARG  (Int, Ref ((Int, Int)))
             ;

        # float_expression: Int REF intmapf -> Lambda_Expression) -> (Int * intset * Lambda_Expression)
        # The intmap contains refs to counters.  The meaning of the counters
        # is slightly overloaded:
        # - if the counter is negative, it means the Variable
        #   is a locally known function and the counter's absolute value denotes
        #   the number of calls (off by one to make sure it's always negative).
        # - else, it indicates that the Variable is a
        #   function argument and the absolute value is a (fuzzily defined) measure
        #   of the reduction in code size/speed that would result from knowing
        #   its value (might be used to decide whether or not duplicating code is
        #   desirable at a specific call site).
        # The three subparts returned are:
        # - the size of Lambda_Expression
        # - the set of freevariables of Lambda_Expression (plus the ones passed as arguments
        #   which are assumed to be the freevars of the fate of Lambda_Expression)
        # - a new Lambda_Expression with MUTUALLY_RECURSIVE_FNSes rewritten.
        #
        fun float_expression mf depth lambda_expression
            =
            {   loop =  float_expression mf depth;
                #
                fun lookup (acf::VAR lv) =>  im::get (mf, lv);
                    lookup _           =>  NULL;
                end;
                #
                fun s_rmv (x, s)
                    =
                    is::delete (s, x)
                    except
                        not_found = s;
                #
                fun addv (s, acf::VAR lv) => is::add (s, lv);
                    addv (s, _) => s;
                end;
                #
                fun addvs (s, vs) =  fold_forward  (fn (v, s) = addv  (s, v))  s  vs;
                fun rmvs (s, lvs) =  fold_forward  (fn (l, s) = s_rmv (l, s))  s  lvs;


                # Look for free vars in the baseop descriptor.
                # This is normally unnecessary since these are special vars anyway
                #
                fun fpo (fv, (NULL: Null_Or( acf::Dictionary ), po, lambda_type, typs))
                        =>
                        fv;

                    fpo (fv, (THE { default, table },   po, lambda_type, typs))
                        =>
                        addvs (addv (fv, acf::VAR default), map (acf::VAR o #2) table);
                end;


                # Look for free vars in the
                # baseop descriptor.
                #
                # This is normally unnecessary since
                # these are exception vars anyway:
                #
                fun fdcon (fv, (s, varhome::EXCEPTION (varhome::HIGHCODE_VARIABLE lv), lambda_type))
                        =>
                        addv (fv, acf::VAR lv);

                    fdcon (fv, _)
                        =>
                        fv;
                end;


                # Recognize the curried essence of a function.
                # - hd: fkind Null_Or identifies the head of the curried function
                # - na: Int gives the number of args still allowed
                #
                fun curry (hd, na)
                          (le as acf::MUTUALLY_RECURSIVE_FNS([(fk as { inlining_hint => acf::INLINE_IF_SIZE_SAFE, ... }, f, args, body)], acf::RET [acf::VAR lv]))
                        =>
                        if (lv == f  and  na >= length(args))
                            #
                            case (hd, fk)
                                #
                                # Recursive functions are only accepted for uncurrying
                                # if they are the head of the function or if the head
                                # is already recursive

                                ( (THE { loop_info=>NULL, ... },{ loop_info=>THE _, ... } )
                                | (THE { call_as=>acf::CALL_AS_GENERIC_PACKAGE, ... },{ call_as=>acf::CALL_AS_FUNCTION (hut::VARIABLE_CALLING_CONVENTION _), ... } )
                                | (THE { call_as=>acf::CALL_AS_FUNCTION _,      ... },{ call_as=>acf::CALL_AS_GENERIC_PACKAGE, ... } )
                                )
                                    =>
                                    ([], le);

                               _    =>
                                    {   my (funs, body)
                                            =
                                            curry ( case hd
                                                        #
                                                        NULL =>  THE fk;
                                                        _    =>  hd;
                                                    esac,

                                                    na - (length args)
                                                  )
                                                  body;

                                        ((fk, f, args) ! funs, body);
                                    };
                            esac;
                        else
                            #  this "never" occurs, but dead-code removal is not bullet-proof 
                            ([], le);
                        fi;

                    curry _ le => ([], le);
                end;

                exception UNCURRYABLE;

                # Do the actual uncurrying:
                #
                fun uncurry (args as (fk, f, fargs) ! _ ! _, body)
                        =>
                        {   f' = cplv f;        #  the new fun name 

                            # Find the rtys of
                            # the uncurried function:
                            #
                            fun getrtypes (( { loop_info=>THE (rtys, _), ... }:  acf::Function_Notes,   _, _), _)
                                    =>
                                    THE rtys;

                                getrtypes ((_, _, _), rtys)
                                    =>
                                    null_or::map
                                        #
                                        fn [lambda_type] =>  #2 (hcf::ltd_fkfun lambda_type);
                                           _             =>  bug "strange loop_info";
                                        end
                                        #
                                        rtys;
                            end;

                            # Create the new fkinds:
                            #
                            ncconv
                                =
                                case (.call_as (#1 (head args)))
                                    #
                                    acf::CALL_AS_GENERIC_PACKAGE
                                        =>
                                        acf::CALL_AS_GENERIC_PACKAGE;

                                    _   =>
                                        case (.call_as (#1 (list::last args)))
                                            #
                                            acf::CALL_AS_FUNCTION (hut::VARIABLE_CALLING_CONVENTION { body_is_raw, ... }) =>
                                            acf::CALL_AS_FUNCTION (hut::VARIABLE_CALLING_CONVENTION { body_is_raw, arg_is_raw => TRUE });

                                            call_as =>   call_as;
                                        esac;
                                esac;

                            my (nfk, nfk')
                                =
                                ou::fk_wrap (fk, fold_forward getrtypes NULL args);

                            nfk' = { inlining_hint     =>  nfk'.inlining_hint,
                                     loop_info         =>  nfk'.loop_info,
                                     private =>  nfk'.private,
                                     call_as           =>  ncconv
                                   };

                            #  funarg renaming 
                            #
                            fun newargs fargs
                                =
                                map  (fn (a, t) =  (cplv a, t))
                                     fargs;

                            #  Create (curried) wrappers to be inlined 
                            #
                            fun recurry ([], args)
                                    =>
                                    acf::APPLY (acf::VAR f', map (acf::VAR o #1) args);

                                recurry (( { inlining_hint, loop_info, private, call_as }, f, fargs) ! rest, args)
                                    =>
                                    {   fk = { inlining_hint => acf::INLINE_WHENEVER_POSSIBLE,
                                               loop_info  => NULL,

                                               private,
                                               call_as
                                             };

                                        nfargs = newargs fargs;

                                        g = cplv f';

                                        acf::MUTUALLY_RECURSIVE_FNS([(fk, g, nfargs, recurry (rest, args @ nfargs))],
                                             acf::RET [acf::VAR g]);
                                    };
                            end;

                            #  Build the new f fundec 
                            #
                            nfargs = newargs fargs;
                            nf = (nfk, f, nfargs, recurry (tail args, nfargs));

                            # Make up the body of the uncurried function (creating
                            # dummy wrappers for the intermediate functions that are now
                            # useless).
                            # Intermediate functions that were not marked as recursive
                            # cannot appear in the body, so we don't need to build them.
                            # Note that we can't just rely on dead-code elimination to remove
                            # them because we may not be able to create them correctly with
                            # the limited type information gleaned in this phase.
                            #
                            fun uncurry' ([], args)
                                    =>
                                    body;

                                uncurry' ((fk, f, fargs) ! rest, args)
                                    =>
                                    {   le = uncurry'(rest, args @ fargs);

                                        case fk

                                            { loop_info => THE _,
                                              call_as,
                                              private,
                                              inlining_hint
                                            }
                                                =>
                                                {   nfargs = newargs fargs;

                                                    fk = { loop_info  => NULL,
                                                           inlining_hint => acf::INLINE_WHENEVER_POSSIBLE,
                                                           private,
                                                           call_as
                                                         };

                                                    acf::MUTUALLY_RECURSIVE_FNS
                                                      ( [ ( fk, f, nfargs,
                                                            recurry (rest, args @ nfargs)
                                                          )
                                                        ],
                                                        le
                                                      );
                                                };

                                           _ => le;

                                        esac;
                                    };
                            end;

                            #  the new f' fundec 
                            #
                            nfbody' = uncurry' (tail args, fargs);

                            nf' = (nfk', f', fold_backward (@) [] (map #3 args), nfbody');

                            (nf, nf');
                        };

                    uncurry (_, body)
                        =>
                        bug "uncurrying a non-curried function";
                end;

                case lambda_expression
                    #
                    acf::RET vs
                        =>
                        (0, addvs (is::empty, vs), lambda_expression);

                    acf::LET (lvs, body, le)
                        =>
                        {   my (s2, fvl, nle  ) =  loop le;
                            my (s1, fvb, nbody) =  loop body;

                            ( s1 + s2,
                              is::union (rmvs (fvl, lvs), fvb),
                              acf::LET (lvs, nbody, nle)
                            );
                        };

                    acf::MUTUALLY_RECURSIVE_FNS (fdecs, le)
                        =>
                        {   # Set of funs defined by
                            # the MUTUALLY_RECURSIVE_FNS 
                            #
                            funs =  is::add_list (is::empty, map #2 fdecs);


                            # Create call-counters for
                            # each fun and add them to fm 
                            #
                            my (fs, mf)
                                =
                                fold_forward
                                    (fn ((fk, f, args, body), (fs, mf))
                                         =
                                         {   c = REF 0;
                                             ((fk, f, args, body, c) ! fs,
                                                im::set (mf, f, FUN c));
                                         }
                                    )
                                    ([], mf)
                                    fdecs;



                            # Process each fun:
                            #
                            fun ffun (fdec as (fk as { loop_info, ... }:  acf::Function_Notes,   f, args, body, cf),
                                      (s, fv, funs, m))
                                =
                                case (curry (NULL,*maxargs)
                                            (acf::MUTUALLY_RECURSIVE_FNS([(fk, f, args, body)], acf::RET [acf::VAR f]))
                                     )

                                    (args as _ ! _ ! _, body)  #  Curried function 
                                        =>
                                        {   my ((fk, f, fargs, fbody), (fk', f', fargs', fbody'))
                                                =
                                                uncurry (args, body);

                                            # Add the wrapper function:
                                            #
                                            cs =  map (fn _ = REF (0, 0))
                                                      fargs;

                                            nm =  im::set (m, f,
                                                         ([f'], 1, fk, fargs, fbody, cf, cs));

                                            # Now retry ffun with the uncurried function:
                                            #
                                            ffun((fk', f', fargs', fbody', REF 1),
                                              (s+1, fv, is::add (funs, f'), nm));
                                        };

                                    _   =>      #  non-curried function 
                                        {   newdepth
                                                =
                                                case loop_info
                                                    #
                                                    THE (_, (acf::TAIL_RECURSIVE_LOOP | acf::PREHEADER_WRAPPED_LOOP))
                                                        =>
                                                        depth + 1;

                                                    _   =>   depth;
                                                esac;

                                            my (mf, cs)
                                                =
                                                fold_backward
                                                    (fn ((v, t), (m, cs))
                                                        =
                                                        {   c = REF (0, 0);

                                                            (im::set (m, v, ARG (newdepth, c)),
                                                                        c ! cs);
                                                        }
                                                    )
                                                    (mf,[])
                                                    args;

                                            my (fs, ffv, body)
                                                =
                                                float_expression mf newdepth body;

                                            ffv = rmvs (ffv, map #1 args);      # fun's freevars 

                                            # Set of rec funs REF'ed
                                            #
                                            ifv = is::intersection (ffv, funs);

                                            (fs + s, is::union (ffv, fv), funs,
                                               im::set (m, f,
                                                 (is::vals_list ifv, fs, fk, args, body, cf, cs)));
                                        };
                                esac;

                            # Process the main lambda_expression and
                            # make it into a dummy function.
                            #
                            # The computation of the freevars
                            # is a little sloppy since `fv'
                            # includes freevars of the fate,
                            # but the uniqueness of varnames ensures
                            # that is::inter (fv, funs) gives the
                            # correct result nonetheless.
                            #
                            (float_expression  mf  depth  le)
                                ->
                                (s, fv, le);

                            lename =   tmp::issue_highcode_codetemp ();

                            m =  im::set
                                   ( im::empty,
                                     lename,
                                     ( is::vals_list (is::intersection (fv, funs)),
                                       0,
                                       { inlining_hint        =>  acf::INLINE_IF_SIZE_SAFE,
                                         loop_info         =>  NULL,
                                         private =>  TRUE,
                                         call_as   =>  acf::CALL_AS_GENERIC_PACKAGE
                                       },
                                       [],
                                       le,
                                       REF 0,
                                       []
                                   ) );


                            # Process the functions,
                            # collecting them in map m:
                            #
                            my (s, fv, funs, m)
                                =
                                fold_forward ffun (s, fv, funs, m) fs;

                            # Find strongly connected components: 
                            #
                            top
                                = 
                                scc::topological_order
                                  { root   => lename,
                                    follow => (fn n =  #1 (null_or::the (im::get (m, n))))
                                  }
                                except
                                    x = {   bug "top: follow";
                                            raise exception x;
                                        };


                            # Turn them back into highcode code: 
                            #
                            fun scc_simple f (_, s,{ loop_info, call_as, private, inlining_hint }, args, body, cf, cs)
                                =
                                {   # Small functions inlining heuristic:
                                    # 
                                    ilthreshold = *asc::inline_threshold + (length args);

                                    ilh =   if (inlining_hint == acf::INLINE_WHENEVER_POSSIBLE)
                                                #
                                                inlining_hint;

                                                #  else if s < ilthreshold then acf::INLINE_WHENEVER_POSSIBLE 
                                            else
                                                cs = map
                                                         (fn REF (sp, ti) = sp + ti / 2)
                                                         cs;

                                                s' = fold_forward (+) 0 cs;

                                                if (s < 2*s' + ilthreshold)
                                                    #
                                                    # say((Collect::LVarString f)  + 
                                                    #  " { " + (int::to_string *cf)  + 
                                                    #  " } = acf::INLINE_MAYBE "  + 
                                                    #   (int::to_string (s-ilthreshold))  + 
                                                    #   (fold_forward (fn (i, s) => s + " "  + 
                                                    #      (int::to_string i))
                                                    #     "" cs) + "\n"); 

                                                    acf::INLINE_MAYBE (s-ilthreshold, cs);
                                                else
                                                    inlining_hint;
                                                fi;
                                            fi;

                                    fk = { loop_info=>NULL, inlining_hint=>ilh, private, call_as };

                                    (fk, f, args, body);
                                };
                            #
                            fun scc_rec f (_, s, fk as { loop_info, call_as, private, inlining_hint }, args, body, cf, cs)
                                =
                                {   fk' =
                                        # Check for unroll opportunities.
                                        # This heuristic is pretty bad since it doesn't
                                        # take the number of rec-calls into account:         XXX BUGGO FIXME
                                        #
                                        case (loop_info, inlining_hint)
                                            #
                                            (THE(_, (acf::PREHEADER_WRAPPED_LOOP|acf::TAIL_RECURSIVE_LOOP)), acf::INLINE_IF_SIZE_SAFE)
                                                =>
                                                if (s < *asc::unroll_threshold)
                                                    #
                                                    { inlining_hint      => acf::INLINE_ONCE_WITHIN_ITSELF,
                                                      loop_info,
                                                      call_as,
                                                      private
                                                    };
                                               else
                                                   fk;
                                               fi;

                                            _ => fk;
                                        esac;

                                    (fk, f, args, body);
                                };
                            #
                            fun sccconvert (scc::SIMPLE f, le)
                                    =>
                                    acf::MUTUALLY_RECURSIVE_FNS([scc_simple f (null_or::the (im::get (m, f)))], le);

                                sccconvert (scc::RECURSIVE fs, le)
                                    =>
                                    acf::MUTUALLY_RECURSIVE_FNS (map (fn f => scc_rec f (null_or::the (im::get (m, f))); end ) fs, le);
                            end;

                            case top

                                 (scc::SIMPLE f) ! sccs
                                     =>
                                     {   if (f != lename)   bugsay "f != lename";   fi;

                                         (   s,
                                             is::difference (fv, funs),
                                             fold_forward sccconvert le sccs
                                         );
                                     };

                                 (scc::RECURSIVE _) ! _
                                      =>
                                      bug "recursive main body in SCC ?!?!?";

                                 []   =>
                                      bug "SCC going crazy";
                            esac;
                        };

                    acf::APPLY (acf::VAR f, args)
                        =>
                        # For known functions, increase
                        # the counter and make the call
                        # a bit cheaper:
                        #
                        {   scall = case (im::get (mf, f))
                                        #
                                        THE (FUN (fc as REF c))
                                            =>
                                            {   fc := c + 1;
                                                1;
                                            };

                                        THE (ARG (d, ac as REF (sp, ti)))
                                            =>
                                            {   ac := (4 + sp, ou::pow2 (depth - d) * 30 + ti);
                                                5;
                                            };

                                        NULL => 5;
                                    esac;

                            (scall + (length args), addvs (is::singleton f, args), lambda_expression);
                        };

                    acf::TYPEFUN ((tfk, f, args, body), le)
                        =>
                        {   my (se, fve, le)   =  loop le;
                            my (sb, fvb, body) =  loop body;

                            (sb + se, is::union (s_rmv (f, fve), fvb),
                              acf::TYPEFUN((tfk, f, args, body), le));
                        };

                    acf::APPLY_TYPEFUN (acf::VAR f, args)
                        =>
                        # The cost of APPLY_TYPEFUN is kinda hard to estimate.
                        # It can be very cheap, and just return a function,
                        # or it might do all kinds of wrapping but we have
                        # almost no information on which to base our choice.
                        #
                        # We opted for cheap here, to try to inline them more
                        # (they might become cheaper once inlined):
                        #
                        (3, is::singleton f, lambda_expression);

                    acf::SWITCH (v, ac, arms, def)
                        =>
                        {   fun farm (dcon as acf::VAL_CASETAG (dc, _, lv), le)
                                    =>
                                    # The naming might end up costly,
                                    # but we count it as 1 
                                    #   
                                    {   my (s, fv, le) = loop le;
                                        (1+s, fdcon (s_rmv (lv, fv), dc), (dcon, le));
                                    };

                                farm (dc, le)
                                   =>
                                   {   my (s, fv, le) = loop le;
                                       (s, fv, (dc, le));
                                   };
                            end;

                            narms = length arms;

                            my (s, smax, fv, arms)
                                =
                                fold_backward
                                    (fn ((s1, fv1, arm), (s2, smax, fv2, arms))
                                        =
                                        (s1+s2, int::max (s1, smax), is::union (fv1, fv2), arm ! arms)
                                    )
                                    (narms, 0, is::empty, [])
                                    (map farm arms);

                            case (lookup v)
                                #
                                THE (ARG (d, ac as REF (sp, ti)))
                                    =>
                                    ac :=  (sp + s - smax + narms, ou::pow2 (depth - d) * 2 + ti);

                                _ => ();
                            esac;

                            case def
                                #
                                NULL =>   (s, fv, acf::SWITCH (v, ac, arms, NULL));
                                #
                                THE le
                                    =>
                                    {   my (sd, fvd, le)
                                            =
                                            loop le;

                                        ( s + sd,
                                          is::union (fv, fvd),
                                          acf::SWITCH (v, ac, arms, THE le)
                                        );
                                    };
                            esac;
                        };

                    acf::CONSTRUCTOR (dc, typs, v, lv, le)
                        =>
                        {   my (s, fv, le) = loop le;

                            (2+s, fdcon (addv (s_rmv (lv, fv), v), dc), acf::CONSTRUCTOR (dc, typs, v, lv, le));
                        };

                    acf::RECORD (rk, vs, lv, le)
                        =>
                        {   (loop le) ->   (s, fv, le);

                            ((length vs)+s, addvs (s_rmv (lv, fv), vs), acf::RECORD (rk, vs, lv, le));
                        };

                    acf::GET_FIELD (v, i, lv, le)
                        =>
                        {   (loop le) ->   (s, fv, le);

                            case (lookup v)
                                #
                                THE (ARG (d, ac as REF (sp, ti)))
                                    =>
                                    ac := (sp + 1, ou::pow2 (depth - d) + ti);

                                 _ => ();
                            esac;

                            (1+s, addv (s_rmv (lv, fv), v), acf::GET_FIELD (v, i, lv, le));
                        };

                    acf::RAISE (acf::VAR v, ltys)
                        =>
                        # Artificially high size estimate
                        # to discourage inlining:
                        #
                        (15, is::singleton v, lambda_expression);

                    acf::EXCEPT (le, v)
                        =>
                        {   my (s, fv, le) = loop le;
                            (2+s, addv (fv, v), acf::EXCEPT (le, v));
                        };

                    acf::BRANCH (po, vs, le1, le2)
                        =>
                        {   my (s1, fv1, le1) = loop le1;
                            my (s2, fv2, le2) = loop le2;

                            (1+s1+s2, fpo (addvs (is::union (fv1, fv2), vs), po),

                            acf::BRANCH (po, vs, le1, le2));
                        };

                    acf::BASEOP (po, vs, lv, le)
                        =>
                        {   my (s, fv, le) = loop le;
                            (1+s, fpo (addvs (s_rmv (lv, fv), vs), po), acf::BASEOP (po, vs, lv, le));
                        };

                    acf::APPLY      _ => bug "bogus acf::APPLY";
                    acf::APPLY_TYPEFUN _ => bug "bogus acf::APPLY_TYPEFUN";
                    acf::RAISE      _ => bug "bogus acf::RAISE";
                esac;
            };

        #
        fun improve_mutually_recursive_anormcode_functions ((fk, f, args, body):  acf::Function)
            =
            {   (float_expression  im::empty  0  body)
                    ->
                    (s, fv, nbody);

                fv =   is::difference (fv, is::add_list (is::empty, map #1 args));

                #   prettyprint_anormcode::printLexp (acf::RET (map acf::VAR (is::members fv))); 

                assert (is::is_empty fv);

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

    };          # package improve_mutually_recursive_anormcode_functions
end;            # stipulate



Comments and suggestions to: bugs@mythryl.org

PreviousUpNext