/*
 * Copyright (c) 2002, The Tendra Project <http://www.ten15.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 unmodified, 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.
 *
 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
 *
 *
 *    		 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.
 *
 * $TenDRA: tendra/src/installers/680x0/common/general_proc.c,v 1.8 2005/09/16 08:53:12 stefanf Exp $
 */


#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;
	reusables = 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 instructions 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()
{
	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()
{
	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()
{
	/* 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 compound 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 compound 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 compound result used as procedure argument");
				mova (dest, A1);
				
				/* pop where offset */
				dest.wh_off = doff;
				
			} else {
				/* Easy */
				make_comment("let A1 point to compound 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 compound result");
			mova (dest, A1);
		}
	}
	/* Make sure we don't reuse A1 accidentally */
	avoid_tmp_reg (REG_A1);
	regsinproc |= regmsk (REG_A1);
}

/************************************************************************
 *  POSTLUDE_HAS_CODE
 *
 *  Returns true if postlude has code
 ************************************************************************/

static bool
postlude_has_code(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(exp e, where dest, 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 */
	
	bool push_result = 0, use_push = 1, reg_res;
	bool has_postlude = 0, has_checkstack = 0, is_untidy = 0;
	
	exp proc, caller_args, pcallees = 0, postlude = 0, callee_args = 0;
	
	make_comment("Apply Proc");
	
	/* Find the procedure and the arguments */
	
	tmp_dest = dest;
	proc = son (e);
	caller_args = (!last(proc)) ? bro (proc) : nilexp;
	
	if (name(e) == apply_general_tag) {
		pcallees     = bro (caller_args);
		postlude    = bro (pcallees);
		callee_args = son (pcallees);
		caller_args = son (caller_args);
		
		is_untidy = call_is_untidy(e);
		has_checkstack = call_has_checkstack(e);
		has_postlude = postlude_has_code(postlude);
	}
	
	/* calculate length of callers and see if we can push them */
	
	if (! test_push_args(caller_args, &callers_size)) use_push = 0;
	
	if (pcallees) {
		if (name(pcallees) == make_callee_list_tag) {
			/* calculate length of callees and see if we can push them */
			if (! test_push_args(callee_args, &callees_size)) use_push = 0;
		}
		size_size = ((call_has_vcallees(pcallees))?32:0);
		callees_size_total = callees_size + size_size;
	}
	
	/* total parameter space */
	longs = callers_size + callees_size_total;
	
	/* Does the result go into a register? */
	reg_res = result_in_reg (sh (e));
	if (!reg_res) {
		if (eq_where (dest, zero)) {
			/* Calculate size of ignored compound result */
			comp_size = round (shape_size (sh (e)), param_align);
		}
	}
	
	/* Find total amount of stack decrease */
	stkdec = longs + comp_size;
	
	if (has_checkstack) {
		/* check if there is room for parameters and return address on the stack */
		checkalloc_stack(mnw(stkdec / 8 + 4), 0);
	}
	
	/* Put arguments onto stack */
	if (use_push) {
		if (comp_size) {
			/* Make room for unwanted compound result */
			dec_stack (comp_size);
			stack_dec -= comp_size;
		}
		
		if (caller_args) {
			make_comment("Push callers");
			push_args (zw (e), stack, caller_args);
		}
		
		if (pcallees) {
			if (name(pcallees) == make_dynamic_callee_tag) {
				push_dynamic_callees (pcallees, stack);
				stack_dec -= callees_size_total;
			}
			else if (name(pcallees) == same_callees_tag) {
				push_same_callees(call_has_vcallees(pcallees));
				stack_dec -= callees_size_total;
			}
			else {
				if (callee_args) {
					make_comment("Push static callees");
					push_args (zw (e), stack, callee_args);
				}
				if (call_has_vcallees(pcallees)) {
					make_comment("push size of callees on the stack");
					stack_dec -= 32;
					stack_size -= 32;
					
					op1 = make_value (callees_size / 8);
					op2 = make_dec_sp();
					make_instr (m_movl, op1, op2, regmsk (REG_SP));
				}
			}
		}
	}
	else {
		/* Can't just use push => Decrease stack instead */
		dec_stack (stkdec);
		stack_dec -= stkdec;
		
		if (caller_args) {
			make_comment("Place callers on the stack");
			place_arguments(caller_args, stack, callees_size_total);
		}
		if (pcallees) {
			if (name(pcallees) == make_dynamic_callee_tag) {
				push_dynamic_callees (pcallees, stack);
			}
			else if (name(pcallees) == same_callees_tag) {
				push_same_callees(call_has_vcallees(pcallees));
			}
			else {
				if (callee_args) {
					make_comment("Place static callees on the stack");
					place_arguments(callee_args, stack, size_size);
				}
				if (call_has_vcallees(pcallees)) {
					make_comment("push size of callees on the stack");
					op1 = make_value (callees_size / 8);
					op2 = make_indirect (REG_SP, 0);
					make_instr (m_movl, op1, op2, regmsk (REG_SP));
				}
			}
		}
	}
	
	start_stack -= stack_dec;
	
	if (!reg_res)
		A1_result_pointer(comp_size, longs, start_stack, dest);
	
	/* Output the call instruction */
	callins (0, proc);
	
	if (is_untidy) {
		stack_dec = 0; /* We can't keep track of it any longer */
		if (need_preserve_stack)
			save_stack ();
	}
	else {
		/* callees has now been cleaned up by called proc. */
		stack_dec += callees_size_total;
		stack_size += callees_size_total;
	}
	
	/* can we cleanup callers now ? */
	if (! (has_postlude || is_untidy)) {
		/* Clean up of callers and room for ignored compound result. */
		stack_dec += callers_size + comp_size;
		dec_stack (- callers_size - comp_size);
	}
	
	/* Move the result into place */
	if (comp_size) {
		make_comment("(unwanted compound result)");
	}
	else
		if (eq_where (dest, zero)) {
			make_comment("(unwanted simple result)");
		}
		else {
			/* ok the result is needed */
			if (has_postlude) {
				/* we need to preserve result on stack */
				result_size = rounder (shape_size(sh(e)), param_align);
				dec_stack (result_size);
				stack_dec -= result_size;
				tmp_dest = SP_p;
				push_result = 1;
			}
			if (reg_res) {
				if (shape_size (sh (e)) <= 32) {
					/* Small register results are in D0 */
					move (sh (e), D0, tmp_dest);
				} else {
					/* Larger register results are in D0 and D1 */
#ifdef SYSV_ABI
					move (sh (e), FP0, tmp_dest);
#else
					move (sh (e), D0_D1, tmp_dest);
					regsinproc |= regmsk (REG_D1);
#endif
				}
			} else {
				make_comment("(compound result)");
				if (has_postlude) {
					make_comment("save compound result before postlude...");
					move (sh (e), dest, tmp_dest);
					make_comment("save compound result before postlude done");
				}
				
				/* Compound results should already have been copied to
				 *            the position pointed to by A1 by the called procedure
				 *            and returned by it in D0, so no further action should
				 *            be required by the calling procedure.  Unfortunately
				 *            cc doesn't always get this right for union results. */
#ifdef OLD_SPEC
				if (cc_conventions && name (sh (e)) == unhd) {
					regsinproc |= regmsk (REG_A0);
					move (slongsh, D0, A0);
					move (sh (e), A0_p, dest);
				}
#endif
			}
		}
	
	if (has_postlude) {
		code_postlude(postlude, caller_args, stack, result_size);
		
		/* put return value back in register */
		if (push_result) {
			make_comment("restore result after postlude...");
			move(sh(e), SP_p, dest);
			make_comment("restore result after postlude done");
			dec_stack (-result_size);
			stack_dec += result_size;
		}
		
		/* Delayed clean up of callers and room for ignored compound result.
		 *         callees are cleaned by the called proc. */
		if (! is_untidy) {
			stack_dec += callers_size + comp_size;
			dec_stack (- callers_size - comp_size);
		}
	}
}

/************************************************************************
 *  TEST_PUSH_ARGS
 *
 *  The total stack space required by the arguments is returned in args_size.
 *
 *  Returns true if all arguments (args) can be pushed to the stack.
 *
 *  The args_size is also used if false is returned.

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

static bool
test_push_args(exp args, ash* args_size)
{
	
	/* See if we can push all the arguments */
	
	bool use_push = 1;
	exp arg = args, formal;
	ash stack = 0;
	ast stack_add_res;
	
	while (arg != nilexp) {
		formal = (name (arg) == caller_tag) ? son (arg) : arg;
		
		if (cpd_param (sh (formal))) use_push = 0;
		if ((name(sh(formal)) == s64hd) || (name(sh(formal)) == u64hd)) use_push = 0;
		if (! push_arg (formal)) use_push = 0;
		
		stack_add_res = add_shape_to_stack (stack, sh (formal));
		stack = stack_add_res.astash;
		
		/* information used by code_postlude */
		if (name (arg) == caller_tag)
			no (arg) = stack_add_res.astoff + stack_add_res.astadj;
		
		arg = (last (arg) ? nilexp : bro (arg));
	}
	
	(* args_size) = stack;
	
	
	return use_push;
}


/************************************************************************
 *  PLACE_ARGUMENTS
 *
 *  Encodes procedure arguments on the stack.
 ************************************************************************/

static void
place_arguments(exp args, ash stack, long start)
{
	exp arg = args;
	ast stack_add_res;
	where stack_pointer;
	long adj;
	long st = start;
	
	/* Indicate recursive calls */
	apply_tag_flag ++;
	
	/* Encode the arguments onto the stack */
	while (arg != nilexp) {
		exp formal = (name (arg) == caller_tag) ? son (arg) : arg;
		
		char nc = name (sh (formal));
		if (nc == scharhd || nc == ucharhd) adj = 24;
		else
			if (nc == swordhd || nc == uwordhd) adj = 16;
			else adj = 0;
		
		stack_pointer = mw (SP_p.wh_exp, st + adj);
		coder (stack_pointer, stack, formal);
		stack_add_res = add_shape_to_stack (st, sh (formal));
		st = stack_add_res.astash;
		
		arg = (last (arg) ? nilexp : bro (arg));
	}
	
	apply_tag_flag --;
}

/************************************************************************
 *  PUSH A SET OF PROCEDURE ARGUMENTS
 *
 *  The arguments are given by a bro-list t.
 *  They are coded in reverse order.
 ************************************************************************/

static void
push_args(where w, ash stack, exp args)
{
	long sz = shape_size (sh (args));
	exp formal;
	
	if (last (args)) {
		/* Code last argument */
		formal = (name (args) == caller_tag) ? son (args) : args;
		coder (w, stack, formal);
		stack_dec -= rounder (sz, param_align);
	} else {
		/* Code the following arguments */
		push_args (w, stack, bro (args));
		/* And then this one */
		formal = (name (args) == caller_tag) ? son (args) : args;
		coder (w, stack, formal);
		stack_dec -= rounder (sz, param_align );
	}
	return;
}

/************************************************************************
 *  TAIL_CALL
 *
 *  Code a tail call.
 ************************************************************************/

void
tail_call(exp e, where dest, ash stack)
{
	exp proc        = son (e);
	exp pcallees     = bro(proc);
	exp callee_args = son (pcallees);
	int longs;
	mach_op *op1, *op2;
	long new_callees_size;
	bool use_push = 1;
	
	make_comment("Tail Call");
	
	update_stack();
	
	if (name(pcallees) == make_dynamic_callee_tag) {
		/* A0 and A1 are used by cleanup. We are just about to make the tail
		 *         call with shape bottom, so they are free */
		push_dynamic_callees_bt (pcallees, stack);
		jmpins(proc);
		return;
	}
	
	/* same callees ? */
	
	if (name(pcallees) == same_callees_tag) {
		restore_regs(ALL);
		
		if (! cur_proc_has_vcallees  && call_has_vcallees(pcallees)) {
			make_comment("push size of same static callees and ret.addr. on the stack");
			op1 = make_indirect (REG_SP, 0);
			op2 = make_register (REG_D0);
			make_instr (m_movl, op1, op2, regmsk (REG_SP));
			
			op1 = make_callees_size ();
			op2 = make_indirect (REG_SP, 0);
			make_instr (m_movl, op1, op2, regmsk (REG_SP));
			
			op1 = make_register (REG_D0);
			op2 = make_dec_sp ();
			make_instr (m_movl, op1, op2, regmsk (REG_SP));
		}
		else if (cur_proc_has_vcallees  && ! call_has_vcallees(pcallees)) {
			make_comment("remove size of same static callees from the stack");
			op1 = make_inc_sp ();
			op2 = make_indirect (REG_SP, 0);
			make_instr (m_movl, op1, op2, regmsk (REG_SP));
		}
		jmpins(proc);
		return;
	}
	
	/* nothing more than same callees ? */
	
	if (! (callee_args || cur_proc_has_vcallees || call_has_vcallees(pcallees))) {
		restore_regs(ALL);
		jmpins(proc);
		return;
	}
	
	/* no callees ? */
	
	if (! callee_args) {
		make_comment("save return address");
		op1 = make_indirect (REG_AP, 4);
		op2 = make_register (REG_A1);
		make_instr (m_movl, op1, op2, regmsk (REG_D0));
		
		cleanup_bt(0,0);
		
		if (call_has_vcallees(pcallees)) {
			make_comment("push zero size of callees on the stack");
			op1 = make_value (0);
			op2 = make_dec_sp();
			make_instr (m_movl, op1, op2, regmsk (REG_SP));
		}
		
		make_comment("push return address back");
		op1 = make_register (REG_A1);
		op2 = make_dec_sp();
		make_instr (m_movl, op1, op2, regmsk (REG_SP));
		
		jmpins(proc);
		return;
	}
	
	/* new callees ! */
	
	if (! test_push_args(callee_args, &new_callees_size)) use_push = 0;
	
	if (use_push) {
		make_comment("Push callees");
		push_args (zw (e), stack, callee_args);
	}
	else {
		/* Decrease stack */
		dec_stack (new_callees_size);
		stack_dec -= new_callees_size;
		place_arguments(callee_args, stack, 0);
	}
	
	if (call_has_vcallees(pcallees)) {
		make_comment("push size of new callees on the stack");
		op1 = make_value (new_callees_size / 8);
		op2 = make_dec_sp();
		make_instr (m_movl, op1, op2, regmsk (REG_SP));
	}
	
	make_comment("push return address");
	op1 = make_indirect (REG_AP, 4);
	op2 = make_dec_sp();
	make_instr (m_movl, op1, op2, regmsk (REG_SP));
	
	/*
	 *      Setup source, dest and end mark for push_range
	 *      We will use D1 & A0.
	 */
	
	make_comment("save end of new callees and return address");
	op1 = make_register (REG_SP);
	op2 = make_register (REG_D1);
	make_instr (m_movl, op1, op2, regmsk (REG_D1));
	
	make_comment("save start of new callees and return address");
	op1 = make_register (REG_SP);
	op2 = make_register (REG_A0);
	make_instr (m_movl, op1, op2, regmsk (REG_A0));
	
	/* add sizeof(new callees) sizeof(ret-addr) + ?+sizeof(callees size)? */
	op1 = make_value(new_callees_size/8+4+(call_has_vcallees(pcallees)?4:0));
	op2 = make_register (REG_A0);
	make_instr (m_addl, op1, op2, regmsk (REG_A0));
	
	cleanup_bt(0,0);
	
	make_comment("push the new callees");
	push_range (REG_A0, REG_D1);
	
	/* make the jump instruction */
	jmpins(proc);
}


/************************************************************************
 *  GENERAL PURPOSE PROCEDURE EPILOGUE
 *
 *  The registers used in the procedure and the space used on the stack
 *  are analysed and used to form the procedure epilogue.
 *  There is some testing to see if D1, A0, A1 and FP1 can be put to
 *  better use.
 ************************************************************************/

void
general_epilogue(bool uses_callers_pointer,
				 bool has_checkstack)
{
	int r, instruction_id;
	bitpattern m;
	long st, st1;
	mach_op *op1, *op2;
	mach_ins * save_ins_pointer;
	
	int tmp_d1 = -1, tmp_a0 = -1, tmp_a1 = -1;
	
	bitpattern rmsk = regs (regsinproc & save_msk);
	bitpattern smsk = rmsk;
	bitpattern cmsk = 0;
	bitpattern fmsk = 0;
	bitpattern fsmsk = fregs (regsinproc & save_msk);
	bool d1_free;
	bool save_d1 = 0;
	bool uses_link = 0;
	
	make_comment("Epilogue");
	
	/* restore the default floating point rounding mode */
	reset_round_mode();
	
	for (r = REG_FP7, m = 1 ; r >= REG_FP2 ; r--, m <<= 1) {
		if (regsinproc & regmsk (r)) fmsk |= m;
	}
	
	/* any calls? */
	if (no_calls > 0) {
		if (uses_callers_pointer) {
			/* Variable number of callers => A5 used as pointer to first caller */
			smsk &= ~regmsk (REG_A5);
		}
		
		smsk &= ~bigregs;
		fsmsk &= ~bigregs;
	}
	
	make_label (crt_ret_lab);
	
#if have_diagnostics
	if (diagnose) xdb_diag_proc_return ();
#endif
	
	d1_free = !(regsinproc & regmsk (REG_D1));
	
	/* Use D1 if not already used */
	if (d1_free) {
		m = smsk & dreg_msk ;     /* m = set of D'regs */
		if (m) {
			/* Replace a used D-register by D1 */
			r = reg (m) ;        /* get the first free register number in the set */
			reg_names [r] = reg_names [ REG_D1 ];
			rmsk &= ~regmsk (r);
			smsk &= ~regmsk (r);
			cmsk |= regmsk (r);
			d1_free = 0;
		}
	}
	
	/* Use A0 if not already used */
	if (!(regsinproc & regmsk (REG_A0))) {
		m = smsk & areg_msk;
		if (m) {
			/* Replace a used A-register by A0 */
			r = reg (m);
			reg_names [r] = reg_names [ REG_A0 ];
			rmsk &= ~regmsk (r);
			smsk &= ~regmsk (r);
			cmsk |= regmsk (r);
		} else if (no_calls == 0) {
			m = rmsk & dreg_msk;
			if (m) {
				/* Move a used D-register into A0 */
				tmp_a0 = reg (m);
				rmsk &= ~regmsk (tmp_a0);
				smsk = rmsk;
				op1 = make_register (REG_A0);
				op2 = make_register (tmp_a0);
				make_instr (m_movl, op1, op2, regmsk (tmp_a0));
				just_ret = 0;
			}
		}
	}
	
	/* Use A1 if not already used */
	if (!(regsinproc & regmsk (REG_A1))) {
		m = smsk & areg_msk;
		if (m) {
			/* Replace a used A-register by A1 */
			r = reg (m);
			reg_names [r] = reg_names [ REG_A1 ];
			rmsk &= ~regmsk (r);
			smsk &= ~regmsk (r);
			cmsk |= regmsk (r);
		} else if (no_calls == 0) {
			m = rmsk & dreg_msk;
			if (m) {
				/* Move a used D-register into A1 */
				tmp_a1 = reg (m);
				rmsk &= ~regmsk (tmp_a1);
				smsk = rmsk;
				op1 = make_register (REG_A1);
				op2 = make_register (tmp_a1);
				make_instr (m_movl, op1, op2, regmsk (tmp_a1));
				just_ret = 0;
			}
		}
	}
	
	/* Use FP1 if not already used */
	if (fsmsk && !(regsinproc & regmsk (REG_FP1))) {
		for (r = REG_FP7, m = 1 ; r >= REG_FP2 ; r--, m <<= 1) {
			if (fsmsk & regmsk (r)) {
				reg_names [r] = reg_names [ REG_FP1 ];
				fmsk &= ~m;
				fsmsk &= ~regmsk (r);
				cmsk |= regmsk (r);
				r = REG_FP1;
			}
		}
	}
	
	if (d1_free && no_calls == 0) {
		m = rmsk & areg_msk;
		if (m) {
			/* Move a used A-register into D1 */
			tmp_d1 = reg (m);
			rmsk &= ~regmsk (tmp_d1);
			op1 = make_register (REG_D1);
			op2 = make_register (tmp_d1);
			make_instr (m_movl, op1, op2, regmsk (tmp_d1));
			just_ret = 0;
		}
	}
	
	/* Calculate stack displacements */
	st1 = round (max_stack, 32) / 8 + 16 * bits_in (fmsk);
	st = st1 + 4 * bits_in (rmsk);
	
	if (st1 || st || used_stack || must_use_bp || cur_proc_has_vcallees) uses_link = 1;
	
	cleanup();
	
	/* Output return instruction */
	make_instr (m_rts, null, null, 0);
	
	/* Output instructions to restore registers */
	save_ins_pointer = current_ins;
	restore_regs_output(rmsk, fmsk, st, st1, uses_link);
	
	/* Go back to the prologue position */
	current_ins = prologue_ins;
	
	/* Calculate the offset between procedure args and sp */
	ldisp = (uses_link ? st + 4 : st);
	
	/* Calculate env_size (ldisp + sizeof(return address) + sizeof(params))*/
	cur_proc_env_size = ldisp + 4 + (cur_proc_callers_size + cur_proc_callees_size)/8;
#if 0
	if (has_checkstack)
		cur_proc_env_size += 1024 ; /* room for exception handler */
#endif
	
	if (uses_link) {
		/* Output link instruction */
		/* push AP; AP = SP; sp=sp-st */
		instruction_id = (-st > 0x7fff ? m_linkl : m_linkw);
		op1 = make_register (REG_AP);
		op2 = make_value (-st);
		make_instr (instruction_id, op1, op2, regmsk (REG_AP) | regmsk (REG_SP));
	}
	
	/* Save register in D1 if necessary */
	if (tmp_d1 >= 0) {
		op1 = make_register (tmp_d1);
		op2 = make_register (REG_D1);
		make_instr (m_movl, op1, op2, regmsk (REG_D1));
	}
	
	/* Save register in A0 if necessary */
	if (tmp_a0 >= 0) {
		op1 = make_register (tmp_a0);
		op2 = make_register (REG_A0);
		make_instr (m_movl, op1, op2, regmsk (REG_A0));
	}
	
	/* Save register in A1 if necessary */
	if (tmp_a1 >= 0) {
		op1 = make_register (tmp_a1);
		op2 = make_register (REG_A1);
		make_instr (m_movl, op1, op2, regmsk (REG_A1));
	}
	
	/* Put registers onto the stack */
	if (rmsk) {
		op1 = make_hex_value (rmsk);
		op2 = make_indirect (REG_SP, 0);
		make_instr (m_moveml, op1, op2, 0);
	}
	
	/* Put floating-point registers onto the stack */
	if (fmsk) {
		op1 = make_hex_value (fmsk);
		op2 = make_indirect (REG_AP, -st1);
		make_instr (m_fmovemx, op1, op2, 0);
	}
	
	if (uses_callers_pointer){
		make_comment("Variable callees => Get address of first caller");
		
		regsinproc |= regmsk (REG_A5);
		
		op1 = make_register (REG_AP);
		op2 = make_register (REG_A5);
		make_instr (m_movl, op1, op2, regmsk (REG_A5));
		
		/* A5 = AP + cur_proc_callees_size */
		/* AP points to the first parameter, callees size is before */
		op1 = make_callees_size ();
		op2 = make_register (REG_A5);
		make_instr (m_addl, op1, op2, regmsk (REG_A5));
		
		op1 = make_value (12);
		op2 = make_register (REG_A5);
		make_instr (m_addl, op1, op2, regmsk (REG_A5));
	}
	
	
	/* Return to previous position */
	current_ins = save_ins_pointer;
	
	callmsk = cmsk;
	have_cond = 0;
	return;
}

/************************************************************************
 *  CODE_POSTLUDE
 *  The postlude parameters positions on the stack are setup, and coder
 *  is called with the postlude body.

************************************************************************/
static void
code_postlude(exp postlude, exp callers, ash stack,
			  long post_offset)
{
	make_comment("Postlude ...");
	
	/* mark parameters by use of the values calculated by gcproc */
	while (name(postlude) == ident_tag && name(son(postlude)) == caller_name_tag) {
		int n = no(son(postlude));
		exp a = callers;
		while (n != 0) {
			a = bro(a);
			n--;
		}
		if (name(a) != caller_tag)
			error("Bad postlude");
		
		ptno(postlude) = par3_pl;
		no(postlude) = no(a) + stack_dec + post_offset;
		
		postlude = bro(son(postlude));
	}
	
	/* code the postlude */
	coder (zero, stack, postlude);
	
	make_comment("Postlude done");
}

/************************************************************************
 *  Makes code for untidy return
 ************************************************************************/

void
untidy_return ()
{
	mach_op *op1, *op2;
	
	make_comment("untidy return");
	
	make_comment("push return address");
	op1 = make_indirect (REG_AP, 4);
	op2 = make_dec_sp();
	make_instr (m_movl, op1, op2, regmsk (REG_SP));
	
	restore_regs(NOT_SP);
	/* Output return instruction */
	make_instr (m_rts, null, null, 0);
}

/************************************************************************
 *  Make a label with named after the address of e and the value of the
 *  env offset from e (an ident_tag) to the application pointer.
 ************************************************************************/

void
make_visible(exp e)
{
	mach_op *op1, *op2;
	long offval;
	
	/* Does it need to be visible? */
	
	if (! ((isvis(e)) || (isenvoff(e)))) return;
	
	setismarked(e);
	
	switch (ptno(e)) {
	case var_pl:
		offval = -no(e)/8;
		break;
	case par2_pl:
		offval = no(e)/8;
		break;
	case par3_pl:
	case par_pl:
	default:
		offval = no(e)/8 + 4;
		if (used_stack) offval += 4;
	}
	op1 = make_lab_data ((long)e, 0);
	op2 = make_int_data (offval);
	make_instr_aux (m_as_assign, op1, op2, 0, 0);
}


/************************************************************************
 *  If a caller parameter is accessed from a framepointer with variable
 *  callees we need to transform the pointer in the addptr expression to
 *  callers pointer.
 ************************************************************************/

void
fix_addptr(exp addptr)
{
	exp pointer  = son (addptr);
	exp offset   = bro (pointer);
	exp E1,E2,E3,E4,E5;
	shape pc_sh;
	
	/* access of a caller param. relative to an environment with variable? */
	
	if (! ((frame_al_of_ptr(sh(pointer)) & al_includes_vcallees) &&
		   (frame_al1_of_offset(sh(offset)) & al_includes_caller_args))) return;
	
	
	/*
	 *      exchange application pointer with callers pointer:
	 *
	 *      addptr(pointer, offset) --> addptr(pointer2, offset)
	 *      where pointer2 = reff(addptr(pointer, cont(reff(pointer, 8*8))), 12*8)
	 *
	 *
	 *                         addptr
	 *                           |
	 *                           |(son)   bro(son)
	 *                           |-------------|
	 *                     E5  reff(8*8)     offset
	 *                           |(son)
	 *                           |
	 *                     E4  addptr
	 *                           |(son)   bro(son)
	 *                           |----------|
	 *                        pointer  E3  cont
	 *                                      |(son)
	 *                                      |
	 *                                 E2  reff(12*8)
	 *                                      |(son)
	 *                                      |
	 *                                 E1  pointer (copy)
	 
	 
	*/
	
	pc_sh = f_pointer(f_callers_alignment(0));
	
	E1 = copyexp(pointer);
	E2 = getexp (pc_sh, 0, 0, E1, 0, 0, 8*8, reff_tag);
	E3 = getexp (pc_sh, 0, 0, E2, 0, 0, 0, cont_tag);
	E4 = getexp (pc_sh, 0, 0, pointer, 0, 0, 0, addptr_tag);
	E5 = getexp (pc_sh, 0, 0, E4, 0, 0, 12*8, reff_tag);
	son(addptr) = E5;
	
	/* Terminate each bro list */
	setfather (E2, E1);
	setfather (E3, E2);
	setfather (E4, E3);
	setfather (E5, E4);
	
	bro (pointer) = E3;
	bro (E5) = offset;
}

/************************************************************************
 *  Transforms an entire exp recursively.
 ************************************************************************/
static void
transform(exp e)
{
	exp s = son(e);
	
	/* Transform the children (if any) */
	if (s && (name(e) != name_tag) && (name(e) != env_offset_tag) && (name(e) != case_tag))
		for (; s && s!=e; s=bro(s)) {
			transform(s);
		}
	
	/* Transform this one */
	switch (name(e)) {
	case addptr_tag:
		fix_addptr(e);
		break;
	default:
		/* nothing to do */
		break;
	}
}

/************************************************************************
 *  Scan through the declarations and apply transform
 *  called from trans.
 ************************************************************************/
void
make_transformations()
{
	dec *d = top_def;
	
	while (d) {
		exp e = son (d->dec_u.dec_val.dec_exp);
		if (e) transform (e);
		d = d->def_next;
	}
}
/************************************************************************
 *  Make a label with:
 *  value: env_size (proc)
 *  name:  L<value of procedure declaration pointer)
 ************************************************************************/

void
output_env_size(dec* proc, long envsize)
{
	mach_op *op1, *op2;
	long offval;
	
	make_comment("env_size comes here:");
	op1 = make_lab_data ((long)proc, 0);
	op2 = make_int_data (envsize);
	make_instr_aux (m_as_assign, op1, op2, 0, 0);
}

