rts/Adjustor.c

   1 /* -----------------------------------------------------------------------------
   2  * Foreign export adjustor thunks
   3  *
   4  * Copyright (c) 1998.
   5  *
   6  * ---------------------------------------------------------------------------*/
   7
   8 /* A little bit of background...
   9
  10 An adjustor thunk is a dynamically allocated code snippet that allows
  11 Haskell closures to be viewed as C function pointers.
  12
  13 Stable pointers provide a way for the outside world to get access to,
  14 and evaluate, Haskell heap objects, with the RTS providing a small
  15 range of ops for doing so. So, assuming we've got a stable pointer in
  16 our hand in C, we can jump into the Haskell world and evaluate a callback
  17 procedure, say. This works OK in some cases where callbacks are used, but
  18 does require the external code to know about stable pointers and how to deal
  19 with them. We'd like to hide the Haskell-nature of a callback and have it
  20 be invoked just like any other C function pointer.
  21
  22 Enter adjustor thunks. An adjustor thunk is a little piece of code
  23 that's generated on-the-fly (one per Haskell closure being exported)
  24 that, when entered using some 'universal' calling convention (e.g., the
  25 C calling convention on platform X), pushes an implicit stable pointer
  26 (to the Haskell callback) before calling another (static) C function stub
  27 which takes care of entering the Haskell code via its stable pointer.
  28
  29 An adjustor thunk is allocated on the C heap, and is called from within
  30 Haskell just before handing out the function pointer to the Haskell (IO)
  31 action. User code should never have to invoke it explicitly.
  32
  33 An adjustor thunk differs from a C function pointer in one respect: when
  34 the code is through with it, it has to be freed in order to release Haskell
  35 and C resources. Failure to do so will result in memory leaks on both the C and
  36 Haskell side.
  37 */
  38
  39 #include "PosixSource.h"
  40 #include "Rts.h"
  41
  42 #include "RtsUtils.h"
  43 #include "Stable.h"
  44
  45 #if defined(USE_LIBFFI_FOR_ADJUSTORS)
  46
  47 #include "ffi.h"
  48 #include <string.h>
  49
  50 void
  51 freeHaskellFunctionPtr(void* ptr)
  52 {
  53     ffi_closure *cl;
  54
  55     cl = (ffi_closure*)ptr;
  56     freeStablePtr(cl->user_data);
  57     stgFree(cl->cif->arg_types);
  58     stgFree(cl->cif);
  59     freeExec(cl);
  60 }
  61
  62 static ffi_type * char_to_ffi_type(char c)
  63 {
  64     switch (c) {
  65     case 'v':  return &ffi_type_void;
  66     case 'f':  return &ffi_type_float;
  67     case 'd':  return &ffi_type_double;
  68     case 'L':  return &ffi_type_sint64;
  69     case 'l':  return &ffi_type_uint64;
  70     case 'W':  return &ffi_type_sint32;
  71     case 'w':  return &ffi_type_uint32;
  72     case 'S':  return &ffi_type_sint16;
  73     case 's':  return &ffi_type_uint16;
  74     case 'B':  return &ffi_type_sint8;
  75     case 'b':  return &ffi_type_uint8;
  76     case 'p':  return &ffi_type_pointer;
  77     default:   barf("char_to_ffi_type: unknown type '%c'", c);
  78     }
  79 }
  80
  81 void*
  82 createAdjustor (int cconv,
  83                 StgStablePtr hptr,
  84                 StgFunPtr wptr,
  85                 char *typeString)
  86 {
  87     ffi_cif *cif;
  88     ffi_type **arg_types;
  89     nat n_args, i;
  90     ffi_type *result_type;
  91     ffi_closure *cl;
  92     int r, abi;
  93     void *code;
  94
  95     n_args = strlen(typeString) - 1;
  96     cif = stgMallocBytes(sizeof(ffi_cif), "createAdjustor");
  97     arg_types = stgMallocBytes(n_args * sizeof(ffi_type*), "createAdjustor");
  98
  99     result_type = char_to_ffi_type(typeString[0]);
 100     for (i=0; i < n_args; i++) {
 101         arg_types[i] = char_to_ffi_type(typeString[i+1]);
 102     }
 103     switch (cconv) {
 104 #ifdef mingw32_TARGET_OS
 105     case 0: /* stdcall */
 106         abi = FFI_STDCALL;
 107         break;
 108 #endif
 109     case 1: /* ccall */
 110         abi = FFI_DEFAULT_ABI;
 111         break;
 112     default:
 113         barf("createAdjustor: convention %d not supported on this platform", cconv);
 114     }
 115
 116     r = ffi_prep_cif(cif, abi, n_args, result_type, arg_types);
 117     if (r != FFI_OK) barf("ffi_prep_cif failed: %d", r);
 118
 119     cl = allocateExec(sizeof(ffi_closure), &code);
 120     if (cl == NULL) {
 121         barf("createAdjustor: failed to allocate memory");
 122     }
 123
 124     r = ffi_prep_closure(cl, cif, (void*)wptr, hptr/*userdata*/);
 125     if (r != FFI_OK) barf("ffi_prep_closure failed: %d", r);
 126
 127     return (void*)code;
 128 }
 129
 130 #else // To end of file...
 131
 132 #if defined(_WIN32)
 133 #include <windows.h>
 134 #endif
 135
 136 #if defined(powerpc_HOST_ARCH) && defined(linux_HOST_OS)
 137 #include <string.h>
 138 #endif
 139
 140 #ifdef LEADING_UNDERSCORE
 141 #define UNDERSCORE "_"
 142 #else
 143 #define UNDERSCORE ""
 144 #endif
 145 #if defined(i386_HOST_ARCH) && !defined(darwin_HOST_OS)
 146 /*
 147   Now here's something obscure for you:
 148
 149   When generating an adjustor thunk that uses the C calling
 150   convention, we have to make sure that the thunk kicks off
 151   the process of jumping into Haskell with a tail jump. Why?
 152   Because as a result of jumping in into Haskell we may end
 153   up freeing the very adjustor thunk we came from using
 154   freeHaskellFunctionPtr(). Hence, we better not return to
 155   the adjustor code on our way  out, since it could by then
 156   point to junk.
 157
 158   The fix is readily at hand, just include the opcodes
 159   for the C stack fixup code that we need to perform when
 160   returning in some static piece of memory and arrange
 161   to return to it before tail jumping from the adjustor thunk.
 162 */
 163 static void  GNUC3_ATTRIBUTE(used) obscure_ccall_wrapper(void)
 164 {
 165   __asm__ (
 166      ".globl " UNDERSCORE "obscure_ccall_ret_code\n"
 167      UNDERSCORE "obscure_ccall_ret_code:\n\t"
 168      "addl $0x4, %esp\n\t"
 169      "ret"
 170    );
 171 }
 172 extern void obscure_ccall_ret_code(void);
 173
 174 #endif
 175
 176 #if defined(x86_64_HOST_ARCH)
 177 static void GNUC3_ATTRIBUTE(used) obscure_ccall_wrapper(void)
 178 {
 179   __asm__ (
 180    ".globl " UNDERSCORE "obscure_ccall_ret_code\n"
 181    UNDERSCORE "obscure_ccall_ret_code:\n\t"
 182    "addq $0x8, %rsp\n\t"
 183    "ret"
 184   );
 185 }
 186 extern void obscure_ccall_ret_code(void);
 187 #endif
 188
 189 #if defined(alpha_HOST_ARCH)
 190 /* To get the definition of PAL_imb: */
 191 # if defined(linux_HOST_OS)
 192 #  include <asm/pal.h>
 193 # else
 194 #  include <machine/pal.h>
 195 # endif
 196 #endif
 197
 198 #if defined(ia64_HOST_ARCH)
 199
 200 /* Layout of a function descriptor */
 201 typedef struct _IA64FunDesc {
 202     StgWord64 ip;
 203     StgWord64 gp;
 204 } IA64FunDesc;
 205
 206 static void *
 207 stgAllocStable(size_t size_in_bytes, StgStablePtr *stable)
 208 {
 209   StgArrWords* arr;
 210   nat data_size_in_words, total_size_in_words;
 211
 212   /* round up to a whole number of words */
 213   data_size_in_words  = (size_in_bytes + sizeof(W_) + 1) / sizeof(W_);
 214   total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
 215
 216   /* allocate and fill it in */
 217   arr = (StgArrWords *)allocate(total_size_in_words);
 218   SET_ARR_HDR(arr, &stg_ARR_WORDS_info, CCCS, data_size_in_words);
 219
 220   /* obtain a stable ptr */
 221   *stable = getStablePtr((StgPtr)arr);
 222
 223   /* and return a ptr to the goods inside the array */
 224   return(&(arr->payload));
 225 }
 226 #endif
 227
 228 #if defined(powerpc_HOST_ARCH) && defined(linux_HOST_OS)
 229 __asm__("obscure_ccall_ret_code:\n\t"
 230         "lwz 1,0(1)\n\t"
 231         "lwz 0,4(1)\n\t"
 232         "mtlr 0\n\t"
 233         "blr");
 234 extern void obscure_ccall_ret_code(void);
 235 #endif
 236
 237 #if defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH)
 238 #if !(defined(powerpc_HOST_ARCH) && defined(linux_HOST_OS))
 239
 240 /* !!! !!! WARNING: !!! !!!
 241  * This structure is accessed from AdjustorAsm.s
 242  * Any changes here have to be mirrored in the offsets there.
 243  */
 244
 245 typedef struct AdjustorStub {
 246 #if defined(powerpc_HOST_ARCH) && defined(darwin_HOST_OS)
 247     unsigned        lis;
 248     unsigned        ori;
 249     unsigned        lwz;
 250     unsigned        mtctr;
 251     unsigned        bctr;
 252     StgFunPtr       code;
 253 #elif defined(powerpc64_HOST_ARCH) && defined(darwin_HOST_OS)
 254         /* powerpc64-darwin: just guessing that it won't use fundescs. */
 255     unsigned        lis;
 256     unsigned        ori;
 257     unsigned        rldimi;
 258     unsigned        oris;
 259     unsigned        ori2;
 260     unsigned        lwz;
 261     unsigned        mtctr;
 262     unsigned        bctr;
 263     StgFunPtr       code;
 264 #else
 265         /* fundesc-based ABIs */
 266 #define         FUNDESCS
 267     StgFunPtr       code;
 268     struct AdjustorStub
 269                     *toc;
 270     void            *env;
 271 #endif
 272     StgStablePtr    hptr;
 273     StgFunPtr       wptr;
 274     StgInt          negative_framesize;
 275     StgInt          extrawords_plus_one;
 276 } AdjustorStub;
 277
 278 #endif
 279 #endif
 280
 281 #if defined(i386_HOST_ARCH) && defined(darwin_HOST_OS)
 282
 283 /* !!! !!! WARNING: !!! !!!
 284  * This structure is accessed from AdjustorAsm.s
 285  * Any changes here have to be mirrored in the offsets there.
 286  */
 287
 288 typedef struct AdjustorStub {
 289     unsigned char   call[8];
 290     StgStablePtr    hptr;
 291     StgFunPtr       wptr;
 292     StgInt          frame_size;
 293     StgInt          argument_size;
 294 } AdjustorStub;
 295 #endif
 296
 297 #if (defined(i386_HOST_ARCH) && defined(darwin_HOST_OS)) || defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH)
 298 static int totalArgumentSize(char *typeString)
 299 {
 300     int sz = 0;
 301     while(*typeString)
 302     {
 303         char t = *typeString++;
 304
 305         switch(t)
 306         {
 307                 // on 32-bit platforms, Double and Int64 occupy two words.
 308             case 'd':
 309             case 'l':
 310             case 'L':
 311                 if(sizeof(void*) == 4)
 312                 {
 313                     sz += 2;
 314                     break;
 315                 }
 316                 // everything else is one word.
 317             default:
 318                 sz += 1;
 319         }
 320     }
 321     return sz;
 322 }
 323 #endif
 324
 325 void*
 326 createAdjustor(int cconv, StgStablePtr hptr,
 327                StgFunPtr wptr,
 328                char *typeString
 329 #if !defined(powerpc_HOST_ARCH) && !defined(powerpc64_HOST_ARCH) && !defined(x86_64_HOST_ARCH)
 330                   STG_UNUSED
 331 #endif
 332               )
 333 {
 334   void *adjustor = NULL;
 335   void *code;
 336
 337   switch (cconv)
 338   {
 339   case 0: /* _stdcall */
 340 #if defined(i386_HOST_ARCH) && !defined(darwin_HOST_OS)
 341     /* Magic constant computed by inspecting the code length of
 342        the following assembly language snippet
 343        (offset and machine code prefixed):
 344
 345      <0>:       58                popl   %eax              # temp. remove ret addr..
 346      <1>:       68 fd fc fe fa    pushl  0xfafefcfd        # constant is large enough to
 347                                                            # hold a StgStablePtr
 348      <6>:       50                pushl  %eax              # put back ret. addr
 349      <7>:       b8 fa ef ff 00    movl   $0x00ffeffa, %eax # load up wptr
 350      <c>:       ff e0             jmp    %eax              # and jump to it.
 351                 # the callee cleans up the stack
 352     */
 353     adjustor = allocateExec(14,&code);
 354     {
 355         unsigned char *const adj_code = (unsigned char *)adjustor;
 356         adj_code[0x00] = (unsigned char)0x58;  /* popl %eax  */
 357
 358         adj_code[0x01] = (unsigned char)0x68;  /* pushl hptr (which is a dword immediate ) */
 359         *((StgStablePtr*)(adj_code + 0x02)) = (StgStablePtr)hptr;
 360
 361         adj_code[0x06] = (unsigned char)0x50; /* pushl %eax */
 362
 363         adj_code[0x07] = (unsigned char)0xb8; /* movl  $wptr, %eax */
 364         *((StgFunPtr*)(adj_code + 0x08)) = (StgFunPtr)wptr;
 365
 366         adj_code[0x0c] = (unsigned char)0xff; /* jmp %eax */
 367         adj_code[0x0d] = (unsigned char)0xe0;
 368     }
 369 #endif
 370     break;
 371
 372   case 1: /* _ccall */
 373 #if defined(i386_HOST_ARCH) && !defined(darwin_HOST_OS)
 374   /* Magic constant computed by inspecting the code length of
 375      the following assembly language snippet
 376      (offset and machine code prefixed):
 377
 378   <00>: 68 ef be ad de     pushl  $0xdeadbeef      # constant is large enough to
 379                                                    # hold a StgStablePtr
 380   <05>: b8 fa ef ff 00     movl   $0x00ffeffa, %eax # load up wptr
 381   <0a>: 68 ef be ad de     pushl  $obscure_ccall_ret_code # push the return address
 382   <0f>: ff e0              jmp    *%eax            # jump to wptr
 383
 384     The ccall'ing version is a tad different, passing in the return
 385     address of the caller to the auto-generated C stub (which enters
 386     via the stable pointer.) (The auto-generated C stub is in on this
 387     game, don't worry :-)
 388
 389     See the comment next to obscure_ccall_ret_code why we need to
 390     perform a tail jump instead of a call, followed by some C stack
 391     fixup.
 392
 393     Note: The adjustor makes the assumption that any return value
 394     coming back from the C stub is not stored on the stack.
 395     That's (thankfully) the case here with the restricted set of
 396     return types that we support.
 397   */
 398     adjustor = allocateExec(17,&code);
 399     {
 400         unsigned char *const adj_code = (unsigned char *)adjustor;
 401
 402         adj_code[0x00] = (unsigned char)0x68;  /* pushl hptr (which is a dword immediate ) */
 403         *((StgStablePtr*)(adj_code+0x01)) = (StgStablePtr)hptr;
 404
 405         adj_code[0x05] = (unsigned char)0xb8;  /* movl  $wptr, %eax */
 406         *((StgFunPtr*)(adj_code + 0x06)) = (StgFunPtr)wptr;
 407
 408         adj_code[0x0a] = (unsigned char)0x68;  /* pushl obscure_ccall_ret_code */
 409         *((StgFunPtr*)(adj_code + 0x0b)) =
 410                         (StgFunPtr)obscure_ccall_ret_code;
 411
 412         adj_code[0x0f] = (unsigned char)0xff; /* jmp *%eax */
 413         adj_code[0x10] = (unsigned char)0xe0;
 414     }
 415 #elif defined(i386_HOST_ARCH) && defined(darwin_HOST_OS)
 416     {
 417         /*
 418           What's special about Darwin/Mac OS X on i386?
 419           It wants the stack to stay 16-byte aligned.
 420
 421           We offload most of the work to AdjustorAsm.S.
 422         */
 423         AdjustorStub *adjustorStub = allocateExec(sizeof(AdjustorStub),&code);
 424         adjustor = adjustorStub;
 425
 426         extern void adjustorCode(void);
 427         int sz = totalArgumentSize(typeString);
 428
 429         adjustorStub->call[0] = 0xe8;
 430         *(long*)&adjustorStub->call[1] = ((char*)&adjustorCode) - ((char*)adjustorStub + 5);
 431         adjustorStub->hptr = hptr;
 432         adjustorStub->wptr = wptr;
 433
 434             // The adjustor puts the following things on the stack:
 435             // 1.) %ebp link
 436             // 2.) padding and (a copy of) the arguments
 437             // 3.) a dummy argument
 438             // 4.) hptr
 439             // 5.) return address (for returning to the adjustor)
 440             // All these have to add up to a multiple of 16.
 441
 442             // first, include everything in frame_size
 443         adjustorStub->frame_size = sz * 4 + 16;
 444             // align to 16 bytes
 445         adjustorStub->frame_size = (adjustorStub->frame_size + 15) & ~15;
 446             // only count 2.) and 3.) as part of frame_size
 447         adjustorStub->frame_size -= 12;
 448         adjustorStub->argument_size = sz;
 449     }
 450
 451 #elif defined(x86_64_HOST_ARCH)
 452     /*
 453       stack at call:
 454                argn
 455                ...
 456                arg7
 457                return address
 458                %rdi,%rsi,%rdx,%rcx,%r8,%r9 = arg0..arg6
 459
 460       if there are <6 integer args, then we can just push the
 461       StablePtr into %edi and shuffle the other args up.
 462
 463       If there are >=6 integer args, then we have to flush one arg
 464       to the stack, and arrange to adjust the stack ptr on return.
 465       The stack will be rearranged to this:
 466
 467              argn
 468              ...
 469              arg7
 470              return address  *** <-- dummy arg in stub fn.
 471              arg6
 472              obscure_ccall_ret_code
 473
 474       This unfortunately means that the type of the stub function
 475       must have a dummy argument for the original return address
 476       pointer inserted just after the 6th integer argument.
 477
 478       Code for the simple case:
 479
 480    0:   4d 89 c1                mov    %r8,%r9
 481    3:   49 89 c8                mov    %rcx,%r8
 482    6:   48 89 d1                mov    %rdx,%rcx
 483    9:   48 89 f2                mov    %rsi,%rdx
 484    c:   48 89 fe                mov    %rdi,%rsi
 485    f:   48 8b 3d 0a 00 00 00    mov    10(%rip),%rdi
 486   16:   ff 25 0c 00 00 00       jmpq   *12(%rip)
 487   ...
 488   20: .quad 0  # aligned on 8-byte boundary
 489   28: .quad 0  # aligned on 8-byte boundary
 490
 491
 492   And the version for >=6 integer arguments:
 493
 494    0:   41 51                   push   %r9
 495    2:   ff 35 20 00 00 00       pushq  32(%rip)        # 28 <ccall_adjustor+0x28>
 496    8:   4d 89 c1                mov    %r8,%r9
 497    b:   49 89 c8                mov    %rcx,%r8
 498    e:   48 89 d1                mov    %rdx,%rcx
 499   11:   48 89 f2                mov    %rsi,%rdx
 500   14:   48 89 fe                mov    %rdi,%rsi
 501   17:   48 8b 3d 12 00 00 00    mov    18(%rip),%rdi        # 30 <ccall_adjustor+0x30>
 502   1e:   ff 25 14 00 00 00       jmpq   *20(%rip)        # 38 <ccall_adjustor+0x38>
 503   ...
 504   28: .quad 0  # aligned on 8-byte boundary
 505   30: .quad 0  # aligned on 8-byte boundary
 506   38: .quad 0  # aligned on 8-byte boundary
 507     */
 508
 509     {
 510         int i = 0;
 511         char *c;
 512
 513         // determine whether we have 6 or more integer arguments,
 514         // and therefore need to flush one to the stack.
 515         for (c = typeString; *c != '\0'; c++) {
 516             if (*c != 'f' && *c != 'd') i++;
 517             if (i == 6) break;
 518         }
 519
 520         if (i < 6) {
 521             adjustor = allocateExec(0x30,&code);
 522
 523             *(StgInt32 *)adjustor        = 0x49c1894d;
 524             *(StgInt32 *)(adjustor+0x4)  = 0x8948c889;
 525             *(StgInt32 *)(adjustor+0x8)  = 0xf28948d1;
 526             *(StgInt32 *)(adjustor+0xc)  = 0x48fe8948;
 527             *(StgInt32 *)(adjustor+0x10) = 0x000a3d8b;
 528             *(StgInt32 *)(adjustor+0x14) = 0x25ff0000;
 529             *(StgInt32 *)(adjustor+0x18) = 0x0000000c;
 530             *(StgInt64 *)(adjustor+0x20) = (StgInt64)hptr;
 531             *(StgInt64 *)(adjustor+0x28) = (StgInt64)wptr;
 532         }
 533         else
 534         {
 535             adjustor = allocateExec(0x40,&code);
 536
 537             *(StgInt32 *)adjustor        = 0x35ff5141;
 538             *(StgInt32 *)(adjustor+0x4)  = 0x00000020;
 539             *(StgInt32 *)(adjustor+0x8)  = 0x49c1894d;
 540             *(StgInt32 *)(adjustor+0xc)  = 0x8948c889;
 541             *(StgInt32 *)(adjustor+0x10) = 0xf28948d1;
 542             *(StgInt32 *)(adjustor+0x14) = 0x48fe8948;
 543             *(StgInt32 *)(adjustor+0x18) = 0x00123d8b;
 544             *(StgInt32 *)(adjustor+0x1c) = 0x25ff0000;
 545             *(StgInt32 *)(adjustor+0x20) = 0x00000014;
 546
 547             *(StgInt64 *)(adjustor+0x28) = (StgInt64)obscure_ccall_ret_code;
 548             *(StgInt64 *)(adjustor+0x30) = (StgInt64)hptr;
 549             *(StgInt64 *)(adjustor+0x38) = (StgInt64)wptr;
 550         }
 551     }
 552 #elif defined(sparc_HOST_ARCH)
 553   /* Magic constant computed by inspecting the code length of the following
 554      assembly language snippet (offset and machine code prefixed):
 555
 556      <00>: 9C23A008   sub   %sp, 8, %sp         ! make room for %o4/%o5 in caller's frame
 557      <04>: DA23A060   st    %o5, [%sp + 96]     ! shift registers by 2 positions
 558      <08>: D823A05C   st    %o4, [%sp + 92]
 559      <0C>: 9A10000B   mov   %o3, %o5
 560      <10>: 9810000A   mov   %o2, %o4
 561      <14>: 96100009   mov   %o1, %o3
 562      <18>: 94100008   mov   %o0, %o2
 563      <1C>: 13000000   sethi %hi(wptr), %o1      ! load up wptr (1 of 2)
 564      <20>: 11000000   sethi %hi(hptr), %o0      ! load up hptr (1 of 2)
 565      <24>: 81C26000   jmp   %o1 + %lo(wptr)     ! jump to wptr (load 2 of 2)
 566      <28>: 90122000   or    %o0, %lo(hptr), %o0 ! load up hptr (2 of 2, delay slot)
 567      <2C>  00000000                             ! place for getting hptr back easily
 568
 569      ccall'ing on SPARC is easy, because we are quite lucky to push a
 570      multiple of 8 bytes (1 word hptr + 1 word dummy arg) in front of the
 571      existing arguments (note that %sp must stay double-word aligned at
 572      all times, see ABI spec at http://www.sparc.org/standards/psABI3rd.pdf).
 573      To do this, we extend the *caller's* stack frame by 2 words and shift
 574      the output registers used for argument passing (%o0 - %o5, we are a *leaf*
 575      procedure because of the tail-jump) by 2 positions. This makes room in
 576      %o0 and %o1 for the additinal arguments, namely  hptr and a dummy (used
 577      for destination addr of jump on SPARC, return address on x86, ...). This
 578      shouldn't cause any problems for a C-like caller: alloca is implemented
 579      similarly, and local variables should be accessed via %fp, not %sp. In a
 580      nutshell: This should work! (Famous last words! :-)
 581   */
 582     adjustor = allocateExec(4*(11+1),&code);
 583     {
 584         unsigned long *const adj_code = (unsigned long *)adjustor;
 585
 586         adj_code[ 0]  = 0x9C23A008UL;   /* sub   %sp, 8, %sp         */
 587         adj_code[ 1]  = 0xDA23A060UL;   /* st    %o5, [%sp + 96]     */
 588         adj_code[ 2]  = 0xD823A05CUL;   /* st    %o4, [%sp + 92]     */
 589         adj_code[ 3]  = 0x9A10000BUL;   /* mov   %o3, %o5            */
 590         adj_code[ 4]  = 0x9810000AUL;   /* mov   %o2, %o4            */
 591         adj_code[ 5]  = 0x96100009UL;   /* mov   %o1, %o3            */
 592         adj_code[ 6]  = 0x94100008UL;   /* mov   %o0, %o2            */
 593         adj_code[ 7]  = 0x13000000UL;   /* sethi %hi(wptr), %o1      */
 594         adj_code[ 7] |= ((unsigned long)wptr) >> 10;
 595         adj_code[ 8]  = 0x11000000UL;   /* sethi %hi(hptr), %o0      */
 596         adj_code[ 8] |= ((unsigned long)hptr) >> 10;
 597         adj_code[ 9]  = 0x81C26000UL;   /* jmp   %o1 + %lo(wptr)     */
 598         adj_code[ 9] |= ((unsigned long)wptr) & 0x000003FFUL;
 599         adj_code[10]  = 0x90122000UL;   /* or    %o0, %lo(hptr), %o0 */
 600         adj_code[10] |= ((unsigned long)hptr) & 0x000003FFUL;
 601
 602         adj_code[11]  = (unsigned long)hptr;
 603
 604         /* flush cache */
 605         asm("flush %0" : : "r" (adj_code     ));
 606         asm("flush %0" : : "r" (adj_code +  2));
 607         asm("flush %0" : : "r" (adj_code +  4));
 608         asm("flush %0" : : "r" (adj_code +  6));
 609         asm("flush %0" : : "r" (adj_code + 10));
 610
 611         /* max. 5 instructions latency, and we need at >= 1 for returning */
 612         asm("nop");
 613         asm("nop");
 614         asm("nop");
 615         asm("nop");
 616     }
 617 #elif defined(alpha_HOST_ARCH)
 618   /* Magic constant computed by inspecting the code length of
 619      the following assembly language snippet
 620      (offset and machine code prefixed; note that the machine code
 621      shown is longwords stored in little-endian order):
 622
 623   <00>: 46520414        mov     a2, a4
 624   <04>: 46100412        mov     a0, a2
 625   <08>: a61b0020        ldq     a0, 0x20(pv)    # load up hptr
 626   <0c>: 46730415        mov     a3, a5
 627   <10>: a77b0028        ldq     pv, 0x28(pv)    # load up wptr
 628   <14>: 46310413        mov     a1, a3
 629   <18>: 6bfb----        jmp     (pv), <hint>    # jump to wptr (with hint)
 630   <1c>: 00000000                                # padding for alignment
 631   <20>: [8 bytes for hptr quadword]
 632   <28>: [8 bytes for wptr quadword]
 633
 634      The "computed" jump at <08> above is really a jump to a fixed
 635      location.  Accordingly, we place an always-correct hint in the
 636      jump instruction, namely the address offset from <0c> to wptr,
 637      divided by 4, taking the lowest 14 bits.
 638
 639      We only support passing 4 or fewer argument words, for the same
 640      reason described under sparc_HOST_ARCH above by JRS, 21 Aug 01.
 641      On the Alpha the first 6 integer arguments are in a0 through a5,
 642      and the rest on the stack.  Hence we want to shuffle the original
 643      caller's arguments by two.
 644
 645      On the Alpha the calling convention is so complex and dependent
 646      on the callee's signature -- for example, the stack pointer has
 647      to be a multiple of 16 -- that it seems impossible to me [ccshan]
 648      to handle the general case correctly without changing how the
 649      adjustor is called from C.  For now, our solution of shuffling
 650      registers only and ignoring the stack only works if the original
 651      caller passed 4 or fewer argument words.
 652
 653 TODO: Depending on how much allocation overhead stgMallocBytes uses for
 654       header information (more precisely, if the overhead is no more than
 655       4 bytes), we should move the first three instructions above down by
 656       4 bytes (getting rid of the nop), hence saving memory. [ccshan]
 657   */
 658     ASSERT(((StgWord64)wptr & 3) == 0);
 659     adjustor = allocateExec(48,&code);
 660     {
 661         StgWord64 *const code = (StgWord64 *)adjustor;
 662
 663         code[0] = 0x4610041246520414L;
 664         code[1] = 0x46730415a61b0020L;
 665         code[2] = 0x46310413a77b0028L;
 666         code[3] = 0x000000006bfb0000L
 667                 | (((StgWord32*)(wptr) - (StgWord32*)(code) - 3) & 0x3fff);
 668
 669         code[4] = (StgWord64)hptr;
 670         code[5] = (StgWord64)wptr;
 671
 672         /* Ensure that instruction cache is consistent with our new code */
 673         __asm__ volatile("call_pal %0" : : "i" (PAL_imb));
 674     }
 675 #elif defined(powerpc_HOST_ARCH) && defined(linux_HOST_OS)
 676
 677 #define OP_LO(op,lo)  ((((unsigned)(op)) << 16) | (((unsigned)(lo)) & 0xFFFF))
 678 #define OP_HI(op,hi)  ((((unsigned)(op)) << 16) | (((unsigned)(hi)) >> 16))
 679     {
 680         /* The PowerPC Linux (32-bit) calling convention is annoyingly complex.
 681            We need to calculate all the details of the stack frame layout,
 682            taking into account the types of all the arguments, and then
 683            generate code on the fly. */
 684
 685         int src_gpr = 3, dst_gpr = 5;
 686         int fpr = 3;
 687         int src_offset = 0, dst_offset = 0;
 688         int n = strlen(typeString),i;
 689         int src_locs[n], dst_locs[n];
 690         int frameSize;
 691         unsigned *code;
 692
 693             /* Step 1:
 694                Calculate where the arguments should go.
 695                src_locs[] will contain the locations of the arguments in the
 696                original stack frame passed to the adjustor.
 697                dst_locs[] will contain the locations of the arguments after the
 698                adjustor runs, on entry to the wrapper proc pointed to by wptr.
 699
 700                This algorithm is based on the one described on page 3-19 of the
 701                System V ABI PowerPC Processor Supplement.
 702             */
 703         for(i=0;typeString[i];i++)
 704         {
 705             char t = typeString[i];
 706             if((t == 'f' || t == 'd') && fpr <= 8)
 707                 src_locs[i] = dst_locs[i] = -32-(fpr++);
 708             else
 709             {
 710                 if((t == 'l' || t == 'L') && src_gpr <= 9)
 711                 {
 712                     if((src_gpr & 1) == 0)
 713                         src_gpr++;
 714                     src_locs[i] = -src_gpr;
 715                     src_gpr += 2;
 716                 }
 717                 else if((t == 'w' || t == 'W') && src_gpr <= 10)
 718                 {
 719                     src_locs[i] = -(src_gpr++);
 720                 }
 721                 else
 722                 {
 723                     if(t == 'l' || t == 'L' || t == 'd')
 724                     {
 725                         if(src_offset % 8)
 726                             src_offset += 4;
 727                     }
 728                     src_locs[i] = src_offset;
 729                     src_offset += (t == 'l' || t == 'L' || t == 'd') ? 8 : 4;
 730                 }
 731
 732                     if((t == 'l' || t == 'L') && dst_gpr <= 9)
 733                 {
 734                     if((dst_gpr & 1) == 0)
 735                         dst_gpr++;
 736                     dst_locs[i] = -dst_gpr;
 737                     dst_gpr += 2;
 738                 }
 739                 else if((t == 'w' || t == 'W') && dst_gpr <= 10)
 740                 {
 741                     dst_locs[i] = -(dst_gpr++);
 742                 }
 743                 else
 744                 {
 745                     if(t == 'l' || t == 'L' || t == 'd')
 746                     {
 747                         if(dst_offset % 8)
 748                             dst_offset += 4;
 749                     }
 750                     dst_locs[i] = dst_offset;
 751                     dst_offset += (t == 'l' || t == 'L' || t == 'd') ? 8 : 4;
 752                 }
 753             }
 754         }
 755
 756         frameSize = dst_offset + 8;
 757         frameSize = (frameSize+15) & ~0xF;
 758
 759             /* Step 2:
 760                Build the adjustor.
 761             */
 762                     // allocate space for at most 4 insns per parameter
 763                     // plus 14 more instructions.
 764         adjustor = allocateExec(4 * (4*n + 14),&code);
 765         code = (unsigned*)adjustor;
 766
 767         *code++ = 0x48000008; // b *+8
 768             // * Put the hptr in a place where freeHaskellFunctionPtr
 769             //   can get at it.
 770         *code++ = (unsigned) hptr;
 771
 772             // * save the link register
 773         *code++ = 0x7c0802a6; // mflr r0;
 774         *code++ = 0x90010004; // stw r0, 4(r1);
 775             // * and build a new stack frame
 776         *code++ = OP_LO(0x9421, -frameSize); // stwu r1, -frameSize(r1)
 777
 778             // * now generate instructions to copy arguments
 779             //   from the old stack frame into the new stack frame.
 780         for(i=n-1;i>=0;i--)
 781         {
 782             if(src_locs[i] < -32)
 783                 ASSERT(dst_locs[i] == src_locs[i]);
 784             else if(src_locs[i] < 0)
 785             {
 786                 // source in GPR.
 787                 ASSERT(typeString[i] != 'f' && typeString[i] != 'd');
 788                 if(dst_locs[i] < 0)
 789                 {
 790                     ASSERT(dst_locs[i] > -32);
 791                         // dst is in GPR, too.
 792
 793                     if(typeString[i] == 'l' || typeString[i] == 'L')
 794                     {
 795                             // mr dst+1, src+1
 796                         *code++ = 0x7c000378
 797                                 | ((-dst_locs[i]+1) << 16)
 798                                 | ((-src_locs[i]+1) << 11)
 799                                 | ((-src_locs[i]+1) << 21);
 800                     }
 801                     // mr dst, src
 802                     *code++ = 0x7c000378
 803                             | ((-dst_locs[i]) << 16)
 804                             | ((-src_locs[i]) << 11)
 805                             | ((-src_locs[i]) << 21);
 806                 }
 807                 else
 808                 {
 809                     if(typeString[i] == 'l' || typeString[i] == 'L')
 810                     {
 811                             // stw src+1, dst_offset+4(r1)
 812                         *code++ = 0x90010000
 813                                 | ((-src_locs[i]+1) << 21)
 814                                 | (dst_locs[i] + 4);
 815                     }
 816
 817                         // stw src, dst_offset(r1)
 818                     *code++ = 0x90010000
 819                             | ((-src_locs[i]) << 21)
 820                             | (dst_locs[i] + 8);
 821                 }
 822             }
 823             else
 824             {
 825                 ASSERT(dst_locs[i] >= 0);
 826                 ASSERT(typeString[i] != 'f' && typeString[i] != 'd');
 827
 828                 if(typeString[i] == 'l' || typeString[i] == 'L')
 829                 {
 830                     // lwz r0, src_offset(r1)
 831                         *code++ = 0x80010000
 832                                 | (src_locs[i] + frameSize + 8 + 4);
 833                     // stw r0, dst_offset(r1)
 834                         *code++ = 0x90010000
 835                                 | (dst_locs[i] + 8 + 4);
 836                     }
 837                 // lwz r0, src_offset(r1)
 838                     *code++ = 0x80010000
 839                             | (src_locs[i] + frameSize + 8);
 840                 // stw r0, dst_offset(r1)
 841                     *code++ = 0x90010000
 842                             | (dst_locs[i] + 8);
 843            }
 844         }
 845
 846             // * hptr will be the new first argument.
 847             // lis r3, hi(hptr)
 848         *code++ = OP_HI(0x3c60, hptr);
 849             // ori r3,r3,lo(hptr)
 850         *code++ = OP_LO(0x6063, hptr);
 851
 852             // * we need to return to a piece of code
 853             //   which will tear down the stack frame.
 854             // lis r11,hi(obscure_ccall_ret_code)
 855         *code++ = OP_HI(0x3d60, obscure_ccall_ret_code);
 856             // ori r11,r11,lo(obscure_ccall_ret_code)
 857         *code++ = OP_LO(0x616b, obscure_ccall_ret_code);
 858             // mtlr r11
 859         *code++ = 0x7d6803a6;
 860
 861             // * jump to wptr
 862             // lis r11,hi(wptr)
 863         *code++ = OP_HI(0x3d60, wptr);
 864             // ori r11,r11,lo(wptr)
 865         *code++ = OP_LO(0x616b, wptr);
 866             // mtctr r11
 867         *code++ = 0x7d6903a6;
 868             // bctr
 869         *code++ = 0x4e800420;
 870
 871         // Flush the Instruction cache:
 872         {
 873             unsigned *p = adjustor;
 874             while(p < code)
 875             {
 876                 __asm__ volatile ("dcbf 0,%0\n\tsync\n\ticbi 0,%0"
 877                                  : : "r" (p));
 878                 p++;
 879             }
 880             __asm__ volatile ("sync\n\tisync");
 881         }
 882     }
 883
 884 #elif defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH)
 885
 886 #define OP_LO(op,lo)  ((((unsigned)(op)) << 16) | (((unsigned)(lo)) & 0xFFFF))
 887 #define OP_HI(op,hi)  ((((unsigned)(op)) << 16) | (((unsigned)(hi)) >> 16))
 888     {
 889         /* The following code applies to all PowerPC and PowerPC64 platforms
 890            whose stack layout is based on the AIX ABI.
 891
 892            Besides (obviously) AIX, this includes
 893             Mac OS 9 and BeOS/PPC (may they rest in peace),
 894                 which use the 32-bit AIX ABI
 895             powerpc64-linux,
 896                 which uses the 64-bit AIX ABI
 897             and Darwin (Mac OS X),
 898                 which uses the same stack layout as AIX,
 899                 but no function descriptors.
 900
 901            The actual stack-frame shuffling is implemented out-of-line
 902            in the function adjustorCode, in AdjustorAsm.S.
 903            Here, we set up an AdjustorStub structure, which
 904            is a function descriptor (on platforms that have function
 905            descriptors) or a short piece of stub code (on Darwin) to call
 906            adjustorCode with a pointer to the AdjustorStub struct loaded
 907            into register r2.
 908
 909            One nice thing about this is that there is _no_ code generated at
 910            runtime on the platforms that have function descriptors.
 911         */
 912         AdjustorStub *adjustorStub;
 913         int sz = 0, extra_sz, total_sz;
 914
 915             // from AdjustorAsm.s
 916             // not declared as a function so that AIX-style
 917             // fundescs can never get in the way.
 918         extern void *adjustorCode;
 919
 920 #ifdef FUNDESCS
 921         adjustorStub = stgMallocBytes(sizeof(AdjustorStub), "createAdjustor");
 922 #else
 923         adjustorStub = allocateExec(sizeof(AdjustorStub),&code);
 924 #endif
 925         adjustor = adjustorStub;
 926
 927         adjustorStub->code = (void*) &adjustorCode;
 928
 929 #ifdef FUNDESCS
 930             // function descriptors are a cool idea.
 931             // We don't need to generate any code at runtime.
 932         adjustorStub->toc = adjustorStub;
 933 #else
 934
 935             // no function descriptors :-(
 936             // We need to do things "by hand".
 937 #if defined(powerpc_HOST_ARCH)
 938             // lis  r2, hi(adjustorStub)
 939         adjustorStub->lis = OP_HI(0x3c40, adjustorStub);
 940             // ori  r2, r2, lo(adjustorStub)
 941         adjustorStub->ori = OP_LO(0x6042, adjustorStub);
 942             // lwz r0, code(r2)
 943         adjustorStub->lwz = OP_LO(0x8002, (char*)(&adjustorStub->code)
 944                                         - (char*)adjustorStub);
 945             // mtctr r0
 946         adjustorStub->mtctr = 0x7c0903a6;
 947             // bctr
 948         adjustorStub->bctr = 0x4e800420;
 949 #else
 950         barf("adjustor creation not supported on this platform");
 951 #endif
 952
 953         // Flush the Instruction cache:
 954         {
 955             int n = sizeof(AdjustorStub)/sizeof(unsigned);
 956             unsigned *p = (unsigned*)adjustor;
 957             while(n--)
 958             {
 959                 __asm__ volatile ("dcbf 0,%0\n\tsync\n\ticbi 0,%0"
 960                                     : : "r" (p));
 961                 p++;
 962             }
 963             __asm__ volatile ("sync\n\tisync");
 964         }
 965 #endif
 966
 967             // Calculate the size of the stack frame, in words.
 968         sz = totalArgumentSize(typeString);
 969
 970             // The first eight words of the parameter area
 971             // are just "backing store" for the parameters passed in
 972             // the GPRs. extra_sz is the number of words beyond those first
 973             // 8 words.
 974         extra_sz = sz - 8;
 975         if(extra_sz < 0)
 976             extra_sz = 0;
 977
 978             // Calculate the total size of the stack frame.
 979         total_sz = (6 /* linkage area */
 980                   + 8 /* minimum parameter area */
 981                   + 2 /* two extra arguments */
 982                   + extra_sz)*sizeof(StgWord);
 983
 984             // align to 16 bytes.
 985             // AIX only requires 8 bytes, but who cares?
 986         total_sz = (total_sz+15) & ~0xF;
 987
 988             // Fill in the information that adjustorCode in AdjustorAsm.S
 989             // will use to create a new stack frame with the additional args.
 990         adjustorStub->hptr = hptr;
 991         adjustorStub->wptr = wptr;
 992         adjustorStub->negative_framesize = -total_sz;
 993         adjustorStub->extrawords_plus_one = extra_sz + 1;
 994     }
 995
 996 #elif defined(ia64_HOST_ARCH)
 997 /*
 998     Up to 8 inputs are passed in registers.  We flush the last two inputs to
 999     the stack, initially into the 16-byte scratch region left by the caller.
1000     We then shuffle the others along by 4 (taking 2 registers for ourselves
1001     to save return address and previous function state - we need to come back
1002     here on the way out to restore the stack, so this is a real function
1003     rather than just a trampoline).
1004
1005     The function descriptor we create contains the gp of the target function
1006     so gp is already loaded correctly.
1007
1008         [MLX]       alloc r16=ar.pfs,10,2,0
1009                     movl r17=wptr
1010         [MII]       st8.spill [r12]=r38,8               // spill in6 (out4)
1011                     mov r41=r37                         // out7 = in5 (out3)
1012                     mov r40=r36;;                       // out6 = in4 (out2)
1013         [MII]       st8.spill [r12]=r39                 // spill in7 (out5)
1014                     mov.sptk b6=r17,50
1015                     mov r38=r34;;                       // out4 = in2 (out0)
1016         [MII]       mov r39=r35                         // out5 = in3 (out1)
1017                     mov r37=r33                         // out3 = in1 (loc1)
1018                     mov r36=r32                         // out2 = in0 (loc0)
1019         [MLX]       adds r12=-24,r12                    // update sp
1020                     movl r34=hptr;;                     // out0 = hptr
1021         [MIB]       mov r33=r16                         // loc1 = ar.pfs
1022                     mov r32=b0                          // loc0 = retaddr
1023                     br.call.sptk.many b0=b6;;
1024
1025         [MII]       adds r12=-16,r12
1026                     mov b0=r32
1027                     mov.i ar.pfs=r33
1028         [MFB]       nop.m 0x0
1029                     nop.f 0x0
1030                     br.ret.sptk.many b0;;
1031 */
1032
1033 /* These macros distribute a long constant into the two words of an MLX bundle */
1034 #define BITS(val,start,count)   (((val) >> (start)) & ((1 << (count))-1))
1035 #define MOVL_LOWORD(val)        (BITS(val,22,18) << 46)
1036 #define MOVL_HIWORD(val)        ( (BITS(val,0,7)    << 36)      \
1037                                 | (BITS(val,7,9)    << 50)      \
1038                                 | (BITS(val,16,5)   << 45)      \
1039                                 | (BITS(val,21,1)   << 44)      \
1040                                 | (BITS(val,40,23))             \
1041                                 | (BITS(val,63,1)    << 59))
1042
1043     {
1044         StgStablePtr stable;
1045         IA64FunDesc *wdesc = (IA64FunDesc *)wptr;
1046         StgWord64 wcode = wdesc->ip;
1047         IA64FunDesc *fdesc;
1048         StgWord64 *code;
1049
1050         /* we allocate on the Haskell heap since malloc'd memory isn't
1051          * executable - argh */
1052         /* Allocated memory is word-aligned (8 bytes) but functions on ia64
1053          * must be aligned to 16 bytes.  We allocate an extra 8 bytes of
1054          * wiggle room so that we can put the code on a 16 byte boundary. */
1055         adjustor = stgAllocStable(sizeof(IA64FunDesc)+18*8+8, &stable);
1056
1057         fdesc = (IA64FunDesc *)adjustor;
1058         code = (StgWord64 *)(fdesc + 1);
1059         /* add 8 bytes to code if needed to align to a 16-byte boundary */
1060         if ((StgWord64)code & 15) code++;
1061         fdesc->ip = (StgWord64)code;
1062         fdesc->gp = wdesc->gp;
1063
1064         code[0]  = 0x0000058004288004 | MOVL_LOWORD(wcode);
1065         code[1]  = 0x6000000220000000 | MOVL_HIWORD(wcode);
1066         code[2]  = 0x029015d818984001;
1067         code[3]  = 0x8401200500420094;
1068         code[4]  = 0x886011d8189c0001;
1069         code[5]  = 0x84011004c00380c0;
1070         code[6]  = 0x0250210046013800;
1071         code[7]  = 0x8401000480420084;
1072         code[8]  = 0x0000233f19a06005 | MOVL_LOWORD((StgWord64)hptr);
1073         code[9]  = 0x6000000440000000 | MOVL_HIWORD((StgWord64)hptr);
1074         code[10] = 0x0200210020010811;
1075         code[11] = 0x1080006800006200;
1076         code[12] = 0x0000210018406000;
1077         code[13] = 0x00aa021000038005;
1078         code[14] = 0x000000010000001d;
1079         code[15] = 0x0084000880000200;
1080
1081         /* save stable pointers in convenient form */
1082         code[16] = (StgWord64)hptr;
1083         code[17] = (StgWord64)stable;
1084     }
1085 #else
1086     barf("adjustor creation not supported on this platform");
1087 #endif
1088     break;
1089
1090   default:
1091     ASSERT(0);
1092     break;
1093   }
1094
1095   /* Have fun! */
1096   return code;
1097 }
1098
1099
1100 void
1101 freeHaskellFunctionPtr(void* ptr)
1102 {
1103 #if defined(i386_HOST_ARCH) && !defined(darwin_HOST_OS)
1104  if ( *(unsigned char*)ptr != 0x68 &&
1105       *(unsigned char*)ptr != 0x58 ) {
1106    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1107    return;
1108  }
1109
1110  /* Free the stable pointer first..*/
1111  if (*(unsigned char*)ptr == 0x68) { /* Aha, a ccall adjustor! */
1112     freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x01)));
1113  } else {
1114     freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x02)));
1115  }
1116 #elif defined(i386_HOST_ARCH) && defined(darwin_HOST_OS)
1117 if ( *(unsigned char*)ptr != 0xe8 ) {
1118    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1119    return;
1120  }
1121  freeStablePtr(((AdjustorStub*)ptr)->hptr);
1122 #elif defined(x86_64_HOST_ARCH)
1123  if ( *(StgWord16 *)ptr == 0x894d ) {
1124      freeStablePtr(*(StgStablePtr*)(ptr+0x20));
1125  } else if ( *(StgWord16 *)ptr == 0x5141 ) {
1126      freeStablePtr(*(StgStablePtr*)(ptr+0x30));
1127  } else {
1128    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1129    return;
1130  }
1131 #elif defined(sparc_HOST_ARCH)
1132  if ( *(unsigned long*)ptr != 0x9C23A008UL ) {
1133    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1134    return;
1135  }
1136
1137  /* Free the stable pointer first..*/
1138  freeStablePtr(*((StgStablePtr*)((unsigned long*)ptr + 11)));
1139 #elif defined(alpha_HOST_ARCH)
1140  if ( *(StgWord64*)ptr != 0xa77b0018a61b0010L ) {
1141    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1142    return;
1143  }
1144
1145  /* Free the stable pointer first..*/
1146  freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x10)));
1147 #elif defined(powerpc_HOST_ARCH) && defined(linux_HOST_OS)
1148  if ( *(StgWord*)ptr != 0x48000008 ) {
1149    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1150    return;
1151  }
1152  freeStablePtr(((StgStablePtr*)ptr)[1]);
1153 #elif defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH)
1154  extern void* adjustorCode;
1155  if ( ((AdjustorStub*)ptr)->code != (StgFunPtr) &adjustorCode ) {
1156    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1157    return;
1158  }
1159  freeStablePtr(((AdjustorStub*)ptr)->hptr);
1160 #elif defined(ia64_HOST_ARCH)
1161  IA64FunDesc *fdesc = (IA64FunDesc *)ptr;
1162  StgWord64 *code = (StgWord64 *)(fdesc+1);
1163
1164  if (fdesc->ip != (StgWord64)code) {
1165    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1166    return;
1167  }
1168  freeStablePtr((StgStablePtr)code[16]);
1169  freeStablePtr((StgStablePtr)code[17]);
1170  return;
1171 #else
1172  ASSERT(0);
1173 #endif
1174  // Can't write to this memory, it is only executable:
1175  // *((unsigned char*)ptr) = '\0';
1176
1177  freeExec(ptr);
1178 }
1179
1180 #endif // !USE_LIBFFI_FOR_ADJUSTORS