/*FORMIPS.c zilla 17apr - mips foreign function, c portion. c.f. MIPSASM.s
 *
 * !! this file gets INCLUDED in forfunc.c !!
 * modified
 * 22sep
 *
 * MIPS argument passing behavior:  char,short are always passed as
 * 32bit ints regardless of whether prototypes are in use.
 * Floats are returned as floats rather than doubles if ansi or -prototypes(?).
 * Floats are passed as floats rather than doubles if -prototypes,
 * or if -ansi and the function is written in prototype form.
 * Thus,
 *   void sub(float);
 *   sub(f) float f; {...
 * will receive a float under non-ansi C, but a double under ansi!; 
 *   sub(float f) {..
 * will receive a float in either case.
 *
 * "F" foreign arguments are passed double; declare float arguments as "f".
 *
 * If float (not double) stops working, be sure code is compiled
 * with ansi or -prototypes.
 *
 * Approach of this code: C code assembles a mirror of the registers/
 * floating registers/stack in normal C data structures FA_*;
 * an assembler subroutine then copies these onto the actual registers&c.
 *
 * From David Frederick, thefred@csd.sgi.com:

An aside:  The stack pointer is *always* double word aligned.
No exceptions.

Passing Arguments:

General registers $4..$7 and floating point registers $f12 and $f14
pass the first few arguments in registers.  Double precision floating-point
arguments are passed in the register pairs $f12,$f13 and $f14,$f15;
single precision floating point arguments are passed in registers $f12 and
$f14.

In determining which register, if any, an argument goes into, take into
account the following considerations:
        1) All integer-valued arguments are passed as 32-bit words,
        with signed or unsigned bytes and halfwords expanded (promoted)
        as necessare.

        2) If the called function returns a structure or union, the caller
        passes the address of an area that is large enough to hold the
        structure in $4.    The called function copies the returned structure
        into this area before it returns.  This address becomes the first
        argument to the function for the purposes of argument register
        allocation and all user arguments are shifted down by one.

        3) Despite the fact that some or all arguments are passed in
        registers, always allocate space on the stack for all arguments.
        This stack space should be a a structure large enough to
        contain all the arguments, aligned according to normal structure
        rules (after promotion and structure return pointer insertion).
        The locations within the stack frame used for arguments are
        called the ``home locations.''

        4) Arguments declared in variable argument lists, for instance those
        defined with a va_list declaration, are passed in the integer
        registers if possible.  This is true even if the arguments are
        floating-point values.  (For known varargs functions, current code
        generation puts the initial fp values in *both* regular and
        fp registers).

        5) When the first argument is integral, the remaining arguments
        are passed in the integral registers.

        6) Structures are passed as if they were very wide integers with
        their size rounded up to an integral number of words.  The fill
        bits necessary for rounding up are undefined.

        A structure can be split so a portion is passed in registers and
        the remainder passed on the stack.  In this case, the first
        words are passed in $4,$5,$6,$7 as neede with additional words
        passed on the stack.

        7) Unions are considered structures.

The rules that determine which arguments go into registers and which ones
must be passed on the stack are most easily explained by considering the list
of arguments as a structure, aligned according to normal structure rules.
Mapping of this structure into the combination of stack and registers is as
follows: uop to two leading floating-point (but not va_alist) arguments
can be passed in $f12 and $f14.  Everything else with a structure offset
greater than or equal to 16 is passed on the stack.  The remainder of the
arguments are passed in $4..$7 based on their struture offset.  Holes
left in the structure for alignment are unused, whether in registers or
on the stack.

The following examples give a representative sampling of the mix of
registes and stack used for passing arguments, where d represents
double-precision floating-point values, s represents single-precision
floating-point values, and n represents integers or pointers. The
list is not exhaustive.


Argument List                   Register and stack assignments
-------------                   -----------------------------
d1,d2                           $f12,$f14
s1,s2                           $f12,$f14
s1,d1                           $f12,$f14
d1,s1                           $f12,$f14
n1,n2,n3,n4                     $4,$5,$6,$7
d1,n1,d2                        $f12,$6,stack
d1,n1,n2                        $f12,$6,$7
s1,n1,n2                        $f12,$5,$6
n1,n2,n3,d1                     $4,$5,$6,stack
n1,n2,n3,s1                     $4,$5,$6,$7
n1,n2,d1                        $4,$5,($6,$7)
n1,d1                           $4,($6,$7)
s1,s2,s3,s4                     $f12,$f14,$6,$7
s1,n1,s2,n2                     $f12,$5,$6,$7
d1,s1,s2                        $f12,$f14,$6
s1,s1,d1                        $f12,$f14,($6,$7)
n1,s1,n2,s2                     $4,$5,$6,$7
n1,s1,n2,n3                     $4,$5,$6,$7
n1,n2,s1,n3                     $4,$5,$6,$7


Function Return Values:

A function can return no value, an integral or pointer value, a
floating-point value, or a structure; unions are treated the same
as structures.

A function that returns no value puts no particular value in any
register.

A function that returns an integral or pointer value puts its
result in register $2.

A function that returns a floating point value returns its value
in register $f0.  Floating-point registers can hold single or
double precision values.

The caller to a function the returns a structure or union passes the
address of an area large enough to hold the area (passes it in $4).
Before the function returns to its caller, it will copy the return
structure to the area in memory pointed to by $4.  The function will
also return a pointer to the returned structure in $2.  Having the
caller supply the return object's space allows reentrancy.

 */


#include <theusual.h>
#include <assert.h>
#include <scheme.h>
#include <zelk.h>


/* FA_MAX is max # of foreign args, counting a double as 2 args.
 * Stack pointer is always double aligned, so this must be EVEN.
 * arg0..3 -> $4..$7
 * arg4         16($sp)
 * arg5         20($sp)
 * argn         (16+4*(n-4))($sp)
 * possibly the longest foreign function currently:
 *(PN3init seed amp pd ncl npt saxis verbose):
  r0    seed    ;offset 0..3 words in registers
  r2,3  amp     
  s4,5  polyd   ;offset >=4 on stack
  s6,7  ncells
  s8    npts
  s9    symaxis
  s10   verbose
*/
#define FA_MAX 12        /* 40($sp) */

#define FA_FLT  13
#define FA_DBL  14      /* argument type code: double, 8bytes */
#define FA_INT  15      /* int,long,char,short,pointer */

/* these globals do not prevent reentrancy-they all get copied to the stack.
 * scheme->c->scheme calling sequences have not arisen yet anyway.
 */
int FA_soff;            /* stack offset, in words not bytes */
int FA_typ0;            /* type of arg0 */
int FA_reg[4];          /* contents of $4..$7 */
int FA_stk[FA_MAX];     /* stack */
double FA_d1,FA_d2;     /* $f12,$f14 */
/* not used float  FA_f1,FA_f2;     /+ $f12,$f14 */

double FA_drtn;         /* returned double */
float  FA_frtn;         /* returned float */
int FA_irtn;            /* returned integer */

/* provide a correct prototype for the assembler routine */
Object ZLforcall2 P_((function *));

#ifdef GENASM
/* assembling this gives ALMOST the code we need */
Object ZLforcall2(func)
  function *func;
{
  FA_drtn = (*func)(FA_d1,FA_reg[2],FA_reg[3],
      FA_stk[4],FA_stk[5],FA_stk[6],FA_stk[7],FA_stk[8],FA_stk[9],
                    FA_stk[10],FA_stk[11]);
}
#else  /*!GENASM*/

/*forward*/ static void FA_put Zproto((int,int,int,double));

static void
FA_put(iarg,typ,I,D)
  int iarg,typ;
  int I;
  double D;
{
  char *argerr = "foreign args overran stack (use fewer args)";
# define CHKSTK \
  if (FA_soff >= FA_MAX) Primitive_Error(argerr);

  CHKSTK
  if (iarg==0) FA_typ0 = typ;

  if (typ==FA_DBL) {

    if (iarg == 0) {    /* leading float goes in $f12 */
      FA_d1 = D;
      FA_soff += 2;
      Ztrace(("d1\n"));
    }

    /* 2 leading floats go in $f12 and $f14 */
    else if ((iarg == 1) &&
             ((FA_typ0 == FA_DBL) || (FA_typ0 == FA_FLT))) { 
      FA_d2 = D;
      FA_soff += 2;
      Ztrace(("d2\n"));
    }

    /* int,[int],float, put in registers 6,7 */
    else if (FA_soff <= 2) {
      if (FA_soff==1) FA_soff++;
      FA_reg[2] = *((long *)(&D));
      FA_reg[3] = *((long *)(&D)+1);
      FA_soff += 2;
      Ztrace(("dbl->[r2,r3] i.e. r6,7\n"));
    } /*iarg==1*/

    /* remaining args on stack */
    else {
      if ((FA_soff%2) != 0) FA_soff++;  /* double align */
      CHKSTK
      FA_stk[FA_soff] = *((long *)(&D));
      FA_stk[FA_soff+1] = *((long *)(&D)+1);
      Ztrace(("dbl -> s:%d,%d\n",FA_soff,FA_soff+1));
      FA_soff += 2;
    } /*dbl on stk*/

  }/*typ==DBL*/


  else if (typ==FA_FLT) {

    if (iarg == 0) {    /* leading float goes in $f12 */
      long *adr = (long *)&FA_d1;
      float f = (float)D;
      *(adr+1) = *(long *)&f; 
      FA_soff ++;
      Ztrace(("f1\n"));
    }

    /* 2 leading floats go in $f12 and $f14 */
    else if ((iarg == 1) &&
             ((FA_typ0 == FA_DBL) || (FA_typ0 == FA_FLT)))
    {
      long *adr = (long *)&FA_d2;
      float f = (float)D;
      *(adr+1) = *(long *)&f; 
      FA_soff ++;
      Ztrace(("f2\n"));
    }

    /* int,[int],float, put in register 5..7 */
    else if (FA_soff < 4) {
      float f = (float)D;
      FA_reg[FA_soff] = *((long *)(&f));
      Ztrace(("f->[r%d]\n",FA_soff));
      FA_soff ++;
    } /*iarg==1*/

    /* remaining args on stack */
    else {
      float f = (float)D;
      CHKSTK
      FA_stk[FA_soff] = *((long *)(&f));
      Ztrace(("flt -> s[%d]\n",FA_soff));
      FA_soff ++;
    } /*flt on stk*/

  }/*typ==FLT*/

  else {        /* typ==INT */
    /* first 4 in registers */
    if (FA_soff < 4) {
      FA_reg[FA_soff] = I;
      Ztrace(("int -> r:%d\n",FA_soff));
      FA_soff ++;
    }
    /* remainder on stack */
    else {
      FA_stk[FA_soff] = I;
      Ztrace(("int -> s:%d\n",FA_soff));
      FA_soff ++;
    }
  } /*typ==INT*/

} /*FA_put*/


Object ZLforcall(name,func,proto,ac,av)
  char *name;
  function *func;
  unsigned char *proto;
  int ac;
  Object *av;
{
  int i;
  Object arg;
  bool err;
  int4 tmp;
  double dtmp;
  char *cs,*ds;
  int j;

# define strheapsize 1024  
  char strheap[strheapsize];
  char *strptr = strheap;

  int padding[512];	      /* superstitous? make sure enough stack space */

  Error_Tag = name;

  if (ForeignTracep)
    printf("%s(%s) #args=%d\n",name,ZLforproto(proto),ac);
  else
    Ztrace(("Zforfuncall %s(%s) ac=%d\n",name,ZLforproto(proto),ac));

  if (ac > FA_MAX) Primitive_Error("exceeds max #args of foreign function");

    /* loop: check argument types, convert int<->flt, stack args.
     * DO NOT DECLARE LOCAL VARIABLES IN BLOCKS BELOW
     * ALSO DO NOT CALL ANY SUBROUTINES
     * variables could occupy the same stack space where
     * the callees frame is being setup (this happened during debugging,
     * see the NONO comment below.
     * ALSO, cannot call any subroutines in this loop, because they
     * may well write over the sp+x44 outparameter assembly area.
     * OR, if calling a subroutine, save this area, and restore it
     * afterwards!
     * NOTE this code depends on T_Returns < T_Ends!!
     */

  err = FALSE;
  FA_soff = 0;
  for( i=0; i < ac; i++ ) {

    if (!proto || (*proto >= T_Returns)) /* too many arguments given */
      { err = TRUE; break; }

    arg = av[i];        /* get supplied argument */

    if ((TYPE(arg)==*proto) || ((TYPE(arg)==T_Bignum) && (*proto==T_Fixnum)))
    {

      /* T_Farray is not a constant, so it is not part of switch below */
      if (*proto == T_Farray) 
        FA_put(i,FA_INT,(long)(FARRAY(arg)->data),0);

      else switch(*proto) {

      case T_Flonum:
        /****NO****[double d;]****NO****/
        dtmp = (double)FLONUM(arg)->val;
        FA_put(i,FA_FLT,0,dtmp);
        break;

      case T_Fixnum:
        FA_put(i,FA_INT,Get_Integer(arg),0);
        break;

      case T_Boolean: 
        FA_put(i,FA_INT,(arg == True) ? 1 : 0,0);
        break;

      case T_String:
        /* elk does not null-terminate strings on its heap,
         * so we must create a null-terminated copy, without
         * calling any subroutines.
         */
        if ((strptr + STRING(arg)->size) >= (strheap+strheapsize))
          Primitive_Error("string heap is full");
        for( cs=STRING(arg)->data,ds=strptr,j=STRING(arg)->size; j; j-- )
          *ds++ = *cs++;
        *ds = (char)0;
        FA_put(i,FA_INT,(long)strptr,0);
        strptr += (STRING(arg)->size + 1);
        break;

      case T_Port:
        FA_put(i,FA_INT,(long)PORT(arg)->file,0);
        break;

      default:
        Primitive_Error("bad type");
        break;

      } /*switch*/
    } /* TYPE(arg)==*proto */


 /* int<->flt type conversion */
    else {
      if ((*proto == T_Flonum)
          && ((TYPE(arg)==T_Fixnum) || (TYPE(arg)==T_Bignum)))
      {
        dtmp = (double)Get_Integer(arg);
        FA_put(i,FA_FLT,0,dtmp);
      }
# ifdef T_Double
      if (*proto == T_Double) {
        if ((TYPE(arg)==T_Fixnum) || (TYPE(arg)==T_Bignum)) {
          dtmp = (double)Get_Integer(arg);
          FA_put(i,FA_DBL,0,dtmp);
        }
        else if (TYPE(arg)==T_Flonum) {
          dtmp = FLONUM(arg)->val;
          FA_put(i,FA_DBL,0,dtmp);
        }
        else {
          err = TRUE; break;
        }
      }
# endif
      else if ((*proto == T_Fixnum) && (TYPE(arg)==T_Flonum)) {
        tmp = (int)(double)FLONUM(arg)->val;
        FA_put(i,FA_INT,tmp,0);
      }
      else {
        printf("proto=%d, TYPE(arg)=%d\n",*proto,TYPE(arg)); fflush(stdout);
        err = TRUE; break;
      }
    } /*convert type*/

    proto++;
  } /*argstackloop*/


  if (err || (proto && (*proto < T_Returns))) {
    printf("(...%s): ",ZLforproto(proto)); /*&HERE*/
    Primitive_Error("incorrect arguments");
  }

  ZLforcall2(func);
  Ztrace(("--ZLforfcall2 rtns(%d %f)\n",FA_irtn,FA_drtn));

  if (*proto++ == T_Returns) {
    Ztrace(("returning..."));

    if (*proto == T_Boolean) {
      Ztrace(("returning boolean %d\n",FA_irtn));
      return( FA_irtn ? True : False );
    }

    else if (*proto == T_Fixnum) {
      Ztrace(("returning int %d\n",FA_irtn));
      return(Make_Integer(FA_irtn));
    }

    else if (*proto == T_String) {
      if (FA_irtn == 0) return(Null);
      /* note elk does not null-terminate strings on its heap */
      return(Make_String((char *)FA_irtn, str_len((char *)FA_irtn)));
    }

    else if (*proto == T_Flonum) {
      Ztrace(("returning float %f\n",FA_frtn));
      return Make_Reduced_Flonum( FA_frtn );
    }

    else if (*proto == T_Double) {
      Ztrace(("returning double %f\n",FA_drtn));
      return Make_Reduced_Flonum( FA_drtn );
    }

    else if (*proto == T_Port) {
      FILE *f = (FILE *)FA_irtn;
      return Make_Port( (f->_flag&_IOREAD) ? P_INPUT : 0,
                       f, Make_String("foreign-port",12));
    }

    else Primitive_Error("bad return spec.");
  } /*get return value*/

  return Null;
} /*ZLforcall*/

#endif /*!GENASM*/
