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