Logo Search packages:      
Sourcecode: tendra version File versions  Download package

coder.c

/*
             Crown Copyright (c) 1997

    This TenDRA(r) Computer Program is subject to Copyright
    owned by the United Kingdom Secretary of State for Defence
    acting through the Defence Evaluation and Research Agency
    (DERA).  It is made available to Recipients with a
    royalty-free licence for its use, reproduction, transfer
    to other parties and amendment for any purpose not excluding
    product development provided that any such use et cetera
    shall be deemed to be acceptance of the following conditions:-

        (1) Its Recipients shall ensure that this Notice is
        reproduced upon any copies or amended versions of it;

        (2) Any amended version of it shall be clearly marked to
        show both the nature of and the organisation responsible
        for the relevant amendment or amendments;

        (3) Its onward transfer from a recipient to another
        party shall be deemed to be that party's acceptance of
        these conditions;

        (4) DERA gives no warranty or assurance as to its
        quality or suitability for any purpose and DERA accepts
        no liability whatsoever in relation to any use to which
        it may be put.
*/
/*
                      VERSION INFORMATION
                      ===================

--------------------------------------------------------------------------
$Header: /u/g/release/CVSROOT/Source/src/installers/680x0/common/coder.c,v 1.1.1.1 1998/01/17 15:55:49 release Exp $
--------------------------------------------------------------------------
$Log: coder.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/13 08:27:10  ma
All avs test passed (except add_to_ptr).

Revision 1.3  1997/11/09 14:06:09  ma
Fixed AVS problems.

Revision 1.2  1997/10/29 10:22:06  ma
Replaced use_alloca with has_alloca.

Revision 1.1.1.1  1997/10/13 12:42:48  ma
First version.

Revision 1.8  1997/10/13 08:49:01  ma
Made all pl_tests for general proc & exception handling pass.

Revision 1.7  1997/09/25 06:44:52  ma
All general_proc tests passed

Revision 1.6  1997/06/24 10:55:57  ma
Added changes for "Plumhall Patch"

Revision 1.5  1997/06/18 12:04:49  ma
Merged with Input Baseline changes.

Revision 1.4  1997/06/18 10:09:23  ma
Checking in before merging with Input Baseline changes.

Revision 1.3  1997/04/20 11:30:19  ma
Introduced gcproc.c & general_proc.[ch].
Added cases for apply_general_proc next to apply_proc in all files.

Revision 1.2  1997/03/20 12:46:22  ma
Now tag ids are kept in unsigned chars (MAX tag id > 127).

Revision 1.1.1.1  1997/03/14 07:50:10  ma
Imported from DRA

 * Revision 1.1.1.1  1996/09/20  10:56:52  john
 *
 * Revision 1.4  1996/07/31  16:25:46  john
 * Changed alloca
 *
 * Revision 1.3  1996/07/30  16:30:43  john
 * Removed offset conversion
 *
 * Revision 1.2  1996/07/05  14:16:42  john
 * Changes for spec 3.1
 *
 * Revision 1.1.1.1  1996/03/26  15:45:09  john
 *
 * Revision 1.5  94/06/29  14:18:27  14:18:27  ra (Robert Andrews)
 * always_round_fl has changed its name.  Need to be slightly more careful
 * in a couple of places.
 *
 * Revision 1.4  94/02/21  15:56:25  15:56:25  ra (Robert Andrews)
 * A couple of flags which used to be bool are now int.
 *
 * Revision 1.3  93/11/19  16:15:49  16:15:49  ra (Robert Andrews)
 * Minor corrections to nof_tag and ncopies_tag cases.
 *
 * Revision 1.2  93/03/08  15:28:34  15:28:34  ra (Robert Andrews)
 * Procedures which take compound arguments and return a compound
 * result which is ignored were having their arguments put on the
 * stack in the wrong place.
 *
 * Revision 1.1  93/02/22  17:15:20  17:15:20  ra (Robert Andrews)
 * Initial revision
 *
--------------------------------------------------------------------------
*/


#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 "mach.h"
#include "mach_ins.h"
#include "mach_op.h"
#include "instr.h"
#include "installglob.h"
#include "codex.h"
#include "instrs.h"
#include "peephole.h"
#include "szs_als.h"
#include "tests.h"
#include "utility.h"
#include "weights.h"
#include "translate.h"
#include "ops_shared.h"
#include "general_proc.h"
#include "68k_globals.h"

#if have_diagnostics
#include "xdb_basics.h"
#endif

extern int do_peephole ;
extern int normal_version ;
static int extra_weight = 0 ;


/*
    ADD A SHAPE TO A THE STACK

    Given an ash p, representing the stack, and a shape s, this procedure
    returns the ast correponding to the new stack formed by adding s to the
    old stack.
*/

ast add_shape_to_stack
    PROTO_N ( ( p, s ) )
    PROTO_T ( ash p X shape s )
{
    ast res ;
    char n = name ( s ) ;
    long sz = shape_size ( s ) ;
    long adj = 0 ;
    if ( n == scharhd || n == ucharhd || n == swordhd || n == uwordhd ) {
      adj = SLONG_SZ - sz ;
      sz = SLONG_SZ ;
    }
    if ( n == bitfhd ) sz = SLONG_SZ ;
    res.astoff = round ( p, param_align ) ;
    res.astadj = adj ;
    res.astash = round ( res.astoff + sz, param_align ) ;
    return ( res ) ;
}


/*
    REGISTER ALLOCATION ROUTINES

    This routine tries to choose registers for a value of shape sha.  br
    gives the breakpoint - the minimum number of registers which need to
    be free for it to be worth putting this value in a register.  The big
    flag is true to indicate that a register which is preserved across
    procedure calls is required.  If a register can be allocated, then
    its bitpattern is returned.  Otherwise 0 is returned.
*/

static bitpattern alloc_reg
    PROTO_N ( ( sha, br, big ) )
    PROTO_T ( shape sha X int br X bool big )
{
    int go = 1 ;
    bitpattern mask ;
    bitpattern rs = regsinuse ;
    int i, start, end, rev = 0 ;

    int rg ;
    int r = shtype ( sha ) ;

    if ( r == Dreg ) {
      rg = bits_in ( ~rs & 0x00fc ) ;
      mask = regmsk ( REG_D2 ) ;
      start =  REG_D2 ;
      end = REG_D7 ;
    } else if ( r == Areg ) {
      rg = bits_in ( ~rs & 0x3c00 ) ;
      mask = regmsk ( REG_A2 ) ;
      start = REG_A2 ;
      end = REG_A5 ;
      if ( br > extra_weight ) br -= extra_weight ;
    } else if ( r == Freg ) {
      if ( round_after_flop ) return ( 0 ) ;
      rg = bits_in ( ~rs & 0xfc0000 ) ;
      mask = regmsk ( REG_FP7 ) ;
      start = REG_FP7 ;
      end = REG_FP2 ;
      rev = 1 ;
    } else {
      error ( "Illegal register type" ) ;
      return ( 0 ) ;
    }

    if ( rg < br || rg == 0 ) return ( 0 ) ;

    i = start ;
    while ( go ) {
      if ( !( rs & mask ) ) {
          if ( big ) {
            bigregs |= mask ;
            if ( r == Freg ) normal_version = 0 ;
          }
          regsinproc |= mask ;
          return ( mask ) ;
      }
      if ( i == end ) {
          go = 0 ;
      } else {
          if ( rev ) {
            i-- ;
            mask >>= 1 ;
          } else {
            i++ ;
            mask <<= 1 ;
          }
      }
    }
    return ( 0 ) ;
}


/*
    IS A GIVEN EXPRESSION A USE OF A REUSABLE REGISTER?

    This routine returns 0 if the expression e is not a use of a reuseable
    register, and the bitmask of the register otherwise.
*/

static long reuse_check
    PROTO_N ( ( e ) )
    PROTO_T ( exp e )
{
    exp id ;
    if ( name ( e ) != name_tag ) return ( 0 ) ;
    id = son ( e ) ;
    if ( isglob ( id ) || pt ( id ) != reg_pl ) return ( 0 ) ;
    return ( reuseables & no ( id ) ) ;
}


/*
    CAN WE REUSE A REGISTER?

    This routine checks whether or not we can use a reuseable register to
    store def.  It returns the bitmask of a suitable register if so and 0
    otherwise.
*/

static long reuse
    PROTO_N ( ( def ) )
    PROTO_T ( exp def )
{
    switch ( name ( def ) ) {

      case name_tag : {
          return ( reuse_check ( def ) ) ;
      }

      case plus_tag :
      case and_tag :
      case or_tag :
      case xor_tag :
      case mult_tag : {
          /* Allow at most two arguments - check both */
          exp arg1 = son ( def ) ;
          exp arg2 = bro ( arg1 ) ;
          if ( last ( arg1 ) ) {
            return ( reuse_check ( arg1 ) ) ;
          }
          if ( last ( arg2 ) ) {
            return ( reuse_check ( arg1 ) || reuse_check ( arg2 ) ) ;
          }
          return ( 0 ) ;
      }

      case chvar_tag :
      case neg_tag :
      case not_tag : {
          /* Check one argument */
          return ( reuse_check ( son ( def ) ) ) ;
      }

      case minus_tag :
      case subptr_tag :
      case minptr_tag :
      case shl_tag :
      case shr_tag : {
          /* Check two arguments */
          exp arg1 = son ( def ) ;
          exp arg2 = bro ( arg1 ) ;
          return ( reuse_check ( arg1 ) || reuse_check ( arg2 ) ) ;
      }
    }
    return ( 0 ) ;
}


/*
    IS AN EXPRESSION GUARANTEED NOT TO USE D0?

    Or if it is, are we really careful?
*/

static bool nouse
    PROTO_N ( ( e ) )
    PROTO_T ( exp e )
{
    char n = name ( e ) ;
    if ( n == test_tag ) return ( 1 ) ;
    return ( 0 ) ;
}


/*
    WHERE IS A DECLARATION TO BE PUT?

    The routine alloc_variable chooses where to put a declaration. e is the
    declaration, def is the definition (for identity) or initialisation
    (for variable), stack is the ash for the current stack position.
    The place field of the result indicates where the declaration should
    be put (reg_pl, var_pl etc. - see coder.h).  num gives the offset
    (for objects put on the stack) or register mask (for objects put into
    registers).  new_stack gives the ash of the stack after this declaration.
    is_new is a flag indicating a new declaration or a reuse of an old
    declaration.
*/

static allocation alloc_variable
    PROTO_N ( ( e, def, stack ) )
    PROTO_T ( exp e X exp def X ash stack )
{
    ast locast ;
    allocation dc ;
    bitpattern ru ;

    unsigned char n = name ( def ) ;
    exp s = son ( def ) ;
    exp body = bro ( def ) ;
    int br = ( int ) no ( e ) ;

    bool force_reg = isusereg ( e ) ;
    bool big = ( props ( e ) & 0x80 ? 1 : 0 ) ;
    bool in_reg1 = 0, in_reg2 = 0, in_reg3 = 1 ;

    dc.new_stack = stack ;
    dc.is_new = 1 ;

    if ( name ( sh ( def ) ) == tophd && !isvis(e)) {
      dc.place = nowhere_pl ;
      dc.num = 0 ;
      return ( dc ) ;
    }

    if ( n == name_tag ) {
      in_reg1 = ( !isvar ( s ) && ( no ( def ) == 0 || !isglob ( s ) ) ) ;
    } else if ( n == cont_tag && name ( s ) == name_tag ) {
      exp t = son ( s ) ;
      in_reg2 = ( isvar ( t ) && ( no ( s ) == 0 || !isglob ( t ) ) &&
                no_side ( body ) ) ;
    }

    if ( !isvar ( e ) && ( in_reg1 || in_reg2 ) ) {

      /* Re-identification or contents of variable not altered in body */
      if ( in_reg1 ) {
          dc.place = ptno ( s ) ;
#ifndef tdf3
            switch ( ptno (s) ) {
            case var_pl:
            dc.num = no ( s ) - no ( def ) ;
                break;

            case par3_pl:
            case par2_pl:
            dc.num = no ( s ) - no ( def ) ;
                break;

            default:
            dc.num = no ( s ) + no ( def ) ;
            }
#else
          if ( ptno ( s ) == var_pl ) {
            dc.num = no ( s ) - no ( def ) ;
          } else {
            dc.num = no ( s ) + no ( def ) ;
          }
#endif

      } else {
          s = son ( s ) ;
          dc.place = ptno ( s ) ;
          if ( ptno ( s ) == var_pl ) {
            dc.num = no ( s ) - no ( son ( def ) ) ;
          } else {
            dc.num = no ( s ) + no ( son ( def ) ) ;
          }
      }

      /* We have a declaration */
      if ( dc.place == reg_pl ) {
          /* If the old one was in registers, reuse it */
          dc.is_new = 0 ;
          return ( dc ) ;
      }

      if ( !force_reg ) {
          if ( regable ( e ) ) {
            ru = alloc_reg ( sh ( def ), br, big ) ;
            if ( ru ) {
                dc.place = reg_pl ;
                dc.num = ru ;
                return ( dc ) ;
            }
          }
          if ( isglob ( s ) ) {
            locast = add_shape_to_stack ( stack, sh ( def ) ) ;
            dc.new_stack = locast.astash ;
            dc.place = var_pl ;
            if ( locast.astadj ) {
                dc.num = locast.astoff + locast.astadj ;
            } else {
                dc.num = locast.astash ;
            }
            return ( dc ) ;
          }
          /* If there was not room, reuse the old dec */
          dc.is_new = 0 ;
          return ( dc ) ;
      }

      if ( regable ( e ) ) {
          ru = alloc_reg ( sh ( def ), br, big ) ;
          if ( ru ) {
            dc.place = reg_pl ;
            dc.num = ru ;
            return ( dc ) ;
          }
          if ( isglob ( s ) ) {
            locast = add_shape_to_stack ( stack, sh ( def ) ) ;
            dc.new_stack = locast.astash ;
            dc.place = var_pl ;
            if ( locast.astadj ) {
                dc.num = locast.astoff + locast.astadj ;
            } else {
                dc.num = locast.astash ;
            }
            return ( dc ) ;
          }
          dc.is_new = 0 ;
          return ( dc ) ;
      }
      return ( dc ) ;
    }

    if ( n == apply_tag || n == apply_general_tag || n == tail_call_tag )
    in_reg3 = result_in_reg ( sh ( def ) ) ;

    /* Try to allocate in registers */
    if ( regable ( e ) && in_reg3 ) {
      if ( ( n == apply_tag || n == apply_general_tag || n == tail_call_tag )
            && shtype ( sh ( def ) ) != Freg && nouse ( bro ( def ) ) ) {
          dc.place = reg_pl ;
          dc.num = regmsk ( REG_D0 ) ;
          return ( dc ) ;
      }
      if ( is_a ( n ) ) {
          long rg = reuse ( def ) & 0x3cfc ;
          if ( rg ) {
            reuseables &= ~rg ;
            dc.place = reg_pl ;
            dc.num = rg ;
            return ( dc ) ;
          }
      }
      ru = alloc_reg ( sh ( def ), br, big ) ;
      if ( ru ) {
          dc.place = reg_pl ;
          dc.num = ru ;
          return ( dc ) ;
      }
    }

    /* Otherwise allocate on the stack */
    locast = add_shape_to_stack ( stack, sh ( def ) ) ;
    dc.new_stack = locast.astash ;
    dc.place = var_pl ;
    if ( locast.astadj ) {
      dc.num = locast.astoff + locast.astadj ;
    } else {
      dc.num = locast.astash ;
    }
    return ( dc ) ;
}


/*
    CURRENT SCOPES

    These variables are used for the scope and destination of inlined
    procedures.
*/

static exp crt_rscope ;
static where rscope_dest ;




/*
    PUSH A SET OF PROCEDURE ARGUMENTS

    The arguments are given by a bro-list starting with t.  They are
    coded in reverse order.
*/

static void code_pars
    PROTO_N ( ( w, stack, t ) )
    PROTO_T ( where w X ash stack X exp t )
{
    long sz = shape_size ( sh ( t ) ) ;
    if ( last ( t ) ) {
      /* Code last argument */
      coder ( w, stack, t ) ;
      stack_dec -= round ( sz, param_align ) ;
    } else {
      /* Code the following arguments */
      code_pars ( w, stack, bro ( t ) ) ;
      /* And then this one */
      coder ( w, stack, t ) ;
      stack_dec -= round ( sz, param_align ) ;
    }
    return ;
}


/*
    PRODUCE CODE FOR A SOLVE STATEMENT

    The solve statement with starter s, labelled statements l, destination
    dest and default jump jr is processed.
*/

static void solve
    PROTO_N ( ( s, l, dest, jr, stack ) )
    PROTO_T ( exp s X exp l X where dest X exp jr X ash stack )
{
    exp t ;
    long r1 ;

    while ( !last ( l ) ) {
      allocation dc ;
      long lb = next_lab () ;
      exp record = simple_exp ( 0 ) ;
      if ( props ( son ( bro ( l ) ) ) & 2 ) setlast ( record ) ;
      no ( record ) = stack ;
      sonno ( record ) = stack_dec ;
      ptno ( record ) = lb ;
      pt ( son ( bro ( l ) ) ) = record ;
      dc = alloc_variable ( bro ( l ), son ( bro ( l ) ), stack ) ;
      ptno ( bro ( l ) ) = dc.place ;
      no ( bro ( l ) ) = dc.num ;
      l = bro ( l ) ;
    }

    r1 = regsinuse ;

    if ( name ( s ) != goto_tag || pt ( s ) != bro ( s ) ) {
      /* Code the starting expression */
      have_cond = 0 ;
      coder ( dest, stack, s ) ;
    }
    t = s ;

    do {
      regsinuse = r1 ;
      if ( name ( sh ( t ) ) != bothd ) make_jump ( m_bra, ptno ( jr ) ) ;
      t = bro ( t ) ;
      if ( no ( son ( t ) ) > 0 ) {
          make_label ( ptno ( pt ( son ( t ) ) ) ) ;
          coder ( dest, stack, t ) ;
      }
    } while ( !last ( t ) ) ;

    regsinuse = r1 ;
    have_cond = 0 ;
    return ;
}


/*
    PRODUCE CODE FOR A CASE STATEMENT

    The controlling number of the case statement is in the D1 register, from
    which already has been deducted.  The list of options is given as a
    bro-list in arg.  The routine returns the total number which has been
    deducted from D1 at the end.
*/
static long caser
    PROTO_N ( ( arg, already ) )
    PROTO_T ( exp arg X long already )
{
    bool sw, go = 1, diff = 0 ;
    exp t, jr, jt, split_at ;
    shape sha = sh ( arg ) ;
    double low, high ;
    double lowest = LONG_MAX, highest = LONG_MIN ;
    long i, j, n, *jtab ;
    long worth = 0 ;

    for ( t = bro ( arg ) ; go && ( t != nilexp ) ; t = bro ( t ) ) {
       if (is_signed(sh(t))) low = no (t) ;
       else low = (unsigned) no(t) ;
       if (son(t)) {
          if (is_signed(sh(son(t)))) high = no(son(t)) ;
          else high =(unsigned) no(son(t)) ;
       }
       else high = low ;

      if ( low != high ) diff = 1 ;
      if ( low < lowest ) lowest = low ;
      if ( high > highest ) highest = high ;
      worth += ( low == high ? 1 : 2 ) ;
      if ( bro ( t ) != nilexp ) {
           double nextlow;
           if (is_signed(sh(bro(t)))) nextlow = no(bro(t));
           else nextlow = (unsigned) no(bro(t));
          if ( ( nextlow / 2 ) > ( high / 2 ) + 20 ) {
            split_at = t ;
            go = 0 ;
          }
      }
#ifndef tdf3
        if (high/2 > low/2 + 20) {
           worth = 0 ;
        }
#endif
    }

    if ( !go ) {
      /* Split into two */
      long a ;
      exp new = copyexp ( arg ) ;
      exp old_bro = bro ( split_at ) ;
      bro ( new ) = old_bro ;
      bro ( split_at ) = nilexp ;
      setlast ( split_at ) ;
      /* Code the first half */
      a = caser ( arg, already ) ;

      /* Code the second half */
      return ( caser ( new, a ) ) ;
    }

    if ( worth > 2 ) {

      /* Construct a jump table */
      mach_op *op1, *op2 ;
      long rlab = next_lab () ;
      long tlab = next_lab () ;
      long slab = next_lab () ;
      n = highest - lowest + 1 ;
      jtab = ( long * ) xcalloc ( n, sizeof ( long ) ) ;

      for ( i = 0 ; i < n ; i++ ) jtab [i] = rlab ;

      for ( t = bro ( arg ) ; t != nilexp ; t = bro ( t ) ) {
           if (is_signed(sh(t))) low = no (t) ;
           else low = (unsigned) no(t) ;
           if (son(t)) {
              if (is_signed(sh(son(t)))) high = no(son(t)) ;
              else high =(unsigned) no(son(t)) ;
           }
           else high = low ;

           j = ptno ( pt ( son ( pt ( t ) ) ) ) ;
           for ( i = low ; i <= high ; i++ ) jtab [ i - (long)lowest ] = j ;
      }

      /* Move offset into D1 */
      jt = simple_exp ( 0 ) ;
      ptno ( jt ) = rlab ;
      /* Subtract the lowest value (minus anything already deducted) */
      sub ( slongsh, mnw ( lowest - already ), D1, D1 ) ;
      sw = cmp ( slongsh, D1, mnw ( highest - lowest ), tst_gr ) ;
      branch ( tst_gr, jt, 0, sw, 0 ) ;

      /* Move displacement into D0 */
#if 0
      op1 = make_reg_index ( REG_ZA0, REG_D1, 0, 4 ) ;
      op1->of->plus->plus = make_lab ( slab, 0 ) ;
      regsinproc |= regmsk ( REG_A0 ) ;
      debug_warning ( "%%za0 used" ) ;
#else
      op1 = make_lab_ind ( slab, 0 ) ;
      i = tmp_reg ( m_lea, op1 ) ;
      op1 = make_reg_index ( i, REG_D1, 0, 4 ) ;
#endif
      op2 = make_register ( REG_D0 ) ;
      make_instr ( m_movl, op1, op2, regmsk ( REG_D0 ) ) ;

      /* Do the jump */
      op1 = make_reg_index ( REG_PC, REG_D0, 2, 1 ) ;
      make_instr ( m_jmp, op1, null, 0 ) ;

      /* Print out table */
      make_label ( tlab ) ;
#ifndef no_align_directives
      make_instr ( m_as_align4, null, null, 0 ) ;
#endif
      make_label ( slab ) ;
      for ( i = 0 ; i < n ; i++ ) {
          op1 = make_lab_diff ( jtab [i], tlab ) ;
          make_instr ( m_as_long, op1, null, 0 ) ;
      }
      make_label ( rlab ) ;

      /* Return the total number deducted from D1 */
      return ( lowest ) ;
    }

    /* If 'high' is not always equal to 'low', restore value of D1 */
    if ( diff ) {
      add ( slongsh, D1, mnw ( already ), D1 ) ;
      already = 0 ;
    }

    /* A series of jumps/comparisons */
    for ( t = bro ( arg ) ; t != nilexp ; t = bro ( t ) ) {
       if (is_signed(sh(t))) low = no (t) ;
       else low = (unsigned) no(t) ;
       if (son(t)) {
          if (is_signed(sh(son(t)))) high = no(son(t)) ;
          else high =(unsigned) no(son(t)) ;
       }
       else high = low ;

      jr = pt ( son ( pt ( t ) ) ) ;
      if ( low == high ) {
          sw = cmp ( sha, D1, mnw ( low - already ), tst_eq ) ;
          branch ( tst_eq, jr, 1, sw, 0 ) ;
      } else {
          jt = simple_exp ( 0 ) ;
          ptno ( jt ) = next_lab () ;
          sw = cmp ( sha, D1, mnw ( low - already ), tst_ls ) ;
          branch ( tst_ls, jt, is_signed ( sh ( t ) ), sw, 0 ) ;
          sw = cmp ( sha, D1, mnw ( (unsigned)(high - already) ), tst_le ) ;
          branch ( tst_le, jr, is_signed ( sh ( son ( t ) ) ), sw, 0 ) ;
          make_label ( ptno ( jt ) ) ;
      }
    }
    /* Return what has been subtracted from D1 */
    have_cond = 0 ;
    return ( already ) ;
}

/*
    RESET STACK POINTER FROM APPLICATIONS POINTER
    sp = AP - (env_size - (sizeof(params) + sizeof(ret-addr) + sizeof(AP)))
*/

static void reset_stack_pointer
    PROTO_Z ()
{
    mach_op *op1, *op2, *op3 ;
    make_comment("reset stack pointer ...");
    update_stack () ;

    op1 = make_indirect ( REG_AP, 0 ) ;
    op2 = op1->of->plus = new_mach_op() ;
    op2->type = MACH_NEG ;
    op2->plus = make_ldisp(4);

    op2 = make_register ( REG_SP ) ;
    make_instr ( m_lea, op1, op2, regmsk ( REG_SP ) ) ;

#if 0
    /* gas misinterpret lea a6@( <label> ) if <label> isn't declared ?? */
    op1 = make_indirect ( REG_AP, 0 ) ;
    op2 = new_mach_op() ;
    op1->of->plus = op2 ;
    /* The address of cur_proc_dec is used to form the env_size label */
    op3 = make_lab ((long)cur_proc_dec,8+(cur_proc_callers_size+cur_proc_callees_size)/8);
    op2->type = MACH_NEG ;
    op2->plus = op3 ;
    op2 = make_register ( REG_SP ) ;
    make_instr ( m_lea, op1, op2, regmsk ( REG_SP ) ) ;
#endif
    make_comment("reset stack pointer done");
}

/*
    CHECK UP ON JUMPS

    This routine checks for jumps to immediately following labels.
*/

static bool red_jump
    PROTO_N ( ( e, la ) )
    PROTO_T ( exp e X exp la )
{
    if ( !last ( la ) && pt ( e ) == bro ( la ) ) return ( 1 ) ;
    return ( 0 ) ;
}


/*
    ALLOW SPACE ON STACK
*/

static ash stack_room
    PROTO_N ( ( stack, dest, off ) )
    PROTO_T ( ash stack X where dest X long off )
{
    exp e = dest.wh_exp ;
    if ( name ( e ) == ident_tag ) {
      if ( ptno ( e ) != var_pl ) return ( stack ) ;
      if ( no ( e ) + off > stack ) stack = no ( e ) + off ;
    }
    return ( stack ) ;
}


/*
    MAIN CODING ROUTINE

    This routine is the main coding routine for such things as identity
    definitions and control structures.  Most of the actual expression
    evaluation is dealt with by codec.  The expression e is coded and
    the result put into dest.  The stack argument gives the current
    structure of the stack.
*/

void coder
    PROTO_N ( ( dest, stack, e ) )
    PROTO_T ( where dest X ash stack X exp e )
{
    bool sw ;

    if ( e == nilexp ) {
      error ( "Internal coding error" ) ;
      return ;
    }

    switch ( name ( e ) ) {

      case ident_tag : {

          long sz ;
          int dw = 0 ;
          allocation dc ;
          bool used_once, used_twice ;
          bitpattern rg = regsinproc ;
          mach_ins *p = current_ins ;

          /* Find the identity definition and body */
          exp def = son ( e ) ;
          exp body = bro ( def ) ;

          /* Check up on uses */
          exp x = pt ( e ) ;
          used_once = ( x == nilexp || pt ( x ) == nilexp ) ;
          used_twice = ( used_once || pt ( pt ( x ) ) == nilexp ) ;

          /* Allocate space for definition */
          if ( ismarked ( e ) && isparam ( e ) &&  no ( e ) > 2 ) {
            /* Rarely used procedure arguments ... */
            dc.is_new = 0 ;
            dc.place = par_pl ;
            dc.num = no ( def ) ;
            dc.new_stack = stack ;
            extra_weight++ ;
            dw = 1 ;
          } else {
            /* And the rest ... */
            dc = alloc_variable ( e, def, stack ) ;
          }

          /* Mark the declaration */
          ptno ( e ) = dc.place ;
          no ( e ) = dc.num ;
#ifndef tdf3
            make_visible( e ) ;
#endif
          if ( dc.place == var_pl ) used_stack = 1 ;
          sz = dc.new_stack ;

          /* Does the definition need evaluating? */
          if ( dc.is_new ) {
            if ( ptno ( e ) == nowhere_pl ) {
                /* Calculate and discard value if not required */
                coder ( zero, stack, def ) ;
            } else {
                /* Encode the definition */
                if ( ptno ( e ) == reg_pl ) regsindec |= dc.num ;
                coder ( zw ( e ), stack, def ) ;
            }

            /* Modify regsinuse if a register is being used */
            if ( ptno ( e ) == reg_pl ) {
                regsindec &= ~dc.num ;
                if ( used_once ) {
                  regsinuse |= dc.num ;
                  reuseables |= dc.num ;
                } else {
                  regsinuse |= dc.num ;
                  reuseables &= ~dc.num ;
                }
            }

            /* Modify max_stack is the stack is being used */
            if ( ptno ( e ) == var_pl && sz > max_stack ) max_stack = sz ;
          }

          /* Encode the body */
          coder ( dest, dc.new_stack, body ) ;
          extra_weight -= dw ;

          /* Look for peephole optimizations */
          if ( dc.is_new && pt ( e ) == reg_pl ) {
            regsinuse &= ~dc.num ;
            if ( !output_immediately && p && do_peephole ) {
                if ( used_twice && post_inc_check ( p, no ( e ) ) ) {
                  regsinproc = rg ;
                  return ;
                }
            }
          }
          return ;
      }
#ifndef tdf3
#else
      case clear_tag : {
          /* Clear means do nothing */
          return ;
      }
#endif
      case seq_tag : {
          /* Sequences */
          bool no_bottom = 1 ;
          exp t = son ( son ( e ) ) ;
          /* Code each sub-expression */
          while ( coder ( zero, stack, t ),
                no_bottom = ( name ( sh ( t ) ) != bothd ),
                !last ( t ) ) t = bro ( t ) ;
          /* Code the result expression if necessary */
          if ( no_bottom ) coder ( dest, stack, bro ( son ( e ) ) ) ;
          return ;
      }

      case cond_tag : {
          /* Conditionals */
          long lb, r1 ;
          allocation dc ;
          exp jr, record ;
          bool is_condgoto = 0 ;

          /* Find the first and alternative expressions */
          exp first = son ( e ) ;
          exp alt = bro ( first ) ;

          /* Check for "if cond goto ..." */
          if ( name ( bro ( son ( alt ) ) ) == goto_tag ) is_condgoto = 1 ;

          /* Find or create the label */
          if ( is_condgoto ) {
            record = pt ( son ( pt ( bro ( son ( alt ) ) ) ) ) ;
          } else {
            lb = next_lab () ;
            record = simple_exp ( 0 ) ;
            no ( record ) = stack ;
            sonno ( record ) = stack_dec ;
            ptno ( record ) = lb ;
          }
          no(son(alt)) = ptno(record);
          pt ( son ( alt ) ) = record ;

          /* Allocate space for the alternative expression */
          dc = alloc_variable ( alt, son ( alt ), stack ) ;
          ptno ( alt ) = dc.place ;
          no ( alt ) = dc.num ;

          /* If first is just a jump to alt, just encode alt */
          if ( name ( first ) == goto_tag && pt ( first ) == alt &&
             son ( first ) != nilexp &&
             name ( sh ( son ( first ) ) ) == tophd ) {
            coder ( dest, stack, bro ( son ( alt ) ) ) ;
            return ;
          }

          /* Code the first expression */
          reuseables = 0 ;
          r1 = regsinuse ;
          coder ( dest, stack, first ) ;

          /* Restore regsinuse */
          regsinuse = r1 ;

          /* If alt is trivial, no further action is required */
          if ( name ( bro ( son ( alt ) ) ) == top_tag ) {
            bitpattern ch = last_jump_regs ;
            make_label ( ptno ( record ) ) ;
            if ( !is_condgoto && !output_immediately && last_jump == lb ) {
                current_ins->changed = ch ;
            }
            return ;
          }

          /* No further action is required for conditional gotos */
          if ( is_condgoto ) return ;

          /* If first doesn't end with a jump, add one */
          if ( name ( sh ( first ) ) != bothd ) {
            long lb2 = next_lab () ;
            jr = simple_exp ( 0 ) ;
            ptno ( jr ) = lb2 ;
            make_jump ( m_bra, lb2 ) ;
          }

          /* Encode the alternative expression */
          reuseables = 0 ;
          make_label ( ptno ( record ) ) ;
          coder ( dest, stack, alt ) ;
          regsinuse = r1 ;
          reuseables = 0 ;

          /* Output the label for the jump added to first if necessary */
          if ( name ( sh ( first ) ) != bothd ) {
            make_label ( ptno ( jr ) ) ;
            retcell ( jr ) ;
          }
          have_cond = 0 ;
          retcell ( record ) ;
          return ;
      }

      case labst_tag : {
          /* Labelled statements */
          allocation dc ;
          have_cond = 0 ;

            /* Is there long jump access to this label ? */
            if ( is_loaded_lv(e) ) {
               if ( need_preserve_stack )
                  restore_stack ();
               else if (!has_alloca)
                  reset_stack_pointer() ;
            };

          /* Allocate space */
          dc = alloc_variable ( e, son ( e ), stack ) ;
          if ( dc.place == reg_pl ) {
            regsinuse |= dc.num ;
            reuseables &= ~dc.num ;
          }

          /* Encode the body */
          coder ( dest, stack, bro ( son ( e ) ) ) ;

          /* Update max_stack and regsinuse */
          if ( dc.place == var_pl ) {
            if ( dc.new_stack > max_stack ) max_stack = dc.new_stack ;
          }
          if ( dc.place == reg_pl ) regsinuse &= ( ~dc.num ) ;
          return ;
      }

      case rep_tag : {
          /* Loops */
          long lb ;
          exp record ;
          allocation dc ;

          /* Find the starter and the body of the loop */
          exp start = son ( e ) ;
          exp body = bro ( start ) ;

          /* Allocate space */
          dc = alloc_variable ( body, son ( body ), stack ) ;
          ptno ( body ) = dc.place ;
          no ( body ) = dc.num ;

          /* Code the starter of the loop */
          coder ( zw ( body ), stack, start ) ;

          /* Create the repeat label */
          lb = next_lab () ;
          make_label ( lb ) ;
          record = simple_exp ( 0 ) ;
          setlast ( record ) ;
          no ( record ) = stack ;
          sonno ( record ) = stack_dec ;
          ptno ( record ) = lb ;
          pt ( son ( body ) ) = record ;
          reuseables = 0 ;

          /* Encode the body of the loop */
          coder ( dest, stack, body ) ;
          retcell ( record ) ;
          return ;
      }

      case goto_tag : {
        /* Jumps */
        exp lab ;

        /* Try to avoid unnecessary jumps */
        if ( last ( e ) && name ( bro ( e ) ) == seq_tag &&
             name ( bro ( bro ( e ) ) ) == labst_tag &&
             red_jump ( e, bro ( e ) ) ) return ;

        /* Output the jump */
        lab = pt ( e ) ;
        make_jump ( m_bra, ptno ( pt ( son ( lab ) ) ) ) ;
        reuseables = 0 ;
        return ;
      }

      case goto_lv_tag : {
        exp dest_exp = son(e); /* destination label */
        exp cont_exp = getexp(sh(dest_exp),nilexp,1,dest_exp,nilexp,0,0,
                        cont_tag);
        where wh;
        mach_op *op;
        wh = zw(cont_exp);
        wh.wh_is = RegInd;
        op = operand(32,wh);
        /*epilogue(1);*/
        make_instr(m_jmp,op,null,~save_msk);
        /*ins1(m_jmp,32,D0,0);*/
        return ;
      }
#ifndef tdf3
        case return_to_label_tag: {
           exp dest_lab = son(e);

           make_comment("return_to_label ...");

           move(slongsh, zw(dest_lab), A0);
           restore_regs(ALL);
           make_instr(m_jmp,operand(32,A0_p),null,~save_msk);

           make_comment("return_to_label done");
           return;
        };
#endif
      case long_jump_tag : {
        exp new_env = son(e);
        exp dest_lab = bro(new_env);
          make_comment("long_jump");

        move(sh(dest_lab),zw(dest_lab),A0);
        move(sh(new_env),zw(new_env),A1);

          /* restore all registers but A6 or SP */
          restore_regs(NOT_A6_OR_SP);

        move(sh(new_env),A1,AP);
        make_instr(m_jmp,operand(32,A0_p),null,~save_msk);
        return ;
      }
      case test_tag : {
          /* Tests */
          exp qwe ;
          where qw ;
          bool sg = 1, sf = 0 ;
            int shn ;

          /* Find the test number */
          long test_n = ( long ) props ( e ) ;

          /* Find the expressions being compared */
          exp arg1 = son ( e ) ;
          exp arg2 = bro ( arg1 ) ;

          /* Find the label to be jumped to */
          exp lab_exp = pt ( e ) ;
          exp jr = pt ( son ( lab_exp ) ) ;

          /* If arg1 is not an operand, code it into D1 */
          if ( !is_o ( name ( arg1 ) ) ) {
            qwe = sim_exp ( sh ( arg1 ), D1 ) ;
            qw = zw ( qwe ) ;
            regsinproc |= regmsk ( REG_D1 ) ;
            coder ( qw, stack, arg1 ) ;
            arg1 = qwe ;
          }

          /* If arg2 is not an operand, code it into D1 */
          if ( !is_o ( name ( arg2 ) ) ) {
            qwe = sim_exp ( sh ( arg2 ), D1 ) ;
            qw = zw ( qwe ) ;
            regsinproc |= regmsk ( REG_D1 ) ;
            coder ( qw, stack, arg2 ) ;
            arg2 = qwe ;
          }

          /* Look for unsigned or floating tests */
            shn = name ( sh ( arg1 ) ) ;

          switch ( shn ) {
              case ucharhd :
              case uwordhd :
              case ulonghd :
                case u64hd   :  sg = 0 ; break ;
            case shrealhd :
            case realhd :
            case doublehd : sg = 0 ; sf = 1 ; break ;
          }

          /* Certain comparisons with 1 or -1 can be changed */
          if ( name ( arg1 ) == val_tag ) {
            long d = no ( arg1 ) ;
            if ( is_offset ( arg1 ) ) d /= 8 ;
            if ( d == 1 ) {
                if ( test_n == tst_le ) {
                  /* 1 <= x becomes 0 < x */
                  test_n = tst_ls ;
                  no ( arg1 ) = 0 ;
                } else if ( test_n == tst_gr ) {
                  /* 1 > x becomes 0 >= x */
                  test_n = tst_ge ;
                  no ( arg1 ) = 0 ;
                }
            } else if ( d == -1 && sg ) {
                if ( test_n == tst_ls ) {
                  /* -1 < x becomes 0 <= x */
                  test_n = tst_le ;
                  no ( arg1 ) = 0 ;
                } else if ( test_n == tst_ge ) {
                  /* -1 >= x becomes 0 > x */
                  test_n = tst_gr ;
                  no ( arg1 ) = 0 ;
                }
            }
          }

          /* Certain other comparisons with 1 or -1 can be changed */
          if ( name ( arg2 ) == val_tag ) {
            long d = no ( arg2 ) ;
            if ( is_offset ( arg2 ) ) d /= 8 ;
            if ( d == 1 ) {
                if ( test_n == tst_ge ) {
                  /* x >= 1 becomes x > 0 */
                  test_n = tst_gr ;
                  no ( arg2 ) = 0 ;
                } else if ( test_n == tst_ls ) {
                  /* x < 1 becomes x <= 0 */
                  test_n = tst_le ;
                  no ( arg2 ) = 0 ;
                }
            } else if ( d == -1 && sg ) {
                if ( test_n == tst_gr ) {
                  /* x > -1 becomes x >= 0 */
                  test_n = tst_ge ;
                  no ( arg2 ) = 0 ;
                } else if ( test_n == tst_le ) {
                  /* x <= 1 becomes x < 0 */
                  test_n = tst_ls ;
                  no ( arg2 ) = 0 ;
                }
            }
          }
            if ( shn == u64hd || shn == s64hd ) {
            where w1, w2 ;
              w1 = zw ( arg1 ) ;
            w2 = zw ( arg2 ) ;

              /* compare low word (unsigned) */
              sw = cmp ( ulongsh, w1, w2, test_n ) ;
              branch ( test_n, jr, sg, sw, sf ) ;

              /* compare high word */
              w1.wh_off += 32 ;
              w2.wh_off += 32 ;
              if ( sg )
                sw = cmp ( slongsh, w1, w2, test_n ) ;
              else
                sw = cmp ( ulongsh, w1, w2, test_n ) ;
              branch ( test_n, jr, sg, sw, sf ) ;

              return ;
            }

          /* Code the comparison */
          sw = cmp ( sh ( arg1 ), zw ( arg1 ), zw ( arg2 ), test_n ) ;

          /* Output the condition jump */
          branch ( test_n, jr, sg, sw, sf ) ;
          return ;
      }

      case testbit_tag : {
          /* Bit tests */
          exp qwe ;
          where qw ;

          /* Find the arguments */
          exp arg1 = son ( e ) ;
          exp arg2 = bro ( arg1 ) ;

          /* Find the label to be jumped to */
          exp lab_exp = pt ( e ) ;
          exp jr = pt ( son ( lab_exp ) ) ;

          /* If arg1 is not an operand, code it into D1 */
          if ( !is_o ( name ( arg1 ) ) ) {
            qwe = sim_exp ( sh ( arg1 ), D1 ) ;
            qw = zw ( qwe ) ;
            regsinproc |= regmsk ( REG_D1 ) ;
            coder ( qw, stack, arg1 ) ;
            arg1 = qwe ;
          }

          /* If arg2 is not an operand, code it into D1 */
          if ( !is_o ( name( arg2 ) ) ) {
            qwe = sim_exp ( sh ( arg2 ), D1 ) ;
            qw = zw ( qwe ) ;
            regsinproc |= regmsk ( REG_D1 ) ;
            coder ( qw, stack, arg2 ) ;
            arg2 = qwe ;
          }

          /* Code the test */
          bit_test ( sh ( arg1 ), zw ( arg1 ), zw ( arg2 ) ) ;

          /* Output the conditional jump */
          branch ( ( long ) props ( e ), jr, 1, 0, 0 ) ;
          return ;
      }

      case ass_tag :
      case assvol_tag : {
          /* Variable assignments */
          exp assdest = son ( e ) ;
          exp assval = bro ( assdest ) ;
            make_comment("assign ...") ;
          if ( name ( sh ( assval ) ) == bitfhd ) {

            int_to_bitf ( assval, e, stack ) ;
            return ;
          }
          codec (zw ( e ), stack, assval ) ;
            make_comment("assign done") ;
          return ;
      }

      case nof_tag : {
          shape sha ;
          long crt, off ;
          exp v = son ( e ) ;

          if ( v == nilexp ) return ;
          if ( name ( dest.wh_exp ) == val_tag ) return ;

          sha = sh ( v ) ;
          crt = dest.wh_off ;
          off = rounder ( shape_size ( sha ), shape_align ( sha ) ) ;

          while ( 1 ) {
            where wh ;
            ash stack2 ;
            wh = mw ( dest.wh_exp, crt ) ;
            stack2 = stack_room ( stack, dest, off + crt ) ;
            coder ( wh, stack2, v ) ;
            if ( last ( v ) ) return ;
            crt += off ;
            v = bro ( v ) ;
          }
          /* Not reached */
      }

      case ncopies_tag : {
          where wh ;
          long n = no ( e ) ;
          shape sha = sh ( son ( e ) ) ;
          long sz = rounder ( shape_size ( sha ), shape_align ( sha ) ) ;
          if ( n == 0 ) return ;
          if ( name ( dest.wh_exp ) == val_tag ) return ;
          if ( n == 1 ) {
            coder ( dest, stack, son ( e ) ) ;
            return ;
          }
          if ( sz == 8 || sz == 16 || sz == 32 ) {
            coder ( D1, stack, son ( e ) ) ;
            regsinproc |= regmsk ( REG_D1 ) ;
            if ( n <= 10 ) {
                long i ;
                for ( i = 0 ; i < n ; i++ ) {
                  wh = mw ( dest.wh_exp, dest.wh_off + i * sz ) ;
                  move ( sha, D1, wh ) ;
                }
                return ;
            } else {
                mach_op *op1, *op2 ;
                long lab = next_lab () ;
                int instr = ins ( sz, ml_mov ) ;
                mova ( dest, A0 ) ;
                regsinproc |= regmsk ( REG_A0 ) ;
                move ( slongsh, mnw ( n - 1 ), D0 ) ;
                make_label ( lab ) ;
                op1 = make_register ( REG_D1 ) ;
                op2 = make_postinc ( REG_A0 ) ;
                make_instr ( instr, op1, op2, regmsk ( REG_A0 ) ) ;
                op1 = make_register ( REG_D0 ) ;
                op2 = make_lab_data ( lab, 0 ) ;
                make_instr ( m_dbf, op1, op2, regmsk ( REG_D0 ) ) ;
                return ;
            }
          }
          coder ( dest, stack, son ( e ) ) ;
          wh = mw ( dest.wh_exp, dest.wh_off + sz ) ;
          move_bytes ( sz * ( n - 1 ), dest, wh, 0 ) ;
          return ;
      }

      case concatnof_tag : {
          ash stack2 ;
          exp a1 = son ( e ) ;
          exp a2 = bro ( a1 ) ;
          long off = dest.wh_off + shape_size ( sh ( a1 ) ) ;
          coder ( dest, stack, a1 ) ;
          stack2 = stack_room ( stack, dest, off ) ;
          coder ( mw ( dest.wh_exp, off ), stack2, a2 ) ;
          return ;
      }

#ifndef tdf3
          case apply_tag :
          case apply_general_tag : {
             apply_general_proc(e, dest, stack);
             return;
          }

          case tail_call_tag : {
             int old_stack_dec = stack_dec;
             tail_call(e, dest, stack);
             stack_dec = old_stack_dec;
             return;
          }

          case caller_tag : {
             coder ( dest, stack, son ( e ) ) ;
             return;
          }
          case trap_tag: {
             trap_ins( no( e ) ) ;
             return;
          }
#endif
#if 0
      case apply_tag : {
          /* Procedure applications */
#ifndef tdf3
#else
          static int apply_tag_flag = 0 ;
#endif
          exp t ;
          ash st ;
          long comp_room = 0 ;
          long longs = 0, stkdec ;
          long start_stack = stack_dec ;
          bool use_push = 1, reg_res ;

          /* Find the procedure and the arguments */
          exp proc = son ( e ) ;
          exp arg = ( last ( proc ) ? nilexp : bro ( proc ) ) ;


#if 0
            /* not a normal procedure call, but a way to specify a debuger break point */
          if ((brog(son(proc))->dec_u.dec_val.processed) &&
              (brog(son(proc))->dec_u.dec_val.extnamed)  &&
              (!strcmp( brog(son(proc))->dec_u.dec_val.dec_id, "_TESTPOINT"))) {
               TESTPOINT();
               return;
            }
#endif

   make_comment("Call Normal Proc");
          /* See if we can push all the arguments */
          st = 0 ;
          if ( arg != nilexp ) {
            t = arg ;
            while ( t != nilexp ) {
                ast a ;
                    if ( cpd_param ( sh ( t ) ) ) use_push = 0 ;
                    if ((name(sh(t)) == s64hd) || (name(sh(t)) == u64hd)){
                      use_push = 0;
                    }
                    if ( !push_arg ( t ) ) use_push = 0 ;
                a = add_shape_to_stack ( st, sh ( t ) ) ;
                st = a.astash ;

                t = ( last ( t ) ? nilexp : bro ( t ) ) ;
            }
          }
          longs = st ;

          /* Does the result go into a register? */
          reg_res = result_in_reg ( sh ( e ) ) ;
          if ( !reg_res ) {
            if ( eq_where ( dest, zero ) ) {
                /* Calculate room for ignored compound result */
/* todo: use symbol instead of 32 */
                comp_room = round ( shape_size ( sh ( e ) ), 32 ) ;
            }
          }

          /* Find total amount of stack decrease */
          stkdec = longs + comp_room ;

          /* Put arguments onto stack */
          if ( use_push ) {
              make_comment("Push callers");
            if ( comp_room ) {
                /* Make room for unwanted compound result */
                dec_stack ( comp_room ) ;
                stack_dec -= comp_room ;
            }
            /* Push the arguments */
            if ( arg != nilexp ) code_pars ( zw ( e ), stack, arg ) ;
          } else {
              make_comment("Place callers");
            /* Decrease stack */
            if ( stkdec ) dec_stack ( stkdec ) ;
            stack_dec -= stkdec ;
            /* Indicate recursive calls */
            apply_tag_flag++ ;
            /* Encode the arguments onto the stack */
            st = 0 ;
            t = arg ;
            while ( t != nilexp ) {
                ast a ;
                where stp ;
                long adj = 0 ;
                char nc = name ( sh ( t ) ) ;
                if ( nc == scharhd || nc == ucharhd ) adj = 24 ;
                if ( nc == swordhd || nc == uwordhd ) adj = 16 ;
                stp = mw ( SP_p.wh_exp, st + adj ) ;
                coder ( stp, stack, t ) ;
                a = add_shape_to_stack ( st, sh ( t ) ) ;
                st = a.astash ;
                t = ( last ( t ) ? nilexp : bro ( t ) ) ;
            }
            apply_tag_flag-- ;
          }
          start_stack -= stack_dec ;

          /* For results which do not fit into registers a pointer to
             where the result is to be put is passed in in A1 */
          if ( !reg_res ) {
            if ( comp_room ) {
                /* Find the space allocated for unwanted results */
                where w ;
                w = mnw ( longs / 8 ) ;
                add ( slongsh, SP, w, A1 ) ;
            } else {
                /* Find the address of where the result is to be put */
                tmp_reg_prefer = REG_A1 ;
                if ( apply_tag_flag ) {
                  /* For recursive calls we need to be very careful
                     if the result is itself to be a procedure argument
                     to get the right stack offset. */
                  long ex = extra_stack ;
                  long doff = dest.wh_off ;
                  extra_stack += start_stack ;
                  dest.wh_off = 0 ;
                  if ( eq_where ( dest, SP_p ) ) {
                      /* Careful! */
                      dest.wh_off = doff + extra_stack ;
                      mova ( dest, A1 ) ;
                      dest.wh_off = doff ;
                  } else {
                      /* Easy */
                      dest.wh_off = doff ;
                      mova ( dest, A1 ) ;
                  }
                  extra_stack = ex ;
                } else {
                  /* Otherwise (easy) ... */
                  mova ( dest, A1 ) ;
                }
            }
            /* Make sure we don't reuse A1 accidently */
            avoid_tmp_reg ( REG_A1 ) ;
            regsinproc |= regmsk ( REG_A1 ) ;
          }

          /* Output the call instruction */
          callins ( longs, son ( e ) ) ;
          stack_dec += stkdec ;
          have_cond = 0 ;

          /* Throw away unwanted compound result */
          if ( comp_room ) {
            dec_stack ( -comp_room ) ;
            return ;
          }

          /* Throw away unwanted simple result */
          if ( eq_where ( dest, zero ) ) return ;

          /* Now move the result into place */
          if ( reg_res ) {
            if ( shape_size ( sh ( e ) ) <= 32 ) {
                /* Small register results are in D0 */
                move ( sh ( e ), D0, dest ) ;
                return ;
            } else {
                /* Larger register results are in D0 and D1 */
#ifdef SYSV_ABI
                move ( sh ( e ), FP0, dest ) ;
#else
                move ( sh ( e ), D0_D1, dest ) ;
                regsinproc |= regmsk ( REG_D1 ) ;
#endif
                return ;
            }
          } else {
            /* 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
            return ;
          }
      }
#endif
      case alloca_tag : {
          /* Local memory allocation */
          exp s = son ( e ) ;
            where size_w ;
            bool allocation_done = 0 ;
          used_stack = 1 ;

            make_comment("Allocate ...") ;

            /* Create a where representing the value to be allocated */

          if ( name ( s ) == val_tag ) {
              long off = no ( s ) ;
              if ( ! is_offset ( s ) ) off *= 8 ;
              off = rounder(off, stack_align) ;

              if ( checkalloc(e)) {
                 size_w = mw(zeroe, off / 8);
              }
              else {
                 /* simple allocation of constant */
                 dec_stack ( off ) ;
                 allocation_done = 1 ;
              }
          }
            else {
               size_w = zw(s) ;
            }

            /* Allocate (checked or not) */

            if ( ! allocation_done )
            if (checkalloc(e)) checkalloc_stack (size_w, 1) ;
            else sub ( slongsh, size_w, SP, SP ) ;

          /* The result of the construct is SP */

          if ( !eq_where ( dest, zero ) ) move ( sh ( e ), SP, dest ) ;

          have_cond = 0 ;

            if (need_preserve_stack) save_stack ();

            make_comment("Allocate done") ;
          return ;
      }

      case last_local_tag : {
           make_comment("last_local ...");
           move ( sh ( e ), SP, dest ) ;
           make_comment("last_local done");
           return ;
      }

      case local_free_tag : {
        exp base = son(e);
        exp offset = bro(base);
        exp s_a0 = sim_exp(sh(base),A0);
        where w_a0;
        w_a0 = zw(s_a0);

          make_comment("local_free ...");

        coder(w_a0,stack,base);

        if(name(offset) == val_tag) {
            long off = no ( offset ) ;
            where size_w ;

            if ( ! is_offset ( offset ) ) off *= 8 ;
            off = rounder(off, stack_align) / 8 ;
            size_w = mw(zeroe, off);
          add(sh(offset),A0,zw(offset),SP);
        }
        else {
          exp s_d0 = sim_exp(sh(offset),D0);
          where w_d0;
          w_d0 = zw(s_d0);
          coder(w_d0,stack,offset);
          add(sh(offset),mnw(7),D0,D0);
          and(sh(offset),D0,mnw(~7),D0);
          add(sh(offset),A0,D0,SP);
        }

          if (need_preserve_stack)
        save_stack ();

          make_comment("local_free done");

        return ;
      }

      case local_free_all_tag : {
           mach_op *op1, *op2 ;
           must_use_bp = 1 ;
           make_comment("local_free_all ...");
           reset_stack_pointer();
           if (need_preserve_stack)
           save_stack ();
           make_comment("local_free_all done");
           return ;
      }

#ifndef tdf3
        case untidy_return_tag :
#endif
      case res_tag : {
          /* Procedure results */
          have_cond = 0 ;

          /* Has the procedure been inlined? */
          if ( crt_rscope == 0 ) {

            /* Non-inlined procedures */
            shape rsha = sh ( son ( e ) ) ;

            /* Does the result go into a register? */
            if ( result_in_reg ( rsha ) ) {
                if ( shape_size ( rsha ) <= 32 ) {
                  /* Small register results go into D0 */
                  coder ( D0, stack, son ( e ) ) ;
                } else {
#ifdef SYSV_ABI
                  coder ( FP0, stack, son ( e ) ) ;
#else
                  /* Larger register results go into D0 and D1 */
                  coder ( D0_D1, stack, son ( e ) ) ;
                  regsinproc |= regmsk ( REG_D1 ) ;
#endif
                }
                /* Jump to the return label */
                if ( name ( rsha ) != bothd ) {
#ifndef tdf3
                       if ( name ( e ) == untidy_return_tag ) {
                          untidy_return() ;
                       }
                       else
#endif
                  make_jump ( m_bra, crt_ret_lab ) ;
                }
                return ;
            }

            /* Otherwise the result has to be encoded into the
               position pointed to by A1 at the start of the procedure.
               This value was stored in A6_4.  The value of this
               pointer is returned in D0. */
            if (   name ( son ( e ) ) == apply_tag
                    || name ( son ( e ) ) == apply_general_tag ) {
                coder ( A6_4_p, stack, son ( e ) ) ;
            } else {
                codec ( A6_4_p, stack, son ( e ) ) ;
            }
#ifdef SYSV_ABI
            move ( slongsh, A6_4, A1 ) ;
#else
            move ( slongsh, A6_4, D0 ) ;
#endif
            regsinproc |= regmsk ( REG_A1 ) ;
#ifndef tdf3
                if ( name ( e ) == untidy_return_tag ) {
                   untidy_return() ;
                }
                else
#endif
            make_jump ( m_bra, crt_ret_lab ) ;
            return ;

          } else {
            /* For inlined procedures, the result goes into rscope_dest
               and a jump is made to crt_rscope */
            coder ( rscope_dest, stack, son ( e ) ) ;
#ifndef tdf3
                if ( name ( e ) == untidy_return_tag ) {
                   untidy_return() ;
                }
                else
#endif
            make_jump ( m_bra, ptno ( crt_rscope ) ) ;
            return ;
          }
      }

#ifdef rscope_tag
      case rscope_tag : {
          /* Procedure scopes */
          exp record ;
          where old_rscope_dest ;
          exp old_rscope = crt_rscope ;
          old_rscope_dest = rscope_dest ;

          /* Check for inlined procedures */
          if ( last ( e ) && ( name ( bro ( e ) ) == proc_tag
                                || name ( bro ( e ) ) == general_proc_tag ) ) {
            /* Non-inlined procedures are simple */
            crt_rscope = 0 ;
            coder ( zero, stack, son ( e ) ) ;
          } else {
            /* This is an inlined procedure */
            long lb = next_lab () ;
            record = simple_exp ( 0 ) ;
            ptno ( record ) = lb ;
            crt_rscope = record ;
            rscope_dest = dest ;
            coder ( zero, stack, son ( e ) ) ;
            make_label ( lb ) ;
            retcell ( record ) ;
          }

          /* Restore the previous scopes */
          rscope_dest = old_rscope_dest ;
          crt_rscope = old_rscope ;
          return ;
      }
#endif

      case solve_tag : {
          /* Solve statements */
          long lb = next_lab () ;
          exp jr = simple_exp ( 0 ) ;
          ptno ( jr ) = lb ;
          solve ( son ( e ), son ( e ), dest, jr, stack ) ;
          make_label ( lb ) ;
          retcell ( jr ) ;
          return ;
      }

      case case_tag : {
          /* Case statements */
          exp d1 ;
          where w1 ;
          bool old_D1_sp = D1_is_special ;
          exp arg1 = son ( e ) ;
          exp t = arg1 ;

          /* Mark the end of the cases */
          while ( !last ( t ) ) t = bro ( t ) ;
          bro ( t ) = nilexp ;

          d1 = sim_exp ( sh ( arg1 ), D1 ) ;
          w1 = zw ( d1 ) ;
          D1_is_special = 1 ;
          regsinproc |= regmsk ( REG_D1 ) ;
          coder ( w1, stack, arg1 ) ;

          change_var_sh ( slongsh, sh ( arg1 ), w1, D1 ) ;
          D1_is_special = old_D1_sp ;

          /* Output the case statement */
          ( void ) caser ( arg1, L0 ) ;

          retcell ( d1 ) ;
          return ;
      }

      case movecont_tag : {
        /* This is done by a library call to memmove */
        exp from_exp = son(e);
        exp to_exp = bro(from_exp);
        exp num_bytes = bro(to_exp);
#if defined(SUN)
          mach_op *op = make_extern_ind("_bcopy",0);
#else
          mach_op *op = make_extern_ind("_memmove",0);
#endif
          make_comment("move_some ...");
        push(slongsh,L32,D0);
        push(slongsh,L32,D1);
        push(slongsh,L32,zw(num_bytes));
#if defined(SUN)
        push(slongsh,L32,zw(to_exp));
        push(slongsh,L32,zw(from_exp));
#else
        push(slongsh,L32,zw(from_exp));
        push(slongsh,L32,zw(to_exp));
#endif
        make_instr(m_call,op,null,0);
        dec_stack(-96);
        pop(slongsh,L32,D1);
        pop(slongsh,L32,D0);
          make_comment("move_some done");
        return ;
      }

      case diagnose_tag : {
#if have_diagnostics
          diag_start ( dno ( e ), e ) ;
          coder ( dest, stack, son ( e ) ) ;
          diag_end ( dno ( e ), e ) ;
#else
          coder ( dest, stack, son ( e ) ) ;
#endif
          return ;
      }
      case prof_tag :{
        return;
      }

      default :  {
          if ( !is_a ( name ( e ) ) ) {
            error ( "Bad operation" ) ;
            return ;
          }
          if ( name ( dest.wh_exp ) != val_tag){
               /* All other cases are passed to codec */
               codec ( dest, stack, e ) ;
               return ;
          }
          else if (!optop(e)){
               /* An operation with an error jump must always be performed,
                  even if the result is discarded.  */
               codec (zero,stack,e);
               return ;
          }
      }
    }
}

Generated by  Doxygen 1.6.0   Back to index