ghc/rts/ForeignCall.c

   1
   2 /* -----------------------------------------------------------------------------
   3  * $Id: ForeignCall.c,v 1.5 1999/10/15 11:03:06 sewardj 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 #if 0
  37 /* By experiment on an x86 box, we found that gcc's
  38  * __builtin_apply(fun,as,size) expects *as to look like this:
  39  *   as[0] = &first arg = &as[1]
  40  *   as[1] = arg1
  41  *   as[2] = arg2
  42  *   ...
  43  *
  44  * on an x86, it returns a pointer to a struct containing an
  45  * int/int64/ptr in its first 4-8 bytes and a float/double in the next
  46  * 8 bytes.
  47  *
  48  * On a sparc:
  49  *   as[0] = &first arg = &as[2]
  50  *   as[1] = where structures should be returned
  51  *   as[2] = arg1
  52  *   as[3] = arg2
  53  *   ...
  54  *
  55  * This is something of a hack - but seems to be more portable than
  56  * hacking it up in assembly language which is how I did it before - ADR
  57  */
  58 void ccall( CFunDescriptor* d, void (*fun)(void) )
  59 {
  60     void *rs;
  61     char* tys = d->arg_tys;
  62     /* ToDo: the use of ARG_SIZE is based on the assumption that Hugs
  63      * obeys the same alignment restrictions as C.
  64      * But this is almost certainly wrong!
  65      * We could use gcc's __va_rounded_size macro (see varargs.h) to do a
  66      * better job.
  67      */
  68 #if i386_TARGET_ARCH
  69     void *as=alloca(4 + d->arg_size);
  70     StgWord* args = (StgWord*) as;
  71     *(void**)(args++) = 4 + (char*)as; /* incoming args ptr */
  72     for(; *tys; ++tys) {
  73       args += unmarshall(*tys,args);
  74     }
  75     rs = __builtin_apply(fun,as,(char*)args-(char*)as-4);
  76 #elif sparc_TARGET_ARCH
  77     void *as=alloca(8 + d->arg_size);
  78     StgWord* args = (StgWord*) as;
  79     int argcount;
  80     *(void**)(args++) = (char*)as; /* incoming args ptr */
  81     *(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*/
  82     for(; *tys; ++tys) {
  83       args += unmarshall(*tys,args);
  84     }
  85     argcount = ((void*)args - as);
  86     ASSERT(8 + d->arg_size == argcount);
  87     if (argcount <= 8) {
  88       argcount = 0;
  89     } else {
  90       argcount -= 4;
  91     }
  92     rs = __builtin_apply(fun,as,argcount);
  93 #else
  94 #error Cant do ccall for this architecture
  95 #endif
  96
  97     /* ToDo: can't handle multiple return values at the moment
  98      * - it's hard enough to get single return values working
  99      */
 100     if (*(d->result_tys)) {
 101         char ty = *(d->result_tys);
 102         ASSERT(d->result_tys[1] == '\0');
 103         switch (ty) {
 104         case 'F':
 105         case 'D':
 106                 /* ToDo: is this right? */
 107                 marshall(ty,(char*)rs+8);
 108                 return;
 109         default:
 110                 marshall(ty,rs);
 111                 return;
 112         }
 113     }
 114 }
 115 #endif
 116
 117
 118
 119
 120 #if 1
 121 /* HACK alert (red alert) */
 122 extern StgInt          PopTaggedInt       ( void ) ;
 123 extern StgDouble       PopTaggedDouble    ( void ) ;
 124 extern StgFloat        PopTaggedFloat     ( void ) ;
 125 extern StgChar         PopTaggedChar      ( void ) ;
 126 extern StgAddr         PopTaggedAddr      ( void ) ;
 127
 128 extern void   PushTaggedInt  ( StgInt );
 129 extern void   PushTaggedAddr ( StgAddr );
 130 extern void   PushPtr        ( StgPtr );
 131 extern StgPtr PopPtr         ( void );
 132
 133
 134 int seqNr = 0;
 135 #define IF(sss) if (strcmp(sss,cdesc)==0)
 136 #define STS      PushPtr((StgPtr)(*bco));SaveThreadState()
 137 #define LTS      LoadThreadState();*bco=(StgBCO*)PopPtr();
 138 #define LTS_RET  LoadThreadState();*bco=(StgBCO*)PopPtr(); return
 139 #define RET      return
 140 void ccall( CFunDescriptor* d, void (*fun)(void), StgBCO** bco )
 141 {
 142    int i;
 143    char cdesc[100];
 144    strcpy(cdesc, d->result_tys);
 145    strcat(cdesc, ":");
 146    strcat(cdesc, d->arg_tys);
 147    for (i = 0; cdesc[i] != 0; i++) {
 148       switch (cdesc[i]) {
 149          case 'x': cdesc[i] = 'A'; break;
 150          default:  break;
 151       }
 152    }
 153
 154    //fprintf(stderr, "ccall: %d cdesc = `%s'\n", seqNr++, cdesc);
 155
 156    IF(":") { STS; ((void(*)(void))(fun))(); LTS_RET; };
 157
 158    IF(":I") { int a1=PopTaggedInt();
 159               STS; ((void(*)(int))(fun))(a1); LTS_RET; };
 160    IF(":A") { void* a1=PopTaggedAddr();
 161               STS; ((void(*)(void*))(fun))(a1); LTS_RET; };
 162
 163    IF("I:") { int r;
 164               STS; r= ((int(*)(void))(fun))(); LTS;
 165               PushTaggedInt(r); RET ;};
 166
 167    IF(":II") { int a1=PopTaggedInt(); int a2=PopTaggedInt();
 168                STS; ((void(*)(int,int))(fun))(a1,a2); LTS_RET; };
 169    IF(":AI") { void* a1=PopTaggedAddr(); int a2=PopTaggedInt();
 170                STS; ((void(*)(void*,int))(fun))(a1,a2); LTS_RET; };
 171
 172    IF("I:I") { int a1=PopTaggedInt(); int r;
 173                STS; r=((int(*)(int))(fun))(a1); LTS;
 174                PushTaggedInt(r); RET; };
 175    IF("A:I") { int a1=PopTaggedInt(); void* r;
 176                STS; r=((void*(*)(int))(fun))(a1); LTS;
 177                PushTaggedAddr(r); RET; };
 178    IF("A:A") { void* a1=PopTaggedAddr(); void* r;
 179                STS; r=((void*(*)(void*))(fun))(a1); LTS;
 180                PushTaggedAddr(r); RET; };
 181
 182    IF("I:II") { int a1=PopTaggedInt(); int a2=PopTaggedInt(); int r;
 183                 STS; r=((int(*)(int,int))(fun))(a1,a2); LTS;
 184                 PushTaggedInt(r); RET; };
 185    IF("I:AI") { void* a1=PopTaggedAddr(); int a2=PopTaggedInt(); int r;
 186                 STS; r=((int(*)(void*,int))(fun))(a1,a2); LTS;
 187                 PushTaggedInt(r); RET; };
 188    IF("A:AI") { void* a1=PopTaggedAddr(); int a2=PopTaggedInt(); void* r;
 189                 STS; r=((void*(*)(void*,int))(fun))(a1,a2); LTS;
 190                 PushTaggedAddr(r); RET; };
 191
 192    IF("I:III") { int a1=PopTaggedInt(); int a2=PopTaggedInt();
 193                  int a3=PopTaggedInt(); int r;
 194                  STS; r=((int(*)(int,int,int))(fun))(a1,a2,a3); LTS;
 195                  PushTaggedInt(r); RET; };
 196
 197    IF(":AIDCF") { void*  a1 = PopTaggedAddr();
 198                   int    a2 = PopTaggedInt();
 199                   double a3 = PopTaggedDouble();
 200                   char   a4 = PopTaggedChar();
 201                   float  a5 = PopTaggedFloat();
 202                   STS;
 203                   ((void(*)(void*,int,double,char,float))(fun))(a1,a2,a3,a4,a5);
 204                   LTS_RET; };
 205
 206
 207 fprintf(stderr,"panic: ccall cdesc `%s' not implemented\n", cdesc );
 208    exit(1);
 209
 210
 211 fprintf(stderr,
 212         "ccall: arg_tys %s arg_size %d result_tys %s result_size %d\n",
 213         d->arg_tys, d->arg_size, d->result_tys, d->result_size );
 214 }
 215
 216 #undef IF
 217 #undef STS
 218 #undef LTS
 219 #undef LTS_RET
 220 #undef RET
 221
 222 #endif
 223
 224
 225
 226
 227
 228
 229 CFunDescriptor* mkDescriptor( char* as, char* rs )
 230 {
 231     /* ToDo: don't use malloc */
 232     CFunDescriptor *d = malloc(sizeof(CFunDescriptor));
 233     assert(d);
 234     d->arg_tys = as;
 235     d->arg_size = argSize(as);
 236     d->result_tys = rs;
 237     d->result_size = argSize(rs);
 238     return d;
 239 }
 240
 241 #endif /* INTERPRETER */