PreviousUpNext

15.4.482  src/lib/compiler/back/top/improve-nextcode/convert-monoarg-to-multiarg-nextcode-g.pkg

## convert-monoarg-to-multiarg-nextcode-g.pkg           "Argument flattening"

# 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



#    "Argument flattening.  As mentioned earlier,
#     the earlier phases of the compiler use languages
#     where functions take and return single values:
#     When multiple values are needed, they are
#     bundled into a tuple.
#
#    "This phase optimizes the code so that such
#     bundles are opened up and passed directly in
#     registers as multiple arguments or multiple
#     return values."
#
#          -- Principled Compilation and Scavenging
#             Stefan Monnier, 2003 [PhD Thesis, U Montreal]
#             http://www.iro.umontreal.ca/~monnier/master.ps.gz 
#
#     (See also the discussion on page 16-18, ibid.)




###               "The traditional mathematics professor of the popular legend is absentminded.
###                He usually appears in public with a lost umbrella in each hand.
###                He prefers to face the blackboard and to turn his back to the class.
###                He writes a, he says b, he means c; but it should be d.
###                
###                Some of his sayings are handed down from generation to generation:
###                
###               "In order to solve this differential equation
###                you look at it till a solution occurs to you.
###                
###               "This principle is so perfectly general that
###                no particular application of it is possible.
###                
###               "Geometry is the science of correct reasoning on incorrect figures.
###                
###               "My method to overcome a difficulty is to go round it.
###                
###               "What is the difference between method and device?
###                A method is a device which you used twice.
###                
###               "The first rule of discovery is to have brains and good luck.
###               "The second rule of discovery is to sit tight and wait
###                till you get a bright idea."
###                
###                                   -- George Pólya, "How to solve it", 1945.





stipulate
    package ncf =  nextcode_form;                               # nextcode_form                 is from   src/lib/compiler/back/top/nextcode/nextcode-form.pkg
    package hut =  highcode_uniq_types;                         # highcode_uniq_types           is from   src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg
    package iht =  int_hashtable;                               # int_hashtable                 is from   src/lib/src/int-hashtable.pkg
herein

    api Convert_Monoarg_To_Multiarg_Nextcode {
        #
        convert_monoarg_to_multiarg_nextcode
            :
            { function:  ncf::Function,
              table:     iht::Hashtable( hut::Uniqtype ),
              click:     String -> Void
            }
            ->
            ncf::Function;
    };
end;



stipulate
    package coc =  global_controls::compiler;                   # global_controls                       is from   src/lib/compiler/toplevel/main/global-controls.pkg
    package err =  error_message;                               # error_message                         is from   src/lib/compiler/front/basics/errormsg/error-message.pkg
    package ncf =  nextcode_form;                               # nextcode_form                         is from   src/lib/compiler/back/top/nextcode/nextcode-form.pkg
    package hcf =  highcode_form;                               # highcode_form                         is from   src/lib/compiler/back/top/highcode/highcode-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
herein 


    # This generic is invoked by:
    #
    #     src/lib/compiler/back/top/improve-nextcode/run-optional-nextcode-improvers-g.pkg
    #
    generic package   convert_monoarg_to_multiarg_nextcode_g   (
        #             ======================================
        #
        mp:  Machine_Properties                                 # Machine_Properties                    is from   src/lib/compiler/back/low/main/main/machine-properties.api
                                                                # machine_properties_intel32            is from   src/lib/compiler/back/low/main/intel32/machine-properties-intel32.pkg
                                                                # machine_properties_pwrpc32            is from   src/lib/compiler/back/low/main/pwrpc32/machine-properties-pwrpc32.pkg
                                                                # machine_properties_sparc32            is from   src/lib/compiler/back/low/main/sparc32/machine-properties-sparc32.pkg
    )
    : (weak) Convert_Monoarg_To_Multiarg_Nextcode               # Convert_Monoarg_To_Multiarg_Nextcode  is from   src/lib/compiler/back/top/improve-nextcode/convert-monoarg-to-multiarg-nextcode-g.pkg
    {

        say =  global_controls::print::say;

        fun bug string
            =
            err::impossible ("Flatten: " + string);

        Arity = BOT 
              | UNK                     # An arg seen that isn't a known record 
              | COUNT  (Int, Bool)      # int is # of record fields; Bool is whether any arguments were unknown records.
              | TOP
              ;

        Info = FNINFO { arity: Ref(  List(  Arity ) ), 
                        alias: Ref(  Null_Or(  ncf::Codetemp ) ),
                        escape: Ref( Bool )
                      }
             | ARGINFO  Ref( Int )              # The highest-numbered field selected 
             | RECINFO  Int                     # Number of fields 
             | MISCINFO
             ;

        fun convert_monoarg_to_multiarg_nextcode { function=>(fkind, fvar, fargs, ctyl, cexp), table, click }
            =
            {   clicks =  REF 0;

                maxfree =  mp::num_int_regs;

                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;

                rep_flag = mp::representations;

                type_flag =   *coc::checknextcode1
                          and *coc::checknextcode2
                          and  rep_flag;

                select_lty
                    = 
                    (fn (lt, i) =  if type_flag   hcf::lt_get_field (lt, i);
                                   else           hcf::truevoid_uniqtype;
                                   fi
                    );

                exception NFLATTEN;

                fun getty v
                    =
                    if type_flag 
                        #
                        (iht::get  table  v)
                        except
                            _ =  { global_controls::print::say ("NFLATTEN: Can't find the variable " +
                                        (int::to_string v) + " in the table ***** \n");
                                   raise exception NFLATTEN;
                                 };
                    else
                        hcf::truevoid_uniqtype;
                    fi;

                addty = if type_flag  iht::set table;
                        else          (fn _ = ());
                        fi;

                fun newty (f, t)
                    =
                    if type_flag

                        ignore (iht::remove table f)   except _ = ();
                        addty (f, t);
                    fi;

                fun make_var (t)
                    =
                    {   v = tmp::issue_highcode_codetemp();
                        addty (v, t);
                        v;
                    };

                fun grabty u
                    =
                    {   fun g (ncf::CODETEMP     v) =>   getty v;
                            g (ncf::INT     _) =>   hcf::int_uniqtype;
                            g (ncf::FLOAT64 _) =>   hcf::float64_uniqtype;
                            g (ncf::STRING  _) =>   hcf::truevoid_uniqtype;
                            g (ncf::LABEL   v) =>   getty v;
                            g _                =>   hcf::truevoid_uniqtype;
                        end;

                        if type_flag   g u;
                        else       hcf::truevoid_uniqtype;
                        fi;
                    };

                fun arg_lty [] => hcf::int_uniqtype;

                    arg_lty [t]
                        => 
                        hcf::if_uniqtype_is_tuple_type
                            ( t, 

                              fn xs as (_ ! _) => length(xs)  <  mp::max_rep_regs
                                                  ??  hcf::make_tuple_uniqtype [t]
                                                  ::  t;
                                 _ => t;
                              end,

                             fn t => 
                                hcf::if_uniqtype_is_package
                                    ( t, 

                                      fn xs as (_ ! _) =>  length (xs) < mp::max_rep_regs
                                                            ??  hcf::make_tuple_uniqtype [t]
                                                            ::  t;
                                         _ => t;
                                      end,

                                      fn t = t
                                    );
                             end
                            );

                    arg_lty r => hcf::make_package_uniqtype r;          #  this is INCORRECT !!!!!!!  XXX BUGGO FIXME
                end;

                fun ltc_fun (x, y)
                    = 
                    if   (hcf::uniqtype_is_typ x  and  hcf::uniqtype_is_typ y)

                         hcf::make_lambdacode_arrow_uniqtype (x, y);
                    else hcf::make_lambdacode_generic_package_uniqtype   (x, y);
                    fi;

                fun make_fn_lty (_, _, NIL)
                        =>
                        bug "make_fn_lty in nflatten";

                    make_fn_lty (k, cntt ! _, x ! r)
                        => 
                        hcf::ltw_is_fate
                          (
                            x,

                            fn [t2] => (k, ltc_fun (arg_lty r, t2));
                                _   => bug "unexpected mkfnLty";
                            end, 

                            fn [t2] => (k, ltc_fun (arg_lty r, hcf::make_typ_uniqtype t2));
                                 _  => bug "unexpected mkfnLty";
                            end, 

                            fn x =  (k, ltc_fun (arg_lty r, x))
                        );

                    make_fn_lty (k, _, r)
                        =>
                        (k, hcf::make_uniqtype_fate([arg_lty r]));
                end;

                # Note that maxfree has already been reduced by 1 (in CPScomp)
                # on most machines to allow for an arithtemp:
                #       
                maxregs = maxfree - mp::num_callee_saves;

                stipulate

                    exception USAGE_MAP;

                    my m: iht::Hashtable( Info )
                        = iht::make_hashtable  { size_hint => 128,  not_found_exception => USAGE_MAP };

                    umap = iht::get  m;

                herein  

                    fun get i
                        =
                        umap i
                        except
                            USAGE_MAP = MISCINFO;

                    enter = iht::set m;
                end;

                fun select (ncf::CODETEMP v, i)
                        =>
                        case (get v)
                             ARGINFO (biggest_sel as REF j) => biggest_sel := int::max (i, j);
                            _ => ();
                        esac;

                    select (ncf::LABEL v, i) => select (ncf::CODETEMP v, i);
                    select _ => ();
                end;

                fun escape (ncf::CODETEMP v)
                        =>
                        case (get v)
                            FNINFO { escape=>r, ... } =>  r := TRUE;
                            _                       =>  ();
                        esac;

                    escape (ncf::LABEL v)
                        =>
                        escape (ncf::CODETEMP v);

                    escape _ => ();
                end;

                fun field' (v, ncf::VIA_SLOT (i, _)) =>  select (v, i);
                    field' (v, _)           =>  escape v;
                end;

                botlist = if *coc::flattenargs  map (fn _ = BOT);
                          else                 map (fn _ = TOP);
                          fi;

                fun enter_fn (_, f, vl, _, cexp)
                    =
                      {   enter (f, FNINFO { arity=>REF (botlist vl), alias=>REF NULL, escape=>REF FALSE } );
                          apply (fn v = enter (v, ARGINFO (REF -1))) vl;
                      };

                stipulate

                    exception FOUND;

                herein 

                    fun find_fetch (v, k) body
                        =
                        # Find whether field k
                        # of variable v is
                        # guaranteed to exist:
                        # 
                        ( f body
                          except FOUND = TRUE
                        )
                        where
                            fun f (ncf::DEFINE_RECORD { fields, next, ... }) =>   { apply g fields;  f next; };
                                f (ncf::GET_FIELD_I { i, record => ncf::CODETEMP v', next, ... })
                                    => 
                                    if (v==v' and i==k)  raise exception FOUND;
                                    else                 f next;
                                    fi;
                                f (ncf::GET_FIELD_I             r) =>  f r.next;
                                f (ncf::GET_ADDRESS_OF_FIELD_I  r) =>  f r.next;
                                f (ncf::DEFINE_FUNS             r) =>  f r.next;
                                f (ncf::FETCH_FROM_RAM          r) =>  f r.next;
                                f (ncf::STORE_TO_RAM            r) =>  f r.next;
                                f (ncf::MATH                    r) =>  f r.next;
                                f (ncf::PURE                    r) =>  f r.next;
                                f (ncf::RAW_C_CALL              r) =>  f r.next;
                                #
                                f (ncf::IF_THEN_ELSE { then_next, else_next, ... }) => find_fetch (v, k) then_next
                                                                                 and find_fetch (v, k) else_next;

                                f (ncf::JUMPTABLE { nexts, ... }) => not (list::exists (not o find_fetch (v, k)) nexts);
                                f _ => FALSE;
                            end 

                            also
                            fun g (ncf::CODETEMP v', ncf::VIA_SLOT (i, _)) =>   if (v==v' and i==k ) raise exception FOUND; fi;
                                g _                               =>   ();
                            end;
                        end;
                end;

                fun check_flatten (_, f, vl, _, body)
                    =
                    case (get f)
                        #
                        FNINFO { arity as REF al, alias, escape }
                            =>
                            {   fun loop (v ! vl, a ! al, headroom)
                                        =>
                                        case (a, get v)
                                            #
                                            ( COUNT (c, some_non_record_actual),
                                              ARGINFO (REF j)
                                            )
                                                =>
                                                if (   j > -1                           #  exists a select of the formal parameter 
                                                   and headroom-(c - 1) >= 0
                                                   and (  not (some_non_record_actual or *escape)
                                                       or *coc::extraflatten 
                                                           and  j == c - 1  and  find_fetch (v, j) body)
                                                   )

                                                     a   ! loop (vl, al, headroom-(c - 1));
                                                else TOP ! loop (vl, al, headroom        );
                                                fi;

                                            _ => TOP ! loop (vl, al, headroom);
                                        esac;

                                    loop _ =>   NIL;
                                end;

                                a' = loop (vl, al, maxregs - 1 - length(al));

                                arity := a';

                                if (list::exists
                                        #
                                        fn COUNT _ => TRUE;
                                           _       => FALSE;
                                        end
                                        #
                                        a'
                                   )
                                    #
                                    alias := THE (tmp::clone_highcode_codetemp f);
                                    click "F";
                                    clicks := *clicks+1;
                                fi;
                            };

                        _ => ();                # Impossible.
                    esac; 


                # ************************************************************************
                #  pass1: Gather usage information on the variables within a nextcode expression.  
                # ************************************************************************
                recursive my pass1
                    =
                    fn ncf::DEFINE_RECORD           { fields, to_temp, next, ... } =>   { enter (to_temp, RECINFO (length fields)); apply field' fields; pass1 next;};
                       ncf::GET_FIELD_I             { i, record,    next, ... } =>   { select (record, i); pass1 next;};
                       ncf::GET_ADDRESS_OF_FIELD_I  { record,       next, ... } =>   { escape record; pass1 next;};
                       #
                       ncf::STORE_TO_RAM            { args,         next, ... } =>   {  apply escape args;  pass1 next;  };
                       ncf::FETCH_FROM_RAM          { args,         next, ... } =>   {  apply escape args;  pass1 next;  };
                       #
                       ncf::MATH                    { args,         next, ... } =>   {  apply escape args;  pass1 next;  };
                       ncf::PURE                    { args,         next, ... } =>   {  apply escape args;  pass1 next;  };
                       ncf::RAW_C_CALL              { args,         next, ... } =>   {  apply escape args;  pass1 next;  };
                       #
                       ncf::JUMPTABLE               { i, nexts,                 ... } => { escape i; apply pass1 nexts;};
                       ncf::IF_THEN_ELSE            { args, then_next, else_next, ... } => { apply escape args; pass1 then_next; pass1 else_next;};

                       ncf::TAIL_CALL {  func => ncf::CODETEMP f,  args  }
                           =>
                           {   fun loop (t ! r, args0 as (ncf::CODETEMP v) ! args, n)
                                       =>
                                       case (t, get v)
                                           #
                                           (BOT, RECINFO size)
                                               =>
                                               loop (COUNT (size, FALSE) ! r, args0, n);

                                           (BOT, _)
                                               =>
                                               UNK ! loop (r, args, n+1);

                                           (UNK, RECINFO size)
                                               => 
                                               loop (COUNT (size, TRUE) ! r, args0, n);

                                           (UNK, _)
                                               =>
                                               UNK ! loop (r, args, n+1);

                                           (COUNT (a, _), RECINFO size)
                                               => 
                                               a == size   ??    t ! loop (r, args, n+1)
                                                           ::  TOP ! loop (r, args, n+1);

                                           (COUNT (a, _), _)
                                               => 
                                               COUNT (a, TRUE) ! loop (r, args, n+1);

                                           _ => TOP ! loop (r, args, n+1);
                                       esac;

                                   loop (_ ! r, _ ! args, n)
                                       =>
                                       TOP ! loop (r, args, n+1);

                                   loop _
                                       =>
                                       NIL;
                               end;

                               apply escape args; 

                               case (get f)
                                    FNINFO { arity as REF al, ... } => arity := loop (al, args, 0);
                                   _ => ();
                               esac;
                           };

                       ncf::TAIL_CALL { args, ... } =>   apply escape args;

                       ncf::DEFINE_FUNS { funs, next }
                           =>
                           {   apply enter_fn funs;
                               apply  (fn (_, _, _, _, body) =  pass1 body)  funs;
                               pass1 next;
                               apply check_flatten funs;
                           };
                   end ;

                recursive my reduce
                    =
                    fn  ncf::DEFINE_RECORD { kind, fields, to_temp, next                }
                     => ncf::DEFINE_RECORD { kind, fields, to_temp, next => reduce next };
                        #
                        ncf::GET_FIELD_I { i, record, to_temp, type, next                }
                     => 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::JUMPTABLE { i, xvar,  nexts } => ncf::JUMPTABLE { i, xvar, nexts => map reduce nexts };
                        #
                        ncf::FETCH_FROM_RAM { op, args, to_temp, type, next }  => ncf::FETCH_FROM_RAM { op, args, to_temp, type, next => reduce next };
                        ncf::STORE_TO_RAM   { op, args,                next }  => ncf::STORE_TO_RAM   { op, args,                next => reduce next };
                        #
                        ncf::MATH { op, args, to_temp, type, next }  =>  ncf::MATH { op, args, to_temp, type,  next => reduce next  };
                        ncf::PURE { op, args, to_temp, type, next }  =>  ncf::PURE { op, args, to_temp, type,  next => reduce next  };
                        #
                        ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next                }
                     => ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next => reduce next };
                        #
                        ncf::IF_THEN_ELSE { op, args, xvar, then_next,                      else_next                     }
                     => ncf::IF_THEN_ELSE { op, args, xvar, then_next => reduce then_next,  else_next => reduce else_next };

                        ncf::TAIL_CALL {  func =>  func as ncf::CODETEMP fv,
                                      args
                                   }
                            =>
                            case (get fv)
                                #       
                                FNINFO { arity=>REF al, alias=>REF (THE f'), ... }
                                    => 
                                    loop (al, args, NIL)
                                    where
                                        fun loop (COUNT (count, _) ! r, v ! vl, args)
                                                =>
                                                g (0, args)
                                                where
                                                    lt = grabty v;

                                                    fun g (i, args)
                                                        = 
                                                        if (i == count)
                                                            #
                                                            loop (r, vl, args);
                                                        else
                                                            tt =   select_lty (lt, i);

                                                            z =   make_var (tt);

                                                            ncf::GET_FIELD_I { i, record =>  v,   to_temp => z,   type => ncf::ctype (tt),   next => g (i+1,  ncf::CODETEMP(z) ! args) };
                                                        fi;
                                                end;

                                            loop(_ ! r, v ! vl, args) =>   loop (r, vl, v ! args);
                                            loop(_, _, args)          =>   ncf::TAIL_CALL { func =>  ncf::CODETEMP f',
                                                                                        args =>  reverse args
                                                                                      };
                                        end;
                                    end;

                               _ => ncf::TAIL_CALL { func, args };
                           esac;

                        ncf::TAIL_CALL funargs =>
                        ncf::TAIL_CALL funargs;

                        ncf::DEFINE_FUNS { funs, next }
                            =>
                            ncf::DEFINE_FUNS { funs =>  map reduce_body (process_args funs),
                                               next =>  reduce next
                                             }
                            where
                                fun vars (0, _, l, l')
                                        =>
                                        (l, l');

                                    vars (i, lt, l, l')
                                        => 
                                        {   tt = select_lty (lt, i - 1);
                                            vars (i - 1, lt, (make_var (tt)) ! l, (ncf::ctype (tt)) ! l');
                                        };
                                end;

                                fun newargs (COUNT (j, _) ! r, v ! vl, _ ! cl)
                                        =>
                                        (new @ vl', ncl @ cl', bodytransform o bt')
                                        where
                                            (getty v)                ->   lt;
                                            (vars (j, lt, NIL, NIL)) ->   (new, ncl);
                                            (newargs (r, vl, cl))    ->   (vl', cl', bt');

                                            fun bodytransform  body
                                                =
                                                ncf::DEFINE_RECORD
                                                  {
                                                     kind    =>   ncf::rk::RECORD,
                                                     fields  =>   map  (fn x = (ncf::CODETEMP x, ncf::SLOT 0))  new,
                                                     to_temp =>   v,
                                                     next    =>   body
                                                  };
                                        end;

                                    newargs(_ ! r, v ! vl, ct ! cl)
                                        => 
                                        (v ! vl', ct ! cl', bt')
                                        where
                                            (newargs (r, vl, cl)) ->   (vl', cl', bt');
                                        end;

                                    newargs _
                                        =>
                                        ([],[], fn b=b);
                                end;


                                fun process_args ((fdef as (fk, f, vl, cl, body)) ! rest)
                                        =>
                                        case (get f)   
                                            #
                                            FNINFO { arity=>REF al, alias=>REF (THE f'), ... }
                                                =>
                                                {   my (nargs, ncl, bt) = newargs (al, vl, cl);
                                                    my (fk', lt) = make_fn_lty (fk, ncl, map getty nargs);
                                                    newty (f', lt);
                                                    wl = map tmp::clone_highcode_codetemp vl;

                                                    (fk, f, wl, cl,  ncf::TAIL_CALL {  func => ncf::CODETEMP f,  args => map ncf::CODETEMP wl })
                                                    !
                                                    (fk', f', nargs, ncl, bt body) ! process_args rest;
                                                };

                                            _ => fdef ! process_args rest;
                                        esac;

                                    process_args NIL
                                        =>
                                        NIL;
                                end;

                                fun reduce_body (fk, f, vl, cl, body)
                                    =
                                    (fk, f, vl, cl, reduce body);

                         end;
                   end;

                fun fprint (function, s:  String)
                     = 
                     {   say "\n"; say s; say "\n \n";
                         prettyprint_nextcode::print_nextcode_function function;
                     };

                debugprint "Flatten: ";
                debugflush();

                if debug   fprint ((fkind, fvar, fargs, ctyl, cexp), "Before flatten:");    fi;

                pass1 cexp;

                cexp' =   *clicks > 0   ??   reduce cexp
                                        ::   cexp;

                if debug
                    #
                    if (*clicks > 0)    fprint ((fkind, fvar, fargs, ctyl, cexp'), "After flatten:");
                    else                say "No flattening this time.\n";
                    fi;
                fi;

                debugprint "\n";

                ( fkind,
                  fvar,
                  fargs,
                  ctyl,
                  cexp'
                );
            };
    };                                                          # generic package convert_monoarg_to_multiarg_nextcode_g
end;                                                            # stipulate 



## Copyright 1996 by Bell Laboratories 
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2013,
## released per terms of SMLNJ-COPYRIGHT.


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext