ghc/rts/ForeignCall.c

   1 /* -*- mode: hugs-c; -*- */
   2 /* -----------------------------------------------------------------------------
   3  * $Id: ForeignCall.c,v 1.3 1999/02/05 16:02:40 simonm Exp $
   4  *
   5  * (c) The GHC Team 1994-1999.
   6  *
   7  * Foreign Function calls
   8  *
   9  * ---------------------------------------------------------------------------*/
  10
  11 #include "Rts.h"
  12
  13 #ifdef INTERPRETER
  14
  15 #include "Assembler.h" /* for CFun stuff */
  16 #include "Evaluator.h"
  17 #include "ForeignCall.h"
  18
  19 /* the assymetry here seem to come from the caller-allocates
  20  * calling convention.  But does the caller really allocate
  21  * result??
  22  */
  23
  24 void hcall( HFunDescriptor* d, StablePtr fun, void* as, void* rs)
  25 {
  26 #if 0
  27     /* out of date - ADR */
  28     marshall(d->arg_tys,as);
  29     prim_hcall(fun);
  30     unmarshall(d->result_tys,rs);
  31 #else
  32     assert(0);
  33 #endif
  34 }
  35
  36 /* By experiment on an x86 box, we found that gcc's
  37  * __builtin_apply(fun,as,size) expects *as to look like this:
  38  *   as[0] = &first arg = &as[1]
  39  *   as[1] = arg1
  40  *   as[2] = arg2
  41  *   ...
  42  *
  43  * on an x86, it returns a pointer to a struct containing an
  44  * int/int64/ptr in its first 4-8 bytes and a float/double in the next
  45  * 8 bytes.
  46  *
  47  * On a sparc:
  48  *   as[0] = &first arg = &as[2]
  49  *   as[1] = where structures should be returned
  50  *   as[2] = arg1
  51  *   as[3] = arg2
  52  *   ...
  53  *
  54  * This is something of a hack - but seems to be more portable than
  55  * hacking it up in assembly language which is how I did it before - ADR
  56  */
  57 void ccall( CFunDescriptor* d, void (*fun)(void) )
  58 {
  59     void *rs;
  60     char* tys = d->arg_tys;
  61     /* ToDo: the use of ARG_SIZE is based on the assumption that Hugs
  62      * obeys the same alignment restrictions as C.
  63      * But this is almost certainly wrong!
  64      * We could use gcc's __va_rounded_size macro (see varargs.h) to do a
  65      * better job.
  66      */
  67 #if i386_TARGET_ARCH
  68     void *as=alloca(4 + d->arg_size);
  69     StgWord* args = (StgWord*) as;
  70     *(void**)(args++) = 4 + (char*)as; /* incoming args ptr */
  71     for(; *tys; ++tys) {
  72       args += unmarshall(*tys,args);
  73     }
  74     rs = __builtin_apply(fun,as,(char*)args-(char*)as-4);
  75 #elif sparc_TARGET_ARCH
  76     void *as=alloca(8 + d->arg_size);
  77     StgWord* args = (StgWord*) as;
  78     int argcount;
  79     *(void**)(args++) = (char*)as; /* incoming args ptr */
  80     *(void**)(args++) = 0;  /* structure value address - I think this is the address of a block of memory where structures are returned - in which case we should initialise with rs or something like that*/
  81     for(; *tys; ++tys) {
  82       args += unmarshall(*tys,args);
  83     }
  84     argcount = ((void*)args - as);
  85     ASSERT(8 + d->arg_size == argcount);
  86     if (argcount <= 8) {
  87       argcount = 0;
  88     } else {
  89       argcount -= 4;
  90     }
  91     rs = __builtin_apply(fun,as,argcount);
  92 #else
  93 #error Cant do ccall for this architecture
  94 #endif
  95
  96     /* ToDo: can't handle multiple return values at the moment
  97      * - it's hard enough to get single return values working
  98      */
  99     if (*(d->result_tys)) {
 100         char ty = *(d->result_tys);
 101         ASSERT(d->result_tys[1] == '\0');
 102         switch (ty) {
 103         case 'F':
 104         case 'D':
 105                 /* ToDo: is this right? */
 106                 marshall(ty,(char*)rs+8);
 107                 return;
 108         default:
 109                 marshall(ty,rs);
 110                 return;
 111         }
 112     }
 113 }
 114
 115 CFunDescriptor* mkDescriptor( char* as, char* rs )
 116 {
 117     /* ToDo: don't use malloc */
 118     CFunDescriptor *d = malloc(sizeof(CFunDescriptor));
 119     assert(d);
 120     d->arg_tys = as;
 121     d->arg_size = argSize(as);
 122     d->result_tys = rs;
 123     d->result_size = argSize(rs);
 124     return d;
 125 }
 126
 127 #endif /* INTERPRETER */