Subversion Repositories tendra.SVN

/*

    Copyright (c) 1993 Open Software Foundation, Inc.

    All Rights Reserved

    Permission to use, copy, modify, and distribute this software

    and its documentation for any purpose and without fee is hereby

    granted, provided that the above copyright notice appears in all

    copies and that both the copyright notice and this permission

    notice appear in supporting documentation.

    OSF DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING

    ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A

    PARTICULAR PURPOSE.

    IN NO EVENT SHALL OSF BE LIABLE FOR ANY SPECIAL, INDIRECT, OR

    CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM

    LOSS OF USE, DATA OR PROFITS, WHETHER IN ACTION OF CONTRACT,

    NEGLIGENCE, OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION

    WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

*/

/*

    		 Crown Copyright (c) 1997

    This TenDRA(r) Computer Program is subject to Copyright

    owned by the United Kingdom Secretary of State for Defence

    acting through the Defence Evaluation and Research Agency

    (DERA).  It is made available to Recipients with a

    royalty-free licence for its use, reproduction, transfer

    to other parties and amendment for any purpose not excluding

    product development provided that any such use et cetera

    shall be deemed to be acceptance of the following conditions:-

        (1) Its Recipients shall ensure that this Notice is

        reproduced upon any copies or amended versions of it;

        (2) Any amended version of it shall be clearly marked to

        show both the nature of and the organisation responsible

        for the relevant amendment or amendments;

        (3) Its onward transfer from a recipient to another

        party shall be deemed to be that party's acceptance of

        these conditions;

        (4) DERA gives no warranty or assurance as to its

        quality or suitability for any purpose and DERA accepts

        no liability whatsoever in relation to any use to which

        it may be put.

*/

/**********************************************************************

$Author: release $

$Date: 1998/02/04 15:49:04 $

$Revision: 1.2 $

$Log: proc.c,v $

 * Revision 1.2  1998/02/04  15:49:04  release

 * Added OSF copyright message.

 *

 * Revision 1.1.1.1  1998/01/17  15:55:57  release

 * First version to be checked into rolling release.

 *

 * Revision 1.3  1996/10/11  08:36:59  pwe

 * permit unpadded size in dynamic callees

 *

 * Revision 1.2  1996/10/04  16:03:30  pwe

 * add banners and mod for PWE ownership

 *

**********************************************************************/

#include "config.h"

#include <signal.h>

#include "memtdf.h"

#include "codegen.h"

#include "geninst.h"

#include "translat.h"

#include "makecode.h"

#include "machine.h"

#include "flags.h"

#include "myassert.h"

#include "comment.h"

#include "proc.h"

#include "stack.h"

#include "mem_copy.h"

#include "xalloc.h"

#include "parameter.h"

#include "error.h"

#include "dynamic_init.h"

space do_callers PROTO_S ((int,exp,space));

void do_function_call PROTO_S ((exp,space));

void do_general_function_call PROTO_S ((exp,space));

makeans move_result_to_dest PROTO_S ((exp,space,where,int));

void restore_callers PROTO_S ((int));

void restore_callees PROTO_S ((void));

static exp find_ote PROTO_S ((exp,int));

typedef struct postl_ {exp pl; struct postl_ * outer; } postl_chain;

static postl_chain * old_pls;

void update_plc PROTO_N ((ch, ma))

    PROTO_T (postl_chain * ch X int ma)

{	

	while (ch != (postl_chain*)0) {

	  exp pl= ch->pl;

	  while (name(pl)==ident_tag && name(son(pl))==caller_name_tag) {

		no(pl)+= (ma<<6);

		pl = bro(son(pl));

	  }

	  ch = ch->outer;

	}

}

/*

 * Temp location in stack frame callee param save area that can be used

 * in short instruction sequence, such as move between float and fixed regs.

 * Initialised at procedure prelude, for that procedure.

 */

baseoff mem_temp PROTO_N ((byte_offset)) PROTO_T (int byte_offset)

{

  baseoff b;

  b.base = R_SP;

  b.offset = -8;

  /*

   * Only 2 words of temp allocated

   */

  ASSERT(byte_offset >= 0 && byte_offset < 8);

  b.offset += byte_offset;

  return b;

}

/*

 * Implement -p option, by calling mcount with static location address as param.

 */

static void call_mcount PROTO_Z ()

{

  static int p_lab = 0;

  p_lab++;

  /* generate .toc entry */

  fprintf(as_file, "\t.toc\n");

  fprintf(as_file, "T.P.%d:\t.tc\tP.%d[TC],P.%d\n", p_lab, p_lab, p_lab);

  /* mcount counter */

  fprintf(as_file, "\t.lcomm\tP.%d,%d\n", p_lab, 4);

  /* reset to default text segment */

  fprintf(as_file, "\t.csect\t[PR]\n");

  /* call mcount */

  fprintf(as_file, "\t%s\t%d,T.P.%d(%d)\n", get_instruction(i_l), R_FIRST_PARAM, p_lab, R_TOC);

#ifdef TDF_MCOUNT

  extj_special_ins(i_bl, ".TDF_mcount");

#else

  extj_special_ins(i_bl, ".mcount");

#endif

  clear_all();

}

/* is param ident e the last param, or for a proc no params? */

bool last_caller_param PROTO_N ((e)) PROTO_T (exp e)

{

  exp next;

  ASSERT(IS_A_PROC(e) || (name(e) == ident_tag && isparam(e)));

  /* Look at the body of the ident for another param */

  if (IS_A_PROC(e))

  {

    next = son(e);

  }

  else

  {

    next = bro(son(e));

  }

  /* Skip diagnose_tag which may be before next param */

  while(name(next) == diagnose_tag)

  {

    next = son(next);

  }

  if (name(next) == ident_tag 

      && isparam(next) 

      && name(son(next))!=formal_callee_tag)

  {

    return 0;			/* another caller param */

  }

  else

  {

    return 1;			/* anything else means e was last param */

  }

}

/*

 * The following functions generate code for various procedure related

 * constructs.  They put the result in dest using t-regs given by sp.

 * If non-zero, exitlab is the label of where the code is to continue.

 * These functions are called by make_code(), the code selection switch.

 */

/* procedure definition */

void make_proc_tag_code PROTO_N ((e,sp)) PROTO_T (exp e X space sp)

{

  procrec *pr = &procrecs[no(e)];

  long pprops = pr->needsproc.propsneeds;

  clear_all();

  suspected_varargs = 0;

  old_pls = (postl_chain *)0;

  p_current = e;

  initialise_procedure(pr);

  generate_procedure_prologue();

  output_parameters(e);

#ifdef DO_DYNAMIC_INITIALISATION

  if (proc_is_main(e))

  {

    call__main();

  }

#endif

  /*

   * Profiling info

   */

  if (do_profile && !p_leaf)

  {/* In the event of the procedure having no parameters, mcount would not

      have been called,so we call it here */

    call_mcount();

  }

  /*

   * Setup p_result

   */

  if ((pprops & realresult_bit) != 0)	/* proc has real result */

  {

    freg frg;

    frg.fr = FR_RESULT;

    frg.dble = (pprops & longrealresult_bit) ? 1 : 0;

    setfregalt(p_result, frg);

  }

  else if ((pprops & has_result_bit) != 0)

  {

    setregalt(p_result, R_RESULT);

  }

  else

  {

    setregalt(p_result, R_0);		/* no result */

  }

  p_return_label = 0;

  init_proc_errors(e);

  make_code(son(e), sp, nowhere, 0);

  output_error_labels();

  /* epilogue created at make_res_tag_code */

  return;

}

/* ident/param definition within proc */

makeans make_ident_tag_code PROTO_N ((e,sp,dest,exitlab)) PROTO_T (exp e X space sp X where dest X int exitlab)

{

  exp init_exp = son(e);			/* initialisation exp */

  int ident_size = shape_size(sh(init_exp));

  int ident_align = shape_align(sh(init_exp));

  int ident_no = no(e);

  where placew;

  int r = R_NO_REG;

  bool remember = 0;

  makeans mka;

  if (props(e) & defer_bit)

  {

    return make_code(bro(init_exp), sp, dest, exitlab);

  }

  /**************Is it an identification of a caller in a postlude?***********/

  if ( name(init_exp)==caller_name_tag )

  {

    exp ote = find_ote(e,no(init_exp));

    long caller_disp = no(ote)>>3;

    no(e) = ENCODE_FOR_BOFF(caller_disp , OUTPUT_CALLER_PARAMETER );

    set_coded_caller(ote); /* Used in apply_general*/

    ASSERT((props(e) & inanyreg )==0);

    /* Should not have been allocated a register by regalloc or scan */

    placew = nowhere;

  }

  /**************Is it in a fixed point register?***************/

  else if (props(e)&inreg_bits)

  {

    if (ident_no==R_NO_REG)	/* Need to allocate a t-reg */

    {

      int s = sp.fixed;

      if (props(e) & notparreg)

      {

	s |= PARAM_TREGS;

      }

      if (props(e) & notresreg)

      {

	s |= RMASK(R_RESULT);

      }

      ident_no = getreg(s);

      no(e) = ident_no;

    }

    setregalt(placew.answhere,ident_no);

  }

  /**************Is it in a floating point register?***************/

  else if (props(e) & infreg_bits)

  {

    freg frg;

    if (ident_no==FR_NO_REG)	/* Need to allocate a t-reg */

    {

      int s = sp.flt;

      if (props(e) & notparreg)

      {

	s |= PARAM_FLT_TREGS;

      }

      if (props(e) & notresreg)

      {

	s |= RMASK(FR_RESULT);

      }

      ident_no = getfreg(s);

      no(e) = ident_no;

    }

    frg.fr = ident_no;

    frg.dble = (ident_size==64);

    setfregalt(placew.answhere, frg);

  }

  /**************Is it a parameter on the stack?***************/

  else if (isparam(e))

  {

    instore is;

    if(name(init_exp) != formal_callee_tag)

    {

      /* Caller parameter living on stack */

      long caller_offset = no(init_exp)>>3;

      no(e) = ENCODE_FOR_BOFF( caller_offset , INPUT_CALLER_PARAMETER ); 

      if (isvarargparam(e))

      {

	if (ident_size == 0)

	{

	  /* void from <varargs.h> */

	  ident_size = 32;

	  ident_align = 32;

	}

      }

    }

    else 

    {

      /* Callee parameter living on stack */

      long callee_offset = no(init_exp)>>3;

      no(e) = ENCODE_FOR_BOFF( callee_offset , INPUT_CALLEE_PARAMETER );

    }

    is.b = boff(e);

    is.adval = 1;

    setinsalt(placew.answhere, is);

  }

  /**************Allocate on the stack?***************/

  else

  {

    /* It is a local living on the stack */

    instore is;

    is.b = boff(e);

    is.adval = 1;

    setinsalt(placew.answhere, is);

    remember = 1;

  }

  placew.ashwhere.ashsize  = ident_size;

  placew.ashwhere.ashalign = ident_align;

  if( isparam(e))

  {

    if(name(init_exp)==formal_callee_tag && (props(e) & inanyreg) )

    {

      instore is;

      ans aa;

      ASSERT(p_has_fp);

      is.b.base = R_FP;

      is.b.offset = EXTRA_CALLEE_BYTES + (no(init_exp)>>3);

      is.adval = 0;

      setinsalt(aa,is);

      move(aa,placew,sp.fixed,is_signed(sh(init_exp)));

    }

  }

  else

  {

    r = code_here(init_exp, sp, placew);

  }

  COMMENT1("make_ident_tag_code end_init: no(e)=%d", no(e));

  if (remember && r != R_NO_REG && pt(e) != nilexp 

      && keep_eq_size(sh(init_exp), sh(pt(e))))

  {

    /* It was temporarily in a register, track it to optimise future access */

    if (isvar(e))

    {

      keepcont(pt(e), r);

    }

    else

    {

      keepreg(pt(e), r);

    }

  }

  /* and evaluate the body of the declaration */

  mka = make_code(bro(init_exp), guard(placew, sp), dest, exitlab);

  COMMENT1("make_ident_tag_code end_range: no(e)=%d", no(e));

  return mka;

}

/* 

 * Delivers the procedure result

 * with either a normal or an untidy return

 */

void make_res_tag_code PROTO_N ((e,sp)) PROTO_T (exp e X space sp)

{

  where w;

  bool untidy = (name(e)==untidy_return_tag) ? 1 : 0 ;

  w.answhere = p_result;

  w.ashwhere = ashof(sh(son(e)));

  code_here(son(e), sp, w);	/* Evaluation of result value */

  if ( p_leaf

      && p_sreg_first_save == R_NO_REG

      && p_sfreg_first_save == FR_NO_REG)

  {

    /* Short return sequence so generate everytime */

    if(untidy)

    {

      generate_untidy_procedure_epilogue();

    }

    else

    {

      generate_procedure_epilogue();

    }

  }

  else

  {

    /* jump to the end of proc for long return sequence */

    if(p_return_label == 0)

    {

      /* For diagnostics always produce return code */

      if (p_no_of_returns>1 && !diagnose)

      {

	p_return_label = new_label();

	set_label(p_return_label);

      }

      if(untidy)

      {

	generate_untidy_procedure_epilogue();

      }

      else

      {

	generate_procedure_epilogue();

      }

    }

    else

    {

      /* jump to the return sequence at first return */

      uncond_ins(i_b, p_return_label);

    }

  }

  clear_all();			

  return;

}

/* procedure call */

makeans make_apply_tag_code PROTO_N ((e,sp,dest,exitlab)) PROTO_T (exp e X space sp X where dest X int exitlab)

{

  exp fn = son(e);		/* Function */

  exp par = bro(fn);		/* Parameters list */

  space nsp;

  nsp=sp;

  /* Structure results are assumed to be transformed */

  ASSERT(redo_structfns);

  ASSERT(reg_result(sh(e)));

  /* Callers evaluated to usual place relative to sp */

  if(!last(fn)){nsp = do_callers(PROC_PARAM_REGS,par,nsp);}

  /* Function call */

  (void) do_function_call(fn,nsp);

  /* Clear all treg associations */

  clear_all();

  /* Move the result to correct destination */

  return move_result_to_dest(e,sp,dest,exitlab);

}

makeans make_apply_general_tag_code PROTO_N ((e,sp,dest,exitlab)) PROTO_T (exp e X space sp X where dest X int exitlab )

{

  exp fn = son(e);

  exp cers = bro(fn);

  exp cees = bro(cers);

  exp pl = bro(cees);

  space nsp;

  makeans mka;

  nsp = sp;

  /* Callers evaluated to usual place relative to sp */

  /* Any params with caller_tag are marked with offset */

  if(no(cers) !=0)  { nsp = do_callers(GENERAL_PROC_PARAM_REGS,son(cers),sp);}

  /* Callees */

  (void)make_code(cees,nsp,nowhere,0);

  /* Function */

  (void)do_general_function_call(fn,nsp);

  /* This code works on the assumption that the stack pointer is returned to 

     where it was initially 

     i.e no untidy returns from the general_proc */

  /* The postlude also works on the assumption that no calls to alloca are 

     done within it */

  /* clear all register associations */

  clear_all();

  /* move the result to the destination */

  mka = move_result_to_dest(e,sp,dest,exitlab);

  /* Possibility here that the function is untidy

   * In this case we must ensure that there is room to construct 

   * subsequent parameter lists within this procedure

   * The only way to guarantee this is to pull down the stack pointer by

   * an extra p_args_and_link_size

   */

  if (call_is_untidy(cees))

  {

    rir_ins(i_a,R_SP,-p_args_and_link_size,R_SP);

    if (p_has_saved_sp)

    {

      save_sp_on_stack();

    }

  }

  if (postlude_has_call(e))

  {

    exp x = son(cers);

    postl_chain p;

    for(;x != nilexp;)

    {

      if(name(x)==caller_tag)

      {

	no(x) += p_args_and_link_size<<3;

      }

      if(last(x))

      {

	break;

      }

      x=bro(x);

    }

    update_plc(old_pls, p_args_and_link_size);

    p.pl = pl;

    p.outer = old_pls;

    old_pls = &p;

    rir_ins(i_a,R_SP,-p_args_and_link_size,R_SP);    

    (void)make_code(pl,sp,nowhere,0);

    rir_ins(i_a,R_SP,p_args_and_link_size,R_SP);

    old_pls = p.outer;

    update_plc(old_pls, -p_args_and_link_size);

    mka.regmove = R_NO_REG; /* The result reg is corrupted */

  }

  else

  {

    (void)make_code(pl,sp,nowhere,0);

  }

  return mka;

}

void make_return_to_label_tag_code PROTO_N ((e,sp)) PROTO_T (exp e X space sp)

{

  int r = reg_operand(son(e),sp);

  mt_ins(i_mtlr,r);  

  /* See generate_procedure_epilogue in stack.c for similarity */

  if (p_frame_size != 0)

  {

    if (p_has_fp)

    {

      /* Use the frame pointer to collapse the frame */

      mov_rr_ins(R_FP,R_SP);comment("collapse frame using FP");

    }

    else if ( p_has_back_chain )

    {

      /* Use the back chain to collapse the stack frame */

      baseoff back_chain;

      back_chain.base = R_SP;

      back_chain.offset = 0;

      ld_ro_ins(i_l, back_chain, R_SP);comment("collapse frame using back chain");

    }

    else

    {

      /* Use the frame size to collapse the stack frame */

      rir_ins(i_a,R_SP,p_frame_size, R_SP);

    }

  }

  /* At this point the stack pointer is collapsed to where the s-regs are

     stored */

  if (p_has_tp)

  {

    mov_rr_ins(R_TP,R_TEMP_TP);comment("copy TP to TEMP_TP");

    restore_sregs(R_SP,0);

    mov_rr_ins(R_TEMP_TP,R_SP);comment("collapse frame using TEMP_TP");

  }

  else

  {

    restore_sregs(R_SP,0);

  }

  /* At this point the stack pointer is in its return position */

  /* Now we move r to the link register */

  z_ins(i_br);

  return;

}

void make_tail_call_tag_code PROTO_N ((e,sp)) PROTO_T (exp e X space sp)

{

  exp fn =son(e);

  exp cees = bro(fn);

  baseoff callee_pointer;

  bool direct_call = (name(fn) == name_tag 

		      && name(son(fn)) == ident_tag

		      && (son(son(fn)) == nilexp || IS_A_PROC(son(son(fn)))));

  static int identification = 0;

  identification++;

  fprintf(as_file,"# Begin tail call no %d\n",identification);

  callee_pointer.base = R_SP;

  callee_pointer.offset = 0;

  ASSERT(p_has_fp);

  if(name(cees)==make_callee_list_tag || name(cees)==make_dynamic_callee_tag)

  {

    /* +++ This is a bit of a long winded way to do the tail call for

       make_dynamic_callee_tag since the callees are copied twice. */

    code_here(cees,sp,nowhere);

    if (direct_call==0)

    {

      /* dynamic call */

      int desc_base = reg_operand(fn,sp);

      baseoff b;

      b.base = desc_base;

      b.offset = 0;

      ld_ro_ins(i_l,b,R_TMP0);comment(NIL);

      b.base = R_SP;

      b.offset = 4;

      st_ro_ins(i_st,R_TMP0,b);comment(NIL);

    }

    restore_link_register();

    restore_callers(GENERAL_PROC_PARAM_REGS);

    /* Set up R_TEMP_TP and R_TEMP_FP */

    if (p_has_tp)

    {

      mov_rr_ins(R_TP,R_TEMP_TP);comment("copy TP to TEMP_TP");

    }

    else

    {

      /* This only happens with a tail call in a normal proc */

      mov_rr_ins(R_FP,R_TEMP_TP);comment("copy FP to TEMP_TP");

    }

    mov_rr_ins(R_FP,R_TEMP_FP);comment("copy FP to TEMP_FP");

    restore_sregs(R_TEMP_FP,0);

    /* At this point R_TP is R_TEMP_TP and R_FP is R_TEMP_FP */

    /* Pull down R_TEMP_TP by the size of the callees */

    if(name(cees)==make_callee_list_tag)

    {

      int size_of_callee_list=ALIGNNEXT((no(cees)>>3)+EXTRA_CALLEE_BYTES , 8);

      st_ro_ins(i_st,R_TEMP_TP,callee_pointer);comment(NIL);

      mov_rr_ins(R_SP,R_TEMP_FP);comment(NIL);

      rir_ins(i_a,R_TEMP_TP,-(long)(size_of_callee_list),R_TEMP_TP);

      reverse_static_memory_copy(R_TEMP_FP,R_TEMP_TP,size_of_callee_list);

      mov_rr_ins(R_TEMP_TP,R_SP);comment(NIL);

    }

    else

    {

      ld_ro_ins(i_l,callee_pointer,R_TMP0);comment(NIL);

      rrr_ins(i_s,R_TMP0,R_SP,R_TMP0);

      /* R_TMP0 should now contain the callee size */

      st_ro_ins(i_st,R_TEMP_TP,callee_pointer);comment(NIL);

      rrr_ins(i_s,R_TEMP_TP,R_TMP0,R_TEMP_TP);

      mov_rr_ins(R_SP,R_TEMP_FP);comment(NIL);

      reverse_dynamic_word_memory_copy(R_TEMP_FP,R_TEMP_TP,R_TMP0);

      mov_rr_ins(R_TEMP_TP,R_SP);comment(NIL);

    }

    /* The memory copy does not corrupt R_TEMP_TP or R_TEMP_FP */

    /* Finally put the stack pointer at the bottom of the callees */

  }

  else if(name(cees)==same_callees_tag)

  {

    if (name(p_current)==general_proc_tag)

    {

      if (direct_call ==0)

      {

	/* dynamic call */

	int desc_base = reg_operand(fn,sp);

	baseoff b;

	b.base = desc_base;

	b.offset = 0;

	ld_ro_ins(i_l,b,R_TMP0);comment(NIL);

	b.base = R_FP;

	b.offset = 4;

	st_ro_ins(i_st,R_TMP0,b);comment(NIL);

      }

      restore_link_register();

      restore_callees();

      restore_callers(GENERAL_PROC_PARAM_REGS);

      mov_rr_ins(R_FP,R_TEMP_FP);comment("copy FP to TEMP_FP");

      restore_sregs(R_TEMP_FP,0);

      mov_rr_ins(R_TEMP_FP,R_SP);comment("collapse frame using TEMP_FP");

    }

    else

    {

      /* This should only occur in the initialisation required for dynamic

	 initialisation of globals as required for c++ */

      ASSERT(p_has_fp);

      restore_link_register();

      restore_callers(PROC_PARAM_REGS);

      mov_rr_ins(R_FP,R_TEMP_FP);comment("copy FP to TEMP_FP");

      restore_sregs(R_TEMP_FP,0);

      mov_rr_ins(R_TEMP_FP,R_SP);comment("collapse frame using TEMP_FP");

    }

  }

  /* Function */

  if (direct_call)

  {

    baseoff b;

    b = boff(son(fn));

    extj_ins(i_b, b);

    /* Link register is set up to be the previous stack frames */

  }

  else

  {

    /* Link register is set up to be the previous stack frames */

    /* Count register is set up to be the target address */

    baseoff b;

    b.base = R_SP;

    b.offset = 4;

    ld_ro_ins(i_l,b,R_TMP0);comment(NIL);

    mt_ins(i_mtctr,R_TMP0);

    z_ins(i_bctr);

  }

  fprintf(as_file,"# End tail call no %d\n",identification);

  return;

}

void make_same_callees_tag_code PROTO_N ((e,sp)) PROTO_T (exp e X space sp)

{

  int roldsp;

  int rfrom;

  int rto;

  space nsp;

  baseoff callee_pointer;

  nsp = sp;

  callee_pointer.base = R_SP;

  callee_pointer.offset = 0;

  ASSERT(name(p_current)==general_proc_tag);

  rfrom = getreg(nsp.fixed);nsp = guardreg(rfrom,nsp);

  rto = getreg(nsp.fixed);nsp = guardreg(rto,nsp);

  roldsp = getreg(nsp.fixed);nsp = guardreg(roldsp,nsp);

  restore_callees();

  mov_rr_ins(R_FP,rfrom);comment(NIL);

  mov_rr_ins(R_SP,roldsp);comment(NIL);

  if (p_has_vcallees)

  {  /* We use the difference between R_TP and R_FP to

     calculate the size of the vcallees and then pulls the

     stack pointer down by this amount and copies the callees

     onto the bottom of the stack.

     Finally it sets up the callee pointer which points to

     the top of the newly constructed callee list */

    int rsize;

    rsize = getreg(nsp.fixed);nsp = guardreg(rsize,nsp);

    rrr_ins(i_s,R_TP,R_FP,rsize);

    rrr_ins(i_s,R_SP,rsize,R_SP);

    mov_rr_ins(R_SP,rto);comment(NIL);

    dynamic_word_memory_copy(rfrom,rto,rsize); /* copy the callees */

  }

  else

  {

    /* We can do slightly better since we know the size of the callees */

    long csize = ALIGNNEXT(p_callee_size + EXTRA_CALLEE_BYTES,8);

    rir_ins(i_a,R_SP,-csize,R_SP);

    mov_rr_ins(R_SP,rto);comment(NIL);

    static_memory_copy(rfrom,rto,csize);

  }

  st_ro_ins(i_st,roldsp,callee_pointer);comment(NIL);

  return;

}

void make_callee_list_tag_code PROTO_N ((e,sp)) PROTO_T (exp e X space sp )

{

  long x; 

  exp list = son(e);

  long disp;

  where w;

  instore is;

  baseoff new_stackpos;

  /* This is an explicit creation of the callee list on the bottom 

     of the stack. no(e) contains the total size in bits required

     to create the callee list.  The EXTRA_CALLEE_BYTES are the 

     bytes needed to store the extra info on the bottom of the callee

     list. At present only 4 bytes are required to hold a pointer which

     points to the top of the list.*/

  x = ALIGNNEXT( (no(e)>>3) + EXTRA_CALLEE_BYTES  , 8 );

  new_stackpos.base = R_SP;

  new_stackpos.offset = -x;

  st_ro_ins(i_stu , R_SP , new_stackpos);comment(NIL);

  disp = EXTRA_CALLEE_BYTES * 8;/* start coding them here */

  update_plc(old_pls,x);

  if(no(e)!=0)

  {

    for(;;)

    {

      ash ap;

      ap = ashof(sh(list));

      disp = ALIGNNEXT(disp, ap.ashalign);

      is.b.offset = disp>>3;

      is.b.base = R_SP;

      is.adval = 1;

      w.ashwhere = ap;

      setinsalt(w.answhere,is);

      code_here(list,sp,w);

      disp = ALIGNNEXT(disp + ap.ashsize,32);

      if(last(list))

	break;

      list = bro(list);

    }

  }

  update_plc(old_pls,-x);

  return ;