ghc/rts/ForeignCall.c

   1
   2 /* -----------------------------------------------------------------------------
   3  * $Id: ForeignCall.c,v 1.19 2000/10/09 10:28:33 daan 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    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    *bco=(StgBCO*)PopPtr();
 339
 340    /* INT, WORD, ADDR, STABLE don't need to do a word-size check
 341       since the result is in the bytes starting at p regardless. */
 342
 343    if (d->num_results > 0) {
 344       p = (unsigned int*) &arg_vec[0];
 345       switch (d->result_tys[0]) {
 346
 347          case INT_REP:
 348             PushTaggedInt ( ((StgInt*)p) [0] );
 349             break;
 350          case WORD_REP:
 351             PushTaggedWord ( ((StgWord*)p) [0] );
 352             break;
 353          case ADDR_REP:
 354             PushTaggedAddr ( ((StgAddr*)p) [0] );
 355             break;
 356          case STABLE_REP:
 357             PushTaggedStablePtr ( ((StgStablePtr*)p) [0] );
 358             break;
 359
 360          case CHAR_REP:
 361             PushTaggedChar ( (StgChar) p[0]);
 362             break;
 363          case FLOAT_REP:
 364             PushTaggedFloat ( ((StgFloat*)p) [0] );
 365             break;
 366          case DOUBLE_REP:
 367             PushTaggedDouble ( ((StgDouble*)p) [0] );
 368             break;
 369
 370          default:
 371             return 1;
 372       }
 373    }
 374
 375    return 0;
 376 }
 377
 378
 379
 380 /* ----------------------------------------------------------------------
 381  * Part the second: CALLING IN -- foreign export {dynamic}
 382  * --------------------------------------------------------------------*/
 383
 384 /* Make it possible for the evaluator to get hold of bytecode
 385    for a given function by name.  Useful but a hack.  Sigh.
 386  */
 387 extern void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s );
 388 extern int /*Bool*/ combined;
 389
 390 /* ----------------------------------------------------------------*
 391  * The implementation for x86_ccall and x86_stdcall.
 392  * ----------------------------------------------------------------*/
 393
 394 static
 395 HaskellObj
 396 unpackArgsAndCallHaskell_x86_nocallconv_wrk ( StgStablePtr stableptr,
 397                                               char* tydesc, char* args)
 398 {
 399    /* Copy args out of the C stack frame in an architecture
 400       dependent fashion, under the direction of the type description
 401       string tydesc.  Dereference the stable pointer, giving the
 402       Haskell function to call.  Build an application of this to
 403       the arguments, and finally wrap primRunST round the whole
 404       thing, since we know it returns an IO type.  Then evaluate
 405       the whole, which leaves nodeOut as the evaluated 'a', where
 406       the type of the function called is .... -> IO a.
 407
 408       We can't immediately unpack the results and return, since
 409       int results need to return in a different register (%eax and
 410       possibly %edx) from float things (%st(0)).  So return nodeOut
 411       to the relevant wrapper function, which knows enough about
 412       the return type to do the Right Thing.
 413
 414       There's no getting round it: this is most heinous hack.
 415    */
 416
 417    HaskellObj      node;
 418    HaskellObj      nodeOut;
 419    SchedulerStatus sstat;
 420
 421    char* resp = tydesc;
 422    char* argp = tydesc;
 423
 424    node = (HaskellObj)deRefStablePtr(stableptr);
 425
 426    if (*argp != ':') argp++;
 427    ASSERT( *argp == ':' );
 428    argp++;
 429    while (*argp) {
 430       switch (*argp) {
 431          case CHAR_REP:
 432             node = rts_apply ( node, rts_mkChar ( *(unsigned int*)args ) );
 433             args += 4;
 434             break;
 435          case INT_REP:
 436             node = rts_apply ( node, rts_mkInt ( *(int*)args ) );
 437             args += 4;
 438             break;
 439          case WORD_REP:
 440             node = rts_apply ( node, rts_mkWord ( *(unsigned int*)args ) );
 441             args += 4;
 442             break;
 443          case ADDR_REP:
 444             node = rts_apply ( node, rts_mkAddr ( *(void**)args ) );
 445             args += 4;
 446             break;
 447          case STABLE_REP:
 448             node = rts_apply ( node, rts_mkStablePtr ( *(int*)args ) );
 449             args += 4;
 450             break;
 451          case FLOAT_REP:
 452             node = rts_apply ( node, rts_mkFloat ( *(float*)args ) );
 453             args += 4;
 454             break;
 455          case DOUBLE_REP:
 456             node = rts_apply ( node, rts_mkDouble ( *(double*)args ) );
 457             args += 8;
 458             break;
 459          default:
 460             barf(
 461                "unpackArgsAndCallHaskell_x86_nocallconv: "
 462                "unexpected arg type rep");
 463       }
 464       argp++;
 465    }
 466
 467    if (combined) {
 468       sstat = rts_evalIO ( node, &nodeOut );
 469    } else {
 470       node = rts_apply (
 471                 getHugs_BCO_cptr_for("runST"),
 472                 node );
 473       sstat = rts_eval ( node, &nodeOut );
 474    }
 475
 476    if (sstat != Success)
 477       barf ("unpackArgsAndCallHaskell_x86_nocallconv: eval failed");
 478
 479    return nodeOut;
 480 }
 481
 482
 483 static
 484 double
 485 unpackArgsAndCallHaskell_x86_nocallconv_DOUBLE (
 486       StgStablePtr stableptr, char* tydesc, char* args
 487    )
 488 {
 489    HaskellObj nodeOut
 490       = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
 491            stableptr, tydesc, args
 492         );
 493    /* Return a double.  This return will go into %st(0), which
 494       is unmodified by the adjustor thunk.
 495    */
 496    ASSERT(tydesc[0] == DOUBLE_REP);
 497    return rts_getDouble(nodeOut);
 498 }
 499
 500
 501 static
 502 float
 503 unpackArgsAndCallHaskell_x86_nocallconv_FLOAT (
 504       StgStablePtr stableptr, char* tydesc, char* args
 505    )
 506 {
 507    HaskellObj nodeOut
 508       = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
 509            stableptr, tydesc, args
 510         );
 511    /* Probably could be merged with the double case, since %st(0) is
 512       still the return register.
 513    */
 514    ASSERT(tydesc[0] == FLOAT_REP);
 515    return rts_getFloat(nodeOut);
 516 }
 517
 518
 519 static
 520 unsigned long
 521 unpackArgsAndCallHaskell_x86_nocallconv_INTISH (
 522       StgStablePtr stableptr, char* tydesc, char* args
 523    )
 524 {
 525    HaskellObj nodeOut;
 526    nodeOut = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
 527                 stableptr, tydesc, args
 528              );
 529    /* A complete hack.  We know that all these returns will be
 530       put into %eax (and %edx, if it is a 64-bit return), and
 531       the adjustor thunk will then itself return to the original
 532       (C-world) caller without modifying %eax or %edx, so the
 533       original caller will be a Happy Bunny.
 534    */
 535    switch (*tydesc) {
 536       case ':':        return 0;
 537       case CHAR_REP:   return (unsigned long)rts_getChar(nodeOut);
 538       case INT_REP:    return (unsigned long)rts_getInt(nodeOut);
 539       case WORD_REP:   return (unsigned long)rts_getWord(nodeOut);
 540       case ADDR_REP:   return (unsigned long)rts_getAddr(nodeOut);
 541       case STABLE_REP: return (unsigned long)rts_getStablePtr(nodeOut);
 542       default:
 543          barf(
 544             "unpackArgsAndCallHaskell_x86_nocallconv: "
 545             "unexpected res type rep");
 546    }
 547 }
 548
 549
 550 /* This is a bit subtle, since it can deal with both stdcall
 551    and ccall.  There are two call transitions to consider:
 552
 553    1.  The call to "here".  If it's a ccall, we can return
 554        using 'ret 0' and let the caller remove the args.
 555        If stdcall, we have to return with 'ret N', where
 556        N is the size of the args passed.  N has to be
 557        determined by inspecting the type descriptor string
 558        typestr.
 559
 560    2.  The call to unpackArgsAndCallHaskell_x86_anycallconv_*.
 561        Whether these are done with stdcall or ccall depends on
 562        the conventions applied by the compiler that translated
 563        those procedures.  Fortunately, we can sidestep what it
 564        did by saving esp (in ebx), pushing the three args,
 565        calling unpack..., and restoring esp from ebx.  This
 566        trick assumes that ebx is a callee-saves register, so
 567        its value will be preserved across the unpack... call.
 568 */
 569 static
 570 StgAddr createAdjThunk_x86 ( StgStablePtr stableptr,
 571                              StgAddr      typestr,
 572                              char         callconv )
 573 {
 574    unsigned char* codeblock;
 575    unsigned char* cp;
 576    unsigned int   ch;
 577    unsigned int   nwords;
 578
 579    unsigned char* argp = (unsigned char*)typestr;
 580    unsigned int   ts   = (unsigned int)typestr;
 581    unsigned int   sp   = (unsigned int)stableptr;
 582
 583    if (((char*)typestr)[0] == DOUBLE_REP)
 584       ch = (unsigned int)
 585               &unpackArgsAndCallHaskell_x86_nocallconv_DOUBLE;
 586    else if (((char*)typestr)[0] == FLOAT_REP)
 587       ch = (unsigned int)
 588               &unpackArgsAndCallHaskell_x86_nocallconv_FLOAT;
 589    else
 590       ch = (unsigned int)
 591               &unpackArgsAndCallHaskell_x86_nocallconv_INTISH;
 592
 593    codeblock = malloc ( 0x26 );
 594    if (!codeblock)
 595       barf ( "createAdjThunk_x86: can't malloc memory\n");
 596
 597    if (callconv == 's') {
 598       nwords = 0;
 599       if (*argp != ':') argp++;
 600       ASSERT( *argp == ':' );
 601       argp++;
 602       while (*argp) {
 603          switch (*argp) {
 604             case CHAR_REP: case INT_REP: case WORD_REP:
 605             case ADDR_REP: case STABLE_REP: case FLOAT_REP:
 606                nwords += 4; break;
 607             case DOUBLE_REP:
 608                nwords += 8; break;
 609             default:
 610                barf("createAdjThunk_x86: unexpected type descriptor");
 611          }
 612          argp++;
 613       }
 614    } else
 615    if (callconv == 'c') {
 616       nwords = 0;
 617    } else {
 618       barf ( "createAdjThunk_x86: unknown calling convention\n");
 619    }
 620
 621    cp = codeblock;
 622    /*
 623       0000 53           pushl %ebx        # save caller's registers
 624       0001 51           pushl %ecx
 625       0002 56           pushl %esi
 626       0003 57           pushl %edi
 627       0004 55           pushl %ebp
 628       0005 89E0         movl %esp,%eax    # sp -> eax
 629       0007 83C018       addl $24,%eax     # move eax back over 5 saved regs + retaddr
 630       000a 89E3         movl %esp,%ebx    # remember sp before pushing args
 631       000c 50           pushl %eax        # push arg-block addr
 632       000d 6844332211   pushl $0x11223344 # push addr of type descr string
 633       0012 6877665544   pushl $0x44556677 # push stableptr to closure
 634       0017 E8BBAA9988   call 0x8899aabb   # SEE COMMENT BELOW
 635                                           # return value is in %eax, or %eax:%edx,
 636                                           # or %st(0), so don't trash these regs
 637                                           # between here and 'ret'
 638       001c 89DC         movl %ebx,%esp    # restore sp from remembered value
 639       001e 5D           popl %ebp         # restore caller's registers
 640       001f 5F           popl %edi
 641       0020 5E           popl %esi
 642       0021 59           popl %ecx
 643       0022 5B           popl %ebx
 644       0023 C27766       ret  $0x6677      # return, clearing args if stdcall
 645    */
 646    *cp++ = 0x53;
 647    *cp++ = 0x51;
 648    *cp++ = 0x56;
 649    *cp++ = 0x57;
 650    *cp++ = 0x55;
 651    *cp++ = 0x89; *cp++ = 0xE0;
 652    *cp++ = 0x83; *cp++ = 0xC0; *cp++ = 0x18;
 653    *cp++ = 0x89; *cp++ = 0xE3;
 654    *cp++ = 0x50;
 655    *cp++ = 0x68; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts;
 656    *cp++ = 0x68; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp;
 657
 658    /* call address needs to be: displacement relative to next insn */
 659    ch = ch - ( ((unsigned int)cp) + 5);
 660    *cp++ = 0xE8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;
 661
 662    *cp++ = 0x89; *cp++ = 0xDC;
 663    *cp++ = 0x5D;
 664    *cp++ = 0x5F;
 665    *cp++ = 0x5E;
 666    *cp++ = 0x59;
 667    *cp++ = 0x5B;
 668    *cp++ = 0xC2; *cp++=nwords;nwords>>=8; *cp++=nwords;
 669
 670    return codeblock;
 671 }
 672
 673
 674 /* ----------------------------------------------------------------*
 675  * The only function involved in foreign-export that needs to be
 676  * visible outside this file.
 677  * ----------------------------------------------------------------*/
 678
 679 StgAddr createAdjThunk ( StgStablePtr stableptr,
 680                          StgAddr      typestr,
 681                          StgChar      callconv )
 682 {
 683    return
 684 #if i386_TARGET_ARCH
 685       createAdjThunk_x86 ( stableptr, typestr, callconv );
 686 #else
 687       0;
 688 #warning foreign export not implemented on this architecture
 689 #endif
 690 }
 691
 692
 693 #endif /* INTERPRETER */
 694