PreviousUpNext

15.4.467  src/lib/compiler/back/top/closures/unrebind.pkg

## unrebind.pkg 

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

############################################################################
#
# "Alpha conversion": the closure converter introduces duplicate namings
# at function arguments (the free variables of known functions) and at
# SELECT's and OFFSET's from closures.  This function restores unique
# namings, and also eliminates OFFSET's of 0 (which are introduced as
# a side effect of trying to improve lazy display).  It assumes that a
# FIX has no free variables.
#
############################################################################



###                         "Never try and teach a pig to sing:
###                          it's a waste of time,
###                          and it annoys the pig."
###
###                                      -- Robert A. Heinlein
###                                         Time Enough for Love



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

    api Un_Rebind {
        #
        unrebind:  ncf::Function  ->  ncf::Function;
    };
end;



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

    package   un_rebind
    : (weak)  Un_Rebind                         # Un_Rebind             is from   src/lib/compiler/back/top/closures/unrebind.pkg
    {

        fun bug s
            =
            error_message::impossible ("UnRebind: " + s);


        fun unrebind (fk, v, args, cl, ce)
            =
            {   fun rename rebind (ncf::CODETEMP v)
                          =>
                          f rebind
                          where
                              fun f NIL
                                      =>
                                      ncf::CODETEMP v;

                                  f ((w: Int, v') ! t)
                                      =>
                                      v == w   ??   v'
                                               ::   f t;
                              end;
                          end;

                    rename _ x
                        =>
                        x;
                end;


                fun f (kind, l, args, cl, b)
                    =
                    {   my (args', rebind')
                            = 
                            fold_backward
                                (   fn (v, (args', rebind'))
                                       =
                                       { v' = tmp::clone_highcode_codetemp v;
                                       
                                           (   v' ! args',
                                               (v, ncf::CODETEMP v') ! rebind'
                                           );
                                       }
                                )

                                (NIL, NIL)

                                args;
                    
                        ( kind,
                          l,
                          args',
                          cl,
                          g rebind' b
                        );
                    }

                also
                fun g (rebind: List( (ncf::Codetemp, ncf::Value) ) )
                    =
                    h
                    where
                        rename = rename rebind;

                        recursive my h
                            =
                            fn ncf::DEFINE_RECORD { kind, fields, to_temp, next }
                                   =>
                                   {   to_temp' = tmp::clone_highcode_codetemp  to_temp;

                                       ncf::DEFINE_RECORD
                                         {      
                                           kind,
                                           fields  =>  map (fn (v, p) = (rename v, p)) fields,
                                           to_temp =>  to_temp',
                                           next    =>  g  ((to_temp, ncf::CODETEMP to_temp') ! rebind)   next
                                         };
                                   };

                              ncf::GET_ADDRESS_OF_FIELD_I { i => 0, record, to_temp, next } =>   g ((to_temp, rename record) ! rebind) next;
                              ncf::GET_ADDRESS_OF_FIELD_I { i,      record, to_temp, next } =>   bug "unexpected non-zero FIELD_POINTER";

                        #        let w' = tmp::clone_highcode_codetemp w
                        #         in ncf::GET_ADDRESS_OF_FIELD_I (i, rename v, w', g ((w, ncf::CODETEMP w') ! rebind) e)
                        #        end

                              ncf::GET_FIELD_I { i, record, to_temp, type, next }
                                  =>
                                  {   to_temp' =  tmp::clone_highcode_codetemp  to_temp;

                                      ncf::GET_FIELD_I
                                        {
                                          i,
                                          record  =>  rename record,
                                          to_temp =>  to_temp',
                                          type,
                                          next    =>  g ((to_temp, ncf::CODETEMP to_temp') ! rebind) next
                                        };
                                  };

                              ncf::TAIL_CALL   { func, args }    =>  ncf::TAIL_CALL   {  func => rename func,   args => map rename args  };
                              ncf::DEFINE_FUNS { funs, next }    =>  ncf::DEFINE_FUNS {  funs => map f funs,    next => h next  };

                              ncf::JUMPTABLE { i, xvar, nexts }  =>  ncf::JUMPTABLE { i => rename i, xvar, nexts => map h nexts };

                              ncf::IF_THEN_ELSE { op, args,                    xvar, then_next,                else_next                }
                           => ncf::IF_THEN_ELSE { op, args => map rename args, xvar, then_next => h then_next, else_next => h else_next };

                              ncf::STORE_TO_RAM   { op, args,                next } =>  ncf::STORE_TO_RAM   { op, args => map rename args,                next => h next };
                              ncf::FETCH_FROM_RAM { op, args, to_temp, type, next } =>  ncf::FETCH_FROM_RAM { op, args => map rename args, to_temp, type, next => h next };

                              ncf::MATH { op, args, to_temp, type, next }         =>  ncf::MATH { op,  args => map rename args,  to_temp, type,  next => h next  };
                              ncf::PURE { op, args, to_temp, type, next }         =>  ncf::PURE { op,  args => map rename args,  to_temp, type,  next => h next  };

                              ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next }
                                  =>
                                  ncf::RAW_C_CALL { kind, cfun_name, cfun_type,  args => map rename args,  to_ttemps,  next => h next  };
                        end;
                    
                    end;                # fun g

            
                (fk,  v,  args,  cl,  g NIL ce);

            };  # fun unrebind 
    };          # package un_rebind 
end;            # stipulate




Comments and suggestions to: bugs@mythryl.org

PreviousUpNext