ghc/rts/ForeignCall.c

   1
   2 /* -----------------------------------------------------------------------------
   3  * $Id: ForeignCall.c,v 1.17 2000/05/26 10:14:34 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     barf("aborting");
 209     ASSERT(0);
 210   }
 211 #undef CALL
 212 #undef CMP
 213 #undef ARG
 214 }
 215
 216
 217 /* ----------------------------------------------------------------*
 218  * Move args/results between STG stack and the above API's arg block
 219  * Returns 0 on success
 220  *         1 if too many args/results or non-handled type
 221  *         2 if config error on this platform
 222  * Tries to automatically handle 32-vs-64 bit differences.
 223  * Assumes an LP64 programming model for 64 bit:
 224  *    sizeof(long)==sizeof(void*)==64  on a 64 bit platform
 225  *    sizeof(int)==32                  on a 64 bit platform
 226  * This code attempts to be architecture neutral (viz, generic).
 227  * ----------------------------------------------------------------*/
 228
 229 int ccall ( CFunDescriptor*  d,
 230             void             (*fun)(void),
 231             StgBCO**         bco,
 232             char             cc,
 233             Capability*      cap
 234           )
 235 {
 236    double         arg_vec [31];
 237    char           argd_vec[31];
 238    unsigned int*  p;
 239    int            i;
 240    unsigned long  ul;
 241    unsigned int   token;
 242
 243    if (sizeof(int) != 4 || sizeof(double) != 8 || sizeof(float) != 4
 244        || (sizeof(void*) != 4 && sizeof(void*) != 8)
 245        || (sizeof(unsigned long) != sizeof(void*)))
 246       return 2;
 247
 248    if (d->num_args > 30 || d->num_results > 1)
 249       return 1; /* unlikely, but ... */
 250
 251    p = (unsigned int*) &arg_vec[1];
 252    for (i = 0; i < (int)(d->num_args); i++) {
 253       switch (d->arg_tys[i]) {
 254
 255          case INT_REP:
 256             ul = (unsigned long)PopTaggedInt();
 257             goto common_int32_or_64;
 258          case WORD_REP:
 259             ul = (unsigned long)PopTaggedWord();
 260             goto common_int32_or_64;
 261          case ADDR_REP:
 262             ul = (unsigned long)(PopTaggedAddr());
 263             goto common_int32_or_64;
 264          case STABLE_REP:
 265             ul = (unsigned long)PopTaggedStablePtr();
 266             common_int32_or_64:
 267             if (sizeof(void*) == 4) {
 268                *(unsigned long *)p = ul; p++; *p++ = 0;
 269                argd_vec[i+1] = 'i';
 270             } else {
 271                *(unsigned long *)p = ul;
 272                p += 2;
 273                argd_vec[i+1] = 'I';
 274             }
 275             break;
 276
 277          case CHAR_REP: {
 278             int j = (int)PopTaggedChar();
 279             *p++ = j; *p++ = 0;
 280             argd_vec[i+1] = 'i';
 281             break;
 282          }
 283          case FLOAT_REP: {
 284             float f = PopTaggedFloat();
 285             *(float*)p = f; p++; *p++ = 0;
 286             argd_vec[i+1] = 'f';
 287             break;
 288          }
 289          case DOUBLE_REP: {
 290             double d = PopTaggedDouble();
 291             *(double*)p = d; p+=2;
 292             argd_vec[i+1] = 'F';
 293             break;
 294          }
 295          default:
 296             return 1;
 297       }
 298    }
 299
 300    if (d->num_results == 0) {
 301       argd_vec[0] = 'i';
 302    } else {
 303       switch (d->result_tys[0]) {
 304          case INT_REP: case WORD_REP: case ADDR_REP: case STABLE_REP:
 305             argd_vec[0] = (sizeof(void*)==4) ? 'i' : 'I'; break;
 306          case CHAR_REP:
 307             argd_vec[0] = 'i'; break;
 308          case FLOAT_REP:
 309             argd_vec[0] = 'f'; break;
 310          case DOUBLE_REP:
 311             argd_vec[0] = 'F'; break;
 312          default:
 313             return 1;
 314       }
 315    }
 316
 317    PushPtr((StgPtr)(*bco));
 318    cap->rCurrentTSO->sp    = MainRegTable.rSp;
 319    cap->rCurrentTSO->su    = MainRegTable.rSu;
 320    cap->rCurrentTSO->splim = MainRegTable.rSpLim;
 321    token = suspendThread(cap);
 322
 323 #if i386_TARGET_ARCH
 324    if (cc == 'c')
 325       universal_call_c_x86_ccall (
 326          d->num_args, (void*)arg_vec, argd_vec, fun );
 327    else if (cc == 's')
 328       universal_call_c_x86_stdcall (
 329          d->num_args, (void*)arg_vec, argd_vec, fun );
 330    else barf ( "ccall(i386): unknown calling convention" );
 331 #else
 332    universal_call_c_generic (
 333       d->num_args, (void*)arg_vec, argd_vec, fun );
 334 #endif
 335
 336    cap = resumeThread(token);
 337    MainRegTable.rSp    = cap->rCurrentTSO->sp;
 338    MainRegTable.rSu    = cap->rCurrentTSO->su;
 339    MainRegTable.rSpLim = cap->rCurrentTSO->splim;
 340    *bco=(StgBCO*)PopPtr();
 341
 342    /* INT, WORD, ADDR, STABLE don't need to do a word-size check
 343       since the result is in the bytes starting at p regardless. */
 344
 345    if (d->num_results > 0) {
 346       p = (unsigned int*) &arg_vec[0];
 347       switch (d->result_tys[0]) {
 348
 349          case INT_REP:
 350             PushTaggedInt ( ((StgInt*)p) [0] );
 351             break;
 352          case WORD_REP:
 353             PushTaggedWord ( ((StgWord*)p) [0] );
 354             break;
 355          case ADDR_REP:
 356             PushTaggedAddr ( ((StgAddr*)p) [0] );
 357             break;
 358          case STABLE_REP:
 359             PushTaggedStablePtr ( ((StgStablePtr*)p) [0] );
 360             break;
 361
 362          case CHAR_REP:
 363             PushTaggedChar ( (StgChar) p[0]);
 364             break;
 365          case FLOAT_REP:
 366             PushTaggedFloat ( ((StgFloat*)p) [0] );
 367             break;
 368          case DOUBLE_REP:
 369             PushTaggedDouble ( ((StgDouble*)p) [0] );
 370             break;
 371
 372          default:
 373             return 1;
 374       }
 375    }
 376
 377    return 0;
 378 }
 379
 380
 381
 382 /* ----------------------------------------------------------------------
 383  * Part the second: CALLING IN -- foreign export {dynamic}
 384  * --------------------------------------------------------------------*/
 385
 386 /* Make it possible for the evaluator to get hold of bytecode
 387    for a given function by name.  Useful but a hack.  Sigh.
 388  */
 389 extern void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s );
 390 extern int /*Bool*/ combined;
 391
 392 /* ----------------------------------------------------------------*
 393  * The implementation for x86_ccall and x86_stdcall.
 394  * ----------------------------------------------------------------*/
 395
 396 static
 397 HaskellObj
 398 unpackArgsAndCallHaskell_x86_nocallconv_wrk ( StgStablePtr stableptr,
 399                                               char* tydesc, char* args)
 400 {
 401    /* Copy args out of the C stack frame in an architecture
 402       dependent fashion, under the direction of the type description
 403       string tydesc.  Dereference the stable pointer, giving the
 404       Haskell function to call.  Build an application of this to
 405       the arguments, and finally wrap primRunST round the whole
 406       thing, since we know it returns an IO type.  Then evaluate
 407       the whole, which leaves nodeOut as the evaluated 'a', where
 408       the type of the function called is .... -> IO a.
 409
 410       We can't immediately unpack the results and return, since
 411       int results need to return in a different register (%eax and
 412       possibly %edx) from float things (%st(0)).  So return nodeOut
 413       to the relevant wrapper function, which knows enough about
 414       the return type to do the Right Thing.
 415
 416       There's no getting round it: this is most heinous hack.
 417    */
 418
 419    HaskellObj      node;
 420    HaskellObj      nodeOut;
 421    SchedulerStatus sstat;
 422
 423    char* resp = tydesc;
 424    char* argp = tydesc;
 425
 426    node = (HaskellObj)deRefStablePtr(stableptr);
 427
 428    if (*argp != ':') argp++;
 429    ASSERT( *argp == ':' );
 430    argp++;
 431    while (*argp) {
 432       switch (*argp) {
 433          case CHAR_REP:
 434             node = rts_apply ( node, rts_mkChar ( *(char*)args ) );
 435             args += 4;
 436             break;
 437          case INT_REP:
 438             node = rts_apply ( node, rts_mkInt ( *(int*)args ) );
 439             args += 4;
 440             break;
 441          case WORD_REP:
 442             node = rts_apply ( node, rts_mkWord ( *(unsigned int*)args ) );
 443             args += 4;
 444             break;
 445          case ADDR_REP:
 446             node = rts_apply ( node, rts_mkAddr ( *(void**)args ) );
 447             args += 4;
 448             break;
 449          case STABLE_REP:
 450             node = rts_apply ( node, rts_mkStablePtr ( *(int*)args ) );
 451             args += 4;
 452             break;
 453          case FLOAT_REP:
 454             node = rts_apply ( node, rts_mkFloat ( *(float*)args ) );
 455             args += 4;
 456             break;
 457          case DOUBLE_REP:
 458             node = rts_apply ( node, rts_mkDouble ( *(double*)args ) );
 459             args += 8;
 460             break;
 461          default:
 462             barf(
 463                "unpackArgsAndCallHaskell_x86_nocallconv: "
 464                "unexpected arg type rep");
 465       }
 466       argp++;
 467    }
 468
 469    if (combined) {
 470       sstat = rts_evalIO ( node, &nodeOut );
 471    } else {
 472       node = rts_apply (
 473                 getHugs_BCO_cptr_for("runST"),
 474                 node );
 475       sstat = rts_eval ( node, &nodeOut );
 476    }
 477
 478    if (sstat != Success)
 479       barf ("unpackArgsAndCallHaskell_x86_nocallconv: eval failed");
 480
 481    return nodeOut;
 482 }
 483
 484
 485 static
 486 double
 487 unpackArgsAndCallHaskell_x86_nocallconv_DOUBLE (
 488       StgStablePtr stableptr, char* tydesc, char* args
 489    )
 490 {
 491    HaskellObj nodeOut
 492       = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
 493            stableptr, tydesc, args
 494         );
 495    /* Return a double.  This return will go into %st(0), which
 496       is unmodified by the adjustor thunk.
 497    */
 498    ASSERT(tydesc[0] == DOUBLE_REP);
 499    return rts_getDouble(nodeOut);
 500 }
 501
 502
 503 static
 504 float
 505 unpackArgsAndCallHaskell_x86_nocallconv_FLOAT (
 506       StgStablePtr stableptr, char* tydesc, char* args
 507    )
 508 {
 509    HaskellObj nodeOut
 510       = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
 511            stableptr, tydesc, args
 512         );
 513    /* Probably could be merged with the double case, since %st(0) is
 514       still the return register.
 515    */
 516    ASSERT(tydesc[0] == FLOAT_REP);
 517    return rts_getFloat(nodeOut);
 518 }
 519
 520
 521 static
 522 unsigned long
 523 unpackArgsAndCallHaskell_x86_nocallconv_INTISH (
 524       StgStablePtr stableptr, char* tydesc, char* args
 525    )
 526 {
 527    HaskellObj nodeOut;
 528    nodeOut = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
 529                 stableptr, tydesc, args
 530              );
 531    /* A complete hack.  We know that all these returns will be
 532       put into %eax (and %edx, if it is a 64-bit return), and
 533       the adjustor thunk will then itself return to the original
 534       (C-world) caller without modifying %eax or %edx, so the
 535       original caller will be a Happy Bunny.
 536    */
 537    switch (*tydesc) {
 538       case ':':        return 0;
 539       case CHAR_REP:   return (unsigned long)rts_getChar(nodeOut);
 540       case INT_REP:    return (unsigned long)rts_getInt(nodeOut);
 541       case WORD_REP:   return (unsigned long)rts_getWord(nodeOut);
 542       case ADDR_REP:   return (unsigned long)rts_getAddr(nodeOut);
 543       case STABLE_REP: return (unsigned long)rts_getStablePtr(nodeOut);
 544       default:
 545          barf(
 546             "unpackArgsAndCallHaskell_x86_nocallconv: "
 547             "unexpected res type rep");
 548    }
 549 }
 550
 551
 552 /* This is a bit subtle, since it can deal with both stdcall
 553    and ccall.  There are two call transitions to consider:
 554
 555    1.  The call to "here".  If it's a ccall, we can return
 556        using 'ret 0' and let the caller remove the args.
 557        If stdcall, we have to return with 'ret N', where
 558        N is the size of the args passed.  N has to be
 559        determined by inspecting the type descriptor string
 560        typestr.
 561
 562    2.  The call to unpackArgsAndCallHaskell_x86_anycallconv_*.
 563        Whether these are done with stdcall or ccall depends on
 564        the conventions applied by the compiler that translated
 565        those procedures.  Fortunately, we can sidestep what it
 566        did by saving esp (in ebx), pushing the three args,
 567        calling unpack..., and restoring esp from ebx.  This
 568        trick assumes that ebx is a callee-saves register, so
 569        its value will be preserved across the unpack... call.
 570 */
 571 static
 572 StgAddr createAdjThunk_x86 ( StgStablePtr stableptr,
 573                              StgAddr      typestr,
 574                              char         callconv )
 575 {
 576    unsigned char* codeblock;
 577    unsigned char* cp;
 578    unsigned int   ch;
 579    unsigned int   nwords;
 580
 581    unsigned char* argp = (unsigned char*)typestr;
 582    unsigned int   ts   = (unsigned int)typestr;
 583    unsigned int   sp   = (unsigned int)stableptr;
 584
 585    if (((char*)typestr)[0] == DOUBLE_REP)
 586       ch = (unsigned int)
 587               &unpackArgsAndCallHaskell_x86_nocallconv_DOUBLE;
 588    else if (((char*)typestr)[0] == FLOAT_REP)
 589       ch = (unsigned int)
 590               &unpackArgsAndCallHaskell_x86_nocallconv_FLOAT;
 591    else
 592       ch = (unsigned int)
 593               &unpackArgsAndCallHaskell_x86_nocallconv_INTISH;
 594
 595    codeblock = malloc ( 0x26 );
 596    if (!codeblock)
 597       barf ( "createAdjThunk_x86: can't malloc memory\n");
 598
 599    if (callconv == 's') {
 600       nwords = 0;
 601       if (*argp != ':') argp++;
 602       ASSERT( *argp == ':' );
 603       argp++;
 604       while (*argp) {
 605          switch (*argp) {
 606             case CHAR_REP: case INT_REP: case WORD_REP:
 607             case ADDR_REP: case STABLE_REP: case FLOAT_REP:
 608                nwords += 4; break;
 609             case DOUBLE_REP:
 610                nwords += 8; break;
 611             default:
 612                barf("createAdjThunk_x86: unexpected type descriptor");
 613          }
 614          argp++;
 615       }
 616    } else
 617    if (callconv == 'c') {
 618       nwords = 0;
 619    } else {
 620       barf ( "createAdjThunk_x86: unknown calling convention\n");
 621    }
 622
 623    cp = codeblock;
 624    /*
 625       0000 53           pushl %ebx        # save caller's registers
 626       0001 51           pushl %ecx
 627       0002 56           pushl %esi
 628       0003 57           pushl %edi
 629       0004 55           pushl %ebp
 630       0005 89E0         movl %esp,%eax    # sp -> eax
 631       0007 83C018       addl $24,%eax     # move eax back over 5 saved regs + retaddr
 632       000a 89E3         movl %esp,%ebx    # remember sp before pushing args
 633       000c 50           pushl %eax        # push arg-block addr
 634       000d 6844332211   pushl $0x11223344 # push addr of type descr string
 635       0012 6877665544   pushl $0x44556677 # push stableptr to closure
 636       0017 E8BBAA9988   call 0x8899aabb   # SEE COMMENT BELOW
 637                                           # return value is in %eax, or %eax:%edx,
 638                                           # or %st(0), so don't trash these regs
 639                                           # between here and 'ret'
 640       001c 89DC         movl %ebx,%esp    # restore sp from remembered value
 641       001e 5D           popl %ebp         # restore caller's registers
 642       001f 5F           popl %edi
 643       0020 5E           popl %esi
 644       0021 59           popl %ecx
 645       0022 5B           popl %ebx
 646       0023 C27766       ret  $0x6677      # return, clearing args if stdcall
 647    */
 648    *cp++ = 0x53;
 649    *cp++ = 0x51;
 650    *cp++ = 0x56;
 651    *cp++ = 0x57;
 652    *cp++ = 0x55;
 653    *cp++ = 0x89; *cp++ = 0xE0;
 654    *cp++ = 0x83; *cp++ = 0xC0; *cp++ = 0x18;
 655    *cp++ = 0x89; *cp++ = 0xE3;
 656    *cp++ = 0x50;
 657    *cp++ = 0x68; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts;
 658    *cp++ = 0x68; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp;
 659
 660    /* call address needs to be: displacement relative to next insn */
 661    ch = ch - ( ((unsigned int)cp) + 5);
 662    *cp++ = 0xE8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;
 663
 664    *cp++ = 0x89; *cp++ = 0xDC;
 665    *cp++ = 0x5D;
 666    *cp++ = 0x5F;
 667    *cp++ = 0x5E;
 668    *cp++ = 0x59;
 669    *cp++ = 0x5B;
 670    *cp++ = 0xC2; *cp++=nwords;nwords>>=8; *cp++=nwords;
 671
 672    return codeblock;
 673 }
 674
 675
 676 /* ----------------------------------------------------------------*
 677  * The only function involved in foreign-export that needs to be
 678  * visible outside this file.
 679  * ----------------------------------------------------------------*/
 680
 681 StgAddr createAdjThunk ( StgStablePtr stableptr,
 682                          StgAddr      typestr,
 683                          StgChar      callconv )
 684 {
 685    return
 686 #if i386_TARGET_ARCH
 687       createAdjThunk_x86 ( stableptr, typestr, callconv );
 688 #else
 689       0;
 690 #warning foreign export not implemented on this architecture
 691 #endif
 692 }
 693
 694
 695 #endif /* INTERPRETER */
 696