Subversion Repositories tendra.SVN

/*

 * Copyright (c) 2002-2005 The TenDRA Project <http://www.tendra.org/>.

 * All rights reserved.

 *

 * Redistribution and use in source and binary forms, with or without

 * modification, are permitted provided that the following conditions are met:

 *

 * 1. Redistributions of source code must retain the above copyright notice,

 *    this list of conditions and the following disclaimer.

 * 2. Redistributions in binary form must reproduce the above copyright notice,

 *    this list of conditions and the following disclaimer in the documentation

 *    and/or other materials provided with the distribution.

 * 3. Neither the name of The TenDRA Project nor the names of its contributors

 *    may be used to endorse or promote products derived from this software

 *    without specific, prior written permission.

 *

 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS

 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,

 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR

 * PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR

 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,

 * EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,

 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;

 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,

 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR

 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF

 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

 *

 * $Id$

 */

/*

    		 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(bool sto, exp to, exp e);

extern bool just_ret;

extern mach_ins *prologue_ins;

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

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

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

static void place_arguments(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(ash stack, shape s);

extern void prologue(void);

extern void out_profile(bool save_a1);

extern int do_peephole;

extern int do_pic;

void gcproc

(exp p, char *pname, long cname, int is_ext, int reg_res, 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

(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

(void)

{

   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

(bitpattern rmsk, bitpattern fmsk, long st, long st1, 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

(bool save_ret, 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

(void)

{

   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

(int start, 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

(void)

{

   /* 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

(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

(exp pcallees, 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

(exp pcallees, 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

(long comp_size, long longs, long start_stack, 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;