Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] View of /sml/trunk/src/runtime/c-libs/smlnj-ccalls/c-calls.c
ViewVC logotype

View of /sml/trunk/src/runtime/c-libs/smlnj-ccalls/c-calls.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 107 - (download) (as text) (annotate)
Thu May 28 21:30:17 1998 UTC (22 years, 2 months ago) by monnier
File size: 28804 byte(s)
This commit was generated by cvs2svn to compensate for changes in r106,
which included commits to RCS files with non-trunk default branches.
/* c-calls.c
 *
 * COPYRIGHT (c) 1995 by AT&T Bell Laboratories.
 *
 * C-side support for calling user C functions from SML/NJ.
 *
 */

#include <string.h>
#include "ml-base.h"
#include "ml-values.h"
#include "ml-objects.h"
#if defined(INDIRECT_CFUNC) 
#  include "c-library.h"
#endif
#include "ml-c.h"
#include "c-calls.h"


/* assumptions:
 *
 *     Word_t fits in a machine word
 *
 *     restrictions:
 *	   C function args must fit in Word_t
 *         C's double is the largest return value from a function 
 */

ml_val_t	dummyRoot = ML_unit;  /* empty root for GC */

/* visible_msp used to expose msp to C code */
ml_state_t	*visible_msp = NULL;

#define CONS_SZB (3*WORD_SZB)     /* desc + car + cdr */
#define CADDR_SZB (2*WORD_SZB)    /* string desc + ptr */

#define MK_SOME(msp,v) recAlloc1(msp,v)

#define NULLARY_DATACON  INT_CtoML(0)

/* this map must correspond to the layout of the type cdata and ctype
   datatypes defined in ML_FILES
*/

#define MLADDR_CODE          '@'
#define MLARRAY_CODE         'A'
#define MLCHAR_CODE          'C'
#define MLDOUBLE_CODE        'D'
#define MLFLOAT_CODE         'R'
#define MLFUNCTION_CODE      'F'
#define MLINT_CODE           'I'
#define MLLONG_CODE          'L'
#define MLPTR_CODE           'P'
#define MLSHORT_CODE         'i'
#define MLSTRING_CODE        'S'
#define MLOPENSTRUCT_CODE    '('
#define MLCLOSESTRUCT_CODE   ')'
#define MLOPENUNION_CODE     '<'
#define MLCLOSEUNION_CODE    '>'
#define MLVECTOR_CODE        'B'
#define MLVOID_CODE          'V'
#define MLPAD_CODE           '#'

#define MLSTRUCT_CODE MLOPENSTRUCT_CODE
#define MLUNION_CODE  MLOPENUNION_CODE


/* this enumeration must match the sml/nj tags on the cdata datatype */
/* see c-calls.sml */

#define MLADDR_TAG      0
#define MLARRAY_TAG     1
#define MLCHAR_TAG      2
#define MLDOUBLE_TAG    3
#define MLFLOAT_TAG     4
#define MLFUNCTION_TAG  5
#define MLINT_TAG       6
#define MLLONG_TAG      7
#define MLPTR_TAG       8
#define MLSHORT_TAG     9
#define MLSTRING_TAG    10
#define MLSTRUCT_TAG    11
#define MLUNION_TAG     12
#define MLVECTOR_TAG     13
/* #define MLVOID_TAG   not used  */

/* map from datatype tags to single char descriptor (aka code) */
char typeMap[] = {MLADDR_CODE,
		  MLARRAY_CODE,
		  MLCHAR_CODE,
		  MLDOUBLE_CODE,
		  MLFLOAT_CODE,
		  MLFUNCTION_CODE,
		  MLINT_CODE,
		  MLLONG_CODE,
		  MLPTR_CODE,
		  MLSHORT_CODE,
		  MLSTRING_CODE,
		  MLSTRUCT_CODE,
		  MLUNION_CODE,
		  MLVECTOR_CODE,
		  MLVOID_CODE};

/* utility functions */

#define CHAR_RANGE 255   /* must agree with CharRange in c-calls.sml */

PVT int extractUnsigned(unsigned char **s,int bytes)
{
    int r = 0;
    
    while (bytes--)
	r = r * CHAR_RANGE + (int) *((*s)++) - 1;
    return r;
}



/* could (should) use stdlib's strdup instead of this */
PVT char *mk_strcpy(char *s)
{
    char *p;

    if ((p = (char *) MALLOC(strlen(s)+1)) == NULL)
	Die("couldn't make string copy during C call\n");
    return strcpy(p,s);
}

Word_t *checked_memalign(int n,int align)
{
    Word_t *p;

    if (align < sizeof(Word_t))
	align = sizeof(Word_t);
    if ((p = (Word_t *)MALLOC(n)) == NULL)
	Die("couldn't alloc memory for C call\n");

    ASSERT(((Word_t)p & (Word_t)(align-1)) != 0);

    return p;
}

PVT ml_val_t recAlloc1(ml_state_t *msp,ml_val_t v)
{
    ml_val_t ret;

    REC_ALLOC1(msp,ret,v);
    return ret;
}

PVT ml_val_t mkWord32(ml_state_t *msp, Word_t p)
{
    ML_AllocWrite(msp, 0, MAKE_DESC(sizeof(Word_t), DTAG_string));
    ML_AllocWrite(msp, 1, (ml_val_t)p);
    return ML_Alloc(msp, sizeof(Word_t));
}

PVT Word_t getWord32(ml_val_t v)
{
    return (Word_t) REC_SEL(v,0);
}

#define MK_CADDR(msp,p) mkWord32(msp,(Word_t) (p))
#define GET_CADDR(v)    (Word_t *)getWord32(v)

PVT ml_val_t double_CtoML(ml_state_t *msp,double g)
{
    ml_val_t res;

#ifdef DEBUG_C_CALLS
SayDebug("double_CtoML: building an ML double %l.15f\n", g);
#endif
    /* Force REALD_SZB alignment */
    msp->ml_allocPtr = (ml_val_t *)((Addr_t)(msp->ml_allocPtr) | WORD_SZB);
    ML_AllocWrite(msp,0,DESC_reald);
    res = ML_Alloc(msp,(sizeof(double)>>2));
    memcpy (res, &g, sizeof(double));
    return res;
}

/* ptrs to storage alloc'd by the interface. */
typedef struct ptr_desc {
    Word_t *ptr;
    struct ptr_desc *next;
} ptrlist_t;

PVT ptrlist_t *ptrlist = NULL;

#ifdef DEBUG_C_CALLS
PVT int ptrlist_len()
{
    int i = 0;
    ptrlist_t *p = ptrlist;

    while (p != NULL) {
	i++;
	p = p->next;
    }
    return i;
}
#endif
    
    
PVT void keep_ptr(Word_t *p)
{
    ptrlist_t *q = (ptrlist_t *) checked_alloc(sizeof(ptrlist_t));

#ifdef DEBUG_C_CALLS
    SayDebug("keeping ptr %x, |ptrlist|=%d\n", p, ptrlist_len());
#endif

    q->ptr = p;
    q->next = ptrlist;
    ptrlist = q;
}

PVT void free_ptrlist()
{
    ptrlist_t *p;

#ifdef DEBUG_C_CALLS
    SayDebug("freeing ptr list, |ptrlist|=%d\n",ptrlist_len());
#endif
    p = ptrlist;
    while (p != NULL) {
	ptrlist = ptrlist->next;
	FREE(p->ptr);               /* the block */
	FREE(p);                    /* the block's descriptor */
	p = ptrlist;
    }
}

PVT ml_val_t ptrlist_to_MLlist(ml_state_t *msp)
{
    ml_val_t lp = LIST_nil;
    ml_val_t v;
    ptrlist_t *p;

#ifdef DEBUG_C_CALLS
    int i = 0;
    SayDebug("converting ptrlist (|ptrlist|=%d) to ML list ",ptrlist_len());
#endif
    p = ptrlist;
    while (p != NULL) {
#ifdef DEBUG_C_CALLS
	i++;
#endif
	ptrlist = p->next;
	v = MK_CADDR(msp,p->ptr);
	LIST_cons(msp, lp, v, lp);
	FREE(p);
	p = ptrlist;
    }
#ifdef DEBUG_C_CALLS
    SayDebug("of length %d\n", i);
#endif
    return lp;
}

/* return the number of bytes the ptrlist will occupy in the ML heap */
PVT int ptrlist_space()
{
    int n = 0;
    ptrlist_t *p;

    p = ptrlist;
    while (p != NULL) {
	p = p->next;
	n += CONS_SZB + CADDR_SZB;
    }
#ifdef DEBUG_C_CALLS
    SayDebug("space for ptrlist is %d, |ptrlist|=%d\n",n,ptrlist_len());
#endif
    return n;
}

PVT void save_ptrlist(ptrlist_t **save)
{
#ifdef DEBUG_C_CALLS
    SayDebug("saving ptrlist, |ptrlist|=%d\n", ptrlist_len());
#endif
    *save = ptrlist;
    ptrlist = NULL;
}

PVT void restore_ptrlist(ptrlist_t *save)
{
    ptrlist = save;
#ifdef DEBUG_C_CALLS
    SayDebug("restoring ptrlist, |ptrlist|=%d\n", ptrlist_len());
#endif
}

ml_val_t revMLList(ml_val_t l,ml_val_t r)
{
    if (l == LIST_nil)
	return r;
    else {
	ml_val_t tmp = LIST_tl(l);

	LIST_tl(l) = r;
	return revMLList(tmp,l);
    }
}

	
#define SMALL_SPACE 0    /* size to 'NeedGC' for a small obj, say <10 words */

PVT void spaceCheck(ml_state_t *msp, int bytes, ml_val_t *one_root)
{
    /* assume the ONE_K buffer will absorb descriptors, '\0' terminators */
    if (NeedGC(msp,bytes + ONE_K)) {
#ifdef DEBUG_C_CALLS
SayDebug("spaceCheck: invoking GC\n");
#endif
	InvokeGCWithRoots(msp,0,one_root,NIL(ml_val_t *));
	if (NeedGC(msp,bytes + ONE_K))
	    Error("spaceCheck: cannot alloc ML space for ML-C conversion\n");
    }
}


/* interface functions */

PVT char *too_many_args = "c-calls with more than 15 args not supported\n";

/* call_word_fn
 * used when the return type fits into a machine word (Word_t)
 */
PVT Word_t call_word_fn(Word_t (*f)(),int n,Word_t *args)
{
    Word_t ret = 0;

    switch(n) {
      case 0: 
	ret = (*f)();
	break;
      case 1:
	ret = (*f)(args[0]);
	break;
      case 2:
	ret = (*f)(args[0],args[1]);
	break;
      case 3:
	ret = (*f)(args[0],args[1],args[2]);
	break;
      case 4:
	ret = (*f)(args[0],args[1],args[2],args[3]);
	break;
      case 5:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4]);
	break;
      case 6:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5]);
	break;
      case 7:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5],args[6]);
	break;
      case 8:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5],args[6],args[7]);
	break;
      case 9:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5],args[6],args[7],args[8]);
	break;
      case 10:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5],args[6],args[7],args[8],args[9]);
	break;
      case 11:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5],args[6],args[7],args[8],args[9],
		   args[10]);
	break;
      case 12:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5],args[6],args[7],args[8],args[9],
		   args[10],args[11]);
	break;
      case 13:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5],args[6],args[7],args[8],args[9],
		   args[10],args[11],args[12]);
	break;
      case 14:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5],args[6],args[7],args[8],args[9],
		   args[10],args[11],args[12],args[13]);
	break;
      case 15:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5],args[6],args[7],args[8],args[9],
		   args[10],args[11],args[12],args[13],args[14]);
	break;
      default:
	/* shouldn't happen; ML side assures this */
	Error(too_many_args);
    }

#ifdef DEBUG_C_CALLS
    SayDebug("call_word_fn: return=0x%x\n",ret);
#endif
    return ret;
}    

/* call_double_fn
 */
PVT double call_double_fn(double (*f)(),int n,Word_t *args)
{
    double ret;

    switch(n) {
      case 0: 
	ret = (*f)();
	break;
      case 1:
	ret = (*f)(args[0]);
	break;
      case 2:
	ret = (*f)(args[0],args[1]);
	break;
      case 3:
	ret = (*f)(args[0],args[1],args[2]);
	break;
      case 4:
	ret = (*f)(args[0],args[1],args[2],args[3]);
	break;
      case 5:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4]);
	break;
      case 6:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5]);
	break;
      case 7:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5],args[6]);
	break;
      case 8:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5],args[6],args[7]);
	break;
      case 9:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5],args[6],args[7],args[8]);
	break;
      case 10:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5],args[6],args[7],args[8],args[9]);
	break;
      default:
	/* shouldn't happen; ML side assures this */
	Error(too_many_args);
    }
    return ret;
}    

/* call_float_fn
 */
PVT float call_float_fn(float (*f)(),int n,Word_t *args)
{
    float ret;

    switch(n) {
      case 0: 
	ret = (*f)();
	break;
      case 1:
	ret = (*f)(args[0]);
	break;
      case 2:
	ret = (*f)(args[0],args[1]);
	break;
      case 3:
	ret = (*f)(args[0],args[1],args[2]);
	break;
      case 4:
	ret = (*f)(args[0],args[1],args[2],args[3]);
	break;
      case 5:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4]);
	break;
      case 6:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5]);
	break;
      case 7:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5],args[6]);
	break;
      case 8:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5],args[6],args[7]);
	break;
      case 9:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5],args[6],args[7],args[8]);
	break;
      case 10:
	ret = (*f)(args[0],args[1],args[2],args[3],args[4],
		   args[5],args[6],args[7],args[8],args[9]);
	break;
      default:
	/* shouldn't happen; ML side assures this */
	Error(too_many_args);
    }
    return ret;
}    

/* error handling */

#define NO_ERR                   0
#define ERR_TYPEMISMATCH         1
#define ERR_EMPTY_AGGREGATE      2
#define ERR_SZ_MISMATCH    3
#define ERR_WRONG_ARG_COUNT      4
#define ERR_TOO_MANY_ARGS        5

PVT char *errtbl[] = {
    "no error",
    "type mismatch",
    "empty aggregate",
    "array/vector size does not match registered size",
    "wrong number of args in C call",
    "current max of 10 args to C fn",
    };

PVT char errbuf[100];

PVT ml_val_t RaiseError(ml_state_t *msp,int err)
{
    sprintf(errbuf,"SML/NJ-C-Interface: %s",errtbl[err]);
    return RAISE_ERROR(msp, errbuf);
}


/* char *nextdatum(char *t)
 *
 * must match typeToCtl in c-calls.sml
 */
PVT char *nextdatum(char *t)
{
    int level = 0;

    do {
	switch(*t) {
	  case MLFUNCTION_CODE: {
	      int nargs, i;

	      t++;   /* skip code */
	      nargs = extractUnsigned((unsigned char **)&t,1);
	      /* skip arg types AND return type */
	      for (i = 0; i < nargs+1; i++) {
		  t = nextdatum(t);
	      }
	    }
	    break;
	  case MLPTR_CODE:
	    /* can fall through as long as Cptr has 4 bytes of sz info */
	  case MLARRAY_CODE:
	  case MLVECTOR_CODE:
	    t = nextdatum(t+5);    /* skip 4 bytes of sz info & code */
	    break;
	  case MLOPENUNION_CODE:
	    t++;                   /* skip 1 byte of sz info ; fall through */
	  case MLOPENSTRUCT_CODE:
	    t++;                   /* skip code */
	    level++;
	    break;
	  case MLCLOSEUNION_CODE:
	  case MLCLOSESTRUCT_CODE:
	    t++;                   /* skip code */
	    level--;
	    break;
	  case MLINT_CODE:
	  case MLSHORT_CODE:
	  case MLLONG_CODE:
	    /* skip 1 byte of size; fall through */
	    t++;
	  default:
	    t++;                   /* skip simple type */
	    break;
	}
    } while (level);
    return t;
}

PVT void mkCint(Word_t src,Word_t **dst,int bytes)
{
#ifdef DEBUG_C_CALLS
    SayDebug("mkCint: placing integer into %d bytes at %x\n", bytes, *dst);
#endif

#ifdef BYTE_ORDER_BIG
    src <<= (sizeof(Word_t) - bytes)*8;
#endif
    memcpy (*dst, &src, bytes);
    (*(Byte_t **)dst) += bytes;
}

PVT void mkMLint(Word_t **src,Word_t *dst,int bytes)
{
#ifdef DEBUG_C_CALLS
    SayDebug("mkMLint: reading integer from %x into %d bytes\n", *src, bytes);
#endif
    
    memcpy (dst, *src, bytes);
#ifdef BYTE_ORDER_BIG
    *dst >>= (sizeof(Word_t) - bytes)*8;
#endif
    *(Byte_t **)src += bytes;
}


#define DO_PAD(p,t)         (*(Byte_t **)(p) += extractUnsigned((unsigned char **)(t),1))
#define IF_PAD_DO_PAD(p,t)  {if (**t == MLPAD_CODE) {++(*t); DO_PAD(p,t);}}

int datumMLtoC(ml_state_t *msp,char **t,Word_t **p,ml_val_t datum)
{
    int tag = REC_SELINT(datum,0);
    ml_val_t val = REC_SEL(datum,1);
    int err = NO_ERR;
    int sz = 0;

    while (**t == MLPAD_CODE) {
	++(*t);  /* advance past code */
#ifdef DEBUG_C_CALLS
	SayDebug("datumMLtoC: adding pad from %x ", *p);
#endif
	DO_PAD(p,t);
#ifdef DEBUG_C_CALLS
	SayDebug(" to %x\n", *p);
#endif
    }
    if (typeMap[tag] != **t) {
#ifdef DEBUG_C_CALLS
       SayDebug("datumMLtoC: type mismatch %c != %d\n",**t,tag);
#endif
	return ERR_TYPEMISMATCH;
    }
    switch(*(*t)++) {
      case MLFUNCTION_CODE: {
	  char *argtypes[N_ARGS], *rettype;
	  char *this_arg, *next_arg;
	  int nargs, len, i;

	  nargs = extractUnsigned((unsigned char **)t,1);
#ifdef DEBUG_C_CALLS
	  SayDebug("datumMLtoC: function with %d args\n", nargs);
#endif
	  this_arg = *t;
	  for (i = 0; i < nargs; i++) {
	      next_arg = nextdatum(this_arg);
	      len = next_arg - this_arg;
	      argtypes[i] = (char *)checked_alloc(len+1);  /* len plus null */
	      strncpy(argtypes[i],this_arg,len);
	      argtypes[i][len] = '\0';
	      this_arg = next_arg;
#ifdef DEBUG_C_CALLS
	      SayDebug("datumMLtoC: function arg[%d] is \"%s\"\n", 
		     i,argtypes[i]);
#endif
	  }
	  /* get the return type */
	  next_arg = nextdatum(this_arg);
	  len = next_arg - this_arg;
	  rettype = (char *)checked_alloc(len+1);  /* len plus null */
	  strncpy(rettype,this_arg,len);
	  rettype[len] = '\0';
#ifdef DEBUG_C_CALLS
	  SayDebug("datumMLtoC: function returns \"%s\"\n", 
		 rettype);
#endif
	  *t = next_arg;
	  *(*p)++ = mk_C_function(msp,val,nargs,argtypes,rettype);
#ifdef DEBUG_C_CALLS
	  SayDebug("datumMLtoC: made C function\n");
#endif
        }
        break;
      case MLPTR_CODE: {
	  int szb, align;
	  Word_t *q;

	  szb = extractUnsigned((unsigned char **)t,4);
	  align = extractUnsigned((unsigned char **)t,1);
#ifdef DEBUG_C_CALLS
	  SayDebug("datumMLtoC: ptr szb=%d, align=%d\n", szb, align);
#endif
	  q = checked_memalign(szb,align);
	  keep_ptr(q);
	  *(*p)++ = (Word_t) q;
#ifdef DEBUG_C_CALLS
	  SayDebug("datumMLtoC: ptr substructure at %x\n", q);
#endif
	  if (err = datumMLtoC(msp,t,&q,val))
	      return err;
        }
	break;
      case MLCHAR_CODE:
	*(*(Byte_t **)p)++ = (Byte_t) INT_MLtoC(val);
	break;
      case MLFLOAT_CODE: 
	sz = sizeof(float);
	/* fall through */
      case MLDOUBLE_CODE: {
	  double g;

	  if (!sz) {
	      /* came in through MLDOUBLE_CODE */
	      sz = sizeof(double);
	  }
	  memcpy (&g, (Word_t *)val, sizeof(double));
#ifdef DEBUG_C_CALLS
SayDebug("datumMLtoC: ML real %l.15f:%l.15f %.15f\n", *(double *)val, g, (float) g);
#endif
	  if (sz == sizeof(float))
	      *(*(float **)p)++ = (float) g;
	  else
	      *(*(double **)p)++ = g;
        }
	break;
      case MLINT_CODE:
      case MLSHORT_CODE:
      case MLLONG_CODE:
#ifdef DEBUG_C_CALLS
	SayDebug("datumMLtoC: integer %d\n", getWord32(val));
#endif
	mkCint(getWord32(val),p,extractUnsigned((unsigned char **)t,1));
	break;
      case MLADDR_CODE:
#ifdef DEBUG_C_CALLS
       SayDebug("datumMLtoC: addr %x\n", GET_CADDR(val));
#endif
	*(*p)++ = (Word_t) GET_CADDR(val);
	break;
      case MLSTRING_CODE: {
	  char *r, *s;

	  s = PTR_MLtoC(char,val);
#ifdef DEBUG_C_CALLS
	  SayDebug("datumMLtoC: string \"%s\"\n",s);
#endif
	  r = (char *) checked_alloc(strlen(s)+1);
	  strcpy(r,s);
	  keep_ptr((Word_t *) r);
	  *(*p)++ =  (Word_t) r;
#ifdef DEBUG_C_CALLS
	  SayDebug("datumMLtoC: copied string \"%s\"=%x\n",r,r);
#endif
        }
	break;
      case MLOPENSTRUCT_CODE: {
	  ml_val_t lp = val;
	  ml_val_t hd;

#ifdef DEBUG_C_CALLS
	  SayDebug("datumMLtoC: struct\n");
#endif
	  while (**t != MLCLOSESTRUCT_CODE) {
	      hd = LIST_hd(lp);
	      if (err = datumMLtoC(msp,t,p,hd))
		  return err;
	      lp = LIST_tl(lp);
	      IF_PAD_DO_PAD(p,t);
	  }
	  (*t)++;  /* advance past MLCLOSESTRUCT_CODE */
        }
	break;
      case MLOPENUNION_CODE: {
	  Byte_t *init_p = (Byte_t *) *p;
	  char *next_try;

	  sz = extractUnsigned((unsigned char **)t,1);
#ifdef DEBUG_C_CALLS
	  SayDebug("datumMLtoC: union of size %d\n", sz);
#endif
	  if ((**t) == MLCLOSEUNION_CODE)
	      return ERR_EMPTY_AGGREGATE;
	  next_try = nextdatum(*t);
	  /* try union types until one matches or all fail */
	  while ((err = datumMLtoC(msp,t,p,val)) == ERR_TYPEMISMATCH) {
	      *t = next_try;
	      if ((**t) == MLCLOSEUNION_CODE) {
		  err = ERR_TYPEMISMATCH;
		  break;
	      }
	      next_try = nextdatum(*t);
	      *p = (Word_t *) init_p;
	  }
	  if (err)
	      return err;
	  while (**t != MLCLOSEUNION_CODE)
	      *t = nextdatum(*t);
	  (*t)++; /* advance past MLCLOSEUNION_CODE */
	  *p = (Word_t *) (init_p + sz);
        }
	break;
      case MLARRAY_CODE: 
      case MLVECTOR_CODE: {
	  int nelems,elem_sz, i;
	  char *saved_t;

	  nelems = extractUnsigned((unsigned char **)t,2);
	  elem_sz = extractUnsigned((unsigned char **)t,2);
#ifdef DEBUG_C_CALLS
	 SayDebug("datumMLtoC: array/vector of %d elems of size %d\n", 
		nelems, elem_sz);
#endif
	  i = sz = OBJ_LEN(val);
#ifdef DEBUG_C_CALLS
	  SayDebug("datumMLtoC: array/vector size is %d\n", sz);
#endif

	  if (sz != nelems)
	      return ERR_SZ_MISMATCH;
	  saved_t = *t;
	  while (!err && i--) {
	      *t = saved_t;
	      err = datumMLtoC(msp,t,p,*(ml_val_t *)val++);
	  }
	  if (err)
	      return err;
        }
	break;
      case MLCLOSESTRUCT_CODE:
      case MLCLOSEUNION_CODE:
	return ERR_EMPTY_AGGREGATE;
	break;
      default:
	Die("datumMLtoC: cannot yet handle type\n");
    }
    return err;
}

/* ML entry point for 'datumMLtoC' */
ml_val_t ml_datumMLtoC(ml_state_t *msp, ml_val_t arg)
{
    /* no GCs can occur since no allocation on ML heap */
    /* guaranteed that datum is a pointer (Cptr or Cstring) */
    char *type = REC_SELPTR(char,arg,0);
    ml_val_t datum = REC_SEL(arg,1);
    int err = 0;
    Word_t p, *q = &p;
    ml_val_t lp, ret;
    ptrlist_t *saved_pl;

    save_ptrlist(&saved_pl);
    err = datumMLtoC(msp,&type,&q,datum);
    if (err) {
      free_ptrlist();
      restore_ptrlist(saved_pl);
      return RaiseError(msp,err);
    }
    /* return (result,list of pointers to alloc'd C objects) */
    spaceCheck(msp,ptrlist_space(),&dummyRoot);
    lp = ptrlist_to_MLlist(msp);   /* this frees the ptr descriptors */
    restore_ptrlist(saved_pl);
    ret = MK_CADDR(msp,(Word_t *)p);
    REC_ALLOC2(msp, ret, ret, lp);
    return ret;
}

PVT ml_val_t word_CtoML(ml_state_t *msp,char **t,Word_t **p, ml_val_t *root)
{
    ml_val_t ret = ML_unit;
    ml_val_t mlval = ML_unit;
    int tag;
    char code;

    switch(code = *(*t)++) {
      case MLPAD_CODE:
#ifdef DEBUG_C_CALLS
	SayDebug("word_CtoML: skipping pad %x ", *p);
#endif
	DO_PAD(p,t);
#ifdef DEBUG_C_CALLS
	SayDebug(" to %x\n", *p);
#endif
	return word_CtoML(msp,t,p,root);
      case MLVOID_CODE:
	return NULLARY_DATACON;
      case MLCHAR_CODE:
	tag = MLCHAR_TAG;
	mlval = INT_CtoML(**(Byte_t **)p);
	(*(Byte_t **)p)++;
	break;
      case MLPTR_CODE: {
	  Word_t q;
#ifdef DEBUG_C_CALLS
	  SayDebug("word_CtoML: ptr %x\n", **(Word_t ****)p);
#endif
	  tag = MLPTR_TAG;
#ifdef DEBUG_C_CALLS
	  SayDebug("word_CtoML: size is %d\n", 
		   extractUnsigned((unsigned char **)t,4));
	  SayDebug("word_CtoML: align is %d\n", 
		   extractUnsigned((unsigned char **)t,1));
#else
	  *t += 5;  /* 5 bytes of size */
#endif
	  q = **p;
	  mlval = word_CtoML(msp,t,(Word_t **) &q,root);
	  (*p)++;
        }
	break;
      case MLINT_CODE: 
	tag = MLINT_TAG;
	goto handle_int;
      case MLSHORT_CODE:
	tag = MLSHORT_TAG;
	goto handle_int;
      case MLLONG_CODE:
	tag = MLLONG_TAG;
handle_int:
	{
	    Word_t w;

	    mkMLint(p,&w,extractUnsigned((unsigned char **)t,1));
	    mlval = mkWord32(msp,w);
	}
	break;
      case MLADDR_CODE: {
	  Word_t *cp = ** (Word_t ***) p;

#ifdef DEBUG_C_CALLS
	  SayDebug("word_CtoML:  C addr %x\n", cp);
#endif
	  tag = MLADDR_TAG;
	  mlval = MK_CADDR(msp,cp);
	  (*p)++;
        }
	break;
      case MLFLOAT_CODE: {
	  /* C floats become ML reals, which are doubles... */
	  tag = MLFLOAT_TAG;
	  mlval = double_CtoML(msp,(double) *(*(float **)p)++);
#ifdef DEBUG_C_CALLS
	  SayDebug("word_CtoML: made float %l.15f\n", *(double*)mlval);
#endif
        }
	break;
      case MLDOUBLE_CODE: {
	  tag = MLDOUBLE_TAG;
	  mlval = double_CtoML(msp,*(*(double **)p)++);
#ifdef DEBUG_C_CALLS
	  SayDebug("word_CtoML: made double %l.15f\n", *(double*)mlval);
#endif
        }
	break;
      case MLSTRING_CODE:
#ifdef DEBUG_C_CALLS
	SayDebug("word_CtoML:  string \"%s\"\n", (char *)**p);
#endif
	tag = MLSTRING_TAG;
	spaceCheck(msp,strlen((char *)**p),root);
	mlval = ML_CString(msp,(char *) **p);
	(*p)++;
	break;
      case MLOPENSTRUCT_CODE: {
	  ml_val_t local_root;

	  tag = MLSTRUCT_TAG;
	  mlval = LIST_nil;

#ifdef DEBUG_C_CALLS
	  SayDebug("word_CtoML: open struct\n");
#endif
	  while (**t != MLCLOSESTRUCT_CODE) {
	      LIST_cons(msp,local_root,mlval,*root);
	      ret = word_CtoML(msp,t,p,&local_root);
	      mlval = LIST_hd(local_root);
	      *root = LIST_tl(local_root);
	      LIST_cons(msp,mlval,ret,mlval);
	      IF_PAD_DO_PAD(p,t);
	  }
	  (*t)++;  /* advance past MLCLOSESTRUCT_CODE */
	  mlval = revMLList(mlval,LIST_nil);
        }
	break;
      case MLCLOSESTRUCT_CODE:
	Die("word_CtoML: found lone MLCLOSESTRUCT_CODE");
      case MLARRAY_CODE: 
      case MLVECTOR_CODE: {
	  int szb;
	  char *saved_t;
	  ml_val_t res,local_root;
	  int n,i;
	  Word_t dtag;

	  tag = (code == MLARRAY_CODE) ? MLARRAY_TAG : MLVECTOR_TAG;
	  dtag = (code == MLARRAY_CODE) ? DTAG_array : DTAG_vector;
	  n = extractUnsigned((unsigned char **)t,2);  /* number of elements */
	  szb = extractUnsigned((unsigned char **)t,2);/* element sz (bytes)*/
#ifdef DEBUG_C_CALLS
	  SayDebug("word_CtoML: array/vector with %d elems of size %d\n", n, szb);
#endif
	  saved_t = *t;
	  spaceCheck(msp,szb*n,root);
	  /* ML_AllocArray isn't used here since it might call GC */
	  ML_AllocWrite (msp, 0, MAKE_DESC(n,dtag));
	  mlval = ML_Alloc (msp, n);
	  /* clear the array/vector so that it can be GC'd if necessary */
	  for (i = 0; i < n; i++) {
	      PTR_MLtoC(ml_val_t,mlval)[i] = ML_unit;
	  }
	  for (i = 0; i < n; i++) {
	      *t = saved_t;
	      LIST_cons(msp,local_root,mlval,*root);
	      res = word_CtoML(msp,t,p,&local_root);
	      mlval = LIST_hd(local_root);
	      *root = LIST_tl(local_root);
	      PTR_MLtoC(ml_val_t,mlval)[i] = res;
	  }
        }
	break;
      default:
#ifdef DEBUG_C_CALLS
	SayDebug("word_CtoML: bad type is '%c'\n", *(*t-1));
#endif
	Die("word_CtoML: cannot yet handle type\n");
    }
    REC_ALLOC2(msp,ret,INT_CtoML(tag),mlval);
    return ret;
}

/* static  c-calls-fns.c needs to see this */
ml_val_t datumCtoML(ml_state_t *msp, char *type, Word_t p, ml_val_t *root)
{
    ml_val_t ret;

#ifdef DEBUG_C_CALLS
   SayDebug("datumCtoML: C address is %x\n", p);
#endif

#ifdef DEBUG_C_CALLS
   SayDebug("datumCtoML: type is %s\n", type);
#endif

    switch (*type) {
      case MLDOUBLE_CODE:
	ret = double_CtoML(msp, *(double *)p);
	REC_ALLOC2(msp,ret,INT_CtoML(MLDOUBLE_TAG),ret);
	break;
      case MLFLOAT_CODE:
	ret = double_CtoML(msp, (double) (*(float *)p));
	REC_ALLOC2(msp,ret,INT_CtoML(MLFLOAT_TAG),ret);
	break;
      default: {
	  Word_t *q = &p;
	  ret = word_CtoML(msp,&type,&q,root);
      }
      break;
    }
#ifdef DEBUG_C_CALLS
    SayDebug("datumCtoML: returning\n");
#endif
    return ret;
}


/* ML entry point for 'datumCtoML' */
ml_val_t ml_datumCtoML(ml_state_t *msp, ml_val_t arg)
{
    /* make copies of things that GC may move */
    char *type = mk_strcpy(REC_SELPTR(char,arg,0));
    Word_t *caddr = GET_CADDR(REC_SEL(arg,1));
    ml_val_t ret;

    ret = datumCtoML(msp,type,(Word_t) caddr,&arg);
    FREE(type);
    return ret;
}


/* ML entry point for 'c_call' */
ml_val_t ml_c_call(ml_state_t *msp, ml_val_t arg)
{
#if !defined(INDIRECT_CFUNC)
    Word_t (*f)() = (Word_t (*)())
                      REC_SELPTR(Word_t,arg,0);
#else
    Word_t (*f)() = (Word_t (*)())
                      ((cfunc_binding_t *)REC_SELPTR(Word_t,arg,0))->cfunc;
#endif
    int n_cargs = REC_SELINT(arg,1);
    ml_val_t carg_types = REC_SEL(arg,2);                   /* string list */
    char *cret_type = REC_SELPTR(char,arg,3);
    ml_val_t cargs = REC_SEL(arg,4);                        /* cdata list */
    bool_t auto_free = REC_SELINT(arg,5);
    ptrlist_t *saved_pl;

    ml_val_t p,q;
    ml_val_t ret;
    int i;
    Word_t vals[N_ARGS];
    Word_t w;
    int err = NO_ERR;

    if (n_cargs > N_ARGS)  /* shouldn't see this; ML side insures this */
	return RaiseError(msp,ERR_TOO_MANY_ARGS);
	
    /* save the ptrlist since C can call ML can call C ... */
    save_ptrlist(&saved_pl);

    p = carg_types;
    q = cargs;
    i = 0;
    while (p != LIST_nil && q != LIST_nil) {
	char *carg_type = PTR_MLtoC(char,LIST_hd(p));
	Word_t *vp;

#ifdef DEBUG_C_CALLS
	SayDebug("ml_c_call: arg %d:\"%s\"\n",i,carg_type);
#endif

	vp = &vals[i];
	if (err = datumMLtoC(msp,&carg_type,&vp,LIST_hd(q)))
	    break;
	i++;
	p = LIST_tl(p);
	q = LIST_tl(q);
    }
#ifdef DEBUG_C_CALLS
    SayDebug("ml_c_call: rettype is \"%s\"\n", cret_type);
#endif

    /* within ml_c_call, no ML allocation occurs above this point */

    if (!err && (i != n_cargs))
	err = ERR_WRONG_ARG_COUNT;
    if (err) {
	free_ptrlist();
	restore_ptrlist(saved_pl);
	return RaiseError(msp,err);
    }
#ifdef DEBUG_C_CALLS
    SayDebug("ml_c_call: calling C function at %x\n", f);
#endif

    /* expose msp so C has access to it */
    visible_msp = msp;
    switch (*cret_type) {
      case MLDOUBLE_CODE:
	ret = double_CtoML(msp,call_double_fn((double (*)())f,n_cargs,vals));
	REC_ALLOC2(msp,ret,INT_CtoML(MLDOUBLE_TAG),ret);
	break;
      case MLFLOAT_CODE:
	ret = double_CtoML(msp,
			   (double) call_float_fn((float(*)())f,n_cargs,vals));
	REC_ALLOC2(msp,ret,INT_CtoML(MLFLOAT_TAG),ret);
	break;
      case MLCHAR_CODE: {
	  Byte_t b = (Byte_t) call_word_fn(f,n_cargs,vals);
	  Byte_t *bp = &b;
	
	  ret = word_CtoML(msp,&cret_type,(Word_t **)&bp,&dummyRoot);
        }
	break;
      default: {
	Word_t w = call_word_fn(f,n_cargs,vals);
	Word_t *wp = &w;
	
	ret = word_CtoML(msp,&cret_type,&wp,&dummyRoot);
      }
    }
#ifdef DEBUG_C_CALLS
    SayDebug("ml_c_call: returned from C function\n");
#endif

#ifdef DEBUG_C_CALLS
    SayDebug("ml_c_call: auto_free is %d\n",auto_free);
#endif

    /* setup the return value, always a pair */
    {
	ml_val_t lp = LIST_nil;

	if (auto_free) {
#ifdef DEBUG_C_CALLS
	    SayDebug("ml_c_call: performing auto-free\n");
#endif

	    free_ptrlist();
	} else {
	    /* return (result,list of pointers to alloc'd C objects) */
#ifdef DEBUG_C_CALLS
	    SayDebug("ml_c_call: returning list of caddrs\n");
#endif
	    spaceCheck(msp,ptrlist_space(),&ret);
	    lp = ptrlist_to_MLlist(msp); /* this frees the ptr descriptors */
	}
	REC_ALLOC2(msp, ret, ret, lp);
    }
    restore_ptrlist(saved_pl);     /* restore the previous ptrlist */
    return ret;
}


/* end of c-calls.c */

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0