ghc/rts/ForeignCall.c

   1
   2 /* -----------------------------------------------------------------------------
   3  * $Id: ForeignCall.c,v 1.16 2000/05/12 11:59:39 sewardj Exp $
   4  *
   5  * (c) The GHC Team 1994-1999.
   6  *
   7  * Implementation of foreign import and foreign export.
   8  * ---------------------------------------------------------------------------*/
   9
  10 #include "Rts.h"
  11
  12 #ifdef INTERPRETER
  13
  14 #include "RtsUtils.h"    /* barf :-) */
  15 #include "Assembler.h"   /* for CFun stuff */
  16 #include "Schedule.h"
  17 #include "Evaluator.h"
  18 #include "ForeignCall.h"
  19
  20 /* Exports of this file:
  21       mkDescriptor
  22       ccall
  23       createAdjThunk
  24    Everything else is local, I think.
  25 */
  26
  27 /* ----------------------------------------------------------------------
  28  * Some misc-ery to begin with.
  29  * --------------------------------------------------------------------*/
  30
  31 CFunDescriptor* mkDescriptor( char* as, char* rs )
  32 {
  33     /* ToDo: don't use malloc */
  34     CFunDescriptor *d  = malloc(sizeof(CFunDescriptor));
  35     if (d == NULL) return d;
  36     d->arg_tys     = as;
  37     d->result_tys  = rs;
  38     d->num_args    = strlen(as);
  39     d->num_results = strlen(rs);
  40     return d;
  41 }
  42
  43
  44 /* ----------------------------------------------------------------------
  45  * Part the first: CALLING OUT -- foreign import
  46  * --------------------------------------------------------------------*/
  47
  48 /* SOME NOTES ABOUT PARAMETERISATION.
  49
  50    These pertain equally to foreign import and foreign export.
  51
  52    Implementations for calling in and out are very architecture
  53    dependent.  After some consideration, it appears that the two
  54    important factors are the instruction set, and the calling
  55    convention used.  Factors like the OS and compiler are not
  56    directly relevant.
  57
  58    So: routines which are architecture dependent are have
  59        _instructionsetname_callingconventionname attached to the
  60        the base name.  For example, code specific to the ccall
  61        convention on x86 would be suffixed _x86_ccall.
  62
  63    A third possible dimension of parameterisation relates to the
  64    split between callee and caller saves registers.  For example,
  65    x86_ccall code needs to assume a split, and different splits
  66    using ccall on x86 need different code.  However, that does not
  67    yet seem an issue, so it is ignored here.
  68 */
  69
  70
  71 /* ------------------------------------------------------------------
  72  * Calling out to C: a simple, universal calling API
  73  * ----------------------------------------------------------------*/
  74
  75 /* The universal call-C API supplies a single function:
  76
  77       void universal_call_c ( int   n_args,
  78                               void* args,
  79                               char* argstr,
  80                               void* fun )
  81
  82    PRECONDITIONS
  83
  84    args points to the start of a block of memory containing the
  85    arguments.  This block is an array of 8-byte entities,
  86    containing (n_args+1) slots.   The zeroth slot is where the
  87    return result goes. Slots [1 .. n_args] contain the arguments,
  88    presented left-to-right.
  89
  90    Arguments are stored in the host's byte ordering inside
  91    the slots.  Only 4 or 8 byte entities are allowed.
  92    4-byte entities are stored in the half-slot with lower
  93    addresses.
  94
  95    For example, a 32-bit value 0xAABBCCDD would be stored, on
  96    a little-endian, as
  97
  98       DD CC BB AA  0  0  0  0
  99
 100    whereas on a big-endian would expect
 101
 102       AA BB CC DD  0  0  0  0
 103
 104    Clients do not need to fill in the zero bytes; they are there
 105    only for illustration.
 106
 107    argstr is a simplified argument descriptor string.  argstr
 108    has one character for each (notional) argument slot of
 109    args.  That means the first byte of argstr describes the
 110    return type.  args should be allocated by the caller to hold
 111    as many slots as implied by argstr.
 112
 113    argstr always specifies a return type.  If the function to
 114    be called returns no result, you must specify a bogus
 115    return type in argstr[0]; a 32-bit int seems like a good bet.
 116
 117    Characters in argstr specify the result and argument types:
 118
 119       i    32-bit integral
 120       I    64-bit integral
 121       f    32-bit floating
 122       F    64-bit floating
 123
 124    Pointers should travel as integral entities.  At the moment
 125    there are no descriptors for entities smaller than 32 bits
 126    since AFAIK all calling conventions expand smaller entities
 127    to 32 bits anyway.  Users of this routine need to handle
 128    packing/unpacking of 16 and 8 bit quantities themselves.
 129
 130    If the preconditions are not met, behaviour of
 131    universal_call_c is entirely undefined.
 132
 133
 134    POSTCONDITION
 135
 136    The function specified by fun is called with arguments
 137    in args as specified by argstr.  The result of the call
 138    is placed in the first 8 bytes of args, again as specified
 139    by the first byte of argstr.  Calling and returning is to
 140    be done using the correct calling convention for the
 141    architecture.
 142
 143    It's clear that implementations of universal_call_c will
 144    have to be handwritten assembly.  The above design is intended
 145    to make that assembly as simple as possible, at the expense
 146    of a small amount of complication for the API's user.
 147
 148    These architecture-dependent assembly routines are in
 149    rts/universal_call_c.S.
 150 */
 151
 152
 153 /* ----------------------------------------------------------------*
 154  * External  refs for the assembly routines.
 155  * ----------------------------------------------------------------*/
 156
 157 #if i386_TARGET_ARCH
 158 extern void universal_call_c_x86_stdcall  ( int, void*, char*, void* );
 159 extern void universal_call_c_x86_ccall    ( int, void*, char*, void* );
 160 #else
 161 static void universal_call_c_generic      ( int, void*, char*, void* );
 162 #endif
 163
 164 /* ----------------------------------------------------------------*
 165  * This is a generic version of universal call that
 166  * only works for specific argument patterns.
 167  *
 168  * It allows ports to work on the Hugs Prelude immediately,
 169  * even if universal_call_c_arch_callingconvention is not available.
 170  * ----------------------------------------------------------------*/
 171
 172 static void universal_call_c_generic
 173 ( int   n_args,
 174   void* args,
 175   char* argstr,
 176   void* fun )
 177 {
 178   unsigned int *p = (unsigned int*) args;
 179
 180 #define ARG(n)  (p[n*2])
 181 #define CMP(str) ((n_args + 1 == (int)strlen(str)) && \
 182                   (!strncmp(str,argstr,n_args + 1)))
 183
 184 #define CALL(retType,callTypes,callVals) \
 185         ((retType(*)callTypes)(fun))callVals
 186
 187   if (CMP("i")) {
 188     int res = CALL(int,(void),());
 189     ARG(0) = res;
 190   } else if (CMP("ii")) {
 191     int arg1 = (int) ARG(1);
 192     int res = CALL(int,(int),(arg1));
 193     ARG(0) = res;
 194   } else if (CMP("iii")) {
 195     int arg1 = (int) ARG(1);
 196     int arg2 = (int) ARG(2);
 197     int res = CALL(int,(int,int),(arg1,arg2));
 198     ARG(0) = res;
 199   } else {
 200     /* Do not have the generic call for this argument list. */
 201     int i;
 202     printf("Can not call external function at address %d\n",(int)fun);
 203     printf("Argument string = '");
 204     for(i=0;i<n_args;i++) {
 205       printf("%c",(char)argstr[i]);
 206     }
 207     printf("' [%d arg(s)]\n",n_args);
 208     assert(0);
 209   }
 210 #undef CALL
 211 #undef CMP
 212 #undef ARG
 213 }
 214
 215
 216 /* ----------------------------------------------------------------*
 217  * Move args/results between STG stack and the above API's arg block
 218  * Returns 0 on success
 219  *         1 if too many args/results or non-handled type
 220  *         2 if config error on this platform
 221  * Tries to automatically handle 32-vs-64 bit differences.
 222  * Assumes an LP64 programming model for 64 bit:
 223  *    sizeof(long)==sizeof(void*)==64  on a 64 bit platform
 224  *    sizeof(int)==32                  on a 64 bit platform
 225  * This code attempts to be architecture neutral (viz, generic).
 226  * ----------------------------------------------------------------*/
 227
 228 int ccall ( CFunDescriptor*  d,
 229             void             (*fun)(void),
 230             StgBCO**         bco,
 231             char             cc,
 232             Capability*      cap
 233           )
 234 {
 235    double         arg_vec [31];
 236    char           argd_vec[31];
 237    unsigned int*  p;
 238    int            i;
 239    unsigned long  ul;
 240    unsigned int   token;
 241
 242    if (sizeof(int) != 4 || sizeof(double) != 8 || sizeof(float) != 4
 243        || (sizeof(void*) != 4 && sizeof(void*) != 8)
 244        || (sizeof(unsigned long) != sizeof(void*)))
 245       return 2;
 246
 247    if (d->num_args > 30 || d->num_results > 1)
 248       return 1; /* unlikely, but ... */
 249
 250    p = (unsigned int*) &arg_vec[1];
 251    for (i = 0; i < (int)(d->num_args); i++) {
 252       switch (d->arg_tys[i]) {
 253
 254          case INT_REP:
 255             ul = (unsigned long)PopTaggedInt();
 256             goto common_int32_or_64;
 257          case WORD_REP:
 258             ul = (unsigned long)PopTaggedWord();
 259             goto common_int32_or_64;
 260          case ADDR_REP:
 261             ul = (unsigned long)(PopTaggedAddr());
 262             goto common_int32_or_64;
 263          case STABLE_REP:
 264             ul = (unsigned long)PopTaggedStablePtr();
 265             common_int32_or_64:
 266             if (sizeof(void*) == 4) {
 267                *(unsigned long *)p = ul; p++; *p++ = 0;
 268                argd_vec[i+1] = 'i';
 269             } else {
 270                *(unsigned long *)p = ul;
 271                p += 2;
 272                argd_vec[i+1] = 'I';
 273             }
 274             break;
 275
 276          case CHAR_REP: {
 277             int j = (int)PopTaggedChar();
 278             *p++ = j; *p++ = 0;
 279             argd_vec[i+1] = 'i';
 280             break;
 281          }
 282          case FLOAT_REP: {
 283             float f = PopTaggedFloat();
 284             *(float*)p = f; p++; *p++ = 0;
 285             argd_vec[i+1] = 'f';
 286             break;
 287          }
 288          case DOUBLE_REP: {
 289             double d = PopTaggedDouble();
 290             *(double*)p = d; p+=2;
 291             argd_vec[i+1] = 'F';
 292             break;
 293          }
 294          default:
 295             return 1;
 296       }
 297    }
 298
 299    if (d->num_results == 0) {
 300       argd_vec[0] = 'i';
 301    } else {
 302       switch (d->result_tys[0]) {
 303          case INT_REP: case WORD_REP: case ADDR_REP: case STABLE_REP:
 304             argd_vec[0] = (sizeof(void*)==4) ? 'i' : 'I'; break;
 305          case CHAR_REP:
 306             argd_vec[0] = 'i'; break;
 307          case FLOAT_REP:
 308             argd_vec[0] = 'f'; break;
 309          case DOUBLE_REP:
 310             argd_vec[0] = 'F'; break;
 311          default:
 312             return 1;
 313       }
 314    }
 315
 316    PushPtr((StgPtr)(*bco));
 317    cap->rCurrentTSO->sp    = MainRegTable.rSp;
 318    cap->rCurrentTSO->su    = MainRegTable.rSu;
 319    cap->rCurrentTSO->splim = MainRegTable.rSpLim;
 320    token = suspendThread(cap);
 321
 322 #if i386_TARGET_ARCH
 323    if (cc == 'c')
 324       universal_call_c_x86_ccall (
 325          d->num_args, (void*)arg_vec, argd_vec, fun );
 326    else if (cc == 's')
 327       universal_call_c_x86_stdcall (
 328          d->num_args, (void*)arg_vec, argd_vec, fun );
 329    else barf ( "ccall(i386): unknown calling convention" );
 330 #else
 331    universal_call_c_generic (
 332       d->num_args, (void*)arg_vec, argd_vec, fun );
 333 #endif
 334
 335    cap = resumeThread(token);
 336    MainRegTable.rSp    = cap->rCurrentTSO->sp;
 337    MainRegTable.rSu    = cap->rCurrentTSO->su;
 338    MainRegTable.rSpLim = cap->rCurrentTSO->splim;
 339    *bco=(StgBCO*)PopPtr();
 340
 341    /* INT, WORD, ADDR, STABLE don't need to do a word-size check
 342       since the result is in the bytes starting at p regardless. */
 343
 344    if (d->num_results > 0) {
 345       p = (unsigned int*) &arg_vec[0];
 346       switch (d->result_tys[0]) {
 347
 348          case INT_REP:
 349             PushTaggedInt ( ((StgInt*)p) [0] );
 350             break;
 351          case WORD_REP:
 352             PushTaggedWord ( ((StgWord*)p) [0] );
 353             break;
 354          case ADDR_REP:
 355             PushTaggedAddr ( ((StgAddr*)p) [0] );
 356             break;
 357          case STABLE_REP:
 358             PushTaggedStablePtr ( ((StgStablePtr*)p) [0] );
 359             break;
 360
 361          case CHAR_REP:
 362             PushTaggedChar ( (StgChar) p[0]);
 363             break;
 364          case FLOAT_REP:
 365             PushTaggedFloat ( ((StgFloat*)p) [0] );
 366             break;
 367          case DOUBLE_REP:
 368             PushTaggedDouble ( ((StgDouble*)p) [0] );
 369             break;
 370
 371          default:
 372             return 1;
 373       }
 374    }
 375
 376    return 0;
 377 }
 378
 379
 380
 381 /* ----------------------------------------------------------------------
 382  * Part the second: CALLING IN -- foreign export {dynamic}
 383  * --------------------------------------------------------------------*/
 384
 385 /* Make it possible for the evaluator to get hold of bytecode
 386    for a given function by name.  Useful but a hack.  Sigh.
 387  */
 388 extern void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s );
 389 extern int /*Bool*/ combined;
 390
 391 /* ----------------------------------------------------------------*
 392  * The implementation for x86_ccall and x86_stdcall.
 393  * ----------------------------------------------------------------*/
 394
 395 static
 396 HaskellObj
 397 unpackArgsAndCallHaskell_x86_nocallconv_wrk ( StgStablePtr stableptr,
 398                                               char* tydesc, char* args)
 399 {
 400    /* Copy args out of the C stack frame in an architecture
 401       dependent fashion, under the direction of the type description
 402       string tydesc.  Dereference the stable pointer, giving the
 403       Haskell function to call.  Build an application of this to
 404       the arguments, and finally wrap primRunST round the whole
 405       thing, since we know it returns an IO type.  Then evaluate
 406       the whole, which leaves nodeOut as the evaluated 'a', where
 407       the type of the function called is .... -> IO a.
 408
 409       We can't immediately unpack the results and return, since
 410       int results need to return in a different register (%eax and
 411       possibly %edx) from float things (%st(0)).  So return nodeOut
 412       to the relevant wrapper function, which knows enough about
 413       the return type to do the Right Thing.
 414
 415       There's no getting round it: this is most heinous hack.
 416    */
 417
 418    HaskellObj      node;
 419    HaskellObj      nodeOut;
 420    SchedulerStatus sstat;
 421
 422    char* resp = tydesc;
 423    char* argp = tydesc;
 424
 425    node = (HaskellObj)deRefStablePtr(stableptr);
 426
 427    if (*argp != ':') argp++;
 428    ASSERT( *argp == ':' );
 429    argp++;
 430    while (*argp) {
 431       switch (*argp) {
 432          case CHAR_REP:
 433             node = rts_apply ( node, rts_mkChar ( *(char*)args ) );
 434             args += 4;
 435             break;
 436          case INT_REP:
 437             node = rts_apply ( node, rts_mkInt ( *(int*)args ) );
 438             args += 4;
 439             break;
 440          case WORD_REP:
 441             node = rts_apply ( node, rts_mkWord ( *(unsigned int*)args ) );
 442             args += 4;
 443             break;
 444          case ADDR_REP:
 445             node = rts_apply ( node, rts_mkAddr ( *(void**)args ) );
 446             args += 4;
 447             break;
 448          case STABLE_REP:
 449             node = rts_apply ( node, rts_mkStablePtr ( *(int*)args ) );
 450             args += 4;
 451             break;
 452          case FLOAT_REP:
 453             node = rts_apply ( node, rts_mkFloat ( *(float*)args ) );
 454             args += 4;
 455             break;
 456          case DOUBLE_REP:
 457             node = rts_apply ( node, rts_mkDouble ( *(double*)args ) );
 458             args += 8;
 459             break;
 460          default:
 461             barf(
 462                "unpackArgsAndCallHaskell_x86_nocallconv: "
 463                "unexpected arg type rep");
 464       }
 465       argp++;
 466    }
 467
 468    if (combined) {
 469       sstat = rts_evalIO ( node, &nodeOut );
 470    } else {
 471       node = rts_apply (
 472                 getHugs_BCO_cptr_for("runST"),
 473                 node );
 474       sstat = rts_eval ( node, &nodeOut );
 475    }
 476
 477    if (sstat != Success)
 478       barf ("unpackArgsAndCallHaskell_x86_nocallconv: eval failed");
 479
 480    return nodeOut;
 481 }
 482
 483
 484 static
 485 double
 486 unpackArgsAndCallHaskell_x86_nocallconv_DOUBLE (
 487       StgStablePtr stableptr, char* tydesc, char* args
 488    )
 489 {
 490    HaskellObj nodeOut
 491       = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
 492            stableptr, tydesc, args
 493         );
 494    /* Return a double.  This return will go into %st(0), which
 495       is unmodified by the adjustor thunk.
 496    */
 497    ASSERT(tydesc[0] == DOUBLE_REP);
 498    return rts_getDouble(nodeOut);
 499 }
 500
 501
 502 static
 503 float
 504 unpackArgsAndCallHaskell_x86_nocallconv_FLOAT (
 505       StgStablePtr stableptr, char* tydesc, char* args
 506    )
 507 {
 508    HaskellObj nodeOut
 509       = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
 510            stableptr, tydesc, args
 511         );
 512    /* Probably could be merged with the double case, since %st(0) is
 513       still the return register.
 514    */
 515    ASSERT(tydesc[0] == FLOAT_REP);
 516    return rts_getFloat(nodeOut);
 517 }
 518
 519
 520 static
 521 unsigned long
 522 unpackArgsAndCallHaskell_x86_nocallconv_INTISH (
 523       StgStablePtr stableptr, char* tydesc, char* args
 524    )
 525 {
 526    HaskellObj nodeOut;
 527    nodeOut = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
 528                 stableptr, tydesc, args
 529              );
 530    /* A complete hack.  We know that all these returns will be
 531       put into %eax (and %edx, if it is a 64-bit return), and
 532       the adjustor thunk will then itself return to the original
 533       (C-world) caller without modifying %eax or %edx, so the
 534       original caller will be a Happy Bunny.
 535    */
 536    switch (*tydesc) {
 537       case ':':        return 0;
 538       case CHAR_REP:   return (unsigned long)rts_getChar(nodeOut);
 539       case INT_REP:    return (unsigned long)rts_getInt(nodeOut);
 540       case WORD_REP:   return (unsigned long)rts_getWord(nodeOut);
 541       case ADDR_REP:   return (unsigned long)rts_getAddr(nodeOut);
 542       case STABLE_REP: return (unsigned long)rts_getStablePtr(nodeOut);
 543       default:
 544          barf(
 545             "unpackArgsAndCallHaskell_x86_nocallconv: "
 546             "unexpected res type rep");
 547    }
 548 }
 549
 550
 551 /* This is a bit subtle, since it can deal with both stdcall
 552    and ccall.  There are two call transitions to consider:
 553
 554    1.  The call to "here".  If it's a ccall, we can return
 555        using 'ret 0' and let the caller remove the args.
 556        If stdcall, we have to return with 'ret N', where
 557        N is the size of the args passed.  N has to be
 558        determined by inspecting the type descriptor string
 559        typestr.
 560
 561    2.  The call to unpackArgsAndCallHaskell_x86_anycallconv_*.
 562        Whether these are done with stdcall or ccall depends on
 563        the conventions applied by the compiler that translated
 564        those procedures.  Fortunately, we can sidestep what it
 565        did by saving esp (in ebx), pushing the three args,
 566        calling unpack..., and restoring esp from ebx.  This
 567        trick assumes that ebx is a callee-saves register, so
 568        its value will be preserved across the unpack... call.
 569 */
 570 static
 571 StgAddr createAdjThunk_x86 ( StgStablePtr stableptr,
 572                              StgAddr      typestr,
 573                              char         callconv )
 574 {
 575    unsigned char* codeblock;
 576    unsigned char* cp;
 577    unsigned int   ch;
 578    unsigned int   nwords;
 579
 580    unsigned char* argp = (unsigned char*)typestr;
 581    unsigned int   ts   = (unsigned int)typestr;
 582    unsigned int   sp   = (unsigned int)stableptr;
 583
 584    if (((char*)typestr)[0] == DOUBLE_REP)
 585       ch = (unsigned int)
 586               &unpackArgsAndCallHaskell_x86_nocallconv_DOUBLE;
 587    else if (((char*)typestr)[0] == FLOAT_REP)
 588       ch = (unsigned int)
 589               &unpackArgsAndCallHaskell_x86_nocallconv_FLOAT;
 590    else
 591       ch = (unsigned int)
 592               &unpackArgsAndCallHaskell_x86_nocallconv_INTISH;
 593
 594    codeblock = malloc ( 0x26 );
 595    if (!codeblock)
 596       barf ( "createAdjThunk_x86: can't malloc memory\n");
 597
 598    if (callconv == 's') {
 599       nwords = 0;
 600       if (*argp != ':') argp++;
 601       ASSERT( *argp == ':' );
 602       argp++;
 603       while (*argp) {
 604          switch (*argp) {
 605             case CHAR_REP: case INT_REP: case WORD_REP:
 606             case ADDR_REP: case STABLE_REP: case FLOAT_REP:
 607                nwords += 4; break;
 608             case DOUBLE_REP:
 609                nwords += 8; break;
 610             default:
 611                barf("createAdjThunk_x86: unexpected type descriptor");
 612          }
 613          argp++;
 614       }
 615    } else
 616    if (callconv == 'c') {
 617       nwords = 0;
 618    } else {
 619       barf ( "createAdjThunk_x86: unknown calling convention\n");
 620    }
 621
 622    cp = codeblock;
 623    /*
 624       0000 53           pushl %ebx        # save caller's registers
 625       0001 51           pushl %ecx
 626       0002 56           pushl %esi
 627       0003 57           pushl %edi
 628       0004 55           pushl %ebp
 629       0005 89E0         movl %esp,%eax    # sp -> eax
 630       0007 83C018       addl $24,%eax     # move eax back over 5 saved regs + retaddr
 631       000a 89E3         movl %esp,%ebx    # remember sp before pushing args
 632       000c 50           pushl %eax        # push arg-block addr
 633       000d 6844332211   pushl $0x11223344 # push addr of type descr string
 634       0012 6877665544   pushl $0x44556677 # push stableptr to closure
 635       0017 E8BBAA9988   call 0x8899aabb   # SEE COMMENT BELOW
 636                                           # return value is in %eax, or %eax:%edx,
 637                                           # or %st(0), so don't trash these regs
 638                                           # between here and 'ret'
 639       001c 89DC         movl %ebx,%esp    # restore sp from remembered value
 640       001e 5D           popl %ebp         # restore caller's registers
 641       001f 5F           popl %edi
 642       0020 5E           popl %esi
 643       0021 59           popl %ecx
 644       0022 5B           popl %ebx
 645       0023 C27766       ret  $0x6677      # return, clearing args if stdcall
 646    */
 647    *cp++ = 0x53;
 648    *cp++ = 0x51;
 649    *cp++ = 0x56;
 650    *cp++ = 0x57;
 651    *cp++ = 0x55;
 652    *cp++ = 0x89; *cp++ = 0xE0;
 653    *cp++ = 0x83; *cp++ = 0xC0; *cp++ = 0x18;
 654    *cp++ = 0x89; *cp++ = 0xE3;
 655    *cp++ = 0x50;
 656    *cp++ = 0x68; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts;
 657    *cp++ = 0x68; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp;
 658
 659    /* call address needs to be: displacement relative to next insn */
 660    ch = ch - ( ((unsigned int)cp) + 5);
 661    *cp++ = 0xE8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;
 662
 663    *cp++ = 0x89; *cp++ = 0xDC;
 664    *cp++ = 0x5D;
 665    *cp++ = 0x5F;
 666    *cp++ = 0x5E;
 667    *cp++ = 0x59;
 668    *cp++ = 0x5B;
 669    *cp++ = 0xC2; *cp++=nwords;nwords>>=8; *cp++=nwords;
 670
 671    return codeblock;
 672 }
 673
 674
 675 /* ----------------------------------------------------------------*
 676  * The only function involved in foreign-export that needs to be
 677  * visible outside this file.
 678  * ----------------------------------------------------------------*/
 679
 680 StgAddr createAdjThunk ( StgStablePtr stableptr,
 681                          StgAddr      typestr,
 682                          StgChar      callconv )
 683 {
 684    return
 685 #if i386_TARGET_ARCH
 686       createAdjThunk_x86 ( stableptr, typestr, callconv );
 687 #else
 688       0;
 689 #warning foreign export not implemented on this architecture
 690 #endif
 691 }
 692
 693
 694 #endif /* INTERPRETER */
 695