Subversion Repositories tendra.SVN

/*

    		 Crown Copyright (c) 1996

    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.

*/

/*

			    VERSION INFORMATION

			    ===================

--------------------------------------------------------------------------

$Header: /u/g/release/CVSROOT/Source/src/installers/680x0/common/general_proc.c,v 1.1.1.1 1998/01/17 15:55:49 release Exp $

--------------------------------------------------------------------------

$Log: general_proc.c,v $

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

 * First version to be checked into rolling release.

 *

Revision 1.4  1997/11/09 14:08:39  ma

Added preseve stack.

Revision 1.3  1997/10/29 10:22:14  ma

Replaced use_alloca with has_alloca.

Revision 1.2  1997/10/17 12:13:57  ma

Cleaned up.

Revision 1.1.1.1  1997/10/13 12:42:52  ma

First version.

Revision 1.6  1997/10/13 11:43:36  ma

Declared scan2.h

Revision 1.5  1997/10/13 08:49:29  ma

Made all pl_tests for general proc & exception handling pass.

Revision 1.4  1997/09/25 06:45:05  ma

All general_proc tests passed

Revision 1.3  1997/06/24 10:56:02  ma

Added changes for "Plumhall Patch"

Revision 1.2  1997/06/18 10:09:31  ma

Checking in before merging with Input Baseline changes.

--------------------------------------------------------------------------

*/

#include "config.h"

#include <limits.h>

#include "common_types.h"

#include "check.h"

#include "exp.h"

#include "expmacs.h"

#include "flags.h"

#include "shapemacs.h"

#include "externs.h"

#include "install_fns.h"

#include "spec.h"

#include "mach.h"

#include "where.h"

#include "tags.h"

#include "codec.h"

#include "coder.h"

#include "operations.h"

#include "ops_shared.h"

#include "mach_ins.h"

#include "mach_op.h"

#include "instr.h"

#include "codex.h"

#include "output.h"

#include "instrs.h"

#include "peephole.h"

#include "szs_als.h"

#include "tests.h"

#include "utility.h"

#include "weights.h"

#include "translate.h"

#include "general_proc.h"

#include "68k_globals.h"

#include "installglob.h"

#include "special_exps.h"

/* externals */

void scan2 PROTO_S ( ( bool sto, exp to, exp e ) ) ;

extern bool just_ret ;

extern mach_ins *prologue_ins ;

static void code_postlude PROTO_S ((exp postlude, exp callers, ash stack, long post_offset)) ;

static bool test_push_args PROTO_S ((exp args, ash* args_size )) ;

static void push_args PROTO_S ((where w, ash stack, exp args )) ;

static void place_arguments PROTO_S ((exp args, ash stack, long start )) ;

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

    GCPROC

    This routine encodes a procedure call.  The procedure is named pname

    with oname as an alternative (used with diagnostics).  The actual

    body of the procedure is p.

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

/* coder.c & codex.c */

extern ast add_shape_to_stack PROTO_S ((ash stack, shape s ));

extern void prologue PROTO_S ((void));

extern void out_profile PROTO_S (( bool save_a1 ));

extern int do_peephole ;

extern int do_pic ;

void gcproc

    PROTO_N ( ( p, pname, cname, is_ext, reg_res, di) )

    PROTO_T ( exp p X char *pname X long cname X int is_ext X int reg_res X diag_global *di )

{

  exp t ;

  ash stack ;

  ash param_pos ;

  mach_op *op1, *op2 ;

  static long crt_proc_no = 0 ;

  bool has_callers = 0;

  bool has_checkstack = 0;

  bool uses_callers_pointer = 0;

  cur_proc_callees_size = 0;

  /* find out if the call has tail_call or same_callees constructs */

  cur_proc_has_tail_call = 0;

  cur_proc_use_same_callees = 0;

  scan2(1, p, p);

  comp_weights ( p ) ;

  /* Set up flags, register masks, stack etc. */

  has_alloca = proc_has_alloca(p);

  must_use_bp = has_alloca || proc_has_lv(p) || proc_uses_crt_env (p) ;

  bigregs = 0 ;

  crt_ret_lab = next_lab () ;

  extra_stack = 0 ;

  have_cond = 0 ;

  max_stack = 0 ;

  no_calls = 0 ;

  regsinproc = 0 ;

  regsinuse = 0 ;

  reuseables = 0 ;

  regsindec = 0 ;

  stack = 0 ;

  special_no = crt_proc_no++ ;

  stack_dec = 0 ;

  stack_size = 0 ;

  used_ldisp = 0 ;

  used_stack = do_profile || diagnose || must_use_bp ;

  /* Mark procedure body */

  ptno ( p ) = par_pl ;

  no ( p ) = 0 ;

  /* Mark procedure parameters */

  param_pos = 0 ;

  /* the callees are encoded first. Scan to first callee if any */

  t = son ( p ) ;

  while ( name ( t ) == ident_tag && isparam ( t ) &&

          name ( son ( t ) ) != formal_callee_tag ) {

    t = bro(son(t)) ;

    has_callers = 1 ;

  }

  cur_proc_has_vcallees = proc_has_vcallees(p) ;

  uses_callers_pointer = cur_proc_has_vcallees && has_callers ;

  if (uses_callers_pointer) {

    /* ok callers are accessed by use of a5 */

    regsinproc |= regmsk ( REG_A5 ) ;

    regsinuse  |= regmsk ( REG_A5 ) ;

  }

  /* do we have any callees? */

  if (name(t) == ident_tag && name(son(t)) == formal_callee_tag) {

    while(name(t) == ident_tag && name(son(t)) == formal_callee_tag) {

      ast a ;

      a = add_shape_to_stack ( param_pos, sh ( son ( t ) ) ) ;

      no ( t ) = a.astoff + a.astadj + (cur_proc_has_vcallees ? 4*8 : 0);

      param_pos = a.astash ;

      ptno ( t ) = par_pl ;

      make_visible( t ) ;

      t = bro ( son ( t ) ) ;

    }

    cur_proc_callees_size = param_pos ;

  }

  /* encode the caller parameters */

  {

    exp caller = son ( p ) ;

    int location_id = par_pl ;

    if ( uses_callers_pointer ) {

      location_id = par2_pl ;

      param_pos = 0 ;

    }

    while (name(caller) == ident_tag && isparam (caller) &&

           name(son(caller)) != formal_callee_tag ) {

      ast a;

      a = add_shape_to_stack ( param_pos, sh ( son ( caller ) ) ) ;

      ptno ( caller ) = location_id ;

      no ( caller ) = a.astoff + a.astadj ;

      param_pos = a.astash ;

      make_visible( caller ) ;

      caller = bro ( son ( caller ) ) ;

    }

  }

  /* calculate callers size */

  cur_proc_callers_size = param_pos ;

  if ( ! uses_callers_pointer )

  cur_proc_callers_size -= cur_proc_callees_size ;

  /* Output procedure name(s) */

  area ( ptext ) ;

  make_instr ( m_as_align4, null, null, 0 ) ;

  if ( is_ext && pname ) {

     if ( strcmp ( pname, "_cmppt" ) == 0 ) {

        /* Hack to get alignments right */

      make_instr ( m_nop, null, null, 0 ) ;

      make_instr ( m_nop, null, null, 0 ) ;

    }

    op1 = make_extern_data ( pname, 0 ) ;

    make_instr ( m_as_global, op1, null, 0 ) ;

  }

  if ( cname == -1 ) {

    make_external_label ( pname ) ;

  } else {

     make_label ( cname ) ;

  }

  if (! strcmp (pname, "_main")) {

     make_comment("Do Dynamic Initialization");

     op1 = make_extern_ind("___TDF_main",0);

     make_instr(m_call,op1,null,0);

  }

  /* Output profiling information if required */

  if ( do_profile ) {

    out_profile ( !reg_res ) ;

    used_stack = 1 ;

  }

  if ( proc_has_checkstack(p) ) {

     /* check that there is room for env_size(<this proc>) */

     /* since callers, callees & return address are pushed */

     /* we only check for the rest */

     long already_allocated = cur_proc_callers_size + cur_proc_callees_size + 32 ;

     where w;

     w = mw (get_env_size(cur_proc_dec), - already_allocated);

     checkalloc_stack (w, 0);

     has_checkstack = 1 ;

  }

  /* Set up procedure prologue */

  prologue () ;

  /* Diagnostics for start of procedure */

#if have_diagnostics

  if ( di ) xdb_diag_proc_begin ( di, p, pname, cname, is_ext ) ;

#endif

  /* Allow for procedures which return compound results */

  if ( !reg_res ) {

    /* Save A1 on the stack */

    ast newstack ;

    newstack = add_shape_to_stack ( stack, slongsh ) ;

    stack = newstack.astash ;

    max_stack = 32 ;

    used_stack = 1 ;

    op1 = make_register ( REG_A1 ) ;

    op2 = make_indirect ( REG_AP, -4 ) ;

    make_instr ( m_movl, op1, op2, 0 ) ;

  }

  need_preserve_stack = 0;

  if (proc_uses_crt_env(p) && proc_has_lv(p) && has_alloca) {

     need_preserve_stack = 1 ;

     stack += 32 ;

     max_stack += 32 ;

     save_stack () ;

  };

  /* Encode the procedure body */

#if have_diagnostics

  if ( diagnose ) {

    dnt_begin () ;

    coder ( zero, stack, t ) ;

    dnt_end () ;

  } else

#endif

    coder ( zero, stack, t ) ;

  /* Output the procedure epilogue */

  general_epilogue (uses_callers_pointer, has_checkstack) ;

  /* Apply peephole optimizations and return */

  if ( do_peephole ) peephole () ;

  /* Diagnostics for end of procedure */

#if have_diagnostics

  if ( di ) xdb_diag_proc_end ( di ) ;

#endif

  return  ;

}

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

  restore_regs_subsribers is used by restore_regs.

  It is a list of places to put insructions to restore registers.

I If untidy is true, it means that sp shall not be restored.

*/

typedef struct rrs_tag {

  mach_ins* ins ;

  restore_type_t restore_type  ;

  struct rrs_tag* next ;

} rrs;

rrs* restore_regs_subsribers = 0 ;

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

 RESTORE_REGS

 Subscribe on code to restore registers. See restore_regs_output below.

 Restore_type is one of: ALL, NOT_SP, NOT_A6_OR_SP

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

void restore_regs

    PROTO_N ( ( typ ) )

    PROTO_T ( restore_type_t typ )

{

  rrs* p = (rrs*) xmalloc(sizeof(rrs)) ;

  p->ins  = current_ins ;

  p->next = restore_regs_subsribers ;

  p->restore_type = typ ;

  restore_regs_subsribers = p ;

}

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

/* used by restore_regs_output below */

rrs* pop_restore_regs_subsriber

    PROTO_Z ()

{

   rrs* p = restore_regs_subsribers ;

   if (p != 0) {

      restore_regs_subsribers = p->next ;

   }

   return p ;

}

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

  RESTORE_REGS_OUTPUT

  Output instructions to restore registers.

  This is done in all places where the restore_regs call has been made.

  This procedure is called by epilogue after installing the body of a

  General Procedure. First then we know which registers to restore.

  rmsk is the set of normal regs to restore from AP - st

  fmsk is the set of floating point regs to restore from AP - st1

  side effect: current_ins is changed

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

void restore_regs_output

    PROTO_N ( ( rmsk, fmsk, st, st1, uses_link ) )

    PROTO_T ( bitpattern rmsk X bitpattern fmsk X long st X long st1 X bool uses_link )

{

   rrs* p ;

   while ( ( p = pop_restore_regs_subsriber () ) ) {

      mach_op *op1, *op2 ;

      current_ins = p->ins ;

      make_comment("Restore Registers") ;

      /* Restore floating-point registers from the stack */

      if ( fmsk ) {

         just_ret = 0 ;

         op1 = make_indirect ( REG_AP, -st1 ) ;

         op2 = make_hex_value ( fmsk ) ;

         make_instr ( m_fmovemx, op1, op2, fmsk ) ;

      }

      /* Restore registers from the stack */

      if ( rmsk ) {

         just_ret = 0 ;

         if ( must_use_bp ) {

            op1 = make_indirect ( REG_AP, -st ) ;

         } else {

            op1 = make_indirect ( REG_SP, 0 ) ;

         }

         op2 = make_hex_value ( rmsk ) ;

         make_instr ( m_moveml, op1, op2, rmsk ) ;

      }

      if ( uses_link ) {

         just_ret = 0 ;

         switch ( p->restore_type ){

         case ALL:

            /* Output unlink instruction */

            op1 = make_register ( REG_AP ) ;

            make_instr ( m_unlk, op1, null, regmsk ( REG_AP ) ) ;

            break;

         case NOT_SP:

            make_comment("untidy return => Restore A6, but not SP");

            op1 = make_indirect ( REG_AP, 0 ) ;

            op2 = make_register ( REG_AP ) ;

            make_instr ( m_movl, op1, op2, regmsk ( REG_AP ) ) ;

            break;

         case NOT_A6_OR_SP:

            make_comment("exit with long jump => Don't restore A6 or SP");

            break;

         default:

            error("wrong restore type");

         }

      }

   }

}

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

  CLEANUP_BT

  Cleanup before a tail call is performed. Used by tail_call.

  Restore registers and frees callees stack room and return address.

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

void cleanup_bt

    PROTO_N ( ( save_ret, rg ) )

    PROTO_T ( bool save_ret X int rg )

{

   mach_op *op1, *op2 ;

   make_comment ( "Cleanup before tail call ..." );

   /* save callees size in scratch register if needed */

   if (cur_proc_has_vcallees) {

      make_comment ( "save old callees size" );

      op1 = make_indirect ( REG_AP, 8 ) ;

      op2 = make_register ( REG_D0 ) ;

      make_instr ( m_movl, op1, op2, regmsk ( REG_D0 ) ) ;

   }

   /* subscribe on code to restore registers */

   restore_regs(ALL) ;

   if ( save_ret ) {

      make_comment ( "save return address in register" );

      op1 = make_indirect ( REG_SP, 0 ) ;

      op2 = make_register ( rg ) ;

      make_instr ( m_movl, op1, op2, regmsk ( rg ) ) ;

   }

   if ( cur_proc_has_vcallees ) {

      make_comment("cleanup variable callees and return address");

      op1 = make_register ( REG_D0 ) ;

      op2 = make_register ( REG_SP );

      make_instr ( m_addl, op1, op2, regmsk ( REG_SP ) );

      op1 = make_value ( 8 ) ;  /* size of callers pointer & ret.addr. */

      op2 = make_register ( REG_SP );

      make_instr ( m_addl, op1, op2, regmsk ( REG_SP ) );

   }

   else {

      make_comment("cleanup static callees and return address");

      op1 = make_value ( cur_proc_callees_size / 8 + 4 ) ;

      op2 = make_register ( REG_SP );

      make_instr ( m_addl, op1, op2, regmsk ( REG_SP ) );

   }

   make_comment ( "Cleanup before tail call done" );

}

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

  CLEANUP

  Restore registers and frees callees stack room, just before return from

  a procedure. Used by general_epilogue.

  The return address is restored.

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

void cleanup

    PROTO_Z ()

{

   mach_op *op1, *op2 ;

   bool callees_to_clean = cur_proc_has_vcallees || cur_proc_callees_size ;

   make_comment ( "Cleanup before return ..." );

   /* save callees size in scratch register if needed */

   if ( cur_proc_has_vcallees ) {

      make_comment ( "save callees size" );

      op1 = make_indirect ( REG_AP, 8 ) ;

      op2 = make_register ( REG_A0 ) ;

      make_instr ( m_movl, op1, op2, regmsk ( REG_A0 ) ) ;

   }

   /* subscribe on code to restore registers */

   restore_regs(ALL) ;

   if ( callees_to_clean ) {

      make_comment ( "save return address in register" );

      op1 = make_indirect ( REG_SP, 0 ) ;

      op2 = make_register ( REG_A1 ) ;

      make_instr ( m_movl, op1, op2, regmsk ( REG_A1 ) ) ;

      if ( cur_proc_has_vcallees ) {

         make_comment("cleanup variable callees and return address");

         op1 = make_register ( REG_A0 ) ;

         op2 = make_register ( REG_SP );

         make_instr ( m_addl, op1, op2, regmsk ( REG_SP ) );

         op1 = make_value ( 4 ) ; /* size of callers pointer */

         op2 = make_register ( REG_SP );

         make_instr ( m_addl, op1, op2, regmsk ( REG_SP ) );

      }

      else {

         make_comment("cleanup static callees");

         op1 = make_value ( cur_proc_callees_size / 8 ) ;

         op2 = make_register ( REG_SP );

         make_instr ( m_addl, op1, op2, regmsk ( REG_SP ) );

      }

      make_comment("put return address back on the stack");

      op1 = make_register ( REG_A1 ) ;

      op2 = make_indirect ( REG_SP, 0 ) ;

      make_instr ( m_movl, op1, op2, 0 ) ;

   }

   make_comment ( "Cleanup before return done" );

}

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

  PUSH_RANGE

  Push memory in the range [start, end] on the stack. (start > end).

  (modifies start, end, SP)

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

void push_range

    PROTO_N ( ( start, end ) )

    PROTO_T ( int start X int end )

{

   mach_op *op1, *op2 ;

   long lb ;

   make_comment("Push range");

   lb = next_lab () ;

   make_label ( lb ) ;

   op1 = make_predec ( start ) ;

   op2 = make_dec_sp () ;

   make_instr ( m_movw, op1, op2, regmsk ( REG_SP ) ) ;

   op1 = make_register ( start ) ;

   op2 = make_register ( end ) ;

   make_instr ( m_cmpl, op1, op2, 0 ) ;

   make_jump ( m_bne, lb ) ;

}

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

  MAKE_CALLEES_SIZE

  Returns an operand specifying the size of the callees for

  the current procedure.

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

mach_op* make_callees_size

    PROTO_Z ()

{

   /* Is it a run time value ? */

   if ( cur_proc_has_vcallees )

   return make_indirect ( REG_AP, 8 ) ;

   /* or compile time value ? */

   return make_value ( cur_proc_callees_size / 8 ) ;

}

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

  PUSH_SAME_CALLEES

  Used by apply_general_proc to push the same callees

  (modifies A0,D0,D1,SP)

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

void push_same_callees

    PROTO_N ( ( var_callees ) )

    PROTO_T ( bool var_callees )

{

   mach_op *op1, *op2 ;

   /* do we have any callees to push ? */

   if ( cur_proc_has_vcallees || cur_proc_callees_size ) {

      make_comment("Push same callees");

      make_comment("end of callees");

      op1 = make_register ( REG_AP ) ;

      op2 = make_register ( REG_D1 ) ;

      make_instr ( m_movl, op1, op2, regmsk ( REG_D1 ) ) ;

      /* add sizeof(ret-addr)+sizeof(preincrement) ?+sizeof(callees size)? */

      op1 = make_value( ( cur_proc_has_vcallees )? 12 : 8 ) ;

      op2 = make_register ( REG_D1 ) ;

      make_instr ( m_addl, op1, op2, regmsk ( REG_D1 ) ) ;

      make_comment("start of callees");

      op1 = make_register ( REG_D1 ) ;

      op2 = make_register ( REG_A0 ) ;

      make_instr ( m_movl, op1, op2, regmsk ( REG_A0 ) ) ;

      op1 = make_callees_size() ;

      op2 = make_register ( REG_A0 ) ;

      make_instr ( m_addl, op1, op2, regmsk ( REG_A0 ) ) ;

      push_range ( REG_A0, REG_D1 ) ;

   }

   if (var_callees) {

      make_comment("push size of callees on the stack");

      op1 = make_callees_size () ;

      op2 = make_dec_sp();

      make_instr ( m_movl, op1, op2, regmsk ( REG_SP )) ;

      stack_size -= 32 ;

   }

}

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

  PUSH_DYNAMIC_CALLEES

  Used by apply_general_proc to push dynamic callees

  Callees size is available in D1 afterwards.

  (modifies A0,D0,D1,SP)

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

void push_dynamic_callees

    PROTO_N ( ( pcallees, stack ) )

    PROTO_T ( exp pcallees X ash stack )

{

   mach_op *op1, *op2 ;

   exp ptr = son ( pcallees ) ;

   exp sze = bro ( ptr ) ;

   exp ident, ident_def ;

   bool const_compound_shape = 0 ;

   long total_size = 0 ;

   make_comment("Push dynamic callees");

   coder ( A1, stack, ptr ) ;

   coder ( D1, stack, sze ) ;

   /* are callees of compond shape ? */

   if ( name ( ptr ) == name_tag) {

      ident = son ( ptr ) ;

      ident_def = son ( ident ) ;

      if ( name ( ident_def ) == compound_tag ) {

         const_compound_shape = ! ( isvar ( ident ) ) ;

      }

   }

   if ( const_compound_shape ) {

      long value ;

      exp pair = son ( ident_def ) ;

      if ( pair ) for (;;) {

         pair = bro ( pair ) ;

         value = no ( pair ) ;

         op1 = make_value ( value ) ;

         op2 = make_dec_sp () ;

         make_instr ( m_movl, op1, op2, regmsk ( REG_SP ) ) ;

         total_size += 4 ;

         if ( last ( pair ) ) break ;

         pair = bro ( pair ) ;

      }

   }

   else {

      /* Let A0 point to end of callees */

      op1 = make_register ( REG_A1 ) ;

      op2 = make_register ( REG_A0 ) ;

      make_instr ( m_movl, op1, op2, regmsk ( REG_A0 ) ) ;

      op1 = make_register ( REG_D1 ) ;

      op2 = make_register ( REG_A0 ) ;

      make_instr ( m_addl, op1, op2, regmsk ( REG_A0 ) ) ;

      push_range ( REG_A0, REG_A1 ) ;

   }

   if ( call_has_vcallees(pcallees) ) {

      make_comment("push size of dynamic callees on the stack");

      if ( const_compound_shape ) {

         op1 = make_value ( total_size ) ;

      }

      else {

         op1 = make_register ( REG_D1 ) ;

      }

      op2 = make_dec_sp();

      make_instr ( m_movl, op1, op2, regmsk ( REG_SP )) ;

      stack_size -= 32 ;

   }

   else {

       debug_warning("call with dynamic callees requires var_callees PROCPROPS");

   }

}

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

  PUSH_DYNAMIC_CALLEES_BT

  Used by tail_call to push dynamic callees

  (modifies A0,A1,D0,D1,SP)

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

void push_dynamic_callees_bt

    PROTO_N ( ( pcallees, stack ) )

    PROTO_T ( exp pcallees X ash stack )

{

   mach_op *op1, *op2 ;

   push_dynamic_callees ( pcallees, stack );

   make_comment("push return address");

   op1 = make_indirect ( REG_AP, 4 ) ;

   op2 = make_dec_sp();

   make_instr ( m_movl, op1, op2, regmsk ( REG_SP ) ) ;

   make_comment("put end of callees, size & return address in A1");

   op1 = make_register ( REG_SP ) ;

   op2 = make_register ( REG_A1 ) ;

   make_instr ( m_movl, op1, op2, regmsk ( REG_A1 ) ) ;

   make_comment("put start of callees in A0");

   op1 = make_register ( REG_A1 ) ;

   op2 = make_register ( REG_A0 ) ;

   make_instr ( m_movl, op1, op2, regmsk ( REG_A0 ) ) ;

   /* add size of callee from D1 */

   op1 = make_register ( REG_D1 ) ;

   op2 = make_register ( REG_A0 ) ;

   make_instr ( m_addl, op1, op2, regmsk ( REG_A0 ) ) ;

   /* add size of return address and size of callees size if needed */

   op1 = make_value ((call_has_vcallees(pcallees)) ? 8 : 4) ;

   op2 = make_register ( REG_A0 ) ;

   make_instr ( m_addl, op1, op2, regmsk ( REG_A0 ) ) ;

   cleanup_bt (0, 0) ;

   push_range ( REG_A0, REG_A1 ) ;

}

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

  A1_RESULT_POINTER

  For results which do not fit into registers a pointer to

  where the result is to be put is passed in A1

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

void A1_result_pointer

    PROTO_N ( ( comp_size, longs, start_stack, dest ) )

    PROTO_T ( long comp_size X long longs X long start_stack X where dest )

{

   if ( comp_size ) {

      /* Find the space allocated for unwanted results */

      where w ;

      w = mnw ( longs / 8 ) ;

      make_comment("let A1 point to unwanted compund result") ;

      add ( slongsh, SP, w, A1 ) ;

   } else {

      long doff ;

      /* Find the address of where the result is to be put */

      tmp_reg_prefer = REG_A1 ;

      if ( apply_tag_flag ) {

         /* For recursive use of apply_proc or apply_general

            we need to be very careful if the result is itself

            to be a procedure argument to get the right stack offset. */

         /* push old value */

         long ex = extra_stack ;

         extra_stack += start_stack ;

         if ( (dest.wh_exp == SP_p.wh_exp) && (dest.wh_is == SP_p.wh_is) ) {

            /* Careful! */

            /* push where offset */

            doff = dest.wh_off ;

            dest.wh_off = doff + extra_stack ;

            make_comment("let A1 point to compund result used as procedure argument") ;

            mova ( dest, A1 ) ;

            /* pop where offset */

            dest.wh_off = doff ;

         } else {

            /* Easy */

            make_comment("let A1 point to compund result from eval. of call par.") ;

            mova ( dest, A1 ) ;

         }

         /* pop value after call */

         extra_stack = ex  ;

      }

      else {

         /* Otherwise (easy) ... */

         make_comment("let A1 point to compund result") ;

         mova ( dest, A1 ) ;

      }

   }

   /* Make sure we don't reuse A1 accidently */

   avoid_tmp_reg ( REG_A1 ) ;

   regsinproc |= regmsk ( REG_A1 ) ;

}

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

  POSTLUDE_HAS_CODE

  Returns true if postlude has code

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

static bool postlude_has_code

    PROTO_N ( ( postlude ) )

    PROTO_T ( exp postlude )

{

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

      postlude = bro( son( postlude ) );

   }

   return ( name( postlude ) != top_tag ) ;

}

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

  APPLY_GENERAL_PROC

  Code a General Procedure Call.

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

void apply_general_proc

    PROTO_N ( ( e, dest, stack ) )

    PROTO_T ( exp e X where dest X ash stack )

{

   /* Procedure applications */

   exp t ;

   ash st ;

   where tmp_dest;

   mach_op *op1, *op2 ;

   long comp_size = 0 ;

   long longs = 0, stkdec ;

   long start_stack = stack_dec ;

   long callers_size = 0, callees_size = 0 ; /* size of parameters on the stack */

   long size_size = 0 ;                      /* size of callees size */

   long callees_size_total = 0 ;             /* size of callees and callees size */

   long result_size = 0 ;                    /* size of result */